source: release/1.3/source/lib/describe.lisp @ 11747

Last change on this file since 11747 was 11747, checked in by rme, 11 years ago

Merge trunk changes through r11740.

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