This patch adds a runtime check to the elaboration of tagged types to raise
Program_Error if a user-specified external tag is the same as the external
tag for some other declaration. The following test must raise Program_Error
if compiled with -gnat12
package Pkg1 is
type Typ is tagged null record;
for Typ'External_Tag use "ext_T1";
end;
package Pkg2 is
type Typ is tagged null record;
for Typ'External_Tag use "ext_T1";
end;
with Pkg1;
with Pkg2;
procedure Main is
O1 : Pkg1.Typ;
O2 : Pkg2.Typ;
begin
null;
end;
Command: gnatmake -q -gnatws -gnat12 main.adb; ./main
Output: raised PROGRAM_ERROR : duplicated external tag
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Javier Miranda <mira...@adacore.com>
* a-tags.ads, a-tags.adb (Check_TSD): New subprogram.
* rtsfind.ads (RE_Check_TSD): New runtime entity.
* exp_disp.adb (Make_DT): Generate call to the new runtime routine that
checks if the external tag of a type is the same as the external tag
of some other declaration.
Index: a-tags.adb
===================================================================
--- a-tags.adb (revision 176998)
+++ a-tags.adb (working copy)
@@ -303,6 +303,24 @@
return This - Offset_To_Top (This);
end Base_Address;
+ ---------------
+ -- Check_TSD --
+ ---------------
+
+ procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
+ T : Tag;
+
+ begin
+ -- Verify that the external tag of this TSD is not registered in the
+ -- runtime hash table.
+
+ T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
+
+ if T /= null then
+ raise Program_Error with "duplicated external tag";
+ end if;
+ end Check_TSD;
+
--------------------
-- Descendant_Tag --
--------------------
Index: a-tags.ads
===================================================================
--- a-tags.ads (revision 176998)
+++ a-tags.ads (working copy)
@@ -421,6 +421,10 @@
-- Ada 2005 (AI-251): Displace "This" to point to the base address of
-- the object (that is, the address of the primary tag of the object).
+ procedure Check_TSD (TSD : Type_Specific_Data_Ptr);
+ -- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD
+ -- is the same as the external tag for some other tagged type declaration.
+
function Displace (This : System.Address; T : Tag) return System.Address;
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 177138)
+++ rtsfind.ads (working copy)
@@ -551,6 +551,7 @@
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
+ RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags
@@ -1729,6 +1730,7 @@
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
+ RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags,
