source: trunk/disk-cache-inspector.lisp @ 3

Revision 3, 7.7 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: WOOD -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; disk-cache-inspector.lisp
6;; Inspector interface for the disk-cache data file.
7;; This code is as gross as it is because format is so slow.
8;;
9;; Copyright © 1996 Digitool, Inc.
10;; Copyright © 1992-1995 Apple Computer, Inc.
11;; All rights reserved.
12;; Permission is given to use, copy, and modify this software provided
13;; that Digitool is given credit in all derivative works.
14;; This software is provided "as is". Digitool makes no warranty or
15;; representation, either express or implied, with respect to this software,
16;; its quality, accuracy, merchantability, or fitness for a particular
17;; purpose.
18;;
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; A disk-cache inspects the normal way, but has a command that
23;; brings up a contents editor.
24;; While in the contents editor, you can move to any address
25;; with a command, you can control-click or double-click to
26;; move to a pointed-to address and set @, and you can option-click
27;; to just set @ to the pointed at value.
28;; The commands menu remembers the last two addresses visited.
29
30;;;;;;;;;;;;;;;;;;;;;;;;;;
31;;
32;; Modification History
33;;
34;; ------------- 0.96
35;; ------------- 0.95
36;; ------------- 0.94
37;; 03/21/96 bill %typed-uvref -> aref inside a lying declaration.
38;; ------------- 0.93
39;; ------------- 0.9
40;; ------------- 0.8
41;; ------------- 0.6
42;; 03/18/92 bill New file
43;;
44
45(In-package :wood)
46
47(defclass disk-cache-inspector (inspector::usual-object-first-inspector) ())
48
49; True to bring up the contents editor by default instead of the structure editor.
50(defparameter *inspect-disk-cache-data* t)
51
52(defmethod inspector::inspector-class ((object disk-cache))
53  (if *inspect-disk-cache-data*
54    'disk-cache-inspector
55    (call-next-method)))
56
57(defclass disk-cache-inspector-view (inspector::inspector-view)
58  ((last-address :initform nil :accessor last-address)
59   (current-address :initform nil :accessor current-address))
60  (:default-initargs :cache-p nil))
61
62(defmethod inspector::inspector-view-class ((in disk-cache-inspector))
63  'disk-cache-inspector-view)
64
65(defmethod inspector::compute-line-count ((in disk-cache-inspector))
66  (floor (+ (disk-cache-size (inspector::inspector-object in)) 15) 16))
67
68(defun encode-hex (value string index digits)
69  (unless (and (simple-string-p string)
70               (fixnump index)
71               (fixnump digits)
72               (>= index 0)
73               (<= (the fixnum (+ index digits)) (length string))
74               (fixnump value))
75    (error "You lose."))
76  (%encode-hex value string index digits))
77
78(defconstant *hex-digits* "0123456789ABCDEF")
79
80(defun %encode-hex (value string index digits-left)
81  (declare (optimize (speed 3 safety 0)))
82  (declare (fixnum pos digits-left value))
83  (if (eql digits-left 0)
84    index
85    (let ((r (logand value #xf))
86          (q (ash value -4)))
87      (declare (fixnum r q))
88      (let ((i (%encode-hex q string index (the fixnum (1- digits-left)))))
89        (setf (schar string i) (schar *hex-digits* r))
90        (the fixnum (1+ i))))))
91
92(defparameter *disk-cache-inspector-string*
93  (make-string 16 :element-type 'base-character))
94(defparameter *disk-cache-inspector-value*
95  (make-string (+ 8 2 8 1 8 1 8 1 8 2 16 2)
96               :initial-element #\space
97               :element-type 'base-character))
98
99(defmethod inspector::line-n ((in disk-cache-inspector) n)
100  (let* ((disk-cache (inspector::inspector-object in))
101         (address (* n 16))
102         (size (disk-cache-size disk-cache))
103         (string *disk-cache-inspector-string*)
104         (value *disk-cache-inspector-value*))
105    (let ((count (min 16 (- size address))))
106      (read-string disk-cache address count string)
107      (do ((i count (1+ i)))
108          ((>= i 16))
109        (declare (fixnum i))
110        (setf (schar string i) (code-char 0))))
111    (encode-hex address value 0 8)
112    (setf (schar value 8) #\:)
113    (let ((index 10)
114          (word -1))
115      (declare (fixnum index word))
116      (locally (declare (type (simple-array (unsigned-byte 16) (*)) string)
117                        (optimize (speed 3) (safety 0)))
118        (dotimes (i 4)
119          (encode-hex (aref string (incf word)) value index 4)
120          (encode-hex (aref string (incf word)) value (incf index 4) 4)
121          (incf index 5)))
122      (setf (schar value (incf index)) #\")
123      (dotimes (i 16)
124        (let ((char (schar string i)))
125          (declare (character char))
126          (setf (schar value (incf index))
127                (if (graphic-char-p char) char #\.))))
128      (setf (schar value (incf index)) #\")
129      (values value
130              nil
131              :static))))
132
133(defmethod inspector::prin1-value ((i disk-cache-inspector) stream value
134                                   &optional label type)
135  (declare (ignore label type))
136  (if (stringp value)
137    (stream-write-string stream value 0 (length value))
138    (call-next-method)))
139
140(defmethod inspector::inspect-selection ((v disk-cache-inspector-view))
141  (let ((selection (inspector::selection v)))
142    (if (eql 0 selection)
143      (call-next-method)
144      (let ((address (* (1- selection) 16))
145            (h (point-h (view-mouse-position v))))
146        (multiple-value-bind (ff ms) (view-font-codes v)
147          (let* ((w (nth-value 2 (font-codes-info ff ms)))
148                 (char (round h w))
149                 (word (floor (- char 10) 9))
150                 (dc (inspector::inspector-object v))
151                 (new-address (cond ((< word 0) address)
152                                    ((> word 3) (ed-beep) (cancel))
153                                    (t (read-unsigned-long dc (+ address (* word 4)))))))
154            (if (option-key-p)
155              (setq @ new-address)
156              (progn
157                (when (> new-address (disk-cache-size dc))
158                  (ed-beep) (cancel))
159                (scroll-to-address v new-address)))))))))
160
161(defmethod inspector::inspector-commands ((dc disk-cache))
162  `(("Inspect contents"
163     ,#'(lambda () (let ((*inspect-disk-cache-data* t))
164                     (inspect dc))))))
165
166(defmethod inspector::inspector-commands ((in disk-cache-inspector))
167  (let ((view (inspector::inspector-view in)))
168    `(("Inspect struct"
169     ,#'(lambda () (let ((*inspect-disk-cache-data* nil))
170                     (inspect (inspector::inspector-object in)))))
171      ("Go to address..."
172       ,#'(lambda ()
173            (let ((address (let ((*read-base* 16))
174                             (read-from-string
175                              (get-string-from-user "Enter an address (hex):")))))
176              (if (integerp address)
177                (scroll-to-address view address)))))
178      ,@(let ((last-address (last-address view)))
179          (when last-address
180            `((,(format nil "Go to address #x~x" last-address)
181               ,#'(lambda ()
182                    (scroll-to-address view last-address))))))
183      ,@(let ((current-address (current-address view)))
184          (when current-address
185            `((,(format nil "Go to address #x~x" current-address)
186               ,#'(lambda ()
187                    (scroll-to-address view current-address)))))))))
188
189(defmethod scroll-to-address ((v disk-cache-inspector-view) address)
190  (setf (last-address v) (current-address v))
191  (setf (current-address v) address)
192  (setq @ address)
193  (let* ((inspector (inspector::inspector v))
194         (dc (inspector::inspector-object inspector)))
195    (inspector::scroll-to-line
196     v
197     (1+ (floor (min (disk-cache-size dc) address) 16))
198     nil
199     0)
200    (unless (eql (inspector::compute-line-count inspector)
201                 (inspector::inspector-line-count inspector))
202      (inspector::resample v))))
203;;;    1   3/10/94  bill         1.8d247
204;;;    2   3/23/95  bill         1.11d010
Note: See TracBrowser for help on using the repository browser.