From ec19aaaf927977db65022cb344615a26098e9cd4 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 11 Oct 2010 09:30:15 +0000 Subject: [PATCH] 2010-10-11 Gary Dismukes * 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 * 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 * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165285 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 23 +++++++++++++++++++++++ gcc/ada/exp_attr.adb | 1 + gcc/ada/lib-xref.adb | 2 +- gcc/ada/lib-xref.ads | 6 +++++- gcc/ada/par-ch4.adb | 1 + gcc/ada/sem_attr.adb | 43 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_disp.adb | 7 +++---- gcc/ada/sem_res.adb | 4 ++-- gcc/ada/snames.ads-tmpl | 2 ++ gcc/ada/xr_tabls.adb | 5 +++-- 10 files changed, 84 insertions(+), 10 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 87552d1dcf1..0d2b6bed060 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2010-10-11 Gary Dismukes + + * 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 + + * 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 + + * 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 * 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 e573906d483..18864c06dfb 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 d87daec69b9..02af70c23b5 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 86303d1627d..d14e163e9f9 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 c444d6708a4..bcffe80979e 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 b6cb8a46de6..7bc45571001 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 478819af007..6205c094438 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 c737f24f0a3..7245b0bb410 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 ad43f3a0e43..94e1ba27be8 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 b75da1f8423..29021aa3e28 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; -- 2.11.0