Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 4                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

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

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_Ch2;  use Exp_Ch2;

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_Intr; use Exp_Intr;

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

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Par_SCO;  use Par_SCO;

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_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 SCIL_LL;  use SCIL_LL;

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.

   function Current_Anonymous_Master return Entity_Id;

   --  Return the entity of the heterogeneous finalization master belonging to

   --  the current unit (either function, package or procedure). This master

   --  services all anonymous access-to-controlled types. If the current unit

   --  does not have such master, create one.

   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.

   procedure Expand_Short_Circuit_Operator (N : Node_Id);

   --  Common expansion processing for short-circuit boolean operators

   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 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 Optimize_Length_Comparison (N : Node_Id);

   --  Given an expression, if it is of the form X'Length op N (or the other

   --  way round), where N is known at compile time to be 0 or 1, and X is a

   --  simple entity, and op is a comparison operator, optimizes it into a

   --  comparison of First and Last.

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

            Arg1 := Right_Opnd (Op1);

            Arg2 := Right_Opnd (Op2);

            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         => Arg1,

                 Attribute_Name => Name_Length)));

      end if;

      Rewrite (N, Call_Node);

      Analyze (N);

   exception

      when RE_Not_Available =>

         return;

   end Build_Boolean_Array_Proc_Call;

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

   -- Current_Anonymous_Master --

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

   function Current_Anonymous_Master return Entity_Id is

      Decls     : List_Id;

      Loc       : Source_Ptr;

      Subp_Body : Node_Id;

      Unit_Decl : Node_Id;

      Unit_Id   : Entity_Id;

   begin

      Unit_Id := Cunit_Entity (Current_Sem_Unit);

      --  Find the entity of the current unit

      if Ekind (Unit_Id) = E_Subprogram_Body then

         --  When processing subprogram bodies, the proper scope is always that

         --  of the spec.

         Subp_Body := Unit_Id;

         while Present (Subp_Body)

           and then Nkind (Subp_Body) /= N_Subprogram_Body

         loop

            Subp_Body := Parent (Subp_Body);

         end loop;

         Unit_Id := Corresponding_Spec (Subp_Body);

      end if;

      Loc := Sloc (Unit_Id);

      Unit_Decl := Unit (Cunit (Current_Sem_Unit));

      --  Find the declarations list of the current unit

      if Nkind (Unit_Decl) = N_Package_Declaration then

         Unit_Decl := Specification (Unit_Decl);

         Decls := Visible_Declarations (Unit_Decl);

         if No (Decls) then

            Decls := New_List (Make_Null_Statement (Loc));

            Set_Visible_Declarations (Unit_Decl, Decls);

         elsif Is_Empty_List (Decls) then

            Append_To (Decls, Make_Null_Statement (Loc));

         end if;

      else

         Decls := Declarations (Unit_Decl);

         if No (Decls) then

            Decls := New_List (Make_Null_Statement (Loc));

            Set_Declarations (Unit_Decl, Decls);

         elsif Is_Empty_List (Decls) then

            Append_To (Decls, Make_Null_Statement (Loc));

         end if;

      end if;

      --  The current unit has an existing anonymous master, traverse its

      --  declarations and locate the entity.

      if Has_Anonymous_Master (Unit_Id) then

         declare

            Decl       : Node_Id;

            Fin_Mas_Id : Entity_Id;

         begin

            Decl := First (Decls);

            while Present (Decl) loop

               --  Look for the first variable in the declarations whole type

               --  is Finalization_Master.

               if Nkind (Decl) = N_Object_Declaration then

                  Fin_Mas_Id := Defining_Identifier (Decl);

                  if Ekind (Fin_Mas_Id) = E_Variable

                    and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)

                  then

                     return Fin_Mas_Id;

                  end if;

               end if;

               Next (Decl);

            end loop;

            --  The master was not found even though the unit was labeled as

            --  having one.

            raise Program_Error;

         end;

      --  Create a new anonymous master

      else

         declare

            First_Decl : constant Node_Id := First (Decls);

            Action     : Node_Id;

            Fin_Mas_Id : Entity_Id;

         begin

            --  Since the master and its associated initialization is inserted

            --  at top level, use the scope of the unit when analyzing.

            Push_Scope (Unit_Id);

            --  Create the finalization master

            Fin_Mas_Id :=

              Make_Defining_Identifier (Loc,

                Chars => New_External_Name (Chars (Unit_Id), "AM"));

            --  Generate:

            --    <Fin_Mas_Id> : Finalization_Master;

            Action :=

              Make_Object_Declaration (Loc,

                Defining_Identifier => Fin_Mas_Id,

                Object_Definition =>

                  New_Reference_To (RTE (RE_Finalization_Master), Loc));

            Insert_Before_And_Analyze (First_Decl, Action);

            --  Mark the unit to prevent the generation of multiple masters

            Set_Has_Anonymous_Master (Unit_Id);

            --  Do not set the base pool and mode of operation on .NET/JVM

            --  since those targets do not support pools and all VM masters

            --  are heterogeneous by default.

            if VM_Target = No_VM then

               --  Generate:

               --    Set_Base_Pool

               --      (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);

               Action :=

                 Make_Procedure_Call_Statement (Loc,

                   Name =>

                     New_Reference_To (RTE (RE_Set_Base_Pool), Loc),

                   Parameter_Associations => New_List (

                     New_Reference_To (Fin_Mas_Id, Loc),

                     Make_Attribute_Reference (Loc,

                       Prefix =>

                         New_Reference_To (RTE (RE_Global_Pool_Object), Loc),

                       Attribute_Name => Name_Unrestricted_Access)));

               Insert_Before_And_Analyze (First_Decl, Action);

               --  Generate:

               --    Set_Is_Heterogeneous (<Fin_Mas_Id>);

               Action :=

                 Make_Procedure_Call_Statement (Loc,

                   Name =>

                     New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc),

                   Parameter_Associations => New_List (

                     New_Reference_To (Fin_Mas_Id, Loc)));

               Insert_Before_And_Analyze (First_Decl, Action);

            end if;

            --  Restore the original state of the scope stack

            Pop_Scope;

            return Fin_Mas_Id;

         end;

      end if;

   end Current_Anonymous_Master;

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

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

         New_Node : Node_Id;

      begin

         if Ada_Version >= Ada_2005

           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

               New_Node := New_Copy (Ref);

            else

               New_Node := New_Reference_To (Ref, Loc);

            end if;

            New_Node :=

              Make_Attribute_Reference (Loc,

                Prefix         => New_Node,

                Attribute_Name => Name_Tag);

            if Tagged_Type_Expansion then

               New_Node := Build_Get_Access_Level (Loc, New_Node);

            elsif VM_Target /= No_VM then

               New_Node :=

                 Make_Function_Call (Loc,

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

                   Parameter_Associations => New_List (New_Node));

            --  Cannot generate the runtime check

            else

               return;

            end if;

            Insert_Action (N,

              Make_Raise_Program_Error (Loc,

                Condition =>

                  Make_Op_Gt (Loc,

                    Left_Opnd  => New_Node,

                    Right_Opnd =>

                      Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),

                Reason => PE_Accessibility_Check_Failed));

         end if;

      end Apply_Accessibility_Check;

      --  Local variables

      Aggr_In_Place : constant Boolean   := Is_Delayed_Aggregate (Exp);

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

      T             : constant Entity_Id := Entity (Indic);

      Node          : Node_Id;

      Tag_Assign    : Node_Id;

      Temp          : Entity_Id;

      Temp_Decl     : Node_Id;

      TagT : Entity_Id := Empty;

      --  Type used as source for tag assignment

      TagR : Node_Id := Empty;

      --  Target reference for tag assignment

   --  Start of processing for Expand_Allocator_Expression

   begin

      --  In the case of an Ada 2012 allocator whose initial value comes from a

      --  function call, pass "the accessibility level determined by the point

      --  of call" (AI05-0234) to the function. Conceptually, this belongs in

      --  Expand_Call but it couldn't be done there (because the Etype of the

      --  allocator wasn't set then) so we generate the parameter here. See

      --  the Boolean variable Defer in (a block within) Expand_Call.

      if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then

         declare

            Subp : Entity_Id;

         begin

            if Nkind (Name (Exp)) = N_Explicit_Dereference then

               Subp := Designated_Type (Etype (Prefix (Name (Exp))));

            else

               Subp := Entity (Name (Exp));

            end if;

            Subp := Ultimate_Alias (Subp);

            if Present (Extra_Accessibility_Of_Result (Subp)) then

               Add_Extra_Actual_To_Call

                 (Subprogram_Call => Exp,

                  Extra_Formal    => Extra_Accessibility_Of_Result (Subp),

                  Extra_Actual    => Dynamic_Accessibility_Level (PtrT));