diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8546a3461c0..ff6e85c3e81 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2012-10-29 Thomas Quinot + + * gnat_rm.texi, sem_prag.adb, sem_util.adb, sem_util.ads, + par-prag.adb, par-util.adb, snames.ads-tmpl (Sem_Prag.Analyze_Pragma): + Handle new pragma Attribute_Definition. + (Sem_Util.Bad_Attribute): New routine, moved here + from par-util, so that it can be used by the above. + (Par_Util.Signal_Bad_Attribute): Processing moved to + Sem_Util.Bad_Attribute. + 2012-10-29 Robert Dewar * s-tpoben.ads, s-taskin.ads, exp_ch3.adb: Minor reformatting. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c084b1cdcd4..098978c7c3c 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -107,6 +107,7 @@ Implementation Defined Pragmas * Pragma Assert:: * Pragma Assertion_Policy:: * Pragma Assume_No_Invalid_Values:: +* Pragma Attribute_Definition:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: * Pragma Check:: @@ -845,6 +846,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Assert:: * Pragma Assertion_Policy:: * Pragma Assume_No_Invalid_Values:: +* Pragma Attribute_Definition:: * Pragma Ast_Entry:: * Pragma C_Pass_By_Copy:: * Pragma Check:: @@ -1308,6 +1310,28 @@ resulting from an OpenVMS system service call. The pragma does not affect normal use of the entry. For further details on this pragma, see the DEC Ada Language Reference Manual, section 9.12a. +@node Pragma Attribute_Definition +@unnumberedsec Pragma Attribute_Definition +@findex Attribute_Definition +@noindent +Syntax: +@smallexample @c ada +pragma Attribute_Definition + ([Attribute =>] ATTRIBUTE_DESIGNATOR, + [Entity =>] LOCAL_NAME, + [Expression =>] EXPRESSION | NAME); +@end smallexample + +@noindent +If Attribute is a known attribute name, this pragma is equivalent to +the attribute definition clause: +@smallexample @c ada + for Entity'Attribute use Expression; +@end smallexample +else the pragma is ignored, and a warning is emitted. This allows source +code to be written that takes advantage of some new attribute, while remaining +compilable with earlier compilers. + @node Pragma C_Pass_By_Copy @unnumberedsec Pragma C_Pass_By_Copy @cindex Passing by copy diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5bbf914d845..7dcf94033bb 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1103,6 +1103,7 @@ begin Pragma_Atomic | Pragma_Atomic_Components | Pragma_Attach_Handler | + Pragma_Attribute_Definition | Pragma_Check | Pragma_Check_Name | Pragma_Check_Policy | diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 0c23f93d90b..3baf9f51f57 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -716,20 +716,7 @@ package body Util is procedure Signal_Bad_Attribute is begin - Error_Msg_N ("unrecognized attribute&", Token_Node); - - -- Check for possible misspelling - - Error_Msg_Name_1 := First_Attribute_Name; - while Error_Msg_Name_1 <= Last_Attribute_Name loop - if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then - Error_Msg_N -- CODEFIX - ("\possible misspelling of %", Token_Node); - exit; - end if; - - Error_Msg_Name_1 := Error_Msg_Name_1 + 1; - end loop; + Bad_Attribute (Token_Node, Token_Name, Warn => False); end Signal_Bad_Attribute; ----------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index aee77f9c22e..2957c856eac 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6919,6 +6919,47 @@ package body Sem_Prag is Assume_No_Invalid_Values := False; end if; + -------------------------- + -- Attribute_Definition -- + -------------------------- + + -- pragma Attribute_Definition + -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, + -- [Entity =>] LOCAL_NAME, + -- [Expression =>] EXPRESSION | NAME); + + when Pragma_Attribute_Definition => Attribute_Definition : declare + Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); + Aname : Name_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (3); + Check_Optional_Identifier (Arg1, "attribute"); + Check_Optional_Identifier (Arg2, "entity"); + Check_Optional_Identifier (Arg3, "expression"); + + if Nkind (Attribute_Designator) /= N_Identifier then + Error_Msg_N ("attribute name expected", Attribute_Designator); + return; + end if; + + Check_Arg_Is_Local_Name (Arg2); + + Aname := Chars (Attribute_Designator); + if not Is_Attribute_Name (Aname) then + Bad_Attribute (Attribute_Designator, Aname, Warn => True); + return; + end if; + + Rewrite (N, + Make_Attribute_Definition_Clause (Loc, + Name => Get_Pragma_Arg (Arg2), + Chars => Aname, + Expression => Get_Pragma_Arg (Arg3))); + Analyze (N); + end Attribute_Definition; + --------------- -- AST_Entry -- --------------- @@ -15289,6 +15330,7 @@ package body Sem_Prag is Pragma_Assert_And_Cut => -1, Pragma_Assertion_Policy => 0, Pragma_Assume_No_Invalid_Values => 0, + Pragma_Attribute_Definition => +3, Pragma_Asynchronous => -1, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1c9eb645555..690e30fe5f4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -36,6 +36,7 @@ with Fname; use Fname; with Freeze; use Freeze; with Lib; use Lib; with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; @@ -404,6 +405,33 @@ package body Sem_Util is and then Scope_Depth (ST) >= Scope_Depth (SCT); end Available_Full_View_Of_Component; + ------------------- + -- Bad_Attribute -- + ------------------- + + procedure Bad_Attribute + (N : Node_Id; + Nam : Name_Id; + Warn : Boolean := False) + is + begin + Error_Msg_Warn := Warn; + Error_Msg_N ("unrecognized attribute&<", N); + + -- Check for possible misspelling + + Error_Msg_Name_1 := First_Attribute_Name; + while Error_Msg_Name_1 <= Last_Attribute_Name loop + if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then + Error_Msg_N -- CODEFIX + ("\possible misspelling of %<", N); + exit; + end if; + + Error_Msg_Name_1 := Error_Msg_Name_1 + 1; + end loop; + end Bad_Attribute; + -------------------------------- -- Bad_Predicated_Subtype_Use -- -------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1b089b85ee7..bf6486d464f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -108,6 +108,14 @@ package Sem_Util is -- are open, and the scope of the array is not outside the scope of the -- component. + procedure Bad_Attribute + (N : Node_Id; + Nam : Name_Id; + Warn : Boolean := False); + -- Called when node N is expected to contain a valid attribute name, and + -- Nam is found instead. If Warn is set True this is a warning, else this + -- is an error. + procedure Bad_Predicated_Subtype_Use (Msg : String; N : Node_Id; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 7987c8a41fd..0fd39c34ef8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -363,6 +363,7 @@ package Snames is Name_Annotate : constant Name_Id := N + $; -- GNAT Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT + Name_Attribute_Definition : constant Name_Id := N + $; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT Name_Check_Name : constant Name_Id := N + $; -- GNAT Name_Check_Policy : constant Name_Id := N + $; -- GNAT @@ -1646,6 +1647,7 @@ package Snames is Pragma_Annotate, Pragma_Assertion_Policy, Pragma_Assume_No_Invalid_Values, + Pragma_Attribute_Definition, Pragma_C_Pass_By_Copy, Pragma_Check_Name, Pragma_Check_Policy,