From: Robert Dewar Date: Mon, 14 Oct 2013 12:46:56 +0000 (+0000) Subject: exp_attr.adb (Expand_N_Attribute_Reference): Add error entry for Library_Level attrib... X-Git-Tag: releases/gcc-4.9.0~3521 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=f7ea2603f6c28fa91fbf2bf5f79cb2d04cec61c7;p=thirdparty%2Fgcc.git exp_attr.adb (Expand_N_Attribute_Reference): Add error entry for Library_Level attribute (which should not survive to expansion) 2013-10-14 Robert Dewar * exp_attr.adb (Expand_N_Attribute_Reference): Add error entry for Library_Level attribute (which should not survive to expansion) * gnat_rm.texi: Document attribute Library_Level * sem_attr.adb (Analyze_Attribute, case Library_Level): Implement this new attribute (Set_Boolean_Result): Replaces Set_Result (Check_Standard_Prefix): Document that Check_E0 is called (Check_System_Prefix): New procedure * snames.ads-tmpl: Add entry for Library_Level attribute 2013-10-14 Robert Dewar * exp_ch6.adb, sinfo.ads: Minor reformatting. * checks.adb (Overlap_Check): Use identifier casing in messages. From-SVN: r203528 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 567d644f188c..6c3394354862 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2013-10-14 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference): Add error + entry for Library_Level attribute (which should not survive + to expansion) + * gnat_rm.texi: Document attribute Library_Level + * sem_attr.adb (Analyze_Attribute, case Library_Level): Implement + this new attribute (Set_Boolean_Result): Replaces Set_Result + (Check_Standard_Prefix): Document that Check_E0 is called + (Check_System_Prefix): New procedure + * snames.ads-tmpl: Add entry for Library_Level attribute + +2013-10-14 Robert Dewar + + * exp_ch6.adb, sinfo.ads: Minor reformatting. + * checks.adb (Overlap_Check): Use identifier casing in messages. + 2013-10-14 Robert Dewar * einfo.ads, einfo.adb (Default_Aspect_Component_Value): Is on base type diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 29a185931671..f968e20200b8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; @@ -2189,7 +2190,9 @@ package body Checks is Formal_2 : Entity_Id; Check : in out Node_Id) is - Cond : Node_Id; + Cond : Node_Id; + ID_Casing : constant Casing_Type := + Identifier_Casing (Source_Index (Current_Sem_Unit)); begin -- Generate: @@ -2220,9 +2223,17 @@ package body Checks is end if; Store_String_Chars ("aliased parameters, actuals for """); - Store_String_Chars (Get_Name_String (Chars (Formal_1))); + + Get_Name_String (Chars (Formal_1)); + Set_Casing (ID_Casing); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Store_String_Chars (""" and """); - Store_String_Chars (Get_Name_String (Chars (Formal_2))); + + Get_Name_String (Chars (Formal_2)); + Set_Casing (ID_Casing); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Store_String_Chars (""" overlap"); Insert_Action (Call, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 003476725117..1a6ad5721462 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6485,6 +6485,7 @@ package body Exp_Attr is Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Last_Valid | + Attribute_Library_Level | Attribute_Lock_Free | Attribute_Machine_Emax | Attribute_Machine_Emin | diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 151d649c8c93..d1c4641e12d7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8084,8 +8084,9 @@ package body Exp_Ch6 is -- AI05-0073: If function has a controlling access result, check that -- the tag of the return value, if it is not null, matches designated -- type of return type. - -- The return expression is referenced twice in the code below, so - -- it must be made free of side effects. Given that different compilers + + -- The return expression is referenced twice in the code below, so it + -- must be made free of side effects. Given that different compilers -- may evaluate these parameters in different order, both occurrences -- perform a copy. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3c62f3d2127e..cc3f2480ac5a 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -337,6 +337,7 @@ Implementation Defined Attributes * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -7842,6 +7843,7 @@ consideration, you should minimize the use of these attributes. * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -8341,6 +8343,31 @@ The @code{Large} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. +@node Attribute Library_Level +@unnumberedsec Attribute Library_Level +@findex Library_Level +@noindent +@noindent +@code{Standard'Library_Level} (@code{Standard} is the only allowed +prefix) returns a Boolean value which is True if the attribute is +evaluated at the library level (e.g. with a package declaration), +and false if evaluated elsewhere (e.g. within a subprogram body). +In the case of generics, the value indicates the placement of +the instantiation, not the template, and indeed the use of this +attribute within a generic is the intended common application +as shown in this example: + +@smallexample @c ada +generic + ... +package Gen is + pragma Compile_Time_Error + (not Standard'Library_Level, + "Gen can only be instantiated at library level"); + ... +end Gen; +@end smallexample + @node Attribute Loop_Entry @unnumberedsec Attribute Loop_Entry @findex Loop_Entry diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 44692e038238..f235921068bf 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -189,6 +189,11 @@ package body Sem_Attr is -- where therefore the prefix of the attribute does not match the enclosing -- scope. + procedure Set_Boolean_Result (N : Node_Id; B : Boolean); + -- Rewrites node N with an occurrence of either Standard_False or + -- Standard_True, depending on the value of the parameter B. The + -- result is marked as a static expression. + ----------------------- -- Analyze_Attribute -- ----------------------- @@ -339,13 +344,17 @@ package body Sem_Attr is -- Verify that prefix of attribute N is a scalar type procedure Check_Standard_Prefix; - -- Verify that prefix of attribute N is package Standard + -- Verify that prefix of attribute N is package Standard. Also checks + -- that there are no arguments. procedure Check_Stream_Attribute (Nam : TSS_Name_Type); -- Validity checking for stream attribute. Nam is the TSS name of the -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_System_Prefix; + -- Verify that prefix of attribute N is package System + procedure Check_PolyORB_Attribute; -- Validity checking for PolyORB/DSA attribute @@ -1972,6 +1981,17 @@ package body Sem_Attr is Check_Not_CPP_Type; end Check_Stream_Attribute; + ------------------------- + -- Check_System_Prefix -- + ------------------------- + + procedure Check_System_Prefix is + begin + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then + Error_Attr ("only allowed prefix for % attribute is System", P); + end if; + end Check_System_Prefix; + ----------------------- -- Check_Task_Prefix -- ----------------------- @@ -3663,6 +3683,21 @@ package body Sem_Attr is Check_Array_Type; Set_Etype (N, Universal_Integer); + ------------------- + -- Library_Level -- + ------------------- + + when Attribute_Library_Level => + Check_E0; + Check_Standard_Prefix; + + if not Inside_A_Generic then + Set_Boolean_Result (N, + Nearest_Dynamic_Scope (Current_Scope) = Standard_Standard); + end if; + + Set_Etype (N, Standard_Boolean); + --------------- -- Lock_Free -- --------------- @@ -4965,35 +5000,10 @@ package body Sem_Attr is U : Node_Id; Unam : Unit_Name_Type; - procedure Set_Result (B : Boolean); - -- Replace restriction node by static constant False or True, - -- depending on the value of B. - - ---------------- - -- Set_Result -- - ---------------- - - procedure Set_Result (B : Boolean) is - begin - if B then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - - Set_Is_Static_Expression (N); - end Set_Result; - - -- Start of processing for Restriction_Set - begin Check_E1; Analyze (P); - - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Set_Result (False); - Error_Attr_P ("prefix of % attribute must be System"); - end if; + Check_System_Prefix; -- No_Dependence case @@ -5002,7 +5012,7 @@ package body Sem_Attr is U := Explicit_Actual_Parameter (E1); if not OK_No_Dependence_Unit_Name (U) then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr; end if; @@ -5013,14 +5023,14 @@ package body Sem_Attr is if Designate_Same_Unit (U, No_Dependences.Table (J).Unit) and then No_Dependences.Table (J).Warn = False then - Set_Result (True); + Set_Boolean_Result (N, True); return; end if; end loop; -- If not in the No_Dependence table, result is False - Set_Result (False); + Set_Boolean_Result (N, False); -- In this case, we must ensure that the binder will reject any -- other unit in the partition that sets No_Dependence for this @@ -5043,29 +5053,29 @@ package body Sem_Attr is else if Nkind (E1) /= N_Identifier then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr ("attribute % requires restriction identifier", E1); else R := Get_Restriction_Id (Process_Restriction_Synonyms (E1)); if R = Not_A_Restriction_Id then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("invalid restriction identifier &", E1); elsif R not in Partition_Boolean_Restrictions then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("& is not a boolean partition-wide restriction", E1); end if; if Restriction_Active (R) then - Set_Result (True); + Set_Boolean_Result (N, True); else Check_Restriction (R, N); - Set_Result (False); + Set_Boolean_Result (N, False); end if; end if; end if; @@ -5596,10 +5606,7 @@ package body Sem_Attr is begin Check_E1; Analyze (P); - - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Error_Attr_P ("prefix of % attribute must be System"); - end if; + Check_System_Prefix; Generate_Reference (RTE (RE_Address), P); Analyze_And_Resolve (E1, Any_Integer); @@ -6809,8 +6816,8 @@ package body Sem_Attr is return; end if; - -- Cases where P is not an object. Cannot do anything if P is - -- not the name of an entity. + -- Cases where P is not an object. Cannot do anything if P is not the + -- name of an entity. elsif not Is_Entity_Name (P) then Check_Expressions; @@ -6908,10 +6915,9 @@ package body Sem_Attr is -- We can fold 'Alignment applied to a type if the alignment is known -- (as happens for an alignment from an attribute definition clause). - -- At this stage, this can happen only for types (e.g. record - -- types) for which the size is always non-static. We exclude - -- generic types from consideration (since they have bogus - -- sizes set within templates). + -- At this stage, this can happen only for types (e.g. record types) for + -- which the size is always non-static. We exclude generic types from + -- consideration (since they have bogus sizes set within templates). elsif Id = Attribute_Alignment and then Is_Type (P_Entity) @@ -9118,6 +9124,7 @@ package body Sem_Attr is Attribute_First_Bit | Attribute_Input | Attribute_Last_Bit | + Attribute_Library_Level | Attribute_Maximum_Alignment | Attribute_Old | Attribute_Output | @@ -10421,6 +10428,23 @@ package body Sem_Attr is Eval_Attribute (N); end Resolve_Attribute; + ------------------------ + -- Set_Boolean_Result -- + ------------------------ + + procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if B then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Set_Is_Static_Expression (N); + end Set_Boolean_Result; + -------------------------------- -- Stream_Attribute_Available -- -------------------------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c39f3c4885cd..ebe51f29d66c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -7646,7 +7646,7 @@ package Sinfo is -- N_Subprogram_Info -- Sloc points to the entity for the procedure -- Identifier (Node1) identifier referencing the procedure - -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc + -- Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc) -- Note: in the case where a debug source file is generated, the Sloc -- for this node points to the quote in the Sprint file output. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 5254b57b3660..c5c4cdab7d29 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -807,20 +807,15 @@ package Snames is -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These - -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT. + -- attributes are implemented in all Ada modes in GNAT. -- The entries marked GNAT are attributes that are defined by GNAT and - -- implemented in both Ada 83 and Ada 95 modes. Full descriptions of these - -- implementation dependent attributes may be found in the appropriate - -- section in Sem_Attr. + -- implemented in all Ada modes. Full descriptions of these implementation + -- dependent attributes may be found in the appropriate Sem_Attr section. -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - -- The entries marked HiLite are attributes that are defined by Hi-Lite - -- and implemented in GNAT operating under formal verification mode. The - -- entries are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + $; Name_Abort_Signal : constant Name_Id := N + $; -- GNAT Name_Access : constant Name_Id := N + $; @@ -881,8 +876,9 @@ package Snames is Name_Last_Valid : constant Name_Id := N + $; -- Ada 12 Name_Leading_Part : constant Name_Id := N + $; Name_Length : constant Name_Id := N + $; + Name_Library_Level : constant Name_Id := N + $; -- GNAT Name_Lock_Free : constant Name_Id := N + $; -- GNAT - Name_Loop_Entry : constant Name_Id := N + $; -- HiLite + Name_Loop_Entry : constant Name_Id := N + $; -- GNAT Name_Machine_Emax : constant Name_Id := N + $; Name_Machine_Emin : constant Name_Id := N + $; Name_Machine_Mantissa : constant Name_Id := N + $; @@ -1498,6 +1494,7 @@ package Snames is Attribute_Last_Valid, Attribute_Leading_Part, Attribute_Length, + Attribute_Library_Level, Attribute_Lock_Free, Attribute_Loop_Entry, Attribute_Machine_Emax,