source: branches/working-0711/ccl/lib/describe.lisp @ 12949

Last change on this file since 12949 was 12949, checked in by gz, 10 years ago

cleanup of function inspectors and disassembly (r12650, r12682, r12756, r12838, r12846, r12848)

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