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-2010, 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 32with System; use System; 33with System.Storage_Elements; use System.Storage_Elements; 34 35package 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 188end GNAT.Debug_Utilities; 189