* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165285
138bc75d-0d04-0410-961f-
82ee72b054a4
+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
Attribute_Stub_Type |
Attribute_Target_Name |
Attribute_Type_Class |
+ Attribute_Type_Key |
Attribute_Unconstrained_Array |
Attribute_Universal_Literal_String |
Attribute_Wchar_T_Size |
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;
-- --
-- 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- --
-- 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
-- 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)
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
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 --
-----------------
Attribute_Target_Name |
Attribute_Terminated |
Attribute_To_Address |
+ Attribute_Type_Key |
Attribute_UET_Address |
Attribute_Unchecked_Access |
Attribute_Universal_Literal_String |
-- 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);
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
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 + $;
Attribute_Terminated,
Attribute_To_Address,
Attribute_Type_Class,
+ Attribute_Type_Key,
Attribute_UET_Address,
Attribute_Unbiased_Rounding,
Attribute_Unchecked_Access,
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' =>
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;
OSDN Git Service
