source: trunk/source/lib/describe.lisp @ 15115

Last change on this file since 15115 was 15115, checked in by gz, 8 years ago

Move the make-xxx-stack-range functions out of the inspector package

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