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

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

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 322 bytes --]

This patch enables detection of conflicting external tags when compiling
under Ada 2005 mode. Required since this AI is a binding interpretation.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_DT): Generate call to Check_TSD in Ada 2005 mode.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 1006 bytes --]

Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 177161)
+++ exp_disp.adb	(working copy)
@@ -5995,10 +5995,17 @@
 
       --     Check_TSD (TSD'Unrestricted_Access);
 
-      --  Seems wrong to restrict this BI to Ada 2012 ???
+      --  This check is a consequence of AI05-0113-1/06, so it officially
+      --  applies to Ada 2005 (and Ada 2012). It might be argued that it is
+      --  a desirable check to add in Ada 95 mode, but we hesitate to make
+      --  this change, as it would be incompatible, and could conceivably
+      --  cause a problem in existing Aa 95 code.
 
+      --  We check for No_Run_Time_Mode here, because we do not want to pick
+      --  up the RE_Check_TSD entity and call it in No_Run_Time mode.
+
       if not No_Run_Time_Mode
-        and then Ada_Version >= Ada_2012
+        and then Ada_Version >= Ada_2005
         and then RTE_Available (RE_Check_TSD)
       then
          Append_To (Elab_Code,

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

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 1034 bytes --]

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.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 2437 bytes --]

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,