gnat_rm.texi, [...] (Sem_Prag.Analyze_Pragma): Handle new pragma Attribute_Definition.

2012-10-29  Thomas Quinot  <quinot@adacore.com>

	* 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.

From-SVN: r192935

gcc/ada/ChangeLog

@@ -1,3 +1,13 @@
+2012-10-29  Thomas Quinot  <quinot@adacore.com>
+
+	* 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  <dewar@adacore.com>
 
 	* s-tpoben.ads, s-taskin.ads, exp_ch3.adb: Minor reformatting.

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

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                   |

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);
+      Bad_Attribute (Token_Node, Token_Name, Warn => False);
-
-      --  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;
    end Signal_Bad_Attribute;
 
    -----------------------------

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,

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 --
    --------------------------------

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;

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,