[platform/upstream/gcc.git] / gcc / ada / exp_util.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ U T I L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2013, 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.      --
--                                                                          --
------------------------------------------------------------------------------

with Aspects;  use Aspects;
with Atree;    use Atree;
with Casing;   use Casing;
with Checks;   use Checks;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Errout;   use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6;  use Exp_Ch6;
with Exp_Ch7;  use Exp_Ch7;
with Inline;   use Inline;
with Itypes;   use Itypes;
with Lib;      use Lib;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;      use Opt;
with Restrict; use Restrict;
with Rident;   use Rident;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
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 Stringt;  use Stringt;
with Targparm; use Targparm;
with Tbuild;   use Tbuild;
with Ttypes;   use Ttypes;
with Urealp;   use Urealp;
with Validsw;  use Validsw;

package body Exp_Util is

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Build_Task_Array_Image
     (Loc    : Source_Ptr;
      Id_Ref : Node_Id;
      A_Type : Entity_Id;
      Dyn    : Boolean := False) return Node_Id;
   --  Build function to generate the image string for a task that is an array
   --  component, concatenating the images of each index. To avoid storage
   --  leaks, the string is built with successive slice assignments. The flag
   --  Dyn indicates whether this is called for the initialization procedure of
   --  an array of tasks, or for the name of a dynamically created task that is
   --  assigned to an indexed component.

   function Build_Task_Image_Function
     (Loc   : Source_Ptr;
      Decls : List_Id;
      Stats : List_Id;
      Res   : Entity_Id) return Node_Id;
   --  Common processing for Task_Array_Image and Task_Record_Image. Build
   --  function body that computes image.

   procedure Build_Task_Image_Prefix
      (Loc    : Source_Ptr;
       Len    : out Entity_Id;
       Res    : out Entity_Id;
       Pos    : out Entity_Id;
       Prefix : Entity_Id;
       Sum    : Node_Id;
       Decls  : List_Id;
       Stats  : List_Id);
   --  Common processing for Task_Array_Image and Task_Record_Image. Create
   --  local variables and assign prefix of name to result string.

   function Build_Task_Record_Image
     (Loc    : Source_Ptr;
      Id_Ref : Node_Id;
      Dyn    : Boolean := False) return Node_Id;
   --  Build function to generate the image string for a task that is a record
   --  component. Concatenate name of variable with that of selector. The flag
   --  Dyn indicates whether this is called for the initialization procedure of
   --  record with task components, or for a dynamically created task that is
   --  assigned to a selected component.

   function Make_CW_Equivalent_Type
     (T : Entity_Id;
      E : Node_Id) return Entity_Id;
   --  T is a class-wide type entity, E is the initial expression node that
   --  constrains T in case such as: " X: T := E" or "new T'(E)". This function
   --  returns the entity of the Equivalent type and inserts on the fly the
   --  necessary declaration such as:
   --
   --    type anon is record
   --       _parent : Root_Type (T); constrained with E discriminants (if any)
   --       Extension : String (1 .. expr to match size of E);
   --    end record;
   --
   --  This record is compatible with any object of the class of T thanks to
   --  the first field and has the same size as E thanks to the second.

   function Make_Literal_Range
     (Loc         : Source_Ptr;
      Literal_Typ : Entity_Id) return Node_Id;
   --  Produce a Range node whose bounds are:
   --    Low_Bound (Literal_Type) ..
   --        Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
   --  this is used for expanding declarations like X : String := "sdfgdfg";
   --
   --  If the index type of the target array is not integer, we generate:
   --     Low_Bound (Literal_Type) ..
   --        Literal_Type'Val
   --          (Literal_Type'Pos (Low_Bound (Literal_Type))
   --             + (Length (Literal_Typ) -1))

   function Make_Non_Empty_Check
     (Loc : Source_Ptr;
      N   : Node_Id) return Node_Id;
   --  Produce a boolean expression checking that the unidimensional array
   --  node N is not empty.

   function New_Class_Wide_Subtype
     (CW_Typ : Entity_Id;
      N      : Node_Id) return Entity_Id;
   --  Create an implicit subtype of CW_Typ attached to node N

   function Requires_Cleanup_Actions
     (L                 : List_Id;
      Lib_Level         : Boolean;
      Nested_Constructs : Boolean) return Boolean;
   --  Given a list L, determine whether it contains one of the following:
   --
   --    1) controlled objects
   --    2) library-level tagged types
   --
   --  Lib_Level is True when the list comes from a construct at the library
   --  level, and False otherwise. Nested_Constructs is True when any nested
   --  packages declared in L must be processed, and False otherwise.

   -------------------------------------
   -- Activate_Atomic_Synchronization --
   -------------------------------------

   procedure Activate_Atomic_Synchronization (N : Node_Id) is
      Msg_Node : Node_Id;

   begin
      case Nkind (Parent (N)) is

         --  Check for cases of appearing in the prefix of a construct where
         --  we don't need atomic synchronization for this kind of usage.

         when
              --  Nothing to do if we are the prefix of an attribute, since we
              --  do not want an atomic sync operation for things like 'Size.

              N_Attribute_Reference |

              --  The N_Reference node is like an attribute

              N_Reference           |

              --  Nothing to do for a reference to a component (or components)
              --  of a composite object. Only reads and updates of the object
              --  as a whole require atomic synchronization (RM C.6 (15)).

              N_Indexed_Component   |
              N_Selected_Component  |
              N_Slice               =>

            --  For all the above cases, nothing to do if we are the prefix

            if Prefix (Parent (N)) = N then
               return;
            end if;

         when others => null;
      end case;

      --  Go ahead and set the flag

      Set_Atomic_Sync_Required (N);

      --  Generate info message if requested

      if Warn_On_Atomic_Synchronization then
         case Nkind (N) is
            when N_Identifier =>
               Msg_Node := N;

            when N_Selected_Component | N_Expanded_Name =>
               Msg_Node := Selector_Name (N);

            when N_Explicit_Dereference | N_Indexed_Component =>
               Msg_Node := Empty;

            when others =>
               pragma Assert (False);
               return;
         end case;

         if Present (Msg_Node) then
            Error_Msg_N
              ("?N?info: atomic synchronization set for &", Msg_Node);
         else
            Error_Msg_N
              ("?N?info: atomic synchronization set", N);
         end if;
      end if;
   end Activate_Atomic_Synchronization;

   ----------------------
   -- Adjust_Condition --
   ----------------------

   procedure Adjust_Condition (N : Node_Id) is
   begin
      if No (N) then
         return;
      end if;

      declare
         Loc : constant Source_Ptr := Sloc (N);
         T   : constant Entity_Id  := Etype (N);
         Ti  : Entity_Id;

      begin
         --  Defend against a call where the argument has no type, or has a
         --  type that is not Boolean. This can occur because of prior errors.

         if No (T) or else not Is_Boolean_Type (T) then
            return;
         end if;

         --  Apply validity checking if needed

         if Validity_Checks_On and Validity_Check_Tests then
            Ensure_Valid (N);
         end if;

         --  Immediate return if standard boolean, the most common case,
         --  where nothing needs to be done.

         if Base_Type (T) = Standard_Boolean then
            return;
         end if;

         --  Case of zero/non-zero semantics or non-standard enumeration
         --  representation. In each case, we rewrite the node as:

         --      ityp!(N) /= False'Enum_Rep

         --  where ityp is an integer type with large enough size to hold any
         --  value of type T.

         if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
            if Esize (T) <= Esize (Standard_Integer) then
               Ti := Standard_Integer;
            else
               Ti := Standard_Long_Long_Integer;
            end if;

            Rewrite (N,
              Make_Op_Ne (Loc,
                Left_Opnd  => Unchecked_Convert_To (Ti, N),
                Right_Opnd =>
                  Make_Attribute_Reference (Loc,
                    Attribute_Name => Name_Enum_Rep,
                    Prefix         =>
                      New_Occurrence_Of (First_Literal (T), Loc))));
            Analyze_And_Resolve (N, Standard_Boolean);

         else
            Rewrite (N, Convert_To (Standard_Boolean, N));
            Analyze_And_Resolve (N, Standard_Boolean);
         end if;
      end;
   end Adjust_Condition;

   ------------------------
   -- Adjust_Result_Type --
   ------------------------

   procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
   begin
      --  Ignore call if current type is not Standard.Boolean

      if Etype (N) /= Standard_Boolean then
         return;
      end if;

      --  If result is already of correct type, nothing to do. Note that
      --  this will get the most common case where everything has a type
      --  of Standard.Boolean.

      if Base_Type (T) = Standard_Boolean then
         return;

      else
         declare
            KP : constant Node_Kind := Nkind (Parent (N));

         begin
            --  If result is to be used as a Condition in the syntax, no need
            --  to convert it back, since if it was changed to Standard.Boolean
            --  using Adjust_Condition, that is just fine for this usage.

            if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
               return;

            --  If result is an operand of another logical operation, no need
            --  to reset its type, since Standard.Boolean is just fine, and
            --  such operations always do Adjust_Condition on their operands.

            elsif     KP in N_Op_Boolean
              or else KP in N_Short_Circuit
              or else KP = N_Op_Not
            then
               return;

            --  Otherwise we perform a conversion from the current type, which
            --  must be Standard.Boolean, to the desired type.

            else
               Set_Analyzed (N);
               Rewrite (N, Convert_To (T, N));
               Analyze_And_Resolve (N, T);
            end if;
         end;
      end if;
   end Adjust_Result_Type;

   --------------------------
   -- Append_Freeze_Action --
   --------------------------

   procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
      Fnode : Node_Id;

   begin
      Ensure_Freeze_Node (T);
      Fnode := Freeze_Node (T);

      if No (Actions (Fnode)) then
         Set_Actions (Fnode, New_List (N));
      else
         Append (N, Actions (Fnode));
      end if;

   end Append_Freeze_Action;

   ---------------------------
   -- Append_Freeze_Actions --
   ---------------------------

   procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
      Fnode : Node_Id;

   begin
      if No (L) then
         return;
      end if;

      Ensure_Freeze_Node (T);
      Fnode := Freeze_Node (T);

      if No (Actions (Fnode)) then
         Set_Actions (Fnode, L);
      else
         Append_List (L, Actions (Fnode));
      end if;
   end Append_Freeze_Actions;

   ------------------------------------
   -- Build_Allocate_Deallocate_Proc --
   ------------------------------------

   procedure Build_Allocate_Deallocate_Proc
     (N           : Node_Id;
      Is_Allocate : Boolean)
   is
      Desig_Typ    : Entity_Id;
      Expr         : Node_Id;
      Pool_Id      : Entity_Id;
      Proc_To_Call : Node_Id := Empty;
      Ptr_Typ      : Entity_Id;

      function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
      --  Locate TSS primitive Finalize_Address in type Typ

      function Find_Object (E : Node_Id) return Node_Id;
      --  Given an arbitrary expression of an allocator, try to find an object
      --  reference in it, otherwise return the original expression.

      function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
      --  Determine whether subprogram Subp denotes a custom allocate or
      --  deallocate.

      ---------------------------
      -- Find_Finalize_Address --
      ---------------------------

      function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
         Utyp : Entity_Id := Typ;

      begin
         --  Handle protected class-wide or task class-wide types

         if Is_Class_Wide_Type (Utyp) then
            if Is_Concurrent_Type (Root_Type (Utyp)) then
               Utyp := Root_Type (Utyp);

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

         --  Handle private types

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

         --  Handle protected and task types

         if Is_Concurrent_Type (Utyp)
           and then Present (Corresponding_Record_Type (Utyp))
         then
            Utyp := Corresponding_Record_Type (Utyp);
         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;

         --  When dealing with an internally built full view for a type with
         --  unknown discriminants, use the original record type.

         if Is_Underlying_Record_View (Utyp) then
            Utyp := Etype (Utyp);
         end if;

         return TSS (Utyp, TSS_Finalize_Address);
      end Find_Finalize_Address;

      -----------------
      -- Find_Object --
      -----------------

      function Find_Object (E : Node_Id) return Node_Id is
         Expr : Node_Id;

      begin
         pragma Assert (Is_Allocate);

         Expr := E;
         loop
            if Nkind_In (Expr, N_Qualified_Expression,
                               N_Unchecked_Type_Conversion)
            then
               Expr := Expression (Expr);

            elsif Nkind (Expr) = N_Explicit_Dereference then
               Expr := Prefix (Expr);

            else
               exit;
            end if;
         end loop;

         return Expr;
      end Find_Object;

      ---------------------------------
      -- Is_Allocate_Deallocate_Proc --
      ---------------------------------

      function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
      begin
         --  Look for a subprogram body with only one statement which is a
         --  call to Allocate_Any_Controlled / Deallocate_Any_Controlled.

         if Ekind (Subp) = E_Procedure
           and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
         then
            declare
               HSS  : constant Node_Id :=
                        Handled_Statement_Sequence (Parent (Parent (Subp)));
               Proc : Entity_Id;

            begin
               if Present (Statements (HSS))
                 and then Nkind (First (Statements (HSS))) =
                            N_Procedure_Call_Statement
               then
                  Proc := Entity (Name (First (Statements (HSS))));

                  return
                    Is_RTE (Proc, RE_Allocate_Any_Controlled)
                      or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
               end if;
            end;
         end if;

         return False;
      end Is_Allocate_Deallocate_Proc;

   --  Start of processing for Build_Allocate_Deallocate_Proc

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

      if Alfa_Mode then
         return;
      end if;

      --  Obtain the attributes of the allocation / deallocation

      if Nkind (N) = N_Free_Statement then
         Expr := Expression (N);
         Ptr_Typ := Base_Type (Etype (Expr));
         Proc_To_Call := Procedure_To_Call (N);

      else
         if Nkind (N) = N_Object_Declaration then
            Expr := Expression (N);
         else
            Expr := N;
         end if;

         --  In certain cases an allocator with a qualified expression may
         --  be relocated and used as the initialization expression of a
         --  temporary:

         --    before:
         --       Obj : Ptr_Typ := new Desig_Typ'(...);

         --    after:
         --       Tmp : Ptr_Typ := new Desig_Typ'(...);
         --       Obj : Ptr_Typ := Tmp;

         --  Since the allocator is always marked as analyzed to avoid infinite
         --  expansion, it will never be processed by this routine given that
         --  the designated type needs finalization actions. Detect this case
         --  and complete the expansion of the allocator.

         if Nkind (Expr) = N_Identifier
           and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
           and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
         then
            Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
            return;
         end if;

         --  The allocator may have been rewritten into something else in which
         --  case the expansion performed by this routine does not apply.

         if Nkind (Expr) /= N_Allocator then
            return;
         end if;

         Ptr_Typ := Base_Type (Etype (Expr));
         Proc_To_Call := Procedure_To_Call (Expr);
      end if;

      Pool_Id := Associated_Storage_Pool (Ptr_Typ);
      Desig_Typ := Available_View (Designated_Type (Ptr_Typ));

      --  Handle concurrent types

      if Is_Concurrent_Type (Desig_Typ)
        and then Present (Corresponding_Record_Type (Desig_Typ))
      then
         Desig_Typ := Corresponding_Record_Type (Desig_Typ);
      end if;

      --  Do not process allocations / deallocations without a pool

      if No (Pool_Id) then
         return;

      --  Do not process allocations on / deallocations from the secondary
      --  stack.

      elsif Is_RTE (Pool_Id, RE_SS_Pool) then
         return;

      --  Do not replicate the machinery if the allocator / free has already
      --  been expanded and has a custom Allocate / Deallocate.

      elsif Present (Proc_To_Call)
        and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
      then
         return;
      end if;

      if Needs_Finalization (Desig_Typ) then

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

         if Restriction_Active (No_Finalization) then
            return;

         --  Do nothing if the access type may never allocate / deallocate
         --  objects.

         elsif No_Pool_Assigned (Ptr_Typ) then
            return;

         --  Access-to-controlled types are not supported on .NET/JVM since
         --  these targets cannot support pools and address arithmetic.

         elsif VM_Target /= No_VM then
            return;
         end if;

         --  The allocation / deallocation of a controlled object must be
         --  chained on / detached from a finalization master.

         pragma Assert (Present (Finalization_Master (Ptr_Typ)));

      --  The only other kind of allocation / deallocation supported by this
      --  routine is on / from a subpool.

      elsif Nkind (Expr) = N_Allocator
        and then No (Subpool_Handle_Name (Expr))
      then
         return;
      end if;

      declare
         Loc     : constant Source_Ptr := Sloc (N);
         Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
         Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
         Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
         Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');

         Actuals      : List_Id;
         Fin_Addr_Id  : Entity_Id;
         Fin_Mas_Act  : Node_Id;
         Fin_Mas_Id   : Entity_Id;
         Proc_To_Call : Entity_Id;
         Subpool      : Node_Id := Empty;

      begin
         --  Step 1: Construct all the actuals for the call to library routine
         --  Allocate_Any_Controlled / Deallocate_Any_Controlled.

         --  a) Storage pool

         Actuals := New_List (New_Reference_To (Pool_Id, Loc));

         if Is_Allocate then

            --  b) Subpool

            if Nkind (Expr) = N_Allocator then
               Subpool := Subpool_Handle_Name (Expr);
            end if;

            --  If a subpool is present it can be an arbitrary name, so make
            --  the actual by copying the tree.

            if Present (Subpool) then
               Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
            else
               Append_To (Actuals, Make_Null (Loc));
            end if;

            --  c) Finalization master

            if Needs_Finalization (Desig_Typ) then
               Fin_Mas_Id  := Finalization_Master (Ptr_Typ);
               Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);

               --  Handle the case where the master is actually a pointer to a
               --  master. This case arises in build-in-place functions.

               if Is_Access_Type (Etype (Fin_Mas_Id)) then
                  Append_To (Actuals, Fin_Mas_Act);
               else
                  Append_To (Actuals,
                    Make_Attribute_Reference (Loc,
                      Prefix         => Fin_Mas_Act,
                      Attribute_Name => Name_Unrestricted_Access));
               end if;
            else
               Append_To (Actuals, Make_Null (Loc));
            end if;

            --  d) Finalize_Address

            --  Primitive Finalize_Address is never generated in CodePeer mode
            --  since it contains an Unchecked_Conversion.

            if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
               Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
               pragma Assert (Present (Fin_Addr_Id));

               Append_To (Actuals,
                 Make_Attribute_Reference (Loc,
                   Prefix         => New_Reference_To (Fin_Addr_Id, Loc),
                   Attribute_Name => Name_Unrestricted_Access));
            else
               Append_To (Actuals, Make_Null (Loc));
            end if;
         end if;

         --  e) Address
         --  f) Storage_Size
         --  g) Alignment

         Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
         Append_To (Actuals, New_Reference_To (Size_Id, Loc));

         if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
            Append_To (Actuals, New_Reference_To (Alig_Id, Loc));

         --  For deallocation of class wide types we obtain the value of
         --  alignment from the Type Specific Record of the deallocated object.
         --  This is needed because the frontend expansion of class-wide types
         --  into equivalent types confuses the backend.

         else
            --  Generate:
            --     Obj.all'Alignment

            --  ... because 'Alignment applied to class-wide types is expanded
            --  into the code that reads the value of alignment from the TSD
            --  (see Expand_N_Attribute_Reference)

            Append_To (Actuals,
              Unchecked_Convert_To (RTE (RE_Storage_Offset),
                Make_Attribute_Reference (Loc,
                  Prefix         =>
                    Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
                  Attribute_Name => Name_Alignment)));
         end if;

         --  h) Is_Controlled

         --  Generate a run-time check to determine whether a class-wide object
         --  is truly controlled.

         if Needs_Finalization (Desig_Typ) then
            if Is_Class_Wide_Type (Desig_Typ)
              or else Is_Generic_Actual_Type (Desig_Typ)
            then
               declare
                  Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
                  Flag_Expr : Node_Id;
                  Param     : Node_Id;
                  Temp      : Node_Id;

               begin
                  if Is_Allocate then
                     Temp := Find_Object (Expression (Expr));
                  else
                     Temp := Expr;
                  end if;

                  --  Processing for generic actuals

                  if Is_Generic_Actual_Type (Desig_Typ) then
                     Flag_Expr :=
                       New_Reference_To (Boolean_Literals
                         (Needs_Finalization (Base_Type (Desig_Typ))), Loc);

                  --  Processing for subtype indications

                  elsif Nkind (Temp) in N_Has_Entity
                    and then Is_Type (Entity (Temp))
                  then
                     Flag_Expr :=
                       New_Reference_To (Boolean_Literals
                         (Needs_Finalization (Entity (Temp))), Loc);

                  --  Generate a runtime check to test the controlled state of
                  --  an object for the purposes of allocation / deallocation.

                  else
                     --  The following case arises when allocating through an
                     --  interface class-wide type, generate:
                     --
                     --    Temp.all

                     if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
                        Param :=
                          Make_Explicit_Dereference (Loc,
                            Prefix =>
                              Relocate_Node (Temp));

                     --  Generate:
                     --    Temp'Tag

                     else
                        Param :=
                          Make_Attribute_Reference (Loc,
                            Prefix =>
                              Relocate_Node (Temp),
                            Attribute_Name => Name_Tag);
                     end if;

                     --  Generate:
                     --    Needs_Finalization (<Param>)

                     Flag_Expr :=
                       Make_Function_Call (Loc,
                         Name =>
                           New_Reference_To (RTE (RE_Needs_Finalization), Loc),
                         Parameter_Associations => New_List (Param));
                  end if;

                  --  Create the temporary which represents the finalization
                  --  state of the expression. Generate:
                  --
                  --    F : constant Boolean := <Flag_Expr>;

                  Insert_Action (N,
                    Make_Object_Declaration (Loc,
                      Defining_Identifier => Flag_Id,
                      Constant_Present => True,
                      Object_Definition =>
                        New_Reference_To (Standard_Boolean, Loc),
                      Expression => Flag_Expr));

                  --  The flag acts as the last actual

                  Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
               end;

            --  The object is statically known to be controlled

            else
               Append_To (Actuals, New_Reference_To (Standard_True, Loc));
            end if;

         else
            Append_To (Actuals, New_Reference_To (Standard_False, Loc));
         end if;

         --  i) On_Subpool

         if Is_Allocate then
            Append_To (Actuals,
              New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
         end if;

         --  Step 2: Build a wrapper Allocate / Deallocate which internally
         --  calls Allocate_Any_Controlled / Deallocate_Any_Controlled.

         --  Select the proper routine to call

         if Is_Allocate then
            Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
         else
            Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
         end if;

         --  Create a custom Allocate / Deallocate routine which has identical
         --  profile to that of System.Storage_Pools.

         Insert_Action (N,
           Make_Subprogram_Body (Loc,
             Specification =>

               --  procedure Pnn

               Make_Procedure_Specification (Loc,
                 Defining_Unit_Name => Proc_Id,
                 Parameter_Specifications => New_List (

                  --  P : Root_Storage_Pool

                   Make_Parameter_Specification (Loc,
                     Defining_Identifier => Make_Temporary (Loc, 'P'),
                     Parameter_Type =>
                       New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),

                  --  A : [out] Address

                   Make_Parameter_Specification (Loc,
                     Defining_Identifier => Addr_Id,
                     Out_Present         => Is_Allocate,
                     Parameter_Type      =>
                       New_Reference_To (RTE (RE_Address), Loc)),

                  --  S : Storage_Count

                   Make_Parameter_Specification (Loc,
                     Defining_Identifier => Size_Id,
                     Parameter_Type      =>
                       New_Reference_To (RTE (RE_Storage_Count), Loc)),

                  --  L : Storage_Count

                   Make_Parameter_Specification (Loc,
                     Defining_Identifier => Alig_Id,
                     Parameter_Type      =>
                       New_Reference_To (RTE (RE_Storage_Count), Loc)))),

             Declarations => No_List,

             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements => New_List (
                   Make_Procedure_Call_Statement (Loc,
                     Name => New_Reference_To (Proc_To_Call, Loc),
                     Parameter_Associations => Actuals)))));

         --  The newly generated Allocate / Deallocate becomes the default
         --  procedure to call when the back end processes the allocation /
         --  deallocation.

         if Is_Allocate then
            Set_Procedure_To_Call (Expr, Proc_Id);
         else
            Set_Procedure_To_Call (N, Proc_Id);
         end if;
      end;
   end Build_Allocate_Deallocate_Proc;

   ------------------------
   -- Build_Runtime_Call --
   ------------------------

   function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
   begin
      --  If entity is not available, we can skip making the call (this avoids
      --  junk duplicated error messages in a number of cases).

      if not RTE_Available (RE) then
         return Make_Null_Statement (Loc);
      else
         return
           Make_Procedure_Call_Statement (Loc,
             Name => New_Reference_To (RTE (RE), Loc));
      end if;
   end Build_Runtime_Call;

   ----------------------------
   -- Build_Task_Array_Image --
   ----------------------------

   --  This function generates the body for a function that constructs the
   --  image string for a task that is an array component. The function is
   --  local to the init proc for the array type, and is called for each one
   --  of the components. The constructed image has the form of an indexed
   --  component, whose prefix is the outer variable of the array type.
   --  The n-dimensional array type has known indexes Index, Index2...

   --  Id_Ref is an indexed component form created by the enclosing init proc.
   --  Its successive indexes are Val1, Val2, ... which are the loop variables
   --  in the loops that call the individual task init proc on each component.

   --  The generated function has the following structure:

   --  function F return String is
   --     Pref : string renames Task_Name;
   --     T1   : String := Index1'Image (Val1);
   --     ...
   --     Tn   : String := indexn'image (Valn);
   --     Len  : Integer := T1'Length + ... + Tn'Length + n + 1;
   --     --  Len includes commas and the end parentheses.
   --     Res  : String (1..Len);
   --     Pos  : Integer := Pref'Length;
   --
   --  begin
   --     Res (1 .. Pos) := Pref;
   --     Pos := Pos + 1;
   --     Res (Pos)    := '(';
   --     Pos := Pos + 1;
   --     Res (Pos .. Pos + T1'Length - 1) := T1;
   --     Pos := Pos + T1'Length;
   --     Res (Pos) := '.';
   --     Pos := Pos + 1;
   --     ...
   --     Res (Pos .. Pos + Tn'Length - 1) := Tn;
   --     Res (Len) := ')';
   --
   --     return Res;
   --  end F;
   --
   --  Needless to say, multidimensional arrays of tasks are rare enough that
   --  the bulkiness of this code is not really a concern.

   function Build_Task_Array_Image
     (Loc    : Source_Ptr;
      Id_Ref : Node_Id;
      A_Type : Entity_Id;
      Dyn    : Boolean := False) return Node_Id
   is
      Dims : constant Nat := Number_Dimensions (A_Type);
      --  Number of dimensions for array of tasks

      Temps : array (1 .. Dims) of Entity_Id;
      --  Array of temporaries to hold string for each index

      Indx : Node_Id;
      --  Index expression

      Len : Entity_Id;
      --  Total length of generated name

      Pos : Entity_Id;
      --  Running index for substring assignments

      Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
      --  Name of enclosing variable, prefix of resulting name

      Res : Entity_Id;
      --  String to hold result

      Val : Node_Id;
      --  Value of successive indexes

      Sum : Node_Id;
      --  Expression to compute total size of string

      T : Entity_Id;
      --  Entity for name at one index position

      Decls : constant List_Id := New_List;
      Stats : constant List_Id := New_List;

   begin
      --  For a dynamic task, the name comes from the target variable. For a
      --  static one it is a formal of the enclosing init proc.

      if Dyn then
         Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier => Pref,
             Object_Definition => New_Occurrence_Of (Standard_String, Loc),
             Expression =>
               Make_String_Literal (Loc,
                 Strval => String_From_Name_Buffer)));

      else
         Append_To (Decls,
           Make_Object_Renaming_Declaration (Loc,
             Defining_Identifier => Pref,
             Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
             Name                => Make_Identifier (Loc, Name_uTask_Name)));
      end if;

      Indx := First_Index (A_Type);
      Val  := First (Expressions (Id_Ref));

      for J in 1 .. Dims loop
         T := Make_Temporary (Loc, 'T');
         Temps (J) := T;

         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier => T,
             Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
             Expression          =>
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_Image,
                 Prefix         => New_Occurrence_Of (Etype (Indx), Loc),
                 Expressions    => New_List (New_Copy_Tree (Val)))));

         Next_Index (Indx);
         Next (Val);
      end loop;

      Sum := Make_Integer_Literal (Loc, Dims + 1);

      Sum :=
        Make_Op_Add (Loc,
          Left_Opnd => Sum,
          Right_Opnd =>
            Make_Attribute_Reference (Loc,
              Attribute_Name => Name_Length,
              Prefix         => New_Occurrence_Of (Pref, Loc),
              Expressions    => New_List (Make_Integer_Literal (Loc, 1))));

      for J in 1 .. Dims loop
         Sum :=
           Make_Op_Add (Loc,
             Left_Opnd  => Sum,
             Right_Opnd =>
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_Length,
                 Prefix         =>
                  New_Occurrence_Of (Temps (J), Loc),
                Expressions     => New_List (Make_Integer_Literal (Loc, 1))));
      end loop;

      Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);

      Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name       =>
            Make_Indexed_Component (Loc,
              Prefix      => New_Occurrence_Of (Res, Loc),
              Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
          Expression =>
            Make_Character_Literal (Loc,
              Chars              => Name_Find,
              Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name       => New_Occurrence_Of (Pos, Loc),
          Expression =>
            Make_Op_Add (Loc,
              Left_Opnd  => New_Occurrence_Of (Pos, Loc),
              Right_Opnd => Make_Integer_Literal (Loc, 1))));

      for J in 1 .. Dims loop

         Append_To (Stats,
           Make_Assignment_Statement (Loc,
             Name =>
               Make_Slice (Loc,
                 Prefix          => New_Occurrence_Of (Res, Loc),
                 Discrete_Range  =>
                   Make_Range (Loc,
                     Low_Bound  => New_Occurrence_Of  (Pos, Loc),
                     High_Bound =>
                       Make_Op_Subtract (Loc,
                         Left_Opnd  =>
                           Make_Op_Add (Loc,
                             Left_Opnd  => New_Occurrence_Of (Pos, Loc),
                             Right_Opnd =>
                               Make_Attribute_Reference (Loc,
                                 Attribute_Name => Name_Length,
                                 Prefix         =>
                                   New_Occurrence_Of (Temps (J), Loc),
                                 Expressions    =>
                                   New_List (Make_Integer_Literal (Loc, 1)))),
                         Right_Opnd => Make_Integer_Literal (Loc, 1)))),

              Expression => New_Occurrence_Of (Temps (J), Loc)));

         if J < Dims then
            Append_To (Stats,
               Make_Assignment_Statement (Loc,
                  Name       => New_Occurrence_Of (Pos, Loc),
                  Expression =>
                    Make_Op_Add (Loc,
                      Left_Opnd  => New_Occurrence_Of (Pos, Loc),
                      Right_Opnd =>
                        Make_Attribute_Reference (Loc,
                          Attribute_Name => Name_Length,
                          Prefix         => New_Occurrence_Of (Temps (J), Loc),
                          Expressions    =>
                            New_List (Make_Integer_Literal (Loc, 1))))));

            Set_Character_Literal_Name (Char_Code (Character'Pos (',')));

            Append_To (Stats,
              Make_Assignment_Statement (Loc,
                Name => Make_Indexed_Component (Loc,
                   Prefix => New_Occurrence_Of (Res, Loc),
                   Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
                Expression =>
                  Make_Character_Literal (Loc,
                    Chars              => Name_Find,
                    Char_Literal_Value => UI_From_Int (Character'Pos (',')))));

            Append_To (Stats,
              Make_Assignment_Statement (Loc,
                Name         => New_Occurrence_Of (Pos, Loc),
                  Expression =>
                    Make_Op_Add (Loc,
                      Left_Opnd  => New_Occurrence_Of (Pos, Loc),
                      Right_Opnd => Make_Integer_Literal (Loc, 1))));
         end if;
      end loop;

      Set_Character_Literal_Name (Char_Code (Character'Pos (')')));

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name        =>
            Make_Indexed_Component (Loc,
              Prefix      => New_Occurrence_Of (Res, Loc),
              Expressions => New_List (New_Occurrence_Of (Len, Loc))),
           Expression =>
             Make_Character_Literal (Loc,
               Chars              => Name_Find,
               Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
      return Build_Task_Image_Function (Loc, Decls, Stats, Res);
   end Build_Task_Array_Image;

   ----------------------------
   -- Build_Task_Image_Decls --
   ----------------------------

   function Build_Task_Image_Decls
     (Loc          : Source_Ptr;
      Id_Ref       : Node_Id;
      A_Type       : Entity_Id;
      In_Init_Proc : Boolean := False) return List_Id
   is
      Decls  : constant List_Id   := New_List;
      T_Id   : Entity_Id := Empty;
      Decl   : Node_Id;
      Expr   : Node_Id   := Empty;
      Fun    : Node_Id   := Empty;
      Is_Dyn : constant Boolean :=
                 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
                   and then
                 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;

   begin
      --  If Discard_Names or No_Implicit_Heap_Allocations are in effect,
      --  generate a dummy declaration only.

      if Restriction_Active (No_Implicit_Heap_Allocations)
        or else Global_Discard_Names
      then
         T_Id := Make_Temporary (Loc, 'J');
         Name_Len := 0;

         return
           New_List (
             Make_Object_Declaration (Loc,
               Defining_Identifier => T_Id,
               Object_Definition => New_Occurrence_Of (Standard_String, Loc),
               Expression =>
                 Make_String_Literal (Loc,
                   Strval => String_From_Name_Buffer)));

      else
         if Nkind (Id_Ref) = N_Identifier
           or else Nkind (Id_Ref) = N_Defining_Identifier
         then
            --  For a simple variable, the image of the task is built from
            --  the name of the variable. To avoid possible conflict with the
            --  anonymous type created for a single protected object, add a
            --  numeric suffix.

            T_Id :=
              Make_Defining_Identifier (Loc,
                New_External_Name (Chars (Id_Ref), 'T', 1));

            Get_Name_String (Chars (Id_Ref));

            Expr :=
              Make_String_Literal (Loc,
                Strval => String_From_Name_Buffer);

         elsif Nkind (Id_Ref) = N_Selected_Component then
            T_Id :=
              Make_Defining_Identifier (Loc,
                New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
            Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);

         elsif Nkind (Id_Ref) = N_Indexed_Component then
            T_Id :=
              Make_Defining_Identifier (Loc,
                New_External_Name (Chars (A_Type), 'N'));

            Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
         end if;
      end if;

      if Present (Fun) then
         Append (Fun, Decls);
         Expr := Make_Function_Call (Loc,
           Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));

         if not In_Init_Proc and then VM_Target = No_VM then
            Set_Uses_Sec_Stack (Defining_Entity (Fun));
         end if;
      end if;

      Decl := Make_Object_Declaration (Loc,
        Defining_Identifier => T_Id,
        Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
        Constant_Present    => True,
        Expression          => Expr);

      Append (Decl, Decls);
      return Decls;
   end Build_Task_Image_Decls;

   -------------------------------
   -- Build_Task_Image_Function --
   -------------------------------

   function Build_Task_Image_Function
     (Loc   : Source_Ptr;
      Decls : List_Id;
      Stats : List_Id;
      Res   : Entity_Id) return Node_Id
   is
      Spec : Node_Id;

   begin
      Append_To (Stats,
        Make_Simple_Return_Statement (Loc,
          Expression => New_Occurrence_Of (Res, Loc)));

      Spec := Make_Function_Specification (Loc,
        Defining_Unit_Name => Make_Temporary (Loc, 'F'),
        Result_Definition  => New_Occurrence_Of (Standard_String, Loc));

      --  Calls to 'Image use the secondary stack, which must be cleaned up
      --  after the task name is built.

      return Make_Subprogram_Body (Loc,
         Specification => Spec,
         Declarations => Decls,
         Handled_Statement_Sequence =>
           Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
   end Build_Task_Image_Function;

   -----------------------------
   -- Build_Task_Image_Prefix --
   -----------------------------

   procedure Build_Task_Image_Prefix
      (Loc    : Source_Ptr;
       Len    : out Entity_Id;
       Res    : out Entity_Id;
       Pos    : out Entity_Id;
       Prefix : Entity_Id;
       Sum    : Node_Id;
       Decls  : List_Id;
       Stats  : List_Id)
   is
   begin
      Len := Make_Temporary (Loc, 'L', Sum);

      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => Len,
          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
          Expression          => Sum));

      Res := Make_Temporary (Loc, 'R');

      Append_To (Decls,
         Make_Object_Declaration (Loc,
            Defining_Identifier => Res,
            Object_Definition =>
               Make_Subtype_Indication (Loc,
                  Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
               Constraint =>
                 Make_Index_Or_Discriminant_Constraint (Loc,
                   Constraints =>
                     New_List (
                       Make_Range (Loc,
                         Low_Bound => Make_Integer_Literal (Loc, 1),
                         High_Bound => New_Occurrence_Of (Len, Loc)))))));

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

      Append_To (Decls,
         Make_Object_Declaration (Loc,
            Defining_Identifier => Pos,
            Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc)));

      --  Pos := Prefix'Length;

      Append_To (Stats,
         Make_Assignment_Statement (Loc,
            Name => New_Occurrence_Of (Pos, Loc),
            Expression =>
              Make_Attribute_Reference (Loc,
                Attribute_Name => Name_Length,
                Prefix         => New_Occurrence_Of (Prefix, Loc),
                Expressions    => New_List (Make_Integer_Literal (Loc, 1)))));

      --  Res (1 .. Pos) := Prefix;

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name =>
            Make_Slice (Loc,
              Prefix          => New_Occurrence_Of (Res, Loc),
              Discrete_Range  =>
                Make_Range (Loc,
                   Low_Bound  => Make_Integer_Literal (Loc, 1),
                   High_Bound => New_Occurrence_Of (Pos, Loc))),

          Expression => New_Occurrence_Of (Prefix, Loc)));

      Append_To (Stats,
         Make_Assignment_Statement (Loc,
            Name       => New_Occurrence_Of (Pos, Loc),
            Expression =>
              Make_Op_Add (Loc,
                Left_Opnd  => New_Occurrence_Of (Pos, Loc),
                Right_Opnd => Make_Integer_Literal (Loc, 1))));
   end Build_Task_Image_Prefix;

   -----------------------------
   -- Build_Task_Record_Image --
   -----------------------------

   function Build_Task_Record_Image
     (Loc    : Source_Ptr;
      Id_Ref : Node_Id;
      Dyn    : Boolean := False) return Node_Id
   is
      Len : Entity_Id;
      --  Total length of generated name

      Pos : Entity_Id;
      --  Index into result

      Res : Entity_Id;
      --  String to hold result

      Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
      --  Name of enclosing variable, prefix of resulting name

      Sum : Node_Id;
      --  Expression to compute total size of string

      Sel : Entity_Id;
      --  Entity for selector name

      Decls : constant List_Id := New_List;
      Stats : constant List_Id := New_List;

   begin
      --  For a dynamic task, the name comes from the target variable. For a
      --  static one it is a formal of the enclosing init proc.

      if Dyn then
         Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier => Pref,
             Object_Definition => New_Occurrence_Of (Standard_String, Loc),
             Expression =>
               Make_String_Literal (Loc,
                 Strval => String_From_Name_Buffer)));

      else
         Append_To (Decls,
           Make_Object_Renaming_Declaration (Loc,
             Defining_Identifier => Pref,
             Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
             Name                => Make_Identifier (Loc, Name_uTask_Name)));
      end if;

      Sel := Make_Temporary (Loc, 'S');

      Get_Name_String (Chars (Selector_Name (Id_Ref)));

      Append_To (Decls,
         Make_Object_Declaration (Loc,
           Defining_Identifier => Sel,
           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
           Expression          =>
             Make_String_Literal (Loc,
               Strval => String_From_Name_Buffer)));

      Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));

      Sum :=
        Make_Op_Add (Loc,
          Left_Opnd => Sum,
          Right_Opnd =>
           Make_Attribute_Reference (Loc,
             Attribute_Name => Name_Length,
             Prefix =>
               New_Occurrence_Of (Pref, Loc),
             Expressions => New_List (Make_Integer_Literal (Loc, 1))));

      Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);

      Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));

      --  Res (Pos) := '.';

      Append_To (Stats,
         Make_Assignment_Statement (Loc,
           Name => Make_Indexed_Component (Loc,
              Prefix => New_Occurrence_Of (Res, Loc),
              Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
           Expression =>
             Make_Character_Literal (Loc,
               Chars => Name_Find,
               Char_Literal_Value =>
                 UI_From_Int (Character'Pos ('.')))));

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name => New_Occurrence_Of (Pos, Loc),
          Expression =>
            Make_Op_Add (Loc,
              Left_Opnd => New_Occurrence_Of (Pos, Loc),
              Right_Opnd => Make_Integer_Literal (Loc, 1))));

      --  Res (Pos .. Len) := Selector;

      Append_To (Stats,
        Make_Assignment_Statement (Loc,
          Name => Make_Slice (Loc,
             Prefix => New_Occurrence_Of (Res, Loc),
             Discrete_Range  =>
               Make_Range (Loc,
                 Low_Bound  => New_Occurrence_Of (Pos, Loc),
                 High_Bound => New_Occurrence_Of (Len, Loc))),
          Expression => New_Occurrence_Of (Sel, Loc)));

      return Build_Task_Image_Function (Loc, Decls, Stats, Res);
   end Build_Task_Record_Image;

   ----------------------------------
   -- Component_May_Be_Bit_Aligned --
   ----------------------------------

   function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
      UT : Entity_Id;

   begin
      --  If no component clause, then everything is fine, since the back end
      --  never bit-misaligns by default, even if there is a pragma Packed for
      --  the record.

      if No (Comp) or else No (Component_Clause (Comp)) then
         return False;
      end if;

      UT := Underlying_Type (Etype (Comp));

      --  It is only array and record types that cause trouble

      if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
         return False;

      --  If we know that we have a small (64 bits or less) record or small
      --  bit-packed array, then everything is fine, since the back end can
      --  handle these cases correctly.

      elsif Esize (Comp) <= 64
        and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
      then
         return False;

      --  Otherwise if the component is not byte aligned, we know we have the
      --  nasty unaligned case.

      elsif Normalized_First_Bit (Comp) /= Uint_0
        or else Esize (Comp) mod System_Storage_Unit /= Uint_0
      then
         return True;

      --  If we are large and byte aligned, then OK at this level

      else
         return False;
      end if;
   end Component_May_Be_Bit_Aligned;

   -----------------------------------
   -- Corresponding_Runtime_Package --
   -----------------------------------

   function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
      Pkg_Id : RTU_Id := RTU_Null;

   begin
      pragma Assert (Is_Concurrent_Type (Typ));

      if Ekind (Typ) in Protected_Kind then
         if Has_Entries (Typ)

            --  A protected type without entries that covers an interface and
            --  overrides the abstract routines with protected procedures is
            --  considered equivalent to a protected type with entries in the
            --  context of dispatching select statements. It is sufficient to
            --  check for the presence of an interface list in the declaration
            --  node to recognize this case.

           or else Present (Interface_List (Parent (Typ)))
           or else
             (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
                 or else Has_Interrupt_Handler (Typ))
               and then not Restriction_Active (No_Dynamic_Attachment))
         then
            if Abort_Allowed
              or else Restriction_Active (No_Entry_Queue) = False
              or else Number_Entries (Typ) > 1
              or else (Has_Attach_Handler (Typ)
                        and then not Restricted_Profile)
            then
               Pkg_Id := System_Tasking_Protected_Objects_Entries;
            else
               Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
            end if;

         else
            Pkg_Id := System_Tasking_Protected_Objects;
         end if;
      end if;

      return Pkg_Id;
   end Corresponding_Runtime_Package;

   -------------------------------
   -- Convert_To_Actual_Subtype --
   -------------------------------

   procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
      Act_ST : Entity_Id;

   begin
      Act_ST := Get_Actual_Subtype (Exp);

      if Act_ST = Etype (Exp) then
         return;
      else
         Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
         Analyze_And_Resolve (Exp, Act_ST);
      end if;
   end Convert_To_Actual_Subtype;

   -----------------------------------
   -- Current_Sem_Unit_Declarations --
   -----------------------------------

   function Current_Sem_Unit_Declarations return List_Id is
      U     : Node_Id := Unit (Cunit (Current_Sem_Unit));
      Decls : List_Id;

   begin
      --  If the current unit is a package body, locate the visible
      --  declarations of the package spec.

      if Nkind (U) = N_Package_Body then
         U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
      end if;

      if Nkind (U) = N_Package_Declaration then
         U := Specification (U);
         Decls := Visible_Declarations (U);

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

      else
         Decls := Declarations (U);

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

      return Decls;
   end Current_Sem_Unit_Declarations;

   -----------------------
   -- Duplicate_Subexpr --
   -----------------------

   function Duplicate_Subexpr
     (Exp      : Node_Id;
      Name_Req : Boolean := False) return Node_Id
   is
   begin
      Remove_Side_Effects (Exp, Name_Req);
      return New_Copy_Tree (Exp);
   end Duplicate_Subexpr;

   ---------------------------------
   -- Duplicate_Subexpr_No_Checks --
   ---------------------------------

   function Duplicate_Subexpr_No_Checks
     (Exp      : Node_Id;
      Name_Req : Boolean := False) return Node_Id
   is
      New_Exp : Node_Id;
   begin
      Remove_Side_Effects (Exp, Name_Req);
      New_Exp := New_Copy_Tree (Exp);
      Remove_Checks (New_Exp);
      return New_Exp;
   end Duplicate_Subexpr_No_Checks;

   -----------------------------------
   -- Duplicate_Subexpr_Move_Checks --
   -----------------------------------

   function Duplicate_Subexpr_Move_Checks
     (Exp      : Node_Id;
      Name_Req : Boolean := False) return Node_Id
   is
      New_Exp : Node_Id;
   begin
      Remove_Side_Effects (Exp, Name_Req);
      New_Exp := New_Copy_Tree (Exp);
      Remove_Checks (Exp);
      return New_Exp;
   end Duplicate_Subexpr_Move_Checks;

   --------------------
   -- Ensure_Defined --
   --------------------

   procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
      IR : Node_Id;

   begin
      --  An itype reference must only be created if this is a local itype, so
      --  that gigi can elaborate it on the proper objstack.

      if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
         IR := Make_Itype_Reference (Sloc (N));
         Set_Itype (IR, Typ);
         Insert_Action (N, IR);
      end if;
   end Ensure_Defined;

   --------------------
   -- Entry_Names_OK --
   --------------------

   function Entry_Names_OK return Boolean is
   begin
      return
        not Restricted_Profile
          and then not Global_Discard_Names
          and then not Restriction_Active (No_Implicit_Heap_Allocations)
          and then not Restriction_Active (No_Local_Allocators);
   end Entry_Names_OK;

   -------------------
   -- Evaluate_Name --
   -------------------

   procedure Evaluate_Name (Nam : Node_Id) is
      K : constant Node_Kind := Nkind (Nam);

   begin
      --  For an explicit dereference, we simply force the evaluation of the
      --  name expression. The dereference provides a value that is the address
      --  for the renamed object, and it is precisely this value that we want
      --  to preserve.

      if K = N_Explicit_Dereference then
         Force_Evaluation (Prefix (Nam));

      --  For a selected component, we simply evaluate the prefix

      elsif K = N_Selected_Component then
         Evaluate_Name (Prefix (Nam));

      --  For an indexed component, or an attribute reference, we evaluate the
      --  prefix, which is itself a name, recursively, and then force the
      --  evaluation of all the subscripts (or attribute expressions).

      elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
         Evaluate_Name (Prefix (Nam));

         declare
            E : Node_Id;

         begin
            E := First (Expressions (Nam));
            while Present (E) loop
               Force_Evaluation (E);

               if Original_Node (E) /= E then
                  Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
               end if;

               Next (E);
            end loop;
         end;

      --  For a slice, we evaluate the prefix, as for the indexed component
      --  case and then, if there is a range present, either directly or as the
      --  constraint of a discrete subtype indication, we evaluate the two
      --  bounds of this range.

      elsif K = N_Slice then
         Evaluate_Name (Prefix (Nam));

         declare
            DR     : constant Node_Id := Discrete_Range (Nam);
            Constr : Node_Id;
            Rexpr  : Node_Id;

         begin
            if Nkind (DR) = N_Range then
               Force_Evaluation (Low_Bound (DR));
               Force_Evaluation (High_Bound (DR));

            elsif Nkind (DR) = N_Subtype_Indication then
               Constr := Constraint (DR);

               if Nkind (Constr) = N_Range_Constraint then
                  Rexpr := Range_Expression (Constr);

                  Force_Evaluation (Low_Bound (Rexpr));
                  Force_Evaluation (High_Bound (Rexpr));
               end if;
            end if;
         end;

      --  For a type conversion, the expression of the conversion must be the
      --  name of an object, and we simply need to evaluate this name.

      elsif K = N_Type_Conversion then
         Evaluate_Name (Expression (Nam));

      --  For a function call, we evaluate the call

      elsif K = N_Function_Call then
         Force_Evaluation (Nam);

      --  The remaining cases are direct name, operator symbol and character
      --  literal. In all these cases, we do nothing, since we want to
      --  reevaluate each time the renamed object is used.

      else
         return;
      end if;
   end Evaluate_Name;

   ---------------------
   -- Evolve_And_Then --
   ---------------------

   procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
   begin
      if No (Cond) then
         Cond := Cond1;
      else
         Cond :=
           Make_And_Then (Sloc (Cond1),
             Left_Opnd  => Cond,
             Right_Opnd => Cond1);
      end if;
   end Evolve_And_Then;

   --------------------
   -- Evolve_Or_Else --
   --------------------

   procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
   begin
      if No (Cond) then
         Cond := Cond1;
      else
         Cond :=
           Make_Or_Else (Sloc (Cond1),
             Left_Opnd  => Cond,
             Right_Opnd => Cond1);
      end if;
   end Evolve_Or_Else;

   ------------------------------
   -- Expand_Subtype_From_Expr --
   ------------------------------

   --  This function is applicable for both static and dynamic allocation of
   --  objects which are constrained by an initial expression. Basically it
   --  transforms an unconstrained subtype indication into a constrained one.

   --  The expression may also be transformed in certain cases in order to
   --  avoid multiple evaluation. In the static allocation case, the general
   --  scheme is:

   --     Val : T := Expr;

   --        is transformed into

   --     Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
   --
   --  Here are the main cases :
   --
   --  <if Expr is a Slice>
   --    Val : T ([Index_Subtype (Expr)]) := Expr;
   --
   --  <elsif Expr is a String Literal>
   --    Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
   --
   --  <elsif Expr is Constrained>
   --    subtype T is Type_Of_Expr
   --    Val : T := Expr;
   --
   --  <elsif Expr is an entity_name>
   --    Val : T (constraints taken from Expr) := Expr;
   --
   --  <else>
   --    type Axxx is access all T;
   --    Rval : Axxx := Expr'ref;
   --    Val  : T (constraints taken from Rval) := Rval.all;

   --    ??? note: when the Expression is allocated in the secondary stack
   --              we could use it directly instead of copying it by declaring
   --              Val : T (...) renames Rval.all

   procedure Expand_Subtype_From_Expr
     (N             : Node_Id;
      Unc_Type      : Entity_Id;
      Subtype_Indic : Node_Id;
      Exp           : Node_Id)
   is
      Loc     : constant Source_Ptr := Sloc (N);
      Exp_Typ : constant Entity_Id  := Etype (Exp);
      T       : Entity_Id;

   begin
      --  In general we cannot build the subtype if expansion is disabled,
      --  because internal entities may not have been defined. However, to
      --  avoid some cascaded errors, we try to continue when the expression is
      --  an array (or string), because it is safe to compute the bounds. It is
      --  in fact required to do so even in a generic context, because there
      --  may be constants that depend on the bounds of a string literal, both
      --  standard string types and more generally arrays of characters.

      if not Expander_Active
        and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
      then
         return;
      end if;

      if Nkind (Exp) = N_Slice then
         declare
            Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));

         begin
            Rewrite (Subtype_Indic,
              Make_Subtype_Indication (Loc,
                Subtype_Mark => New_Reference_To (Unc_Type, Loc),
                Constraint =>
                  Make_Index_Or_Discriminant_Constraint (Loc,
                    Constraints => New_List
                      (New_Reference_To (Slice_Type, Loc)))));

            --  This subtype indication may be used later for constraint checks
            --  we better make sure that if a variable was used as a bound of
            --  of the original slice, its value is frozen.

            Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
            Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
         end;

      elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
         Rewrite (Subtype_Indic,
           Make_Subtype_Indication (Loc,
             Subtype_Mark => New_Reference_To (Unc_Type, Loc),
             Constraint =>
               Make_Index_Or_Discriminant_Constraint (Loc,
                 Constraints => New_List (
                   Make_Literal_Range (Loc,
                     Literal_Typ => Exp_Typ)))));

      elsif Is_Constrained (Exp_Typ)
        and then not Is_Class_Wide_Type (Unc_Type)
      then
         if Is_Itype (Exp_Typ) then

            --  Within an initialization procedure, a selected component
            --  denotes a component of the enclosing record, and it appears as
            --  an actual in a call to its own initialization procedure. If
            --  this component depends on the outer discriminant, we must
            --  generate the proper actual subtype for it.

            if Nkind (Exp) = N_Selected_Component
              and then Within_Init_Proc
            then
               declare
                  Decl : constant Node_Id :=
                           Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
               begin
                  if Present (Decl) then
                     Insert_Action (N, Decl);
                     T := Defining_Identifier (Decl);
                  else
                     T := Exp_Typ;
                  end if;
               end;

            --  No need to generate a new one (new what???)

            else
               T := Exp_Typ;
            end if;

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

            Insert_Action (N,
              Make_Subtype_Declaration (Loc,
                Defining_Identifier => T,
                Subtype_Indication  => New_Reference_To (Exp_Typ, Loc)));

            --  This type is marked as an itype even though it has an explicit
            --  declaration since otherwise Is_Generic_Actual_Type can get
            --  set, resulting in the generation of spurious errors. (See
            --  sem_ch8.Analyze_Package_Renaming and sem_type.covers)

            Set_Is_Itype (T);
            Set_Associated_Node_For_Itype (T, Exp);
         end if;

         Rewrite (Subtype_Indic, New_Reference_To (T, Loc));

      --  Nothing needs to be done for private types with unknown discriminants
      --  if the underlying type is not an unconstrained composite type or it
      --  is an unchecked union.

      elsif Is_Private_Type (Unc_Type)
        and then Has_Unknown_Discriminants (Unc_Type)
        and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
                   or else Is_Constrained (Underlying_Type (Unc_Type))
                   or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
      then
         null;

      --  Case of derived type with unknown discriminants where the parent type
      --  also has unknown discriminants.

      elsif Is_Record_Type (Unc_Type)
        and then not Is_Class_Wide_Type (Unc_Type)
        and then Has_Unknown_Discriminants (Unc_Type)
        and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
      then
         --  Nothing to be done if no underlying record view available

         if No (Underlying_Record_View (Unc_Type)) then
            null;

         --  Otherwise use the Underlying_Record_View to create the proper
         --  constrained subtype for an object of a derived type with unknown
         --  discriminants.

         else
            Remove_Side_Effects (Exp);
            Rewrite (Subtype_Indic,
              Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
         end if;

      --  Renamings of class-wide interface types require no equivalent
      --  constrained type declarations because we only need to reference
      --  the tag component associated with the interface. The same is
      --  presumably true for class-wide types in general, so this test
      --  is broadened to include all class-wide renamings, which also
      --  avoids cases of unbounded recursion in Remove_Side_Effects.
      --  (Is this really correct, or are there some cases of class-wide
      --  renamings that require action in this procedure???)

      elsif Present (N)
        and then Nkind (N) = N_Object_Renaming_Declaration
        and then Is_Class_Wide_Type (Unc_Type)
      then
         null;

      --  In Ada 95 nothing to be done if the type of the expression is limited
      --  because in this case the expression cannot be copied, and its use can
      --  only be by reference.

      --  In Ada 2005 the context can be an object declaration whose expression
      --  is a function that returns in place. If the nominal subtype has
      --  unknown discriminants, the call still provides constraints on the
      --  object, and we have to create an actual subtype from it.

      --  If the type is class-wide, the expression is dynamically tagged and
      --  we do not create an actual subtype either. Ditto for an interface.
      --  For now this applies only if the type is immutably limited, and the
      --  function being called is build-in-place. This will have to be revised
      --  when build-in-place functions are generalized to other types.

      elsif Is_Immutably_Limited_Type (Exp_Typ)
        and then
         (Is_Class_Wide_Type (Exp_Typ)
           or else Is_Interface (Exp_Typ)
           or else not Has_Unknown_Discriminants (Exp_Typ)
           or else not Is_Composite_Type (Unc_Type))
      then
         null;

      --  For limited objects initialized with build in place function calls,
      --  nothing to be done; otherwise we prematurely introduce an N_Reference
      --  node in the expression initializing the object, which breaks the
      --  circuitry that detects and adds the additional arguments to the
      --  called function.

      elsif Is_Build_In_Place_Function_Call (Exp) then
         null;

      else
         Remove_Side_Effects (Exp);
         Rewrite (Subtype_Indic,
           Make_Subtype_From_Expr (Exp, Unc_Type));
      end if;
   end Expand_Subtype_From_Expr;

   ------------------------
   -- Find_Interface_ADT --
   ------------------------

   function Find_Interface_ADT
     (T     : Entity_Id;
      Iface : Entity_Id) return Elmt_Id
   is
      ADT : Elmt_Id;
      Typ : Entity_Id := T;

   begin
      pragma Assert (Is_Interface (Iface));

      --  Handle private types

      if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
         Typ := Full_View (Typ);
      end if;

      --  Handle access types

      if Is_Access_Type (Typ) then
         Typ := Designated_Type (Typ);
      end if;

      --  Handle task and protected types implementing interfaces

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

      pragma Assert
        (not Is_Class_Wide_Type (Typ)
          and then Ekind (Typ) /= E_Incomplete_Type);

      if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
         return First_Elmt (Access_Disp_Table (Typ));

      else
         ADT :=
           Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
         while Present (ADT)
           and then Present (Related_Type (Node (ADT)))
           and then Related_Type (Node (ADT)) /= Iface
           and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
                                     Use_Full_View => True)
         loop
            Next_Elmt (ADT);
         end loop;

         pragma Assert (Present (Related_Type (Node (ADT))));
         return ADT;
      end if;
   end Find_Interface_ADT;

   ------------------------
   -- Find_Interface_Tag --
   ------------------------

   function Find_Interface_Tag
     (T     : Entity_Id;
      Iface : Entity_Id) return Entity_Id
   is
      AI_Tag : Entity_Id;
      Found  : Boolean   := False;
      Typ    : Entity_Id := T;

      procedure Find_Tag (Typ : Entity_Id);
      --  Internal subprogram used to recursively climb to the ancestors

      --------------
      -- Find_Tag --
      --------------

      procedure Find_Tag (Typ : Entity_Id) is
         AI_Elmt : Elmt_Id;
         AI      : Node_Id;

      begin
         --  This routine does not handle the case in which the interface is an
         --  ancestor of Typ. That case is handled by the enclosing subprogram.

         pragma Assert (Typ /= Iface);

         --  Climb to the root type handling private types

         if Present (Full_View (Etype (Typ))) then
            if Full_View (Etype (Typ)) /= Typ then
               Find_Tag (Full_View (Etype (Typ)));
            end if;

         elsif Etype (Typ) /= Typ then
            Find_Tag (Etype (Typ));
         end if;

         --  Traverse the list of interfaces implemented by the type

         if not Found
           and then Present (Interfaces (Typ))
           and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
         then
            --  Skip the tag associated with the primary table

            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
            pragma Assert (Present (AI_Tag));

            AI_Elmt := First_Elmt (Interfaces (Typ));
            while Present (AI_Elmt) loop
               AI := Node (AI_Elmt);

               if AI = Iface
                 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
               then
                  Found := True;
                  return;
               end if;

               AI_Tag := Next_Tag_Component (AI_Tag);
               Next_Elmt (AI_Elmt);
            end loop;
         end if;
      end Find_Tag;

   --  Start of processing for Find_Interface_Tag

   begin
      pragma Assert (Is_Interface (Iface));

      --  Handle access types

      if Is_Access_Type (Typ) then
         Typ := Designated_Type (Typ);
      end if;

      --  Handle class-wide types

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

      --  Handle private types

      if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
         Typ := Full_View (Typ);
      end if;

      --  Handle entities from the limited view

      if Ekind (Typ) = E_Incomplete_Type then
         pragma Assert (Present (Non_Limited_View (Typ)));
         Typ := Non_Limited_View (Typ);
      end if;

      --  Handle task and protected types implementing interfaces

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

      --  If the interface is an ancestor of the type, then it shared the
      --  primary dispatch table.

      if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
         pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
         return First_Tag_Component (Typ);

      --  Otherwise we need to search for its associated tag component

      else
         Find_Tag (Typ);
         pragma Assert (Found);
         return AI_Tag;
      end if;
   end Find_Interface_Tag;

   ------------------
   -- Find_Prim_Op --
   ------------------

   function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
      Prim : Elmt_Id;
      Typ  : Entity_Id := T;
      Op   : Entity_Id;

   begin
      if Is_Class_Wide_Type (Typ) then
         Typ := Root_Type (Typ);
      end if;

      Typ := Underlying_Type (Typ);

      --  Loop through primitive operations

      Prim := First_Elmt (Primitive_Operations (Typ));
      while Present (Prim) loop
         Op := Node (Prim);

         --  We can retrieve primitive operations by name if it is an internal
         --  name. For equality we must check that both of its operands have
         --  the same type, to avoid confusion with user-defined equalities
         --  than may have a non-symmetric signature.

         exit when Chars (Op) = Name
           and then
             (Name /= Name_Op_Eq
               or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));

         Next_Elmt (Prim);

         --  Raise Program_Error if no primitive found

         if No (Prim) then
            raise Program_Error;
         end if;
      end loop;

      return Node (Prim);
   end Find_Prim_Op;

   ------------------
   -- Find_Prim_Op --
   ------------------

   function Find_Prim_Op
     (T    : Entity_Id;
      Name : TSS_Name_Type) return Entity_Id
   is
      Inher_Op  : Entity_Id := Empty;
      Own_Op    : Entity_Id := Empty;
      Prim_Elmt : Elmt_Id;
      Prim_Id   : Entity_Id;
      Typ       : Entity_Id := T;

   begin
      if Is_Class_Wide_Type (Typ) then
         Typ := Root_Type (Typ);
      end if;

      Typ := Underlying_Type (Typ);

      --  This search is based on the assertion that the dispatching version
      --  of the TSS routine always precedes the real primitive.

      Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
      while Present (Prim_Elmt) loop
         Prim_Id := Node (Prim_Elmt);

         if Is_TSS (Prim_Id, Name) then
            if Present (Alias (Prim_Id)) then
               Inher_Op := Prim_Id;
            else
               Own_Op := Prim_Id;
            end if;
         end if;

         Next_Elmt (Prim_Elmt);
      end loop;

      if Present (Own_Op) then
         return Own_Op;
      elsif Present (Inher_Op) then
         return Inher_Op;
      else
         raise Program_Error;
      end if;
   end Find_Prim_Op;

   ----------------------------
   -- Find_Protection_Object --
   ----------------------------

   function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
      S : Entity_Id;

   begin
      S := Scop;
      while Present (S) loop
         if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
           and then Present (Protection_Object (S))
         then
            return Protection_Object (S);
         end if;

         S := Scope (S);
      end loop;

      --  If we do not find a Protection object in the scope chain, then
      --  something has gone wrong, most likely the object was never created.

      raise Program_Error;
   end Find_Protection_Object;

   --------------------------
   -- Find_Protection_Type --
   --------------------------

   function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
      Comp : Entity_Id;
      Typ  : Entity_Id := Conc_Typ;

   begin
      if Is_Concurrent_Type (Typ) then
         Typ := Corresponding_Record_Type (Typ);
      end if;

      --  Since restriction violations are not considered serious errors, the
      --  expander remains active, but may leave the corresponding record type
      --  malformed. In such cases, component _object is not available so do
      --  not look for it.

      if not Analyzed (Typ) then
         return Empty;
      end if;

      Comp := First_Component (Typ);
      while Present (Comp) loop
         if Chars (Comp) = Name_uObject then
            return Base_Type (Etype (Comp));
         end if;

         Next_Component (Comp);
      end loop;

      --  The corresponding record of a protected type should always have an
      --  _object field.

      raise Program_Error;
   end Find_Protection_Type;

   ----------------------
   -- Force_Evaluation --
   ----------------------

   procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
   begin
      Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
   end Force_Evaluation;

   ---------------------------------
   -- Fully_Qualified_Name_String --
   ---------------------------------

   function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
      procedure Internal_Full_Qualified_Name (E : Entity_Id);
      --  Compute recursively the qualified name without NUL at the end, adding
      --  it to the currently started string being generated

      ----------------------------------
      -- Internal_Full_Qualified_Name --
      ----------------------------------

      procedure Internal_Full_Qualified_Name (E : Entity_Id) is
         Ent : Entity_Id;

      begin
         --  Deal properly with child units

         if Nkind (E) = N_Defining_Program_Unit_Name then
            Ent := Defining_Identifier (E);
         else
            Ent := E;
         end if;

         --  Compute qualification recursively (only "Standard" has no scope)

         if Present (Scope (Scope (Ent))) then
            Internal_Full_Qualified_Name (Scope (Ent));
            Store_String_Char (Get_Char_Code ('.'));
         end if;

         --  Every entity should have a name except some expanded blocks
         --  don't bother about those.

         if Chars (Ent) = No_Name then
            return;
         end if;

         --  Generates the entity name in upper case

         Get_Decoded_Name_String (Chars (Ent));
         Set_All_Upper_Case;
         Store_String_Chars (Name_Buffer (1 .. Name_Len));
         return;
      end Internal_Full_Qualified_Name;

   --  Start of processing for Full_Qualified_Name

   begin
      Start_String;
      Internal_Full_Qualified_Name (E);
      Store_String_Char (Get_Char_Code (ASCII.NUL));
      return End_String;
   end Fully_Qualified_Name_String;

   ------------------------
   -- Generate_Poll_Call --
   ------------------------

   procedure Generate_Poll_Call (N : Node_Id) is
   begin
      --  No poll call if polling not active

      if not Polling_Required then
         return;

      --  Otherwise generate require poll call

      else
         Insert_Before_And_Analyze (N,
           Make_Procedure_Call_Statement (Sloc (N),
             Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
      end if;
   end Generate_Poll_Call;

   ---------------------------------
   -- Get_Current_Value_Condition --
   ---------------------------------

   --  Note: the implementation of this procedure is very closely tied to the
   --  implementation of Set_Current_Value_Condition. In the Get procedure, we
   --  interpret Current_Value fields set by the Set procedure, so the two
   --  procedures need to be closely coordinated.

   procedure Get_Current_Value_Condition
     (Var : Node_Id;
      Op  : out Node_Kind;
      Val : out Node_Id)
   is
      Loc : constant Source_Ptr := Sloc (Var);
      Ent : constant Entity_Id  := Entity (Var);

      procedure Process_Current_Value_Condition
        (N : Node_Id;
         S : Boolean);
      --  N is an expression which holds either True (S = True) or False (S =
      --  False) in the condition. This procedure digs out the expression and
      --  if it refers to Ent, sets Op and Val appropriately.

      -------------------------------------
      -- Process_Current_Value_Condition --
      -------------------------------------

      procedure Process_Current_Value_Condition
        (N : Node_Id;
         S : Boolean)
      is
         Cond : Node_Id;
         Sens : Boolean;

      begin
         Cond := N;
         Sens := S;

         --  Deal with NOT operators, inverting sense

         while Nkind (Cond) = N_Op_Not loop
            Cond := Right_Opnd (Cond);
            Sens := not Sens;
         end loop;

         --  Deal with AND THEN and AND cases

         if Nkind_In (Cond, N_And_Then, N_Op_And) then

            --  Don't ever try to invert a condition that is of the form of an
            --  AND or AND THEN (since we are not doing sufficiently general
            --  processing to allow this).

            if Sens = False then
               Op  := N_Empty;
               Val := Empty;
               return;
            end if;

            --  Recursively process AND and AND THEN branches

            Process_Current_Value_Condition (Left_Opnd (Cond), True);

            if Op /= N_Empty then
               return;
            end if;

            Process_Current_Value_Condition (Right_Opnd (Cond), True);
            return;

         --  Case of relational operator

         elsif Nkind (Cond) in N_Op_Compare then
            Op := Nkind (Cond);

            --  Invert sense of test if inverted test

            if Sens = False then
               case Op is
                  when N_Op_Eq => Op := N_Op_Ne;
                  when N_Op_Ne => Op := N_Op_Eq;
                  when N_Op_Lt => Op := N_Op_Ge;
                  when N_Op_Gt => Op := N_Op_Le;
                  when N_Op_Le => Op := N_Op_Gt;
                  when N_Op_Ge => Op := N_Op_Lt;
                  when others  => raise Program_Error;
               end case;
            end if;

            --  Case of entity op value

            if Is_Entity_Name (Left_Opnd (Cond))
              and then Ent = Entity (Left_Opnd (Cond))
              and then Compile_Time_Known_Value (Right_Opnd (Cond))
            then
               Val := Right_Opnd (Cond);

            --  Case of value op entity

            elsif Is_Entity_Name (Right_Opnd (Cond))
              and then Ent = Entity (Right_Opnd (Cond))
              and then Compile_Time_Known_Value (Left_Opnd (Cond))
            then
               Val := Left_Opnd (Cond);

               --  We are effectively swapping operands

               case Op is
                  when N_Op_Eq => null;
                  when N_Op_Ne => null;
                  when N_Op_Lt => Op := N_Op_Gt;
                  when N_Op_Gt => Op := N_Op_Lt;
                  when N_Op_Le => Op := N_Op_Ge;
                  when N_Op_Ge => Op := N_Op_Le;
                  when others  => raise Program_Error;
               end case;

            else
               Op := N_Empty;
            end if;

            return;

            --  Case of Boolean variable reference, return as though the
            --  reference had said var = True.

         else
            if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
               Val := New_Occurrence_Of (Standard_True, Sloc (Cond));

               if Sens = False then
                  Op := N_Op_Ne;
               else
                  Op := N_Op_Eq;
               end if;
            end if;
         end if;
      end Process_Current_Value_Condition;

   --  Start of processing for Get_Current_Value_Condition

   begin
      Op  := N_Empty;
      Val := Empty;

      --  Immediate return, nothing doing, if this is not an object

      if Ekind (Ent) not in Object_Kind then
         return;
      end if;

      --  Otherwise examine current value

      declare
         CV   : constant Node_Id := Current_Value (Ent);
         Sens : Boolean;
         Stm  : Node_Id;

      begin
         --  If statement. Condition is known true in THEN section, known False
         --  in any ELSIF or ELSE part, and unknown outside the IF statement.

         if Nkind (CV) = N_If_Statement then

            --  Before start of IF statement

            if Loc < Sloc (CV) then
               return;

               --  After end of IF statement

            elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
               return;
            end if;

            --  At this stage we know that we are within the IF statement, but
            --  unfortunately, the tree does not record the SLOC of the ELSE so
            --  we cannot use a simple SLOC comparison to distinguish between
            --  the then/else statements, so we have to climb the tree.

            declare
               N : Node_Id;

            begin
               N := Parent (Var);
               while Parent (N) /= CV loop
                  N := Parent (N);

                  --  If we fall off the top of the tree, then that's odd, but
                  --  perhaps it could occur in some error situation, and the
                  --  safest response is simply to assume that the outcome of
                  --  the condition is unknown. No point in bombing during an
                  --  attempt to optimize things.

                  if No (N) then
                     return;
                  end if;
               end loop;

               --  Now we have N pointing to a node whose parent is the IF
               --  statement in question, so now we can tell if we are within
               --  the THEN statements.

               if Is_List_Member (N)
                 and then List_Containing (N) = Then_Statements (CV)
               then
                  Sens := True;

               --  If the variable reference does not come from source, we
               --  cannot reliably tell whether it appears in the else part.
               --  In particular, if it appears in generated code for a node
               --  that requires finalization, it may be attached to a list
               --  that has not been yet inserted into the code. For now,
               --  treat it as unknown.

               elsif not Comes_From_Source (N) then
                  return;

               --  Otherwise we must be in ELSIF or ELSE part

               else
                  Sens := False;
               end if;
            end;

            --  ELSIF part. Condition is known true within the referenced
            --  ELSIF, known False in any subsequent ELSIF or ELSE part,
            --  and unknown before the ELSE part or after the IF statement.

         elsif Nkind (CV) = N_Elsif_Part then

            --  if the Elsif_Part had condition_actions, the elsif has been
            --  rewritten as a nested if, and the original elsif_part is
            --  detached from the tree, so there is no way to obtain useful
            --  information on the current value of the variable.
            --  Can this be improved ???

            if No (Parent (CV)) then
               return;
            end if;

            Stm := Parent (CV);

            --  Before start of ELSIF part

            if Loc < Sloc (CV) then
               return;

               --  After end of IF statement

            elsif Loc >= Sloc (Stm) +
              Text_Ptr (UI_To_Int (End_Span (Stm)))
            then
               return;
            end if;

            --  Again we lack the SLOC of the ELSE, so we need to climb the
            --  tree to see if we are within the ELSIF part in question.

            declare
               N : Node_Id;

            begin
               N := Parent (Var);
               while Parent (N) /= Stm loop
                  N := Parent (N);

                  --  If we fall off the top of the tree, then that's odd, but
                  --  perhaps it could occur in some error situation, and the
                  --  safest response is simply to assume that the outcome of
                  --  the condition is unknown. No point in bombing during an
                  --  attempt to optimize things.

                  if No (N) then
                     return;
                  end if;
               end loop;

               --  Now we have N pointing to a node whose parent is the IF
               --  statement in question, so see if is the ELSIF part we want.
               --  the THEN statements.

               if N = CV then
                  Sens := True;

                  --  Otherwise we must be in subsequent ELSIF or ELSE part

               else
                  Sens := False;
               end if;
            end;

         --  Iteration scheme of while loop. The condition is known to be
         --  true within the body of the loop.

         elsif Nkind (CV) = N_Iteration_Scheme then
            declare
               Loop_Stmt : constant Node_Id := Parent (CV);

            begin
               --  Before start of body of loop

               if Loc < Sloc (Loop_Stmt) then
                  return;

               --  After end of LOOP statement

               elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
                  return;

               --  We are within the body of the loop

               else
                  Sens := True;
               end if;
            end;

         --  All other cases of Current_Value settings

         else
            return;
         end if;

         --  If we fall through here, then we have a reportable condition, Sens
         --  is True if the condition is true and False if it needs inverting.

         Process_Current_Value_Condition (Condition (CV), Sens);
      end;
   end Get_Current_Value_Condition;

   ---------------------
   -- Get_Stream_Size --
   ---------------------

   function Get_Stream_Size (E : Entity_Id) return Uint is
   begin
      --  If we have a Stream_Size clause for this type use it

      if Has_Stream_Size_Clause (E) then
         return Static_Integer (Expression (Stream_Size_Clause (E)));

      --  Otherwise the Stream_Size if the size of the type

      else
         return Esize (E);
      end if;
   end Get_Stream_Size;

   ---------------------------
   -- Has_Access_Constraint --
   ---------------------------

   function Has_Access_Constraint (E : Entity_Id) return Boolean is
      Disc : Entity_Id;
      T    : constant Entity_Id := Etype (E);

   begin
      if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
         Disc := First_Discriminant (T);
         while Present (Disc) loop
            if Is_Access_Type (Etype (Disc)) then
               return True;
            end if;

            Next_Discriminant (Disc);
         end loop;

         return False;
      else
         return False;
      end if;
   end Has_Access_Constraint;

   ----------------------------------
   -- Has_Following_Address_Clause --
   ----------------------------------

   --  Should this function check the private part in a package ???

   function Has_Following_Address_Clause (D : Node_Id) return Boolean is
      Id   : constant Entity_Id := Defining_Identifier (D);
      Decl : Node_Id;

   begin
      Decl := Next (D);
      while Present (Decl) loop
         if Nkind (Decl) = N_At_Clause
           and then Chars (Identifier (Decl)) = Chars (Id)
         then
            return True;

         elsif Nkind (Decl) = N_Attribute_Definition_Clause
           and then Chars (Decl) = Name_Address
           and then Chars (Name (Decl)) = Chars (Id)
         then
            return True;
         end if;

         Next (Decl);
      end loop;

      return False;
   end Has_Following_Address_Clause;

   --------------------
   -- Homonym_Number --
   --------------------

   function Homonym_Number (Subp : Entity_Id) return Nat is
      Count : Nat;
      Hom   : Entity_Id;

   begin
      Count := 1;
      Hom := Homonym (Subp);
      while Present (Hom) loop
         if Scope (Hom) = Scope (Subp) then
            Count := Count + 1;
         end if;

         Hom := Homonym (Hom);
      end loop;

      return Count;
   end Homonym_Number;

   -----------------------------------
   -- In_Library_Level_Package_Body --
   -----------------------------------

   function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
   begin
      --  First determine whether the entity appears at the library level, then
      --  look at the containing unit.

      if Is_Library_Level_Entity (Id) then
         declare
            Container : constant Node_Id := Cunit (Get_Source_Unit (Id));

         begin
            return Nkind (Unit (Container)) = N_Package_Body;
         end;
      end if;

      return False;
   end In_Library_Level_Package_Body;

   ------------------------------
   -- In_Unconditional_Context --
   ------------------------------

   function In_Unconditional_Context (Node : Node_Id) return Boolean is
      P : Node_Id;

   begin
      P := Node;
      while Present (P) loop
         case Nkind (P) is
            when N_Subprogram_Body =>
               return True;

            when N_If_Statement =>
               return False;

            when N_Loop_Statement =>
               return False;

            when N_Case_Statement =>
               return False;

            when others =>
               P := Parent (P);
         end case;
      end loop;

      return False;
   end In_Unconditional_Context;

   -------------------
   -- Insert_Action --
   -------------------

   procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
   begin
      if Present (Ins_Action) then
         Insert_Actions (Assoc_Node, New_List (Ins_Action));
      end if;
   end Insert_Action;

   --  Version with check(s) suppressed

   procedure Insert_Action
     (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
   is
   begin
      Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
   end Insert_Action;

   -------------------------
   -- Insert_Action_After --
   -------------------------

   procedure Insert_Action_After
     (Assoc_Node : Node_Id;
      Ins_Action : Node_Id)
   is
   begin
      Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
   end Insert_Action_After;

   --------------------
   -- Insert_Actions --
   --------------------

   procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
      N : Node_Id;
      P : Node_Id;

      Wrapped_Node : Node_Id := Empty;

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

      --  Ignore insert of actions from inside default expression (or other
      --  similar "spec expression") in the special spec-expression analyze
      --  mode. Any insertions at this point have no relevance, since we are
      --  only doing the analyze to freeze the types of any static expressions.
      --  See section "Handling of Default Expressions" in the spec of package
      --  Sem for further details.

      if In_Spec_Expression then
         return;
      end if;

      --  If the action derives from stuff inside a record, then the actions
      --  are attached to the current scope, to be inserted and analyzed on
      --  exit from the scope. The reason for this is that we may also be
      --  generating freeze actions at the same time, and they must eventually
      --  be elaborated in the correct order.

      if Is_Record_Type (Current_Scope)
        and then not Is_Frozen (Current_Scope)
      then
         if No (Scope_Stack.Table
                  (Scope_Stack.Last).Pending_Freeze_Actions)
         then
            Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
              Ins_Actions;
         else
            Append_List
              (Ins_Actions,
               Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
         end if;

         return;
      end if;

      --  We now intend to climb up the tree to find the right point to
      --  insert the actions. We start at Assoc_Node, unless this node is a
      --  subexpression in which case we start with its parent. We do this for
      --  two reasons. First it speeds things up. Second, if Assoc_Node is
      --  itself one of the special nodes like N_And_Then, then we assume that
      --  an initial request to insert actions for such a node does not expect
      --  the actions to get deposited in the node for later handling when the
      --  node is expanded, since clearly the node is being dealt with by the
      --  caller. Note that in the subexpression case, N is always the child we
      --  came from.

      --  N_Raise_xxx_Error is an annoying special case, it is a statement if
      --  it has type Standard_Void_Type, and a subexpression otherwise.
      --  otherwise. Procedure calls, and similarly procedure attribute
      --  references, are also statements.

      if Nkind (Assoc_Node) in N_Subexpr
        and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
                   or else Etype (Assoc_Node) /= Standard_Void_Type)
        and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
        and then (Nkind (Assoc_Node) /= N_Attribute_Reference
                   or else
                     not Is_Procedure_Attribute_Name
                           (Attribute_Name (Assoc_Node)))
      then
         N := Assoc_Node;
         P := Parent (Assoc_Node);

      --  Non-subexpression case. Note that N is initially Empty in this case
      --  (N is only guaranteed Non-Empty in the subexpr case).

      else
         N := Empty;
         P := Assoc_Node;
      end if;

      --  Capture root of the transient scope

      if Scope_Is_Transient then
         Wrapped_Node := Node_To_Be_Wrapped;
      end if;

      loop
         pragma Assert (Present (P));

         --  Make sure that inserted actions stay in the transient scope

         if Present (Wrapped_Node) and then N = Wrapped_Node then
            Store_Before_Actions_In_Scope (Ins_Actions);
            return;
         end if;

         case Nkind (P) is

            --  Case of right operand of AND THEN or OR ELSE. Put the actions
            --  in the Actions field of the right operand. They will be moved
            --  out further when the AND THEN or OR ELSE operator is expanded.
            --  Nothing special needs to be done for the left operand since
            --  in that case the actions are executed unconditionally.

            when N_Short_Circuit =>
               if N = Right_Opnd (P) then

                  --  We are now going to either append the actions to the
                  --  actions field of the short-circuit operation. We will
                  --  also analyze the actions now.

                  --  This analysis is really too early, the proper thing would
                  --  be to just park them there now, and only analyze them if
                  --  we find we really need them, and to it at the proper
                  --  final insertion point. However attempting to this proved
                  --  tricky, so for now we just kill current values before and
                  --  after the analyze call to make sure we avoid peculiar
                  --  optimizations from this out of order insertion.

                  Kill_Current_Values;

                  if Present (Actions (P)) then
                     Insert_List_After_And_Analyze
                       (Last (Actions (P)), Ins_Actions);
                  else
                     Set_Actions (P, Ins_Actions);
                     Analyze_List (Actions (P));
                  end if;

                  Kill_Current_Values;

                  return;
               end if;

            --  Then or Else dependent expression of an if expression. Add
            --  actions to Then_Actions or Else_Actions field as appropriate.
            --  The actions will be moved further out when the if is expanded.

            when N_If_Expression =>
               declare
                  ThenX : constant Node_Id := Next (First (Expressions (P)));
                  ElseX : constant Node_Id := Next (ThenX);

               begin
                  --  If the enclosing expression is already analyzed, as
                  --  is the case for nested elaboration checks, insert the
                  --  conditional further out.

                  if Analyzed (P) then
                     null;

                  --  Actions belong to the then expression, temporarily place
                  --  them as Then_Actions of the if expression. They will be
                  --  moved to the proper place later when the if expression
                  --  is expanded.

                  elsif N = ThenX then
                     if Present (Then_Actions (P)) then
                        Insert_List_After_And_Analyze
                          (Last (Then_Actions (P)), Ins_Actions);
                     else
                        Set_Then_Actions (P, Ins_Actions);
                        Analyze_List (Then_Actions (P));
                     end if;

                     return;

                  --  Actions belong to the else expression, temporarily place
                  --  them as Else_Actions of the if expression. They will be
                  --  moved to the proper place later when the if expression
                  --  is expanded.

                  elsif N = ElseX then
                     if Present (Else_Actions (P)) then
                        Insert_List_After_And_Analyze
                          (Last (Else_Actions (P)), Ins_Actions);
                     else
                        Set_Else_Actions (P, Ins_Actions);
                        Analyze_List (Else_Actions (P));
                     end if;

                     return;

                  --  Actions belong to the condition. In this case they are
                  --  unconditionally executed, and so we can continue the
                  --  search for the proper insert point.

                  else
                     null;
                  end if;
               end;

            --  Alternative of case expression, we place the action in the
            --  Actions field of the case expression alternative, this will
            --  be handled when the case expression is expanded.

            when N_Case_Expression_Alternative =>
               if Present (Actions (P)) then
                  Insert_List_After_And_Analyze
                    (Last (Actions (P)), Ins_Actions);
               else
                  Set_Actions (P, Ins_Actions);
                  Analyze_List (Actions (P));
               end if;

               return;

            --  Case of appearing within an Expressions_With_Actions node. When
            --  the new actions come from the expression of the expression with
            --  actions, they must be added to the existing actions. The other
            --  alternative is when the new actions are related to one of the
            --  existing actions of the expression with actions. In that case
            --  they must be inserted further up the tree.

            when N_Expression_With_Actions =>
               if N = Expression (P) then
                  Insert_List_After_And_Analyze
                    (Last (Actions (P)), Ins_Actions);
                  return;
               end if;

            --  Case of appearing in the condition of a while expression or
            --  elsif. We insert the actions into the Condition_Actions field.
            --  They will be moved further out when the while loop or elsif
            --  is analyzed.

            when N_Iteration_Scheme |
                 N_Elsif_Part
            =>
               if N = Condition (P) then
                  if Present (Condition_Actions (P)) then
                     Insert_List_After_And_Analyze
                       (Last (Condition_Actions (P)), Ins_Actions);
                  else
                     Set_Condition_Actions (P, Ins_Actions);

                     --  Set the parent of the insert actions explicitly. This
                     --  is not a syntactic field, but we need the parent field
                     --  set, in particular so that freeze can understand that
                     --  it is dealing with condition actions, and properly
                     --  insert the freezing actions.

                     Set_Parent (Ins_Actions, P);
                     Analyze_List (Condition_Actions (P));
                  end if;

                  return;
               end if;

            --  Statements, declarations, pragmas, representation clauses

            when
               --  Statements

               N_Procedure_Call_Statement               |
               N_Statement_Other_Than_Procedure_Call    |

               --  Pragmas

               N_Pragma                                 |

               --  Representation_Clause

               N_At_Clause                              |
               N_Attribute_Definition_Clause            |
               N_Enumeration_Representation_Clause      |
               N_Record_Representation_Clause           |

               --  Declarations

               N_Abstract_Subprogram_Declaration        |
               N_Entry_Body                             |
               N_Exception_Declaration                  |
               N_Exception_Renaming_Declaration         |
               N_Expression_Function                    |
               N_Formal_Abstract_Subprogram_Declaration |
               N_Formal_Concrete_Subprogram_Declaration |
               N_Formal_Object_Declaration              |
               N_Formal_Type_Declaration                |
               N_Full_Type_Declaration                  |
               N_Function_Instantiation                 |
               N_Generic_Function_Renaming_Declaration  |
               N_Generic_Package_Declaration            |
               N_Generic_Package_Renaming_Declaration   |
               N_Generic_Procedure_Renaming_Declaration |
               N_Generic_Subprogram_Declaration         |
               N_Implicit_Label_Declaration             |
               N_Incomplete_Type_Declaration            |
               N_Number_Declaration                     |
               N_Object_Declaration                     |
               N_Object_Renaming_Declaration            |
               N_Package_Body                           |
               N_Package_Body_Stub                      |
               N_Package_Declaration                    |
               N_Package_Instantiation                  |
               N_Package_Renaming_Declaration           |
               N_Private_Extension_Declaration          |
               N_Private_Type_Declaration               |
               N_Procedure_Instantiation                |
               N_Protected_Body                         |
               N_Protected_Body_Stub                    |
               N_Protected_Type_Declaration             |
               N_Single_Task_Declaration                |
               N_Subprogram_Body                        |
               N_Subprogram_Body_Stub                   |
               N_Subprogram_Declaration                 |
               N_Subprogram_Renaming_Declaration        |
               N_Subtype_Declaration                    |
               N_Task_Body                              |
               N_Task_Body_Stub                         |
               N_Task_Type_Declaration                  |

               --  Use clauses can appear in lists of declarations

               N_Use_Package_Clause                     |
               N_Use_Type_Clause                        |

               --  Freeze entity behaves like a declaration or statement

               N_Freeze_Entity
            =>
               --  Do not insert here if the item is not a list member (this
               --  happens for example with a triggering statement, and the
               --  proper approach is to insert before the entire select).

               if not Is_List_Member (P) then
                  null;

               --  Do not insert if parent of P is an N_Component_Association
               --  node (i.e. we are in the context of an N_Aggregate or
               --  N_Extension_Aggregate node. In this case we want to insert
               --  before the entire aggregate.

               elsif Nkind (Parent (P)) = N_Component_Association then
                  null;

               --  Do not insert if the parent of P is either an N_Variant node
               --  or an N_Record_Definition node, meaning in either case that
               --  P is a member of a component list, and that therefore the
               --  actions should be inserted outside the complete record
               --  declaration.

               elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
                  null;

               --  Do not insert freeze nodes within the loop generated for
               --  an aggregate, because they may be elaborated too late for
               --  subsequent use in the back end: within a package spec the
               --  loop is part of the elaboration procedure and is only
               --  elaborated during the second pass.

               --  If the loop comes from source, or the entity is local to the
               --  loop itself it must remain within.

               elsif Nkind (Parent (P)) = N_Loop_Statement
                 and then not Comes_From_Source (Parent (P))
                 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
                 and then
                   Scope (Entity (First (Ins_Actions))) /= Current_Scope
               then
                  null;

               --  Otherwise we can go ahead and do the insertion

               elsif P = Wrapped_Node then
                  Store_Before_Actions_In_Scope (Ins_Actions);
                  return;

               else
                  Insert_List_Before_And_Analyze (P, Ins_Actions);
                  return;
               end if;

            --  A special case, N_Raise_xxx_Error can act either as a statement
            --  or a subexpression. We tell the difference by looking at the
            --  Etype. It is set to Standard_Void_Type in the statement case.

            when
               N_Raise_xxx_Error =>
                  if Etype (P) = Standard_Void_Type then
                     if  P = Wrapped_Node then
                        Store_Before_Actions_In_Scope (Ins_Actions);
                     else
                        Insert_List_Before_And_Analyze (P, Ins_Actions);
                     end if;

                     return;

                  --  In the subexpression case, keep climbing

                  else
                     null;
                  end if;

            --  If a component association appears within a loop created for
            --  an array aggregate, attach the actions to the association so
            --  they can be subsequently inserted within the loop. For other
            --  component associations insert outside of the aggregate. For
            --  an association that will generate a loop, its Loop_Actions
            --  attribute is already initialized (see exp_aggr.adb).

            --  The list of loop_actions can in turn generate additional ones,
            --  that are inserted before the associated node. If the associated
            --  node is outside the aggregate, the new actions are collected
            --  at the end of the loop actions, to respect the order in which
            --  they are to be elaborated.

            when
               N_Component_Association =>
                  if Nkind (Parent (P)) = N_Aggregate
                    and then Present (Loop_Actions (P))
                  then
                     if Is_Empty_List (Loop_Actions (P)) then
                        Set_Loop_Actions (P, Ins_Actions);
                        Analyze_List (Ins_Actions);

                     else
                        declare
                           Decl : Node_Id;

                        begin
                           --  Check whether these actions were generated by a
                           --  declaration that is part of the loop_ actions
                           --  for the component_association.

                           Decl := Assoc_Node;
                           while Present (Decl) loop
                              exit when Parent (Decl) = P
                                and then Is_List_Member (Decl)
                                and then
                                  List_Containing (Decl) = Loop_Actions (P);
                              Decl := Parent (Decl);
                           end loop;

                           if Present (Decl) then
                              Insert_List_Before_And_Analyze
                                (Decl, Ins_Actions);
                           else
                              Insert_List_After_And_Analyze
                                (Last (Loop_Actions (P)), Ins_Actions);
                           end if;
                        end;
                     end if;

                     return;

                  else
                     null;
                  end if;

            --  Another special case, an attribute denoting a procedure call

            when
               N_Attribute_Reference =>
                  if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
                     if P = Wrapped_Node then
                        Store_Before_Actions_In_Scope (Ins_Actions);
                     else
                        Insert_List_Before_And_Analyze (P, Ins_Actions);
                     end if;

                     return;

                  --  In the subexpression case, keep climbing

                  else
                     null;
                  end if;

            --  A contract node should not belong to the tree

            when N_Contract =>
               raise Program_Error;

            --  For all other node types, keep climbing tree

            when
               N_Abortable_Part                         |
               N_Accept_Alternative                     |
               N_Access_Definition                      |
               N_Access_Function_Definition             |
               N_Access_Procedure_Definition            |
               N_Access_To_Object_Definition            |
               N_Aggregate                              |
               N_Allocator                              |
               N_Aspect_Specification                   |
               N_Case_Expression                        |
               N_Case_Statement_Alternative             |
               N_Character_Literal                      |
               N_Compilation_Unit                       |
               N_Compilation_Unit_Aux                   |
               N_Component_Clause                       |
               N_Component_Declaration                  |
               N_Component_Definition                   |
               N_Component_List                         |
               N_Constrained_Array_Definition           |
               N_Decimal_Fixed_Point_Definition         |
               N_Defining_Character_Literal             |
               N_Defining_Identifier                    |
               N_Defining_Operator_Symbol               |
               N_Defining_Program_Unit_Name             |
               N_Delay_Alternative                      |
               N_Delta_Constraint                       |
               N_Derived_Type_Definition                |
               N_Designator                             |
               N_Digits_Constraint                      |
               N_Discriminant_Association               |
               N_Discriminant_Specification             |
               N_Empty                                  |
               N_Entry_Body_Formal_Part                 |
               N_Entry_Call_Alternative                 |
               N_Entry_Declaration                      |
               N_Entry_Index_Specification              |
               N_Enumeration_Type_Definition            |
               N_Error                                  |
               N_Exception_Handler                      |
               N_Expanded_Name                          |
               N_Explicit_Dereference                   |
               N_Extension_Aggregate                    |
               N_Floating_Point_Definition              |
               N_Formal_Decimal_Fixed_Point_Definition  |
               N_Formal_Derived_Type_Definition         |
               N_Formal_Discrete_Type_Definition        |
               N_Formal_Floating_Point_Definition       |
               N_Formal_Modular_Type_Definition         |
               N_Formal_Ordinary_Fixed_Point_Definition |
               N_Formal_Package_Declaration             |
               N_Formal_Private_Type_Definition         |
               N_Formal_Incomplete_Type_Definition      |
               N_Formal_Signed_Integer_Type_Definition  |
               N_Function_Call                          |
               N_Function_Specification                 |
               N_Generic_Association                    |
               N_Handled_Sequence_Of_Statements         |
               N_Identifier                             |
               N_In                                     |
               N_Index_Or_Discriminant_Constraint       |
               N_Indexed_Component                      |
               N_Integer_Literal                        |
               N_Iterator_Specification                 |
               N_Itype_Reference                        |
               N_Label                                  |
               N_Loop_Parameter_Specification           |
               N_Mod_Clause                             |
               N_Modular_Type_Definition                |
               N_Not_In                                 |
               N_Null                                   |
               N_Op_Abs                                 |
               N_Op_Add                                 |
               N_Op_And                                 |
               N_Op_Concat                              |
               N_Op_Divide                              |
               N_Op_Eq                                  |
               N_Op_Expon                               |
               N_Op_Ge                                  |
               N_Op_Gt                                  |
               N_Op_Le                                  |
               N_Op_Lt                                  |
               N_Op_Minus                               |
               N_Op_Mod                                 |
               N_Op_Multiply                            |
               N_Op_Ne                                  |
               N_Op_Not                                 |
               N_Op_Or                                  |
               N_Op_Plus                                |
               N_Op_Rem                                 |
               N_Op_Rotate_Left                         |
               N_Op_Rotate_Right                        |
               N_Op_Shift_Left                          |
               N_Op_Shift_Right                         |
               N_Op_Shift_Right_Arithmetic              |
               N_Op_Subtract                            |
               N_Op_Xor                                 |
               N_Operator_Symbol                        |
               N_Ordinary_Fixed_Point_Definition        |
               N_Others_Choice                          |
               N_Package_Specification                  |
               N_Parameter_Association                  |
               N_Parameter_Specification                |
               N_Pop_Constraint_Error_Label             |
               N_Pop_Program_Error_Label                |
               N_Pop_Storage_Error_Label                |
               N_Pragma_Argument_Association            |
               N_Procedure_Specification                |
               N_Protected_Definition                   |
               N_Push_Constraint_Error_Label            |
               N_Push_Program_Error_Label               |
               N_Push_Storage_Error_Label               |
               N_Qualified_Expression                   |
               N_Quantified_Expression                  |
               N_Raise_Expression                       |
               N_Range                                  |
               N_Range_Constraint                       |
               N_Real_Literal                           |
               N_Real_Range_Specification               |
               N_Record_Definition                      |
               N_Reference                              |
               N_SCIL_Dispatch_Table_Tag_Init           |
               N_SCIL_Dispatching_Call                  |
               N_SCIL_Membership_Test                   |
               N_Selected_Component                     |
               N_Signed_Integer_Type_Definition         |
               N_Single_Protected_Declaration           |
               N_Slice                                  |
               N_String_Literal                         |
               N_Subprogram_Info                        |
               N_Subtype_Indication                     |
               N_Subunit                                |
               N_Task_Definition                        |
               N_Terminate_Alternative                  |
               N_Triggering_Alternative                 |
               N_Type_Conversion                        |
               N_Unchecked_Expression                   |
               N_Unchecked_Type_Conversion              |
               N_Unconstrained_Array_Definition         |
               N_Unused_At_End                          |
               N_Unused_At_Start                        |
               N_Variant                                |
               N_Variant_Part                           |
               N_Validate_Unchecked_Conversion          |
               N_With_Clause
            =>
               null;

         end case;

         --  If we fall through above tests, keep climbing tree

         N := P;

         if Nkind (Parent (N)) = N_Subunit then

            --  This is the proper body corresponding to a stub. Insertion must
            --  be done at the point of the stub, which is in the declarative
            --  part of the parent unit.

            P := Corresponding_Stub (Parent (N));

         else
            P := Parent (N);
         end if;
      end loop;
   end Insert_Actions;

   --  Version with check(s) suppressed

   procedure Insert_Actions
     (Assoc_Node  : Node_Id;
      Ins_Actions : List_Id;
      Suppress    : Check_Id)
   is
   begin
      if Suppress = All_Checks then
         declare
            Sva : constant Suppress_Array := Scope_Suppress.Suppress;
         begin
            Scope_Suppress.Suppress := (others => True);
            Insert_Actions (Assoc_Node, Ins_Actions);
            Scope_Suppress.Suppress := Sva;
         end;

      else
         declare
            Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
         begin
            Scope_Suppress.Suppress (Suppress) := True;
            Insert_Actions (Assoc_Node, Ins_Actions);
            Scope_Suppress.Suppress (Suppress) := Svg;
         end;
      end if;
   end Insert_Actions;

   --------------------------
   -- Insert_Actions_After --
   --------------------------

   procedure Insert_Actions_After
     (Assoc_Node  : Node_Id;
      Ins_Actions : List_Id)
   is
   begin
      if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
         Store_After_Actions_In_Scope (Ins_Actions);
      else
         Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
      end if;
   end Insert_Actions_After;

   ---------------------------------
   -- Insert_Library_Level_Action --
   ---------------------------------

   procedure Insert_Library_Level_Action (N : Node_Id) is
      Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));

   begin
      Push_Scope (Cunit_Entity (Main_Unit));
      --  ??? should this be Current_Sem_Unit instead of Main_Unit?

      if No (Actions (Aux)) then
         Set_Actions (Aux, New_List (N));
      else
         Append (N, Actions (Aux));
      end if;

      Analyze (N);
      Pop_Scope;
   end Insert_Library_Level_Action;

   ----------------------------------
   -- Insert_Library_Level_Actions --
   ----------------------------------

   procedure Insert_Library_Level_Actions (L : List_Id) is
      Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));

   begin
      if Is_Non_Empty_List (L) then
         Push_Scope (Cunit_Entity (Main_Unit));
         --  ??? should this be Current_Sem_Unit instead of Main_Unit?

         if No (Actions (Aux)) then
            Set_Actions (Aux, L);
            Analyze_List (L);
         else
            Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
         end if;

         Pop_Scope;
      end if;
   end Insert_Library_Level_Actions;

   ----------------------
   -- Inside_Init_Proc --
   ----------------------

   function Inside_Init_Proc return Boolean is
      S : Entity_Id;

   begin
      S := Current_Scope;
      while Present (S) and then S /= Standard_Standard loop
         if Is_Init_Proc (S) then
            return True;
         else
            S := Scope (S);
         end if;
      end loop;

      return False;
   end Inside_Init_Proc;

   ----------------------------
   -- Is_All_Null_Statements --
   ----------------------------

   function Is_All_Null_Statements (L : List_Id) return Boolean is
      Stm : Node_Id;

   begin
      Stm := First (L);
      while Present (Stm) loop
         if Nkind (Stm) /= N_Null_Statement then
            return False;
         end if;

         Next (Stm);
      end loop;

      return True;
   end Is_All_Null_Statements;

   --------------------------------------------------
   -- Is_Displacement_Of_Object_Or_Function_Result --
   --------------------------------------------------

   function Is_Displacement_Of_Object_Or_Function_Result
     (Obj_Id : Entity_Id) return Boolean
   is
      function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
      --  Determine if particular node denotes a controlled function call

      function Is_Displace_Call (N : Node_Id) return Boolean;
      --  Determine whether a particular node is a call to Ada.Tags.Displace.
      --  The call might be nested within other actions such as conversions.

      function Is_Source_Object (N : Node_Id) return Boolean;
      --  Determine whether a particular node denotes a source object

      ---------------------------------
      -- Is_Controlled_Function_Call --
      ---------------------------------

      function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
         Expr : Node_Id := Original_Node (N);

      begin
         if Nkind (Expr) = N_Function_Call then
            Expr := Name (Expr);
         end if;

         --  The function call may appear in object.operation format

         if Nkind (Expr) = N_Selected_Component then
            Expr := Selector_Name (Expr);
         end if;

         return
           Nkind_In (Expr, N_Expanded_Name, N_Identifier)
             and then Ekind (Entity (Expr)) = E_Function
             and then Needs_Finalization (Etype (Entity (Expr)));
      end Is_Controlled_Function_Call;

      ----------------------
      -- Is_Displace_Call --
      ----------------------

      function Is_Displace_Call (N : Node_Id) return Boolean is
         Call : Node_Id := N;

      begin
         --  Strip various actions which may precede a call to Displace

         loop
            if Nkind (Call) = N_Explicit_Dereference then
               Call := Prefix (Call);

            elsif Nkind_In (Call, N_Type_Conversion,
                                  N_Unchecked_Type_Conversion)
            then
               Call := Expression (Call);

            else
               exit;
            end if;
         end loop;

         return
           Present (Call)
             and then Nkind (Call) = N_Function_Call
             and then Is_RTE (Entity (Name (Call)), RE_Displace);
      end Is_Displace_Call;

      ----------------------
      -- Is_Source_Object --
      ----------------------

      function Is_Source_Object (N : Node_Id) return Boolean is
      begin
         return
           Present (N)
             and then Nkind (N) in N_Has_Entity
             and then Is_Object (Entity (N))
             and then Comes_From_Source (N);
      end Is_Source_Object;

      --  Local variables

      Decl      : constant Node_Id   := Parent (Obj_Id);
      Obj_Typ   : constant Entity_Id := Base_Type (Etype (Obj_Id));
      Orig_Decl : constant Node_Id   := Original_Node (Decl);

   --  Start of processing for Is_Displacement_Of_Object_Or_Function_Result

   begin
      --  Case 1:

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

      --  rewritten into:

      --     Tmp : ... := Function_Call (...)'reference;
      --     Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));

      --  where the return type of the function and the class-wide type require
      --  dispatch table pointer displacement.

      --  Case 2:

      --     Obj : CW_Type := Src_Obj;

      --  rewritten into:

      --     Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));

      --  where the type of the source object and the class-wide type require
      --  dispatch table pointer displacement.

      return
        Nkind (Decl) = N_Object_Renaming_Declaration
          and then Nkind (Orig_Decl) = N_Object_Declaration
          and then Comes_From_Source (Orig_Decl)
          and then Is_Class_Wide_Type (Obj_Typ)
          and then Is_Displace_Call (Renamed_Object (Obj_Id))
          and then
            (Is_Controlled_Function_Call (Expression (Orig_Decl))
              or else Is_Source_Object (Expression (Orig_Decl)));
   end Is_Displacement_Of_Object_Or_Function_Result;

   ------------------------------
   -- Is_Finalizable_Transient --
   ------------------------------

   function Is_Finalizable_Transient
     (Decl     : Node_Id;
      Rel_Node : Node_Id) return Boolean
   is
      Obj_Id  : constant Entity_Id := Defining_Identifier (Decl);
      Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
      Desig   : Entity_Id := Obj_Typ;

      function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
      --  Determine whether transient object Trans_Id is initialized either
      --  by a function call which returns an access type or simply renames
      --  another pointer.

      function Initialized_By_Aliased_BIP_Func_Call
        (Trans_Id : Entity_Id) return Boolean;
      --  Determine whether transient object Trans_Id is initialized by a
      --  build-in-place function call where the BIPalloc parameter is of
      --  value 1 and BIPaccess is not null. This case creates an aliasing
      --  between the returned value and the value denoted by BIPaccess.

      function Is_Aliased
        (Trans_Id   : Entity_Id;
         First_Stmt : Node_Id) return Boolean;
      --  Determine whether transient object Trans_Id has been renamed or
      --  aliased through 'reference in the statement list starting from
      --  First_Stmt.

      function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
      --  Determine whether transient object Trans_Id is allocated on the heap

      function Is_Iterated_Container
        (Trans_Id   : Entity_Id;
         First_Stmt : Node_Id) return Boolean;
      --  Determine whether transient object Trans_Id denotes a container which
      --  is in the process of being iterated in the statement list starting
      --  from First_Stmt.

      ---------------------------
      -- Initialized_By_Access --
      ---------------------------

      function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
         Expr : constant Node_Id := Expression (Parent (Trans_Id));

      begin
         return
           Present (Expr)
             and then Nkind (Expr) /= N_Reference
             and then Is_Access_Type (Etype (Expr));
      end Initialized_By_Access;

      ------------------------------------------
      -- Initialized_By_Aliased_BIP_Func_Call --
      ------------------------------------------

      function Initialized_By_Aliased_BIP_Func_Call
        (Trans_Id : Entity_Id) return Boolean
      is
         Call : Node_Id := Expression (Parent (Trans_Id));

      begin
         --  Build-in-place calls usually appear in 'reference format

         if Nkind (Call) = N_Reference then
            Call := Prefix (Call);
         end if;

         if Is_Build_In_Place_Function_Call (Call) then
            declare
               Access_Nam : Name_Id := No_Name;
               Access_OK  : Boolean := False;
               Actual     : Node_Id;
               Alloc_Nam  : Name_Id := No_Name;
               Alloc_OK   : Boolean := False;
               Formal     : Node_Id;
               Func_Id    : Entity_Id;
               Param      : Node_Id;

            begin
               --  Examine all parameter associations of the function call

               Param := First (Parameter_Associations (Call));
               while Present (Param) loop
                  if Nkind (Param) = N_Parameter_Association
                    and then Nkind (Selector_Name (Param)) = N_Identifier
                  then
                     Actual := Explicit_Actual_Parameter (Param);
                     Formal := Selector_Name (Param);

                     --  Construct the names of formals BIPaccess and BIPalloc
                     --  using the function name retrieved from an arbitrary
                     --  formal.

                     if Access_Nam = No_Name
                       and then Alloc_Nam = No_Name
                       and then Present (Entity (Formal))
                     then
                        Func_Id := Scope (Entity (Formal));

                        Access_Nam :=
                          New_External_Name (Chars (Func_Id),
                            BIP_Formal_Suffix (BIP_Object_Access));

                        Alloc_Nam :=
                          New_External_Name (Chars (Func_Id),
                            BIP_Formal_Suffix (BIP_Alloc_Form));
                     end if;

                     --  A match for BIPaccess => Temp has been found

                     if Chars (Formal) = Access_Nam
                       and then Nkind (Actual) /= N_Null
                     then
                        Access_OK := True;
                     end if;

                     --  A match for BIPalloc => 1 has been found

                     if Chars (Formal) = Alloc_Nam
                       and then Nkind (Actual) = N_Integer_Literal
                       and then Intval (Actual) = Uint_1
                     then
                        Alloc_OK := True;
                     end if;
                  end if;

                  Next (Param);
               end loop;

               return Access_OK and Alloc_OK;
            end;
         end if;

         return False;
      end Initialized_By_Aliased_BIP_Func_Call;

      ----------------
      -- Is_Aliased --
      ----------------

      function Is_Aliased
        (Trans_Id   : Entity_Id;
         First_Stmt : Node_Id) return Boolean
      is
         function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
         --  Given an object renaming declaration, retrieve the entity of the
         --  renamed name. Return Empty if the renamed name is anything other
         --  than a variable or a constant.

         -------------------------
         -- Find_Renamed_Object --
         -------------------------

         function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
            Ren_Obj : Node_Id := Empty;

            function Find_Object (N : Node_Id) return Traverse_Result;
            --  Try to detect an object which is either a constant or a
            --  variable.

            -----------------
            -- Find_Object --
            -----------------

            function Find_Object (N : Node_Id) return Traverse_Result is
            begin
               --  Stop the search once a constant or a variable has been
               --  detected.

               if Nkind (N) = N_Identifier
                 and then Present (Entity (N))
                 and then Ekind_In (Entity (N), E_Constant, E_Variable)
               then
                  Ren_Obj := Entity (N);
                  return Abandon;
               end if;

               return OK;
            end Find_Object;

            procedure Search is new Traverse_Proc (Find_Object);

            --  Local variables

            Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));

         --  Start of processing for Find_Renamed_Object

         begin
            --  Actions related to dispatching calls may appear as renamings of
            --  tags. Do not process this type of renaming because it does not
            --  use the actual value of the object.

            if not Is_RTE (Typ, RE_Tag_Ptr) then
               Search (Name (Ren_Decl));
            end if;

            return Ren_Obj;
         end Find_Renamed_Object;

         --  Local variables

         Expr    : Node_Id;
         Ren_Obj : Entity_Id;
         Stmt    : Node_Id;

      --  Start of processing for Is_Aliased

      begin
         Stmt := First_Stmt;
         while Present (Stmt) loop
            if Nkind (Stmt) = N_Object_Declaration then
               Expr := Expression (Stmt);

               if Present (Expr)
                 and then Nkind (Expr) = N_Reference
                 and then Nkind (Prefix (Expr)) = N_Identifier
                 and then Entity (Prefix (Expr)) = Trans_Id
               then
                  return True;
               end if;

            elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
               Ren_Obj := Find_Renamed_Object (Stmt);

               if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
                  return True;
               end if;
            end if;

            Next (Stmt);
         end loop;

         return False;
      end Is_Aliased;

      ------------------
      -- Is_Allocated --
      ------------------

      function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
         Expr : constant Node_Id := Expression (Parent (Trans_Id));
      begin
         return
           Is_Access_Type (Etype (Trans_Id))
             and then Present (Expr)
             and then Nkind (Expr) = N_Allocator;
      end Is_Allocated;

      ---------------------------
      -- Is_Iterated_Container --
      ---------------------------

      function Is_Iterated_Container
        (Trans_Id   : Entity_Id;
         First_Stmt : Node_Id) return Boolean
      is
         Aspect : Node_Id;
         Call   : Node_Id;
         Iter   : Entity_Id;
         Param  : Node_Id;
         Stmt   : Node_Id;
         Typ    : Entity_Id;

      begin
         --  It is not possible to iterate over containers in non-Ada 2012 code

         if Ada_Version < Ada_2012 then
            return False;
         end if;

         Typ := Etype (Trans_Id);

         --  Handle access type created for secondary stack use

         if Is_Access_Type (Typ) then
            Typ := Designated_Type (Typ);
         end if;

         --  Look for aspect Default_Iterator

         if Has_Aspects (Parent (Typ)) then
            Aspect := Find_Aspect (Typ, Aspect_Default_Iterator);

            if Present (Aspect) then
               Iter := Entity (Aspect);

               --  Examine the statements following the container object and
               --  look for a call to the default iterate routine where the
               --  first parameter is the transient. Such a call appears as:

               --     It : Access_To_CW_Iterator :=
               --            Iterate (Tran_Id.all, ...)'reference;

               Stmt := First_Stmt;
               while Present (Stmt) loop

                  --  Detect an object declaration which is initialized by a
                  --  secondary stack function call.

                  if Nkind (Stmt) = N_Object_Declaration
                    and then Present (Expression (Stmt))
                    and then Nkind (Expression (Stmt)) = N_Reference
                    and then Nkind (Prefix (Expression (Stmt))) =
                               N_Function_Call
                  then
                     Call := Prefix (Expression (Stmt));

                     --  The call must invoke the default iterate routine of
                     --  the container and the transient object must appear as
                     --  the first actual parameter. Skip any calls whose names
                     --  are not entities.

                     if Is_Entity_Name (Name (Call))
                       and then Entity (Name (Call)) = Iter
                       and then Present (Parameter_Associations (Call))
                     then
                        Param := First (Parameter_Associations (Call));

                        if Nkind (Param) = N_Explicit_Dereference
                          and then Entity (Prefix (Param)) = Trans_Id
                        then
                           return True;
                        end if;
                     end if;
                  end if;

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

         return False;
      end Is_Iterated_Container;

   --  Start of processing for Is_Finalizable_Transient

   begin
      --  Handle access types

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

      return
        Ekind_In (Obj_Id, E_Constant, E_Variable)
          and then Needs_Finalization (Desig)
          and then Requires_Transient_Scope (Desig)
          and then Nkind (Rel_Node) /= N_Simple_Return_Statement

          --  Do not consider renamed or 'reference-d transient objects because
          --  the act of renaming extends the object's lifetime.

          and then not Is_Aliased (Obj_Id, Decl)

          --  Do not consider transient objects allocated on the heap since
          --  they are attached to a finalization master.

          and then not Is_Allocated (Obj_Id)

          --  If the transient object is a pointer, check that it is not
          --  initialized by a function which returns a pointer or acts as a
          --  renaming of another pointer.

          and then
            (not Is_Access_Type (Obj_Typ)
               or else not Initialized_By_Access (Obj_Id))

          --  Do not consider transient objects which act as indirect aliases
          --  of build-in-place function results.

          and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)

          --  Do not consider conversions of tags to class-wide types

          and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)

          --  Do not consider containers in the context of iterator loops. Such
          --  transient objects must exist for as long as the loop is around,
          --  otherwise any operation carried out by the iterator will fail.

          and then not Is_Iterated_Container (Obj_Id, Decl);
   end Is_Finalizable_Transient;

   ---------------------------------
   -- Is_Fully_Repped_Tagged_Type --
   ---------------------------------

   function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
      U    : constant Entity_Id := Underlying_Type (T);
      Comp : Entity_Id;

   begin
      if No (U) or else not Is_Tagged_Type (U) then
         return False;
      elsif Has_Discriminants (U) then
         return False;
      elsif not Has_Specified_Layout (U) then
         return False;
      end if;

      --  Here we have a tagged type, see if it has any unlayed out fields
      --  other than a possible tag and parent fields. If so, we return False.

      Comp := First_Component (U);
      while Present (Comp) loop
         if not Is_Tag (Comp)
           and then Chars (Comp) /= Name_uParent
           and then No (Component_Clause (Comp))
         then
            return False;
         else
            Next_Component (Comp);
         end if;
      end loop;

      --  All components are layed out

      return True;
   end Is_Fully_Repped_Tagged_Type;

   ----------------------------------
   -- Is_Library_Level_Tagged_Type --
   ----------------------------------

   function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
   begin
      return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
   end Is_Library_Level_Tagged_Type;

   --------------------------
   -- Is_Non_BIP_Func_Call --
   --------------------------

   function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
   begin
      --  The expected call is of the format
      --
      --    Func_Call'reference

      return
        Nkind (Expr) = N_Reference
          and then Nkind (Prefix (Expr)) = N_Function_Call
          and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
   end Is_Non_BIP_Func_Call;

   ----------------------------------
   -- Is_Possibly_Unaligned_Object --
   ----------------------------------

   function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
      T  : constant Entity_Id := Etype (N);

   begin
      --  If renamed object, apply test to underlying object

      if Is_Entity_Name (N)
        and then Is_Object (Entity (N))
        and then Present (Renamed_Object (Entity (N)))
      then
         return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
      end if;

      --  Tagged and controlled types and aliased types are always aligned, as
      --  are concurrent types.

      if Is_Aliased (T)
        or else Has_Controlled_Component (T)
        or else Is_Concurrent_Type (T)
        or else Is_Tagged_Type (T)
        or else Is_Controlled (T)
      then
         return False;
      end if;

      --  If this is an element of a packed array, may be unaligned

      if Is_Ref_To_Bit_Packed_Array (N) then
         return True;
      end if;

      --  Case of indexed component reference: test whether prefix is unaligned

      if Nkind (N) = N_Indexed_Component then
         return Is_Possibly_Unaligned_Object (Prefix (N));

      --  Case of selected component reference

      elsif Nkind (N) = N_Selected_Component then
         declare
            P : constant Node_Id   := Prefix (N);
            C : constant Entity_Id := Entity (Selector_Name (N));
            M : Nat;
            S : Nat;

         begin
            --  If component reference is for an array with non-static bounds,
            --  then it is always aligned: we can only process unaligned arrays
            --  with static bounds (more precisely compile time known bounds).

            if Is_Array_Type (T)
              and then not Compile_Time_Known_Bounds (T)
            then
               return False;
            end if;

            --  If component is aliased, it is definitely properly aligned

            if Is_Aliased (C) then
               return False;
            end if;

            --  If component is for a type implemented as a scalar, and the
            --  record is packed, and the component is other than the first
            --  component of the record, then the component may be unaligned.

            if Is_Packed (Etype (P))
              and then Represented_As_Scalar (Etype (C))
              and then First_Entity (Scope (C)) /= C
            then
               return True;
            end if;

            --  Compute maximum possible alignment for T

            --  If alignment is known, then that settles things

            if Known_Alignment (T) then
               M := UI_To_Int (Alignment (T));

            --  If alignment is not known, tentatively set max alignment

            else
               M := Ttypes.Maximum_Alignment;

               --  We can reduce this if the Esize is known since the default
               --  alignment will never be more than the smallest power of 2
               --  that does not exceed this Esize value.

               if Known_Esize (T) then
                  S := UI_To_Int (Esize (T));

                  while (M / 2) >= S loop
                     M := M / 2;
                  end loop;
               end if;
            end if;

            --  The following code is historical, it used to be present but it
            --  is too cautious, because the front-end does not know the proper
            --  default alignments for the target. Also, if the alignment is
            --  not known, the front end can't know in any case! If a copy is
            --  needed, the back-end will take care of it. This whole section
            --  including this comment can be removed later ???

            --  If the component reference is for a record that has a specified
            --  alignment, and we either know it is too small, or cannot tell,
            --  then the component may be unaligned.

            --  What is the following commented out code ???

            --  if Known_Alignment (Etype (P))
            --    and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
            --    and then M > Alignment (Etype (P))
            --  then
            --     return True;
            --  end if;

            --  Case of component clause present which may specify an
            --  unaligned position.

            if Present (Component_Clause (C)) then

               --  Otherwise we can do a test to make sure that the actual
               --  start position in the record, and the length, are both
               --  consistent with the required alignment. If not, we know
               --  that we are unaligned.

               declare
                  Align_In_Bits : constant Nat := M * System_Storage_Unit;
               begin
                  if Component_Bit_Offset (C) mod Align_In_Bits /= 0
                    or else Esize (C) mod Align_In_Bits /= 0
                  then
                     return True;
                  end if;
               end;
            end if;

            --  Otherwise, for a component reference, test prefix

            return Is_Possibly_Unaligned_Object (P);
         end;

      --  If not a component reference, must be aligned

      else
         return False;
      end if;
   end Is_Possibly_Unaligned_Object;

   ---------------------------------
   -- Is_Possibly_Unaligned_Slice --
   ---------------------------------

   function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
   begin
      --  Go to renamed object

      if Is_Entity_Name (N)
        and then Is_Object (Entity (N))
        and then Present (Renamed_Object (Entity (N)))
      then
         return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
      end if;

      --  The reference must be a slice

      if Nkind (N) /= N_Slice then
         return False;
      end if;

      --  Always assume the worst for a nested record component with a
      --  component clause, which gigi/gcc does not appear to handle well.
      --  It is not clear why this special test is needed at all ???

      if Nkind (Prefix (N)) = N_Selected_Component
        and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
        and then
          Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
      then
         return True;
      end if;

      --  We only need to worry if the target has strict alignment

      if not Target_Strict_Alignment then
         return False;
      end if;

      --  If it is a slice, then look at the array type being sliced

      declare
         Sarr : constant Node_Id := Prefix (N);
         --  Prefix of the slice, i.e. the array being sliced

         Styp : constant Entity_Id := Etype (Prefix (N));
         --  Type of the array being sliced

         Pref : Node_Id;
         Ptyp : Entity_Id;

      begin
         --  The problems arise if the array object that is being sliced
         --  is a component of a record or array, and we cannot guarantee
         --  the alignment of the array within its containing object.

         --  To investigate this, we look at successive prefixes to see
         --  if we have a worrisome indexed or selected component.

         Pref := Sarr;
         loop
            --  Case of array is part of an indexed component reference

            if Nkind (Pref) = N_Indexed_Component then
               Ptyp := Etype (Prefix (Pref));

               --  The only problematic case is when the array is packed, in
               --  which case we really know nothing about the alignment of
               --  individual components.

               if Is_Bit_Packed_Array (Ptyp) then
                  return True;
               end if;

            --  Case of array is part of a selected component reference

            elsif Nkind (Pref) = N_Selected_Component then
               Ptyp := Etype (Prefix (Pref));

               --  We are definitely in trouble if the record in question
               --  has an alignment, and either we know this alignment is
               --  inconsistent with the alignment of the slice, or we don't
               --  know what the alignment of the slice should be.

               if Known_Alignment (Ptyp)
                 and then (Unknown_Alignment (Styp)
                            or else Alignment (Styp) > Alignment (Ptyp))
               then
                  return True;
               end if;

               --  We are in potential trouble if the record type is packed.
               --  We could special case when we know that the array is the
               --  first component, but that's not such a simple case ???

               if Is_Packed (Ptyp) then
                  return True;
               end if;

               --  We are in trouble if there is a component clause, and
               --  either we do not know the alignment of the slice, or
               --  the alignment of the slice is inconsistent with the
               --  bit position specified by the component clause.

               declare
                  Field : constant Entity_Id := Entity (Selector_Name (Pref));
               begin
                  if Present (Component_Clause (Field))
                    and then
                      (Unknown_Alignment (Styp)
                        or else
                         (Component_Bit_Offset (Field) mod
                           (System_Storage_Unit * Alignment (Styp))) /= 0)
                  then
                     return True;
                  end if;
               end;

            --  For cases other than selected or indexed components we know we
            --  are OK, since no issues arise over alignment.

            else
               return False;
            end if;

            --  We processed an indexed component or selected component
            --  reference that looked safe, so keep checking prefixes.

            Pref := Prefix (Pref);
         end loop;
      end;
   end Is_Possibly_Unaligned_Slice;

   -------------------------------
   -- Is_Related_To_Func_Return --
   -------------------------------

   function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
      Expr : constant Node_Id := Related_Expression (Id);
   begin
      return
        Present (Expr)
          and then Nkind (Expr) = N_Explicit_Dereference
          and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
   end Is_Related_To_Func_Return;

   --------------------------------
   -- Is_Ref_To_Bit_Packed_Array --
   --------------------------------

   function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
      Result : Boolean;
      Expr   : Node_Id;

   begin
      if Is_Entity_Name (N)
        and then Is_Object (Entity (N))
        and then Present (Renamed_Object (Entity (N)))
      then
         return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
      end if;

      if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
         if Is_Bit_Packed_Array (Etype (Prefix (N))) then
            Result := True;
         else
            Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
         end if;

         if Result and then Nkind (N) = N_Indexed_Component then
            Expr := First (Expressions (N));
            while Present (Expr) loop
               Force_Evaluation (Expr);
               Next (Expr);
            end loop;
         end if;

         return Result;

      else
         return False;
      end if;
   end Is_Ref_To_Bit_Packed_Array;

   --------------------------------
   -- Is_Ref_To_Bit_Packed_Slice --
   --------------------------------

   function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
   begin
      if Nkind (N) = N_Type_Conversion then
         return Is_Ref_To_Bit_Packed_Slice (Expression (N));

      elsif Is_Entity_Name (N)
        and then Is_Object (Entity (N))
        and then Present (Renamed_Object (Entity (N)))
      then
         return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));

      elsif Nkind (N) = N_Slice
        and then Is_Bit_Packed_Array (Etype (Prefix (N)))
      then
         return True;

      elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
         return Is_Ref_To_Bit_Packed_Slice (Prefix (N));

      else
         return False;
      end if;
   end Is_Ref_To_Bit_Packed_Slice;

   -----------------------
   -- Is_Renamed_Object --
   -----------------------

   function Is_Renamed_Object (N : Node_Id) return Boolean is
      Pnod : constant Node_Id   := Parent (N);
      Kind : constant Node_Kind := Nkind (Pnod);
   begin
      if Kind = N_Object_Renaming_Declaration then
         return True;
      elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
         return Is_Renamed_Object (Pnod);
      else
         return False;
      end if;
   end Is_Renamed_Object;

   --------------------------------------
   -- Is_Secondary_Stack_BIP_Func_Call --
   --------------------------------------

   function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
      Call : Node_Id := Expr;

   begin
      --  Build-in-place calls usually appear in 'reference format. Note that
      --  the accessibility check machinery may add an extra 'reference due to
      --  side effect removal.

      while Nkind (Call) = N_Reference loop
         Call := Prefix (Call);
      end loop;

      if Nkind_In (Call, N_Qualified_Expression,
                         N_Unchecked_Type_Conversion)
      then
         Call := Expression (Call);
      end if;

      if Is_Build_In_Place_Function_Call (Call) then
         declare
            Access_Nam : Name_Id := No_Name;
            Actual     : Node_Id;
            Param      : Node_Id;
            Formal     : Node_Id;

         begin
            --  Examine all parameter associations of the function call

            Param := First (Parameter_Associations (Call));
            while Present (Param) loop
               if Nkind (Param) = N_Parameter_Association
                 and then Nkind (Selector_Name (Param)) = N_Identifier
               then
                  Formal := Selector_Name (Param);
                  Actual := Explicit_Actual_Parameter (Param);

                  --  Construct the name of formal BIPalloc. It is much easier
                  --  to extract the name of the function using an arbitrary
                  --  formal's scope rather than the Name field of Call.

                  if Access_Nam = No_Name
                    and then Present (Entity (Formal))
                  then
                     Access_Nam :=
                       New_External_Name
                         (Chars (Scope (Entity (Formal))),
                          BIP_Formal_Suffix (BIP_Alloc_Form));
                  end if;

                  --  A match for BIPalloc => 2 has been found

                  if Chars (Formal) = Access_Nam
                    and then Nkind (Actual) = N_Integer_Literal
                    and then Intval (Actual) = Uint_2
                  then
                     return True;
                  end if;
               end if;

               Next (Param);
            end loop;
         end;
      end if;

      return False;
   end Is_Secondary_Stack_BIP_Func_Call;

   -------------------------------------
   -- Is_Tag_To_Class_Wide_Conversion --
   -------------------------------------

   function Is_Tag_To_Class_Wide_Conversion
     (Obj_Id : Entity_Id) return Boolean
   is
      Expr : constant Node_Id := Expression (Parent (Obj_Id));

   begin
      return
        Is_Class_Wide_Type (Etype (Obj_Id))
          and then Present (Expr)
          and then Nkind (Expr) = N_Unchecked_Type_Conversion
          and then Etype (Expression (Expr)) = RTE (RE_Tag);
   end Is_Tag_To_Class_Wide_Conversion;

   ----------------------------
   -- Is_Untagged_Derivation --
   ----------------------------

   function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
   begin
      return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
               or else
             (Is_Private_Type (T) and then Present (Full_View (T))
               and then not Is_Tagged_Type (Full_View (T))
               and then Is_Derived_Type (Full_View (T))
               and then Etype (Full_View (T)) /= T);
   end Is_Untagged_Derivation;

   ---------------------------
   -- Is_Volatile_Reference --
   ---------------------------

   function Is_Volatile_Reference (N : Node_Id) return Boolean is
   begin
      if Nkind (N) in N_Has_Etype
        and then Present (Etype (N))
        and then Treat_As_Volatile (Etype (N))
      then
         return True;

      elsif Is_Entity_Name (N) then
         return Treat_As_Volatile (Entity (N));

      elsif Nkind (N) = N_Slice then
         return Is_Volatile_Reference (Prefix (N));

      elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
         if (Is_Entity_Name (Prefix (N))
              and then Has_Volatile_Components (Entity (Prefix (N))))
           or else (Present (Etype (Prefix (N)))
                     and then Has_Volatile_Components (Etype (Prefix (N))))
         then
            return True;
         else
            return Is_Volatile_Reference (Prefix (N));
         end if;

      else
         return False;
      end if;
   end Is_Volatile_Reference;

   --------------------------
   -- Is_VM_By_Copy_Actual --
   --------------------------

   function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
   begin
      return VM_Target /= No_VM
        and then (Nkind (N) = N_Slice
                    or else
                      (Nkind (N) = N_Identifier
                        and then Present (Renamed_Object (Entity (N)))
                        and then Nkind (Renamed_Object (Entity (N))) =
                                                                 N_Slice));
   end Is_VM_By_Copy_Actual;

   --------------------
   -- Kill_Dead_Code --
   --------------------

   procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
      W : Boolean := Warn;
      --  Set False if warnings suppressed

   begin
      if Present (N) then
         Remove_Warning_Messages (N);

         --  Generate warning if appropriate

         if W then

            --  We suppress the warning if this code is under control of an
            --  if statement, whose condition is a simple identifier, and
            --  either we are in an instance, or warnings off is set for this
            --  identifier. The reason for killing it in the instance case is
            --  that it is common and reasonable for code to be deleted in
            --  instances for various reasons.

            if Nkind (Parent (N)) = N_If_Statement then
               declare
                  C : constant Node_Id := Condition (Parent (N));
               begin
                  if Nkind (C) = N_Identifier
                    and then
                      (In_Instance
                        or else (Present (Entity (C))
                                  and then Has_Warnings_Off (Entity (C))))
                  then
                     W := False;
                  end if;
               end;
            end if;

            --  Generate warning if not suppressed

            if W then
               Error_Msg_F
                 ("?t?this code can never be executed and has been deleted!",
                  N);
            end if;
         end if;

         --  Recurse into block statements and bodies to process declarations
         --  and statements.

         if Nkind (N) = N_Block_Statement
           or else Nkind (N) = N_Subprogram_Body
           or else Nkind (N) = N_Package_Body
         then
            Kill_Dead_Code (Declarations (N), False);
            Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));

            if Nkind (N) = N_Subprogram_Body then
               Set_Is_Eliminated (Defining_Entity (N));
            end if;

         elsif Nkind (N) = N_Package_Declaration then
            Kill_Dead_Code (Visible_Declarations (Specification (N)));
            Kill_Dead_Code (Private_Declarations (Specification (N)));

            --  ??? After this point, Delete_Tree has been called on all
            --  declarations in Specification (N), so references to entities
            --  therein look suspicious.

            declare
               E : Entity_Id := First_Entity (Defining_Entity (N));
            begin
               while Present (E) loop
                  if Ekind (E) = E_Operator then
                     Set_Is_Eliminated (E);
                  end if;

                  Next_Entity (E);
               end loop;
            end;

         --  Recurse into composite statement to kill individual statements in
         --  particular instantiations.

         elsif Nkind (N) = N_If_Statement then
            Kill_Dead_Code (Then_Statements (N));
            Kill_Dead_Code (Elsif_Parts (N));
            Kill_Dead_Code (Else_Statements (N));

         elsif Nkind (N) = N_Loop_Statement then
            Kill_Dead_Code (Statements (N));

         elsif Nkind (N) = N_Case_Statement then
            declare
               Alt : Node_Id;
            begin
               Alt := First (Alternatives (N));
               while Present (Alt) loop
                  Kill_Dead_Code (Statements (Alt));
                  Next (Alt);
               end loop;
            end;

         elsif Nkind (N) = N_Case_Statement_Alternative then
            Kill_Dead_Code (Statements (N));

         --  Deal with dead instances caused by deleting instantiations

         elsif Nkind (N) in N_Generic_Instantiation then
            Remove_Dead_Instance (N);
         end if;
      end if;
   end Kill_Dead_Code;

   --  Case where argument is a list of nodes to be killed

   procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
      N : Node_Id;
      W : Boolean;
   begin
      W := Warn;
      if Is_Non_Empty_List (L) then
         N := First (L);
         while Present (N) loop
            Kill_Dead_Code (N, W);
            W := False;
            Next (N);
         end loop;
      end if;
   end Kill_Dead_Code;

   ------------------------
   -- Known_Non_Negative --
   ------------------------

   function Known_Non_Negative (Opnd : Node_Id) return Boolean is
   begin
      if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
         return True;

      else
         declare
            Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
         begin
            return
              Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
         end;
      end if;
   end Known_Non_Negative;

   --------------------
   -- Known_Non_Null --
   --------------------

   function Known_Non_Null (N : Node_Id) return Boolean is
   begin
      --  Checks for case where N is an entity reference

      if Is_Entity_Name (N) and then Present (Entity (N)) then
         declare
            E   : constant Entity_Id := Entity (N);
            Op  : Node_Kind;
            Val : Node_Id;

         begin
            --  First check if we are in decisive conditional

            Get_Current_Value_Condition (N, Op, Val);

            if Known_Null (Val) then
               if Op = N_Op_Eq then
                  return False;
               elsif Op = N_Op_Ne then
                  return True;
               end if;
            end if;

            --  If OK to do replacement, test Is_Known_Non_Null flag

            if OK_To_Do_Constant_Replacement (E) then
               return Is_Known_Non_Null (E);

            --  Otherwise if not safe to do replacement, then say so

            else
               return False;
            end if;
         end;

      --  True if access attribute

      elsif Nkind (N) = N_Attribute_Reference
        and then (Attribute_Name (N) = Name_Access
                    or else
                  Attribute_Name (N) = Name_Unchecked_Access
                    or else
                  Attribute_Name (N) = Name_Unrestricted_Access)
      then
         return True;

      --  True if allocator

      elsif Nkind (N) = N_Allocator then
         return True;

      --  For a conversion, true if expression is known non-null

      elsif Nkind (N) = N_Type_Conversion then
         return Known_Non_Null (Expression (N));

      --  Above are all cases where the value could be determined to be
      --  non-null. In all other cases, we don't know, so return False.

      else
         return False;
      end if;
   end Known_Non_Null;

   ----------------
   -- Known_Null --
   ----------------

   function Known_Null (N : Node_Id) return Boolean is
   begin
      --  Checks for case where N is an entity reference

      if Is_Entity_Name (N) and then Present (Entity (N)) then
         declare
            E   : constant Entity_Id := Entity (N);
            Op  : Node_Kind;
            Val : Node_Id;

         begin
            --  Constant null value is for sure null

            if Ekind (E) = E_Constant
              and then Known_Null (Constant_Value (E))
            then
               return True;
            end if;

            --  First check if we are in decisive conditional

            Get_Current_Value_Condition (N, Op, Val);

            if Known_Null (Val) then
               if Op = N_Op_Eq then
                  return True;
               elsif Op = N_Op_Ne then
                  return False;
               end if;
            end if;

            --  If OK to do replacement, test Is_Known_Null flag

            if OK_To_Do_Constant_Replacement (E) then
               return Is_Known_Null (E);

            --  Otherwise if not safe to do replacement, then say so

            else
               return False;
            end if;
         end;

      --  True if explicit reference to null

      elsif Nkind (N) = N_Null then
         return True;

      --  For a conversion, true if expression is known null

      elsif Nkind (N) = N_Type_Conversion then
         return Known_Null (Expression (N));

      --  Above are all cases where the value could be determined to be null.
      --  In all other cases, we don't know, so return False.

      else
         return False;
      end if;
   end Known_Null;

   -----------------------------
   -- Make_CW_Equivalent_Type --
   -----------------------------

   --  Create a record type used as an equivalent of any member of the class
   --  which takes its size from exp.

   --  Generate the following code:

   --   type Equiv_T is record
   --     _parent :  T (List of discriminant constraints taken from Exp);
   --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
   --   end Equiv_T;
   --
   --   ??? Note that this type does not guarantee same alignment as all
   --   derived types

   function Make_CW_Equivalent_Type
     (T : Entity_Id;
      E : Node_Id) return Entity_Id
   is
      Loc         : constant Source_Ptr := Sloc (E);
      Root_Typ    : constant Entity_Id  := Root_Type (T);
      List_Def    : constant List_Id    := Empty_List;
      Comp_List   : constant List_Id    := New_List;
      Equiv_Type  : Entity_Id;
      Range_Type  : Entity_Id;
      Str_Type    : Entity_Id;
      Constr_Root : Entity_Id;
      Sizexpr     : Node_Id;

   begin
      --  If the root type is already constrained, there are no discriminants
      --  in the expression.

      if not Has_Discriminants (Root_Typ)
        or else Is_Constrained (Root_Typ)
      then
         Constr_Root := Root_Typ;
      else
         Constr_Root := Make_Temporary (Loc, 'R');

         --  subtype cstr__n is T (List of discr constraints taken from Exp)

         Append_To (List_Def,
           Make_Subtype_Declaration (Loc,
             Defining_Identifier => Constr_Root,
             Subtype_Indication  => Make_Subtype_From_Expr (E, Root_Typ)));
      end if;

      --  Generate the range subtype declaration

      Range_Type := Make_Temporary (Loc, 'G');

      if not Is_Interface (Root_Typ) then

         --  subtype rg__xx is
         --    Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit

         Sizexpr :=
           Make_Op_Subtract (Loc,
             Left_Opnd =>
               Make_Attribute_Reference (Loc,
                 Prefix =>
                   OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
                 Attribute_Name => Name_Size),
             Right_Opnd =>
               Make_Attribute_Reference (Loc,
                 Prefix => New_Reference_To (Constr_Root, Loc),
                 Attribute_Name => Name_Object_Size));
      else
         --  subtype rg__xx is
         --    Storage_Offset range 1 .. Expr'size / Storage_Unit

         Sizexpr :=
           Make_Attribute_Reference (Loc,
             Prefix =>
               OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
             Attribute_Name => Name_Size);
      end if;

      Set_Paren_Count (Sizexpr, 1);

      Append_To (List_Def,
        Make_Subtype_Declaration (Loc,
          Defining_Identifier => Range_Type,
          Subtype_Indication =>
            Make_Subtype_Indication (Loc,
              Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
              Constraint => Make_Range_Constraint (Loc,
                Range_Expression =>
                  Make_Range (Loc,
                    Low_Bound => Make_Integer_Literal (Loc, 1),
                    High_Bound =>
                      Make_Op_Divide (Loc,
                        Left_Opnd => Sizexpr,
                        Right_Opnd => Make_Integer_Literal (Loc,
                            Intval => System_Storage_Unit)))))));

      --  subtype str__nn is Storage_Array (rg__x);

      Str_Type := Make_Temporary (Loc, 'S');
      Append_To (List_Def,
        Make_Subtype_Declaration (Loc,
          Defining_Identifier => Str_Type,
          Subtype_Indication =>
            Make_Subtype_Indication (Loc,
              Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
              Constraint =>
                Make_Index_Or_Discriminant_Constraint (Loc,
                  Constraints =>
                    New_List (New_Reference_To (Range_Type, Loc))))));

      --  type Equiv_T is record
      --    [ _parent : Tnn; ]
      --    E : Str_Type;
      --  end Equiv_T;

      Equiv_Type := Make_Temporary (Loc, 'T');
      Set_Ekind (Equiv_Type, E_Record_Type);
      Set_Parent_Subtype (Equiv_Type, Constr_Root);

      --  Set Is_Class_Wide_Equivalent_Type very early to trigger the special
      --  treatment for this type. In particular, even though _parent's type
      --  is a controlled type or contains controlled components, we do not
      --  want to set Has_Controlled_Component on it to avoid making it gain
      --  an unwanted _controller component.

      Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);

      if not Is_Interface (Root_Typ) then
         Append_To (Comp_List,
           Make_Component_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uParent),
             Component_Definition =>
               Make_Component_Definition (Loc,
                 Aliased_Present    => False,
                 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
      end if;

      Append_To (Comp_List,
        Make_Component_Declaration (Loc,
          Defining_Identifier  => Make_Temporary (Loc, 'C'),
          Component_Definition =>
            Make_Component_Definition (Loc,
              Aliased_Present    => False,
              Subtype_Indication => New_Reference_To (Str_Type, Loc))));

      Append_To (List_Def,
        Make_Full_Type_Declaration (Loc,
          Defining_Identifier => Equiv_Type,
          Type_Definition =>
            Make_Record_Definition (Loc,
              Component_List =>
                Make_Component_List (Loc,
                  Component_Items => Comp_List,
                  Variant_Part    => Empty))));

      --  Suppress all checks during the analysis of the expanded code to avoid
      --  the generation of spurious warnings under ZFP run-time.

      Insert_Actions (E, List_Def, Suppress => All_Checks);
      return Equiv_Type;
   end Make_CW_Equivalent_Type;

   -------------------------
   -- Make_Invariant_Call --
   -------------------------

   function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
      Loc : constant Source_Ptr := Sloc (Expr);
      Typ : constant Entity_Id  := Etype (Expr);

   begin
      pragma Assert
        (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));

      if Check_Enabled (Name_Invariant)
           or else
         Check_Enabled (Name_Assertion)
      then
         return
           Make_Procedure_Call_Statement (Loc,
             Name                   =>
               New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
             Parameter_Associations => New_List (Relocate_Node (Expr)));

      else
         return
           Make_Null_Statement (Loc);
      end if;
   end Make_Invariant_Call;

   ------------------------
   -- Make_Literal_Range --
   ------------------------

   function Make_Literal_Range
     (Loc         : Source_Ptr;
      Literal_Typ : Entity_Id) return Node_Id
   is
      Lo          : constant Node_Id :=
                      New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
      Index       : constant Entity_Id := Etype (Lo);

      Hi          : Node_Id;
      Length_Expr : constant Node_Id :=
                      Make_Op_Subtract (Loc,
                        Left_Opnd =>
                          Make_Integer_Literal (Loc,
                            Intval => String_Literal_Length (Literal_Typ)),
                        Right_Opnd =>
                          Make_Integer_Literal (Loc, 1));

   begin
      Set_Analyzed (Lo, False);

         if Is_Integer_Type (Index) then
            Hi :=
              Make_Op_Add (Loc,
                Left_Opnd  => New_Copy_Tree (Lo),
                Right_Opnd => Length_Expr);
         else
            Hi :=
              Make_Attribute_Reference (Loc,
                Attribute_Name => Name_Val,
                Prefix => New_Occurrence_Of (Index, Loc),
                Expressions => New_List (
                 Make_Op_Add (Loc,
                   Left_Opnd =>
                     Make_Attribute_Reference (Loc,
                       Attribute_Name => Name_Pos,
                       Prefix => New_Occurrence_Of (Index, Loc),
                       Expressions => New_List (New_Copy_Tree (Lo))),
                  Right_Opnd => Length_Expr)));
         end if;

         return
           Make_Range (Loc,
             Low_Bound  => Lo,
             High_Bound => Hi);
   end Make_Literal_Range;

   --------------------------
   -- Make_Non_Empty_Check --
   --------------------------

   function Make_Non_Empty_Check
     (Loc : Source_Ptr;
      N   : Node_Id) return Node_Id
   is
   begin
      return
        Make_Op_Ne (Loc,
          Left_Opnd =>
            Make_Attribute_Reference (Loc,
              Attribute_Name => Name_Length,
              Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
          Right_Opnd =>
            Make_Integer_Literal (Loc, 0));
   end Make_Non_Empty_Check;

   -------------------------
   -- Make_Predicate_Call --
   -------------------------

   function Make_Predicate_Call
     (Typ  : Entity_Id;
      Expr : Node_Id;
      Mem  : Boolean := False) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (Expr);

   begin
      pragma Assert (Present (Predicate_Function (Typ)));

      --  Call special membership version if requested and available

      if Mem then
         declare
            PFM : constant Entity_Id := Predicate_Function_M (Typ);
         begin
            if Present (PFM) then
               return
                 Make_Function_Call (Loc,
                   Name                   => New_Occurrence_Of (PFM, Loc),
                   Parameter_Associations => New_List (Relocate_Node (Expr)));
            end if;
         end;
      end if;

      --  Case of calling normal predicate function

      return
          Make_Function_Call (Loc,
            Name                   =>
              New_Occurrence_Of (Predicate_Function (Typ), Loc),
            Parameter_Associations => New_List (Relocate_Node (Expr)));
   end Make_Predicate_Call;

   --------------------------
   -- Make_Predicate_Check --
   --------------------------

   function Make_Predicate_Check
     (Typ  : Entity_Id;
      Expr : Node_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (Expr);

   begin
      return
        Make_Pragma (Loc,
          Pragma_Identifier            => Make_Identifier (Loc, Name_Check),
          Pragma_Argument_Associations => New_List (
            Make_Pragma_Argument_Association (Loc,
              Expression => Make_Identifier (Loc, Name_Predicate)),
            Make_Pragma_Argument_Association (Loc,
              Expression => Make_Predicate_Call (Typ, Expr))));
   end Make_Predicate_Check;

   ----------------------------
   -- Make_Subtype_From_Expr --
   ----------------------------

   --  1. If Expr is an unconstrained array expression, creates
   --    Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))

   --  2. If Expr is a unconstrained discriminated type expression, creates
   --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)

   --  3. If Expr is class-wide, creates an implicit class wide subtype

   function Make_Subtype_From_Expr
     (E       : Node_Id;
      Unc_Typ : Entity_Id) return Node_Id
   is
      Loc         : constant Source_Ptr := Sloc (E);
      List_Constr : constant List_Id    := New_List;
      D           : Entity_Id;

      Full_Subtyp  : Entity_Id;
      Priv_Subtyp  : Entity_Id;
      Utyp         : Entity_Id;
      Full_Exp     : Node_Id;

   begin
      if Is_Private_Type (Unc_Typ)
        and then Has_Unknown_Discriminants (Unc_Typ)
      then
         --  Prepare the subtype completion, Go to base type to
         --  find underlying type, because the type may be a generic
         --  actual or an explicit subtype.

         Utyp        := Underlying_Type (Base_Type (Unc_Typ));
         Full_Subtyp := Make_Temporary (Loc, 'C');
         Full_Exp    :=
           Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
         Set_Parent (Full_Exp, Parent (E));

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

         Insert_Action (E,
           Make_Subtype_Declaration (Loc,
             Defining_Identifier => Full_Subtyp,
             Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));

         --  Define the dummy private subtype

         Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
         Set_Etype          (Priv_Subtyp, Base_Type (Unc_Typ));
         Set_Scope          (Priv_Subtyp, Full_Subtyp);
         Set_Is_Constrained (Priv_Subtyp);
         Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
         Set_Is_Itype       (Priv_Subtyp);
         Set_Associated_Node_For_Itype (Priv_Subtyp, E);

         if Is_Tagged_Type  (Priv_Subtyp) then
            Set_Class_Wide_Type
              (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
            Set_Direct_Primitive_Operations (Priv_Subtyp,
              Direct_Primitive_Operations (Unc_Typ));
         end if;

         Set_Full_View (Priv_Subtyp, Full_Subtyp);

         return New_Reference_To (Priv_Subtyp, Loc);

      elsif Is_Array_Type (Unc_Typ) then
         for J in 1 .. Number_Dimensions (Unc_Typ) loop
            Append_To (List_Constr,
              Make_Range (Loc,
                Low_Bound =>
                  Make_Attribute_Reference (Loc,
                    Prefix => Duplicate_Subexpr_No_Checks (E),
                    Attribute_Name => Name_First,
                    Expressions => New_List (
                      Make_Integer_Literal (Loc, J))),

                High_Bound =>
                  Make_Attribute_Reference (Loc,
                    Prefix         => Duplicate_Subexpr_No_Checks (E),
                    Attribute_Name => Name_Last,
                    Expressions    => New_List (
                      Make_Integer_Literal (Loc, J)))));
         end loop;

      elsif Is_Class_Wide_Type (Unc_Typ) then
         declare
            CW_Subtype : Entity_Id;
            EQ_Typ     : Entity_Id := Empty;

         begin
            --  A class-wide equivalent type is not needed when VM_Target
            --  because the VM back-ends handle the class-wide object
            --  initialization itself (and doesn't need or want the
            --  additional intermediate type to handle the assignment).

            if Expander_Active and then Tagged_Type_Expansion then

               --  If this is the class_wide type of a completion that is a
               --  record subtype, set the type of the class_wide type to be
               --  the full base type, for use in the expanded code for the
               --  equivalent type. Should this be done earlier when the
               --  completion is analyzed ???

               if Is_Private_Type (Etype (Unc_Typ))
                 and then
                   Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
               then
                  Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
               end if;

               EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
            end if;

            CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
            Set_Equivalent_Type (CW_Subtype, EQ_Typ);
            Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));

            return New_Occurrence_Of (CW_Subtype, Loc);
         end;

      --  Indefinite record type with discriminants

      else
         D := First_Discriminant (Unc_Typ);
         while Present (D) loop
            Append_To (List_Constr,
              Make_Selected_Component (Loc,
                Prefix        => Duplicate_Subexpr_No_Checks (E),
                Selector_Name => New_Reference_To (D, Loc)));

            Next_Discriminant (D);
         end loop;
      end if;

      return
        Make_Subtype_Indication (Loc,
          Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
          Constraint   =>
            Make_Index_Or_Discriminant_Constraint (Loc,
              Constraints => List_Constr));
   end Make_Subtype_From_Expr;

   -----------------------------
   -- May_Generate_Large_Temp --
   -----------------------------

   --  At the current time, the only types that we return False for (i.e. where
   --  we decide we know they cannot generate large temps) are ones where we
   --  know the size is 256 bits or less at compile time, and we are still not
   --  doing a thorough job on arrays and records ???

   function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
   begin
      if not Size_Known_At_Compile_Time (Typ) then
         return False;

      elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
         return False;

      elsif Is_Array_Type (Typ) and then Present (Packed_Array_Type (Typ)) then
         return May_Generate_Large_Temp (Packed_Array_Type (Typ));

      --  We could do more here to find other small types ???

      else
         return True;
      end if;
   end May_Generate_Large_Temp;

   ------------------------
   -- Needs_Finalization --
   ------------------------

   function Needs_Finalization (T : Entity_Id) return Boolean is
      function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
      --  If type is not frozen yet, check explicitly among its components,
      --  because the Has_Controlled_Component flag is not necessarily set.

      -----------------------------------
      -- Has_Some_Controlled_Component --
      -----------------------------------

      function Has_Some_Controlled_Component
        (Rec : Entity_Id) return Boolean
      is
         Comp : Entity_Id;

      begin
         if Has_Controlled_Component (Rec) then
            return True;

         elsif not Is_Frozen (Rec) then
            if Is_Record_Type (Rec) then
               Comp := First_Entity (Rec);

               while Present (Comp) loop
                  if not Is_Type (Comp)
                    and then Needs_Finalization (Etype (Comp))
                  then
                     return True;
                  end if;

                  Next_Entity (Comp);
               end loop;

               return False;

            elsif Is_Array_Type (Rec) then
               return Needs_Finalization (Component_Type (Rec));

            else
               return Has_Controlled_Component (Rec);
            end if;
         else
            return False;
         end if;
      end Has_Some_Controlled_Component;

   --  Start of processing for Needs_Finalization

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

      if Restriction_Active (No_Finalization) then
         return False;

      --  C, C++, CIL and Java types are not considered controlled. It is
      --  assumed that the non-Ada side will handle their clean up.

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

      else
         --  Class-wide types are treated as controlled because derivations
         --  from the root type can introduce controlled components.

         return
           Is_Class_Wide_Type (T)
             or else Is_Controlled (T)
             or else Has_Controlled_Component (T)
             or else Has_Some_Controlled_Component (T)
             or else
               (Is_Concurrent_Type (T)
                 and then Present (Corresponding_Record_Type (T))
                 and then Needs_Finalization (Corresponding_Record_Type (T)));
      end if;
   end Needs_Finalization;

   ----------------------------
   -- Needs_Constant_Address --
   ----------------------------

   function Needs_Constant_Address
     (Decl : Node_Id;
      Typ  : Entity_Id) return Boolean
   is
   begin

      --  If we have no initialization of any kind, then we don't need to place
      --  any restrictions on the address clause, because the object will be
      --  elaborated after the address clause is evaluated. This happens if the
      --  declaration has no initial expression, or the type has no implicit
      --  initialization, or the object is imported.

      --  The same holds for all initialized scalar types and all access types.
      --  Packed bit arrays of size up to 64 are represented using a modular
      --  type with an initialization (to zero) and can be processed like other
      --  initialized scalar types.

      --  If the type is controlled, code to attach the object to a
      --  finalization chain is generated at the point of declaration, and
      --  therefore the elaboration of the object cannot be delayed: the
      --  address expression must be a constant.

      if No (Expression (Decl))
        and then not Needs_Finalization (Typ)
        and then
          (not Has_Non_Null_Base_Init_Proc (Typ)
            or else Is_Imported (Defining_Identifier (Decl)))
      then
         return False;

      elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
        or else Is_Access_Type (Typ)
        or else
          (Is_Bit_Packed_Array (Typ)
            and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
      then
         return False;

      else

         --  Otherwise, we require the address clause to be constant because
         --  the call to the initialization procedure (or the attach code) has
         --  to happen at the point of the declaration.

         --  Actually the IP call has been moved to the freeze actions anyway,
         --  so maybe we can relax this restriction???

         return True;
      end if;
   end Needs_Constant_Address;

   ----------------------------
   -- New_Class_Wide_Subtype --
   ----------------------------

   function New_Class_Wide_Subtype
     (CW_Typ : Entity_Id;
      N      : Node_Id) return Entity_Id
   is
      Res       : constant Entity_Id := Create_Itype (E_Void, N);
      Res_Name  : constant Name_Id   := Chars (Res);
      Res_Scope : constant Entity_Id := Scope (Res);

   begin
      Copy_Node (CW_Typ, Res);
      Set_Comes_From_Source (Res, False);
      Set_Sloc (Res, Sloc (N));
      Set_Is_Itype (Res);
      Set_Associated_Node_For_Itype (Res, N);
      Set_Is_Public (Res, False);   --  By default, may be changed below.
      Set_Public_Status (Res);
      Set_Chars (Res, Res_Name);
      Set_Scope (Res, Res_Scope);
      Set_Ekind (Res, E_Class_Wide_Subtype);
      Set_Next_Entity (Res, Empty);
      Set_Etype (Res, Base_Type (CW_Typ));
      Set_Is_Frozen (Res, False);
      Set_Freeze_Node (Res, Empty);
      return (Res);
   end New_Class_Wide_Subtype;

   --------------------------------
   -- Non_Limited_Designated_Type --
   ---------------------------------

   function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
      Desig : constant Entity_Id := Designated_Type (T);
   begin
      if Ekind (Desig) = E_Incomplete_Type
        and then Present (Non_Limited_View (Desig))
      then
         return Non_Limited_View (Desig);
      else
         return Desig;
      end if;
   end Non_Limited_Designated_Type;

   -----------------------------------
   -- OK_To_Do_Constant_Replacement --
   -----------------------------------

   function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
      ES : constant Entity_Id := Scope (E);
      CS : Entity_Id;

   begin
      --  Do not replace statically allocated objects, because they may be
      --  modified outside the current scope.

      if Is_Statically_Allocated (E) then
         return False;

      --  Do not replace aliased or volatile objects, since we don't know what
      --  else might change the value.

      elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
         return False;

      --  Debug flag -gnatdM disconnects this optimization

      elsif Debug_Flag_MM then
         return False;

      --  Otherwise check scopes

      else
         CS := Current_Scope;

         loop
            --  If we are in right scope, replacement is safe

            if CS = ES then
               return True;

            --  Packages do not affect the determination of safety

            elsif Ekind (CS) = E_Package then
               exit when CS = Standard_Standard;
               CS := Scope (CS);

            --  Blocks do not affect the determination of safety

            elsif Ekind (CS) = E_Block then
               CS := Scope (CS);

            --  Loops do not affect the determination of safety. Note that we
            --  kill all current values on entry to a loop, so we are just
            --  talking about processing within a loop here.

            elsif Ekind (CS) = E_Loop then
               CS := Scope (CS);

            --  Otherwise, the reference is dubious, and we cannot be sure that
            --  it is safe to do the replacement.

            else
               exit;
            end if;
         end loop;

         return False;
      end if;
   end OK_To_Do_Constant_Replacement;

   ------------------------------------
   -- Possible_Bit_Aligned_Component --
   ------------------------------------

   function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
   begin
      case Nkind (N) is

         --  Case of indexed component

         when N_Indexed_Component =>
            declare
               P    : constant Node_Id   := Prefix (N);
               Ptyp : constant Entity_Id := Etype (P);

            begin
               --  If we know the component size and it is less than 64, then
               --  we are definitely OK. The back end always does assignment of
               --  misaligned small objects correctly.

               if Known_Static_Component_Size (Ptyp)
                 and then Component_Size (Ptyp) <= 64
               then
                  return False;

               --  Otherwise, we need to test the prefix, to see if we are
               --  indexing from a possibly unaligned component.

               else
                  return Possible_Bit_Aligned_Component (P);
               end if;
            end;

         --  Case of selected component

         when N_Selected_Component =>
            declare
               P    : constant Node_Id   := Prefix (N);
               Comp : constant Entity_Id := Entity (Selector_Name (N));

            begin
               --  If there is no component clause, then we are in the clear
               --  since the back end will never misalign a large component
               --  unless it is forced to do so. In the clear means we need
               --  only the recursive test on the prefix.

               if Component_May_Be_Bit_Aligned (Comp) then
                  return True;
               else
                  return Possible_Bit_Aligned_Component (P);
               end if;
            end;

         --  For a slice, test the prefix, if that is possibly misaligned,
         --  then for sure the slice is!

         when N_Slice =>
            return Possible_Bit_Aligned_Component (Prefix (N));

         --  For an unchecked conversion, check whether the expression may
         --  be bit-aligned.

         when N_Unchecked_Type_Conversion =>
            return Possible_Bit_Aligned_Component (Expression (N));

         --  If we have none of the above, it means that we have fallen off the
         --  top testing prefixes recursively, and we now have a stand alone
         --  object, where we don't have a problem.

         when others =>
            return False;

      end case;
   end Possible_Bit_Aligned_Component;

   -----------------------------------------------
   -- Process_Statements_For_Controlled_Objects --
   -----------------------------------------------

   procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
      Loc : constant Source_Ptr := Sloc (N);

      function Are_Wrapped (L : List_Id) return Boolean;
      --  Determine whether list L contains only one statement which is a block

      function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
      --  Given a list of statements L, wrap it in a block statement and return
      --  the generated node.

      -----------------
      -- Are_Wrapped --
      -----------------

      function Are_Wrapped (L : List_Id) return Boolean is
         Stmt : constant Node_Id := First (L);
      begin
         return
           Present (Stmt)
             and then No (Next (Stmt))
             and then Nkind (Stmt) = N_Block_Statement;
      end Are_Wrapped;

      ------------------------------
      -- Wrap_Statements_In_Block --
      ------------------------------

      function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
      begin
         return
           Make_Block_Statement (Loc,
             Declarations => No_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements => L));
      end Wrap_Statements_In_Block;

      --  Local variables

      Block : Node_Id;

   --  Start of processing for Process_Statements_For_Controlled_Objects

   begin
      --  Whenever a non-handled statement list is wrapped in a block, the
      --  block must be explicitly analyzed to redecorate all entities in the
      --  list and ensure that a finalizer is properly built.

      case Nkind (N) is
         when N_Elsif_Part             |
              N_If_Statement           |
              N_Conditional_Entry_Call |
              N_Selective_Accept       =>

            --  Check the "then statements" for elsif parts and if statements

            if Nkind_In (N, N_Elsif_Part, N_If_Statement)
              and then not Is_Empty_List (Then_Statements (N))
              and then not Are_Wrapped (Then_Statements (N))
              and then Requires_Cleanup_Actions
                         (Then_Statements (N), False, False)
            then
               Block := Wrap_Statements_In_Block (Then_Statements (N));
               Set_Then_Statements (N, New_List (Block));

               Analyze (Block);
            end if;

            --  Check the "else statements" for conditional entry calls, if
            --  statements and selective accepts.

            if Nkind_In (N, N_Conditional_Entry_Call,
                            N_If_Statement,
                            N_Selective_Accept)
              and then not Is_Empty_List (Else_Statements (N))
              and then not Are_Wrapped (Else_Statements (N))
              and then Requires_Cleanup_Actions
                         (Else_Statements (N), False, False)
            then
               Block := Wrap_Statements_In_Block (Else_Statements (N));
               Set_Else_Statements (N, New_List (Block));

               Analyze (Block);
            end if;

         when N_Abortable_Part             |
              N_Accept_Alternative         |
              N_Case_Statement_Alternative |
              N_Delay_Alternative          |
              N_Entry_Call_Alternative     |
              N_Exception_Handler          |
              N_Loop_Statement             |
              N_Triggering_Alternative     =>

            if not Is_Empty_List (Statements (N))
              and then not Are_Wrapped (Statements (N))
              and then Requires_Cleanup_Actions (Statements (N), False, False)
            then
               Block := Wrap_Statements_In_Block (Statements (N));
               Set_Statements (N, New_List (Block));

               Analyze (Block);
            end if;

         when others                       =>
            null;
      end case;
   end Process_Statements_For_Controlled_Objects;

   ----------------------
   -- Remove_Init_Call --
   ----------------------

   function Remove_Init_Call
     (Var        : Entity_Id;
      Rep_Clause : Node_Id) return Node_Id
   is
      Par : constant Node_Id   := Parent (Var);
      Typ : constant Entity_Id := Etype (Var);

      Init_Proc : Entity_Id;
      --  Initialization procedure for Typ

      function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
      --  Look for init call for Var starting at From and scanning the
      --  enclosing list until Rep_Clause or the end of the list is reached.

      ----------------------------
      -- Find_Init_Call_In_List --
      ----------------------------

      function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
         Init_Call : Node_Id;

      begin
         Init_Call := From;
         while Present (Init_Call) and then Init_Call /= Rep_Clause loop
            if Nkind (Init_Call) = N_Procedure_Call_Statement
              and then Is_Entity_Name (Name (Init_Call))
              and then Entity (Name (Init_Call)) = Init_Proc
            then
               return Init_Call;
            end if;

            Next (Init_Call);
         end loop;

         return Empty;
      end Find_Init_Call_In_List;

      Init_Call : Node_Id;

   --  Start of processing for Find_Init_Call

   begin
      if Present (Initialization_Statements (Var)) then
         Init_Call := Initialization_Statements (Var);
         Set_Initialization_Statements (Var, Empty);

      elsif not Has_Non_Null_Base_Init_Proc (Typ) then

         --  No init proc for the type, so obviously no call to be found

         return Empty;

      else
         --  We might be able to handle other cases below by just properly
         --  setting Initialization_Statements at the point where the init proc
         --  call is generated???

         Init_Proc := Base_Init_Proc (Typ);

         --  First scan the list containing the declaration of Var

         Init_Call := Find_Init_Call_In_List (From => Next (Par));

         --  If not found, also look on Var's freeze actions list, if any,
         --  since the init call may have been moved there (case of an address
         --  clause applying to Var).

         if No (Init_Call) and then Present (Freeze_Node (Var)) then
            Init_Call :=
              Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
         end if;

         --  If the initialization call has actuals that use the secondary
         --  stack, the call may have been wrapped into a temporary block, in
         --  which case the block itself has to be removed.

         if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
            declare
               Blk : constant Node_Id := Next (Par);
            begin
               if Present
                    (Find_Init_Call_In_List
                      (First (Statements (Handled_Statement_Sequence (Blk)))))
               then
                  Init_Call := Blk;
               end if;
            end;
         end if;
      end if;

      if Present (Init_Call) then
         Remove (Init_Call);
      end if;
      return Init_Call;
   end Remove_Init_Call;

   -------------------------
   -- Remove_Side_Effects --
   -------------------------

   procedure Remove_Side_Effects
     (Exp          : Node_Id;
      Name_Req     : Boolean := False;
      Variable_Ref : Boolean := False)
   is
      Loc          : constant Source_Ptr      := Sloc (Exp);
      Exp_Type     : constant Entity_Id       := Etype (Exp);
      Svg_Suppress : constant Suppress_Record := Scope_Suppress;
      Def_Id       : Entity_Id;
      E            : Node_Id;
      New_Exp      : Node_Id;
      Ptr_Typ_Decl : Node_Id;
      Ref_Type     : Entity_Id;
      Res          : Node_Id;

      function Side_Effect_Free (N : Node_Id) return Boolean;
      --  Determines if the tree N represents an expression that is known not
      --  to have side effects, and for which no processing is required.

      function Side_Effect_Free (L : List_Id) return Boolean;
      --  Determines if all elements of the list L are side effect free

      function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
      --  The argument N is a construct where the Prefix is dereferenced if it
      --  is an access type and the result is a variable. The call returns True
      --  if the construct is side effect free (not considering side effects in
      --  other than the prefix which are to be tested by the caller).

      function Within_In_Parameter (N : Node_Id) return Boolean;
      --  Determines if N is a subcomponent of a composite in-parameter. If so,
      --  N is not side-effect free when the actual is global and modifiable
      --  indirectly from within a subprogram, because it may be passed by
      --  reference. The front-end must be conservative here and assume that
      --  this may happen with any array or record type. On the other hand, we
      --  cannot create temporaries for all expressions for which this
      --  condition is true, for various reasons that might require clearing up
      --  ??? For example, discriminant references that appear out of place, or
      --  spurious type errors with class-wide expressions. As a result, we
      --  limit the transformation to loop bounds, which is so far the only
      --  case that requires it.

      -----------------------------
      -- Safe_Prefixed_Reference --
      -----------------------------

      function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
      begin
         --  If prefix is not side effect free, definitely not safe

         if not Side_Effect_Free (Prefix (N)) then
            return False;

         --  If the prefix is of an access type that is not access-to-constant,
         --  then this construct is a variable reference, which means it is to
         --  be considered to have side effects if Variable_Ref is set True.

         elsif Is_Access_Type (Etype (Prefix (N)))
           and then not Is_Access_Constant (Etype (Prefix (N)))
           and then Variable_Ref
         then
            --  Exception is a prefix that is the result of a previous removal
            --  of side-effects.

            return Is_Entity_Name (Prefix (N))
              and then not Comes_From_Source (Prefix (N))
              and then Ekind (Entity (Prefix (N))) = E_Constant
              and then Is_Internal_Name (Chars (Entity (Prefix (N))));

         --  If the prefix is an explicit dereference then this construct is a
         --  variable reference, which means it is to be considered to have
         --  side effects if Variable_Ref is True.

         --  We do NOT exclude dereferences of access-to-constant types because
         --  we handle them as constant view of variables.

         elsif Nkind (Prefix (N)) = N_Explicit_Dereference
           and then Variable_Ref
         then
            return False;

         --  Note: The following test is the simplest way of solving a complex
         --  problem uncovered by the following test (Side effect on loop bound
         --  that is a subcomponent of a global variable:

         --    with Text_Io; use Text_Io;
         --    procedure Tloop is
         --      type X is
         --        record
         --          V : Natural := 4;
         --          S : String (1..5) := (others => 'a');
         --        end record;
         --      X1 : X;

         --      procedure Modi;

         --      generic
         --        with procedure Action;
         --      procedure Loop_G (Arg : X; Msg : String)

         --      procedure Loop_G (Arg : X; Msg : String) is
         --      begin
         --        Put_Line ("begin loop_g " & Msg & " will loop till: "
         --                  & Natural'Image (Arg.V));
         --        for Index in 1 .. Arg.V loop
         --          Text_Io.Put_Line
         --            (Natural'Image (Index) & " " & Arg.S (Index));
         --          if Index > 2 then
         --            Modi;
         --          end if;
         --        end loop;
         --        Put_Line ("end loop_g " & Msg);
         --      end;

         --      procedure Loop1 is new Loop_G (Modi);
         --      procedure Modi is
         --      begin
         --        X1.V := 1;
         --        Loop1 (X1, "from modi");
         --      end;
         --
         --    begin
         --      Loop1 (X1, "initial");
         --    end;

         --  The output of the above program should be:

         --    begin loop_g initial will loop till:  4
         --     1 a
         --     2 a
         --     3 a
         --    begin loop_g from modi will loop till:  1
         --     1 a
         --    end loop_g from modi
         --     4 a
         --    begin loop_g from modi will loop till:  1
         --     1 a
         --    end loop_g from modi
         --    end loop_g initial

         --  If a loop bound is a subcomponent of a global variable, a
         --  modification of that variable within the loop may incorrectly
         --  affect the execution of the loop.

         elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
           and then Within_In_Parameter (Prefix (N))
           and then Variable_Ref
         then
            return False;

         --  All other cases are side effect free

         else
            return True;
         end if;
      end Safe_Prefixed_Reference;

      ----------------------
      -- Side_Effect_Free --
      ----------------------

      function Side_Effect_Free (N : Node_Id) return Boolean is
      begin
         --  Note on checks that could raise Constraint_Error. Strictly, if we
         --  take advantage of 11.6, these checks do not count as side effects.
         --  However, we would prefer to consider that they are side effects,
         --  since the backend CSE does not work very well on expressions which
         --  can raise Constraint_Error. On the other hand if we don't consider
         --  them to be side effect free, then we get some awkward expansions
         --  in -gnato mode, resulting in code insertions at a point where we
         --  do not have a clear model for performing the insertions.

         --  Special handling for entity names

         if Is_Entity_Name (N) then

            --  Variables are considered to be a side effect if Variable_Ref
            --  is set or if we have a volatile reference and Name_Req is off.
            --  If Name_Req is True then we can't help returning a name which
            --  effectively allows multiple references in any case.

            if Is_Variable (N, Use_Original_Node => False) then
               return not Variable_Ref
                 and then (not Is_Volatile_Reference (N) or else Name_Req);

            --  Any other entity (e.g. a subtype name) is definitely side
            --  effect free.

            else
               return True;
            end if;

         --  A value known at compile time is always side effect free

         elsif Compile_Time_Known_Value (N) then
            return True;

         --  A variable renaming is not side-effect free, because the renaming
         --  will function like a macro in the front-end in some cases, and an
         --  assignment can modify the component designated by N, so we need to
         --  create a temporary for it.

         --  The guard testing for Entity being present is needed at least in
         --  the case of rewritten predicate expressions, and may well also be
         --  appropriate elsewhere. Obviously we can't go testing the entity
         --  field if it does not exist, so it's reasonable to say that this is
         --  not the renaming case if it does not exist.

         elsif Is_Entity_Name (Original_Node (N))
           and then Present (Entity (Original_Node (N)))
           and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
           and then Ekind (Entity (Original_Node (N))) /= E_Constant
         then
            declare
               RO : constant Node_Id :=
                      Renamed_Object (Entity (Original_Node (N)));

            begin
               --  If the renamed object is an indexed component, or an
               --  explicit dereference, then the designated object could
               --  be modified by an assignment.

               if Nkind_In (RO, N_Indexed_Component,
                                N_Explicit_Dereference)
               then
                  return False;

               --  A selected component must have a safe prefix

               elsif Nkind (RO) = N_Selected_Component then
                  return Safe_Prefixed_Reference (RO);

               --  In all other cases, designated object cannot be changed so
               --  we are side effect free.

               else
                  return True;
               end if;
            end;

         --  Remove_Side_Effects generates an object renaming declaration to
         --  capture the expression of a class-wide expression. In VM targets
         --  the frontend performs no expansion for dispatching calls to
         --  class- wide types since they are handled by the VM. Hence, we must
         --  locate here if this node corresponds to a previous invocation of
         --  Remove_Side_Effects to avoid a never ending loop in the frontend.

         elsif VM_Target /= No_VM
            and then not Comes_From_Source (N)
            and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
            and then Is_Class_Wide_Type (Etype (N))
         then
            return True;
         end if;

         --  For other than entity names and compile time known values,
         --  check the node kind for special processing.

         case Nkind (N) is

            --  An attribute reference is side effect free if its expressions
            --  are side effect free and its prefix is side effect free or
            --  is an entity reference.

            --  Is this right? what about x'first where x is a variable???

            when N_Attribute_Reference =>
               return Side_Effect_Free (Expressions (N))
                 and then Attribute_Name (N) /= Name_Input
                 and then (Is_Entity_Name (Prefix (N))
                            or else Side_Effect_Free (Prefix (N)));

            --  A binary operator is side effect free if and both operands are
            --  side effect free. For this purpose binary operators include
            --  membership tests and short circuit forms.

            when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
               return Side_Effect_Free (Left_Opnd  (N))
                        and then
                      Side_Effect_Free (Right_Opnd (N));

            --  An explicit dereference is side effect free only if it is
            --  a side effect free prefixed reference.

            when N_Explicit_Dereference =>
               return Safe_Prefixed_Reference (N);

            --  A call to _rep_to_pos is side effect free, since we generate
            --  this pure function call ourselves. Moreover it is critically
            --  important to make this exception, since otherwise we can have
            --  discriminants in array components which don't look side effect
            --  free in the case of an array whose index type is an enumeration
            --  type with an enumeration rep clause.

            --  All other function calls are not side effect free

            when N_Function_Call =>
               return Nkind (Name (N)) = N_Identifier
                 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
                 and then
                   Side_Effect_Free (First (Parameter_Associations (N)));

            --  An indexed component is side effect free if it is a side
            --  effect free prefixed reference and all the indexing
            --  expressions are side effect free.

            when N_Indexed_Component =>
               return Side_Effect_Free (Expressions (N))
                 and then Safe_Prefixed_Reference (N);

            --  A type qualification is side effect free if the expression
            --  is side effect free.

            when N_Qualified_Expression =>
               return Side_Effect_Free (Expression (N));

            --  A selected component is side effect free only if it is a side
            --  effect free prefixed reference. If it designates a component
            --  with a rep. clause it must be treated has having a potential
            --  side effect, because it may be modified through a renaming, and
            --  a subsequent use of the renaming as a macro will yield the
            --  wrong value. This complex interaction between renaming and
            --  removing side effects is a reminder that the latter has become
            --  a headache to maintain, and that it should be removed in favor
            --  of the gcc mechanism to capture values ???

            when N_Selected_Component =>
               if Nkind (Parent (N)) = N_Explicit_Dereference
                 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
               then
                  return False;
               else
                  return Safe_Prefixed_Reference (N);
               end if;

            --  A range is side effect free if the bounds are side effect free

            when N_Range =>
               return Side_Effect_Free (Low_Bound (N))
                 and then Side_Effect_Free (High_Bound (N));

            --  A slice is side effect free if it is a side effect free
            --  prefixed reference and the bounds are side effect free.

            when N_Slice =>
               return Side_Effect_Free (Discrete_Range (N))
                 and then Safe_Prefixed_Reference (N);

            --  A type conversion is side effect free if the expression to be
            --  converted is side effect free.

            when N_Type_Conversion =>
               return Side_Effect_Free (Expression (N));

            --  A unary operator is side effect free if the operand
            --  is side effect free.

            when N_Unary_Op =>
               return Side_Effect_Free (Right_Opnd (N));

            --  An unchecked type conversion is side effect free only if it
            --  is safe and its argument is side effect free.

            when N_Unchecked_Type_Conversion =>
               return Safe_Unchecked_Type_Conversion (N)
                 and then Side_Effect_Free (Expression (N));

            --  An unchecked expression is side effect free if its expression
            --  is side effect free.

            when N_Unchecked_Expression =>
               return Side_Effect_Free (Expression (N));

            --  A literal is side effect free

            when N_Character_Literal    |
                 N_Integer_Literal      |
                 N_Real_Literal         |
                 N_String_Literal       =>
               return True;

            --  We consider that anything else has side effects. This is a bit
            --  crude, but we are pretty close for most common cases, and we
            --  are certainly correct (i.e. we never return True when the
            --  answer should be False).

            when others =>
               return False;
         end case;
      end Side_Effect_Free;

      --  A list is side effect free if all elements of the list are side
      --  effect free.

      function Side_Effect_Free (L : List_Id) return Boolean is
         N : Node_Id;

      begin
         if L = No_List or else L = Error_List then
            return True;

         else
            N := First (L);
            while Present (N) loop
               if not Side_Effect_Free (N) then
                  return False;
               else
                  Next (N);
               end if;
            end loop;

            return True;
         end if;
      end Side_Effect_Free;

      -------------------------
      -- Within_In_Parameter --
      -------------------------

      function Within_In_Parameter (N : Node_Id) return Boolean is
      begin
         if not Comes_From_Source (N) then
            return False;

         elsif Is_Entity_Name (N) then
            return Ekind (Entity (N)) = E_In_Parameter;

         elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
            return Within_In_Parameter (Prefix (N));

         else
            return False;
         end if;
      end Within_In_Parameter;

   --  Start of processing for Remove_Side_Effects

   begin
      --  Handle cases in which there is nothing to do

      if not Expander_Active then
         return;
      end if;

      --  Cannot generate temporaries if the invocation to remove side effects
      --  was issued too early and the type of the expression is not resolved
      --  (this happens because routines Duplicate_Subexpr_XX implicitly invoke
      --  Remove_Side_Effects).

      if No (Exp_Type)
        or else Ekind (Exp_Type) = E_Access_Attribute_Type
      then
         return;

      --  No action needed for side-effect free expressions

      elsif Side_Effect_Free (Exp) then
         return;
      end if;

      --  The remaining procesaing is done with all checks suppressed

      --  Note: from now on, don't use return statements, instead do a goto
      --  Leave, to ensure that we properly restore Scope_Suppress.Suppress.

      Scope_Suppress.Suppress := (others => True);

      --  If it is a scalar type and we need to capture the value, just make
      --  a copy. Likewise for a function call, an attribute reference, an
      --  allocator, or an operator. And if we have a volatile reference and
      --  Name_Req is not set (see comments above for Side_Effect_Free).

      if Is_Elementary_Type (Exp_Type)
        and then (Variable_Ref
                   or else Nkind_In (Exp, N_Function_Call,
                                          N_Attribute_Reference,
                                          N_Allocator)
                   or else Nkind (Exp) in N_Op
                   or else (not Name_Req and then Is_Volatile_Reference (Exp)))
      then
         Def_Id := Make_Temporary (Loc, 'R', Exp);
         Set_Etype (Def_Id, Exp_Type);
         Res := New_Reference_To (Def_Id, Loc);

         --  If the expression is a packed reference, it must be reanalyzed and
         --  expanded, depending on context. This is the case for actuals where
         --  a constraint check may capture the actual before expansion of the
         --  call is complete.

         if Nkind (Exp) = N_Indexed_Component
           and then Is_Packed (Etype (Prefix (Exp)))
         then
            Set_Analyzed (Exp, False);
            Set_Analyzed (Prefix (Exp), False);
         end if;

         E :=
           Make_Object_Declaration (Loc,
             Defining_Identifier => Def_Id,
             Object_Definition   => New_Reference_To (Exp_Type, Loc),
             Constant_Present    => True,
             Expression          => Relocate_Node (Exp));

         Set_Assignment_OK (E);
         Insert_Action (Exp, E);

      --  If the expression has the form v.all then we can just capture the
      --  pointer, and then do an explicit dereference on the result.

      elsif Nkind (Exp) = N_Explicit_Dereference then
         Def_Id := Make_Temporary (Loc, 'R', Exp);
         Res :=
           Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));

         Insert_Action (Exp,
           Make_Object_Declaration (Loc,
             Defining_Identifier => Def_Id,
             Object_Definition   =>
               New_Reference_To (Etype (Prefix (Exp)), Loc),
             Constant_Present    => True,
             Expression          => Relocate_Node (Prefix (Exp))));

      --  Similar processing for an unchecked conversion of an expression of
      --  the form v.all, where we want the same kind of treatment.

      elsif Nkind (Exp) = N_Unchecked_Type_Conversion
        and then Nkind (Expression (Exp)) = N_Explicit_Dereference
      then
         Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
         goto Leave;

      --  If this is a type conversion, leave the type conversion and remove
      --  the side effects in the expression. This is important in several
      --  circumstances: for change of representations, and also when this is a
      --  view conversion to a smaller object, where gigi can end up creating
      --  its own temporary of the wrong size.

      elsif Nkind (Exp) = N_Type_Conversion then
         Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
         goto Leave;

      --  If this is an unchecked conversion that Gigi can't handle, make
      --  a copy or a use a renaming to capture the value.

      elsif Nkind (Exp) = N_Unchecked_Type_Conversion
        and then not Safe_Unchecked_Type_Conversion (Exp)
      then
         if CW_Or_Has_Controlled_Part (Exp_Type) then

            --  Use a renaming to capture the expression, rather than create
            --  a controlled temporary.

            Def_Id := Make_Temporary (Loc, 'R', Exp);
            Res := New_Reference_To (Def_Id, Loc);

            Insert_Action (Exp,
              Make_Object_Renaming_Declaration (Loc,
                Defining_Identifier => Def_Id,
                Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
                Name                => Relocate_Node (Exp)));

         else
            Def_Id := Make_Temporary (Loc, 'R', Exp);
            Set_Etype (Def_Id, Exp_Type);
            Res := New_Reference_To (Def_Id, Loc);

            E :=
              Make_Object_Declaration (Loc,
                Defining_Identifier => Def_Id,
                Object_Definition   => New_Reference_To (Exp_Type, Loc),
                Constant_Present    => not Is_Variable (Exp),
                Expression          => Relocate_Node (Exp));

            Set_Assignment_OK (E);
            Insert_Action (Exp, E);
         end if;

      --  For expressions that denote objects, we can use a renaming scheme.
      --  This is needed for correctness in the case of a volatile object of
      --  a non-volatile type because the Make_Reference call of the "default"
      --  approach would generate an illegal access value (an access value
      --  cannot designate such an object - see Analyze_Reference). We skip
      --  using this scheme if we have an object of a volatile type and we do
      --  not have Name_Req set true (see comments above for Side_Effect_Free).

      --  In Ada 2012 a qualified expression is an object, but for purposes of
      --  removing side effects it still need to be transformed into a separate
      --  declaration, particularly if the expression is an aggregate.

      elsif Is_Object_Reference (Exp)
        and then Nkind (Exp) /= N_Function_Call
        and then Nkind (Exp) /= N_Qualified_Expression
        and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
      then
         Def_Id := Make_Temporary (Loc, 'R', Exp);

         if Nkind (Exp) = N_Selected_Component
           and then Nkind (Prefix (Exp)) = N_Function_Call
           and then Is_Array_Type (Exp_Type)
         then
            --  Avoid generating a variable-sized temporary, by generating
            --  the renaming declaration just for the function call. The
            --  transformation could be refined to apply only when the array
            --  component is constrained by a discriminant???

            Res :=
              Make_Selected_Component (Loc,
                Prefix => New_Occurrence_Of (Def_Id, Loc),
                Selector_Name => Selector_Name (Exp));

            Insert_Action (Exp,
              Make_Object_Renaming_Declaration (Loc,
                Defining_Identifier => Def_Id,
                Subtype_Mark        =>
                  New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
                Name                => Relocate_Node (Prefix (Exp))));

         else
            Res := New_Reference_To (Def_Id, Loc);

            Insert_Action (Exp,
              Make_Object_Renaming_Declaration (Loc,
                Defining_Identifier => Def_Id,
                Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
                Name                => Relocate_Node (Exp)));
         end if;

         --  If this is a packed reference, or a selected component with
         --  a non-standard representation, a reference to the temporary
         --  will be replaced by a copy of the original expression (see
         --  Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
         --  elaborated by gigi, and is of course not to be replaced in-line
         --  by the expression it renames, which would defeat the purpose of
         --  removing the side-effect.

         if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
           and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
         then
            null;
         else
            Set_Is_Renaming_Of_Object (Def_Id, False);
         end if;

      --  Otherwise we generate a reference to the value

      else
         --  An expression which is in Alfa mode is considered side effect free
         --  if the resulting value is captured by a variable or a constant.

         if Alfa_Mode and then Nkind (Parent (Exp)) = N_Object_Declaration then
            goto Leave;
         end if;

         --  Special processing for function calls that return a limited type.
         --  We need to build a declaration that will enable build-in-place
         --  expansion of the call. This is not done if the context is already
         --  an object declaration, to prevent infinite recursion.

         --  This is relevant only in Ada 2005 mode. In Ada 95 programs we have
         --  to accommodate functions returning limited objects by reference.

         if Ada_Version >= Ada_2005
           and then Nkind (Exp) = N_Function_Call
           and then Is_Immutably_Limited_Type (Etype (Exp))
           and then Nkind (Parent (Exp)) /= N_Object_Declaration
         then
            declare
               Obj  : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
               Decl : Node_Id;

            begin
               Decl :=
                 Make_Object_Declaration (Loc,
                   Defining_Identifier => Obj,
                   Object_Definition   => New_Occurrence_Of (Exp_Type, Loc),
                   Expression          => Relocate_Node (Exp));

               Insert_Action (Exp, Decl);
               Set_Etype (Obj, Exp_Type);
               Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
               goto Leave;
            end;
         end if;

         Def_Id := Make_Temporary (Loc, 'R', Exp);
         Set_Etype (Def_Id, Exp_Type);

         --  The regular expansion of functions with side effects involves the
         --  generation of an access type to capture the return value found on
         --  the secondary stack. Since Alfa (and why) cannot process access
         --  types, use a different approach which ignores the secondary stack
         --  and "copies" the returned object.

         if Alfa_Mode then
            Res := New_Reference_To (Def_Id, Loc);
            Ref_Type := Exp_Type;

         --  Regular expansion utilizing an access type and 'reference

         else
            Res :=
              Make_Explicit_Dereference (Loc,
                Prefix => New_Reference_To (Def_Id, Loc));

            --  Generate:
            --    type Ann is access all <Exp_Type>;

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

            Ptr_Typ_Decl :=
              Make_Full_Type_Declaration (Loc,
                Defining_Identifier => Ref_Type,
                Type_Definition     =>
                  Make_Access_To_Object_Definition (Loc,
                    All_Present        => True,
                    Subtype_Indication =>
                      New_Reference_To (Exp_Type, Loc)));

            Insert_Action (Exp, Ptr_Typ_Decl);
         end if;

         E := Exp;
         if Nkind (E) = N_Explicit_Dereference then
            New_Exp := Relocate_Node (Prefix (E));
         else
            E := Relocate_Node (E);

            --  Do not generate a 'reference in Alfa mode since the access type
            --  is not created in the first place.

            if Alfa_Mode then
               New_Exp := E;

            --  Otherwise generate reference, marking the value as non-null
            --  since we know it cannot be null and we don't want a check.

            else
               New_Exp := Make_Reference (Loc, E);
               Set_Is_Known_Non_Null (Def_Id);
            end if;
         end if;

         if Is_Delayed_Aggregate (E) then

            --  The expansion of nested aggregates is delayed until the
            --  enclosing aggregate is expanded. As aggregates are often
            --  qualified, the predicate applies to qualified expressions as
            --  well, indicating that the enclosing aggregate has not been
            --  expanded yet. At this point the aggregate is part of a
            --  stand-alone declaration, and must be fully expanded.

            if Nkind (E) = N_Qualified_Expression then
               Set_Expansion_Delayed (Expression (E), False);
               Set_Analyzed (Expression (E), False);
            else
               Set_Expansion_Delayed (E, False);
            end if;

            Set_Analyzed (E, False);
         end if;

         Insert_Action (Exp,
           Make_Object_Declaration (Loc,
             Defining_Identifier => Def_Id,
             Object_Definition   => New_Reference_To (Ref_Type, Loc),
             Constant_Present    => True,
             Expression          => New_Exp));
      end if;

      --  Preserve the Assignment_OK flag in all copies, since at least one
      --  copy may be used in a context where this flag must be set (otherwise
      --  why would the flag be set in the first place).

      Set_Assignment_OK (Res, Assignment_OK (Exp));

      --  Finally rewrite the original expression and we are done

      Rewrite (Exp, Res);
      Analyze_And_Resolve (Exp, Exp_Type);

   <<Leave>>
      Scope_Suppress := Svg_Suppress;
   end Remove_Side_Effects;

   ---------------------------
   -- Represented_As_Scalar --
   ---------------------------

   function Represented_As_Scalar (T : Entity_Id) return Boolean is
      UT : constant Entity_Id := Underlying_Type (T);
   begin
      return Is_Scalar_Type (UT)
        or else (Is_Bit_Packed_Array (UT)
                  and then Is_Scalar_Type (Packed_Array_Type (UT)));
   end Represented_As_Scalar;

   ------------------------------
   -- Requires_Cleanup_Actions --
   ------------------------------

   function Requires_Cleanup_Actions
     (N         : Node_Id;
      Lib_Level : Boolean) return Boolean
   is
      At_Lib_Level : constant Boolean :=
                       Lib_Level
                         and then Nkind_In (N, N_Package_Body,
                                               N_Package_Specification);
      --  N is at the library level if the top-most context is a package and
      --  the path taken to reach N does not inlcude non-package constructs.

   begin
      case Nkind (N) is
         when N_Accept_Statement      |
              N_Block_Statement       |
              N_Entry_Body            |
              N_Package_Body          |
              N_Protected_Body        |
              N_Subprogram_Body       |
              N_Task_Body             =>
            return
              Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
                or else
                  (Present (Handled_Statement_Sequence (N))
                    and then
                      Requires_Cleanup_Actions
                        (Statements (Handled_Statement_Sequence (N)),
                         At_Lib_Level, True));

         when N_Package_Specification =>
            return
              Requires_Cleanup_Actions
                (Visible_Declarations (N), At_Lib_Level, True)
                  or else
              Requires_Cleanup_Actions
                (Private_Declarations (N), At_Lib_Level, True);

         when others                  =>
            return False;
      end case;
   end Requires_Cleanup_Actions;

   ------------------------------
   -- Requires_Cleanup_Actions --
   ------------------------------

   function Requires_Cleanup_Actions
     (L                 : List_Id;
      Lib_Level         : Boolean;
      Nested_Constructs : Boolean) return Boolean
   is
      Decl    : Node_Id;
      Expr    : Node_Id;
      Obj_Id  : Entity_Id;
      Obj_Typ : Entity_Id;
      Pack_Id : Entity_Id;
      Typ     : Entity_Id;

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

      Decl := First (L);
      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_Unregister_Tag)
              and then not No_Run_Time_Mode
              and then not Is_Abstract_Type (Typ)
            then
               return True;
            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 Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
               null;

            --  Transient variables are treated separately in order to minimize
            --  the size of the generated code. See Exp_Ch7.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
               return True;

            --  The object is of the form:
            --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
            --
            --    Obj : Access_Typ :=
            --            BIP_Function_Call (BIPalloc => 2, ...)'reference;

            elsif Is_Access_Type (Obj_Typ)
              and then Needs_Finalization
                         (Available_View (Designated_Type (Obj_Typ)))
              and then Present (Expr)
              and then
                (Is_Secondary_Stack_BIP_Func_Call (Expr)
                  or else
                    (Is_Non_BIP_Func_Call (Expr)
                      and then not Is_Related_To_Func_Return (Obj_Id)))
            then
               return True;

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

            elsif Is_Access_Type (Obj_Typ)
              and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
              and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
                                                      N_Object_Declaration
              and then Is_Finalizable_Transient
                         (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
            then
               return True;

            --  Processing for intermediate results of if expressions where
            --  one of the alternatives uses a controlled function call.

            elsif Is_Access_Type (Obj_Typ)
              and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
              and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
                                                      N_Defining_Identifier
              and then Present (Expr)
              and then Nkind (Expr) = N_Null
            then
               return 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.

            elsif Ekind (Obj_Id) = E_Variable
              and then
                (Is_Simple_Protected_Type (Obj_Typ)
                  or else Has_Simple_Protected_Object (Obj_Typ))
            then
               return 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 Lib_Level 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 (Status_Flag_Or_Transient_Decl (Obj_Id))
            then
               return True;

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

            --     Obj1 : CW_Type := Src_Obj;
            --     Obj2 : CW_Type := Function_Call (...);

            --     Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
            --     Tmp  : ... := Function_Call (...)'reference;
            --     Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));

            elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
               return 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)))
              and then Requires_Cleanup_Actions
                         (Actions (Decl), Lib_Level, Nested_Constructs)
            then
               return True;
            end if;

         --  Nested package declarations

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

            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
              and then
                Requires_Cleanup_Actions (Specification (Decl), Lib_Level)
            then
               return True;
            end if;

         --  Nested package bodies

         elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
            Pack_Id := Corresponding_Spec (Decl);

            if Ekind (Pack_Id) /= E_Generic_Package
              and then Requires_Cleanup_Actions (Decl, Lib_Level)
            then
               return True;
            end if;
         end if;

         Next (Decl);
      end loop;

      return False;
   end Requires_Cleanup_Actions;

   ------------------------------------
   -- Safe_Unchecked_Type_Conversion --
   ------------------------------------

   --  Note: this function knows quite a bit about the exact requirements of
   --  Gigi with respect to unchecked type conversions, and its code must be
   --  coordinated with any changes in Gigi in this area.

   --  The above requirements should be documented in Sinfo ???

   function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
      Otyp   : Entity_Id;
      Ityp   : Entity_Id;
      Oalign : Uint;
      Ialign : Uint;
      Pexp   : constant Node_Id := Parent (Exp);

   begin
      --  If the expression is the RHS of an assignment or object declaration
      --   we are always OK because there will always be a target.

      --  Object renaming declarations, (generated for view conversions of
      --  actuals in inlined calls), like object declarations, provide an
      --  explicit type, and are safe as well.

      if (Nkind (Pexp) = N_Assignment_Statement
           and then Expression (Pexp) = Exp)
        or else Nkind_In (Pexp, N_Object_Declaration,
                                N_Object_Renaming_Declaration)
      then
         return True;

      --  If the expression is the prefix of an N_Selected_Component we should
      --  also be OK because GCC knows to look inside the conversion except if
      --  the type is discriminated. We assume that we are OK anyway if the
      --  type is not set yet or if it is controlled since we can't afford to
      --  introduce a temporary in this case.

      elsif Nkind (Pexp) = N_Selected_Component
        and then Prefix (Pexp) = Exp
      then
         if No (Etype (Pexp)) then
            return True;
         else
            return
              not Has_Discriminants (Etype (Pexp))
                or else Is_Constrained (Etype (Pexp));
         end if;
      end if;

      --  Set the output type, this comes from Etype if it is set, otherwise we
      --  take it from the subtype mark, which we assume was already fully
      --  analyzed.

      if Present (Etype (Exp)) then
         Otyp := Etype (Exp);
      else
         Otyp := Entity (Subtype_Mark (Exp));
      end if;

      --  The input type always comes from the expression, and we assume
      --  this is indeed always analyzed, so we can simply get the Etype.

      Ityp := Etype (Expression (Exp));

      --  Initialize alignments to unknown so far

      Oalign := No_Uint;
      Ialign := No_Uint;

      --  Replace a concurrent type by its corresponding record type and each
      --  type by its underlying type and do the tests on those. The original
      --  type may be a private type whose completion is a concurrent type, so
      --  find the underlying type first.

      if Present (Underlying_Type (Otyp)) then
         Otyp := Underlying_Type (Otyp);
      end if;

      if Present (Underlying_Type (Ityp)) then
         Ityp := Underlying_Type (Ityp);
      end if;

      if Is_Concurrent_Type (Otyp) then
         Otyp := Corresponding_Record_Type (Otyp);
      end if;

      if Is_Concurrent_Type (Ityp) then
         Ityp := Corresponding_Record_Type (Ityp);
      end if;

      --  If the base types are the same, we know there is no problem since
      --  this conversion will be a noop.

      if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
         return True;

      --  Same if this is an upwards conversion of an untagged type, and there
      --  are no constraints involved (could be more general???)

      elsif Etype (Ityp) = Otyp
        and then not Is_Tagged_Type (Ityp)
        and then not Has_Discriminants (Ityp)
        and then No (First_Rep_Item (Base_Type (Ityp)))
      then
         return True;

      --  If the expression has an access type (object or subprogram) we assume
      --  that the conversion is safe, because the size of the target is safe,
      --  even if it is a record (which might be treated as having unknown size
      --  at this point).

      elsif Is_Access_Type (Ityp) then
         return True;

      --  If the size of output type is known at compile time, there is never
      --  a problem. Note that unconstrained records are considered to be of
      --  known size, but we can't consider them that way here, because we are
      --  talking about the actual size of the object.

      --  We also make sure that in addition to the size being known, we do not
      --  have a case which might generate an embarrassingly large temp in
      --  stack checking mode.

      elsif Size_Known_At_Compile_Time (Otyp)
        and then
          (not Stack_Checking_Enabled
            or else not May_Generate_Large_Temp (Otyp))
        and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
      then
         return True;

      --  If either type is tagged, then we know the alignment is OK so
      --  Gigi will be able to use pointer punning.

      elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
         return True;

      --  If either type is a limited record type, we cannot do a copy, so say
      --  safe since there's nothing else we can do.

      elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
         return True;

      --  Conversions to and from packed array types are always ignored and
      --  hence are safe.

      elsif Is_Packed_Array_Type (Otyp)
        or else Is_Packed_Array_Type (Ityp)
      then
         return True;
      end if;

      --  The only other cases known to be safe is if the input type's
      --  alignment is known to be at least the maximum alignment for the
      --  target or if both alignments are known and the output type's
      --  alignment is no stricter than the input's. We can use the component
      --  type alignement for an array if a type is an unpacked array type.

      if Present (Alignment_Clause (Otyp)) then
         Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));

      elsif Is_Array_Type (Otyp)
        and then Present (Alignment_Clause (Component_Type (Otyp)))
      then
         Oalign := Expr_Value (Expression (Alignment_Clause
                                           (Component_Type (Otyp))));
      end if;

      if Present (Alignment_Clause (Ityp)) then
         Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));

      elsif Is_Array_Type (Ityp)
        and then Present (Alignment_Clause (Component_Type (Ityp)))
      then
         Ialign := Expr_Value (Expression (Alignment_Clause
                                           (Component_Type (Ityp))));
      end if;

      if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
         return True;

      elsif Ialign /= No_Uint and then Oalign /= No_Uint
        and then Ialign <= Oalign
      then
         return True;

      --   Otherwise, Gigi cannot handle this and we must make a temporary

      else
         return False;
      end if;
   end Safe_Unchecked_Type_Conversion;

   ---------------------------------
   -- Set_Current_Value_Condition --
   ---------------------------------

   --  Note: the implementation of this procedure is very closely tied to the
   --  implementation of Get_Current_Value_Condition. Here we set required
   --  Current_Value fields, and in Get_Current_Value_Condition, we interpret
   --  them, so they must have a consistent view.

   procedure Set_Current_Value_Condition (Cnode : Node_Id) is

      procedure Set_Entity_Current_Value (N : Node_Id);
      --  If N is an entity reference, where the entity is of an appropriate
      --  kind, then set the current value of this entity to Cnode, unless
      --  there is already a definite value set there.

      procedure Set_Expression_Current_Value (N : Node_Id);
      --  If N is of an appropriate form, sets an appropriate entry in current
      --  value fields of relevant entities. Multiple entities can be affected
      --  in the case of an AND or AND THEN.

      ------------------------------
      -- Set_Entity_Current_Value --
      ------------------------------

      procedure Set_Entity_Current_Value (N : Node_Id) is
      begin
         if Is_Entity_Name (N) then
            declare
               Ent : constant Entity_Id := Entity (N);

            begin
               --  Don't capture if not safe to do so

               if not Safe_To_Capture_Value (N, Ent, Cond => True) then
                  return;
               end if;

               --  Here we have a case where the Current_Value field may need
               --  to be set. We set it if it is not already set to a compile
               --  time expression value.

               --  Note that this represents a decision that one condition
               --  blots out another previous one. That's certainly right if
               --  they occur at the same level. If the second one is nested,
               --  then the decision is neither right nor wrong (it would be
               --  equally OK to leave the outer one in place, or take the new
               --  inner one. Really we should record both, but our data
               --  structures are not that elaborate.

               if Nkind (Current_Value (Ent)) not in N_Subexpr then
                  Set_Current_Value (Ent, Cnode);
               end if;
            end;
         end if;
      end Set_Entity_Current_Value;

      ----------------------------------
      -- Set_Expression_Current_Value --
      ----------------------------------

      procedure Set_Expression_Current_Value (N : Node_Id) is
         Cond : Node_Id;

      begin
         Cond := N;

         --  Loop to deal with (ignore for now) any NOT operators present. The
         --  presence of NOT operators will be handled properly when we call
         --  Get_Current_Value_Condition.

         while Nkind (Cond) = N_Op_Not loop
            Cond := Right_Opnd (Cond);
         end loop;

         --  For an AND or AND THEN, recursively process operands

         if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
            Set_Expression_Current_Value (Left_Opnd (Cond));
            Set_Expression_Current_Value (Right_Opnd (Cond));
            return;
         end if;

         --  Check possible relational operator

         if Nkind (Cond) in N_Op_Compare then
            if Compile_Time_Known_Value (Right_Opnd (Cond)) then
               Set_Entity_Current_Value (Left_Opnd (Cond));
            elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
               Set_Entity_Current_Value (Right_Opnd (Cond));
            end if;

            --  Check possible boolean variable reference

         else
            Set_Entity_Current_Value (Cond);
         end if;
      end Set_Expression_Current_Value;

   --  Start of processing for Set_Current_Value_Condition

   begin
      Set_Expression_Current_Value (Condition (Cnode));
   end Set_Current_Value_Condition;

   --------------------------
   -- Set_Elaboration_Flag --
   --------------------------

   procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
      Loc : constant Source_Ptr := Sloc (N);
      Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
      Asn : Node_Id;

   begin
      if Present (Ent) then

         --  Nothing to do if at the compilation unit level, because in this
         --  case the flag is set by the binder generated elaboration routine.

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

         --  Here we do need to generate an assignment statement

         else
            Check_Restriction (No_Elaboration_Code, N);
            Asn :=
              Make_Assignment_Statement (Loc,
                Name       => New_Occurrence_Of (Ent, Loc),
                Expression => Make_Integer_Literal (Loc, Uint_1));

            if Nkind (Parent (N)) = N_Subunit then
               Insert_After (Corresponding_Stub (Parent (N)), Asn);
            else
               Insert_After (N, Asn);
            end if;

            Analyze (Asn);

            --  Kill current value indication. This is necessary because the
            --  tests of this flag are inserted out of sequence and must not
            --  pick up bogus indications of the wrong constant value.

            Set_Current_Value (Ent, Empty);
         end if;
      end if;
   end Set_Elaboration_Flag;

   ----------------------------
   -- Set_Renamed_Subprogram --
   ----------------------------

   procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
   begin
      --  If input node is an identifier, we can just reset it

      if Nkind (N) = N_Identifier then
         Set_Chars  (N, Chars (E));
         Set_Entity (N, E);

         --  Otherwise we have to do a rewrite, preserving Comes_From_Source

      else
         declare
            CS : constant Boolean := Comes_From_Source (N);
         begin
            Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
            Set_Entity (N, E);
            Set_Comes_From_Source (N, CS);
            Set_Analyzed (N, True);
         end;
      end if;
   end Set_Renamed_Subprogram;

   ----------------------------------
   -- Silly_Boolean_Array_Not_Test --
   ----------------------------------

   --  This procedure implements an odd and silly test. We explicitly check
   --  for the case where the 'First of the component type is equal to the
   --  'Last of this component type, and if this is the case, we make sure
   --  that constraint error is raised. The reason is that the NOT is bound
   --  to cause CE in this case, and we will not otherwise catch it.

   --  No such check is required for AND and OR, since for both these cases
   --  False op False = False, and True op True = True. For the XOR case,
   --  see Silly_Boolean_Array_Xor_Test.

   --  Believe it or not, this was reported as a bug. Note that nearly always,
   --  the test will evaluate statically to False, so the code will be
   --  statically removed, and no extra overhead caused.

   procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
      Loc : constant Source_Ptr := Sloc (N);
      CT  : constant Entity_Id  := Component_Type (T);

   begin
      --  The check we install is

      --    constraint_error when
      --      component_type'first = component_type'last
      --        and then array_type'Length /= 0)

      --  We need the last guard because we don't want to raise CE for empty
      --  arrays since no out of range values result. (Empty arrays with a
      --  component type of True .. True -- very useful -- even the ACATS
      --  does not test that marginal case!)

      Insert_Action (N,
        Make_Raise_Constraint_Error (Loc,
          Condition =>
            Make_And_Then (Loc,
              Left_Opnd =>
                Make_Op_Eq (Loc,
                  Left_Opnd =>
                    Make_Attribute_Reference (Loc,
                      Prefix         => New_Occurrence_Of (CT, Loc),
                      Attribute_Name => Name_First),

                  Right_Opnd =>
                    Make_Attribute_Reference (Loc,
                      Prefix         => New_Occurrence_Of (CT, Loc),
                      Attribute_Name => Name_Last)),

              Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
          Reason => CE_Range_Check_Failed));
   end Silly_Boolean_Array_Not_Test;

   ----------------------------------
   -- Silly_Boolean_Array_Xor_Test --
   ----------------------------------

   --  This procedure implements an odd and silly test. We explicitly check
   --  for the XOR case where the component type is True .. True, since this
   --  will raise constraint error. A special check is required since CE
   --  will not be generated otherwise (cf Expand_Packed_Not).

   --  No such check is required for AND and OR, since for both these cases
   --  False op False = False, and True op True = True, and no check is
   --  required for the case of False .. False, since False xor False = False.
   --  See also Silly_Boolean_Array_Not_Test

   procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
      Loc : constant Source_Ptr := Sloc (N);
      CT  : constant Entity_Id  := Component_Type (T);

   begin
      --  The check we install is

      --    constraint_error when
      --      Boolean (component_type'First)
      --        and then Boolean (component_type'Last)
      --        and then array_type'Length /= 0)

      --  We need the last guard because we don't want to raise CE for empty
      --  arrays since no out of range values result (Empty arrays with a
      --  component type of True .. True -- very useful -- even the ACATS
      --  does not test that marginal case!).

      Insert_Action (N,
        Make_Raise_Constraint_Error (Loc,
          Condition =>
            Make_And_Then (Loc,
              Left_Opnd =>
                Make_And_Then (Loc,
                  Left_Opnd =>
                    Convert_To (Standard_Boolean,
                      Make_Attribute_Reference (Loc,
                        Prefix         => New_Occurrence_Of (CT, Loc),
                        Attribute_Name => Name_First)),

                  Right_Opnd =>
                    Convert_To (Standard_Boolean,
                      Make_Attribute_Reference (Loc,
                        Prefix         => New_Occurrence_Of (CT, Loc),
                        Attribute_Name => Name_Last))),

              Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
          Reason => CE_Range_Check_Failed));
   end Silly_Boolean_Array_Xor_Test;

   --------------------------
   -- Target_Has_Fixed_Ops --
   --------------------------

   Integer_Sized_Small : Ureal;
   --  Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
   --  called (we don't want to compute it more than once!)

   Long_Integer_Sized_Small : Ureal;
   --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
   --  is called (we don't want to compute it more than once)

   First_Time_For_THFO : Boolean := True;
   --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)

   function Target_Has_Fixed_Ops
     (Left_Typ   : Entity_Id;
      Right_Typ  : Entity_Id;
      Result_Typ : Entity_Id) return Boolean
   is
      function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
      --  Return True if the given type is a fixed-point type with a small
      --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
      --  an absolute value less than 1.0. This is currently limited to
      --  fixed-point types that map to Integer or Long_Integer.

      ------------------------
      -- Is_Fractional_Type --
      ------------------------

      function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
      begin
         if Esize (Typ) = Standard_Integer_Size then
            return Small_Value (Typ) = Integer_Sized_Small;

         elsif Esize (Typ) = Standard_Long_Integer_Size then
            return Small_Value (Typ) = Long_Integer_Sized_Small;

         else
            return False;
         end if;
      end Is_Fractional_Type;

   --  Start of processing for Target_Has_Fixed_Ops

   begin
      --  Return False if Fractional_Fixed_Ops_On_Target is false

      if not Fractional_Fixed_Ops_On_Target then
         return False;
      end if;

      --  Here the target has Fractional_Fixed_Ops, if first time, compute
      --  standard constants used by Is_Fractional_Type.

      if First_Time_For_THFO then
         First_Time_For_THFO := False;

         Integer_Sized_Small :=
           UR_From_Components
             (Num   => Uint_1,
              Den   => UI_From_Int (Standard_Integer_Size - 1),
              Rbase => 2);

         Long_Integer_Sized_Small :=
           UR_From_Components
             (Num   => Uint_1,
              Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
              Rbase => 2);
      end if;

      --  Return True if target supports fixed-by-fixed multiply/divide for
      --  fractional fixed-point types (see Is_Fractional_Type) and the operand
      --  and result types are equivalent fractional types.

      return Is_Fractional_Type (Base_Type (Left_Typ))
        and then Is_Fractional_Type (Base_Type (Right_Typ))
        and then Is_Fractional_Type (Base_Type (Result_Typ))
        and then Esize (Left_Typ) = Esize (Right_Typ)
        and then Esize (Left_Typ) = Esize (Result_Typ);
   end Target_Has_Fixed_Ops;

   ------------------------------------------
   -- Type_May_Have_Bit_Aligned_Components --
   ------------------------------------------

   function Type_May_Have_Bit_Aligned_Components
     (Typ : Entity_Id) return Boolean
   is
   begin
      --  Array type, check component type

      if Is_Array_Type (Typ) then
         return
           Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));

      --  Record type, check components

      elsif Is_Record_Type (Typ) then
         declare
            E : Entity_Id;

         begin
            E := First_Component_Or_Discriminant (Typ);
            while Present (E) loop
               if Component_May_Be_Bit_Aligned (E)
                 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
               then
                  return True;
               end if;

               Next_Component_Or_Discriminant (E);
            end loop;

            return False;
         end;

      --  Type other than array or record is always OK

      else
         return False;
      end if;
   end Type_May_Have_Bit_Aligned_Components;

   ----------------------------------
   -- Within_Case_Or_If_Expression --
   ----------------------------------

   function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
      Par : Node_Id;

   begin
      --  Locate an enclosing case or if expression. Note: these constructs can
      --  get expanded into Expression_With_Actions, hence the need to test
      --  using the original node.

      Par := N;
      while Present (Par) loop
         if Nkind_In (Original_Node (Par), N_Case_Expression,
                                           N_If_Expression)
         then
            return True;

         --  Prevent the search from going too far

         elsif Nkind_In (Par, N_Entry_Body,
                              N_Package_Body,
                              N_Package_Declaration,
                              N_Protected_Body,
                              N_Subprogram_Body,
                              N_Task_Body)
         then
            return False;
         end if;

         Par := Parent (Par);
      end loop;

      return False;
   end Within_Case_Or_If_Expression;

   ----------------------------
   -- Wrap_Cleanup_Procedure --
   ----------------------------

   procedure Wrap_Cleanup_Procedure (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
      Stmts : constant List_Id    := Statements (Stseq);

   begin
      if Abort_Allowed then
         Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
         Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
      end if;
   end Wrap_Cleanup_Procedure;

end Exp_Util;