Subversion Repositories openrisc_me

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 4                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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 Atree;    use Atree;

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_Atag; use Exp_Atag;

with Exp_Ch3;  use Exp_Ch3;

with Exp_Ch6;  use Exp_Ch6;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Disp; use Exp_Disp;

with Exp_Fixd; use Exp_Fixd;

with Exp_Pakd; use Exp_Pakd;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Exp_VFpt; use Exp_VFpt;

with Freeze;   use Freeze;

with Inline;   use Inline;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Cat;  use Sem_Cat;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch13; use Sem_Ch13;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_SCIL; use Sem_SCIL;

with Sem_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Sem_Warn; use Sem_Warn;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Ttypes;   use Ttypes;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

with Validsw;  use Validsw;

package body Exp_Ch4 is

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

   -- Local Subprograms --

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

   procedure Binary_Op_Validity_Checks (N : Node_Id);

   pragma Inline (Binary_Op_Validity_Checks);

   --  Performs validity checks for a binary operator

   procedure Build_Boolean_Array_Proc_Call

     (N   : Node_Id;

      Op1 : Node_Id;

      Op2 : Node_Id);

   --  If a boolean array assignment can be done in place, build call to

   --  corresponding library procedure.

   procedure Displace_Allocator_Pointer (N : Node_Id);

   --  Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and

   --  Expand_Allocator_Expression. Allocating class-wide interface objects

   --  this routine displaces the pointer to the allocated object to reference

   --  the component referencing the corresponding secondary dispatch table.

   procedure Expand_Allocator_Expression (N : Node_Id);

   --  Subsidiary to Expand_N_Allocator, for the case when the expression

   --  is a qualified expression or an aggregate.

   procedure Expand_Array_Comparison (N : Node_Id);

   --  This routine handles expansion of the comparison operators (N_Op_Lt,

   --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic

   --  code for these operators is similar, differing only in the details of

   --  the actual comparison call that is made. Special processing (call a

   --  run-time routine)

   function Expand_Array_Equality

     (Nod    : Node_Id;

      Lhs    : Node_Id;

      Rhs    : Node_Id;

      Bodies : List_Id;

      Typ    : Entity_Id) return Node_Id;

   --  Expand an array equality into a call to a function implementing this

   --  equality, and a call to it. Loc is the location for the generated nodes.

   --  Lhs and Rhs are the array expressions to be compared. Bodies is a list

   --  on which to attach bodies of local functions that are created in the

   --  process. It is the responsibility of the caller to insert those bodies

   --  at the right place. Nod provides the Sloc value for the generated code.

   --  Normally the types used for the generated equality routine are taken

   --  from Lhs and Rhs. However, in some situations of generated code, the

   --  Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies

   --  the type to be used for the formal parameters.

   procedure Expand_Boolean_Operator (N : Node_Id);

   --  Common expansion processing for Boolean operators (And, Or, Xor) for the

   --  case of array type arguments.

   function Expand_Composite_Equality

     (Nod    : Node_Id;

      Typ    : Entity_Id;

      Lhs    : Node_Id;

      Rhs    : Node_Id;

      Bodies : List_Id) return Node_Id;

   --  Local recursive function used to expand equality for nested composite

   --  types. Used by Expand_Record/Array_Equality, Bodies is a list on which

   --  to attach bodies of local functions that are created in the process.

   --  This is the responsibility of the caller to insert those bodies at the

   --  right place. Nod provides the Sloc value for generated code. Lhs and Rhs

   --  are the left and right sides for the comparison, and Typ is the type of

   --  the arrays to compare.

   procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);

   --  Routine to expand concatenation of a sequence of two or more operands

   --  (in the list Operands) and replace node Cnode with the result of the

   --  concatenation. The operands can be of any appropriate type, and can

   --  include both arrays and singleton elements.

   procedure Fixup_Universal_Fixed_Operation (N : Node_Id);

   --  N is a N_Op_Divide or N_Op_Multiply node whose result is universal

   --  fixed. We do not have such a type at runtime, so the purpose of this

   --  routine is to find the real type by looking up the tree. We also

   --  determine if the operation must be rounded.

   function Get_Allocator_Final_List

     (N    : Node_Id;

      T    : Entity_Id;

      PtrT : Entity_Id) return Entity_Id;

   --  If the designated type is controlled, build final_list expression for

   --  created object. If context is an access parameter, create a local access

   --  type to have a usable finalization list.

   function Has_Inferable_Discriminants (N : Node_Id) return Boolean;

   --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable

   --  discriminants if it has a constrained nominal type, unless the object

   --  is a component of an enclosing Unchecked_Union object that is subject

   --  to a per-object constraint and the enclosing object lacks inferable

   --  discriminants.

   --

   --  An expression of an Unchecked_Union type has inferable discriminants

   --  if it is either a name of an object with inferable discriminants or a

   --  qualified expression whose subtype mark denotes a constrained subtype.

   procedure Insert_Dereference_Action (N : Node_Id);

   --  N is an expression whose type is an access. When the type of the

   --  associated storage pool is derived from Checked_Pool, generate a

   --  call to the 'Dereference' primitive operation.

   function Make_Array_Comparison_Op

     (Typ : Entity_Id;

      Nod : Node_Id) return Node_Id;

   --  Comparisons between arrays are expanded in line. This function produces

   --  the body of the implementation of (a > b), where a and b are one-

   --  dimensional arrays of some discrete type. The original node is then

   --  expanded into the appropriate call to this function. Nod provides the

   --  Sloc value for the generated code.

   function Make_Boolean_Array_Op

     (Typ : Entity_Id;

      N   : Node_Id) return Node_Id;

   --  Boolean operations on boolean arrays are expanded in line. This function

   --  produce the body for the node N, which is (a and b), (a or b), or (a xor

   --  b). It is used only the normal case and not the packed case. The type

   --  involved, Typ, is the Boolean array type, and the logical operations in

   --  the body are simple boolean operations. Note that Typ is always a

   --  constrained type (the caller has ensured this by using

   --  Convert_To_Actual_Subtype if necessary).

   procedure Rewrite_Comparison (N : Node_Id);

   --  If N is the node for a comparison whose outcome can be determined at

   --  compile time, then the node N can be rewritten with True or False. If

   --  the outcome cannot be determined at compile time, the call has no

   --  effect. If N is a type conversion, then this processing is applied to

   --  its expression. If N is neither comparison nor a type conversion, the

   --  call has no effect.

   procedure Tagged_Membership

     (N         : Node_Id;

      SCIL_Node : out Node_Id;

      Result    : out Node_Id);

   --  Construct the expression corresponding to the tagged membership test.

   --  Deals with a second operand being (or not) a class-wide type.

   function Safe_In_Place_Array_Op

     (Lhs : Node_Id;

      Op1 : Node_Id;

      Op2 : Node_Id) return Boolean;

   --  In the context of an assignment, where the right-hand side is a boolean

   --  operation on arrays, check whether operation can be performed in place.

   procedure Unary_Op_Validity_Checks (N : Node_Id);

   pragma Inline (Unary_Op_Validity_Checks);

   --  Performs validity checks for a unary operator

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

   -- Binary_Op_Validity_Checks --

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

   procedure Binary_Op_Validity_Checks (N : Node_Id) is

   begin

      if Validity_Checks_On and Validity_Check_Operands then

         Ensure_Valid (Left_Opnd (N));

         Ensure_Valid (Right_Opnd (N));

      end if;

   end Binary_Op_Validity_Checks;

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

   -- Build_Boolean_Array_Proc_Call --

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

   procedure Build_Boolean_Array_Proc_Call

     (N   : Node_Id;

      Op1 : Node_Id;

      Op2 : Node_Id)

   is

      Loc       : constant Source_Ptr := Sloc (N);

      Kind      : constant Node_Kind := Nkind (Expression (N));

      Target    : constant Node_Id   :=

                    Make_Attribute_Reference (Loc,

                      Prefix         => Name (N),

                      Attribute_Name => Name_Address);

      Arg1      : constant Node_Id := Op1;

      Arg2      : Node_Id := Op2;

      Call_Node : Node_Id;

      Proc_Name : Entity_Id;

   begin

      if Kind = N_Op_Not then

         if Nkind (Op1) in N_Binary_Op then

            --  Use negated version of the binary operators

            if Nkind (Op1) = N_Op_And then

               Proc_Name := RTE (RE_Vector_Nand);

            elsif Nkind (Op1) = N_Op_Or then

               Proc_Name := RTE (RE_Vector_Nor);

            else pragma Assert (Nkind (Op1) = N_Op_Xor);

               Proc_Name := RTE (RE_Vector_Xor);

            end if;

            Call_Node :=

              Make_Procedure_Call_Statement (Loc,

                Name => New_Occurrence_Of (Proc_Name, Loc),

                Parameter_Associations => New_List (

                  Target,

                  Make_Attribute_Reference (Loc,

                    Prefix => Left_Opnd (Op1),

                    Attribute_Name => Name_Address),

                  Make_Attribute_Reference (Loc,

                    Prefix => Right_Opnd (Op1),

                    Attribute_Name => Name_Address),

                  Make_Attribute_Reference (Loc,

                    Prefix => Left_Opnd (Op1),

                    Attribute_Name => Name_Length)));

         else

            Proc_Name := RTE (RE_Vector_Not);

            Call_Node :=

              Make_Procedure_Call_Statement (Loc,

                Name => New_Occurrence_Of (Proc_Name, Loc),

                Parameter_Associations => New_List (

                  Target,

                  Make_Attribute_Reference (Loc,

                    Prefix => Op1,

                    Attribute_Name => Name_Address),

                  Make_Attribute_Reference (Loc,

                    Prefix => Op1,

                     Attribute_Name => Name_Length)));

         end if;

      else

         --  We use the following equivalences:

         --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)

         --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)

         --   (not X) xor (not Y)  =  X xor Y

         --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)

         if Nkind (Op1) = N_Op_Not then

            if Kind = N_Op_And then

               Proc_Name := RTE (RE_Vector_Nor);

            elsif Kind = N_Op_Or then

               Proc_Name := RTE (RE_Vector_Nand);

            else

               Proc_Name := RTE (RE_Vector_Xor);

            end if;

         else

            if Kind = N_Op_And then

               Proc_Name := RTE (RE_Vector_And);

            elsif Kind = N_Op_Or then

               Proc_Name := RTE (RE_Vector_Or);

            elsif Nkind (Op2) = N_Op_Not then

               Proc_Name := RTE (RE_Vector_Nxor);

               Arg2 := Right_Opnd (Op2);

            else

               Proc_Name := RTE (RE_Vector_Xor);

            end if;

         end if;

         Call_Node :=

           Make_Procedure_Call_Statement (Loc,

             Name => New_Occurrence_Of (Proc_Name, Loc),

             Parameter_Associations => New_List (

               Target,

                  Make_Attribute_Reference (Loc,

                    Prefix => Arg1,

                    Attribute_Name => Name_Address),

                  Make_Attribute_Reference (Loc,

                    Prefix => Arg2,

                    Attribute_Name => Name_Address),

                 Make_Attribute_Reference (Loc,

                   Prefix => Op1,

                    Attribute_Name => Name_Length)));

      end if;

      Rewrite (N, Call_Node);

      Analyze (N);

   exception

      when RE_Not_Available =>

         return;

   end Build_Boolean_Array_Proc_Call;

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

   -- Displace_Allocator_Pointer --

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

   procedure Displace_Allocator_Pointer (N : Node_Id) is

      Loc       : constant Source_Ptr := Sloc (N);

      Orig_Node : constant Node_Id := Original_Node (N);

      Dtyp      : Entity_Id;

      Etyp      : Entity_Id;

      PtrT      : Entity_Id;

   begin

      --  Do nothing in case of VM targets: the virtual machine will handle

      --  interfaces directly.

      if not Tagged_Type_Expansion then

         return;

      end if;

      pragma Assert (Nkind (N) = N_Identifier

        and then Nkind (Orig_Node) = N_Allocator);

      PtrT := Etype (Orig_Node);

      Dtyp := Available_View (Designated_Type (PtrT));

      Etyp := Etype (Expression (Orig_Node));

      if Is_Class_Wide_Type (Dtyp)

        and then Is_Interface (Dtyp)

      then

         --  If the type of the allocator expression is not an interface type

         --  we can generate code to reference the record component containing

         --  the pointer to the secondary dispatch table.

         if not Is_Interface (Etyp) then

            declare

               Saved_Typ : constant Entity_Id := Etype (Orig_Node);

            begin

               --  1) Get access to the allocated object

               Rewrite (N,

                 Make_Explicit_Dereference (Loc,

                   Relocate_Node (N)));

               Set_Etype (N, Etyp);

               Set_Analyzed (N);

               --  2) Add the conversion to displace the pointer to reference

               --     the secondary dispatch table.

               Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));

               Analyze_And_Resolve (N, Dtyp);

               --  3) The 'access to the secondary dispatch table will be used

               --     as the value returned by the allocator.

               Rewrite (N,

                 Make_Attribute_Reference (Loc,

                   Prefix         => Relocate_Node (N),

                   Attribute_Name => Name_Access));

               Set_Etype (N, Saved_Typ);

               Set_Analyzed (N);

            end;

         --  If the type of the allocator expression is an interface type we

         --  generate a run-time call to displace "this" to reference the

         --  component containing the pointer to the secondary dispatch table

         --  or else raise Constraint_Error if the actual object does not

         --  implement the target interface. This case corresponds with the

         --  following example:

         --   function Op (Obj : Iface_1'Class) return access Iface_2'Class is

         --   begin

         --      return new Iface_2'Class'(Obj);

         --   end Op;

         else

            Rewrite (N,

              Unchecked_Convert_To (PtrT,

                Make_Function_Call (Loc,

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

                  Parameter_Associations => New_List (

                    Unchecked_Convert_To (RTE (RE_Address),

                      Relocate_Node (N)),

                    New_Occurrence_Of

                      (Elists.Node

                        (First_Elmt

                          (Access_Disp_Table (Etype (Base_Type (Dtyp))))),

                       Loc)))));

            Analyze_And_Resolve (N, PtrT);

         end if;

      end if;

   end Displace_Allocator_Pointer;

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

   -- Expand_Allocator_Expression --

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

   procedure Expand_Allocator_Expression (N : Node_Id) is

      Loc    : constant Source_Ptr := Sloc (N);

      Exp    : constant Node_Id    := Expression (Expression (N));

      PtrT   : constant Entity_Id  := Etype (N);

      DesigT : constant Entity_Id  := Designated_Type (PtrT);

      procedure Apply_Accessibility_Check

        (Ref            : Node_Id;

         Built_In_Place : Boolean := False);

      --  Ada 2005 (AI-344): For an allocator with a class-wide designated

      --  type, generate an accessibility check to verify that the level of the

      --  type of the created object is not deeper than the level of the access

      --  type. If the type of the qualified expression is class- wide, then

      --  always generate the check (except in the case where it is known to be

      --  unnecessary, see comment below). Otherwise, only generate the check

      --  if the level of the qualified expression type is statically deeper

      --  than the access type.

      --

      --  Although the static accessibility will generally have been performed

      --  as a legality check, it won't have been done in cases where the

      --  allocator appears in generic body, so a run-time check is needed in

      --  general. One special case is when the access type is declared in the

      --  same scope as the class-wide allocator, in which case the check can

      --  never fail, so it need not be generated.

      --

      --  As an open issue, there seem to be cases where the static level

      --  associated with the class-wide object's underlying type is not

      --  sufficient to perform the proper accessibility check, such as for

      --  allocators in nested subprograms or accept statements initialized by

      --  class-wide formals when the actual originates outside at a deeper

      --  static level. The nested subprogram case might require passing

      --  accessibility levels along with class-wide parameters, and the task

      --  case seems to be an actual gap in the language rules that needs to

      --  be fixed by the ARG. ???

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

      -- Apply_Accessibility_Check --

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

      procedure Apply_Accessibility_Check

        (Ref            : Node_Id;

         Built_In_Place : Boolean := False)

      is

         Ref_Node : Node_Id;

      begin

         --  Note: we skip the accessibility check for the VM case, since

         --  there does not seem to be any practical way of implementing it.

         if Ada_Version >= Ada_05

           and then Tagged_Type_Expansion

           and then Is_Class_Wide_Type (DesigT)

           and then not Scope_Suppress (Accessibility_Check)

           and then

             (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)

               or else

                 (Is_Class_Wide_Type (Etype (Exp))

                   and then Scope (PtrT) /= Current_Scope))

         then

            --  If the allocator was built in place Ref is already a reference

            --  to the access object initialized to the result of the allocator

            --  (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise

            --  it is the entity associated with the object containing the

            --  address of the allocated object.

            if Built_In_Place then

               Ref_Node := New_Copy (Ref);

            else

               Ref_Node := New_Reference_To (Ref, Loc);

            end if;

            Insert_Action (N,

               Make_Raise_Program_Error (Loc,

                 Condition =>

                   Make_Op_Gt (Loc,

                     Left_Opnd  =>

                       Build_Get_Access_Level (Loc,

                         Make_Attribute_Reference (Loc,

                           Prefix => Ref_Node,

                           Attribute_Name => Name_Tag)),

                     Right_Opnd =>

                       Make_Integer_Literal (Loc,

                         Type_Access_Level (PtrT))),

                 Reason => PE_Accessibility_Check_Failed));

         end if;

      end Apply_Accessibility_Check;

      --  Local variables

      Indic : constant Node_Id   := Subtype_Mark (Expression (N));

      T     : constant Entity_Id := Entity (Indic);

      Flist : Node_Id;

      Node  : Node_Id;

      Temp  : Entity_Id;

      TagT : Entity_Id := Empty;

      --  Type used as source for tag assignment

      TagR : Node_Id := Empty;

      --  Target reference for tag assignment

      Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);

      Tag_Assign : Node_Id;

      Tmp_Node   : Node_Id;

   --  Start of processing for Expand_Allocator_Expression

   begin

      if Is_Tagged_Type (T) or else Needs_Finalization (T) then

         if Is_CPP_Constructor_Call (Exp) then

            --  Generate:

            --  Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn

            --  Allocate the object with no expression

            Node := Relocate_Node (N);

            Set_Expression (Node, New_Reference_To (Etype (Exp), Loc));

            --  Avoid its expansion to avoid generating a call to the default

            --  C++ constructor

            Set_Analyzed (Node);

            Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));

            Insert_Action (N,

              Make_Object_Declaration (Loc,

                Defining_Identifier => Temp,

                Constant_Present    => True,

                Object_Definition   => New_Reference_To (PtrT, Loc),

                Expression          => Node));

            Apply_Accessibility_Check (Temp);

            --  Locate the enclosing list and insert the C++ constructor call

            declare

               P : Node_Id;

            begin

               P := Parent (Node);

               while not Is_List_Member (P) loop

                  P := Parent (P);

               end loop;

               Insert_List_After_And_Analyze (P,

                 Build_Initialization_Call (Loc,

                   Id_Ref =>

                     Make_Explicit_Dereference (Loc,

                       Prefix => New_Reference_To (Temp, Loc)),

                   Typ => Etype (Exp),

                   Constructor_Ref => Exp));

            end;

            Rewrite (N, New_Reference_To (Temp, Loc));

            Analyze_And_Resolve (N, PtrT);

            return;

         end if;

         --  Ada 2005 (AI-318-02): If the initialization expression is a call

         --  to a build-in-place function, then access to the allocated object

         --  must be passed to the function. Currently we limit such functions

         --  to those with constrained limited result subtypes, but eventually

         --  we plan to expand the allowed forms of functions that are treated

         --  as build-in-place.

         if Ada_Version >= Ada_05

           and then Is_Build_In_Place_Function_Call (Exp)

         then

            Make_Build_In_Place_Call_In_Allocator (N, Exp);

            Apply_Accessibility_Check (N, Built_In_Place => True);

            return;

         end if;

         --    Actions inserted before:

         --              Temp : constant ptr_T := new T'(Expression);

         --   <no CW>    Temp._tag := T'tag;

         --   <CTRL>     Adjust (Finalizable (Temp.all));

         --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));

         --  We analyze by hand the new internal allocator to avoid

         --  any recursion and inappropriate call to Initialize

         --  We don't want to remove side effects when the expression must be

         --  built in place. In the case of a build-in-place function call,

         --  that could lead to a duplication of the call, which was already

         --  substituted for the allocator.

         if not Aggr_In_Place then

            Remove_Side_Effects (Exp);

         end if;

         Temp :=

           Make_Defining_Identifier (Loc, New_Internal_Name ('P'));

         --  For a class wide allocation generate the following code:

         --    type Equiv_Record is record ... end record;

         --    implicit subtype CW is <Class_Wide_Subytpe>;

         --    temp : PtrT := new CW'(CW!(expr));

         if Is_Class_Wide_Type (T) then

            Expand_Subtype_From_Expr (Empty, T, Indic, Exp);

            --  Ada 2005 (AI-251): If the expression is a class-wide interface

            --  object we generate code to move up "this" to reference the

            --  base of the object before allocating the new object.

            --  Note that Exp'Address is recursively expanded into a call

            --  to Base_Address (Exp.Tag)

            if Is_Class_Wide_Type (Etype (Exp))

              and then Is_Interface (Etype (Exp))

              and then Tagged_Type_Expansion

            then

               Set_Expression

                 (Expression (N),

                  Unchecked_Convert_To (Entity (Indic),

                    Make_Explicit_Dereference (Loc,

                      Unchecked_Convert_To (RTE (RE_Tag_Ptr),

                        Make_Attribute_Reference (Loc,

                          Prefix         => Exp,

                          Attribute_Name => Name_Address)))));

            else

               Set_Expression

                 (Expression (N),

                  Unchecked_Convert_To (Entity (Indic), Exp));

            end if;

            Analyze_And_Resolve (Expression (N), Entity (Indic));

         end if;

         --  Keep separate the management of allocators returning interfaces

         if not Is_Interface (Directly_Designated_Type (PtrT)) then

            if Aggr_In_Place then

               Tmp_Node :=

                 Make_Object_Declaration (Loc,

                   Defining_Identifier => Temp,

                   Object_Definition   => New_Reference_To (PtrT, Loc),

                   Expression          =>

                     Make_Allocator (Loc,

                       New_Reference_To (Etype (Exp), Loc)));

               --  Copy the Comes_From_Source flag for the allocator we just

               --  built, since logically this allocator is a replacement of

               --  the original allocator node. This is for proper handling of

               --  restriction No_Implicit_Heap_Allocations.

               Set_Comes_From_Source

                 (Expression (Tmp_Node), Comes_From_Source (N));

               Set_No_Initialization (Expression (Tmp_Node));

               Insert_Action (N, Tmp_Node);

               if Needs_Finalization (T)

                 and then Ekind (PtrT) = E_Anonymous_Access_Type

               then

                  --  Create local finalization list for access parameter

                  Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);

               end if;

               Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);

            else

               Node := Relocate_Node (N);

               Set_Analyzed (Node);

               Insert_Action (N,

                 Make_Object_Declaration (Loc,

                   Defining_Identifier => Temp,

                   Constant_Present    => True,

                   Object_Definition   => New_Reference_To (PtrT, Loc),

                   Expression          => Node));

            end if;

         --  Ada 2005 (AI-251): Handle allocators whose designated type is an

         --  interface type. In this case we use the type of the qualified

         --  expression to allocate the object.

         else

            declare

               Def_Id   : constant Entity_Id :=

                            Make_Defining_Identifier (Loc,

                              New_Internal_Name ('T'));

               New_Decl : Node_Id;

            begin

               New_Decl :=

                 Make_Full_Type_Declaration (Loc,

                   Defining_Identifier => Def_Id,

                   Type_Definition =>

                     Make_Access_To_Object_Definition (Loc,

                       All_Present            => True,

                       Null_Exclusion_Present => False,

                       Constant_Present       => False,

                       Subtype_Indication     =>

                         New_Reference_To (Etype (Exp), Loc)));

               Insert_Action (N, New_Decl);

               --  Inherit the final chain to ensure that the expansion of the

               --  aggregate is correct in case of controlled types

               if Needs_Finalization (Directly_Designated_Type (PtrT)) then

                  Set_Associated_Final_Chain (Def_Id,

                    Associated_Final_Chain (PtrT));

               end if;

               --  Declare the object using the previous type declaration

               if Aggr_In_Place then

                  Tmp_Node :=

                    Make_Object_Declaration (Loc,

                      Defining_Identifier => Temp,

                      Object_Definition   => New_Reference_To (Def_Id, Loc),

                      Expression          =>

                        Make_Allocator (Loc,

                          New_Reference_To (Etype (Exp), Loc)));

                  --  Copy the Comes_From_Source flag for the allocator we just