old-autovect-branch/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-2005, AdaCore                     --
  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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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;
  51       N : Integer_Address;
  52       U : Natural := 0;
  53
  54    begin
  55       S (S'Last) := '#';
  56       P := Address_Image_Length - 1;
  57       N := To_Integer (A);
  58       while P > 3 loop
  59          if U = 4 then
  60             S (P) := '_';
  61             P := P - 1;
  62             U := 1;
  63
  64          else
  65             U := U + 1;
  66          end if;
  67
  68          S (P) := H (Integer (N mod 16));
  69          P := P - 1;
  70          N := N / 16;
  71       end loop;
  72
  73       S (1 .. 3) := "16#";
  74       return S;
  75    end Image;
  76
  77    -----------
  78    -- Image --
  79    -----------
  80
  81    --  String case
  82
  83    function Image (S : String) return String is
  84       W : String (1 .. 2 * S'Length + 2);
  85       P : Positive := 1;
  86
  87    begin
  88       W (1) := '"';
  89
  90       for J in S'Range loop
  91          if S (J) = '"' then
  92             P := P + 1;
  93             W (P) := '"';
  94          end if;
  95
  96          P := P + 1;
  97          W (P) := S (J);
  98       end loop;
  99
 100       P := P + 1;
 101       W (P) := '"';
 102       return W (1 .. P);
 103    end Image;
 104
 105    -------------
 106    -- Image_C --
 107    -------------
 108
 109    function Image_C (A : Address) return Image_C_String is
 110       S : Image_C_String;
 111       N : Integer_Address := To_Integer (A);
 112
 113    begin
 114       for P in reverse 3 .. S'Last loop
 115          S (P) := H (Integer (N mod 16));
 116          N := N / 16;
 117       end loop;
 118
 119       S (1 .. 2) := "0x";
 120       return S;
 121    end Image_C;
 122
 123    -----------
 124    -- Value --
 125    -----------
 126
 127    function Value (S : String) return System.Address is
 128       Base : Integer_Address := 10;
 129       Res  : Integer_Address := 0;
 130       Last : Natural := S'Last;
 131       C    : Character;
 132       N    : Integer_Address;
 133
 134    begin
 135       --  Skip final Ada 95 base character
 136
 137       if S (Last) = '#' or else S (Last) = ':' then
 138          Last := Last - 1;
 139       end if;
 140
 141       --  Loop through characters
 142
 143       for J in S'First .. Last loop
 144          C := S (J);
 145
 146          --  C format hex constant
 147
 148          if C = 'x' then
 149             if Res /= 0 then
 150                raise Constraint_Error;
 151             end if;
 152
 153             Base := 16;
 154
 155          --  Ada form based literal
 156
 157          elsif C = '#' or else C = ':' then
 158             Base := Res;
 159             Res  := 0;
 160
 161          --  Ignore all underlines
 162
 163          elsif C = '_' then
 164             null;
 165
 166          --  Otherwise must have digit
 167
 168          else
 169             if C in '0' .. '9' then
 170                N := Character'Pos (C) - Character'Pos ('0');
 171             elsif C in 'A' .. 'F' then
 172                N := Character'Pos (C) - (Character'Pos ('A') - 10);
 173             elsif C in 'a' .. 'f' then
 174                N := Character'Pos (C) - (Character'Pos ('a') - 10);
 175             else
 176                raise Constraint_Error;
 177             end if;
 178
 179             if N >= Base then
 180                raise Constraint_Error;
 181             else
 182                Res := Res * Base + N;
 183             end if;
 184          end if;
 185       end loop;
 186
 187       return To_Address (Res);
 188    end Value;
 189
 190 end GNAT.Debug_Utilities;