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

Last change on this file since 12765 was 12765, checked in by gb, 10 years ago

Use the new (internal) function to partition slots into
:instance,:class, and other :allocation values when describing
standard instances. (Probably overkill.)

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