X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_attr.adb;h=a669e26aeef602d36211aaa9086e90aa0ade2305;hb=068f40295c3c2ba63eb76bb3e589978da09d8842;hp=370bc1df9995eaafa2a524b4d041f391bd8b6422;hpb=03e3a723257e49661df9511a349b6b2f2f0747a9;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 370bc1df999..a669e26aeef 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -16,8 +16,8 @@ -- 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 COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -27,17 +27,17 @@ 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_Tss; use Exp_Tss; +with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; with Lib; use Lib; with Lib.Xref; use Lib.Xref; -with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -57,16 +57,15 @@ with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; -with Snames; use Snames; -with Stand; with Stringt; use Stringt; +with Style; +with Stylesw; use Stylesw; with Targparm; use Targparm; with Ttypes; use Ttypes; with Ttypef; use Ttypef; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; -with Widechar; use Widechar; package body Sem_Attr is @@ -80,6 +79,7 @@ package body Sem_Attr is -- 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 | @@ -126,6 +126,31 @@ package body Sem_Attr is 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_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 -- ----------------------- @@ -250,7 +275,8 @@ package body Sem_Attr is -- two attribute expressions are present procedure Legal_Formal_Attribute; - -- Common processing for attributes Definite, and Has_Discriminants + -- Common processing for attributes Definite, Has_Access_Values, + -- and Has_Discriminants procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type @@ -258,6 +284,9 @@ package body Sem_Attr is procedure Check_Library_Unit; -- Verify that prefix of attribute N is a library unit + procedure Check_Modular_Integer_Type; + -- Verify that prefix of attribute N is a modular integer type + 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. @@ -308,6 +337,10 @@ package body Sem_Attr is -- 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 @@ -342,24 +375,22 @@ package body Sem_Attr is -- the type of the prefix. If prefix is overloaded, so it 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 : Entity_Id; - + Typ : constant Entity_Id := + New_Internal_Entity + (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); begin - if Aname = Name_Unrestricted_Access then - Typ := - New_Internal_Entity - (E_Allocator_Type, Current_Scope, Loc, 'A'); - else - Typ := - New_Internal_Entity - (E_Access_Attribute_Type, Current_Scope, Loc, 'A'); - end if; - Set_Etype (Typ, Typ); Init_Size_Align (Typ); Set_Is_Itype (Typ); @@ -376,9 +407,26 @@ package body Sem_Attr 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. + function Get_Kind (E : Entity_Id) return Entity_Kind; - -- Distinguish between access to regular and protected - -- subprograms. + -- 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); + end if; + end Check_Local_Access; -------------- -- Get_Kind -- @@ -400,19 +448,25 @@ package body Sem_Attr is -- subprogram itself as the designated type. Type-checking in -- this case compares the signatures of the designated types. + Set_Etype (N, Any_Type); + if not Is_Overloaded (P) then - Acc_Type := - New_Internal_Entity - (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); - Set_Etype (Acc_Type, Acc_Type); - Set_Directly_Designated_Type (Acc_Type, Entity (P)); - Set_Etype (N, Acc_Type); + Check_Local_Access (Entity (P)); + + if not Is_Intrinsic_Subprogram (Entity (P)) then + Acc_Type := + New_Internal_Entity + (Get_Kind (Entity (P)), Current_Scope, Loc, 'A'); + Set_Etype (Acc_Type, Acc_Type); + Set_Directly_Designated_Type (Acc_Type, Entity (P)); + Set_Etype (N, Acc_Type); + end if; else Get_First_Interp (P, Index, It); - Set_Etype (N, Any_Type); - while Present (It.Nam) loop + Check_Local_Access (It.Nam); + if not Is_Intrinsic_Subprogram (It.Nam) then Acc_Type := New_Internal_Entity @@ -424,21 +478,56 @@ package body Sem_Attr is Get_Next_Interp (Index, It); end loop; + end if; - if Etype (N) = Any_Type then - Error_Attr ("prefix of % attribute cannot be intrinsic", P); - 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 (Par) = N_Aggregate + or else Nkind (Par) = 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_E0; if Nkind (P) = N_Character_Literal then - Error_Attr - ("prefix of % attribute cannot be enumeration literal", P); + Error_Attr_P + ("prefix of % attribute cannot be enumeration literal"); end if; -- Case of access to subprogram @@ -453,6 +542,15 @@ package body Sem_Attr is Check_Restriction (No_Implicit_Dynamic_Code, P); end if; + if Is_Always_Inlined (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; + -- Build the appropriate subprogram type Build_Access_Subprogram_Type (P); @@ -473,7 +571,7 @@ package body Sem_Attr is and then Is_Overloadable (Entity (Selector_Name (P))) then if Ekind (Entity (Selector_Name (P))) = E_Entry then - Error_Attr ("prefix of % attribute must be subprogram", P); + Error_Attr_P ("prefix of % attribute must be subprogram"); end if; Build_Access_Subprogram_Type (Selector_Name (P)); @@ -481,12 +579,21 @@ package body Sem_Attr is end if; -- Deal with incorrect reference to a type, but note that some - -- accesses are allowed (references to the current type instance). + -- 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 - Scop := Current_Scope; 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 @@ -508,6 +615,7 @@ package body Sem_Attr is loop Q := Parent (Q); end loop; + if Present (Q) then Set_Has_Per_Object_Constraint ( Defining_Identifier (Q), True); @@ -515,7 +623,7 @@ package body Sem_Attr is end; if Nkind (P) = N_Expanded_Name then - Error_Msg_N + Error_Msg_F ("current instance prefix must be a direct name", P); end if; @@ -555,6 +663,18 @@ package body Sem_Attr is 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_05 + and then OK_Self_Reference + then + null; + -- Otherwise we have an error case else @@ -577,11 +697,9 @@ package body Sem_Attr is 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); @@ -590,31 +708,38 @@ package body Sem_Attr is end; end if; - -- If we have an access to an object, and the attribute comes - -- from source, then set the object as potentially source modified. - -- We do this because the resulting access pointer can be used to - -- modify the variable, and we might not detect this, leading to - -- some junk warnings. + -- Special cases when prefix is entity name if Is_Entity_Name (P) then + + -- If we have an access to an object, and the attribute comes from + -- source, then set the object as potentially source modified. We + -- do this because the resulting access pointer can be used to + -- modify the variable, and we might not detect this, leading to + -- some junk warnings. + Set_Never_Set_In_Source (Entity (P), False); + + -- Mark entity as address taken, and kill current values + + Set_Address_Taken (Entity (P)); + Kill_Current_Values (Entity (P)); end if; - -- Check for aliased view unless unrestricted case. We allow - -- a nonaliased prefix when within an instance because the - -- prefix may have been a tagged formal object, which is - -- defined to be aliased even when the actual might not be - -- (other instance cases will have been caught in the generic). - -- Similarly, within an inlined body we know that the attribute - -- is legal in the original subprogram, and therefore legal in - -- the expansion. + -- Check for aliased view unless unrestricted case. We allow a + -- nonaliased prefix when within an instance because the prefix may + -- have been a tagged formal object, which is defined to be aliased + -- even when the actual might not be (other instance cases will have + -- been caught in the generic). Similarly, within an inlined body we + -- know that the attribute is legal in the original subprogram, and + -- therefore legal in the expansion. if Aname /= Name_Unrestricted_Access and then not Is_Aliased_View (P) and then not In_Instance and then not In_Inlined_Body then - Error_Attr ("prefix of % attribute must be aliased", P); + Error_Attr_P ("prefix of % attribute must be aliased"); end if; end Analyze_Access_Attribute; @@ -626,7 +751,7 @@ package body Sem_Attr is Index : Entity_Id; D : Int; - -- Dimension number for array attributes. + -- Dimension number for array attributes begin -- Case of string literal or string literal subtype. These cases @@ -671,12 +796,8 @@ package body Sem_Attr is -- object, and that the expression, if present, is static -- and within the range of the dimensions of the type. - if Is_Array_Type (P_Type) then - Index := First_Index (P_Base_Type); - - else pragma Assert (Is_Access_Type (P_Type)); - Index := First_Index (Base_Type (Designated_Type (P_Type))); - end if; + pragma Assert (Is_Array_Type (P_Type)); + Index := First_Index (P_Base_Type); if No (E1) then @@ -703,7 +824,7 @@ package body Sem_Attr is procedure Check_Array_Type is D : Int; - -- Dimension number for array attributes. + -- Dimension number for array attributes begin -- If the type is a string literal type, then this must be generated @@ -722,6 +843,7 @@ package body Sem_Attr is -- Normal case of array type or subtype Check_Either_E0_Or_E1; + Check_Dereference; if Is_Array_Type (P_Type) then if not Is_Constrained (P_Type) @@ -734,31 +856,22 @@ package body Sem_Attr is -- recovery behavior. Error_Msg_Name_1 := Aname; - Error_Msg_N + Error_Msg_F ("prefix for % attribute must be constrained array", P); end if; D := Number_Dimensions (P_Type); - elsif Is_Access_Type (P_Type) - and then Is_Array_Type (Designated_Type (P_Type)) - then - if Is_Entity_Name (P) and then Is_Type (Entity (P)) then - Error_Attr ("prefix of % attribute cannot be access type", P); - end if; - - D := Number_Dimensions (Designated_Type (P_Type)); - - -- If there is an implicit dereference, then we must freeze - -- the designated type of the access type, since the type of - -- the referenced array is this type (see AI95-00106). - - Freeze_Before (N, Designated_Type (P_Type)); - else if Is_Private_Type (P_Type) then - Error_Attr - ("prefix for % attribute may not be private type", P); + Error_Attr_P ("prefix for % attribute may not be private type"); + + elsif Is_Access_Type (P_Type) + and then Is_Array_Type (Designated_Type (P_Type)) + and then Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of % attribute cannot be access type"); elsif Attr_Id = Attribute_First or else @@ -767,7 +880,7 @@ package body Sem_Attr is Error_Attr ("invalid prefix for % attribute", P); else - Error_Attr ("prefix for % attribute must be array", P); + Error_Attr_P ("prefix for % attribute must be array"); end if; end if; @@ -788,6 +901,12 @@ package body Sem_Attr is Error_Attr ("invalid dimension number for array type", E1); end if; end if; + + if (Style_Check and Style_Check_Array_Attribute_Index) + and then Comes_From_Source (N) + then + Style.Check_Array_Attribute_Index (N, E1, D); + end if; end Check_Array_Type; ------------------------- @@ -836,8 +955,7 @@ package body Sem_Attr is and then Ekind (Entity (Selector_Name (P))) /= E_Discriminant) then - Error_Attr - ("prefix for % attribute must be selected component", P); + Error_Attr_P ("prefix for % attribute must be selected component"); end if; end Check_Component; @@ -850,8 +968,7 @@ package body Sem_Attr is Check_Type; if not Is_Decimal_Fixed_Point_Type (P_Type) then - Error_Attr - ("prefix of % attribute must be decimal type", P); + Error_Attr_P ("prefix of % attribute must be decimal type"); end if; end Check_Decimal_Fixed_Point_Type; @@ -873,7 +990,15 @@ package body Sem_Attr is -- Case of an expression Resolve (P); + if Is_Access_Type (P_Type) then + + -- If there is an implicit dereference, then we must freeze + -- the designated type of the access type, since the type of + -- the referenced array is this type (see AI95-00106). + + Freeze_Before (N, Designated_Type (P_Type)); + Rewrite (P, Make_Explicit_Dereference (Sloc (P), Prefix => Relocate_Node (P))); @@ -898,7 +1023,7 @@ package body Sem_Attr is Check_Type; if not Is_Discrete_Type (P_Type) then - Error_Attr ("prefix of % attribute must be discrete type", P); + Error_Attr_P ("prefix of % attribute must be discrete type"); end if; end Check_Discrete_Type; @@ -975,7 +1100,6 @@ package body Sem_Attr is procedure Check_Enum_Image is Lit : Entity_Id; - begin if Is_Enumeration_Type (P_Base_Type) then Lit := First_Literal (P_Base_Type); @@ -995,7 +1119,7 @@ package body Sem_Attr is Check_Type; if not Is_Fixed_Point_Type (P_Type) then - Error_Attr ("prefix of % attribute must be fixed point type", P); + Error_Attr_P ("prefix of % attribute must be fixed point type"); end if; end Check_Fixed_Point_Type; @@ -1018,7 +1142,7 @@ package body Sem_Attr is Check_Type; if not Is_Floating_Point_Type (P_Type) then - Error_Attr ("prefix of % attribute must be float type", P); + Error_Attr_P ("prefix of % attribute must be float type"); end if; end Check_Floating_Point_Type; @@ -1061,7 +1185,7 @@ package body Sem_Attr is Check_Type; if not Is_Integer_Type (P_Type) then - Error_Attr ("prefix of % attribute must be integer type", P); + Error_Attr_P ("prefix of % attribute must be integer type"); end if; end Check_Integer_Type; @@ -1072,22 +1196,87 @@ package body Sem_Attr is procedure Check_Library_Unit is begin if not Is_Compilation_Unit (Entity (P)) then - Error_Attr ("prefix of % attribute must be library unit", P); + Error_Attr_P ("prefix of % attribute must be library unit"); end if; end Check_Library_Unit; + -------------------------------- + -- Check_Modular_Integer_Type -- + -------------------------------- + + procedure Check_Modular_Integer_Type is + begin + Check_Type; + + if not Is_Modular_Integer_Type (P_Type) then + Error_Attr_P + ("prefix of % attribute must be modular integer type"); + end if; + end Check_Modular_Integer_Type; + ------------------------------- -- Check_Not_Incomplete_Type -- ------------------------------- procedure Check_Not_Incomplete_Type is + E : Entity_Id; + Typ : Entity_Id; + begin + -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit + -- dereference we have to check wrong uses of incomplete types + -- (other wrong uses are checked at their freezing point). + + -- Example 1: Limited-with + + -- limited with Pkg; + -- package P is + -- type Acc is access Pkg.T; + -- X : Acc; + -- S : Integer := X.all'Size; -- ERROR + -- end P; + + -- Example 2: Tagged incomplete + + -- type T is tagged; + -- type Acc is access all T; + -- X : Acc; + -- S : constant Integer := X.all'Size; -- ERROR + -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR + + if Ada_Version >= Ada_05 + and then Nkind (P) = N_Explicit_Dereference + then + E := P; + while Nkind (E) = N_Explicit_Dereference loop + E := Prefix (E); + end loop; + + if From_With_Type (Etype (E)) then + Error_Attr_P + ("prefix of % attribute cannot be an incomplete type"); + + else + if Is_Access_Type (Etype (E)) then + Typ := Directly_Designated_Type (Etype (E)); + else + Typ := Etype (E); + end if; + + if Ekind (Typ) = E_Incomplete_Type + and then No (Full_View (Typ)) + then + Error_Attr_P + ("prefix of % attribute cannot be an incomplete type"); + end if; + end if; + end if; + if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) or else In_Default_Expression then return; - else Check_Fully_Declared (P_Type, P); end if; @@ -1118,7 +1307,7 @@ package body Sem_Attr is -- Otherwise we must have an object reference elsif not Is_Object_Reference (P) then - Error_Attr ("prefix of % attribute must be object", P); + Error_Attr_P ("prefix of % attribute must be object"); end if; end Check_Object_Reference; @@ -1150,7 +1339,7 @@ package body Sem_Attr is end; end if; - Error_Attr ("prefix of % attribute must be program unit", P); + Error_Attr_P ("prefix of % attribute must be program unit"); end Check_Program_Unit; --------------------- @@ -1162,7 +1351,7 @@ package body Sem_Attr is Check_Type; if not Is_Real_Type (P_Type) then - Error_Attr ("prefix of % attribute must be real type", P); + Error_Attr_P ("prefix of % attribute must be real type"); end if; end Check_Real_Type; @@ -1175,7 +1364,7 @@ package body Sem_Attr is Check_Type; if not Is_Scalar_Type (P_Type) then - Error_Attr ("prefix of % attribute must be scalar type", P); + Error_Attr_P ("prefix of % attribute must be scalar type"); end if; end Check_Scalar_Type; @@ -1229,17 +1418,27 @@ package body Sem_Attr is Btyp := Implementation_Base_Type (P_Type); -- Stream attributes not allowed on limited types unless the - -- special OK_For_Stream flag is set. - - if Is_Limited_Type (P_Type) - and then Comes_From_Source (N) - and then not Present (TSS (Btyp, Nam)) - and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert)) + -- attribute reference was generated by the expander (in which + -- case the underlying type will be used, as described in Sinfo), + -- or the attribute was specified explicitly for the type itself + -- or one of its ancestors (taking visibility rules into account if + -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp + -- (with no visibility restriction). + + if Comes_From_Source (N) + and then not Stream_Attribute_Available (P_Type, Nam) + and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then Error_Msg_Name_1 := Aname; - Error_Msg_NE - ("limited type& has no% attribute", P, Btyp); - Explain_Limited_Type (P_Type, P); + + if Is_Limited_Type (P_Type) then + Error_Msg_NE + ("limited type& has no% attribute", P, P_Type); + Explain_Limited_Type (P_Type, P); + else + Error_Msg_NE + ("attribute% for type& is not available", P, P_Type); + end if; end if; -- Check for violation of restriction No_Stream_Attributes @@ -1259,7 +1458,7 @@ package body Sem_Attr is -- Note: the double call to Root_Type here is needed because the -- root type of a class-wide type is the corresponding type (e.g. - -- X for X'Class, and we really want to go to the root. + -- X for X'Class, and we really want to go to the root.) if not Is_Access_Type (Etyp) or else Root_Type (Root_Type (Designated_Type (Etyp))) /= @@ -1294,13 +1493,28 @@ package body Sem_Attr is begin Analyze (P); + -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to + -- task interface class-wide types. + if Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) - and then Is_Task_Type (Designated_Type (Etype (P)))) + and then Is_Task_Type (Designated_Type (Etype (P)))) + or else (Ada_Version >= Ada_05 + and then Ekind (Etype (P)) = E_Class_Wide_Type + and then Is_Interface (Etype (P)) + and then Is_Task_Interface (Etype (P))) then Resolve (P); + else - Error_Attr ("prefix of % attribute must be a task", P); + if Ada_Version >= Ada_05 then + Error_Attr_P + ("prefix of % attribute must be a task or a task " & + "interface class-wide object"); + + else + Error_Attr_P ("prefix of % attribute must be a task"); + end if; end if; end Check_Task_Prefix; @@ -1317,7 +1531,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then - Error_Attr ("prefix of % attribute must be a type", P); + Error_Attr_P ("prefix of % attribute must be a type"); elsif Ekind (Entity (P)) = E_Incomplete_Type and then Present (Full_View (Entity (P))) @@ -1365,6 +1579,17 @@ package body Sem_Attr is Error_Attr; end Error_Attr; + ------------------ + -- Error_Attr_P -- + ------------------ + + procedure Error_Attr_P (Msg : String) is + begin + Error_Msg_Name_1 := Aname; + Error_Msg_F (Msg, P); + Error_Attr; + end Error_Attr_P; + ---------------------------- -- Legal_Formal_Attribute -- ---------------------------- @@ -1376,7 +1601,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then - Error_Attr ("prefix of % attribute must be generic type", N); + Error_Attr_P ("prefix of % attribute must be generic type"); elsif Is_Generic_Actual_Type (Entity (P)) or else In_Instance @@ -1386,13 +1611,13 @@ package body Sem_Attr is elsif Is_Generic_Type (Entity (P)) then if not Is_Indefinite_Subtype (Entity (P)) then - Error_Attr - ("prefix of % attribute must be indefinite generic type", N); + Error_Attr_P + ("prefix of % attribute must be indefinite generic type"); end if; else - Error_Attr - ("prefix of % attribute must be indefinite generic type", N); + Error_Attr_P + ("prefix of % attribute must be indefinite generic type"); end if; Set_Etype (N, Standard_Boolean); @@ -1405,80 +1630,6 @@ package body Sem_Attr is procedure Standard_Attribute (Val : Int) is begin Check_Standard_Prefix; - - -- First a special check (more like a kludge really). For GNAT5 - -- on Windows, the alignments in GCC are severely mixed up. In - -- particular, we have a situation where the maximum alignment - -- that GCC thinks is possible is greater than the guaranteed - -- alignment at run-time. That causes many problems. As a partial - -- cure for this situation, we force a value of 4 for the maximum - -- alignment attribute on this target. This still does not solve - -- all problems, but it helps. - - -- A further (even more horrible) dimension to this kludge is now - -- installed. There are two uses for Maximum_Alignment, one is to - -- determine the maximum guaranteed alignment, that's the one we - -- want the kludge to yield as 4. The other use is to maximally - -- align objects, we can't use 4 here, since for example, long - -- long integer has an alignment of 8, so we will get errors. - - -- It is of course impossible to determine which use the programmer - -- has in mind, but an approximation for now is to disconnect the - -- kludge if the attribute appears in an alignment clause. - - -- To be removed if GCC ever gets its act together here ??? - - Alignment_Kludge : declare - P : Node_Id; - - function On_X86 return Boolean; - -- Determine if target is x86 (ia32), return True if so - - ------------ - -- On_X86 -- - ------------ - - function On_X86 return Boolean is - T : constant String := Sdefault.Target_Name.all; - - begin - -- There is no clean way to check this. That's not surprising, - -- the front end should not be doing this kind of test ???. The - -- way we do it is test for either "86" or "pentium" being in - -- the string for the target name. - - for J in T'First .. T'Last - 1 loop - if T (J .. J + 1) = "86" - or else (J <= T'Last - 6 - and then T (J .. J + 6) = "pentium") - then - return True; - end if; - end loop; - - return False; - end On_X86; - - begin - if Aname = Name_Maximum_Alignment and then On_X86 then - P := Parent (N); - - while Nkind (P) in N_Subexpr loop - P := Parent (P); - end loop; - - if Nkind (P) /= N_Attribute_Definition_Clause - or else Chars (P) /= Name_Alignment - then - Rewrite (N, Make_Integer_Literal (Loc, 4)); - Analyze (N); - return; - end if; - end if; - end Alignment_Kludge; - - -- Normally we get the value from gcc ??? - Rewrite (N, Make_Integer_Literal (Loc, Val)); Analyze (N); end Standard_Attribute; @@ -1520,11 +1671,11 @@ package body Sem_Attr is raise Bad_Attribute; end if; - -- Deal with Ada 83 and Features issues + -- Deal with Ada 83 issues if Comes_From_Source (N) then if not Attribute_83 (Attr_Id) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Error_Msg_N ("(Ada 83) attribute% is not standard?", N); end if; @@ -1535,26 +1686,34 @@ package body Sem_Attr is end if; end if; + -- Deal with Ada 2005 issues + + if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Attributes, N); + end if; + -- Remote access to subprogram type access attribute reference needs -- unanalyzed copy for tree transformation. The analyzed copy is used -- for its semantic information (whether prefix is a remote subprogram -- name), the unanalyzed copy is used to construct new subtree rooted - -- with N_aggregate which represents a fat pointer aggregate. + -- with N_Aggregate which represents a fat pointer aggregate. if Aname = Name_Access then Discard_Node (Copy_Separate_Tree (N)); end if; -- Analyze prefix and exit if error in analysis. If the prefix is an - -- incomplete type, use full view if available. A special case is - -- that we never analyze the prefix of an Elab_Body or Elab_Spec - -- or UET_Address attribute. + -- incomplete type, use full view if available. Note that there are + -- some attributes for which we do not analyze the prefix, since the + -- prefix is not a normal name. if Aname /= Name_Elab_Body and then Aname /= Name_Elab_Spec and then Aname /= Name_UET_Address + and then + Aname /= Name_Enabled then Analyze (P); P_Type := Etype (P); @@ -1562,11 +1721,44 @@ package body Sem_Attr is if Is_Entity_Name (P) and then Present (Entity (P)) and then Is_Type (Entity (P)) - and then Ekind (Entity (P)) = E_Incomplete_Type then - P_Type := Get_Full_View (P_Type); - Set_Entity (P, P_Type); - Set_Etype (P, P_Type); + if Ekind (Entity (P)) = E_Incomplete_Type then + P_Type := Get_Full_View (P_Type); + Set_Entity (P, P_Type); + Set_Etype (P, P_Type); + + elsif Entity (P) = Current_Scope + and then Is_Record_Type (Entity (P)) + then + -- Use of current instance within the type. Verify that if the + -- attribute appears within a constraint, it yields an access + -- type, other uses are illegal. + + declare + Par : Node_Id; + + begin + Par := Parent (N); + while Present (Par) + and then Nkind (Parent (Par)) /= N_Component_Definition + loop + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) = N_Subtype_Indication + then + if Attr_Id /= Attribute_Access + and then Attr_Id /= Attribute_Unchecked_Access + and then Attr_Id /= Attribute_Unrestricted_Access + then + Error_Msg_N + ("in a constraint the current instance can only" + & " be used with an access attribute", N); + end if; + end if; + end; + end if; end if; if P_Type = Any_Type then @@ -1586,7 +1778,7 @@ package body Sem_Attr is E1 := First (Exprs); Analyze (E1); - -- Check for missing or bad expression (result of previous error) + -- Check for missing/bad expression (result of previous error) if No (E1) or else Etype (E1) = Any_Type then raise Bad_Attribute; @@ -1607,7 +1799,11 @@ package body Sem_Attr is end if; end if; - if Is_Overloaded (P) + -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current + -- output compiling in Ada 95 mode for the case of ambiguous prefixes. + + if Ada_Version < Ada_05 + and then Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address and then Aname /= Name_Code_Address @@ -1615,6 +1811,50 @@ package body Sem_Attr is and then Aname /= Name_Unchecked_Access then Error_Attr ("ambiguous prefix for % attribute", P); + + elsif Ada_Version >= Ada_05 + and then Is_Overloaded (P) + and then Aname /= Name_Access + and then Aname /= Name_Address + and then Aname /= Name_Code_Address + and then Aname /= Name_Unchecked_Access + then + -- Ada 2005 (AI-345): Since protected and task types have primitive + -- entry wrappers, the attributes Count, Caller and AST_Entry require + -- a context check + + if Ada_Version >= Ada_05 + and then (Aname = Name_Count + or else Aname = Name_Caller + or else Aname = Name_AST_Entry) + then + declare + Count : Natural := 0; + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (P, I, It); + while Present (It.Nam) loop + if Comes_From_Source (It.Nam) then + Count := Count + 1; + else + Remove_Interp (I); + end if; + + Get_Next_Interp (I, It); + end loop; + + if Count > 1 then + Error_Attr ("ambiguous prefix for % attribute", P); + else + Set_Is_Overloaded (P, False); + end if; + end; + + else + Error_Attr ("ambiguous prefix for % attribute", P); + end if; end if; -- Remaining processing depends on attribute @@ -1669,6 +1909,21 @@ package body Sem_Attr is end if; Set_Address_Taken (Ent); + Kill_Current_Values (Ent); + + -- An Address attribute is accepted when generated by the + -- compiler for dispatching operation, and an error is + -- issued once the subprogram is frozen (to avoid confusing + -- errors about implicit uses of Address in the dispatch + -- table initialization). + + if Is_Always_Inlined (Entity (P)) + and then Comes_From_Source (P) + then + Error_Attr_P + ("prefix of % attribute cannot be Inline_Always" & + " subprogram"); + end if; elsif Is_Object (Ent) or else Ekind (Ent) = E_Label @@ -1813,7 +2068,7 @@ package body Sem_Attr is procedure Bad_AST_Entry is begin - Error_Attr ("prefix for % attribute must be task entry", P); + Error_Attr_P ("prefix for % attribute must be task entry"); end Bad_AST_Entry; function OK_Entry (E : Entity_Id) return Boolean is @@ -1829,8 +2084,7 @@ package body Sem_Attr is if Result then if not Is_AST_Entry (E) then Error_Msg_Name_2 := Aname; - Error_Attr - ("% attribute requires previous % pragma", P); + Error_Attr ("% attribute requires previous % pragma", P); end if; end if; @@ -1861,6 +2115,7 @@ package body Sem_Attr is -- If the prefix is a selected component whose prefix is of an -- access type, then introduce an explicit dereference. + -- ??? Could we reuse Check_Dereference here? if Nkind (Pref) = N_Selected_Component and then Is_Access_Type (Ptyp) @@ -1920,18 +2175,18 @@ package body Sem_Attr is Find_Type (P); Typ := Entity (P); - if Ada_95 + if Ada_Version >= Ada_95 and then not Is_Scalar_Type (Typ) and then not Is_Generic_Type (Typ) then - Error_Msg_N ("prefix of Base attribute must be scalar type", N); + Error_Attr_P ("prefix of Base attribute must be scalar type"); elsif Sloc (Typ) = Standard_Location and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then - Error_Msg_NE - ("?redudant attribute, & is its own base type", N, Typ); + Error_Msg_NE + ("?redudant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); @@ -1950,7 +2205,7 @@ package body Sem_Attr is Attribute_Name => Name_Base), Expression => Relocate_Node (E1))); - -- E1 may be overloaded, and its interpretations preserved. + -- E1 may be overloaded, and its interpretations preserved Save_Interps (E1, Expression (N)); Analyze (N); @@ -1977,7 +2232,7 @@ package body Sem_Attr is Check_E0; if not Is_Object_Reference (P) then - Error_Attr ("prefix for % attribute must be object", P); + Error_Attr_P ("prefix for % attribute must be object"); -- What about the access object cases ??? @@ -1998,7 +2253,7 @@ package body Sem_Attr is Check_Type; if not Is_Record_Type (P_Type) then - Error_Attr ("prefix of % attribute must be record type", P); + Error_Attr_P ("prefix of % attribute must be record type"); end if; if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then @@ -2030,7 +2285,6 @@ package body Sem_Attr is -- immediately and sets an appropriate type. when Attribute_Bit_Position => - if Comes_From_Source (N) then Check_Component; end if; @@ -2090,7 +2344,7 @@ package body Sem_Attr is end if; end loop; - Set_Etype (N, RTE (RO_AT_Task_ID)); + Set_Etype (N, RTE (RO_AT_Task_Id)); end Caller; ------------- @@ -2107,6 +2361,8 @@ package body Sem_Attr is ----------- when Attribute_Class => Class : declare + P : constant Entity_Id := Prefix (N); + begin Check_Restriction (No_Dispatch, N); Check_Either_E0_Or_E1; @@ -2121,19 +2377,37 @@ package body Sem_Attr is Make_Type_Conversion (Loc, Subtype_Mark => Make_Attribute_Reference (Loc, - Prefix => Prefix (N), + Prefix => P, Attribute_Name => Name_Class), Expression => Relocate_Node (E1))); Save_Interps (E1, Expression (N)); - Analyze (N); + + -- Ada 2005 (AI-251): In case of abstract interfaces we have to + -- analyze and resolve the type conversion to generate the code + -- that displaces the reference to the base of the object. + + if Is_Interface (Etype (P)) + or else Is_Interface (Etype (E1)) + then + Analyze_And_Resolve (N, Etype (P)); + + -- However, the attribute is a name that occurs in a context + -- that imposes its own type. Leave the result unanalyzed, + -- so that type checking with the context type take place. + -- on the new conversion node, otherwise Resolve is a noop. + + Set_Analyzed (N, False); + + else + Analyze (N); + end if; -- Otherwise we just need to find the proper type else Find_Type (N); end if; - end Class; ------------------ @@ -2198,6 +2472,13 @@ package body Sem_Attr is -- Case from RM J.4(2) of constrained applied to private type if Is_Entity_Name (P) and then Is_Type (Entity (P)) then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("constrained for private type is an " & + "obsolescent feature (RM J.4)?", N); + end if; -- If we are within an instance, the attribute must be legal -- because it was valid in the generic unit. Ditto if this is @@ -2237,7 +2518,7 @@ package body Sem_Attr is end if; -- Must have discriminants or be an access type designating - -- a type with discriminants. If it is a classwide type is + -- a type with discriminants. If it is a classwide type is ??? -- has unknown discriminants. if Has_Discriminants (P_Type) @@ -2261,8 +2542,8 @@ package body Sem_Attr is -- Fall through if bad prefix - Error_Attr - ("prefix of % attribute must be object of discriminated type", P); + Error_Attr_P + ("prefix of % attribute must be object of discriminated type"); --------------- -- Copy_Sign -- @@ -2383,6 +2664,14 @@ package body Sem_Attr is if It.Nam = Ent then null; + -- Ada 2005 (AI-345): Do not consider primitive entry + -- wrappers generated for task or protected types. + + elsif Ada_Version >= Ada_05 + and then not Comes_From_Source (It.Nam) + then + null; + else Error_Attr ("ambiguous entry name", N); end if; @@ -2450,8 +2739,8 @@ package body Sem_Attr is if not Is_Floating_Point_Type (P_Type) and then not Is_Decimal_Fixed_Point_Type (P_Type) then - Error_Attr - ("prefix of % attribute must be float or decimal type", P); + Error_Attr_P + ("prefix of % attribute must be float or decimal type"); end if; Set_Etype (N, Universal_Integer); @@ -2496,12 +2785,35 @@ package body Sem_Attr is Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); - -------------- - -- Enum_Rep -- - -------------- + ------------- + -- Enabled -- + ------------- + + when Attribute_Enabled => + Check_Either_E0_Or_E1; - when Attribute_Enum_Rep => Enum_Rep : declare - begin + if Present (E1) then + if not Is_Entity_Name (E1) or else No (Entity (E1)) then + Error_Msg_N ("entity name expected for Enabled attribute", E1); + E1 := Empty; + end if; + end if; + + if Nkind (P) /= N_Identifier then + Error_Msg_N ("identifier expected (check name)", P); + + elsif Get_Check_Id (Chars (P)) = No_Check_Id then + Error_Msg_N ("& is not a recognized check name", P); + end if; + + Set_Etype (N, Standard_Boolean); + + -------------- + -- Enum_Rep -- + -------------- + + when Attribute_Enum_Rep => Enum_Rep : declare + begin if Present (E1) then Check_E1; Check_Discrete_Type; @@ -2513,9 +2825,9 @@ package body Sem_Attr is and then Ekind (Entity (P)) /= E_Enumeration_Literal) then - Error_Attr + Error_Attr_P ("prefix of %attribute must be " & - "discrete type/object or enum literal", P); + "discrete type/object or enum literal"); end if; end if; @@ -2550,7 +2862,7 @@ package body Sem_Attr is Set_Etype (N, Standard_String); if not Is_Tagged_Type (P_Type) then - Error_Attr ("prefix of % attribute must be tagged", P); + Error_Attr_P ("prefix of % attribute must be tagged"); end if; ----------- @@ -2605,6 +2917,15 @@ package body Sem_Attr is Resolve (E1, P_Base_Type); ----------------------- + -- Has_Access_Values -- + ----------------------- + + when Attribute_Has_Access_Values => + Check_Type; + Check_E0; + Set_Etype (N, Standard_Boolean); + + ----------------------- -- Has_Discriminants -- ----------------------- @@ -2622,16 +2943,29 @@ package body Sem_Attr is if Etype (P) = Standard_Exception_Type then Set_Etype (N, RTE (RE_Exception_Id)); + -- Ada 2005 (AI-345): Attribute 'Identity may be applied to + -- task interface class-wide types. + elsif Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) - and then Is_Task_Type (Designated_Type (Etype (P)))) + and then Is_Task_Type (Designated_Type (Etype (P)))) + or else (Ada_Version >= Ada_05 + and then Ekind (Etype (P)) = E_Class_Wide_Type + and then Is_Interface (Etype (P)) + and then Is_Task_Interface (Etype (P))) then Resolve (P); - Set_Etype (N, RTE (RO_AT_Task_ID)); + Set_Etype (N, RTE (RO_AT_Task_Id)); else - Error_Attr ("prefix of % attribute must be a task or an " - & "exception", P); + if Ada_Version >= Ada_05 then + Error_Attr_P + ("prefix of % attribute must be an exception, a " & + "task or a task interface class-wide object"); + else + Error_Attr_P + ("prefix of % attribute must be a task or an exception"); + end if; end if; ----------- @@ -2644,7 +2978,7 @@ package body Sem_Attr is Check_Scalar_Type; if Is_Real_Type (P_Type) then - if Ada_83 and then Comes_From_Source (N) then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Error_Msg_N ("(Ada 83) % attribute not allowed for real types", N); @@ -2672,8 +3006,8 @@ package body Sem_Attr is if not Is_Scalar_Type (P_Type) or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) then - Error_Attr - ("prefix of % attribute must be scalar object name", N); + Error_Attr_P + ("prefix of % attribute must be scalar object name"); end if; Check_Enum_Image; @@ -2791,6 +3125,15 @@ package body Sem_Attr is Check_E0; Set_Etype (N, Universal_Integer); + ---------------------- + -- Machine_Rounding -- + ---------------------- + + when Attribute_Machine_Rounding => + Check_Floating_Point_Type_1; + Set_Etype (N, P_Base_Type); + Resolve (E1, P_Base_Type); + -------------------- -- Machine_Rounds -- -------------------- @@ -2855,7 +3198,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else not Is_Subprogram (Entity (P)) then - Error_Attr ("prefix of % attribute must be subprogram", P); + Error_Attr_P ("prefix of % attribute must be subprogram"); end if; Check_Either_E0_Or_E1; @@ -2889,6 +3232,21 @@ package body Sem_Attr is Resolve (E2, P_Base_Type); Set_Etype (N, P_Base_Type); + --------- + -- Mod -- + --------- + + when Attribute_Mod => + + -- Note: this attribute is only allowed in Ada 2005 mode, but + -- we do not need to test that here, since Mod is only recognized + -- as an attribute name in Ada 2005 mode during the parse. + + Check_E1; + Check_Modular_Integer_Type; + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); + ----------- -- Model -- ----------- @@ -2936,12 +3294,7 @@ package body Sem_Attr is when Attribute_Modulus => Check_E0; - Check_Type; - - if not Is_Modular_Integer_Type (P_Type) then - Error_Attr ("prefix of % attribute must be modular type", P); - end if; - + Check_Modular_Integer_Type; Set_Etype (N, Universal_Integer); -------------------- @@ -3066,8 +3419,8 @@ package body Sem_Attr is if P_Type /= Any_Type then if not Is_Library_Level_Entity (Entity (P)) then - Error_Attr - ("prefix of % attribute must be library-level entity", P); + Error_Attr_P + ("prefix of % attribute must be library-level entity"); -- The defining entity of prefix should not be declared inside -- a Pure unit. RM E.1(8). @@ -3076,8 +3429,8 @@ package body Sem_Attr is elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then - Error_Attr - ("prefix of % attribute must not be declared pure", P); + Error_Attr_P + ("prefix of % attribute must not be declared pure"); end if; end if; @@ -3143,6 +3496,56 @@ package body Sem_Attr is end if; end if; + -------------- + -- Priority -- + -------------- + + -- Ada 2005 (AI-327): Dynamic ceiling priorities + + when Attribute_Priority => + if Ada_Version < Ada_05 then + Error_Attr ("% attribute is allowed only in Ada 2005 mode", P); + end if; + + Check_E0; + + -- The prefix must be a protected object (AARM D.5.2 (2/2)) + + Analyze (P); + + if Is_Protected_Type (Etype (P)) + or else (Is_Access_Type (Etype (P)) + and then Is_Protected_Type (Designated_Type (Etype (P)))) + then + Resolve (P, Etype (P)); + else + Error_Attr_P ("prefix of % attribute must be a protected object"); + end if; + + Set_Etype (N, Standard_Integer); + + -- Must be called from within a protected procedure or entry of the + -- protected object. + + declare + S : Entity_Id; + + begin + S := Current_Scope; + while S /= Etype (P) + and then S /= Standard_Standard + loop + S := Scope (S); + end loop; + + if S = Standard_Standard then + Error_Attr ("the attribute % is only allowed inside protected " + & "operations", P); + end if; + end; + + Validate_Non_Static_Attribute_Function_Call; + ----------- -- Range -- ----------- @@ -3150,7 +3553,7 @@ package body Sem_Attr is when Attribute_Range => Check_Array_Or_Scalar_Type; - if Ada_83 + if Ada_Version = Ada_83 and then Is_Scalar_Type (P_Type) and then Comes_From_Source (N) then @@ -3298,14 +3701,28 @@ package body Sem_Attr is when Attribute_Size | Attribute_VADS_Size => Check_E0; - if Is_Object_Reference (P) - or else (Is_Entity_Name (P) - and then Ekind (Entity (P)) = E_Function) + -- If prefix is parameterless function call, rewrite and resolve + -- as such. + + if Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function then + Resolve (P); + + -- Similar processing for a protected function call + + elsif Nkind (P) = N_Selected_Component + and then Ekind (Entity (Selector_Name (P))) = E_Function + then + Resolve (P); + end if; + + if Is_Object_Reference (P) then Check_Object_Reference (P); elsif Is_Entity_Name (P) - and then Is_Type (Entity (P)) + and then (Is_Type (Entity (P)) + or else Ekind (Entity (P)) = E_Enumeration_Literal) then null; @@ -3315,7 +3732,7 @@ package body Sem_Attr is null; else - Error_Attr ("invalid prefix for % attribute", P); + Error_Attr_P ("invalid prefix for % attribute"); end if; Check_Not_Incomplete_Type; @@ -3338,6 +3755,11 @@ package body Sem_Attr is if Is_Access_Type (P_Type) then Check_E0; + if Ekind (P_Type) = E_Access_Subprogram_Type then + Error_Attr_P + ("cannot use % attribute for access-to-subprogram type"); + end if; + -- Set appropriate entity if Present (Associated_Storage_Pool (Root_Type (P_Type))) then @@ -3355,7 +3777,7 @@ package body Sem_Attr is Validate_Remote_Access_To_Class_Wide_Type (N); else - Error_Attr ("prefix of % attribute must be access type", P); + Error_Attr_P ("prefix of % attribute must be access type"); end if; ------------------ @@ -3363,12 +3785,16 @@ package body Sem_Attr is ------------------ when Attribute_Storage_Size => - if Is_Task_Type (P_Type) then Check_E0; Set_Etype (N, Universal_Integer); elsif Is_Access_Type (P_Type) then + if Ekind (P_Type) = E_Access_Subprogram_Type then + Error_Attr_P + ("cannot use % attribute for access-to-subprogram type"); + end if; + if Is_Entity_Name (P) and then Is_Type (Entity (P)) then @@ -3392,8 +3818,7 @@ package body Sem_Attr is end if; else - Error_Attr - ("prefix of % attribute must be access or task type", P); + Error_Attr_P ("prefix of % attribute must be access or task type"); end if; ------------------ @@ -3403,6 +3828,38 @@ package body Sem_Attr is when Attribute_Storage_Unit => Standard_Attribute (Ttypes.System_Storage_Unit); + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => + Check_E0; + Check_Type; + + if Is_Entity_Name (P) + and then Is_Elementary_Type (Entity (P)) + then + Set_Etype (N, Universal_Integer); + else + Error_Attr_P ("invalid prefix for % attribute"); + end if; + + --------------- + -- Stub_Type -- + --------------- + + when Attribute_Stub_Type => + Check_Type; + Check_E0; + + if Is_Remote_Access_To_Class_Wide_Type (P_Type) then + Rewrite (N, + New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc)); + else + Error_Attr_P + ("prefix of% attribute must be remote access to classwide"); + end if; + ---------- -- Succ -- ---------- @@ -3418,7 +3875,7 @@ package body Sem_Attr is if Is_Real_Type (P_Type) then null; - -- If not modular type, test for overflow check required. + -- If not modular type, test for overflow check required else if not Is_Modular_Integer_Type (P_Type) @@ -3437,7 +3894,7 @@ package body Sem_Attr is Check_Dereference; if not Is_Tagged_Type (P_Type) then - Error_Attr ("prefix of % attribute must be tagged", P); + Error_Attr_P ("prefix of % attribute must be tagged"); -- Next test does not apply to generated code -- why not, and what does the illegal reference mean??? @@ -3446,11 +3903,18 @@ package body Sem_Attr is and then not Is_Class_Wide_Type (P_Type) and then Comes_From_Source (N) then - Error_Attr - ("% attribute can only be applied to objects of class-wide type", - P); + Error_Attr_P + ("% attribute can only be applied to objects " & + "of class - wide type"); end if; + -- The prefix cannot be an incomplete type. However, references + -- to 'Tag can be generated when expanding interface conversions, + -- and this is legal. + + if Comes_From_Source (N) then + Check_Not_Incomplete_Type; + end if; Set_Etype (N, RTE (RE_Tag)); ----------------- @@ -3459,22 +3923,21 @@ package body Sem_Attr is when Attribute_Target_Name => Target_Name : declare TN : constant String := Sdefault.Target_Name.all; - TL : Integer := TN'Last; + TL : Natural; begin Check_Standard_Prefix; Check_E0; - Start_String; + + TL := TN'Last; if TN (TL) = '/' or else TN (TL) = '\' then TL := TL - 1; end if; - Store_String_Chars (TN (TN'First .. TL)); - Rewrite (N, Make_String_Literal (Loc, - Strval => End_String)); + Strval => TN (TN'First .. TL))); Analyze_And_Resolve (N, Standard_String); end Target_Name; @@ -3498,7 +3961,7 @@ package body Sem_Attr is if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Error_Attr ("prefix of %attribute must be System", P); + Error_Attr_P ("prefix of %attribute must be System"); end if; Generate_Reference (RTE (RE_Address), P); @@ -3581,7 +4044,7 @@ package body Sem_Attr is if not Is_Entity_Name (P) or else Ekind (Entity (P)) not in Named_Kind then - Error_Attr ("prefix for % attribute must be named number", P); + Error_Attr_P ("prefix for % attribute must be named number"); else declare @@ -3682,7 +4145,7 @@ package body Sem_Attr is end if; if not Is_Scalar_Type (P_Type) then - Error_Attr ("object for % attribute must be of scalar type", P); + Error_Attr_P ("object for % attribute must be of scalar type"); end if; Set_Etype (N, Standard_Boolean); @@ -3696,8 +4159,23 @@ package body Sem_Attr is Check_E1; Check_Scalar_Type; + -- Case of enumeration type + if Is_Enumeration_Type (P_Type) then Check_Restriction (No_Enumeration_Maps, N); + + -- Mark all enumeration literals as referenced, since the use of + -- the Value attribute can implicitly reference any of the + -- literals of the enumeration base type. + + declare + Ent : Entity_Id := First_Literal (P_Base_Type); + begin + while Present (Ent) loop + Set_Referenced (Ent); + Next_Literal (Ent); + end loop; + end; end if; -- Set Etype before resolving expression because expansion of @@ -3747,6 +4225,19 @@ package body Sem_Attr is Validate_Non_Static_Attribute_Function_Call; end Wide_Image; + --------------------- + -- Wide_Wide_Image -- + --------------------- + + when Attribute_Wide_Wide_Image => Wide_Wide_Image : + begin + Check_Scalar_Type; + Set_Etype (N, Standard_Wide_Wide_String); + Check_E1; + Resolve (E1, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Wide_Image; + ---------------- -- Wide_Value -- ---------------- @@ -3763,6 +4254,31 @@ package body Sem_Attr is Validate_Non_Static_Attribute_Function_Call; end Wide_Value; + --------------------- + -- Wide_Wide_Value -- + --------------------- + + when Attribute_Wide_Wide_Value => Wide_Wide_Value : + begin + Check_E1; + Check_Scalar_Type; + + -- Set Etype before resolving expression because expansion + -- of expression may require enclosing type. + + Set_Etype (N, P_Type); + Validate_Non_Static_Attribute_Function_Call; + end Wide_Wide_Value; + + --------------------- + -- Wide_Wide_Width -- + --------------------- + + when Attribute_Wide_Wide_Width => + Check_E0; + Check_Scalar_Type; + Set_Etype (N, Universal_Integer); + ---------------- -- Wide_Width -- ---------------- @@ -3805,11 +4321,14 @@ package body Sem_Attr is -- one attribute expression, and the check succeeds, we want to be able -- to proceed securely assuming that an expression is in fact present. + -- Note: we set the attribute analyzed in this case to prevent any + -- attempt at reanalysis which could generate spurious error msgs. + exception when Bad_Attribute => + Set_Analyzed (N); Set_Etype (N, Any_Type); return; - end Analyze_Attribute; -------------------- @@ -3823,7 +4342,7 @@ package body Sem_Attr is P : constant Node_Id := Prefix (N); C_Type : constant Entity_Id := Etype (N); - -- The type imposed by the context. + -- The type imposed by the context E1 : Node_Id; -- First expression, or Empty if none @@ -3924,6 +4443,10 @@ package body Sem_Attr is -- used for First and Last of scalar types. Static is reset to False -- if the type or index type is not statically constrained. + function Statically_Denotes_Entity (N : Node_Id) return Boolean; + -- Verify that the prefix of a potentially static array attribute + -- satisfies the conditions of 4.9 (14). + --------------- -- Aft_Value -- --------------- @@ -3935,7 +4458,6 @@ package body Sem_Attr is begin Result := 1; Delta_Val := Delta_Value (P_Type); - while Delta_Val < Ureal_Tenth loop Delta_Val := Delta_Val * Ureal_10; Result := Result + 1; @@ -3949,9 +4471,9 @@ package body Sem_Attr is ----------------------- procedure Check_Expressions is - E : Node_Id := E1; - + E : Node_Id; begin + E := E1; while Present (E) loop Check_Non_Static_Context (E); Next (E); @@ -4281,6 +4803,25 @@ package body Sem_Attr is end if; end Set_Bounds; + ------------------------------- + -- Statically_Denotes_Entity -- + ------------------------------- + + function Statically_Denotes_Entity (N : Node_Id) return Boolean is + E : Entity_Id; + + begin + if not Is_Entity_Name (N) then + return False; + else + E := Entity (N); + end if; + + return + Nkind (Parent (E)) /= N_Object_Renaming_Declaration + or else Statically_Denotes_Entity (Renamed_Object (E)); + end Statically_Denotes_Entity; + -- Start of processing for Eval_Attribute begin @@ -4295,6 +4836,49 @@ package body Sem_Attr is E2 := Empty; end if; + -- Special processing for Enabled attribute. This attribute has a very + -- special prefix, and the easiest way to avoid lots of special checks + -- to protect this special prefix from causing trouble is to deal with + -- this attribute immediately and be done with it. + + if Id = Attribute_Enabled then + + -- Evaluate the Enabled attribute + + -- We skip evaluation if the expander is not active. This is not just + -- an optimization. It is of key importance that we not rewrite the + -- attribute in a generic template, since we want to pick up the + -- setting of the check in the instance, and testing expander active + -- is as easy way of doing this as any. + + if Expander_Active then + declare + C : constant Check_Id := Get_Check_Id (Chars (P)); + R : Boolean; + + begin + if No (E1) then + if C in Predefined_Check_Id then + R := Scope_Suppress (C); + else + R := Is_Check_Suppressed (Empty, C); + end if; + + else + R := Is_Check_Suppressed (Entity (E1), C); + end if; + + if R then + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + end; + end if; + + return; + end if; + -- Special processing for cases where the prefix is an object. For -- this purpose, a string literal counts as an object (attributes -- of string literals can only appear in generated code). @@ -4410,10 +4994,10 @@ package body Sem_Attr is then P_Type := Etype (P_Entity); - -- If the entity is an array constant with an unconstrained - -- nominal subtype then get the type from the initial value. - -- If the value has been expanded into assignments, the expression - -- is not present and the attribute reference remains dynamic. + -- If the entity is an array constant with an unconstrained nominal + -- subtype then get the type from the initial value. If the value has + -- been expanded into assignments, there is no expression and the + -- attribute reference remains dynamic. -- We could do better here and retrieve the type ??? if Ekind (P_Entity) = E_Constant @@ -4433,6 +5017,8 @@ package body Sem_Attr is elsif (Id = Attribute_Definite or else + Id = Attribute_Has_Access_Values + or else Id = Attribute_Has_Discriminants or else Id = Attribute_Type_Class @@ -4537,27 +5123,34 @@ package body Sem_Attr is -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are possibly static. - -- In addition Component_Size is possibly foldable, even though it - -- can never be static. - -- Definite, Has_Discriminants, Type_Class and Unconstrained_Array are - -- again exceptions, because they apply as well to unconstrained types. + -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and + -- Unconstrained_Array are again exceptions, because they apply as + -- well to unconstrained types. + + -- In addition Component_Size is an exception since it is possibly + -- foldable, even though it is never static, and it does apply to + -- unconstrained arrays. Furthermore, it is essential to fold this + -- in the packed case, since otherwise the value will be incorrect. elsif Id = Attribute_Definite or else + Id = Attribute_Has_Access_Values + or else Id = Attribute_Has_Discriminants or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array + or else + Id = Attribute_Component_Size then Static := False; else if not Is_Constrained (P_Type) - or else (Id /= Attribute_Component_Size and then - Id /= Attribute_First and then - Id /= Attribute_Last and then + or else (Id /= Attribute_First and then + Id /= Attribute_Last and then Id /= Attribute_Length) then Check_Expressions; @@ -4573,7 +5166,8 @@ package body Sem_Attr is -- Again we compute the variable Static for easy reference later -- (note that no array attributes are static in Ada 83). - Static := Ada_95; + Static := Ada_Version >= Ada_95 + and then Statically_Denotes_Entity (P); declare N : Node_Id; @@ -4820,19 +5414,9 @@ package body Sem_Attr is -------------- when Attribute_Definite => - declare - Result : Node_Id; - - begin - if Is_Indefinite_Subtype (P_Entity) then - Result := New_Occurrence_Of (Standard_False, Loc); - else - Result := New_Occurrence_Of (Standard_True, Loc); - end if; - - Rewrite (N, Result); - Analyze_And_Resolve (N, Standard_Boolean); - end; + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); ------------ -- Denorm -- @@ -4867,12 +5451,12 @@ package body Sem_Attr is when Attribute_Enum_Rep => - -- For an enumeration type with a non-standard representation - -- use the Enumeration_Rep field of the proper constant. Note - -- that this would not work for types Character/Wide_Character, - -- since no real entities are created for the enumeration - -- literals, but that does not matter since these two types - -- do not have non-standard representations anyway. + -- For an enumeration type with a non-standard representation use + -- the Enumeration_Rep field of the proper constant. Note that this + -- will not work for types Character/Wide_[Wide-]Character, since no + -- real entities are created for the enumeration literals, but that + -- does not matter since these two types do not have non-standard + -- representations anyway. if Is_Enumeration_Type (P_Type) and then Has_Non_Standard_Rep (P_Type) @@ -4957,23 +5541,22 @@ package body Sem_Attr is Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static); ----------------------- - -- Has_Discriminants -- + -- Has_Access_Values -- ----------------------- - when Attribute_Has_Discriminants => - declare - Result : Node_Id; + when Attribute_Has_Access_Values => + Rewrite (N, New_Occurrence_Of + (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); - begin - if Has_Discriminants (P_Entity) then - Result := New_Occurrence_Of (Standard_True, Loc); - else - Result := New_Occurrence_Of (Standard_False, Loc); - end if; + ----------------------- + -- Has_Discriminants -- + ----------------------- - Rewrite (N, Result); - Analyze_And_Resolve (N, Standard_Boolean); - end; + when Attribute_Has_Discriminants => + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); -------------- -- Identity -- @@ -4988,9 +5571,29 @@ package body Sem_Attr is -- Image is a scalar attribute, but is never static, because it is -- not a static function (having a non-scalar argument (RM 4.9(22)) + -- However, we can constant-fold the image of an enumeration literal + -- if names are available. when Attribute_Image => - null; + if Is_Entity_Name (E1) + and then Ekind (Entity (E1)) = E_Enumeration_Literal + and then not Discard_Names (First_Subtype (Etype (E1))) + and then not Global_Discard_Names + then + declare + Lit : constant Entity_Id := Entity (E1); + Str : String_Id; + begin + Start_String; + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + Set_Casing (All_Upper_Case); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Str := End_String; + Rewrite (N, Make_String_Literal (Loc, Strval => Str)); + Analyze_And_Resolve (N, Standard_String); + Set_Is_Static_Expression (N, False); + end; + end if; --------- -- Img -- @@ -5208,6 +5811,20 @@ package body Sem_Attr is Fold_Uint (N, Uint_2, True); end if; + ---------------------- + -- Machine_Rounding -- + ---------------------- + + -- Note: for the folding case, it is fine to treat Machine_Rounding + -- exactly the same way as Rounding, since this is one of the allowed + -- behaviors, and performance is not an issue here. It might be a bit + -- better to give the same result as it would give at run-time, even + -- though the non-determinism is certainly permitted. + + when Attribute_Machine_Rounding => + Fold_Ureal (N, + Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static); + -------------------- -- Machine_Rounds -- -------------------- @@ -5395,10 +6012,19 @@ package body Sem_Attr is Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); else - Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); + Fold_Uint + (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); end if; end Min; + --------- + -- Mod -- + --------- + + when Attribute_Mod => + Fold_Uint + (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static); + ----------- -- Model -- ----------- @@ -5593,11 +6219,23 @@ package body Sem_Attr is -- Remainder -- --------------- - when Attribute_Remainder => - Fold_Ureal (N, - Eval_Fat.Remainder - (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), - Static); + when Attribute_Remainder => Remainder : declare + X : constant Ureal := Expr_Value_R (E1); + Y : constant Ureal := Expr_Value_R (E2); + + begin + if UR_Is_Zero (Y) then + Apply_Compile_Time_Constraint_Error + (N, "division by zero in Remainder", + CE_Overflow_Check_Failed, + Warn => not Static); + + Check_Expressions; + return; + end if; + + Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static); + end Remainder; ----------- -- Round -- @@ -5772,7 +6410,7 @@ package body Sem_Attr is -- Size_Clause field for a subtype when Has_Size_Clause -- is False. Consider: - -- type x is range 1 .. 64; g + -- type x is range 1 .. 64; -- for x'size use 12; -- subtype y is x range 0 .. 3; @@ -5833,6 +6471,13 @@ package body Sem_Attr is Fold_Ureal (N, Small_Value (P_Type), True); end if; + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => + null; + ---------- -- Succ -- ---------- @@ -5896,7 +6541,7 @@ package body Sem_Attr is Id : RE_Id; begin - if Is_RTE (P_Root_Type, RE_Address) then + if Is_Descendent_Of_Address (Typ) then Id := RE_Type_Class_Address; elsif Is_Enumeration_Type (Typ) then @@ -5942,7 +6587,6 @@ package body Sem_Attr is end if; Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); - end Type_Class; ----------------------- @@ -5962,13 +6606,10 @@ package body Sem_Attr is Typ : constant Entity_Id := Underlying_Type (P_Type); begin - if Is_Array_Type (P_Type) - and then not Is_Constrained (Typ) - then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals ( + Is_Array_Type (P_Type) + and then not Is_Constrained (Typ)), Loc)); -- Analyze and resolve as boolean, note that this attribute is -- a static attribute in GNAT. @@ -6016,12 +6657,10 @@ package body Sem_Attr is when Attribute_Value_Size => Value_Size : declare P_TypeA : constant Entity_Id := Underlying_Type (P_Type); - begin if RM_Size (P_TypeA) /= Uint_0 then Fold_Uint (N, RM_Size (P_TypeA), True); end if; - end Value_Size; ------------- @@ -6043,6 +6682,22 @@ package body Sem_Attr is when Attribute_Wide_Image => null; + --------------------- + -- Wide_Wide_Image -- + --------------------- + + -- Wide_Wide_Image is a scalar attribute but is never static, because it + -- is not a static function (having a non-scalar argument (RM 4.9(22)). + + when Attribute_Wide_Wide_Image => + null; + + --------------------- + -- Wide_Wide_Width -- + --------------------- + + -- Processing for Wide_Wide_Width is combined with Width + ---------------- -- Wide_Width -- ---------------- @@ -6053,9 +6708,11 @@ package body Sem_Attr is -- Width -- ----------- - -- This processing also handles the case of Wide_Width + -- This processing also handles the case of Wide_[Wide_]Width - when Attribute_Width | Attribute_Wide_Width => Width : + when Attribute_Width | + Attribute_Wide_Width | + Attribute_Wide_Wide_Width => Width : begin if Compile_Time_Known_Bounds (P_Type) then @@ -6077,7 +6734,8 @@ package body Sem_Attr is -- nnn is set to 2 for Short_Float and Float (32 bit -- floats), and 3 for Long_Float and Long_Long_Float. - -- This is not quite right, but is good enough. + -- For machines where Long_Long_Float is the IEEE + -- extended precision type, the exponent takes 4 digits. declare Len : Int := @@ -6086,8 +6744,10 @@ package body Sem_Attr is begin if Esize (P_Type) <= 32 then Len := Len + 6; - else + elsif Esize (P_Type) = 64 then Len := Len + 7; + else + Len := Len + 8; end if; Fold_Uint (N, UI_From_Int (Len), True); @@ -6136,10 +6796,11 @@ package body Sem_Attr is W := 0; -- Width for types derived from Standard.Character - -- and Standard.Wide_Character. + -- and Standard.Wide_[Wide_]Character. elsif R = Standard_Character - or else R = Standard_Wide_Character + or else R = Standard_Wide_Character + or else R = Standard_Wide_Wide_Character then W := 0; @@ -6147,17 +6808,10 @@ package body Sem_Attr is for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop - -- Assume all wide-character escape sequences are - -- same length, so we can quit when we reach one. + -- All wide characters look like Hex_hhhhhhhh if J > 255 then - if Id = Attribute_Wide_Width then - W := Int'Max (W, 3); - exit; - else - W := Int'Max (W, Length_Wide); - exit; - end if; + W := 12; else C := Character'Val (J); @@ -6242,8 +6896,8 @@ package body Sem_Attr is Get_Decoded_Name_String (Chars (L)); Wt := Nat (Name_Len); - -- For Wide_Width, use encoded name, and then - -- adjust for the encoding. + -- For Wide_[Wide_]Width, use encoded name, and + -- then adjust for the encoding. else Get_Name_String (Chars (L)); @@ -6304,6 +6958,7 @@ package body Sem_Attr is Attribute_Elaborated | Attribute_Elab_Body | Attribute_Elab_Spec | + Attribute_Enabled | Attribute_External_Tag | Attribute_First_Bit | Attribute_Input | @@ -6313,10 +6968,12 @@ package body Sem_Attr is Attribute_Partition_ID | Attribute_Pool_Address | Attribute_Position | + Attribute_Priority | Attribute_Read | Attribute_Storage_Pool | Attribute_Storage_Size | Attribute_Storage_Unit | + Attribute_Stub_Type | Attribute_Tag | Attribute_Target_Name | Attribute_Terminated | @@ -6329,11 +6986,11 @@ package body Sem_Attr is Attribute_Value | Attribute_Wchar_T_Size | Attribute_Wide_Value | + Attribute_Wide_Wide_Value | Attribute_Word_Size | Attribute_Write => raise Program_Error; - end case; -- At the end of the case, one more check. If we did a static evaluation @@ -6366,7 +7023,6 @@ package body Sem_Attr is else null; end if; - end Eval_Attribute; ------------------------------ @@ -6385,6 +7041,16 @@ package body Sem_Attr is and then Associated_Node_For_Itype (Anon) = Parent (Typ); end Is_Anonymous_Tagged_Base; + -------------------------------- + -- Name_Implies_Lvalue_Prefix -- + -------------------------------- + + function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is + pragma Assert (Is_Attribute_Name (Nam)); + begin + return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam)); + end Name_Implies_Lvalue_Prefix; + ----------------------- -- Resolve_Attribute -- ----------------------- @@ -6395,10 +7061,68 @@ package body Sem_Attr is Aname : constant Name_Id := Attribute_Name (N); Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); Btyp : constant Entity_Id := Base_Type (Typ); + Des_Btyp : Entity_Id; Index : Interp_Index; It : Interp; Nom_Subt : Entity_Id; + procedure Accessibility_Message; + -- Error, or warning within an instance, if the static accessibility + -- rules of 3.10.2 are violated. + + --------------------------- + -- Accessibility_Message -- + --------------------------- + + procedure Accessibility_Message is + Indic : Node_Id := Parent (Parent (N)); + + begin + -- In an instance, this is a runtime check, but one we + -- know will fail, so generate an appropriate warning. + + if In_Instance_Body then + Error_Msg_F + ("?non-local pointer cannot point to local object", P); + Error_Msg_F + ("\?Program_Error will be raised at run time", P); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + return; + + else + Error_Msg_F + ("non-local pointer cannot point to local object", P); + + -- Check for case where we have a missing access definition + + if Is_Record_Type (Current_Scope) + and then + (Nkind (Parent (N)) = N_Discriminant_Association + or else + Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint) + then + Indic := Parent (Parent (N)); + while Present (Indic) + and then Nkind (Indic) /= N_Subtype_Indication + loop + Indic := Parent (Indic); + end loop; + + if Present (Indic) then + Error_Msg_NE + ("\use an access definition for" & + " the access discriminant of&", + N, Entity (Subtype_Mark (Indic))); + end if; + end if; + end if; + end Accessibility_Message; + + -- Start of processing for Resolve_Attribute + begin -- If error during analysis, no point in continuing, except for -- array types, where we get better recovery by using unconstrained @@ -6438,6 +7162,7 @@ package body Sem_Attr is | Attribute_Unchecked_Access | Attribute_Unrestricted_Access => + Access_Attribute : begin if Is_Variable (P) then Note_Possible_Modification (P); end if; @@ -6445,18 +7170,16 @@ package body Sem_Attr is if Is_Entity_Name (P) then if Is_Overloaded (P) then Get_First_Interp (P, Index, It); - while Present (It.Nam) loop - if Type_Conformant (Designated_Type (Typ), It.Nam) then Set_Entity (P, It.Nam); - -- The prefix is definitely NOT overloaded anymore - -- at this point, so we reset the Is_Overloaded - -- flag to avoid any confusion when reanalyzing - -- the node. + -- The prefix is definitely NOT overloaded anymore at + -- this point, so we reset the Is_Overloaded flag to + -- avoid any confusion when reanalyzing the node. Set_Is_Overloaded (P, False); + Set_Is_Overloaded (N, False); Generate_Reference (Entity (P), P); exit; end if; @@ -6464,12 +7187,20 @@ package body Sem_Attr is Get_Next_Interp (Index, It); end loop; - -- If it is a subprogram name or a type, there is nothing - -- to resolve. + -- If Prefix is a subprogram name, it is frozen by this + -- reference: - elsif not Is_Overloadable (Entity (P)) - and then not Is_Type (Entity (P)) - then + -- If it is a type, there is nothing to resolve. + -- If it is an object, complete its resolution. + + elsif Is_Overloadable (Entity (P)) then + if not In_Default_Expression then + Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); + end if; + + elsif Is_Type (Entity (P)) then + null; + else Resolve (P); end if; @@ -6478,27 +7209,23 @@ package body Sem_Attr is if not Is_Entity_Name (P) then null; - elsif Is_Abstract (Entity (P)) - and then Is_Overloadable (Entity (P)) + elsif Is_Overloadable (Entity (P)) + and then Is_Abstract_Subprogram (Entity (P)) then - Error_Msg_N ("prefix of % attribute cannot be abstract", P); + Error_Msg_F ("prefix of % attribute cannot be abstract", P); Set_Etype (N, Any_Type); elsif Convention (Entity (P)) = Convention_Intrinsic then if Ekind (Entity (P)) = E_Enumeration_Literal then - Error_Msg_N + Error_Msg_F ("prefix of % attribute cannot be enumeration literal", - P); + P); else - Error_Msg_N + Error_Msg_F ("prefix of % attribute cannot be intrinsic", P); end if; Set_Etype (N, Any_Type); - - elsif Is_Thread_Body (Entity (P)) then - Error_Msg_N - ("prefix of % attribute cannot be a thread body", P); end if; -- Assignments, return statements, components of aggregates, @@ -6507,10 +7234,27 @@ package body Sem_Attr is -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? - if Ekind (Btyp) = E_Access_Subprogram_Type then + if Ekind (Btyp) = E_Access_Subprogram_Type + or else + Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type + or else + Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type + then + -- Deal with convention mismatch + if Convention (Btyp) /= Convention (Entity (P)) then - Error_Msg_N - ("subprogram has invalid convention for context", P); + Error_Msg_FE + ("subprogram & has wrong convention", P, Entity (P)); + + Error_Msg_FE + ("\does not match convention of access type &", + P, Btyp); + + if not Has_Convention_Pragma (Btyp) then + Error_Msg_FE + ("\probable missing pragma Convention for &", + P, Btyp); + end if; else Check_Subtype_Conformant @@ -6521,54 +7265,147 @@ package body Sem_Attr is if Attr_Id = Attribute_Unchecked_Access then Error_Msg_Name_1 := Aname; - Error_Msg_N + Error_Msg_F ("attribute% cannot be applied to a subprogram", P); elsif Aname = Name_Unrestricted_Access then null; -- Nothing to check - -- Check the static accessibility rule of 3.10.2(32) - -- In an instance body, if subprogram and type are both - -- local, other rules prevent dangling references, and no - -- warning is needed. + -- Check the static accessibility rule of 3.10.2(32). + -- This rule also applies within the private part of an + -- instantiation. This rule does not apply to anonymous + -- access-to-subprogram types (Ada 2005). elsif Attr_Id = Attribute_Access - and then Subprogram_Access_Level (Entity (P)) - > Type_Access_Level (Btyp) + and then not In_Instance_Body + and then Subprogram_Access_Level (Entity (P)) > + Type_Access_Level (Btyp) + and then Ekind (Btyp) /= + E_Anonymous_Access_Subprogram_Type + and then Ekind (Btyp) /= + E_Anonymous_Access_Protected_Subprogram_Type then - if not In_Instance_Body then - Error_Msg_N - ("subprogram must not be deeper than access type", - P); + Error_Msg_F + ("subprogram must not be deeper than access type", P); + + -- Check the restriction of 3.10.2(32) that disallows the + -- access attribute within a generic body when the ultimate + -- ancestor of the type of the attribute is declared outside + -- of the generic unit and the subprogram is declared within + -- that generic unit. This includes any such attribute that + -- occurs within the body of a generic unit that is a child + -- of the generic unit where the subprogram is declared. + -- The rule also prohibits applying the attibute when the + -- access type is a generic formal access type (since the + -- level of the actual type is not known). This restriction + -- does not apply when the attribute type is an anonymous + -- access-to-subprogram type. Note that this check was + -- revised by AI-229, because the originally Ada 95 rule + -- was too lax. The original rule only applied when the + -- subprogram was declared within the body of the generic, + -- which allowed the possibility of dangling references). + -- The rule was also too strict in some case, in that it + -- didn't permit the access to be declared in the generic + -- spec, whereas the revised rule does (as long as it's not + -- a formal type). + + -- There are a couple of subtleties of the test for applying + -- the check that are worth noting. First, we only apply it + -- when the levels of the subprogram and access type are the + -- same (the case where the subprogram is statically deeper + -- was applied above, and the case where the type is deeper + -- is always safe). Second, we want the check to apply + -- within nested generic bodies and generic child unit + -- bodies, but not to apply to an attribute that appears in + -- the generic unit's specification. This is done by testing + -- that the attribute's innermost enclosing generic body is + -- not the same as the innermost generic body enclosing the + -- generic unit where the subprogram is declared (we don't + -- want the check to apply when the access attribute is in + -- the spec and there's some other generic body enclosing + -- generic). Finally, there's no point applying the check + -- when within an instance, because any violations will have + -- been caught by the compilation of the generic unit. - elsif Scope (Entity (P)) /= Scope (Btyp) then - Error_Msg_N - ("subprogram must not be deeper than access type?", - P); + elsif Attr_Id = Attribute_Access + and then not In_Instance + and then Present (Enclosing_Generic_Unit (Entity (P))) + and then Present (Enclosing_Generic_Body (N)) + and then Enclosing_Generic_Body (N) /= + Enclosing_Generic_Body + (Enclosing_Generic_Unit (Entity (P))) + and then Subprogram_Access_Level (Entity (P)) = + Type_Access_Level (Btyp) + and then Ekind (Btyp) /= + E_Anonymous_Access_Subprogram_Type + and then Ekind (Btyp) /= + E_Anonymous_Access_Protected_Subprogram_Type + then + -- The attribute type's ultimate ancestor must be + -- declared within the same generic unit as the + -- subprogram is declared. The error message is + -- specialized to say "ancestor" for the case where + -- the access type is not its own ancestor, since + -- saying simply "access type" would be very confusing. + + if Enclosing_Generic_Unit (Entity (P)) /= + Enclosing_Generic_Unit (Root_Type (Btyp)) + then Error_Msg_N - ("Constraint_Error will be raised ?", P); - Set_Raises_Constraint_Error (N); - end if; - - -- Check the restriction of 3.10.2(32) that disallows - -- the type of the access attribute to be declared - -- outside a generic body when the subprogram is declared - -- within that generic body. + ("''Access attribute not allowed in generic body", + N); + + if Root_Type (Btyp) = Btyp then + Error_Msg_NE + ("\because " & + "access type & is declared outside " & + "generic unit (RM 3.10.2(32))", N, Btyp); + else + Error_Msg_NE + ("\because ancestor of " & + "access type & is declared outside " & + "generic unit (RM 3.10.2(32))", N, Btyp); + end if; - elsif Enclosing_Generic_Body (Entity (P)) - /= Enclosing_Generic_Body (Btyp) - then - Error_Msg_N - ("access type must not be outside generic body", P); + Error_Msg_NE + ("\move ''Access to private part, or " & + "(Ada 2005) use anonymous access type instead of &", + N, Btyp); + + -- If the ultimate ancestor of the attribute's type is + -- a formal type, then the attribute is illegal because + -- the actual type might be declared at a higher level. + -- The error message is specialized to say "ancestor" + -- for the case where the access type is not its own + -- ancestor, since saying simply "access type" would be + -- very confusing. + + elsif Is_Generic_Type (Root_Type (Btyp)) then + if Root_Type (Btyp) = Btyp then + Error_Msg_N + ("access type must not be a generic formal type", + N); + else + Error_Msg_N + ("ancestor access type must not be a generic " & + "formal type", N); + end if; + end if; end if; end if; - -- if this is a renaming, an inherited operation, or a - -- subprogram instance, use the original entity. + -- If this is a renaming, an inherited operation, or a + -- subprogram instance, use the original entity. This may make + -- the node type-inconsistent, so this transformation can only + -- be done if the node will not be reanalyzed. In particular, + -- if it is within a default expression, the transformation + -- must be delayed until the default subprogram is created for + -- it, when the enclosing subprogram is frozen. if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) and then Present (Alias (Entity (P))) + and then Expander_Active then Rewrite (P, New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); @@ -6583,7 +7420,7 @@ package body Sem_Attr is if Attr_Id = Attribute_Unchecked_Access then Error_Msg_Name_1 := Aname; - Error_Msg_N + Error_Msg_F ("attribute% cannot be applied to protected operation", P); end if; @@ -6592,13 +7429,18 @@ package body Sem_Attr is elsif Is_Overloaded (P) then - -- Use the designated type of the context to disambiguate. + -- Use the designated type of the context to disambiguate + -- Note that this was not strictly conformant to Ada 95, + -- but was the implementation adopted by most Ada 95 compilers. + -- The use of the context type to resolve an Access attribute + -- reference is now mandated in AI-235 for Ada 2005. + declare Index : Interp_Index; It : Interp; + begin Get_First_Interp (P, Index, It); - while Present (It.Typ) loop if Covers (Designated_Type (Typ), It.Typ) then Resolve (P, It.Typ); @@ -6612,20 +7454,34 @@ package body Sem_Attr is Resolve (P); end if; - -- X'Access is illegal if X denotes a constant and the access - -- type is access-to-variable. Same for 'Unchecked_Access. - -- The rule does not apply to 'Unrestricted_Access. + -- X'Access is illegal if X denotes a constant and the access type + -- is access-to-variable. Same for 'Unchecked_Access. The rule + -- does not apply to 'Unrestricted_Access. If the reference is a + -- default-initialized aggregate component for a self-referential + -- type the reference is legal. if not (Ekind (Btyp) = E_Access_Subprogram_Type - or else (Is_Record_Type (Btyp) and then - Present (Corresponding_Remote_Type (Btyp))) + or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type + or else (Is_Record_Type (Btyp) + and then + Present (Corresponding_Remote_Type (Btyp))) or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type + or else Ekind (Btyp) + = E_Anonymous_Access_Protected_Subprogram_Type or else Is_Access_Constant (Btyp) or else Is_Variable (P) or else Attr_Id = Attribute_Unrestricted_Access) then - if Comes_From_Source (N) then - Error_Msg_N ("access-to-variable designates constant", P); + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + -- Legality of a self-reference through an access + -- attribute has been verified in Analyze_Access_Attribute. + + null; + + elsif Comes_From_Source (N) then + Error_Msg_F ("access-to-variable designates constant", P); end if; end if; @@ -6633,29 +7489,74 @@ package body Sem_Attr is or else Attr_Id = Attribute_Unchecked_Access) and then (Ekind (Btyp) = E_General_Access_Type - or else Ekind (Btyp) = E_Anonymous_Access_Type) + or else Ekind (Btyp) = E_Anonymous_Access_Type) then + -- Ada 2005 (AI-230): Check the accessibility of anonymous + -- access types for stand-alone objects, record and array + -- components, and return objects. For a component definition + -- the level is the same of the enclosing composite type. + + if Ada_Version >= Ada_05 + and then Is_Local_Anonymous_Access (Btyp) + and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then Attr_Id = Attribute_Access + then + -- In an instance, this is a runtime check, but one we + -- know will fail, so generate an appropriate warning. + + if In_Instance_Body then + Error_Msg_F + ("?non-local pointer cannot point to local object", P); + Error_Msg_F + ("\?Program_Error will be raised at run time", P); + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Typ); + + else + Error_Msg_F + ("non-local pointer cannot point to local object", P); + end if; + end if; + if Is_Dependent_Component_Of_Mutable_Object (P) then - Error_Msg_N + Error_Msg_F ("illegal attribute for discriminant-dependent component", P); end if; - -- Check the static matching rule of 3.10.2(27). The - -- nominal subtype of the prefix must statically - -- match the designated type. + -- Check static matching rule of 3.10.2(27). Nominal subtype + -- of the prefix must statically match the designated type. Nom_Subt := Etype (P); if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then - Nom_Subt := Etype (Nom_Subt); + Nom_Subt := Base_Type (Nom_Subt); + end if; + + Des_Btyp := Designated_Type (Btyp); + + if Ekind (Des_Btyp) = E_Incomplete_Subtype then + + -- Ada 2005 (AI-412): Subtypes of incomplete types visible + -- through a limited with clause or regular incomplete + -- subtypes. + + if From_With_Type (Des_Btyp) + and then Present (Non_Limited_View (Des_Btyp)) + then + Des_Btyp := Non_Limited_View (Des_Btyp); + else + Des_Btyp := Etype (Des_Btyp); + end if; end if; if Is_Tagged_Type (Designated_Type (Typ)) then -- If the attribute is in the context of an access - -- parameter, then the prefix is allowed to be of - -- the class-wide type (by AI-127). + -- parameter, then the prefix is allowed to be of the + -- class-wide type (by AI-127). if Ekind (Typ) = E_Anonymous_Access_Type then if not Covers (Designated_Type (Typ), Nom_Subt) @@ -6675,10 +7576,10 @@ package body Sem_Attr is null; else - Error_Msg_NE + Error_Msg_FE ("type of prefix: & not compatible", P, Nom_Subt); - Error_Msg_NE + Error_Msg_FE ("\with &, the expected designated type", P, Designated_Type (Typ)); end if; @@ -6690,11 +7591,11 @@ package body Sem_Attr is (not Is_Class_Wide_Type (Designated_Type (Typ)) and then Is_Class_Wide_Type (Nom_Subt)) then - Error_Msg_NE + Error_Msg_FE ("type of prefix: & is not covered", P, Nom_Subt); - Error_Msg_NE + Error_Msg_FE ("\by &, the expected designated type" & - " ('R'M 3.10.2 (27))", P, Designated_Type (Typ)); + " (RM 3.10.2 (27))", P, Designated_Type (Typ)); end if; if Is_Class_Wide_Type (Designated_Type (Typ)) @@ -6706,22 +7607,30 @@ package body Sem_Attr is (N, Etype (Designated_Type (Typ))); end if; - elsif not Subtypes_Statically_Match - (Designated_Type (Base_Type (Typ)), Nom_Subt) + -- Ada 2005 (AI-363): Require static matching when designated + -- type has discriminants and a constrained partial view, since + -- in general objects of such types are mutable, so we can't + -- allow the access value to designate a constrained object + -- (because access values must be assumed to designate mutable + -- objects when designated type does not impose a constraint). + + elsif not Subtypes_Statically_Match (Des_Btyp, Nom_Subt) and then not (Has_Discriminants (Designated_Type (Typ)) + and then not Is_Constrained (Des_Btyp) and then - not Is_Constrained - (Designated_Type (Base_Type (Typ)))) + (Ada_Version < Ada_05 + or else + not Has_Constrained_Partial_View + (Designated_Type (Base_Type (Typ))))) then - Error_Msg_N + Error_Msg_F ("object subtype must statically match " & "designated subtype", P); if Is_Entity_Name (P) and then Is_Array_Type (Designated_Type (Typ)) then - declare D : constant Node_Id := Declaration_Node (Entity (P)); @@ -6744,63 +7653,41 @@ package body Sem_Attr is and then Object_Access_Level (P) > Type_Access_Level (Btyp) and then Ekind (Btyp) = E_General_Access_Type then - -- In an instance, this is a runtime check, but one we - -- know will fail, so generate an appropriate warning. - - if In_Instance_Body then - Error_Msg_N - ("?non-local pointer cannot point to local object", P); - Error_Msg_N - ("?Program_Error will be raised at run time", P); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Typ); - return; - - else - Error_Msg_N - ("non-local pointer cannot point to local object", P); - - if Is_Record_Type (Current_Scope) - and then (Nkind (Parent (N)) = - N_Discriminant_Association - or else - Nkind (Parent (N)) = - N_Index_Or_Discriminant_Constraint) - then - declare - Indic : Node_Id := Parent (Parent (N)); - - begin - while Present (Indic) - and then Nkind (Indic) /= N_Subtype_Indication - loop - Indic := Parent (Indic); - end loop; - - if Present (Indic) then - Error_Msg_NE - ("\use an access definition for" & - " the access discriminant of&", N, - Entity (Subtype_Mark (Indic))); - end if; - end; - end if; - end if; + Accessibility_Message; + return; end if; end if; if Ekind (Btyp) = E_Access_Protected_Subprogram_Type - and then Is_Entity_Name (P) - and then not Is_Protected_Type (Scope (Entity (P))) + or else + Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type then - Error_Msg_N ("context requires a protected subprogram", P); + if Is_Entity_Name (P) + and then not Is_Protected_Type (Scope (Entity (P))) + then + Error_Msg_F ("context requires a protected subprogram", P); + + -- Check accessibility of protected object against that of the + -- access type, but only on user code, because the expander + -- creates access references for handlers. If the context is an + -- anonymous_access_to_protected, there are no accessibility + -- checks either. Omit check entirely for Unrestricted_Access. + + elsif Object_Access_Level (P) > Type_Access_Level (Btyp) + and then Comes_From_Source (N) + and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type + and then Attr_Id /= Attribute_Unrestricted_Access + then + Accessibility_Message; + return; + end if; - elsif Ekind (Btyp) = E_Access_Subprogram_Type + elsif (Ekind (Btyp) = E_Access_Subprogram_Type + or else + Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type) and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then - Error_Msg_N ("context requires a non-protected subprogram", P); + Error_Msg_F ("context requires a non-protected subprogram", P); end if; -- The context cannot be a pool-specific type, but this is a @@ -6813,7 +7700,12 @@ package body Sem_Attr is Wrong_Type (N, Typ); end if; - Set_Etype (N, Typ); + -- The context may be a constrained access type (however ill- + -- advised such subtypes might be) so in order to generate a + -- constraint check when needed set the type of the attribute + -- reference to the base type of the context. + + Set_Etype (N, Btyp); -- Check for incorrect atomic/volatile reference (RM C.6(12)) @@ -6821,19 +7713,24 @@ package body Sem_Attr is if Is_Atomic_Object (P) and then not Is_Atomic (Designated_Type (Typ)) then - Error_Msg_N + Error_Msg_F ("access to atomic object cannot yield access-to-" & "non-atomic type", P); elsif Is_Volatile_Object (P) and then not Is_Volatile (Designated_Type (Typ)) then - Error_Msg_N + Error_Msg_F ("access to volatile object cannot yield access-to-" & "non-volatile type", P); end if; end if; + if Is_Entity_Name (P) then + Set_Address_Taken (Entity (P)); + end if; + end Access_Attribute; + ------------- -- Address -- ------------- @@ -6842,6 +7739,7 @@ package body Sem_Attr is -- is not permitted here, since there is no context to resolve it. when Attribute_Address | Attribute_Code_Address => + Address_Attribute : begin -- To be safe, assume that if the address of a variable is taken, -- it may be modified via this address, so note modification. @@ -6850,7 +7748,7 @@ package body Sem_Attr is Note_Possible_Modification (P); end if; - if Nkind (P) in N_Subexpr + if Nkind (P) in N_Subexpr and then Is_Overloaded (P) then Get_First_Interp (P, Index, It); @@ -6858,14 +7756,13 @@ package body Sem_Attr is if Present (It.Nam) then Error_Msg_Name_1 := Aname; - Error_Msg_N - ("prefix of % attribute cannot be overloaded", N); - return; + Error_Msg_F + ("prefix of % attribute cannot be overloaded", P); end if; end if; if not Is_Entity_Name (P) - or else not Is_Overloadable (Entity (P)) + or else not Is_Overloadable (Entity (P)) then if not Is_Task_Type (Etype (P)) or else Nkind (P) = N_Explicit_Dereference @@ -6885,6 +7782,11 @@ package body Sem_Attr is New_Occurrence_Of (Alias (Entity (P)), Sloc (P))); end if; + if Is_Entity_Name (P) then + Set_Address_Taken (Entity (P)); + end if; + end Address_Attribute; + --------------- -- AST_Entry -- --------------- @@ -6954,6 +7856,16 @@ package body Sem_Attr is when Attribute_Elaborated => null; + ------------- + -- Enabled -- + ------------- + + -- Prefix of Enabled attribute is a check name, which must be treated + -- specially and not touched by Resolve. + + when Attribute_Enabled => + null; + -------------------- -- Mechanism_Code -- -------------------- @@ -7204,8 +8116,20 @@ package body Sem_Attr is when Attribute_Wide_Value => Resolve (First (Expressions (N)), Standard_Wide_String); + when Attribute_Wide_Wide_Value => + Resolve (First (Expressions (N)), Standard_Wide_Wide_String); + when others => null; end case; + + -- If the prefix of the attribute is a class-wide type then it + -- will be expanded into a dispatching call to a predefined + -- primitive. Therefore we must check for potential violation + -- of such restriction. + + if Is_Class_Wide_Type (Etype (P)) then + Check_Restriction (No_Dispatching_Calls, N); + end if; end case; -- Normally the Freezing is done by Resolve but sometimes the Prefix @@ -7216,7 +8140,87 @@ package body Sem_Attr is -- Finally perform static evaluation on the attribute reference Eval_Attribute (N); - end Resolve_Attribute; + -------------------------------- + -- Stream_Attribute_Available -- + -------------------------------- + + function Stream_Attribute_Available + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Partial_View : Node_Id := Empty) return Boolean + is + Etyp : Entity_Id := Typ; + + -- Start of processing for Stream_Attribute_Available + + begin + -- We need some comments in this body ??? + + if Has_Stream_Attribute_Definition (Typ, Nam) then + return True; + end if; + + if Is_Class_Wide_Type (Typ) then + return not Is_Limited_Type (Typ) + or else Stream_Attribute_Available (Etype (Typ), Nam); + end if; + + if Nam = TSS_Stream_Input + and then Is_Abstract_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + then + return False; + end if; + + if not (Is_Limited_Type (Typ) + or else (Present (Partial_View) + and then Is_Limited_Type (Partial_View))) + then + return True; + end if; + + -- In Ada 2005, Input can invoke Read, and Output can invoke Write + + if Nam = TSS_Stream_Input + and then Ada_Version >= Ada_05 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Read) + then + return True; + + elsif Nam = TSS_Stream_Output + and then Ada_Version >= Ada_05 + and then Stream_Attribute_Available (Etyp, TSS_Stream_Write) + then + return True; + end if; + + -- Case of Read and Write: check for attribute definition clause that + -- applies to an ancestor type. + + while Etype (Etyp) /= Etyp loop + Etyp := Etype (Etyp); + + if Has_Stream_Attribute_Definition (Etyp, Nam) then + return True; + end if; + end loop; + + if Ada_Version < Ada_05 then + + -- In Ada 95 mode, also consider a non-visible definition + + declare + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + begin + return Btyp /= Typ + and then Stream_Attribute_Available + (Btyp, Nam, Partial_View => Typ); + end; + end if; + + return False; + end Stream_Attribute_Available; + end Sem_Attr;