Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ A T T R                              --

--                                                                          --

--                                 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 Ada.Characters.Latin_1; use Ada.Characters.Latin_1;

with Atree;    use Atree;

with Casing;   use Casing;

with Checks;   use Checks;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Eval_Fat;

with Exp_Dist; use Exp_Dist;

with Exp_Util; use Exp_Util;

with Expander; use Expander;

with Freeze;   use Freeze;

with Gnatvsn;  use Gnatvsn;

with Itypes;   use Itypes;

with Lib;      use Lib;

with Lib.Xref; use Lib.Xref;

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

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Cat;  use Sem_Cat;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch10; use Sem_Ch10;

with Sem_Dim;  use Sem_Dim;

with Sem_Dist; use Sem_Dist;

with Sem_Elim; use Sem_Elim;

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

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Stringt;  use Stringt;

with Style;

with Stylesw;  use Stylesw;

with Targparm; use Targparm;

with Ttypes;   use Ttypes;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

package body Sem_Attr is

   True_Value  : constant Uint := Uint_1;

   False_Value : constant Uint := Uint_0;

   --  Synonyms to be used when these constants are used as Boolean values

   Bad_Attribute : exception;

   --  Exception raised if an error is detected during attribute processing,

   --  used so that we can abandon the processing so we don't run into

   --  trouble with cascaded errors.

   --  The following array is the list of attributes defined in the Ada 83 RM

   --  that are not included in Ada 95, but still get recognized in GNAT.

   Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(

      Attribute_Address                |

      Attribute_Aft                    |

      Attribute_Alignment              |

      Attribute_Base                   |

      Attribute_Callable               |

      Attribute_Constrained            |

      Attribute_Count                  |

      Attribute_Delta                  |

      Attribute_Digits                 |

      Attribute_Emax                   |

      Attribute_Epsilon                |

      Attribute_First                  |

      Attribute_First_Bit              |

      Attribute_Fore                   |

      Attribute_Image                  |

      Attribute_Large                  |

      Attribute_Last                   |

      Attribute_Last_Bit               |

      Attribute_Leading_Part           |

      Attribute_Length                 |

      Attribute_Machine_Emax           |

      Attribute_Machine_Emin           |

      Attribute_Machine_Mantissa       |

      Attribute_Machine_Overflows      |

      Attribute_Machine_Radix          |

      Attribute_Machine_Rounds         |

      Attribute_Mantissa               |

      Attribute_Pos                    |

      Attribute_Position               |

      Attribute_Pred                   |

      Attribute_Range                  |

      Attribute_Safe_Emax              |

      Attribute_Safe_Large             |

      Attribute_Safe_Small             |

      Attribute_Size                   |

      Attribute_Small                  |

      Attribute_Storage_Size           |

      Attribute_Succ                   |

      Attribute_Terminated             |

      Attribute_Val                    |

      Attribute_Value                  |

      Attribute_Width                  => True,

      others                           => False);

   --  The following array is the list of attributes defined in the Ada 2005

   --  RM which are not defined in Ada 95. These are recognized in Ada 95 mode,

   --  but in Ada 95 they are considered to be implementation defined.

   Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(

      Attribute_Machine_Rounding       |

      Attribute_Mod                    |

      Attribute_Priority               |

      Attribute_Stream_Size            |

      Attribute_Wide_Wide_Width        => True,

      others                           => False);

   --  The following array contains all attributes that imply a modification

   --  of their prefixes or result in an access value. Such prefixes can be

   --  considered as lvalues.

   Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=

      Attribute_Class_Array'(

      Attribute_Access                 |

      Attribute_Address                |

      Attribute_Input                  |

      Attribute_Read                   |

      Attribute_Unchecked_Access       |

      Attribute_Unrestricted_Access    => True,

      others                           => False);

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

   -- Local_Subprograms --

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

   procedure Eval_Attribute (N : Node_Id);

   --  Performs compile time evaluation of attributes where possible, leaving

   --  the Is_Static_Expression/Raises_Constraint_Error flags appropriately

   --  set, and replacing the node with a literal node if the value can be

   --  computed at compile time. All static attribute references are folded,

   --  as well as a number of cases of non-static attributes that can always

   --  be computed at compile time (e.g. floating-point model attributes that

   --  are applied to non-static subtypes). Of course in such cases, the

   --  Is_Static_Expression flag will not be set on the resulting literal.

   --  Note that the only required action of this procedure is to catch the

   --  static expression cases as described in the RM. Folding of other cases

   --  is done where convenient, but some additional non-static folding is in

   --  N_Expand_Attribute_Reference in cases where this is more convenient.

   function Is_Anonymous_Tagged_Base

     (Anon : Entity_Id;

      Typ  : Entity_Id)

      return Boolean;

   --  For derived tagged types that constrain parent discriminants we build

   --  an anonymous unconstrained base type. We need to recognize the relation

   --  between the two when analyzing an access attribute for a constrained

   --  component, before the full declaration for Typ has been analyzed, and

   --  where therefore the prefix of the attribute does not match the enclosing

   --  scope.

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

   -- Analyze_Attribute --

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

   procedure Analyze_Attribute (N : Node_Id) is

      Loc     : constant Source_Ptr   := Sloc (N);

      Aname   : constant Name_Id      := Attribute_Name (N);

      P       : constant Node_Id      := Prefix (N);

      Exprs   : constant List_Id      := Expressions (N);

      Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);

      E1      : Node_Id;

      E2      : Node_Id;

      P_Type : Entity_Id;

      --  Type of prefix after analysis

      P_Base_Type : Entity_Id;

      --  Base type of prefix after analysis

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

      -- Local Subprograms --

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

      procedure Analyze_Access_Attribute;

      --  Used for Access, Unchecked_Access, Unrestricted_Access attributes.

      --  Internally, Id distinguishes which of the three cases is involved.

      procedure Bad_Attribute_For_Predicate;

      --  Output error message for use of a predicate (First, Last, Range) not

      --  allowed with a type that has predicates. If the type is a generic

      --  actual, then the message is a warning, and we generate code to raise

      --  program error with an appropriate reason. No error message is given

      --  for internally generated uses of the attributes.

      --  The legality rule only applies to scalar types, even though the

      --  current AI mentions all subtypes.

      procedure Check_Array_Or_Scalar_Type;

      --  Common procedure used by First, Last, Range attribute to check

      --  that the prefix is a constrained array or scalar type, or a name

      --  of an array object, and that an argument appears only if appropriate

      --  (i.e. only in the array case).

      procedure Check_Array_Type;

      --  Common semantic checks for all array attributes. Checks that the

      --  prefix is a constrained array type or the name of an array object.

      --  The error message for non-arrays is specialized appropriately.

      procedure Check_Asm_Attribute;

      --  Common semantic checks for Asm_Input and Asm_Output attributes

      procedure Check_Component;

      --  Common processing for Bit_Position, First_Bit, Last_Bit, and

      --  Position. Checks prefix is an appropriate selected component.

      procedure Check_Decimal_Fixed_Point_Type;

      --  Check that prefix of attribute N is a decimal fixed-point type

      procedure Check_Dereference;

      --  If the prefix of attribute is an object of an access type, then

      --  introduce an explicit dereference, and adjust P_Type accordingly.

      procedure Check_Discrete_Type;

      --  Verify that prefix of attribute N is a discrete type

      procedure Check_E0;

      --  Check that no attribute arguments are present

      procedure Check_Either_E0_Or_E1;

      --  Check that there are zero or one attribute arguments present

      procedure Check_E1;

      --  Check that exactly one attribute argument is present

      procedure Check_E2;

      --  Check that two attribute arguments are present

      procedure Check_Enum_Image;

      --  If the prefix type is an enumeration type, set all its literals

      --  as referenced, since the image function could possibly end up

      --  referencing any of the literals indirectly. Same for Enum_Val.

      --  Set the flag only if the reference is in the main code unit. Same

      --  restriction when resolving 'Value; otherwise an improperly set

      --  reference when analyzing an inlined body will lose a proper warning

      --  on a useless with_clause.

      procedure Check_Fixed_Point_Type;

      --  Verify that prefix of attribute N is a fixed type

      procedure Check_Fixed_Point_Type_0;

      --  Verify that prefix of attribute N is a fixed type and that

      --  no attribute expressions are present

      procedure Check_Floating_Point_Type;

      --  Verify that prefix of attribute N is a float type

      procedure Check_Floating_Point_Type_0;

      --  Verify that prefix of attribute N is a float type and that

      --  no attribute expressions are present

      procedure Check_Floating_Point_Type_1;

      --  Verify that prefix of attribute N is a float type and that

      --  exactly one attribute expression is present

      procedure Check_Floating_Point_Type_2;

      --  Verify that prefix of attribute N is a float type and that

      --  two attribute expressions are present

      procedure Legal_Formal_Attribute;

      --  Common processing for attributes Definite and Has_Discriminants.

      --  Checks that prefix is generic indefinite formal type.

      procedure Check_SPARK_Restriction_On_Attribute;

      --  Issue an error in formal mode because attribute N is allowed

      procedure Check_Integer_Type;

      --  Verify that prefix of attribute N is an integer type

      procedure Check_Modular_Integer_Type;

      --  Verify that prefix of attribute N is a modular integer type

      procedure Check_Not_CPP_Type;

      --  Check that P (the prefix of the attribute) is not an CPP type

      --  for which no Ada predefined primitive is available.

      procedure Check_Not_Incomplete_Type;

      --  Check that P (the prefix of the attribute) is not an incomplete

      --  type or a private type for which no full view has been given.

      procedure Check_Object_Reference (P : Node_Id);

      --  Check that P (the prefix of the attribute) is an object reference

      procedure Check_Program_Unit;

      --  Verify that prefix of attribute N is a program unit

      procedure Check_Real_Type;

      --  Verify that prefix of attribute N is fixed or float type

      procedure Check_Scalar_Type;

      --  Verify that prefix of attribute N is a scalar type

      procedure Check_Standard_Prefix;

      --  Verify that prefix of attribute N is package Standard

      procedure Check_Stream_Attribute (Nam : TSS_Name_Type);

      --  Validity checking for stream attribute. Nam is the TSS name of the

      --  corresponding possible defined attribute function (e.g. for the

      --  Read attribute, Nam will be TSS_Stream_Read).

      procedure Check_PolyORB_Attribute;

      --  Validity checking for PolyORB/DSA attribute

      procedure Check_Task_Prefix;

      --  Verify that prefix of attribute N is a task or task type

      procedure Check_Type;

      --  Verify that the prefix of attribute N is a type

      procedure Check_Unit_Name (Nod : Node_Id);

      --  Check that Nod is of the form of a library unit name, i.e that

      --  it is an identifier, or a selected component whose prefix is

      --  itself of the form of a library unit name. Note that this is

      --  quite different from Check_Program_Unit, since it only checks

      --  the syntactic form of the name, not the semantic identity. This

      --  is because it is used with attributes (Elab_Body, Elab_Spec,

      --  UET_Address and Elaborated) which can refer to non-visible unit.

      procedure Error_Attr (Msg : String; Error_Node : Node_Id);

      pragma No_Return (Error_Attr);

      procedure Error_Attr;

      pragma No_Return (Error_Attr);

      --  Posts error using Error_Msg_N at given node, sets type of attribute

      --  node to Any_Type, and then raises Bad_Attribute to avoid any further

      --  semantic processing. The message typically contains a % insertion

      --  character which is replaced by the attribute name. The call with

      --  no arguments is used when the caller has already generated the

      --  required error messages.

      procedure Error_Attr_P (Msg : String);

      pragma No_Return (Error_Attr);

      --  Like Error_Attr, but error is posted at the start of the prefix

      procedure Standard_Attribute (Val : Int);

      --  Used to process attributes whose prefix is package Standard which

      --  yield values of type Universal_Integer. The attribute reference

      --  node is rewritten with an integer literal of the given value.

      procedure Unexpected_Argument (En : Node_Id);

      --  Signal unexpected attribute argument (En is the argument)

      procedure Validate_Non_Static_Attribute_Function_Call;

      --  Called when processing an attribute that is a function call to a

      --  non-static function, i.e. an attribute function that either takes

      --  non-scalar arguments or returns a non-scalar result. Verifies that

      --  such a call does not appear in a preelaborable context.

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

      -- Analyze_Access_Attribute --

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

      procedure Analyze_Access_Attribute is

         Acc_Type : Entity_Id;

         Scop : Entity_Id;

         Typ  : Entity_Id;

         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;

         --  Build an access-to-object type whose designated type is DT,

         --  and whose Ekind is appropriate to the attribute type. The

         --  type that is constructed is returned as the result.

         procedure Build_Access_Subprogram_Type (P : Node_Id);

         --  Build an access to subprogram whose designated type is the type of

         --  the prefix. If prefix is overloaded, so is the node itself. The

         --  result is stored in Acc_Type.

         function OK_Self_Reference return Boolean;

         --  An access reference whose prefix is a type can legally appear

         --  within an aggregate, where it is obtained by expansion of

         --  a defaulted aggregate. The enclosing aggregate that contains

         --  the self-referenced is flagged so that the self-reference can

         --  be expanded into a reference to the target object (see exp_aggr).

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

         -- Build_Access_Object_Type --

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

         function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is

            Typ : constant Entity_Id :=

                    New_Internal_Entity

                      (E_Access_Attribute_Type, Current_Scope, Loc, 'A');

         begin

            Set_Etype                     (Typ, Typ);

            Set_Is_Itype                  (Typ);

            Set_Associated_Node_For_Itype (Typ, N);

            Set_Directly_Designated_Type  (Typ, DT);

            return Typ;

         end Build_Access_Object_Type;

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

         -- Build_Access_Subprogram_Type --

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

         procedure Build_Access_Subprogram_Type (P : Node_Id) is

            Index : Interp_Index;

            It    : Interp;

            procedure Check_Local_Access (E : Entity_Id);

            --  Deal with possible access to local subprogram. If we have such

            --  an access, we set a flag to kill all tracked values on any call

            --  because this access value may be passed around, and any called

            --  code might use it to access a local procedure which clobbers a

            --  tracked value. If the scope is a loop or block, indicate that

            --  value tracking is disabled for the enclosing subprogram.

            function Get_Kind (E : Entity_Id) return Entity_Kind;

            --  Distinguish between access to regular/protected subprograms

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

            -- Check_Local_Access --

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

            procedure Check_Local_Access (E : Entity_Id) is

            begin

               if not Is_Library_Level_Entity (E) then

                  Set_Suppress_Value_Tracking_On_Call (Current_Scope);

                  Set_Suppress_Value_Tracking_On_Call

                    (Nearest_Dynamic_Scope (Current_Scope));

               end if;

            end Check_Local_Access;

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

            -- Get_Kind --

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

            function Get_Kind (E : Entity_Id) return Entity_Kind is

            begin

               if Convention (E) = Convention_Protected then

                  return E_Access_Protected_Subprogram_Type;

               else

                  return E_Access_Subprogram_Type;

               end if;

            end Get_Kind;

         --  Start of processing for Build_Access_Subprogram_Type

         begin

            --  In the case of an access to subprogram, use the name of the

            --  subprogram itself as the designated type. Type-checking in

            --  this case compares the signatures of the designated types.

            --  Note: This fragment of the tree is temporarily malformed

            --  because the correct tree requires an E_Subprogram_Type entity

            --  as the designated type. In most cases this designated type is

            --  later overridden by the semantics with the type imposed by the

            --  context during the resolution phase. In the specific case of

            --  the expression Address!(Prim'Unrestricted_Access), used to

            --  initialize slots of dispatch tables, this work will be done by

            --  the expander (see Exp_Aggr).

            --  The reason to temporarily add this kind of node to the tree

            --  instead of a proper E_Subprogram_Type itype, is the following:

            --  in case of errors found in the source file we report better

            --  error messages. For example, instead of generating the

            --  following error:

            --      "expected access to subprogram with profile

            --       defined at line X"

            --  we currently generate:

            --      "expected access to function Z defined at line X"

            Set_Etype (N, Any_Type);

            if not Is_Overloaded (P) then

               Check_Local_Access (Entity (P));

               if not Is_Intrinsic_Subprogram (Entity (P)) then

                  Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);

                  Set_Is_Public (Acc_Type, False);

                  Set_Etype (Acc_Type, Acc_Type);

                  Set_Convention (Acc_Type, Convention (Entity (P)));

                  Set_Directly_Designated_Type (Acc_Type, Entity (P));

                  Set_Etype (N, Acc_Type);

                  Freeze_Before (N, Acc_Type);

               end if;

            else

               Get_First_Interp (P, Index, It);

               while Present (It.Nam) loop

                  Check_Local_Access (It.Nam);

                  if not Is_Intrinsic_Subprogram (It.Nam) then

                     Acc_Type := Create_Itype (Get_Kind (It.Nam), N);

                     Set_Is_Public (Acc_Type, False);

                     Set_Etype (Acc_Type, Acc_Type);

                     Set_Convention (Acc_Type, Convention (It.Nam));

                     Set_Directly_Designated_Type (Acc_Type, It.Nam);

                     Add_One_Interp (N, Acc_Type, Acc_Type);

                     Freeze_Before (N, Acc_Type);

                  end if;

                  Get_Next_Interp (Index, It);

               end loop;

            end if;

            --  Cannot be applied to intrinsic. Looking at the tests above,

            --  the only way Etype (N) can still be set to Any_Type is if

            --  Is_Intrinsic_Subprogram was True for some referenced entity.

            if Etype (N) = Any_Type then

               Error_Attr_P ("prefix of % attribute cannot be intrinsic");

            end if;

         end Build_Access_Subprogram_Type;

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

         -- OK_Self_Reference --

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

         function OK_Self_Reference return Boolean is

            Par : Node_Id;

         begin

            Par := Parent (N);

            while Present (Par)

              and then

               (Nkind (Par) = N_Component_Association

                 or else Nkind (Par) in N_Subexpr)

            loop

               if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then

                  if Etype (Par) = Typ then

                     Set_Has_Self_Reference (Par);

                     return True;

                  end if;

               end if;

               Par := Parent (Par);

            end loop;

            --  No enclosing aggregate, or not a self-reference

            return False;

         end OK_Self_Reference;

      --  Start of processing for Analyze_Access_Attribute

      begin

         Check_SPARK_Restriction_On_Attribute;

         Check_E0;

         if Nkind (P) = N_Character_Literal then

            Error_Attr_P

              ("prefix of % attribute cannot be enumeration literal");

         end if;

         --  Case of access to subprogram

         if Is_Entity_Name (P)

           and then Is_Overloadable (Entity (P))

         then

            if Has_Pragma_Inline_Always (Entity (P)) then

               Error_Attr_P

                 ("prefix of % attribute cannot be Inline_Always subprogram");

            end if;

            if Aname = Name_Unchecked_Access then

               Error_Attr ("attribute% cannot be applied to a subprogram", P);

            end if;

            --  Issue an error if the prefix denotes an eliminated subprogram

            Check_For_Eliminated_Subprogram (P, Entity (P));

            --  Check for obsolescent subprogram reference

            Check_Obsolescent_2005_Entity (Entity (P), P);

            --  Build the appropriate subprogram type

            Build_Access_Subprogram_Type (P);

            --  For P'Access or P'Unrestricted_Access, where P is a nested

            --  subprogram, we might be passing P to another subprogram (but we

            --  don't check that here), which might call P. P could modify

            --  local variables, so we need to kill current values. It is

            --  important not to do this for library-level subprograms, because

            --  Kill_Current_Values is very inefficient in the case of library

            --  level packages with lots of tagged types.

            if Is_Library_Level_Entity (Entity (Prefix (N))) then

               null;

            --  Do not kill values on nodes initializing dispatch tables

            --  slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)

            --  is currently generated by the expander only for this

            --  purpose. Done to keep the quality of warnings currently

            --  generated by the compiler (otherwise any declaration of

            --  a tagged type cleans constant indications from its scope).

            elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion

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

                          or else

                        Etype (Parent (N)) = RTE (RE_Size_Ptr))

              and then Is_Dispatching_Operation

                         (Directly_Designated_Type (Etype (N)))

            then

               null;

            else

               Kill_Current_Values;

            end if;

            return;

         --  Component is an operation of a protected type

         elsif Nkind (P) = N_Selected_Component

           and then Is_Overloadable (Entity (Selector_Name (P)))

         then

            if Ekind (Entity (Selector_Name (P))) = E_Entry then

               Error_Attr_P ("prefix of % attribute must be subprogram");

            end if;

            Build_Access_Subprogram_Type (Selector_Name (P));

            return;

         end if;

         --  Deal with incorrect reference to a type, but note that some

         --  accesses are allowed: references to the current type instance,

         --  or in Ada 2005 self-referential pointer in a default-initialized

         --  aggregate.

         if Is_Entity_Name (P) then

            Typ := Entity (P);

            --  The reference may appear in an aggregate that has been expanded

            --  into a loop. Locate scope of type definition, if any.

            Scop := Current_Scope;

            while Ekind (Scop) = E_Loop loop

               Scop := Scope (Scop);

            end loop;

            if Is_Type (Typ) then

               --  OK if we are within the scope of a limited type

               --  let's mark the component as having per object constraint

               if Is_Anonymous_Tagged_Base (Scop, Typ) then

                  Typ := Scop;

                  Set_Entity (P, Typ);

                  Set_Etype  (P, Typ);

               end if;

               if Typ = Scop then

                  declare

                     Q : Node_Id := Parent (N);

                  begin

                     while Present (Q)

                       and then Nkind (Q) /= N_Component_Declaration

                     loop

                        Q := Parent (Q);

                     end loop;

                     if Present (Q) then

                        Set_Has_Per_Object_Constraint

                          (Defining_Identifier (Q), True);

                     end if;

                  end;

                  if Nkind (P) = N_Expanded_Name then

                     Error_Msg_F

                       ("current instance prefix must be a direct name", P);

                  end if;

                  --  If a current instance attribute appears in a component

                  --  constraint it must appear alone; other contexts (spec-

                  --  expressions, within a task body) are not subject to this

                  --  restriction.

                  if not In_Spec_Expression

                    and then not Has_Completion (Scop)

                    and then not

                      Nkind_In (Parent (N), N_Discriminant_Association,

                                            N_Index_Or_Discriminant_Constraint)

                  then

                     Error_Msg_N

                       ("current instance attribute must appear alone", N);

                  end if;

                  if Is_CPP_Class (Root_Type (Typ)) then

                     Error_Msg_N

                       ("?current instance unsupported for derivations of "

                        & "'C'P'P types", N);

                  end if;

               --  OK if we are in initialization procedure for the type

               --  in question, in which case the reference to the type

               --  is rewritten as a reference to the current object.

               elsif Ekind (Scop) = E_Procedure

                 and then Is_Init_Proc (Scop)

                 and then Etype (First_Formal (Scop)) = Typ

               then

                  Rewrite (N,

                    Make_Attribute_Reference (Loc,

                      Prefix         => Make_Identifier (Loc, Name_uInit),

                      Attribute_Name => Name_Unrestricted_Access));

                  Analyze (N);

                  return;

               --  OK if a task type, this test needs sharpening up ???

               elsif Is_Task_Type (Typ) then

                  null;

               --  OK if self-reference in an aggregate in Ada 2005, and

               --  the reference comes from a copied default expression.

               --  Note that we check legality of self-reference even if the

               --  expression comes from source, e.g. when a single component

               --  association in an aggregate has a box association.

               elsif Ada_Version >= Ada_2005

                 and then OK_Self_Reference

               then

                  null;

               --  OK if reference to current instance of a protected object

               elsif Is_Protected_Self_Reference (P) then

                  null;

               --  Otherwise we have an error case

               else

                  Error_Attr ("% attribute cannot be applied to type", P);

                  return;

               end if;

            end if;

         end if;

         --  If we fall through, we have a normal access to object case.

         --  Unrestricted_Access is legal wherever an allocator would be

         --  legal, so its Etype is set to E_Allocator. The expected type

         --  of the other attributes is a general access type, and therefore

         --  we label them with E_Access_Attribute_Type.

         if not Is_Overloaded (P) then

            Acc_Type := Build_Access_Object_Type (P_Type);

            Set_Etype (N, Acc_Type);

         else

            declare

               Index : Interp_Index;

               It    : Interp;

            begin

               Set_Etype (N, Any_Type);

               Get_First_Interp (P, Index, It);

               while Present (It.Typ) loop

                  Acc_Type := Build_Access_Object_Type (It.Typ);

                  Add_One_Interp (N, Acc_Type, Acc_Type);

                  Get_Next_Interp (Index, It);

               end loop;

            end;

         end if;

         --  Special cases when we can find a prefix that is an entity name

         declare