1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . M E M O R Y _ D U M P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2003-2014, 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.Img_BIU; use System.Img_BIU; 34with System.Storage_Elements; use System.Storage_Elements; 35 36with GNAT.IO; use GNAT.IO; 37with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; 38 39with Ada.Unchecked_Conversion; 40 41package body GNAT.Memory_Dump is 42 43 ---------- 44 -- Dump -- 45 ---------- 46 47 procedure Dump 48 (Addr : Address; 49 Count : Natural) 50 is 51 begin 52 Dump (Addr, Count, Prefix => Absolute_Address); 53 end Dump; 54 55 procedure Dump 56 (Addr : Address; 57 Count : Natural; 58 Prefix : Prefix_Type) 59 is 60 Ctr : Natural := Count; 61 -- Count of bytes left to output 62 63 Offset_Buf : String (1 .. Standard'Address_Size / 4 + 4); 64 Offset_Last : Natural; 65 -- Buffer for prefix in Offset mode 66 67 Adr : Address := Addr; 68 -- Current address 69 70 N : Natural := 0; 71 -- Number of bytes output on current line 72 73 C : Character; 74 -- Character at current storage address 75 76 AIL : Natural; 77 -- Number of chars in prefix (including colon and space) 78 79 Line_Len : Natural; 80 -- Line length for entire line 81 82 Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF"; 83 84 type Char_Ptr is access all Character; 85 86 function To_Char_Ptr is new Ada.Unchecked_Conversion (Address, Char_Ptr); 87 88 begin 89 case Prefix is 90 when Absolute_Address => 91 AIL := Address_Image_Length - 4 + 2; 92 93 when Offset => 94 Offset_Last := Offset_Buf'First - 1; 95 Set_Image_Based_Integer (Ctr, 16, 0, Offset_Buf, Offset_Last); 96 AIL := Offset_Last - 4 + 2; 97 98 when None => 99 AIL := 0; 100 end case; 101 102 Line_Len := AIL + 3 * 16 + 2 + 16; 103 104 declare 105 Line_Buf : String (1 .. Line_Len); 106 107 begin 108 while Ctr /= 0 loop 109 110 -- Start of line processing 111 112 if N = 0 then 113 case Prefix is 114 when Absolute_Address => 115 declare 116 S : constant String := Image (Adr); 117 begin 118 Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) & ": "; 119 end; 120 121 when Offset => 122 declare 123 Last : Natural := 0; 124 Len : Natural; 125 126 begin 127 Set_Image_Based_Integer 128 (Count - Ctr, 16, 0, Offset_Buf, Last); 129 Len := Last - 4; 130 131 Line_Buf (1 .. AIL - Len - 2) := (others => '0'); 132 Line_Buf (AIL - Len - 1 .. AIL - 2) := 133 Offset_Buf (4 .. Last - 1); 134 Line_Buf (AIL - 1 .. AIL) := ": "; 135 end; 136 when None => 137 null; 138 end case; 139 140 Line_Buf (AIL + 1 .. Line_Buf'Last) := (others => ' '); 141 Line_Buf (AIL + 3 * 16 + 1) := '"'; 142 end if; 143 144 -- Add one character to current line 145 146 C := To_Char_Ptr (Adr).all; 147 Adr := Adr + 1; 148 Ctr := Ctr - 1; 149 150 Line_Buf (AIL + 3 * N + 1) := Hex (Character'Pos (C) / 16); 151 Line_Buf (AIL + 3 * N + 2) := Hex (Character'Pos (C) mod 16); 152 153 if C < ' ' or else C = Character'Val (16#7F#) then 154 C := '?'; 155 end if; 156 157 Line_Buf (AIL + 3 * 16 + 2 + N) := C; 158 N := N + 1; 159 160 -- End of line processing 161 162 if N = 16 then 163 Line_Buf (Line_Buf'Last) := '"'; 164 GNAT.IO.Put_Line (Line_Buf); 165 N := 0; 166 end if; 167 end loop; 168 169 -- Deal with possible last partial line 170 171 if N /= 0 then 172 Line_Buf (AIL + 3 * 16 + 2 + N) := '"'; 173 GNAT.IO.Put_Line (Line_Buf (1 .. AIL + 3 * 16 + 2 + N)); 174 end if; 175 end; 176 end Dump; 177 178end GNAT.Memory_Dump; 179