gcc/ada/libgnat/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-2024, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System;                  use System;
  33 with System.Storage_Elements; use System.Storage_Elements;
  34
  35 package body GNAT.Debug_Utilities is
  36
  37    H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
  38    --  Table of hex digits
  39
  40    -----------
  41    -- Image --
  42    -----------
  43
  44    --  Address case
  45
  46    function Image (A : Address) return Image_String is
  47       S : Image_String;
  48       P : Natural;
  49       N : Integer_Address;
  50       U : Natural := 0;
  51
  52    begin
  53       S (S'Last) := '#';
  54       P := Address_Image_Length - 1;
  55       N := To_Integer (A);
  56       while P > 3 loop
  57          if U = 4 then
  58             S (P) := '_';
  59             P := P - 1;
  60             U := 1;
  61
  62          else
  63             U := U + 1;
  64          end if;
  65
  66          S (P) := H (Integer (N mod 16));
  67          P := P - 1;
  68          N := N / 16;
  69       end loop;
  70
  71       S (1 .. 3) := "16#";
  72       return S;
  73    end Image;
  74
  75    -----------
  76    -- Image --
  77    -----------
  78
  79    --  String case
  80
  81    function Image (S : String) return String is
  82       W : String (1 .. 2 * S'Length + 2);
  83       P : Positive := 1;
  84
  85    begin
  86       W (1) := '"';
  87
  88       for J in S'Range loop
  89          if S (J) = '"' then
  90             P := P + 1;
  91             W (P) := '"';
  92          end if;
  93
  94          P := P + 1;
  95          W (P) := S (J);
  96       end loop;
  97
  98       P := P + 1;
  99       W (P) := '"';
 100       return W (1 .. P);
 101    end Image;
 102
 103    -------------
 104    -- Image_C --
 105    -------------
 106
 107    function Image_C (A : Address) return Image_C_String is
 108       S : Image_C_String;
 109       N : Integer_Address := To_Integer (A);
 110
 111    begin
 112       for P in reverse 3 .. S'Last loop
 113          S (P) := H (Integer (N mod 16));
 114          N := N / 16;
 115       end loop;
 116
 117       S (1 .. 2) := "0x";
 118       return S;
 119    end Image_C;
 120
 121    -----------
 122    -- Value --
 123    -----------
 124
 125    function Value (S : String) return System.Address is
 126       Base : Integer_Address := 10;
 127       Res  : Integer_Address := 0;
 128       Last : Natural := S'Last;
 129       C    : Character;
 130       N    : Integer_Address;
 131
 132    begin
 133       --  Skip final Ada 95 base character
 134
 135       if S (Last) = '#' or else S (Last) = ':' then
 136          Last := Last - 1;
 137       end if;
 138
 139       --  Loop through characters
 140
 141       for J in S'First .. Last loop
 142          C := S (J);
 143
 144          --  C format hex constant
 145
 146          if C = 'x' then
 147             if Res /= 0 then
 148                raise Constraint_Error;
 149             end if;
 150
 151             Base := 16;
 152
 153          --  Ada form based literal
 154
 155          elsif C = '#' or else C = ':' then
 156             Base := Res;
 157             Res  := 0;
 158
 159          --  Ignore all underlines
 160
 161          elsif C = '_' then
 162             null;
 163
 164          --  Otherwise must have digit
 165
 166          else
 167             if C in '0' .. '9' then
 168                N := Character'Pos (C) - Character'Pos ('0');
 169             elsif C in 'A' .. 'F' then
 170                N := Character'Pos (C) - (Character'Pos ('A') - 10);
 171             elsif C in 'a' .. 'f' then
 172                N := Character'Pos (C) - (Character'Pos ('a') - 10);
 173             else
 174                raise Constraint_Error;
 175             end if;
 176
 177             if N >= Base then
 178                raise Constraint_Error;
 179             else
 180                Res := Res * Base + N;
 181             end if;
 182          end if;
 183       end loop;
 184
 185       return To_Address (Res);
 186    end Value;
 187
 188 end GNAT.Debug_Utilities;