Patchwork [Ada] Ada 2012 AI-0113 Detection of conflicting external tags

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 2, 2011, 2:28 p.m.
Message ID <20110802142848.GA1445@adacore.com>
Download mbox | patch
Permalink /patch/107930/
State New
Headers show

Comments

Arnaud Charlet - Aug. 2, 2011, 2:28 p.m.
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  <miranda@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.

Patch

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,