1 | ;;; -*- Mode:Lisp; Package:INSPECTOR -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (defpackage "INSPECTOR" |
---|
18 | (:use "CL" "CCL")) |
---|
19 | |
---|
20 | (in-package "INSPECTOR") |
---|
21 | |
---|
22 | (defvar ccl::@) |
---|
23 | |
---|
24 | ;;; The basic inspector object. |
---|
25 | ;;; Note that this knows nothing about windows. |
---|
26 | ;;; It merely knows how to number the constituent parts of an object, |
---|
27 | ;;; How to access a constituent, and how to print a constituent to a stream. |
---|
28 | (defclass inspector () |
---|
29 | ((object :accessor inspector-object :initarg :object) |
---|
30 | (line-count :accessor inspector-line-count :initarg :line-count :initform nil))) |
---|
31 | |
---|
32 | ;;; The usual way to cons up an inspector |
---|
33 | (defmethod make-inspector (object) |
---|
34 | (multiple-value-bind (class alias) (inspector-class object) |
---|
35 | (make-instance class :object (or alias object)))) |
---|
36 | |
---|
37 | (defmethod initialize-instance :after ((i inspector) &key update-line-count) |
---|
38 | (when update-line-count |
---|
39 | (update-line-count i))) |
---|
40 | |
---|
41 | ;;;;;;; |
---|
42 | ;;; |
---|
43 | ;;; The protocol for an inspector. |
---|
44 | ;;; Change these to defgeneric's when it exists. |
---|
45 | ;;; |
---|
46 | ;;; Usually, you need to define methods only for |
---|
47 | ;;; inspector-class, compute-line-count, line-n, and (setf line-n) |
---|
48 | |
---|
49 | ;;; Return the type of inspector for an object |
---|
50 | (defmethod inspector-class (object) |
---|
51 | (cond ((method-exists-p #'line-n object 0) 'usual-inspector) |
---|
52 | ((and (uvectorp object) |
---|
53 | (find-class 'uvector-inspector nil)) |
---|
54 | 'uvector-inspector) |
---|
55 | (t 'basic-inspector))) |
---|
56 | |
---|
57 | ;;; Return three values: the value, label, and type of the nth line of the object |
---|
58 | ;;; Valid types are: |
---|
59 | ;;; :NORMAL or NIL - a normal constituent line: changeable |
---|
60 | ;;; :COLON - a normal line with ": " between the label and the value |
---|
61 | ;;; :COMMENT - a commentary line - Print only the label |
---|
62 | ;;; :STATIC - a commentary line with an inspectable value: not changeable |
---|
63 | (defmethod line-n ((i inspector) n) |
---|
64 | (declare (ignore n))) |
---|
65 | |
---|
66 | ; set the value of line n of the object (the label is fixed) |
---|
67 | (defmethod (setf line-n) (value (i inspector) n) |
---|
68 | (declare (ignore value n))) |
---|
69 | |
---|
70 | ; Compute the number of lines in the object |
---|
71 | (defmethod compute-line-count ((i inspector)) |
---|
72 | 0 |
---|
73 | ) |
---|
74 | |
---|
75 | ; Compute the number of lines in the object and set the line-count slot |
---|
76 | ; If the length is greater than the limit, return (list limit) |
---|
77 | (defun update-line-count (inspector) |
---|
78 | (setf (inspector-line-count inspector) (compute-line-count inspector))) |
---|
79 | |
---|
80 | ; Print the nth line to a stream |
---|
81 | (defmethod prin1-line-n ((i inspector) stream n) |
---|
82 | (multiple-value-call #'prin1-line i stream (line-n i n))) |
---|
83 | |
---|
84 | (defmethod prin1-line ((i inspector) stream value &optional |
---|
85 | label type function) |
---|
86 | (unless function |
---|
87 | (setq function (inspector-print-function i type))) |
---|
88 | (funcall function i stream value label type)) |
---|
89 | |
---|
90 | (defmethod inspector-print-function ((i inspector) type) |
---|
91 | (if (consp type) (setq type (car type))) |
---|
92 | (if (eq type :comment) |
---|
93 | 'prin1-comment |
---|
94 | 'prin1-normal-line)) |
---|
95 | |
---|
96 | |
---|
97 | ; Print a value to a stream. |
---|
98 | (defmethod prin1-normal-line ((i inspector) stream value &optional label type |
---|
99 | colon-p) |
---|
100 | (let* ((type-sym (parse-type i type))) |
---|
101 | (if (eq type-sym :colon) (setq colon-p t)) |
---|
102 | (when label |
---|
103 | (prin1-label i stream value label type) |
---|
104 | (if colon-p (princ ": " stream))) |
---|
105 | (end-of-label stream) ; used by cacheing code |
---|
106 | (prin1-value i stream value label type))) |
---|
107 | |
---|
108 | (defun prin1-colon-line (i stream value &optional label type) |
---|
109 | (prin1-normal-line i stream value label type t)) |
---|
110 | |
---|
111 | (defmethod prin1-label ((i inspector) stream value &optional label type) |
---|
112 | (declare (ignore value type)) |
---|
113 | (if (stringp label) |
---|
114 | (write-string label stream) |
---|
115 | (princ label stream))) |
---|
116 | |
---|
117 | (defmethod prin1-value ((i inspector) stream value &optional label type) |
---|
118 | (declare (ignore label type)) |
---|
119 | (prin1 value stream)) |
---|
120 | |
---|
121 | (defmethod prin1-comment ((i inspector) stream value &optional label type) |
---|
122 | (when label |
---|
123 | (prin1-label i stream value label type) |
---|
124 | (end-of-label stream))) |
---|
125 | |
---|
126 | ;;; Call function on the inspector object and its value, label, & type, for |
---|
127 | ;;; each line in the selected range (default to the whole thing). |
---|
128 | ;;; This can avoid (e.g.) doing NTH for each element of a list. |
---|
129 | ;;; This is the generic-function which the inspector-window uses to |
---|
130 | ;;; display a screenful. |
---|
131 | (defmethod map-lines ((i inspector) function &optional |
---|
132 | (start 0) |
---|
133 | end) |
---|
134 | (unless end |
---|
135 | (setq end (inspector-line-count i))) |
---|
136 | (when (and start end) |
---|
137 | (let ((index start)) |
---|
138 | (dotimes (c (- end start)) |
---|
139 | (declare (fixnum c)) |
---|
140 | (multiple-value-call function i (line-n i index)) |
---|
141 | (incf index))))) |
---|
142 | |
---|
143 | ;;;;;;; |
---|
144 | ;;; |
---|
145 | ;;; Dealing with unbound slots and bogus objects |
---|
146 | ;;; |
---|
147 | (defclass unbound-marker () ()) |
---|
148 | |
---|
149 | (defvar *unbound-marker* (make-instance 'unbound-marker)) |
---|
150 | (defvar *slot-unbound-marker* (make-instance 'unbound-marker)) |
---|
151 | |
---|
152 | (defmethod print-object ((x unbound-marker) stream) |
---|
153 | (print-object (ccl::%unbound-marker) stream)) |
---|
154 | |
---|
155 | (defclass bogus-object-wrapper () |
---|
156 | ((address :initarg :address))) |
---|
157 | |
---|
158 | (defmethod print-object ((x bogus-object-wrapper) stream) |
---|
159 | (print-unreadable-object (x stream) |
---|
160 | (format stream "BOGUS object @ #x~x" (slot-value x 'address)))) |
---|
161 | |
---|
162 | (defvar *bogus-object-hash* |
---|
163 | (make-hash-table :test 'eql :weak :value :size 0)) |
---|
164 | |
---|
165 | (defun bogus-object-wrapper (x) |
---|
166 | (let ((address (%address-of x))) |
---|
167 | (or (gethash address *bogus-object-hash*) |
---|
168 | (setf (gethash address *bogus-object-hash*) |
---|
169 | (make-instance 'bogus-object-wrapper :address address))))) |
---|
170 | |
---|
171 | (defun eliminate-unbound (x) |
---|
172 | (cond ((eq x (ccl::%unbound-marker)) |
---|
173 | *unbound-marker*) |
---|
174 | ((eq x (ccl::%slot-unbound-marker)) |
---|
175 | *slot-unbound-marker*) |
---|
176 | ((ccl::bogus-thing-p x) |
---|
177 | (bogus-object-wrapper x)) |
---|
178 | (t x))) |
---|
179 | |
---|
180 | (defun restore-unbound (x) |
---|
181 | (if (eq x *unbound-marker*) |
---|
182 | (ccl::%unbound-marker) |
---|
183 | (if (eq x *slot-unbound-marker*) |
---|
184 | (ccl::%slot-unbound-marker) |
---|
185 | x))) |
---|
186 | |
---|
187 | (defmethod line-n :around ((i inspector) n) |
---|
188 | (declare (ignore n)) |
---|
189 | (let ((res (multiple-value-list (call-next-method)))) |
---|
190 | (declare (dynamic-extent res)) |
---|
191 | (apply #'values (eliminate-unbound (car res)) (cdr res)))) |
---|
192 | |
---|
193 | (defmethod (setf line-n) :around (new-value (i inspector) n) |
---|
194 | (call-next-method (restore-unbound new-value) i n)) |
---|
195 | |
---|
196 | |
---|
197 | ;;;;;;; |
---|
198 | ;;; |
---|
199 | ;;; describe-object |
---|
200 | ;;; Eventually, this wants to reuse a global inspector rather than |
---|
201 | ;;; consing one. |
---|
202 | (defparameter *describe-pretty* t) |
---|
203 | |
---|
204 | (defmacro with-errorfree-printing (&body body) |
---|
205 | `(let ((*print-readably* nil) |
---|
206 | (*signal-printing-errors* nil)) |
---|
207 | ,@body)) |
---|
208 | |
---|
209 | (defun describe (object &optional stream) |
---|
210 | "Print a description of the object X." |
---|
211 | (cond ((null stream) (setq stream *standard-output*)) |
---|
212 | ((eq stream t) (setq stream *terminal-io*))) |
---|
213 | (setq stream (require-type stream 'stream)) |
---|
214 | (let* ((*print-circle* t) |
---|
215 | (*print-length* 20)) |
---|
216 | (describe-object object stream) |
---|
217 | (values))) |
---|
218 | |
---|
219 | (defmethod describe-object (object stream) |
---|
220 | (let ((inspector (make-inspector object))) |
---|
221 | (when (null (inspector-line-count inspector)) |
---|
222 | (update-line-count inspector)) |
---|
223 | (with-errorfree-printing |
---|
224 | (let* ((*print-pretty* (or *print-pretty* *describe-pretty*)) |
---|
225 | (temp #'(lambda (i value &rest rest) |
---|
226 | (declare (dynamic-extent rest)) |
---|
227 | (apply #'prin1-line i stream value rest) |
---|
228 | (terpri stream)))) |
---|
229 | (declare (dynamic-extent temp)) |
---|
230 | (map-lines inspector temp)))) |
---|
231 | (values)) |
---|
232 | |
---|
233 | ;;; usual-inspector |
---|
234 | ;;; Objects that know how to inspect themselves but don't need any |
---|
235 | ;;; special info other than the object can be a usual-inspector. |
---|
236 | ;;; This class exists mostly to save consing a class for every type |
---|
237 | ;;; of object in the world. |
---|
238 | (defclass usual-inspector (inspector) |
---|
239 | ()) |
---|
240 | |
---|
241 | ;;;;;;; |
---|
242 | ;; |
---|
243 | ;; formatting-inspector |
---|
244 | ;; This one prints using a format string. |
---|
245 | ;; Expects line-n to return (values value label type format-string) |
---|
246 | |
---|
247 | (defclass formatting-inspector (inspector) ()) |
---|
248 | (defclass usual-formatting-inspector (usual-inspector formatting-inspector) ()) |
---|
249 | |
---|
250 | (defmethod prin1-line ((i formatting-inspector) stream value |
---|
251 | &optional label type (format-string "~s")) |
---|
252 | (if (eq :comment (if (consp type) (car type) type)) |
---|
253 | (prin1-comment i stream value label type) |
---|
254 | (funcall (if (listp format-string) #'apply #'funcall) |
---|
255 | #'format-normal-line i stream value label type format-string))) |
---|
256 | |
---|
257 | (defmethod format-normal-line ((i inspector) stream value &optional |
---|
258 | label type (format-string "~s") colon-p) |
---|
259 | (let* ((type-sym (parse-type i type))) |
---|
260 | (if (eq type-sym :colon) (setq colon-p t)) |
---|
261 | (when label |
---|
262 | (if (stringp label) |
---|
263 | (write-string label stream) |
---|
264 | (princ label stream)) |
---|
265 | (if colon-p (princ ": " stream))) |
---|
266 | (end-of-label stream) ; used by cacheing code |
---|
267 | (format stream format-string value))) |
---|
268 | |
---|
269 | ;;;;;;; |
---|
270 | ;; |
---|
271 | ;; inspectors for CCL objects |
---|
272 | ;; |
---|
273 | |
---|
274 | |
---|
275 | (defmethod parse-type ((i inspector) type &optional default1 default2) |
---|
276 | (declare (ignore default1 default2)) |
---|
277 | (values (if (consp type) (car type) type))) |
---|
278 | |
---|
279 | ;;; Used by the cache-entry-stream class to save the column where the label ends. |
---|
280 | (defmethod end-of-label (stream) |
---|
281 | (declare (ignore stream))) |
---|
282 | |
---|
283 | |
---|
284 | |
---|
285 | ;;;;; |
---|
286 | ;; |
---|
287 | ;; The default inspector class |
---|
288 | ;; Used when we don't know what else to do |
---|
289 | ;; |
---|
290 | |
---|
291 | (defclass basic-inspector (inspector) ()) |
---|
292 | |
---|
293 | (defmethod compute-line-count ((i basic-inspector)) |
---|
294 | 3) ; type, class, value |
---|
295 | |
---|
296 | (defun line-n-out-of-range (i n) |
---|
297 | (error "~s is not a valid index for line-n of ~s" n i)) |
---|
298 | |
---|
299 | (defun setf-line-n-out-of-range (i n) |
---|
300 | (error "~s is not a valid index for setf-line-n of ~s" n i)) |
---|
301 | |
---|
302 | (defmethod line-n ((i basic-inspector) n) |
---|
303 | (let ((object (inspector-object i))) |
---|
304 | (case n |
---|
305 | (0 (values object nil :static)) |
---|
306 | (1 (values (type-of object) "Type: " :static)) |
---|
307 | (2 (values (class-of object) "Class: " :static)) |
---|
308 | (t (line-n-out-of-range i n))))) |
---|
309 | |
---|
310 | ;;;;;;; |
---|
311 | ;; |
---|
312 | ;; Automate the object being the first line |
---|
313 | ;; |
---|
314 | (defclass object-first-mixin () ()) |
---|
315 | (defclass object-first-inspector (object-first-mixin inspector) ()) |
---|
316 | |
---|
317 | (defmethod compute-line-count :around ((i object-first-mixin)) |
---|
318 | (1+ (call-next-method))) |
---|
319 | |
---|
320 | (defmethod line-n :around ((i object-first-mixin) n) |
---|
321 | (if (eql 0 n) |
---|
322 | (values (inspector-object i) nil) |
---|
323 | (call-next-method i (1- n)))) |
---|
324 | |
---|
325 | (defmethod (setf line-n) :around (value (i object-first-mixin) n) |
---|
326 | (if (eql n 0) |
---|
327 | (replace-object i value) |
---|
328 | (call-next-method value i (1- n)))) |
---|
329 | |
---|
330 | (defun replace-object (inspector new-object) |
---|
331 | (declare (ignore inspector)) |
---|
332 | (make-inspector new-object)) |
---|
333 | |
---|
334 | |
---|
335 | ; A mixin that displays the object, its type, and its class as the first three lines. |
---|
336 | (defclass basics-first-mixin () ()) |
---|
337 | |
---|
338 | (defmethod compute-line-count :around ((i basics-first-mixin)) |
---|
339 | (+ 3 (call-next-method))) |
---|
340 | |
---|
341 | (defmethod line-n :around ((i basics-first-mixin) n) |
---|
342 | (let ((object (inspector-object i))) |
---|
343 | (case n |
---|
344 | (0 (values object nil)) |
---|
345 | (1 (values (type-of object) "Type: " :static)) |
---|
346 | (2 (values (class-of object) "Class: " :static)) |
---|
347 | (t (call-next-method i (- n 3)))))) |
---|
348 | |
---|
349 | (defmethod (setf line-n) :around (new-value (i basics-first-mixin) n) |
---|
350 | (case n |
---|
351 | (0 (replace-object i new-value)) |
---|
352 | ((1 2) (setf-line-n-out-of-range i n)) |
---|
353 | (t (call-next-method new-value i (- n 3))))) |
---|
354 | |
---|
355 | ;;;;;;; |
---|
356 | ;; |
---|
357 | (defclass usual-object-first-inspector (object-first-mixin usual-inspector) |
---|
358 | ()) |
---|
359 | (defclass usual-basics-first-inspector (basics-first-mixin usual-inspector) |
---|
360 | ()) |
---|
361 | |
---|
362 | (defvar *inspector*) |
---|
363 | |
---|
364 | (defmethod compute-line-count ((i usual-inspector)) |
---|
365 | (let ((*inspector* i)) |
---|
366 | (compute-line-count (inspector-object i)))) |
---|
367 | |
---|
368 | (defmethod line-n ((i usual-inspector) n) |
---|
369 | (let ((*inspector* i)) |
---|
370 | (line-n (inspector-object i) n))) |
---|
371 | |
---|
372 | (defmethod (setf line-n) (value (i usual-inspector) n) |
---|
373 | (let ((*inspector* i)) |
---|
374 | (setf (line-n (inspector-object i) n) value))) |
---|
375 | |
---|
376 | (defmethod inspector-commands ((i usual-inspector)) |
---|
377 | (let ((*inspector* i)) |
---|
378 | (inspector-commands (inspector-object i)))) |
---|
379 | |
---|
380 | (defmethod inspector-commands (random) |
---|
381 | (declare (ignore random)) |
---|
382 | nil) |
---|
383 | |
---|
384 | ;;;;;;; |
---|
385 | ;; |
---|
386 | ;; Bogus objects |
---|
387 | ;; |
---|
388 | |
---|
389 | (defclass bogus-object-inspector (object-first-inspector) |
---|
390 | ()) |
---|
391 | |
---|
392 | (defmethod compute-line-count ((i bogus-object-inspector)) |
---|
393 | 3) |
---|
394 | |
---|
395 | (defmethod line-n ((i bogus-object-inspector) n) |
---|
396 | (values |
---|
397 | nil |
---|
398 | (case n |
---|
399 | (0 "One cause of a bogus object is when a stack consed object is stored") |
---|
400 | (1 "in a register and then control exits the dynamic-extent of the object.") |
---|
401 | (2 "The compiler doesn't bother to clear the register since it won't be used again.")) |
---|
402 | '(:comment :plain :plain))) |
---|
403 | |
---|
404 | (defmethod inspector-class :around (object) |
---|
405 | (if (ccl::bogus-thing-p object) |
---|
406 | 'bogus-object-inspector |
---|
407 | (call-next-method))) |
---|
408 | |
---|
409 | ;;;;;;; |
---|
410 | ;; |
---|
411 | ;; A general sequence inspector |
---|
412 | ;; |
---|
413 | (defclass sequence-inspector (inspector) |
---|
414 | ((print-function :initarg :print-function :initform #'prin1 :reader print-function) |
---|
415 | (commands :initarg :commands :initform nil :accessor inspector-commands) |
---|
416 | (line-n-inspector :initform nil :initarg :line-n-inspector |
---|
417 | :accessor line-n-inspector-function) |
---|
418 | (replace-object-p :initform nil :initarg :replace-object-p |
---|
419 | :reader replace-object-p) |
---|
420 | (resample-function :initform nil :initarg :resample-function |
---|
421 | :reader resample-function) |
---|
422 | (line-n-function :initform nil :initarg :line-n-function |
---|
423 | :reader line-n-function) |
---|
424 | (setf-line-n-p :initform t :initarg :setf-line-n-p |
---|
425 | :reader setf-line-n-p)) |
---|
426 | (:default-initargs :update-line-count t)) |
---|
427 | |
---|
428 | |
---|
429 | |
---|
430 | (defmethod compute-line-count ((i sequence-inspector)) |
---|
431 | (let ((resample-function (resample-function i))) |
---|
432 | (when resample-function |
---|
433 | (setf (inspector-object i) (funcall resample-function i)))) |
---|
434 | (length (inspector-object i))) |
---|
435 | |
---|
436 | (defmethod line-n ((i sequence-inspector) n) |
---|
437 | (let ((f (line-n-function i))) |
---|
438 | (if f |
---|
439 | (funcall f i n) |
---|
440 | (values (elt (inspector-object i) n) nil (unless (setf-line-n-p i) :static))))) |
---|
441 | |
---|
442 | (defmethod (setf line-n) (new-value (i sequence-inspector) n) |
---|
443 | (if (setf-line-n-p i) |
---|
444 | (setf (elt (inspector-object i) n) new-value) |
---|
445 | (setf-line-n-out-of-range i n))) |
---|
446 | |
---|
447 | (defmethod prin1-value ((inspector sequence-inspector) stream value |
---|
448 | &optional label type) |
---|
449 | (declare (ignore label type)) |
---|
450 | (funcall (print-function inspector) value stream)) |
---|
451 | |
---|
452 | (defmethod line-n-inspector ((i sequence-inspector) n value label type) |
---|
453 | (let ((f (line-n-inspector-function i))) |
---|
454 | (or (and f (funcall f i n value label type)) (call-next-method)))) |
---|
455 | |
---|
456 | ;;;;;;; |
---|
457 | ;; |
---|
458 | ;; standard-object |
---|
459 | ;; This should be redone to use the exported class query functions |
---|
460 | ;; (as soon as they exist) |
---|
461 | ;; |
---|
462 | (defclass standard-object-inspector (object-first-inspector) |
---|
463 | ()) |
---|
464 | |
---|
465 | (defmethod inspector-class ((o standard-object)) |
---|
466 | 'standard-object-inspector) |
---|
467 | |
---|
468 | (defmethod compute-line-count ((i standard-object-inspector)) |
---|
469 | (standard-object-compute-line-count i)) |
---|
470 | |
---|
471 | (defun standard-object-compute-line-count (i) |
---|
472 | (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i))) |
---|
473 | (class (class-of object))) |
---|
474 | (multiple-value-bind (instance-slots class-slots) (ccl::extract-instance-and-class-slotds (ccl::class-slots class)) |
---|
475 | (let* ((ninstance-slots (length instance-slots)) |
---|
476 | (nclass-slots (length class-slots))) |
---|
477 | (+ 2 ; class, wrapper |
---|
478 | (if (eql 0 ninstance-slots) |
---|
479 | 0 |
---|
480 | (1+ ninstance-slots)) |
---|
481 | (if (eql 0 nclass-slots) |
---|
482 | 0 |
---|
483 | (1+ nclass-slots)) |
---|
484 | (if (eql 0 (+ nclass-slots ninstance-slots)) |
---|
485 | 1 |
---|
486 | 0)))))) |
---|
487 | |
---|
488 | (defun slot-value-or-unbound (instance slot-name) |
---|
489 | (eliminate-unbound (ccl::slot-value-if-bound instance slot-name |
---|
490 | (ccl::%slot-unbound-marker)))) |
---|
491 | |
---|
492 | (defparameter *standard-object-type* (list nil)) |
---|
493 | (defparameter *standard-object-static-type* |
---|
494 | (cons :static (cdr *standard-object-type*))) |
---|
495 | (defparameter *standard-object-comment-type* |
---|
496 | (list :comment)) |
---|
497 | |
---|
498 | (defmethod line-n ((i standard-object-inspector) n) |
---|
499 | (standard-object-line-n i n)) |
---|
500 | |
---|
501 | (defmethod prin1-label ((i standard-object-inspector) stream value &optional label type) |
---|
502 | (declare (ignore value type)) |
---|
503 | (if (symbolp label) |
---|
504 | (prin1 label stream) |
---|
505 | (call-next-method))) |
---|
506 | |
---|
507 | ; Looks like |
---|
508 | ; Class: |
---|
509 | ; Wrapper: |
---|
510 | ; [Instance slots: |
---|
511 | ; slots...] |
---|
512 | ; [Class slots: |
---|
513 | ; slots...] |
---|
514 | (defun standard-object-line-n (i n) |
---|
515 | (let* ((instance (inspector-object i)) |
---|
516 | (class (class-of instance)) |
---|
517 | (wrapper (or (ccl::standard-object-p instance) |
---|
518 | (if (typep instance 'ccl::funcallable-standard-object) |
---|
519 | (ccl::gf.instance.class-wrapper instance)))) |
---|
520 | (instance-start 2)) |
---|
521 | (if (< n instance-start) |
---|
522 | (if (eql n 0) |
---|
523 | (values class "Class: " :normal) |
---|
524 | (values wrapper "Wrapper: " :static)) |
---|
525 | (let* ((slotds (ccl::extract-instance-effective-slotds class)) |
---|
526 | (instance-count (length slotds)) |
---|
527 | (shared-start (+ instance-start instance-count |
---|
528 | (if (eql 0 instance-count) 0 1)))) |
---|
529 | (if (< n shared-start) |
---|
530 | (if (eql n instance-start) |
---|
531 | (values nil "Instance slots" :comment) |
---|
532 | (let ((slot-name (slot-definition-name |
---|
533 | (elt slotds (- n instance-start 1))))) |
---|
534 | (values (slot-value-or-unbound instance slot-name) |
---|
535 | slot-name |
---|
536 | :colon))) |
---|
537 | (let* ((slotds (ccl::extract-class-effective-slotds class)) |
---|
538 | (shared-count (length slotds)) |
---|
539 | (shared-end (+ shared-start shared-count |
---|
540 | (if (eql shared-count 0) 0 1)))) |
---|
541 | (if (< n shared-end) |
---|
542 | (if (eql n shared-start) |
---|
543 | (values nil "Class slots" :comment) |
---|
544 | (let ((slot-name (slot-definition-name |
---|
545 | (elt slotds (- n shared-start 1))))) |
---|
546 | (values (slot-value-or-unbound instance slot-name) |
---|
547 | slot-name |
---|
548 | :colon))) |
---|
549 | (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end)) |
---|
550 | (values nil "No Slots" :comment) |
---|
551 | (line-n-out-of-range i n))))))))) |
---|
552 | |
---|
553 | (defmethod (setf line-n) (value (i standard-object-inspector) n) |
---|
554 | (standard-object-setf-line-n value i n)) |
---|
555 | |
---|
556 | (defun standard-object-setf-line-n (value i n) |
---|
557 | (let* ((instance (inspector-object i)) |
---|
558 | (class (class-of instance)) |
---|
559 | (instance-start 2)) |
---|
560 | (if (< n instance-start) |
---|
561 | (cond |
---|
562 | ((eql n 0) (change-class instance value) |
---|
563 | (update-line-count i)) |
---|
564 | (t (setf-line-n-out-of-range i n))) |
---|
565 | (let* ((slotds (ccl::extract-instance-effective-slotds class)) |
---|
566 | (instance-count (length slotds)) |
---|
567 | (shared-start (+ instance-start instance-count |
---|
568 | (if (eql 0 instance-count) 0 1)))) |
---|
569 | (if (< n shared-start) |
---|
570 | (if (eql n instance-start) |
---|
571 | (setf-line-n-out-of-range i n) |
---|
572 | (let ((slot-name (slot-definition-name |
---|
573 | (elt slotds (- n instance-start 1))))) |
---|
574 | (setf (slot-value instance slot-name) (restore-unbound value)))) |
---|
575 | (let* ((slotds (ccl::extract-class-effective-slotds class)) |
---|
576 | (shared-count (length slotds)) |
---|
577 | (shared-end (+ shared-start shared-count |
---|
578 | (if (eql shared-count 0) 0 1)))) |
---|
579 | (if (< n shared-end) |
---|
580 | (if (eql n shared-start) |
---|
581 | (setf-line-n-out-of-range i n) |
---|
582 | (let ((slot-name (slot-definition-name |
---|
583 | (elt slotds (- n shared-start 1))))) |
---|
584 | (setf (slot-value instance slot-name) |
---|
585 | (restore-unbound value)))) |
---|
586 | (setf-line-n-out-of-range i n)))))))) |
---|
587 | |
---|
588 | |
---|
589 | ;;;;;;;;;;; Inspector objects for common classes. |
---|
590 | |
---|
591 | (defparameter *plain-comment-type* '(:comment (:plain))) |
---|
592 | (defparameter *bold-comment-type* '(:comment (:bold))) |
---|
593 | |
---|
594 | (defun resample-it () |
---|
595 | ) |
---|
596 | |
---|
597 | ;;;;;;; |
---|
598 | ;; |
---|
599 | ;; Lists |
---|
600 | ;; |
---|
601 | (defclass cons-inspector (basics-first-mixin inspector) ()) |
---|
602 | |
---|
603 | (defclass list-inspector (basics-first-mixin inspector) |
---|
604 | ((length :accessor list-inspector-length) |
---|
605 | (dotted-p :accessor list-inspector-dotted-p) |
---|
606 | (nthcdr :accessor list-inspector-nthcdr) |
---|
607 | (n :accessor list-inspector-n))) |
---|
608 | |
---|
609 | (defmethod inspector-class ((o list)) |
---|
610 | (if (listp (cdr o)) |
---|
611 | 'list-inspector |
---|
612 | 'cons-inspector)) |
---|
613 | |
---|
614 | ; Same as list-length-and-final-cdr, but computes the real length of the list |
---|
615 | (defun real-list-length (list) |
---|
616 | (multiple-value-bind (len final-cdr max-circ-len) |
---|
617 | (ccl::list-length-and-final-cdr list) |
---|
618 | (if (null max-circ-len) |
---|
619 | (values len final-cdr nil) |
---|
620 | (let ((middle (nthcdr max-circ-len list)) |
---|
621 | (n 1)) |
---|
622 | (loop (when (eq list middle) (return)) |
---|
623 | (pop list) |
---|
624 | (incf n)) |
---|
625 | (pop list) |
---|
626 | (loop (when (eq list middle) (return)) |
---|
627 | (pop list) |
---|
628 | (incf n)) |
---|
629 | (values nil nil n))))) |
---|
630 | |
---|
631 | (defmethod compute-line-count ((i list-inspector)) |
---|
632 | (multiple-value-bind (len final-cdr circ-len) (real-list-length (inspector-object i)) |
---|
633 | (setf (list-inspector-dotted-p i) final-cdr) |
---|
634 | (setf (list-inspector-nthcdr i) (inspector-object i)) |
---|
635 | (setf (list-inspector-n i) 0) |
---|
636 | (+ 1 ; regular, dotted, or circular |
---|
637 | 1 ; length |
---|
638 | (abs (setf (list-inspector-length i) |
---|
639 | (or len (- circ-len)))) ; the elements |
---|
640 | (if final-cdr 2 0)))) ; the final-cdr and it's label |
---|
641 | |
---|
642 | (defmethod compute-line-count ((i cons-inspector)) |
---|
643 | 2) ; car & cdr |
---|
644 | |
---|
645 | (defmethod line-n ((i list-inspector) en &aux (n en)) |
---|
646 | (let* ((circ? (list-inspector-length i)) |
---|
647 | (length (abs circ?))) |
---|
648 | (cond ((eql 0 n) |
---|
649 | (values nil (cond ((list-inspector-dotted-p i) "Dotted List") |
---|
650 | ((< circ? 0) "Circular List") |
---|
651 | (t "Normal List")) |
---|
652 | *plain-comment-type*)) |
---|
653 | ((eql 0 (decf n)) (values length "Length: ")) |
---|
654 | ((>= (decf n) (setq length length)) ; end of dotted list |
---|
655 | (let ((final-cdr (list-inspector-dotted-p i))) |
---|
656 | (unless final-cdr (line-n-out-of-range i en)) |
---|
657 | (if (eql n length) |
---|
658 | (values nil "Non-nil final cdr" *plain-comment-type*) |
---|
659 | (values final-cdr (- length 0.5) :colon)))) |
---|
660 | (t (let* ((saved-n (list-inspector-n i)) |
---|
661 | (nthcdr (if (>= n saved-n) |
---|
662 | (nthcdr (- n saved-n) (list-inspector-nthcdr i)) |
---|
663 | (nthcdr n (inspector-object i))))) |
---|
664 | (setf (list-inspector-nthcdr i) nthcdr |
---|
665 | (list-inspector-n i) n) |
---|
666 | (values (car nthcdr) n :colon)))))) |
---|
667 | |
---|
668 | (defmethod line-n ((i cons-inspector) n) |
---|
669 | (let ((object (inspector-object i))) |
---|
670 | (ecase n |
---|
671 | (0 (values (car object) "Car: ")) |
---|
672 | (1 (values (cdr object) "Cdr: "))))) |
---|
673 | |
---|
674 | (defmethod (setf line-n) (value (i list-inspector) n) |
---|
675 | (when (< n 2) |
---|
676 | (setf-line-n-out-of-range i n)) |
---|
677 | (decf n 2) |
---|
678 | (setf (elt (inspector-object i) n) value) |
---|
679 | (resample-it)) |
---|
680 | |
---|
681 | (defmethod (setf line-n) (value (i cons-inspector) n) |
---|
682 | (let ((object (inspector-object i))) |
---|
683 | (ecase n |
---|
684 | (0 (setf (car object) value)) |
---|
685 | (1 (setf (cdr object) value)))) |
---|
686 | (resample-it)) |
---|
687 | |
---|
688 | ;;;;;;; |
---|
689 | ;; |
---|
690 | ;; General uvector's |
---|
691 | ;; |
---|
692 | (defclass uvector-inspector (basics-first-mixin inspector) |
---|
693 | ((name-list :initarg :name-list :initform nil :accessor name-list))) |
---|
694 | |
---|
695 | (defmethod uvector-name-list (object) |
---|
696 | (let* ((type (type-of object)) |
---|
697 | (names (cdr (assq type ccl::*def-accessor-types*))) |
---|
698 | (names-size (length names)) |
---|
699 | res) |
---|
700 | (when names |
---|
701 | (dotimes (i (uvsize object)) |
---|
702 | (declare (fixnum i)) |
---|
703 | (let ((name (and (> names-size i) (aref names i)))) |
---|
704 | (if name |
---|
705 | (push (if (listp name) (car name) name) res) |
---|
706 | (if (and (eql i 0) (typep object 'ccl::internal-structure)) |
---|
707 | (push 'type res) |
---|
708 | (push i res))))) |
---|
709 | (nreverse res)))) |
---|
710 | |
---|
711 | (defmethod compute-line-count ((i uvector-inspector)) |
---|
712 | (setf (name-list i) (uvector-name-list (inspector-object i))) |
---|
713 | (uvsize (inspector-object i))) |
---|
714 | |
---|
715 | (defmethod line-n ((i uvector-inspector) n) |
---|
716 | (values (uvref (inspector-object i) n) |
---|
717 | (or (let ((name-list (name-list i))) (and name-list (nth n (name-list i)))) |
---|
718 | n) |
---|
719 | :colon)) |
---|
720 | |
---|
721 | (defmethod (setf line-n) (new-value (i uvector-inspector) n) |
---|
722 | (setf (uvref (inspector-object i) n) new-value)) |
---|
723 | |
---|
724 | (defmethod inspector-commands ((i uvector-inspector)) |
---|
725 | (let ((object (inspector-object i))) |
---|
726 | (if (method-exists-p #'inspector-commands object) |
---|
727 | (inspector-commands object)))) |
---|
728 | |
---|
729 | ;;;;;;; |
---|
730 | ;; |
---|
731 | ;; Vectors & Arrays |
---|
732 | ;; |
---|
733 | (defmethod inspector-class ((v ccl::simple-1d-array)) |
---|
734 | 'usual-basics-first-inspector) |
---|
735 | |
---|
736 | (defmethod compute-line-count ((v ccl::simple-1d-array)) |
---|
737 | (+ 1 (length v))) |
---|
738 | |
---|
739 | (defmethod line-n ((v ccl::simple-1d-array) n) |
---|
740 | (cond ((eql 0 n) (values (length v) "Length" :static 'prin1-colon-line)) |
---|
741 | (t (decf n 1) |
---|
742 | (values (aref v n) n :colon)))) |
---|
743 | |
---|
744 | (defmethod (setf line-n) (value (v ccl::simple-1d-array) n) |
---|
745 | (when (<= n 0) |
---|
746 | (setf-line-n-out-of-range v n)) |
---|
747 | (decf n 1) |
---|
748 | (prog1 (setf (aref v n) value) |
---|
749 | (resample-it))) |
---|
750 | |
---|
751 | (defclass array-inspector (uvector-inspector) ()) |
---|
752 | |
---|
753 | (defmethod inspector-class ((v array)) |
---|
754 | 'array-inspector) |
---|
755 | |
---|
756 | (defmethod uvector-name-list ((a array)) |
---|
757 | (if (eql 1 (array-rank a)) |
---|
758 | (if (array-has-fill-pointer-p a) |
---|
759 | '("Fill Pointer" "Physical size" "Data vector" "Displacement" "Flags") |
---|
760 | '("Logical size" "Physical size" "Data vector" "Displacement" "Flags")) |
---|
761 | `("Rank" "Physical size" "Data vector" "Displacement" "Flags" "Dim0" "Dim1" "Dim2" "Dim3"))) |
---|
762 | |
---|
763 | (defmethod compute-line-count ((i array-inspector)) |
---|
764 | (let* ((a (inspector-object i)) |
---|
765 | (rank (array-rank a))) |
---|
766 | (call-next-method) ; calculate name list |
---|
767 | (+ (if (eql rank 1) (1+ (uvsize a)) 7) |
---|
768 | (apply #'* (array-dimensions a))))) |
---|
769 | |
---|
770 | (defmethod line-n ((i array-inspector) n) |
---|
771 | (let* ((v (inspector-object i)) |
---|
772 | (rank (array-rank v)) |
---|
773 | (uvsize (if (eql rank 1) |
---|
774 | (+ (uvsize v) 1) |
---|
775 | 7))) |
---|
776 | (cond ((eql 0 n) (values (array-element-type v) |
---|
777 | (if (adjustable-array-p v) |
---|
778 | "Adjustable, Element type" |
---|
779 | "Element type") |
---|
780 | :static 'prin1-colon-line)) |
---|
781 | ((eql 5 n) |
---|
782 | (values (uvref v target::vectorH.flags-cell) |
---|
783 | "Flags: " |
---|
784 | :static |
---|
785 | #'(lambda (i s v l type) |
---|
786 | (format-normal-line i s v l type "#x~x")))) |
---|
787 | ((and (eql 6 n) (not (eql rank 1))) |
---|
788 | (values (array-dimensions v) "Dimensions: " :static)) |
---|
789 | ((< n uvsize) (call-next-method i (1- n))) |
---|
790 | (t (let ((index (- n uvsize))) |
---|
791 | (values (row-major-aref v index) (array-indices v index) :colon)))))) |
---|
792 | |
---|
793 | (defmethod (setf line-n) (new-value (i array-inspector) n) |
---|
794 | (let* ((v (inspector-object i)) |
---|
795 | (rank (array-rank v)) |
---|
796 | (uvsize (if (eql rank 1) |
---|
797 | (+ (uvsize v) 1) |
---|
798 | 7))) |
---|
799 | (prog1 |
---|
800 | (cond ((or (eql 0 n) (eql 1 n) (and (eql 4 n) (not (eql rank 1)))) |
---|
801 | (setf-line-n-out-of-range i n)) |
---|
802 | ((< n uvsize) |
---|
803 | (if (eql 3 n) |
---|
804 | (setq new-value (require-type new-value 'array)) |
---|
805 | (setq new-value (require-type new-value 'fixnum))) |
---|
806 | (call-next-method new-value i (1- n))) |
---|
807 | (t (let ((index (- n uvsize))) |
---|
808 | (setf (row-major-aref v index) new-value)))) |
---|
809 | (resample-it)))) |
---|
810 | |
---|
811 | (defun array-indices (a row-major-index) |
---|
812 | (let ((rank (array-rank a))) |
---|
813 | (if (eql 1 rank) |
---|
814 | row-major-index |
---|
815 | (let ((res nil) |
---|
816 | dim |
---|
817 | (dividend row-major-index) |
---|
818 | remainder) |
---|
819 | (loop |
---|
820 | (when (zerop rank) (return res)) |
---|
821 | (setq dim (array-dimension a (decf rank))) |
---|
822 | (multiple-value-setq (dividend remainder) (floor dividend dim)) |
---|
823 | (push remainder res)))))) |
---|
824 | |
---|
825 | (defmethod prin1-line ((i array-inspector) stream value &optional |
---|
826 | label type function) |
---|
827 | (declare (ignore stream value type function)) |
---|
828 | (if (or (numberp label) (listp label)) ; First line or contents lines |
---|
829 | (call-next-method) |
---|
830 | (let ((*print-array* nil)) |
---|
831 | (call-next-method)))) |
---|
832 | |
---|
833 | ;;;;;;; |
---|
834 | ;; |
---|
835 | ;; Numbers |
---|
836 | ;; |
---|
837 | (defmethod inspector-class ((num number)) 'usual-formatting-inspector) |
---|
838 | |
---|
839 | ; floats |
---|
840 | (defmethod compute-line-count ((num float)) 5) |
---|
841 | |
---|
842 | (defmethod line-n ((num float) n) |
---|
843 | (let ((type :static)) |
---|
844 | (ecase n |
---|
845 | (0 (values num "Float: " type)) |
---|
846 | (1 (values num "Scientific: " type |
---|
847 | (if (< num 0) "~8,2e" "~7,2e"))) |
---|
848 | (2 (values (if (zerop num) "illegal" (log num 2)) |
---|
849 | "Log base 2: " type "~d")) |
---|
850 | (3 (values (rationalize num) |
---|
851 | "Ratio equiv: " type)) |
---|
852 | (4 (values (round num) |
---|
853 | "Nearest integer: " type))))) |
---|
854 | |
---|
855 | ; complex numbers |
---|
856 | (defmethod compute-line-count ((num complex)) 3) |
---|
857 | |
---|
858 | (defmethod line-n ((num complex) n) |
---|
859 | (let ((type :static)) |
---|
860 | (ecase n |
---|
861 | (0 (values num "Complex num: " type)) |
---|
862 | (1 (values (realpart num) "Real part: " type)) |
---|
863 | (2 (values (imagpart num) "Imaginary part: " type))))) |
---|
864 | |
---|
865 | ; ratios |
---|
866 | (defmethod compute-line-count ((num ratio)) 6) |
---|
867 | |
---|
868 | (defmethod line-n ((num ratio) n) |
---|
869 | (let ((type :static)) |
---|
870 | (ecase n |
---|
871 | (0 (values num "Ratio: " type)) |
---|
872 | (1 (values (float num) "Scientific: " type |
---|
873 | (if (< num 0) "~8,2e" "~7,2E"))) |
---|
874 | (2 (values (if (zerop num) "illegal" (log num 2)) |
---|
875 | "Log base 2: " type "~d")) |
---|
876 | (3 (values (round num) "Nearest integer: " type)) |
---|
877 | (4 (values (numerator num) "Numerator: " type)) |
---|
878 | (5 (values (denominator num) "Denominator: " type))))) |
---|
879 | |
---|
880 | ; integers |
---|
881 | (defmethod compute-line-count ((num integer)) |
---|
882 | (let ((res 12)) |
---|
883 | (unless (< 0 num 4000) (decf res)) ; not a roman number |
---|
884 | (unless (<= 0 num 255) (decf res)) ; not a character |
---|
885 | res)) |
---|
886 | |
---|
887 | (defmethod line-n ((num integer) n) |
---|
888 | (if (and (>= n 7) (not (< 0 num 4000))) (incf n)) ; maybe skip roman. |
---|
889 | (if (and (>= n 8) (not (<= 0 num 255))) (incf n)) ; maybe skip character. |
---|
890 | (let* ((type :static) |
---|
891 | (neg? (< num 0)) |
---|
892 | (norm (if neg? |
---|
893 | (+ num (expt 2 (max 32 (* 4 (round (+ (integer-length num) 4) 4))))) |
---|
894 | num))) |
---|
895 | (ecase n |
---|
896 | (0 (values num |
---|
897 | (if (fixnump num) |
---|
898 | "Fixnum: " |
---|
899 | "Bignum: ") |
---|
900 | type "~s")) |
---|
901 | (1 (let ((num (ignore-errors (float num)))) |
---|
902 | (values num "Scientific: " type |
---|
903 | (cond ((null num) "FLOATING-POINT-OVERFLOW") |
---|
904 | ((< num 0) "~8,2e") |
---|
905 | (t "~7,2e"))))) |
---|
906 | (2 (values (if (zerop num) "illegal" (log num 2)) |
---|
907 | "Log base 2: " type "~d")) |
---|
908 | (3 (values norm |
---|
909 | "Binary: " type |
---|
910 | (if neg? "#b...~b" "#b~b"))) |
---|
911 | (4 (values norm |
---|
912 | "Octal: " type |
---|
913 | (if neg? "#o...~o" "#o~o"))) |
---|
914 | (5 (values num |
---|
915 | "Decimal: " type "~d.")) |
---|
916 | (6 (values norm |
---|
917 | "Hex: " type |
---|
918 | (if neg? "#x...~x" "#x~x"))) |
---|
919 | (7 (values (format nil "~@r" num) |
---|
920 | "Roman: " type "~a")) |
---|
921 | (8 (values (code-char num) |
---|
922 | "Character: " type "~s")) |
---|
923 | (9 (values (ccl::ensure-simple-string (prin1-to-string num)) |
---|
924 | "Abbreviated: " |
---|
925 | type #'format-abbreviated-string)) |
---|
926 | (10 (values (or (ignore-errors (universal-time-string num)) "#<error>") |
---|
927 | "As time: " type "~a")) |
---|
928 | (11 (if (< num 0) |
---|
929 | (values most-negative-fixnum 'most-negative-fixnum type '("~d." t)) |
---|
930 | (values most-positive-fixnum 'most-positive-fixnum type '("~d." t))))))) |
---|
931 | |
---|
932 | (defun format-abbreviated-string (stream string) |
---|
933 | (setq string (require-type string 'simple-string)) |
---|
934 | (let ((length (length string))) |
---|
935 | (if (< length 7) |
---|
936 | (princ string stream) |
---|
937 | (format stream "~a <- ~s digits -> ~a" |
---|
938 | (subseq string 0 3) |
---|
939 | (- length 6) |
---|
940 | (subseq string (- length 3) length))))) |
---|
941 | |
---|
942 | (defun universal-time-string (num) |
---|
943 | (multiple-value-bind (second minute hour date month year day) |
---|
944 | (decode-universal-time num) |
---|
945 | (with-output-to-string (s) |
---|
946 | (format s "~d:~2,'0d:~2,'0d " hour minute second) |
---|
947 | (princ (nth day '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" |
---|
948 | "Saturday" "Sunday")) |
---|
949 | s) |
---|
950 | (format s ", ~d " date) |
---|
951 | (princ (nth month '("" "January" "February" "March" "April" "May" "June" "July" |
---|
952 | "August" "September" "October" "November" "December")) |
---|
953 | s) |
---|
954 | (format s ", ~d" year)))) |
---|
955 | |
---|
956 | ; Characters |
---|
957 | (defmethod compute-line-count ((ch character)) 2) |
---|
958 | |
---|
959 | (defmethod line-n ((ch character) n) |
---|
960 | (let ((type :static)) |
---|
961 | (ecase n |
---|
962 | (0 (values ch "Character: " type)) |
---|
963 | (1 (values (char-code ch) "char-code: " type))))) |
---|
964 | |
---|
965 | ;;;;;;; |
---|
966 | ;; |
---|
967 | ;; Symbols |
---|
968 | ;; |
---|
969 | (defun symbol-has-bindings-p (sym) |
---|
970 | (or (constantp sym) (proclaimed-special-p sym) (boundp sym) |
---|
971 | (special-operator-p sym) (macro-function sym) (fboundp sym) |
---|
972 | (type-specifier-p sym) (record-type-p sym nil) |
---|
973 | (find-class sym nil))) |
---|
974 | |
---|
975 | (defmethod inspector-class ((sym symbol)) 'usual-inspector) |
---|
976 | |
---|
977 | (defmethod compute-line-count ((sym symbol)) |
---|
978 | (+ 1 ; The symbol |
---|
979 | (if (symbol-has-bindings-p sym) 1 0) |
---|
980 | 1 ; package |
---|
981 | 1 ; symbol-name |
---|
982 | 1 ; symbol-value |
---|
983 | 1 ; symbol-function |
---|
984 | (if (fboundp sym) 1 0) ; arglist |
---|
985 | 1 ; plist |
---|
986 | (if (find-class sym nil) 1 0) ; class |
---|
987 | )) |
---|
988 | |
---|
989 | |
---|
990 | (defmethod normalize-line-number ((sym symbol) n) |
---|
991 | (if (and (>= n 1) (not (symbol-has-bindings-p sym))) (incf n)) |
---|
992 | (if (and (>= n 6) (not (fboundp sym))) (incf n)) |
---|
993 | n) |
---|
994 | |
---|
995 | (defmethod line-n ((sym symbol) n) |
---|
996 | (setq n (normalize-line-number sym n)) |
---|
997 | (let ((type :normal) |
---|
998 | (comment '(:comment (:bold))) |
---|
999 | (static :static)) |
---|
1000 | (ecase n |
---|
1001 | (0 (values sym "Symbol: " type)) |
---|
1002 | (1 (values nil (symbol-type-line sym) comment)) |
---|
1003 | (2 (let ((p (symbol-package sym))) |
---|
1004 | (if (null p) |
---|
1005 | (values nil "No home package." comment) |
---|
1006 | (multiple-value-bind (found kind) (find-symbol (symbol-name sym) p) |
---|
1007 | (values p |
---|
1008 | (if (or (null kind) (neq found sym)) |
---|
1009 | "NOT PRESENT in home package: " |
---|
1010 | (format nil "~a in package: " kind)) |
---|
1011 | static))))) |
---|
1012 | (3 (values (symbol-name sym) "Print name: " static)) |
---|
1013 | (4 (values (if (boundp sym) (symbol-value sym) *unbound-marker*) |
---|
1014 | "Value: " type)) |
---|
1015 | (5 (values (if (fboundp sym) |
---|
1016 | (cond ((macro-function sym)) |
---|
1017 | ((special-operator-p sym) sym) |
---|
1018 | (t (symbol-function sym))) |
---|
1019 | *unbound-marker*) |
---|
1020 | "Function: " type)) |
---|
1021 | (6 (values (and (fboundp sym) (arglist sym)) |
---|
1022 | "Arglist: " static)) |
---|
1023 | (7 (values (symbol-plist sym) "Plist: " type)) |
---|
1024 | (8 (values (find-class sym) "Class: " static))))) |
---|
1025 | |
---|
1026 | (defmethod (setf line-n) (value (sym symbol) n) |
---|
1027 | (let (resample-p) |
---|
1028 | (setq n (normalize-line-number sym n)) |
---|
1029 | (setq value (restore-unbound value)) |
---|
1030 | (ecase n |
---|
1031 | (0 (replace-object *inspector* value)) |
---|
1032 | ((1 2 3 6) (setf-line-n-out-of-range sym n)) |
---|
1033 | (4 (setf resample-p (not (boundp sym)) |
---|
1034 | (symbol-value sym) value)) |
---|
1035 | (5 (setf resample-p (not (fboundp sym)) |
---|
1036 | (symbol-function sym) value)) |
---|
1037 | (7 (setf (symbol-plist sym) value))) |
---|
1038 | (when resample-p (resample-it)) |
---|
1039 | value)) |
---|
1040 | |
---|
1041 | (defun record-type-p (name &optional check-database) |
---|
1042 | (declare (ignore check-database)) |
---|
1043 | (and (keywordp name) |
---|
1044 | (ignore-errors (ccl::%foreign-type-or-record name)))) |
---|
1045 | |
---|
1046 | ; Add arglist here. |
---|
1047 | (defun symbol-type-line (sym) |
---|
1048 | (let ((types (list |
---|
1049 | (cond ((constantp sym) |
---|
1050 | "Constant") |
---|
1051 | ((proclaimed-special-p sym) |
---|
1052 | "Special Variable") |
---|
1053 | ((boundp sym) |
---|
1054 | "Non-special Variable") |
---|
1055 | (t nil)) |
---|
1056 | (cond ((special-operator-p sym) |
---|
1057 | "Special Operator") |
---|
1058 | ((macro-function sym) |
---|
1059 | "Macro") |
---|
1060 | ((fboundp sym) |
---|
1061 | "Function") |
---|
1062 | (t nil)) |
---|
1063 | (if (type-specifier-p sym) "Type Specifier") |
---|
1064 | (if (record-type-p sym nil) "Record Type") |
---|
1065 | (if (find-class sym nil) "Class Name"))) |
---|
1066 | flag) |
---|
1067 | (with-output-to-string (s) |
---|
1068 | (dolist (type types) |
---|
1069 | (when type |
---|
1070 | (if flag (write-string ", " s)) |
---|
1071 | (setq flag t) |
---|
1072 | (write-string type s)))))) |
---|
1073 | |
---|
1074 | |
---|
1075 | (defmethod inspector-commands ((sym symbol)) |
---|
1076 | (let ((res nil)) |
---|
1077 | '(push (list "Documentation" #'(lambda () (show-documentation sym))) |
---|
1078 | res) |
---|
1079 | (let ((class (find-class sym nil))) |
---|
1080 | (if class |
---|
1081 | (push (list "Inspect Class" #'(lambda () (inspect class))) res))) |
---|
1082 | (if (boundp sym) |
---|
1083 | (push (list "MAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(makunbound ',sym))) |
---|
1084 | (makunbound sym) (resample-it)))) |
---|
1085 | res)) |
---|
1086 | (if (fboundp sym) |
---|
1087 | (push (list "FMAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(fmakunbound ',sym))) |
---|
1088 | (fmakunbound sym) (resample-it)))) |
---|
1089 | res)) |
---|
1090 | '(if (record-type-p sym) |
---|
1091 | (push (list "Inspect Record Type" #'(lambda () (inspect-record-type sym))) |
---|
1092 | res)) |
---|
1093 | (nreverse res))) |
---|
1094 | |
---|
1095 | |
---|
1096 | (defmethod line-n-inspector ((sym symbol) n value label type) |
---|
1097 | (declare (ignore label type)) |
---|
1098 | (setq n (normalize-line-number sym n)) |
---|
1099 | (if (eql n 7) |
---|
1100 | (make-instance 'plist-inspector :symbol sym :object value) |
---|
1101 | (call-next-method))) |
---|
1102 | |
---|
1103 | (defclass plist-inspector (inspector) |
---|
1104 | ((symbol :initarg :symbol :reader plist-symbol))) |
---|
1105 | |
---|
1106 | (defmethod inspector-window-title ((i plist-inspector)) |
---|
1107 | (format nil "~a of ~s" 'plist (plist-symbol i))) |
---|
1108 | |
---|
1109 | (defmethod compute-line-count ((i plist-inspector)) |
---|
1110 | (+ 3 (/ (length (inspector-object i)) 2))) |
---|
1111 | |
---|
1112 | (defmethod line-n ((i plist-inspector) n) |
---|
1113 | (let* ((plist (inspector-object i))) |
---|
1114 | (cond ((eql 0 n) (values plist "Plist: ")) |
---|
1115 | ((eql 1 n) (values (plist-symbol i) "Symbol: " :static)) |
---|
1116 | ((eql 2 n) (values nil nil :comment)) |
---|
1117 | (t (let ((rest (nthcdr (* 2 (- n 3)) plist))) |
---|
1118 | (values (cadr rest) (car rest) :colon)))))) |
---|
1119 | |
---|
1120 | (defmethod (setf line-n) (new-value (i plist-inspector) n) |
---|
1121 | (let* ((plist (inspector-object i))) |
---|
1122 | (if (eql n 0) |
---|
1123 | (replace-object i new-value) |
---|
1124 | (if (< n 3) |
---|
1125 | (setf-line-n-out-of-range i n) |
---|
1126 | (let ((rest (nthcdr (* 2 (- n 3)) plist))) |
---|
1127 | (setf (cadr rest) new-value) |
---|
1128 | (resample-it)))))) |
---|
1129 | |
---|
1130 | (defparameter *inspector-disassembly* nil) |
---|
1131 | |
---|
1132 | ;;;;;;; |
---|
1133 | ;; |
---|
1134 | ;; Functions |
---|
1135 | ;; |
---|
1136 | (defclass function-inspector (inspector) |
---|
1137 | ((disasm-p :accessor disasm-p :initform *inspector-disassembly*) |
---|
1138 | (disasm-info :accessor disasm-info) |
---|
1139 | (pc-width :accessor pc-width) |
---|
1140 | (pc :initarg :pc :initform nil :accessor pc))) |
---|
1141 | |
---|
1142 | (defclass closure-inspector (function-inspector) |
---|
1143 | ((n-closed :accessor closure-n-closed))) |
---|
1144 | |
---|
1145 | |
---|
1146 | |
---|
1147 | (defmethod inspector-class ((f function)) 'function-inspector) |
---|
1148 | (defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector) |
---|
1149 | |
---|
1150 | (defmethod compute-line-count ((f function-inspector)) |
---|
1151 | (+ 1 ; the function |
---|
1152 | 1 ; name |
---|
1153 | 1 ; arglist |
---|
1154 | (let* ((doc (documentation (inspector-object f) t))) |
---|
1155 | (if doc 1 0)) |
---|
1156 | (compute-disassembly-lines f))) |
---|
1157 | |
---|
1158 | (defmethod line-n ((f function-inspector) n) |
---|
1159 | (let* ((o (inspector-object f)) |
---|
1160 | (doc (documentation o t))) |
---|
1161 | (case n |
---|
1162 | (0 (values o "")) |
---|
1163 | (1 (values (function-name o) "Name" :colon)) |
---|
1164 | (2 (multiple-value-bind (arglist type) (arglist o) |
---|
1165 | (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown"))) |
---|
1166 | (values arglist label (if type :colon '(:comment (:plain))))))) |
---|
1167 | (3 (if doc |
---|
1168 | (values (substitute #\space #\newline doc) "Documentation" :colon) |
---|
1169 | (disassembly-line-n f (- n 3)))) |
---|
1170 | (t (disassembly-line-n f (- n (if doc 4 3))))))) |
---|
1171 | |
---|
1172 | (defmethod compute-line-count ((f closure-inspector)) |
---|
1173 | (let* ((o (inspector-object f)) |
---|
1174 | (nclosed (nth-value 8 (function-args (ccl::closure-function o))))) |
---|
1175 | (setf (closure-n-closed f) nclosed) |
---|
1176 | (+ (call-next-method) |
---|
1177 | 1 ; the function we close over |
---|
1178 | 1 ; "Closed over values" |
---|
1179 | nclosed |
---|
1180 | (if (disasm-p f) 1 0)))) ; "Disassembly" |
---|
1181 | |
---|
1182 | (defmethod line-n ((f closure-inspector) n) |
---|
1183 | (let ((o (inspector-object f)) |
---|
1184 | (nclosed (closure-n-closed f))) |
---|
1185 | (if (<= (decf n 2) 0) |
---|
1186 | (call-next-method) |
---|
1187 | (cond ((eql (decf n) 0) |
---|
1188 | (values (ccl::closure-function o) "Inner lfun: " :static)) |
---|
1189 | ((eql (decf n) 0) |
---|
1190 | (values nclosed "Closed over values" :comment #'prin1-comment)) |
---|
1191 | ((< (decf n) nclosed) |
---|
1192 | (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) |
---|
1193 | (map (car (ccl::function-symbol-map (ccl::closure-function o)))) |
---|
1194 | (label (or (and map (svref map (+ n (- (length map) nclosed)))) |
---|
1195 | n)) |
---|
1196 | (cellp (ccl::closed-over-value-p value))) |
---|
1197 | (when cellp |
---|
1198 | (setq value (ccl::closed-over-value value) |
---|
1199 | label (format nil "(~a)" label))) |
---|
1200 | (values value label (if cellp :normal :static) #'prin1-colon-line))) |
---|
1201 | ((eql (decf n nclosed) 0) |
---|
1202 | (values 0 "Disassembly" :comment #'prin1-comment)) |
---|
1203 | (t (disassembly-line-n f (- n 1))))))) |
---|
1204 | |
---|
1205 | (defmethod (setf line-n) (new-value (f function-inspector) n) |
---|
1206 | (let ((o (inspector-object f))) |
---|
1207 | (case n |
---|
1208 | (0 (replace-object f new-value)) |
---|
1209 | (1 (ccl::lfun-name o new-value) (resample-it)) |
---|
1210 | (2 (setf (arglist o) new-value)) |
---|
1211 | (t |
---|
1212 | (if (>= n 3) |
---|
1213 | (set-disassembly-line-n f (- n 3) new-value) |
---|
1214 | (setf-line-n-out-of-range f n))))) |
---|
1215 | new-value) |
---|
1216 | |
---|
1217 | (defmethod (setf line-n) (new-value (f closure-inspector) en &aux (n en)) |
---|
1218 | (let ((o (inspector-object f)) |
---|
1219 | (nclosed (closure-n-closed f))) |
---|
1220 | (if (<= (decf n 2) 0) ; function itself, name, or arglist |
---|
1221 | (call-next-method) |
---|
1222 | (cond ((<= (decf n 2) 0) ; inner-lfun or "Closed over values" |
---|
1223 | (setf-line-n-out-of-range f en)) |
---|
1224 | ((< (decf n) nclosed) ; closed-over variable |
---|
1225 | (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) |
---|
1226 | (cellp (ccl::closed-over-value-p value))) |
---|
1227 | (unless cellp (setf-line-n-out-of-range f en)) |
---|
1228 | (ccl::set-closed-over-value value new-value))) |
---|
1229 | ((eql (decf n nclosed) 0) ; "Disassembly" |
---|
1230 | (setf-line-n-out-of-range f en)) |
---|
1231 | (t (set-disassembly-line-n f (- n 1) new-value)))))) |
---|
1232 | |
---|
1233 | (defun compute-disassembly-lines (f &optional (function (inspector-object f))) |
---|
1234 | (if (functionp function) |
---|
1235 | (let* ((info (and (disasm-p f) (list-to-vector (ccl::disassemble-list function)))) |
---|
1236 | (length (length info)) |
---|
1237 | (last-pc (if info (car (svref info (1- length))) 0))) |
---|
1238 | (if (listp last-pc) (setq last-pc (cadr last-pc))) |
---|
1239 | (setf (pc-width f) (length (format nil "~d" last-pc))) |
---|
1240 | (setf (disasm-info f) info) |
---|
1241 | length) |
---|
1242 | 0)) |
---|
1243 | |
---|
1244 | (defun list-to-vector (list) |
---|
1245 | (let* ((length (length list)) |
---|
1246 | (vec (make-array length))) |
---|
1247 | (dotimes (i length) |
---|
1248 | (declare (fixnum i)) |
---|
1249 | (setf (svref vec i) (pop list))) |
---|
1250 | vec)) |
---|
1251 | |
---|
1252 | (defun disassembly-line-n (f n) |
---|
1253 | (let* ((line (svref (disasm-info f) n)) |
---|
1254 | (value (disasm-line-immediate line))) |
---|
1255 | (values value line (if value :static :comment)))) |
---|
1256 | |
---|
1257 | (defun set-disassembly-line-n (f n new-value &optional |
---|
1258 | (function (inspector-object f))) |
---|
1259 | (declare (ignore new-value function)) |
---|
1260 | (setf-line-n-out-of-range f n)) |
---|
1261 | |
---|
1262 | (defun disasm-line-immediate (line &optional (lookup-functions t)) |
---|
1263 | (pop line) ; remove address |
---|
1264 | (when (eq (car line) 'ccl::jsr_subprim) |
---|
1265 | (return-from disasm-line-immediate (find-symbol (cadr line) :ccl))) |
---|
1266 | (let ((res nil)) |
---|
1267 | (labels ((inner-last (l) |
---|
1268 | (cond ((atom l) l) |
---|
1269 | ((null (cdr l)) (car l)) |
---|
1270 | (t (inner-last (last l)))))) |
---|
1271 | (dolist (e line) |
---|
1272 | (cond ((numberp e) (when (null res) (setq res e))) |
---|
1273 | ((consp e) |
---|
1274 | (cond ((eq (car e) 'function) |
---|
1275 | (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e)))) |
---|
1276 | ((eq (car e) 17) ; locative |
---|
1277 | (setq e (cadr e)) |
---|
1278 | (unless (atom e) |
---|
1279 | (cond ((eq (car e) 'special) |
---|
1280 | (setq res (cadr e))) |
---|
1281 | ((eq (car e) 'function) |
---|
1282 | (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e)))) |
---|
1283 | (t (setq res (inner-last e)))))) |
---|
1284 | ((or (null res) (numberp res)) |
---|
1285 | (setq res (inner-last e)))))))) |
---|
1286 | res)) |
---|
1287 | |
---|
1288 | (defmethod inspector-print-function ((i function-inspector) type) |
---|
1289 | (declare (ignore type)) |
---|
1290 | 'prin1-normal-line) |
---|
1291 | |
---|
1292 | (defmethod prin1-label ((f function-inspector) stream value &optional label type) |
---|
1293 | (declare (ignore value type)) |
---|
1294 | (if (atom label) ; not a disassembly line |
---|
1295 | (call-next-method) |
---|
1296 | (let* ((pc (car label)) |
---|
1297 | (label-p (and (listp pc) (setq pc (cadr pc)))) |
---|
1298 | (pc-mark (pc f))) |
---|
1299 | (if (eq pc pc-mark) |
---|
1300 | (format stream "*~vd" (pc-width f) pc) |
---|
1301 | (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc)) |
---|
1302 | (write-char (if label-p #\= #\ ) stream)))) |
---|
1303 | |
---|
1304 | #+ppc-target |
---|
1305 | (defmethod prin1-value ((f function-inspector) stream value &optional label type) |
---|
1306 | (if (atom label) ; not a disassembly line |
---|
1307 | (unless (eq (if (consp type) (car type) type) :comment) |
---|
1308 | (call-next-method)) |
---|
1309 | (let ((q (cdr label))) |
---|
1310 | (write-char #\( stream) |
---|
1311 | (loop (if (null q) (return)) |
---|
1312 | (ccl::disasm-prin1 (pop q) stream) |
---|
1313 | (if q (write-char #\space stream))) |
---|
1314 | (write-char #\) stream))) |
---|
1315 | value) |
---|
1316 | |
---|
1317 | ;; Generic-functions |
---|
1318 | ;; Display the list of methods on a line of its own to make getting at them faster |
---|
1319 | ;; (They're also inside the dispatch-table which is the first immediate in the disassembly). |
---|
1320 | (defclass gf-inspector (function-inspector) |
---|
1321 | ((method-count :accessor method-count) |
---|
1322 | (slot-count :accessor slot-count :initform 0))) |
---|
1323 | |
---|
1324 | (defmethod inspector-class ((f standard-generic-function)) |
---|
1325 | (if (functionp f) |
---|
1326 | 'gf-inspector |
---|
1327 | 'standard-object-inspector)) |
---|
1328 | |
---|
1329 | (defmethod compute-line-count ((f gf-inspector)) |
---|
1330 | (let* ((gf (inspector-object f)) |
---|
1331 | (count (length (generic-function-methods gf))) |
---|
1332 | (res (+ 1 (setf (method-count f) count) |
---|
1333 | (call-next-method)))) |
---|
1334 | (if (disasm-p f) (1+ res) res))) |
---|
1335 | |
---|
1336 | (defmethod line-n ((f gf-inspector) n) |
---|
1337 | (let* ((count (method-count f)) |
---|
1338 | (slot-count (slot-count f)) |
---|
1339 | (lines (1+ count))) |
---|
1340 | (if (<= 3 n (+ lines slot-count 3)) |
---|
1341 | (let ((methods (generic-function-methods (inspector-object f)))) |
---|
1342 | (cond ((eql (decf n 3) 0) (values methods "Methods: " :static)) |
---|
1343 | ((<= n count) |
---|
1344 | (values (nth (- n 1) methods) nil :static)) |
---|
1345 | ((< (decf n (1+ count)) slot-count) |
---|
1346 | (standard-object-line-n f n)) |
---|
1347 | (t |
---|
1348 | (values 0 "Disassembly" :comment #'prin1-comment)))) |
---|
1349 | (call-next-method f (if (< n 3) n (- n lines slot-count 1)))))) |
---|
1350 | |
---|
1351 | (defmethod (setf line-n) (new-value (f gf-inspector) n) |
---|
1352 | (let* ((count (method-count f)) |
---|
1353 | (slot-count (slot-count f)) |
---|
1354 | (lines (1+ count))) |
---|
1355 | (if (<= 3 n (+ lines slot-count 3)) |
---|
1356 | (let ((en n)) |
---|
1357 | (cond ((<= (decf en 3) count) |
---|
1358 | (setf-line-n-out-of-range f n)) |
---|
1359 | ((< (decf en (1+ count)) slot-count) |
---|
1360 | (standard-object-setf-line-n new-value f en)) |
---|
1361 | (t (setf-line-n-out-of-range f n)))) |
---|
1362 | (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1)))))) |
---|
1363 | |
---|
1364 | #| |
---|
1365 | (defmethod inspector-commands ((f gf-inspector)) |
---|
1366 | (let* ((function (inspector-object f)) |
---|
1367 | (method (selected-object (inspector-view f)))) |
---|
1368 | (if (typep method 'method) |
---|
1369 | (nconc |
---|
1370 | (call-next-method) |
---|
1371 | `(("Remove method" |
---|
1372 | ,#'(lambda () |
---|
1373 | (remove-method function method) |
---|
1374 | (resample-it))))) |
---|
1375 | (call-next-method)))) |
---|
1376 | |# |
---|
1377 | |
---|
1378 | (defclass method-inspector (standard-object-inspector function-inspector) |
---|
1379 | ((standard-object-lines :accessor standard-object-lines))) |
---|
1380 | |
---|
1381 | (defmethod inspector-class ((object standard-method)) |
---|
1382 | 'method-inspector) |
---|
1383 | |
---|
1384 | (defmethod compute-line-count ((i method-inspector)) |
---|
1385 | (+ (setf (standard-object-lines i) (call-next-method)) |
---|
1386 | (if (disasm-p i) 1 0) ; "Disassembly" |
---|
1387 | (compute-disassembly-lines i (method-function (inspector-object i))))) |
---|
1388 | |
---|
1389 | (defmethod line-n ((i method-inspector) n) |
---|
1390 | (let ((sol (standard-object-lines i))) |
---|
1391 | (cond ((< n sol) (call-next-method)) |
---|
1392 | ((eql n sol) (values nil "Disassembly" :comment)) |
---|
1393 | (t (disassembly-line-n i (- n sol 1)))))) |
---|
1394 | |
---|
1395 | (defmethod (setf line-n) (new-value (i method-inspector) n) |
---|
1396 | (let ((sol (standard-object-lines i))) |
---|
1397 | (cond ((< n sol) (call-next-method)) |
---|
1398 | ((eql n sol) (setf-line-n-out-of-range i n)) |
---|
1399 | (t (set-disassembly-line-n |
---|
1400 | i n new-value (method-function (inspector-object i))))))) |
---|
1401 | |
---|
1402 | ;;; funtion-inspector never does prin1-comment. |
---|
1403 | (defmethod prin1-normal-line ((i method-inspector) stream value &optional |
---|
1404 | label type colon-p) |
---|
1405 | (declare (ignore colon-p)) |
---|
1406 | (if (eq type :comment) |
---|
1407 | (prin1-comment i stream value label type) |
---|
1408 | (call-next-method))) |
---|
1409 | |
---|
1410 | |
---|
1411 | ;;;;;;; |
---|
1412 | ;; |
---|
1413 | ;; Structures |
---|
1414 | ;; |
---|
1415 | (defmethod inspector-class ((s structure-object)) |
---|
1416 | 'usual-basics-first-inspector) |
---|
1417 | |
---|
1418 | (defun structure-slots (s) |
---|
1419 | (let ((slots (ccl::sd-slots (ccl::struct-def s)))) |
---|
1420 | (if (symbolp (caar slots)) |
---|
1421 | slots |
---|
1422 | (cdr slots)))) |
---|
1423 | |
---|
1424 | (defmethod compute-line-count ((s structure-object)) |
---|
1425 | (length (structure-slots s))) |
---|
1426 | |
---|
1427 | (defmethod line-n ((s structure-object) n) |
---|
1428 | (let ((slot (nth n (structure-slots s)))) |
---|
1429 | (if slot |
---|
1430 | (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon) |
---|
1431 | (line-n-out-of-range s n)))) |
---|
1432 | |
---|
1433 | (defmethod (setf line-n) (new-value (s structure-object) n) |
---|
1434 | (let ((slot (nth n (structure-slots s)))) |
---|
1435 | (if slot |
---|
1436 | (setf (uvref s (ccl::ssd-offset slot)) new-value) |
---|
1437 | (setf-line-n-out-of-range s n)))) |
---|
1438 | |
---|
1439 | |
---|
1440 | (defclass basic-stream-inspector (uvector-inspector) ()) |
---|
1441 | |
---|
1442 | (defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector) |
---|
1443 | |
---|
1444 | ;;;;;;; |
---|
1445 | ;; |
---|
1446 | ;; packages |
---|
1447 | ;; |
---|
1448 | (defclass package-inspector (uvector-inspector) ()) |
---|
1449 | |
---|
1450 | (defmethod inspector-class ((p package)) 'package-inspector) |
---|
1451 | |
---|
1452 | (defmethod compute-line-count ((i package-inspector)) |
---|
1453 | (+ 2 (call-next-method))) |
---|
1454 | |
---|
1455 | (defmethod line-n ((i package-inspector) n) |
---|
1456 | (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i))) |
---|
1457 | "Internal Symbols: " :static)) |
---|
1458 | ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i))) |
---|
1459 | "External Symbols: " :static)) |
---|
1460 | (t (call-next-method i (- n 2))))) |
---|
1461 | |
---|
1462 | (defmethod (setf line-n) (new-value (i package-inspector) n) |
---|
1463 | (if (< n 2) |
---|
1464 | (setf-line-n-out-of-range i n) |
---|
1465 | (call-next-method new-value i (- n 2)))) |
---|
1466 | |
---|
1467 | (defmethod inspector-commands ((i package-inspector)) |
---|
1468 | `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages)))) |
---|
1469 | (,(format nil "(setq *package* '~a" (inspector-object i)) |
---|
1470 | ,#'(lambda () (setq *package* (inspector-object i)))))) |
---|
1471 | |
---|
1472 | ;;;;;;; |
---|
1473 | ;; |
---|
1474 | ;; Records |
---|
1475 | ;; |
---|
1476 | (defclass record-inspector (object-first-inspector) |
---|
1477 | ((record-type :accessor record-type) |
---|
1478 | (field-names :accessor field-names) |
---|
1479 | (unlock :initform nil :accessor unlock))) |
---|
1480 | |
---|
1481 | (defmethod inspector-class ((o macptr)) |
---|
1482 | 'record-inspector) |
---|
1483 | |
---|
1484 | |
---|
1485 | ;;; Still needs work. |
---|
1486 | ;;; Lots of work. |
---|
1487 | (defclass thread-inspector (uvector-inspector) ()) |
---|
1488 | |
---|
1489 | (defmethod inspector-class ((thread ccl::lisp-thread)) |
---|
1490 | 'thread-inspector) |
---|
1491 | |
---|
1492 | (defmethod compute-line-count :before ((i thread-inspector)) |
---|
1493 | ) |
---|
1494 | |
---|
1495 | (defmethod line-n ((thread thread-inspector) n) |
---|
1496 | (declare (ignore n)) |
---|
1497 | ) |
---|
1498 | |
---|
1499 | #| |
---|
1500 | (defmethod line-n-inspector ((i thread-inspector) n value label type) |
---|
1501 | (declare (ignore n type)) |
---|
1502 | (or (and value |
---|
1503 | (macptrp value) |
---|
1504 | (not (%null-ptr-p value))) |
---|
1505 | (call-next-method))) |
---|
1506 | |# |
---|
1507 | |
---|
1508 | |
---|
1509 | (defmethod line-n-inspector (i n value label type) |
---|
1510 | (declare (ignore i n label type)) |
---|
1511 | (make-inspector value)) |
---|
1512 | |
---|
1513 | (defmethod line-n-inspector ((i usual-inspector) n value label type) |
---|
1514 | (let ((object (inspector-object i))) |
---|
1515 | (if (typep object 'usual-inspector) |
---|
1516 | (make-inspector value) |
---|
1517 | (line-n-inspector (inspector-object i) n value label type)))) |
---|
1518 | |
---|
1519 | |
---|
1520 | |
---|
1521 | |
---|
1522 | ;;;;;;; |
---|
1523 | ;; |
---|
1524 | ;; an ERROR-FRAME stores the stack addresses that the backtrace window displays |
---|
1525 | ;; |
---|
1526 | |
---|
1527 | ;; set to list of function you don't want to see |
---|
1528 | ;; Functions can be symbols, nil for kernel, or #'functions |
---|
1529 | (defparameter *backtrace-internal-functions* |
---|
1530 | (list :kernel)) |
---|
1531 | |
---|
1532 | (defvar *backtrace-hide-internal-functions-p* t) |
---|
1533 | |
---|
1534 | (defclass error-frame () |
---|
1535 | ((addresses :accessor addresses) |
---|
1536 | (restart-info :accessor restart-info) |
---|
1537 | (stack-start :initarg :stack-start :reader stack-start) |
---|
1538 | (stack-end :initarg :stack-end :reader stack-end) |
---|
1539 | (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr) |
---|
1540 | (context :initarg :context :reader context) |
---|
1541 | (frame-count :accessor frame-count) |
---|
1542 | (ignored-functions :accessor ignored-functions |
---|
1543 | :initform (and *backtrace-hide-internal-functions-p* |
---|
1544 | *backtrace-internal-functions*)) |
---|
1545 | (break-condition :accessor break-condition |
---|
1546 | :initarg :break-condition) |
---|
1547 | (unavailable-value-marker :initform (cons nil nil) |
---|
1548 | :accessor unavailable-value-marker))) |
---|
1549 | |
---|
1550 | |
---|
1551 | |
---|
1552 | (defmethod initialize-instance ((f error-frame) &key) |
---|
1553 | (call-next-method) |
---|
1554 | (initialize-addresses f)) |
---|
1555 | |
---|
1556 | (defmethod initialize-addresses ((f error-frame)) |
---|
1557 | (let* ((addresses (list-to-vector (ccl::%stack-frames-in-context (context f))))) |
---|
1558 | (setf (frame-count f) (length addresses) |
---|
1559 | (addresses f) addresses))) |
---|
1560 | |
---|
1561 | (defmethod compute-frame-info ((f error-frame) n) |
---|
1562 | (let* ((frame (svref (addresses f) n)) |
---|
1563 | (context (context f)) |
---|
1564 | (marker (unavailable-value-marker f))) |
---|
1565 | |
---|
1566 | (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame) |
---|
1567 | (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker) |
---|
1568 | (list (ccl::arglist-from-map lfun) args locals))))) |
---|
1569 | |
---|
1570 | (defun print-error-frame-limits (f stream) |
---|
1571 | (format stream "#x~x - #x~x" (stack-start f) (stack-end f))) |
---|
1572 | |
---|
1573 | (defmethod print-object ((f error-frame) stream) |
---|
1574 | (print-unreadable-object (f stream :type 'frame-ptr) |
---|
1575 | (print-error-frame-limits f stream))) |
---|
1576 | |
---|
1577 | |
---|
1578 | |
---|
1579 | ;;;;;;; |
---|
1580 | ;; |
---|
1581 | ;; The inspector for error-frame objects |
---|
1582 | ;; |
---|
1583 | |
---|
1584 | |
---|
1585 | |
---|
1586 | ;;; The "vsp-range" and "tsp-range" slots have to do with |
---|
1587 | ;;; recognizing/validating stack-allocated objects |
---|
1588 | (defclass stack-inspector (inspector) |
---|
1589 | ((vsp-range :accessor vsp-range :initarg :vsp-range) |
---|
1590 | (tsp-range :accessor tsp-range :initarg :tsp-range) |
---|
1591 | (csp-range :accessor csp-range :initarg :csp-range))) |
---|
1592 | |
---|
1593 | |
---|
1594 | |
---|
1595 | |
---|
1596 | (defmethod initialize-instance ((i stack-inspector) &rest initargs &key context) |
---|
1597 | (declare (dynamic-extent initargs)) |
---|
1598 | (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context)) |
---|
1599 | (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context)) |
---|
1600 | (tcr (ccl::bt.tcr context))) |
---|
1601 | (apply #'call-next-method |
---|
1602 | i |
---|
1603 | :object |
---|
1604 | (make-instance 'error-frame |
---|
1605 | :stack-start start |
---|
1606 | :stack-end end |
---|
1607 | :tcr tcr |
---|
1608 | :context context |
---|
1609 | :break-condition (ccl::bt.break-condition context)) |
---|
1610 | :tsp-range (make-tsp-stack-range tcr context) |
---|
1611 | :vsp-range (make-vsp-stack-range tcr context) |
---|
1612 | :csp-range (make-csp-stack-range tcr context) |
---|
1613 | initargs))) |
---|
1614 | |
---|
1615 | (defmethod print-object ((i stack-inspector) stream) |
---|
1616 | (print-unreadable-object (i stream :type 'stack-inspector) |
---|
1617 | (print-error-frame-limits (inspector-object i) stream))) |
---|
1618 | |
---|
1619 | (defmethod addresses ((f stack-inspector)) |
---|
1620 | (addresses (inspector-object f))) |
---|
1621 | |
---|
1622 | (defmethod compute-line-count ((f stack-inspector)) |
---|
1623 | (frame-count (inspector-object f))) |
---|
1624 | |
---|
1625 | (defmethod line-n ((f stack-inspector) n) |
---|
1626 | (let* ((frame (svref (addresses (inspector-object f)) n))) |
---|
1627 | (ccl::cfp-lfun frame))) |
---|
1628 | |
---|
1629 | |
---|
1630 | |
---|
1631 | |
---|
1632 | |
---|
1633 | |
---|
1634 | ;;; inspecting a single stack frame |
---|
1635 | ;;; The inspector-object is expected to be an error-frame |
---|
1636 | (defclass stack-frame-inspector (inspector) |
---|
1637 | ((frame-number :initarg :frame-number :initform nil :reader frame-number) |
---|
1638 | (frame-info :initform nil :accessor frame-info))) |
---|
1639 | |
---|
1640 | |
---|
1641 | (defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key |
---|
1642 | object frame-number) |
---|
1643 | (declare (dynamic-extent initargs)) |
---|
1644 | (setq object (require-type object 'error-frame)) |
---|
1645 | (apply #'call-next-method i |
---|
1646 | :object object |
---|
1647 | initargs) |
---|
1648 | (setf (frame-number i) frame-number)) |
---|
1649 | |
---|
1650 | |
---|
1651 | |
---|
1652 | (defmethod compute-line-count ((i stack-frame-inspector)) |
---|
1653 | (let ((frame-number (frame-number i))) |
---|
1654 | (if (null frame-number) |
---|
1655 | 0 |
---|
1656 | (let* ((error-frame (inspector-object i)) |
---|
1657 | (frame-info (or (frame-info i) |
---|
1658 | (setf (frame-info i) (compute-frame-info error-frame frame-number))))) |
---|
1659 | (destructuring-bind (args locals) (cdr frame-info) |
---|
1660 | (+ 1 (length args) 1 (length locals))))))) |
---|
1661 | |
---|
1662 | (defmethod line-n ((i stack-frame-inspector) n) |
---|
1663 | (unless (< -1 n (inspector-line-count i)) |
---|
1664 | (line-n-out-of-range i n)) |
---|
1665 | (destructuring-bind (arglist args locals) (frame-info i) |
---|
1666 | (if (zerop n) |
---|
1667 | (values arglist nil :static) |
---|
1668 | (let* ((nargs (length args))) |
---|
1669 | (decf n) |
---|
1670 | (if (< n nargs) |
---|
1671 | (cons :arg (nth n args)) |
---|
1672 | (progn |
---|
1673 | (decf n nargs) |
---|
1674 | (if (zerop n) |
---|
1675 | nil |
---|
1676 | (cons :local (nth (1- n) locals))))))))) |
---|
1677 | |
---|
1678 | (defmethod (setf line-n) (value (i stack-frame-inspector) n) |
---|
1679 | (declare (ignorable value n)) |
---|
1680 | (error "not yet!")) |
---|
1681 | |
---|
1682 | |
---|
1683 | |
---|
1684 | |
---|
1685 | |
---|
1686 | (defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type) |
---|
1687 | (declare (ignore label type)) |
---|
1688 | (when value |
---|
1689 | (if (or (atom value) (not (typep (car value) 'keyword))) |
---|
1690 | (prin1 value stream) |
---|
1691 | (progn |
---|
1692 | (if (eq (car value) :arg) |
---|
1693 | (format stream " ") |
---|
1694 | (format stream " ")) |
---|
1695 | (when (cdr value) |
---|
1696 | (destructuring-bind (label . val) (cdr value) |
---|
1697 | (format stream "~a: " label) |
---|
1698 | (if (eq val *unbound-marker*) |
---|
1699 | (format stream "??") |
---|
1700 | (prin1 val stream)))))))) |
---|
1701 | |
---|
1702 | (defmethod (setf frame-number) (frame-number (i stack-frame-inspector)) |
---|
1703 | (let ((max (1- (frame-count (inspector-object i))))) |
---|
1704 | (unless (or (null frame-number) |
---|
1705 | (and (<= 0 frame-number max))) |
---|
1706 | (setq frame-number (require-type frame-number `(or null (integer 0 ,max)))))) |
---|
1707 | (unless (eql frame-number (frame-number i)) |
---|
1708 | (setf (slot-value i 'frame-number) frame-number) |
---|
1709 | (setf (inspector-line-count i) nil) |
---|
1710 | frame-number)) |
---|
1711 | |
---|
1712 | |
---|
1713 | ;;; Each of these stack ranges defines the entire range of (control/value/temp) |
---|
1714 | ;;; addresses; they can be used to addresses of stack-allocated objects |
---|
1715 | ;;; for printing. |
---|
1716 | (defun make-tsp-stack-range (tcr bt-info) |
---|
1717 | (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info)) |
---|
1718 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area) |
---|
1719 | target::area.high)))) |
---|
1720 | |
---|
1721 | #+ppc-target |
---|
1722 | (defun make-vsp-stack-range (tcr bt-info) |
---|
1723 | (list (cons (ccl::%fixnum-ref |
---|
1724 | (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) |
---|
1725 | target::lisp-frame.savevsp) |
---|
1726 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) |
---|
1727 | target::area.high)))) |
---|
1728 | #+x8632-target |
---|
1729 | (defun make-vsp-stack-range (tcr bt-info) |
---|
1730 | (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.esp-cell) |
---|
1731 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) |
---|
1732 | target::area.high)))) |
---|
1733 | |
---|
1734 | #+x8664-target |
---|
1735 | (defun make-vsp-stack-range (tcr bt-info) |
---|
1736 | (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell) |
---|
1737 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) |
---|
1738 | target::area.high)))) |
---|
1739 | |
---|
1740 | #+ppc-target |
---|
1741 | (defun make-csp-stack-range (tcr bt-info) |
---|
1742 | (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) |
---|
1743 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) |
---|
1744 | target::area.high)))) |
---|
1745 | |
---|
1746 | #+x8632-target |
---|
1747 | (defun make-csp-stack-range (tcr bt-info) |
---|
1748 | (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) |
---|
1749 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) |
---|
1750 | target::area.high)))) |
---|
1751 | |
---|
1752 | #+x8664-target |
---|
1753 | (defun make-csp-stack-range (tcr bt-info) |
---|
1754 | (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) |
---|
1755 | (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) |
---|
1756 | target::area.high)))) |
---|
1757 | |
---|
1758 | ;;; Inspector |
---|
1759 | |
---|
1760 | |
---|
1761 | (defvar *inspector-ui* ()) |
---|
1762 | (defvar *previous-inspector-ui* nil) |
---|
1763 | |
---|
1764 | (defclass inspector-ui () |
---|
1765 | ((inspector :initarg :inspector :accessor inspector-ui-inspector) |
---|
1766 | (level :initarg :level :accessor inspector-ui-level))) |
---|
1767 | |
---|
1768 | (defclass inspector-tty-ui (inspector-ui) |
---|
1769 | ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin) |
---|
1770 | (pagesize :initarg :pagesize :initform 20 :accessor |
---|
1771 | inspector-tty-ui-pagesize))) |
---|
1772 | |
---|
1773 | (defmethod ui-initialize ((ui inspector-tty-ui))) |
---|
1774 | |
---|
1775 | (defmethod ui-present ((ui inspector-tty-ui)) |
---|
1776 | (let* ((inspector (inspector-ui-inspector ui))) |
---|
1777 | (when (null (inspector-line-count inspector)) |
---|
1778 | (update-line-count inspector)) |
---|
1779 | (with-errorfree-printing |
---|
1780 | (let* ((stream *debug-io*) |
---|
1781 | (origin (inspector-tty-ui-origin ui)) |
---|
1782 | (pagesize (inspector-tty-ui-pagesize ui)) |
---|
1783 | (page-end (+ origin pagesize)) |
---|
1784 | (n (compute-line-count inspector)) |
---|
1785 | (end (min page-end n)) |
---|
1786 | (tag origin) |
---|
1787 | (*print-pretty* (or *print-pretty* *describe-pretty*)) |
---|
1788 | (*print-length* 5) |
---|
1789 | (*print-level* 5) |
---|
1790 | (func #'(lambda (i value &rest rest) |
---|
1791 | (declare (dynamic-extent rest)) |
---|
1792 | (let* ((type (cadr rest))) |
---|
1793 | (unless (or (eq type :comment) |
---|
1794 | (and (consp type) |
---|
1795 | (eq (car type) :comment))) |
---|
1796 | (format stream "[~d] " tag)) |
---|
1797 | (incf tag)) |
---|
1798 | (format stream "~8t") |
---|
1799 | (apply #'prin1-line i stream value rest) |
---|
1800 | (terpri stream)))) |
---|
1801 | (declare (dynamic-extent func)) |
---|
1802 | (map-lines inspector func origin end))) |
---|
1803 | (values))) |
---|
1804 | |
---|
1805 | (ccl::define-toplevel-command |
---|
1806 | :tty-inspect i (n) |
---|
1807 | "inspect <n>th item" |
---|
1808 | (inspector-ui-inspect-nth *inspector-ui* n)) |
---|
1809 | |
---|
1810 | (ccl::define-toplevel-command |
---|
1811 | :tty-inspect pop () |
---|
1812 | "exit current inspector level" |
---|
1813 | (invoke-restart 'exit-inspector)) |
---|
1814 | |
---|
1815 | (ccl::define-toplevel-command |
---|
1816 | :tty-inspect q () |
---|
1817 | "exit inspector" |
---|
1818 | (invoke-restart 'end-inspect)) |
---|
1819 | |
---|
1820 | (ccl::define-toplevel-command |
---|
1821 | :tty-inspect show () |
---|
1822 | "re-show currently inspected object (the value of CCL:@)" |
---|
1823 | (ui-present *inspector-ui*)) |
---|
1824 | |
---|
1825 | (defmethod inspector-ui-next-page ((ui inspector-tty-ui)) |
---|
1826 | (let* ((nlines (compute-line-count (inspector-ui-inspector ui))) |
---|
1827 | (origin (inspector-tty-ui-origin ui)) |
---|
1828 | (page-size (inspector-tty-ui-pagesize ui)) |
---|
1829 | (new-origin (+ origin page-size))) |
---|
1830 | (if (< new-origin nlines) |
---|
1831 | (setf (inspector-tty-ui-origin ui) new-origin)) |
---|
1832 | (ui-present ui))) |
---|
1833 | |
---|
1834 | (ccl::define-toplevel-command |
---|
1835 | :tty-inspect next () |
---|
1836 | "show next page of object data" |
---|
1837 | (inspector-ui-next-page *inspector-ui*)) |
---|
1838 | |
---|
1839 | (defmethod inspector-ui-prev-page ((ui inspector-tty-ui)) |
---|
1840 | (let* ((origin (inspector-tty-ui-origin ui)) |
---|
1841 | (page-size (inspector-tty-ui-pagesize ui)) |
---|
1842 | (new-origin (max 0 (- origin page-size)))) |
---|
1843 | (setf (inspector-tty-ui-origin ui) new-origin) |
---|
1844 | (ui-present ui))) |
---|
1845 | |
---|
1846 | (ccl::define-toplevel-command |
---|
1847 | :tty-inspect prev () |
---|
1848 | "show previous page of object data" |
---|
1849 | (inspector-ui-prev-page *inspector-ui*)) |
---|
1850 | |
---|
1851 | (ccl::define-toplevel-command |
---|
1852 | :tty-inspect home () |
---|
1853 | "show first page of object data" |
---|
1854 | (progn |
---|
1855 | (setf (inspector-tty-ui-origin *inspector-ui*) 0) |
---|
1856 | (ui-present *inspector-ui*))) |
---|
1857 | |
---|
1858 | (ccl::define-toplevel-command |
---|
1859 | :tty-inspect s (n v) |
---|
1860 | "set the <n>th line of object data to value <v>" |
---|
1861 | (let* ((ui *inspector-ui*)) |
---|
1862 | (setf (line-n (inspector-ui-inspector ui) n) v) |
---|
1863 | (ui-present ui))) |
---|
1864 | |
---|
1865 | |
---|
1866 | (defmethod ui-interact ((ui inspector-tty-ui)) |
---|
1867 | (let* ((level (inspector-ui-level ui)) |
---|
1868 | (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui)))))) |
---|
1869 | (declare (special ccl::*default-integer-command*)) |
---|
1870 | (restart-case |
---|
1871 | (ccl:with-terminal-input |
---|
1872 | (ccl::with-toplevel-commands :tty-inspect |
---|
1873 | (ccl::read-loop |
---|
1874 | :prompt-function #'(lambda (stream) |
---|
1875 | (if (eql level 0) |
---|
1876 | (format stream "~&Inspect> ") |
---|
1877 | (format stream "~&Inspect ~d> " level)))))) |
---|
1878 | (exit-inspector () |
---|
1879 | (if *previous-inspector-ui* |
---|
1880 | (ui-present *previous-inspector-ui*) |
---|
1881 | (terpri *debug-io*)))))) |
---|
1882 | |
---|
1883 | (defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n) |
---|
1884 | (let* ((inspector (inspector-ui-inspector ui))) |
---|
1885 | (multiple-value-bind (value label type) |
---|
1886 | (line-n inspector n) |
---|
1887 | (unless (or (eq type :comment) |
---|
1888 | (and (consp type) (eq (car type) :comment))) |
---|
1889 | (let* ((new-inspector (line-n-inspector inspector n value label type)) |
---|
1890 | (ccl::@ value)) |
---|
1891 | (inspector-ui-inspect |
---|
1892 | (make-instance 'inspector-tty-ui |
---|
1893 | :level (1+ (inspector-ui-level ui)) |
---|
1894 | :inspector new-inspector))))))) |
---|
1895 | |
---|
1896 | (defparameter *default-inspector-ui-class-name* 'inspector-tty-ui) |
---|
1897 | |
---|
1898 | (defmethod inspector-ui-inspect ((ui inspector-ui)) |
---|
1899 | (let* ((*previous-inspector-ui* *inspector-ui*) |
---|
1900 | (*inspector-ui* ui)) |
---|
1901 | (ui-initialize ui) |
---|
1902 | (ui-present ui) |
---|
1903 | (ui-interact ui) |
---|
1904 | (values))) |
---|
1905 | |
---|
1906 | (defun tty-inspect (thing) |
---|
1907 | (inspector-ui-inspect (make-instance *default-inspector-ui-class-name* |
---|
1908 | :inspector (make-inspector thing) |
---|
1909 | :level 0))) |
---|
1910 | |
---|
1911 | (defparameter *default-inspector-ui-creation-function* 'tty-inspect) |
---|
1912 | |
---|
1913 | |
---|
1914 | (defun inspect (thing) |
---|
1915 | (let* ((ccl::@ thing)) |
---|
1916 | (restart-case (funcall *default-inspector-ui-creation-function* thing) |
---|
1917 | (end-inspect () thing)))) |
---|