[multiple changes]

2010-10-11  Gary Dismukes  <dismukes@adacore.com>

	* sem_disp.adb (Check_Dispatching_Operation): Revise test for warning
	about nondispatching subprograms to use In_Same_List (reducing use of
	Parent links).

2010-10-11  Ed Schonberg  <schonberg@adacore.com>

	* xr_tabls.adb, sem_res.adb, lib-xref.adb, lib-xref.ads: Use s for
	reference in a static call.

2010-10-11  Steve Baird  <baird@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, case Type_Key): Type_Key
	attribute should always be transformed into a string literal in
	Analyze_Attribute.
	* par-ch4.adb: Type_Key attribute's type is String; update value of
	Is_Parameterless_Attribute constant to reflect this.
	* sem_attr.adb (Analyze_Attribute): Recognize Type_Key attribute and
	rewrite it as a string literal (attribute value is always known
	statically).
	* snames.ads-tmpl: Add entries for Type_Key attribute.

From-SVN: r165285

10 files changed, 84 insertions, 10 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 87552d1..0d2b6be 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2010-10-11  Gary Dismukes  <dismukes@adacore.com>
+
+	* sem_disp.adb (Check_Dispatching_Operation): Revise test for warning
+	about nondispatching subprograms to use In_Same_List (reducing use of
+	Parent links).
+
+2010-10-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* xr_tabls.adb, sem_res.adb, lib-xref.adb, lib-xref.ads: Use s for
+	reference in a static call.
+
+2010-10-11  Steve Baird  <baird@adacore.com>
+
+	* exp_attr.adb (Expand_N_Attribute_Reference, case Type_Key): Type_Key
+	attribute should always be transformed into a string literal in
+	Analyze_Attribute.
+	* par-ch4.adb: Type_Key attribute's type is String; update value of
+	Is_Parameterless_Attribute constant to reflect this.
+	* sem_attr.adb (Analyze_Attribute): Recognize Type_Key attribute and
+	rewrite it as a string literal (attribute value is always known
+	statically).
+	* snames.ads-tmpl: Add entries for Type_Key attribute.
+
 2010-10-11  Ed Schonberg  <schonberg@adacore.com>
 
 	* lib-xref.adb (Output_References): Common handling for objects and
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index e573906..18864c0 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5355,6 +5355,7 @@ package body Exp_Attr is
            Attribute_Stub_Type                    |
            Attribute_Target_Name                  |
            Attribute_Type_Class                   |
+           Attribute_Type_Key                     |
            Attribute_Unconstrained_Array          |
            Attribute_Universal_Literal_String     |
            Attribute_Wchar_T_Size                 |
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index d87daec..02af70c 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -470,7 +470,7 @@ package body Lib.Xref is
         and then Is_Ada_2005_Only (E)
         and then Ada_Version < Ada_2005
         and then Warn_On_Ada_2005_Compatibility
-        and then (Typ = 'm' or else Typ = 'r')
+        and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')
       then
          Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
       end if;
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 86303d1..d14e163 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1998-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2010, 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- --
@@ -183,6 +183,7 @@ package Lib.Xref is
    --              P = overriding primitive operation
    --              r = reference
    --              R = subprogram reference in dispatching call
+   --              s = subprogram reference in a static call
    --              t = end of body
    --              w = WITH line
    --              x = type extension
@@ -296,6 +297,9 @@ package Lib.Xref is
    --           the specification of the primitive operation of the root
    --           type when the call has a controlling argument in its class.
 
+   --           s is used to mark a static subprogram call. The reference is
+   --           to the specification of the subprogram being called.
+
    --           t is similar to e. It identifies the end of a corresponding
    --           body (such a reference always links up with a b reference)
 
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index c444d67..bcffe80 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -42,6 +42,7 @@ package body Ch4 is
       Attribute_Base         => True,
       Attribute_Class        => True,
       Attribute_Stub_Type    => True,
+      Attribute_Type_Key     => True,
       others                 => False);
    --  This map contains True for parameterless attributes that return a
    --  string or a type. For those attributes, a left parenthesis after
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index b6cb8a4..7bc4557 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4449,6 +4449,48 @@ package body Sem_Attr is
          Check_PolyORB_Attribute;
          Set_Etype (N, RTE (RE_TypeCode));
 
+      --------------
+      -- Type_Key --
+      --------------
+
+      when Attribute_Type_Key =>
+         Check_E0;
+         Check_Type;
+         declare
+            function Type_Key return String;
+            --  A very preliminary implementation.
+            --  For now, a signature consists of only the type name.
+            --  This is clearly incomplete (e.g., adding a new field to
+            --  a record type should change the type's Type_Key attribute).
+
+            --------------
+            -- Type_Key --
+            --------------
+
+            function Type_Key return String is
+
+               Full_Name : constant String_Id :=
+                 Fully_Qualified_Name_String (Entity (P));
+
+               Signature : String
+                 (1 .. Integer (String_Length (Full_Name)) - 1);
+               --  Decrement length to omit trailing NUL
+
+            begin
+               for J in Signature'Range loop
+                  Signature (J) :=
+                    Get_Character (Get_String_Char (Full_Name, Int (J)));
+               end loop;
+
+               return Signature & "'Type_Key";
+            end Type_Key;
+
+         begin
+            Rewrite (N, Make_String_Literal (Loc, Type_Key));
+         end;
+
+         Analyze_And_Resolve (N, Standard_String);
+
       -----------------
       -- UET_Address --
       -----------------
@@ -7596,6 +7638,7 @@ package body Sem_Attr is
            Attribute_Target_Name              |
            Attribute_Terminated               |
            Attribute_To_Address               |
+           Attribute_Type_Key                 |
            Attribute_UET_Address              |
            Attribute_Unchecked_Access         |
            Attribute_Universal_Literal_String |
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 478819a..6205c09 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1045,14 +1045,13 @@ package body Sem_Disp is
          --  case it looks suspiciously like an attempt to define a primitive
          --  operation, which requires the declaration to be in a package spec
          --  (3.2.3(6)). Only report cases where the type and subprogram are
-         --  in the same declaration list (by comparing the unit nodes reached
-         --  via Parent links), to avoid spurious warnings on subprograms in
+         --  in the same declaration list (by checking the enclosing parent
+         --  declarations), to avoid spurious warnings on subprograms in
          --  instance bodies when the type is declared in the instance spec but
          --  hasn't been frozen by the instance body.
 
          elsif not Is_Frozen (Tagged_Type)
-           and then
-             Parent (Parent (Tagged_Type)) = Parent (Parent (Parent (Subp)))
+           and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp)))
          then
             Error_Msg_N
               ("?not dispatching (must be defined in a package spec)", Subp);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c737f24..7245b0b 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5527,10 +5527,10 @@ package body Sem_Res is
       then
          Generate_Reference (Nam, Subp, 'R');
 
-      --  Normal case, not a dispatching call
+      --  Normal case, not a dispatching call. Generate a call reference.
 
       else
-         Generate_Reference (Nam, Subp);
+         Generate_Reference (Nam, Subp, 's');
       end if;
 
       if Is_Intrinsic_Subprogram (Nam) then
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index ad43f3a..94e1ba2 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -801,6 +801,7 @@ package Snames is
    Name_Terminated                     : constant Name_Id := N + $;
    Name_To_Address                     : constant Name_Id := N + $; -- GNAT
    Name_Type_Class                     : constant Name_Id := N + $; -- GNAT
+   Name_Type_Key                       : constant Name_Id := N + $; -- GNAT
    Name_UET_Address                    : constant Name_Id := N + $; -- GNAT
    Name_Unbiased_Rounding              : constant Name_Id := N + $;
    Name_Unchecked_Access               : constant Name_Id := N + $;
@@ -1316,6 +1317,7 @@ package Snames is
       Attribute_Terminated,
       Attribute_To_Address,
       Attribute_Type_Class,
+      Attribute_Type_Key,
       Attribute_UET_Address,
       Attribute_Unbiased_Rounding,
       Attribute_Unchecked_Access,
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb
index b75da1f..29021aa 100644
--- a/gcc/ada/xr_tabls.adb
+++ b/gcc/ada/xr_tabls.adb
@@ -395,7 +395,8 @@ package body Xr_Tabls is
 
    begin
       case Ref_Type is
-         when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | 'i' | ' ' | 'x' =>
+         when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' |
+              's' | 'i' | ' ' | 'x' =>
             null;
 
          when 'l' | 'w' =>
@@ -463,7 +464,7 @@ package body Xr_Tabls is
             New_Ref.Next          := Declaration.Body_Ref;
             Declaration.Body_Ref  := New_Ref;
 
-         when 'r' | 'R' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
+         when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
             New_Ref.Next          := Declaration.Ref_Ref;
             Declaration.Ref_Ref   := New_Ref;