Subversion Repositories openrisc_me

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ A T T R                              --

--                                                                          --

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

--                                                                          --

-- You should have received a copy of the GNU General Public License along  --

-- with this program; see file COPYING3.  If not see                        --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

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

with Elists;   use Elists;

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_Ch9;  use Exp_Ch9;

with Exp_Dist; use Exp_Dist;

with Exp_Imgv; use Exp_Imgv;

with Exp_Pakd; use Exp_Pakd;

with Exp_Strm; use Exp_Strm;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Exp_VFpt; use Exp_VFpt;

with Fname;    use Fname;

with Freeze;   use Freeze;

with Gnatvsn;  use Gnatvsn;

with Itypes;   use Itypes;

with Lib;      use Lib;

with Namet;    use Namet;

with Nmake;    use Nmake;

with Nlists;   use Nlists;

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_Ch6;  use Sem_Ch6;

with Sem_Ch7;  use Sem_Ch7;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

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

with Uname;    use Uname;

with Validsw;  use Validsw;

package body Exp_Attr is

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

   -- Local Subprograms --

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

   procedure Compile_Stream_Body_In_Scope

     (N     : Node_Id;

      Decl  : Node_Id;

      Arr   : Entity_Id;

      Check : Boolean);

   --  The body for a stream subprogram may be generated outside of the scope

   --  of the type. If the type is fully private, it may depend on the full

   --  view of other types (e.g. indices) that are currently private as well.

   --  We install the declarations of the package in which the type is declared

   --  before compiling the body in what is its proper environment. The Check

   --  parameter indicates if checks are to be suppressed for the stream body.

   --  We suppress checks for array/record reads, since the rule is that these

   --  are like assignments, out of range values due to uninitialized storage,

   --  or other invalid values do NOT cause a Constraint_Error to be raised.

   procedure Expand_Access_To_Protected_Op

     (N    : Node_Id;

      Pref : Node_Id;

      Typ  : Entity_Id);

   --  An attribute reference to a protected subprogram is transformed into

   --  a pair of pointers: one to the object, and one to the operations.

   --  This expansion is performed for 'Access and for 'Unrestricted_Access.

   procedure Expand_Fpt_Attribute

     (N    : Node_Id;

      Pkg  : RE_Id;

      Nam  : Name_Id;

      Args : List_Id);

   --  This procedure expands a call to a floating-point attribute function.

   --  N is the attribute reference node, and Args is a list of arguments to

   --  be passed to the function call. Pkg identifies the package containing

   --  the appropriate instantiation of System.Fat_Gen. Float arguments in Args

   --  have already been converted to the floating-point type for which Pkg was

   --  instantiated. The Nam argument is the relevant attribute processing

   --  routine to be called. This is the same as the attribute name, except in

   --  the Unaligned_Valid case.

   procedure Expand_Fpt_Attribute_R (N : Node_Id);

   --  This procedure expands a call to a floating-point attribute function

   --  that takes a single floating-point argument. The function to be called

   --  is always the same as the attribute name.

   procedure Expand_Fpt_Attribute_RI (N : Node_Id);

   --  This procedure expands a call to a floating-point attribute function

   --  that takes one floating-point argument and one integer argument. The

   --  function to be called is always the same as the attribute name.

   procedure Expand_Fpt_Attribute_RR (N : Node_Id);

   --  This procedure expands a call to a floating-point attribute function

   --  that takes two floating-point arguments. The function to be called

   --  is always the same as the attribute name.

   procedure Expand_Pred_Succ (N : Node_Id);

   --  Handles expansion of Pred or Succ attributes for case of non-real

   --  operand with overflow checking required.

   function Get_Index_Subtype (N : Node_Id) return Entity_Id;

   --  Used for Last, Last, and Length, when the prefix is an array type.

   --  Obtains the corresponding index subtype.

   procedure Find_Fat_Info

     (T        : Entity_Id;

      Fat_Type : out Entity_Id;

      Fat_Pkg  : out RE_Id);

   --  Given a floating-point type T, identifies the package containing the

   --  attributes for this type (returned in Fat_Pkg), and the corresponding

   --  type for which this package was instantiated from Fat_Gen. Error if T

   --  is not a floating-point type.

   function Find_Stream_Subprogram

     (Typ : Entity_Id;

      Nam : TSS_Name_Type) return Entity_Id;

   --  Returns the stream-oriented subprogram attribute for Typ. For tagged

   --  types, the corresponding primitive operation is looked up, else the

   --  appropriate TSS from the type itself, or from its closest ancestor

   --  defining it, is returned. In both cases, inheritance of representation

   --  aspects is thus taken into account.

   function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;

   --  Given a type, find a corresponding stream convert pragma that applies to

   --  the implementation base type of this type (Typ). If found, return the

   --  pragma node, otherwise return Empty if no pragma is found.

   function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;

   --  Utility for array attributes, returns true on packed constrained

   --  arrays, and on access to same.

   function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;

   --  Returns true iff the given node refers to an attribute call that

   --  can be expanded directly by the back end and does not need front end

   --  expansion. Typically used for rounding and truncation attributes that

   --  appear directly inside a conversion to integer.

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

   -- Compile_Stream_Body_In_Scope --

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

   procedure Compile_Stream_Body_In_Scope

     (N     : Node_Id;

      Decl  : Node_Id;

      Arr   : Entity_Id;

      Check : Boolean)

   is

      Installed : Boolean := False;

      Scop      : constant Entity_Id := Scope (Arr);

      Curr      : constant Entity_Id := Current_Scope;

   begin

      if Is_Hidden (Arr)

        and then not In_Open_Scopes (Scop)

        and then Ekind (Scop) = E_Package

      then

         Push_Scope (Scop);

         Install_Visible_Declarations (Scop);

         Install_Private_Declarations (Scop);

         Installed := True;

         --  The entities in the package are now visible, but the generated

         --  stream entity must appear in the current scope (usually an

         --  enclosing stream function) so that itypes all have their proper

         --  scopes.

         Push_Scope (Curr);

      end if;

      if Check then

         Insert_Action (N, Decl);

      else

         Insert_Action (N, Decl, Suppress => All_Checks);

      end if;

      if Installed then

         --  Remove extra copy of current scope, and package itself

         Pop_Scope;

         End_Package_Scope (Scop);

      end if;

   end Compile_Stream_Body_In_Scope;

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

   -- Expand_Access_To_Protected_Op --

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

   procedure Expand_Access_To_Protected_Op

     (N    : Node_Id;

      Pref : Node_Id;

      Typ  : Entity_Id)

   is

      --  The value of the attribute_reference is a record containing two

      --  fields: an access to the protected object, and an access to the

      --  subprogram itself. The prefix is a selected component.

      Loc     : constant Source_Ptr := Sloc (N);

      Agg     : Node_Id;

      Btyp    : constant Entity_Id := Base_Type (Typ);

      Sub     : Entity_Id;

      Sub_Ref : Node_Id;

      E_T     : constant Entity_Id := Equivalent_Type (Btyp);

      Acc     : constant Entity_Id :=

                  Etype (Next_Component (First_Component (E_T)));

      Obj_Ref : Node_Id;

      Curr    : Entity_Id;

      function May_Be_External_Call return Boolean;

      --  If the 'Access is to a local operation, but appears in a context

      --  where it may lead to a call from outside the object, we must treat

      --  this as an external call. Clearly we cannot tell without full

      --  flow analysis, and a subsequent call that uses this 'Access may

      --  lead to a bounded error (trying to seize locks twice, e.g.). For

      --  now we treat 'Access as a potential external call if it is an actual

      --  in a call to an outside subprogram.

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

      -- May_Be_External_Call --

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

      function May_Be_External_Call return Boolean is

         Subp : Entity_Id;

         Par  : Node_Id := Parent (N);

      begin

         --  Account for the case where the Access attribute is part of a

         --  named parameter association.

         if Nkind (Par) = N_Parameter_Association then

            Par := Parent (Par);

         end if;

         if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)

            and then Is_Entity_Name (Name (Par))

         then

            Subp := Entity (Name (Par));

            return not In_Open_Scopes (Scope (Subp));

         else

            return False;

         end if;

      end May_Be_External_Call;

   --  Start of processing for Expand_Access_To_Protected_Op

   begin

      --  Within the body of the protected type, the prefix

      --  designates a local operation, and the object is the first

      --  parameter of the corresponding protected body of the

      --  current enclosing operation.

      if Is_Entity_Name (Pref) then

         if May_Be_External_Call then

            Sub :=

              New_Occurrence_Of

                (External_Subprogram (Entity (Pref)), Loc);

         else

            Sub :=

              New_Occurrence_Of

                (Protected_Body_Subprogram (Entity (Pref)), Loc);

         end if;

         --  Don't traverse the scopes when the attribute occurs within an init

         --  proc, because we directly use the _init formal of the init proc in

         --  that case.

         Curr := Current_Scope;

         if not Is_Init_Proc (Curr) then

            pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));

            while Scope (Curr) /= Scope (Entity (Pref)) loop

               Curr := Scope (Curr);

            end loop;

         end if;

         --  In case of protected entries the first formal of its Protected_

         --  Body_Subprogram is the address of the object.

         if Ekind (Curr) = E_Entry then

            Obj_Ref :=

               New_Occurrence_Of

                 (First_Formal

                   (Protected_Body_Subprogram (Curr)), Loc);

         --  If the current scope is an init proc, then use the address of the

         --  _init formal as the object reference.

         elsif Is_Init_Proc (Curr) then

            Obj_Ref :=

              Make_Attribute_Reference (Loc,

                Prefix         => New_Occurrence_Of (First_Formal (Curr), Loc),

                Attribute_Name => Name_Address);

         --  In case of protected subprograms the first formal of its

         --  Protected_Body_Subprogram is the object and we get its address.

         else

            Obj_Ref :=

              Make_Attribute_Reference (Loc,

                Prefix =>

                   New_Occurrence_Of

                     (First_Formal

                        (Protected_Body_Subprogram (Curr)), Loc),

                Attribute_Name => Name_Address);

         end if;

      --  Case where the prefix is not an entity name. Find the

      --  version of the protected operation to be called from

      --  outside the protected object.

      else

         Sub :=

           New_Occurrence_Of

             (External_Subprogram

               (Entity (Selector_Name (Pref))), Loc);

         Obj_Ref :=

           Make_Attribute_Reference (Loc,

             Prefix => Relocate_Node (Prefix (Pref)),

               Attribute_Name => Name_Address);

      end if;

      Sub_Ref :=

        Make_Attribute_Reference (Loc,

          Prefix         => Sub,

          Attribute_Name => Name_Access);

      --  We set the type of the access reference to the already generated

      --  access_to_subprogram type, and declare the reference analyzed, to

      --  prevent further expansion when the enclosing aggregate is analyzed.

      Set_Etype (Sub_Ref, Acc);

      Set_Analyzed (Sub_Ref);

      Agg :=

        Make_Aggregate (Loc,

          Expressions => New_List (Obj_Ref, Sub_Ref));

      Rewrite (N, Agg);

      Analyze_And_Resolve (N, E_T);

      --  For subsequent analysis, the node must retain its type. The backend

      --  will replace it with the equivalent type where needed.

      Set_Etype (N, Typ);

   end Expand_Access_To_Protected_Op;

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

   -- Expand_Fpt_Attribute --

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

   procedure Expand_Fpt_Attribute

     (N    : Node_Id;

      Pkg  : RE_Id;

      Nam  : Name_Id;

      Args : List_Id)

   is

      Loc : constant Source_Ptr := Sloc (N);

      Typ : constant Entity_Id  := Etype (N);

      Fnm : Node_Id;

   begin

      --  The function name is the selected component Attr_xxx.yyy where

      --  Attr_xxx is the package name, and yyy is the argument Nam.

      --  Note: it would be more usual to have separate RE entries for each

      --  of the entities in the Fat packages, but first they have identical

      --  names (so we would have to have lots of renaming declarations to

      --  meet the normal RE rule of separate names for all runtime entities),

      --  and second there would be an awful lot of them!

      Fnm :=

        Make_Selected_Component (Loc,

          Prefix        => New_Reference_To (RTE (Pkg), Loc),

          Selector_Name => Make_Identifier (Loc, Nam));

      --  The generated call is given the provided set of parameters, and then

      --  wrapped in a conversion which converts the result to the target type

      --  We use the base type as the target because a range check may be

      --  required.

      Rewrite (N,

        Unchecked_Convert_To (Base_Type (Etype (N)),

          Make_Function_Call (Loc,

            Name                   => Fnm,

            Parameter_Associations => Args)));

      Analyze_And_Resolve (N, Typ);

   end Expand_Fpt_Attribute;

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

   -- Expand_Fpt_Attribute_R --

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

   --  The single argument is converted to its root type to call the

   --  appropriate runtime function, with the actual call being built

   --  by Expand_Fpt_Attribute

   procedure Expand_Fpt_Attribute_R (N : Node_Id) is

      E1  : constant Node_Id    := First (Expressions (N));

      Ftp : Entity_Id;

      Pkg : RE_Id;

   begin

      Find_Fat_Info (Etype (E1), Ftp, Pkg);

      Expand_Fpt_Attribute

        (N, Pkg, Attribute_Name (N),

         New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));

   end Expand_Fpt_Attribute_R;

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

   -- Expand_Fpt_Attribute_RI --

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

   --  The first argument is converted to its root type and the second

   --  argument is converted to standard long long integer to call the

   --  appropriate runtime function, with the actual call being built

   --  by Expand_Fpt_Attribute

   procedure Expand_Fpt_Attribute_RI (N : Node_Id) is

      E1  : constant Node_Id   := First (Expressions (N));

      Ftp : Entity_Id;

      Pkg : RE_Id;

      E2  : constant Node_Id   := Next (E1);

   begin

      Find_Fat_Info (Etype (E1), Ftp, Pkg);

      Expand_Fpt_Attribute

        (N, Pkg, Attribute_Name (N),

         New_List (

           Unchecked_Convert_To (Ftp, Relocate_Node (E1)),

           Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));

   end Expand_Fpt_Attribute_RI;

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

   -- Expand_Fpt_Attribute_RR --

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

   --  The two arguments are converted to their root types to call the

   --  appropriate runtime function, with the actual call being built

   --  by Expand_Fpt_Attribute

   procedure Expand_Fpt_Attribute_RR (N : Node_Id) is

      E1  : constant Node_Id   := First (Expressions (N));

      Ftp : Entity_Id;

      Pkg : RE_Id;

      E2  : constant Node_Id   := Next (E1);

   begin

      Find_Fat_Info (Etype (E1), Ftp, Pkg);

      Expand_Fpt_Attribute

        (N, Pkg, Attribute_Name (N),

         New_List (

           Unchecked_Convert_To (Ftp, Relocate_Node (E1)),

           Unchecked_Convert_To (Ftp, Relocate_Node (E2))));

   end Expand_Fpt_Attribute_RR;

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

   -- Expand_N_Attribute_Reference --

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

   procedure Expand_N_Attribute_Reference (N : Node_Id) is

      Loc   : constant Source_Ptr   := Sloc (N);

      Typ   : constant Entity_Id    := Etype (N);

      Btyp  : constant Entity_Id    := Base_Type (Typ);

      Pref  : constant Node_Id      := Prefix (N);

      Ptyp  : constant Entity_Id    := Etype (Pref);

      Exprs : constant List_Id      := Expressions (N);

      Id    : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));

      procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);

      --  Rewrites a stream attribute for Read, Write or Output with the

      --  procedure call. Pname is the entity for the procedure to call.

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

      -- Rewrite_Stream_Proc_Call --

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

      procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is

         Item       : constant Node_Id   := Next (First (Exprs));

         Formal     : constant Entity_Id := Next_Formal (First_Formal (Pname));

         Formal_Typ : constant Entity_Id := Etype (Formal);

         Is_Written : constant Boolean   := (Ekind (Formal) /= E_In_Parameter);

      begin

         --  The expansion depends on Item, the second actual, which is

         --  the object being streamed in or out.

         --  If the item is a component of a packed array type, and

         --  a conversion is needed on exit, we introduce a temporary to

         --  hold the value, because otherwise the packed reference will

         --  not be properly expanded.

         if Nkind (Item) = N_Indexed_Component

           and then Is_Packed (Base_Type (Etype (Prefix (Item))))

           and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)

           and then Is_Written

         then

            declare

               Temp : constant Entity_Id :=

                        Make_Defining_Identifier

                          (Loc, New_Internal_Name ('V'));

               Decl : Node_Id;

               Assn : Node_Id;

            begin

               Decl :=

                 Make_Object_Declaration (Loc,

                   Defining_Identifier => Temp,

                   Object_Definition    =>

                     New_Occurrence_Of (Formal_Typ, Loc));

               Set_Etype (Temp, Formal_Typ);

               Assn :=

                 Make_Assignment_Statement (Loc,

                   Name => New_Copy_Tree (Item),

                   Expression =>

                     Unchecked_Convert_To

                       (Etype (Item), New_Occurrence_Of (Temp, Loc)));

               Rewrite (Item, New_Occurrence_Of (Temp, Loc));

               Insert_Actions (N,

                 New_List (

                   Decl,

                   Make_Procedure_Call_Statement (Loc,

                     Name => New_Occurrence_Of (Pname, Loc),

                     Parameter_Associations => Exprs),

                   Assn));

               Rewrite (N, Make_Null_Statement (Loc));

               return;

            end;

         end if;

         --  For the class-wide dispatching cases, and for cases in which

         --  the base type of the second argument matches the base type of

         --  the corresponding formal parameter (that is to say the stream

         --  operation is not inherited), we are all set, and can use the

         --  argument unchanged.

         --  For all other cases we do an unchecked conversion of the second

         --  parameter to the type of the formal of the procedure we are

         --  calling. This deals with the private type cases, and with going

         --  to the root type as required in elementary type case.

         if not Is_Class_Wide_Type (Entity (Pref))

           and then not Is_Class_Wide_Type (Etype (Item))

           and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)

         then

            Rewrite (Item,

              Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));

            --  For untagged derived types set Assignment_OK, to prevent

            --  copies from being created when the unchecked conversion

            --  is expanded (which would happen in Remove_Side_Effects

            --  if Expand_N_Unchecked_Conversion were allowed to call

            --  Force_Evaluation). The copy could violate Ada semantics

            --  in cases such as an actual that is an out parameter.

            --  Note that this approach is also used in exp_ch7 for calls

            --  to controlled type operations to prevent problems with

            --  actuals wrapped in unchecked conversions.

            if Is_Untagged_Derivation (Etype (Expression (Item))) then

               Set_Assignment_OK (Item);

            end if;

         end if;

         --  The stream operation to call maybe a renaming created by

         --  an attribute definition clause, and may not be frozen yet.

         --  Ensure that it has the necessary extra formals.

         if not Is_Frozen (Pname) then

            Create_Extra_Formals (Pname);

         end if;

         --  And now rewrite the call

         Rewrite (N,

           Make_Procedure_Call_Statement (Loc,

             Name => New_Occurrence_Of (Pname, Loc),

             Parameter_Associations => Exprs));

         Analyze (N);

      end Rewrite_Stream_Proc_Call;

   --  Start of processing for Expand_N_Attribute_Reference

   begin

      --  Do required validity checking, if enabled. Do not apply check to

      --  output parameters of an Asm instruction, since the value of this

      --  is not set till after the attribute has been elaborated, and do

      --  not apply the check to the arguments of a 'Read or 'Input attribute

      --  reference since the scalar argument is an OUT scalar.

      if Validity_Checks_On and then Validity_Check_Operands

        and then Id /= Attribute_Asm_Output

        and then Id /= Attribute_Read

        and then Id /= Attribute_Input

      then

         declare

            Expr : Node_Id;

         begin

            Expr := First (Expressions (N));

            while Present (Expr) loop

               Ensure_Valid (Expr);

               Next (Expr);

            end loop;

         end;

      end if;

      --  Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-

      --  place function, then a temporary return object needs to be created

      --  and access to it must be passed to the function. Currently we limit

      --  such functions to those with inherently limited result subtypes, but

      --  eventually we plan to expand the functions that are treated as

      --  build-in-place to include other composite result types.

      if Ada_Version >= Ada_05

        and then Is_Build_In_Place_Function_Call (Pref)

      then

         Make_Build_In_Place_Call_In_Anonymous_Context (Pref);

      end if;

      --  If prefix is a protected type name, this is a reference to the

      --  current instance of the type. For a component definition, nothing

      --  to do (expansion will occur in the init proc). In other contexts,

      --  rewrite into reference to current instance.

      if Is_Protected_Self_Reference (Pref)

           and then not

             (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,

                                    N_Discriminant_Association)

                and then Nkind (Parent (Parent (Parent (Parent (N))))) =

                                                      N_Component_Definition)

      then

         Rewrite (Pref, Concurrent_Ref (Pref));

         Analyze (Pref);

      end if;

      --  Remaining processing depends on specific attribute

      case Id is

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

      -- Access --

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

      when Attribute_Access              |

           Attribute_Unchecked_Access    |

           Attribute_Unrestricted_Access =>

         Access_Cases : declare

            Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);

            Btyp_DDT   : Entity_Id;

            function Enclosing_Object (N : Node_Id) return Node_Id;

            --  If N denotes a compound name (selected component, indexed

            --  component, or slice), returns the name of the outermost such

            --  enclosing object. Otherwise returns N. If the object is a

            --  renaming, then the renamed object is returned.

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

            -- Enclosing_Object --

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

            function Enclosing_Object (N : Node_Id) return Node_Id is

               Obj_Name : Node_Id;

            begin

               Obj_Name := N;

               while Nkind_In (Obj_Name, N_Selected_Component,

                                         N_Indexed_Component,

                                         N_Slice)

               loop

                  Obj_Name := Prefix (Obj_Name);

               end loop;

               return Get_Referenced_Object (Obj_Name);

            end Enclosing_Object;

            --  Local declarations

            Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);

         --  Start of processing for Access_Cases

         begin

            Btyp_DDT := Designated_Type (Btyp);

            --  Handle designated types that come from the limited view

            if Ekind (Btyp_DDT) = E_Incomplete_Type

              and then From_With_Type (Btyp_DDT)

              and then Present (Non_Limited_View (Btyp_DDT))

            then

               Btyp_DDT := Non_Limited_View (Btyp_DDT);

            elsif Is_Class_Wide_Type (Btyp_DDT)

               and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type

               and then From_With_Type (Etype (Btyp_DDT))

               and then Present (Non_Limited_View (Etype (Btyp_DDT)))

               and then Present (Class_Wide_Type

                                  (Non_Limited_View (Etype (Btyp_DDT))))

            then

               Btyp_DDT :=

                 Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));

            end if;

            --  In order to improve the text of error messages, the designated

            --  type of access-to-subprogram itypes is set by the semantics as

            --  the associated subprogram entity (see sem_attr). Now we replace

            --  such node with the proper E_Subprogram_Type itype.

            if Id = Attribute_Unrestricted_Access

              and then Is_Subprogram (Directly_Designated_Type (Typ))

            then

               --  The following conditions ensure that this special management

               --  is done only for "Address!(Prim'Unrestricted_Access)" nodes.

               --  At this stage other cases in which the designated type is

               --  still a subprogram (instead of an E_Subprogram_Type) are

               --  wrong because the semantics must have overridden the type of

               --  the node with the type imposed by the context.

               if Nkind (Parent (N)) = N_Unchecked_Type_Conversion

                 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)

               then

                  Set_Etype (N, RTE (RE_Prim_Ptr));

               else

                  declare

                     Subp       : constant Entity_Id :=

                                    Directly_Designated_Type (Typ);

                     Etyp       : Entity_Id;

                     Extra      : Entity_Id := Empty;

                     New_Formal : Entity_Id;

                     Old_Formal : Entity_Id := First_Formal (Subp);

                     Subp_Typ   : Entity_Id;

                  begin

                     Subp_Typ := Create_Itype (E_Subprogram_Type, N);

                     Set_Etype (Subp_Typ, Etype (Subp));

                     Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));

                     if Present (Old_Formal) then

                        New_Formal := New_Copy (Old_Formal);