gcc/ada/g-debuti.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                 G N A T . D E B U G _ U T I L I T I E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 1997-2003 Ada Core Technologies, Inc.            --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System;                  use System;
  35 with System.Storage_Elements; use System.Storage_Elements;
  36
  37 package body GNAT.Debug_Utilities is
  38
  39       H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
  40       --  Table of hex digits
  41
  42    -----------
  43    -- Image --
  44    -----------
  45
  46    --  Address case
  47
  48    function Image (A : Address) return Image_String is
  49       S : Image_String;
  50       P : Natural := Address_Image_Length - 1;
  51       N : Integer_Address := To_Integer (A);
  52       U : Natural := 0;
  53
  54    begin
  55       S (S'Last) := '#';
  56
  57       while P > 3 loop
  58          if U = 4 then
  59             S (P) := '_';
  60             P := P - 1;
  61             U := 1;
  62
  63          else
  64             U := U + 1;
  65          end if;
  66
  67          S (P) := H (Integer (N mod 16));
  68          P := P - 1;
  69          N := N / 16;
  70       end loop;
  71
  72       S (1 .. 3) := "16#";
  73       return S;
  74    end Image;
  75
  76    -----------
  77    -- Image --
  78    -----------
  79
  80    --  String case
  81
  82    function Image (S : String) return String is
  83       W : String (1 .. 2 * S'Length + 2);
  84       P : Positive := 1;
  85
  86    begin
  87       W (1) := '"';
  88
  89       for J in S'Range loop
  90          if S (J) = '"' then
  91             P := P + 1;
  92             W (P) := '"';
  93          end if;
  94
  95          P := P + 1;
  96          W (P) := S (J);
  97       end loop;
  98
  99       P := P + 1;
 100       W (P) := '"';
 101       return W (1 .. P);
 102    end Image;
 103
 104    -------------
 105    -- Image_C --
 106    -------------
 107
 108    function Image_C (A : Address) return Image_C_String is
 109       S : Image_C_String;
 110       N : Integer_Address := To_Integer (A);
 111
 112    begin
 113       for P in reverse 3 .. S'Last loop
 114          S (P) := H (Integer (N mod 16));
 115          N := N / 16;
 116       end loop;
 117
 118       S (1 .. 2) := "0x";
 119       return S;
 120    end Image_C;
 121
 122    -----------
 123    -- Value --
 124    -----------
 125
 126    function Value (S : String) return System.Address is
 127       Base : Integer_Address := 10;
 128       Res  : Integer_Address := 0;
 129       Last : Natural := S'Last;
 130       C    : Character;
 131       N    : Integer_Address;
 132
 133    begin
 134       --  Skip final Ada 95 base character
 135
 136       if S (Last) = '#' or else S (Last) = ':' then
 137          Last := Last - 1;
 138       end if;
 139
 140       --  Loop through characters
 141
 142       for J in S'First .. Last loop
 143          C := S (J);
 144
 145          --  C format hex constant
 146
 147          if C = 'x' then
 148             if Res /= 0 then
 149                raise Constraint_Error;
 150             end if;
 151
 152             Base := 16;
 153
 154          --  Ada form based literal
 155
 156          elsif C = '#' or C = ':' then
 157             Base := Res;
 158             Res  := 0;
 159
 160          --  Ignore all underlines
 161
 162          elsif C = '_' then
 163             null;
 164
 165          --  Otherwise must have digit
 166
 167          else
 168             if C in '0' .. '9' then
 169                N := Character'Pos (C) - Character'Pos ('0');
 170             elsif C in 'A' .. 'F' then
 171                N := Character'Pos (C) - (Character'Pos ('A') - 10);
 172             elsif C in 'a' .. 'f' then
 173                N := Character'Pos (C) - (Character'Pos ('a') - 10);
 174             else
 175                raise Constraint_Error;
 176             end if;
 177
 178             if N >= Base then
 179                raise Constraint_Error;
 180             else
 181                Res := Res * Base + N;
 182             end if;
 183          end if;
 184       end loop;
 185
 186       return To_Address (Res);
 187    end Value;
 188
 189 end GNAT.Debug_Utilities;