a-tags.adb (Internal_Tag): Protect the run-time against wrong internal tags.

2007-08-31  Javier Miranda  <miranda@adacore.com>

	* a-tags.adb (Internal_Tag): Protect the run-time against wrong
	internal tags.

From-SVN: r127968

diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 0b735be7a443ca4f2d3993fdf4743383daa10bb6..33f0be3a6bee80a8d4fb255f9bafb6a444c61504 100644 (file)
--- a/gcc/ada/a-tags.adb
+++ b/gcc/ada/a-tags.adb
@@ -628,9 +628,50 @@ package body Ada.Tags is
             end loop;
 
             if Addr_Last <= External'Last then
-               Addr :=
-                 Integer_Address'Value (External (Addr_First .. Addr_Last));
-               return To_Tag (Addr);
+
+               --  Protect the run-time against wrong internal tags. We
+               --  cannot use exception handlers here because it would
+               --  disable the use of this run-time compiling with
+               --  restriction No_Exception_Handler.
+
+               declare
+                  C         : Character;
+                  Wrong_Tag : Boolean := False;
+
+               begin
+                  if External (Addr_First) /= '1'
+                    or else External (Addr_First + 1) /= '6'
+                    or else External (Addr_First + 2) /= '#'
+                  then
+                     Wrong_Tag := True;
+
+                  else
+                     for J in Addr_First + 3 .. Addr_Last - 1 loop
+                        C := External (J);
+
+                        if not (C in '0' .. '9')
+                          and then not (C in 'A' .. 'F')
+                          and then not (C in 'a' .. 'f')
+                        then
+                           Wrong_Tag := True;
+                           exit;
+                        end if;
+                     end loop;
+                  end if;
+
+                  --  Convert the numeric value into a tag
+
+                  if not Wrong_Tag then
+                     Addr := Integer_Address'Value
+                               (External (Addr_First .. Addr_Last));
+
+                     --  Internal tags never have value 0
+
+                     if Addr /= 0 then
+                        return To_Tag (Addr);
+                     end if;
+                  end if;
+               end;
             end if;
          end;