X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_attr.adb;h=a669e26aeef602d36211aaa9086e90aa0ade2305;hb=068f40295c3c2ba63eb76bb3e589978da09d8842;hp=f10ec25c707d97cbb806dd5b80f9a3d7107a9e1a;hpb=0b9d81c1cdb1f3d9278217393338eb655abbc7af;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f10ec25c707..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-2005, 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 -- ----------------------- @@ -312,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 @@ -346,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); @@ -380,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 -- @@ -404,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 @@ -428,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 @@ -457,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); @@ -477,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)); @@ -485,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 @@ -512,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); @@ -519,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; @@ -559,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 @@ -581,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); @@ -594,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; @@ -630,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 @@ -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 @@ -735,7 +856,7 @@ 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; @@ -743,15 +864,14 @@ package body Sem_Attr is 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 ("prefix of % attribute cannot be access type", P); + Error_Attr_P ("prefix of % attribute cannot be access type"); elsif Attr_Id = Attribute_First or else @@ -760,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; @@ -781,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; ------------------------- @@ -829,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; @@ -843,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; @@ -899,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; @@ -976,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); @@ -996,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; @@ -1019,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; @@ -1062,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; @@ -1073,7 +1196,7 @@ 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; @@ -1086,8 +1209,8 @@ package body Sem_Attr is Check_Type; if not Is_Modular_Integer_Type (P_Type) then - Error_Attr - ("prefix of % attribute must be modular integer type", P); + Error_Attr_P + ("prefix of % attribute must be modular integer type"); end if; end Check_Modular_Integer_Type; @@ -1096,13 +1219,64 @@ package body Sem_Attr is ------------------------------- 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; @@ -1133,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; @@ -1165,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; --------------------- @@ -1177,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; @@ -1190,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; @@ -1247,17 +1421,24 @@ package body Sem_Attr is -- 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. + -- 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 Is_Limited_Type (P_Type) - and then Comes_From_Source (N) - and then not Present (Find_Inherited_TSS (Btyp, Nam)) + 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 @@ -1277,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))) /= @@ -1312,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; @@ -1335,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))) @@ -1383,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 -- ---------------------------- @@ -1394,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 @@ -1404,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); @@ -1423,84 +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. However, we need to exclude - -- x86_64 for this check. - - for J in T'First .. T'Last - 1 loop - if (T (J .. J + 1) = "86" - and then - (J + 4 > T'Last - or else T (J + 2 .. J + 4) /= "_64")) - 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; @@ -1542,7 +1671,7 @@ 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 @@ -1557,6 +1686,12 @@ 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 @@ -1568,15 +1703,17 @@ package body Sem_Attr is 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); @@ -1584,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 @@ -1608,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; @@ -1629,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 @@ -1637,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 @@ -1691,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 @@ -1835,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 @@ -1851,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; @@ -1947,14 +2179,14 @@ package body Sem_Attr is 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))); @@ -1973,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); @@ -2000,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 ??? @@ -2021,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 @@ -2053,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; @@ -2130,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; @@ -2144,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; ------------------ @@ -2226,7 +2477,7 @@ package body Sem_Attr is if Warn_On_Obsolescent_Feature then Error_Msg_N ("constrained for private type is an " & - "obsolescent feature ('R'M 'J.4)?", N); + "obsolescent feature (RM J.4)?", N); end if; -- If we are within an instance, the attribute must be legal @@ -2267,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) @@ -2291,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 -- @@ -2413,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; @@ -2480,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); @@ -2526,6 +2785,29 @@ package body Sem_Attr is Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); + ------------- + -- Enabled -- + ------------- + + when Attribute_Enabled => + Check_Either_E0_Or_E1; + + 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 -- -------------- @@ -2543,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; @@ -2580,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; ----------- @@ -2661,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)); 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; ----------- @@ -2711,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; @@ -2830,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 -- -------------------- @@ -2894,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; @@ -3115,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). @@ -3125,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; @@ -3192,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 -- ----------- @@ -3367,7 +3721,8 @@ package body Sem_Attr is 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; @@ -3377,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; @@ -3400,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 @@ -3417,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; ------------------ @@ -3425,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 @@ -3454,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; ------------------ @@ -3478,7 +3841,23 @@ package body Sem_Attr is then Set_Etype (N, Universal_Integer); else - Error_Attr ("invalid prefix for % attribute", P); + 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; ---------- @@ -3496,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) @@ -3515,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??? @@ -3524,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)); ----------------- @@ -3575,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); @@ -3658,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 @@ -3759,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); @@ -3773,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 @@ -3941,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 @@ -4042,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 -- --------------- @@ -4053,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; @@ -4067,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); @@ -4399,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 @@ -4413,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). @@ -4528,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 @@ -4657,13 +5123,16 @@ 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_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 @@ -4673,14 +5142,15 @@ package body Sem_Attr is 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; @@ -4696,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_Version >= Ada_95; + Static := Ada_Version >= Ada_95 + and then Statically_Denotes_Entity (P); declare N : Node_Id; @@ -5100,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 -- @@ -5320,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 -- -------------------- @@ -6082,7 +6587,6 @@ package body Sem_Attr is end if; Rewrite (N, New_Occurrence_Of (RTE (Id), Loc)); - end Type_Class; ----------------------- @@ -6153,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; ------------- @@ -6232,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 := @@ -6241,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); @@ -6303,19 +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. - - -- Is this right for UTF-8? + -- 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); @@ -6462,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 | @@ -6471,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 | @@ -6524,7 +7023,6 @@ package body Sem_Attr is else null; end if; - end Eval_Attribute; ------------------------------ @@ -6543,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 -- ----------------------- @@ -6553,6 +7061,7 @@ 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; @@ -6573,10 +7082,10 @@ package body Sem_Attr is -- know will fail, so generate an appropriate warning. if In_Instance_Body then - Error_Msg_N + Error_Msg_F ("?non-local pointer cannot point to local object", P); - Error_Msg_N - ("?Program_Error will be raised at run time", 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)); @@ -6584,7 +7093,7 @@ package body Sem_Attr is return; else - Error_Msg_N + Error_Msg_F ("non-local pointer cannot point to local object", P); -- Check for case where we have a missing access definition @@ -6605,8 +7114,8 @@ package body Sem_Attr is if Present (Indic) then Error_Msg_NE ("\use an access definition for" & - " the access discriminant of&", N, - Entity (Subtype_Mark (Indic))); + " the access discriminant of&", + N, Entity (Subtype_Mark (Indic))); end if; end if; end if; @@ -6653,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; @@ -6660,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; @@ -6679,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; @@ -6693,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, @@ -6728,9 +7240,21 @@ package body Sem_Attr is 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 @@ -6741,18 +7265,19 @@ 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 not In_Instance_Body and then Subprogram_Access_Level (Entity (P)) > Type_Access_Level (Btyp) and then Ekind (Btyp) /= @@ -6760,45 +7285,127 @@ package body Sem_Attr is 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. - - -- Ada2005: If the expected type is for an access - -- parameter, this clause does not apply. + ("''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 Present (Enclosing_Generic_Body (Entity (P))) - and then Enclosing_Generic_Body (Entity (P)) /= - Enclosing_Generic_Body (Btyp) - and then - Ekind (Btyp) /= E_Anonymous_Access_Subprogram_Type - 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. + -- 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))); @@ -6813,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; @@ -6847,14 +7454,17 @@ 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 Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type - or else (Is_Record_Type (Btyp) and then - Present (Corresponding_Remote_Type (Btyp))) + 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 @@ -6862,8 +7472,16 @@ package body Sem_Attr is 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; @@ -6874,55 +7492,71 @@ package body Sem_Attr is or else Ekind (Btyp) = E_Anonymous_Access_Type) then -- Ada 2005 (AI-230): Check the accessibility of anonymous - -- access types in record and array components. For a - -- component definition the level is the same of the - -- enclosing composite type. + -- 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 Ekind (Btyp) = E_Anonymous_Access_Type - and then (Is_Array_Type (Scope (Btyp)) - or else Ekind (Scope (Btyp)) = E_Record_Type) + 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_N + Error_Msg_F ("?non-local pointer cannot point to local object", P); - Error_Msg_N - ("?Program_Error will be raised at run time", 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_N + 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) @@ -6942,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; @@ -6957,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)) @@ -6973,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)); @@ -7023,18 +7665,18 @@ package body Sem_Attr is if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) then - Error_Msg_N ("context requires a protected subprogram", P); + 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. + -- 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 No (Original_Access_Type (Typ)) + and then Attr_Id /= Attribute_Unrestricted_Access then Accessibility_Message; return; @@ -7045,7 +7687,7 @@ package body Sem_Attr is 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 @@ -7058,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)) @@ -7066,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 -- ------------- @@ -7087,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. @@ -7095,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); @@ -7103,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 @@ -7130,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 -- --------------- @@ -7199,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 -- -------------------- @@ -7454,6 +8121,15 @@ package body Sem_Attr is 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 @@ -7466,4 +8142,85 @@ package body Sem_Attr is 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;