diff mbox

[Ada] Improved runtime exception message for duplicated external tag

Message ID 20110804094335.GA11964@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 4, 2011, 9:43 a.m. UTC 
This change improves the exception message associated with PROGRAM_ERROR
for duplicated external tag by including the value of the offending
external tag.

The following compilation must raise Program_Error with the indicated
exception message:

$ gnatmake -z dup_ext_tag.ads
$ ./dup_ext_tag 

raised PROGRAM_ERROR : duplicated external tag foo

pragma Ada_2005;
package Dup_Ext_Tag is
   type T1 is tagged null record; for T1'External_Tag use "foo";
   type T2 is tagged null record; for T2'External_Tag use "foo";
end Dup_Ext_Tag;

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

2011-08-04  Thomas Quinot  <quinot@adacore.com>

	* a-tags.adb (Check_TSD): When raising PROGRAM_ERROR for a duplicated
	external tag, include the value of the external tag in the exception
	message.
diff mbox

Patch

Index: a-tags.adb
===================================================================
--- a-tags.adb	(revision 177275)
+++ a-tags.adb	(working copy)
@@ -310,6 +310,13 @@ 
    procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
       T : Tag;
 
+      E_Tag_Len : constant Integer := Length (TSD.External_Tag);
+      E_Tag     : String (1 .. E_Tag_Len);
+      for E_Tag'Address use TSD.External_Tag.all'Address;
+      pragma Import (Ada, E_Tag);
+
+   --  Start of processing for Check_TSD
+
    begin
       --  Verify that the external tag of this TSD is not registered in the
       --  runtime hash table.
@@ -317,7 +324,7 @@ 
       T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
 
       if T /= null then
-         raise Program_Error with "duplicated external tag";
+         raise Program_Error with "duplicated external tag " & E_Tag;
       end if;
    end Check_TSD;
 
@@ -718,6 +725,8 @@ 
    -- Length --
    ------------
 
+   --  Should this be reimplemented using the strlen GCC builtin???
+
    function Length (Str : Cstring_Ptr) return Natural is
       Len : Integer;