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

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

Make the gui inspector show function disassembly. Extend the inspector protocol to support this a little better. Fix a number of bugs in closing and method inspectors.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 68.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         (all-slots (ccl::class-slots class)))
526    (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots)
527      (let* ((ninstance-slots (length instance-slots))
528             (nclass-slots (length class-slots))
529             (nother-slots (length other-slots)))
530        (+ 2                                ; class, wrapper
531           (if (eql 0 ninstance-slots)
532             0
533             (1+ ninstance-slots))
534           (if (eql 0 nclass-slots)
535             0
536             (1+ nclass-slots))
537           (if (eql 0 nother-slots)
538             0
539             (1+ nother-slots))
540           (if (eql 0 (+ nclass-slots ninstance-slots nother-slots))
541             1
542             0))))))
543
544(defun slot-value-or-unbound (instance slot-name)
545  (eliminate-unbound (ccl::slot-value-if-bound instance slot-name
546                                               (ccl::%slot-unbound-marker))))
547
548(defparameter *standard-object-type* (list nil))
549(defparameter *standard-object-static-type*
550  (cons :static (cdr *standard-object-type*)))
551(defparameter *standard-object-comment-type* 
552  (list :comment))
553
554(defmethod line-n ((i standard-object-inspector) n)
555  (standard-object-line-n i n))
556
557(defmethod prin1-label ((i standard-object-inspector) stream value &optional label type)
558  (declare (ignore value type))
559  (if (symbolp label)
560    (prin1 label stream)
561    (call-next-method)))
562
563; Looks like
564; Class:
565; Wrapper:
566; [Instance slots:
567;  slots...]
568; [Class slots:
569;  slots...]
570; [Other slots:
571;  slots...]
572
573(defun standard-object-line-n (i n)
574  (let* ((instance (inspector-object i))
575         (class (class-of instance))
576         (all-slots (class-slots class))
577         (wrapper (or (ccl::standard-object-p instance)
578                      (if (typep instance 'ccl::funcallable-standard-object)
579                        (ccl::gf.instance.class-wrapper instance))))
580         (instance-start 2))
581    (if (< n instance-start)
582      (if (eql n 0)
583        (values class "Class: " :normal)
584        (values wrapper "Wrapper: " :static))
585      (multiple-value-bind (instance-slotds class-slotds other-slotds)
586          (ccl::extract-instance-class-and-other-slotds all-slots)
587        (let* ((instance-count (length instance-slotds))
588               (shared-start (+ instance-start instance-count
589                                (if (eql 0 instance-count) 0 1))))
590          (if (< n shared-start)
591            (if (eql n instance-start)
592              (values nil "Instance slots" :comment)
593              (let ((slot-name (slot-definition-name
594                                (elt instance-slotds (- n instance-start 1)))))
595                (values (slot-value-or-unbound instance slot-name)
596                        slot-name
597                        :colon)))
598            (let* ((shared-count (length class-slotds))
599                   (shared-end (+ shared-start shared-count
600                                  (if (eql shared-count 0) 0 1))))
601              (if (< n shared-end)
602                (if (eql n shared-start)
603                  (values nil "Class slots" :comment)
604                  (let ((slot-name (slot-definition-name 
605                                    (elt class-slotds (- n shared-start 1)))))
606                    (values (slot-value-or-unbound instance slot-name)
607                            slot-name
608                            :colon)))
609                (let* ((other-start shared-end)
610                       (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0))))
611                  (if (< n other-end)
612                    (if (eql n other-start)
613                      (values nil "Other slots" :comment)
614                      (let ((slot-name (slot-definition-name 
615                                        (elt other-slotds (- n other-start 1)))))
616                        (values (slot-value-or-unbound instance slot-name)
617                                slot-name
618                                :colon)))
619                    (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end))
620                      (values nil "No Slots" :comment)
621                      (line-n-out-of-range i n))))))))))))
622
623(defmethod (setf line-n) (value (i standard-object-inspector) n)
624  (standard-object-setf-line-n value i n))
625
626(defun standard-object-setf-line-n (value i n)
627  (let* ((instance (inspector-object i))
628         (class (class-of instance))
629         (instance-start 2))
630    (if (< n instance-start)
631      (cond
632       ((eql n 0) (change-class instance value)
633         (update-line-count i))
634        (t (setf-line-n-out-of-range i n)))
635      (let* ((slotds (ccl::extract-instance-effective-slotds class))
636             (instance-count (length slotds))
637             (shared-start (+ instance-start instance-count
638                              (if (eql 0 instance-count) 0 1))))
639        (if (< n shared-start)
640          (if (eql n instance-start)
641            (setf-line-n-out-of-range i n)
642            (let ((slot-name (slot-definition-name
643                              (elt slotds (- n instance-start 1)))))
644              (setf (slot-value instance slot-name) (restore-unbound value))))
645          (let* ((slotds (ccl::extract-class-effective-slotds class))
646                 (shared-count (length slotds))
647                 (shared-end (+ shared-start shared-count
648                                (if (eql shared-count 0) 0 1))))
649            (if (< n shared-end)
650              (if (eql n shared-start)
651                (setf-line-n-out-of-range i n)
652                (let ((slot-name (slot-definition-name 
653                                  (elt slotds (- n shared-start 1)))))
654                  (setf (slot-value instance slot-name)
655                        (restore-unbound value))))
656              (setf-line-n-out-of-range i n))))))))
657
658
659;;;;;;;;;;;  Inspector objects for common classes.
660
661(defparameter *plain-comment-type* '(:comment (:plain)))
662(defparameter *bold-comment-type* '(:comment (:bold)))
663
664(defun resample-it ()
665  )
666
667;;;;;;;
668;;
669;; Lists
670;;
671(defclass cons-inspector (basics-first-mixin inspector) ())
672
673(defclass list-inspector (basics-first-mixin inspector)
674  ((length :accessor list-inspector-length)
675   (dotted-p :accessor list-inspector-dotted-p)
676   (nthcdr :accessor list-inspector-nthcdr)
677   (n :accessor list-inspector-n)))
678
679(defmethod inspector-class ((o list))
680  (if (listp (cdr o))
681    'list-inspector
682    'cons-inspector))
683
684; Same as list-length-and-final-cdr, but computes the real length of the list
685(defun real-list-length (list)
686  (multiple-value-bind (len final-cdr max-circ-len)
687      (ccl::list-length-and-final-cdr list)
688    (if (null max-circ-len)
689      (values len final-cdr nil)
690      (let ((middle (nthcdr max-circ-len list))
691            (n 1))
692        (loop (when (eq list middle) (return))
693          (pop list)
694          (incf n))
695        (pop list)
696        (loop (when (eq list middle) (return))
697          (pop list)
698          (incf n))
699        (values nil nil n)))))       
700
701(defmethod compute-line-count ((i list-inspector))
702  (multiple-value-bind (len final-cdr circ-len) (real-list-length (inspector-object i))
703    (setf (list-inspector-dotted-p i) final-cdr)
704    (setf (list-inspector-nthcdr i) (inspector-object i))
705    (setf (list-inspector-n i) 0)
706    (+ 1                                ; regular, dotted, or circular
707       1                                ; length
708       (abs (setf (list-inspector-length i)
709                  (or len (- circ-len))))   ; the elements
710       (if final-cdr 2 0))))            ; the final-cdr and it's label
711
712(defmethod compute-line-count ((i cons-inspector))
713  2)                                    ; car & cdr
714
715(defmethod line-n ((i list-inspector) en &aux (n en))
716  (let* ((circ? (list-inspector-length i))
717         (length (abs circ?)))
718    (cond ((eql 0 n)
719           (values nil (cond ((list-inspector-dotted-p i) "Dotted List")
720                             ((< circ? 0) "Circular List")
721                             (t "Normal List"))
722                   *plain-comment-type*))
723          ((eql 0 (decf n)) (values length "Length: "))
724          ((>= (decf n) (setq length length))   ; end of dotted list
725           (let ((final-cdr (list-inspector-dotted-p i)))
726             (unless final-cdr (line-n-out-of-range i en))
727             (if (eql n length)
728               (values nil "Non-nil final cdr" *plain-comment-type*)
729               (values final-cdr (- length 0.5) :colon))))
730          (t (let* ((saved-n (list-inspector-n i))
731                    (nthcdr (if (>= n saved-n)
732                              (nthcdr (- n saved-n) (list-inspector-nthcdr i))
733                              (nthcdr n (inspector-object i)))))
734               (setf (list-inspector-nthcdr i) nthcdr
735                     (list-inspector-n i) n)
736               (values (car nthcdr) n :colon))))))
737
738(defmethod line-n ((i cons-inspector) n)
739  (let ((object (inspector-object i)))
740    (ecase n
741           (0 (values (car object) "Car: "))
742           (1 (values (cdr object) "Cdr: ")))))
743
744(defmethod (setf line-n) (value (i list-inspector) n)
745  (when (< n 2)
746    (setf-line-n-out-of-range i n))
747  (decf n 2)
748  (setf (elt (inspector-object i) n) value)
749  (resample-it))
750
751(defmethod (setf line-n) (value (i cons-inspector) n)
752  (let ((object (inspector-object i)))
753    (ecase n
754           (0 (setf (car object) value))
755           (1 (setf (cdr object) value))))
756  (resample-it))
757
758;;;;;;;
759;;
760;; General uvector's
761;;
762(defclass uvector-inspector (basics-first-mixin inspector)
763  ((name-list :initarg :name-list :initform nil :accessor name-list)))
764
765(defmethod uvector-name-list (object) 
766  (let* ((type (type-of object))
767         (names (cdr (assq type ccl::*def-accessor-types*)))
768         (names-size (length names))
769         res)
770    (when names
771      (dotimes (i (uvsize object))
772        (declare (fixnum i))
773        (let ((name (and (> names-size i) (aref names i))))
774          (if name
775            (push (if (listp name) (car name) name) res)
776            (if (and (eql i 0) (typep object 'ccl::internal-structure))
777              (push 'type res)
778              (push i res)))))
779      (nreverse res))))
780
781(defmethod compute-line-count ((i uvector-inspector))
782  (setf (name-list i) (uvector-name-list (inspector-object i)))
783  (uvsize (inspector-object i)))
784
785(defmethod line-n ((i uvector-inspector) n)
786  (values (uvref (inspector-object i) n)
787          (or (let ((name-list (name-list i))) (and name-list (nth n (name-list i))))
788              n)
789          :colon))
790
791(defmethod (setf line-n) (new-value (i uvector-inspector) n)
792  (setf (uvref (inspector-object i) n) new-value))
793
794(defmethod inspector-commands ((i uvector-inspector))
795  (let ((object (inspector-object i)))
796    (if (method-exists-p #'inspector-commands object)
797      (inspector-commands object))))
798
799;;;;;;;
800;;
801;; Vectors & Arrays
802;;
803(defmethod inspector-class ((v ccl::simple-1d-array))
804  'usual-basics-first-inspector)
805
806(defmethod compute-line-count ((v ccl::simple-1d-array))
807  (+ 1 (length v)))
808
809(defmethod line-n ((v ccl::simple-1d-array) n)
810  (cond ((eql 0 n) (values (length v) "Length" :static 'prin1-colon-line))
811        (t (decf n 1)
812           (values (aref v n) n :colon))))
813
814(defmethod (setf line-n) (value (v ccl::simple-1d-array) n)
815  (when (<= n 0)
816    (setf-line-n-out-of-range v n))
817  (decf n 1)
818  (prog1 (setf (aref v n) value)
819    (resample-it)))
820
821(defclass array-inspector (uvector-inspector) ())
822
823(defmethod inspector-class ((v array))
824  'array-inspector)
825
826(defmethod uvector-name-list ((a array))
827  (if (eql 1 (array-rank a))
828    (if (array-has-fill-pointer-p a)
829      '("Fill Pointer" "Physical size" "Data vector" "Displacement" "Flags")
830      '("Logical size" "Physical size" "Data vector" "Displacement" "Flags"))
831    `("Rank" "Physical size" "Data vector" "Displacement" "Flags" "Dim0" "Dim1" "Dim2" "Dim3")))
832
833(defmethod compute-line-count ((i array-inspector))
834  (let* ((a (inspector-object i))
835         (rank (array-rank a)))
836    (call-next-method)                  ; calculate name list
837    (+ (if (eql rank 1) (1+ (uvsize a))  7)
838       (apply #'* (array-dimensions a)))))
839
840(defmethod line-n ((i array-inspector) n)
841  (let* ((v (inspector-object i))
842         (rank (array-rank v))
843         (uvsize (if (eql rank 1)
844                   (+ (uvsize v) 1)
845                   7)))
846    (cond ((eql 0 n) (values (array-element-type v)
847                             (if (adjustable-array-p v)
848                               "Adjustable, Element type"
849                               "Element type")
850                             :static 'prin1-colon-line))
851          ((eql  5 n)
852           (values  (uvref v target::vectorH.flags-cell)
853                   "Flags: "
854                   :static
855                   #'(lambda (i s v l type)
856                       (format-normal-line i s v l type "#x~x"))))
857          ((and (eql  6 n) (not (eql rank 1)))
858           (values (array-dimensions v) "Dimensions: " :static))
859          ((< n uvsize) (call-next-method i (1- n)))
860          (t (let ((index (- n uvsize)))
861               (values (row-major-aref v index) (array-indices v index) :colon))))))
862
863(defmethod (setf line-n) (new-value (i array-inspector) n)
864  (let* ((v (inspector-object i))
865         (rank (array-rank v))
866         (uvsize (if (eql rank 1)
867                   (+ (uvsize v) 1)
868                   7)))
869    (prog1
870      (cond ((or (eql 0 n) (eql 1 n) (and (eql 4 n) (not (eql rank 1))))
871             (setf-line-n-out-of-range i n))
872            ((< n uvsize)
873             (if (eql 3 n)
874               (setq new-value (require-type new-value 'array))
875               (setq new-value (require-type new-value 'fixnum)))
876             (call-next-method new-value i (1- n)))
877          (t (let ((index (- n uvsize)))
878               (setf (row-major-aref v index) new-value))))
879      (resample-it))))
880
881(defun array-indices (a row-major-index)
882  (let ((rank (array-rank a)))
883    (if (eql 1 rank)
884      row-major-index
885      (let ((res nil)
886            dim
887            (dividend row-major-index)
888            remainder)
889        (loop
890          (when (zerop rank) (return res))
891          (setq dim (array-dimension a (decf rank)))
892          (multiple-value-setq (dividend remainder) (floor dividend dim))
893          (push remainder res))))))
894 
895(defmethod prin1-line ((i array-inspector) stream value &optional
896                       label type function)
897  (declare (ignore stream value type function))
898  (if (or (numberp label) (listp label))   ; First line or contents lines
899    (call-next-method)
900    (let ((*print-array* nil))
901      (call-next-method))))
902
903;;;;;;;
904;;
905;; Numbers
906;;
907(defmethod inspector-class ((num number)) 'usual-formatting-inspector)
908
909; floats
910(defmethod compute-line-count ((num float)) 5)
911
912(defmethod line-n ((num float) n)
913  (let ((type :static))
914    (ecase n
915      (0 (values num "Float:           " type))
916      (1 (values num "Scientific:      " type
917                 (if (< num 0) "~8,2e" "~7,2e")))
918      (2 (values (if (zerop num) "illegal" (log num 2))
919                     "Log base 2:      " type "~d"))
920      (3 (values (rationalize num)
921                     "Ratio equiv:     " type))
922      (4 (values (round num)
923                     "Nearest integer: " type)))))
924
925; complex numbers
926(defmethod compute-line-count ((num complex)) 3)
927
928(defmethod line-n ((num complex) n)
929  (let ((type :static))
930    (ecase n
931      (0 (values num            "Complex num:    " type))
932      (1 (values (realpart num) "Real part:      " type))
933      (2 (values (imagpart num) "Imaginary part: " type)))))
934
935; ratios
936(defmethod compute-line-count ((num ratio)) 6)
937
938(defmethod line-n ((num ratio) n)
939  (let ((type :static))
940    (ecase n
941      (0 (values num               "Ratio:           " type))
942      (1 (values (float num)       "Scientific:      " type 
943                 (if (< num 0) "~8,2e" "~7,2E")))
944      (2 (values (if (zerop num) "illegal" (log num 2))
945                                   "Log base 2:      " type "~d"))
946      (3 (values (round num)       "Nearest integer: " type))
947      (4 (values (numerator num)   "Numerator:       " type))
948      (5 (values (denominator num) "Denominator:     " type)))))
949
950; integers
951(defmethod compute-line-count ((num integer)) 
952  (let ((res 12))
953    (unless (< 0 num 4000) (decf res))   ; not a roman number
954    (unless (<= 0 num 255) (decf res))   ; not a character
955    res))
956
957(defmethod line-n ((num integer) n)
958  (if (and (>= n 7) (not (< 0 num 4000))) (incf n))   ; maybe skip roman.
959  (if (and (>= n 8) (not (<= 0 num 255))) (incf n))   ; maybe skip character.
960  (let* ((type :static)
961         (neg? (< num 0))
962         (norm (if neg? 
963                 (+ num (expt 2 (max 32 (* 4 (round (+ (integer-length num) 4) 4)))))
964                 num)))
965    (ecase n
966      (0  (values num
967                (if (fixnump num)
968                  "Fixnum:      "
969                  "Bignum:      ")
970                type "~s"))
971      (1  (let ((num (ignore-errors (float num))))
972            (values num "Scientific:  " type
973                    (cond ((null num) "FLOATING-POINT-OVERFLOW")
974                          ((< num 0) "~8,2e")
975                          (t "~7,2e")))))
976      (2  (values (if (zerop num) "illegal" (log num 2)) 
977                  "Log base 2:  " type "~d"))
978      (3  (values norm
979                  "Binary:      " type
980                  (if neg? "#b...~b" "#b~b")))
981      (4  (values norm
982                  "Octal:       " type
983                  (if neg? "#o...~o" "#o~o")))
984      (5  (values num
985                  "Decimal:     " type "~d."))
986      (6  (values norm
987                  "Hex:         " type
988                  (if neg? "#x...~x" "#x~x")))
989      (7  (values (format nil "~@r" num)
990                  "Roman:       " type "~a"))
991      (8  (values (code-char num)
992                  "Character:   " type "~s"))
993      (9 (values (ccl::ensure-simple-string (prin1-to-string num))
994                  "Abbreviated: "
995                  type #'format-abbreviated-string))
996      (10 (values (or (ignore-errors (universal-time-string num)) "#<error>")
997                  "As time:     " type "~a"))
998      (11 (if (< num 0)
999            (values most-negative-fixnum 'most-negative-fixnum type '("~d." t))
1000            (values most-positive-fixnum 'most-positive-fixnum type '("~d." t)))))))
1001
1002(defun format-abbreviated-string (stream string)
1003  (setq string (require-type string 'simple-string))
1004  (let ((length (length string)))
1005    (if (< length 7)
1006      (princ string stream)
1007      (format stream "~a <- ~s digits -> ~a"
1008              (subseq string 0 3)
1009              (- length 6)
1010              (subseq string (- length 3) length)))))
1011
1012(defun universal-time-string (num)
1013  (multiple-value-bind (second minute hour date month year day)
1014                       (decode-universal-time num)
1015    (with-output-to-string (s)
1016      (format s "~d:~2,'0d:~2,'0d " hour minute second)
1017      (princ (nth day '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
1018                        "Saturday" "Sunday"))
1019             s)
1020      (format s ", ~d " date)
1021      (princ (nth month '("" "January" "February" "March" "April" "May" "June" "July"
1022                          "August" "September" "October" "November" "December"))
1023             s)
1024      (format s ", ~d" year))))
1025
1026; Characters
1027(defmethod compute-line-count ((ch character)) 2)
1028
1029(defmethod line-n ((ch character) n)
1030  (let ((type :static))
1031    (ecase n
1032      (0 (values ch             "Character: " type))
1033      (1 (values (char-code ch) "char-code: " type)))))
1034
1035;;;;;;;
1036;;
1037;; Symbols
1038;;
1039(defun symbol-has-bindings-p (sym)
1040  (or (constantp sym) (proclaimed-special-p sym) (boundp sym)
1041      (special-operator-p sym) (macro-function sym) (fboundp sym)
1042      (type-specifier-p sym) (record-type-p sym nil)
1043      (find-class sym nil)))
1044
1045(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector)
1046
1047(defmethod compute-line-count ((sym symbol))
1048  (+ (if (symbol-has-bindings-p sym) 1 0)
1049     1                                  ; package
1050     1                                  ; symbol-name
1051     1                                  ; symbol-value
1052     1                                  ; symbol-function
1053     (if (fboundp sym) 1 0)             ; arglist
1054     1                                  ; plist
1055     (if (find-class sym nil) 1 0)      ; class
1056     ))
1057
1058
1059(defmethod normalize-line-number ((sym symbol) n)
1060  (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n))
1061  (if (and (>= n 5) (not (fboundp sym))) (incf n))
1062  n)
1063
1064(defmethod line-n ((sym symbol) n)
1065  (setq n (normalize-line-number sym n))
1066  (let ((type :normal)
1067        (comment '(:comment (:bold)))
1068        (static :static))
1069    (ecase n
1070      (0 (values nil (symbol-type-line sym) comment))
1071      (1 (let ((p (symbol-package sym)))
1072           (if (null p)
1073             (values nil "No home package." comment)
1074             (multiple-value-bind (found kind) (find-symbol (symbol-name sym) p)
1075               (values p 
1076                       (if (or (null kind) (neq found sym))
1077                         "NOT PRESENT in home package: "
1078                         (format nil "~a in package: " kind))
1079                       static)))))
1080      (2 (values (symbol-name sym) "Print name: " static))
1081      (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*)
1082                 "Value: " type))
1083      (4 (values (if (fboundp sym)
1084                   (cond ((macro-function sym))
1085                         ((special-operator-p sym) sym)
1086                         (t (symbol-function sym)))
1087                   *unbound-marker*)
1088                 "Function: " type))
1089      (5 (values (and (fboundp sym) (arglist sym))
1090                 "Arglist: " static))
1091      (6 (values (symbol-plist sym) "Plist: " type))
1092      (7 (values (find-class sym) "Class: " static)))))
1093
1094(defmethod (setf line-n) (value (sym symbol) n)
1095  (let (resample-p)
1096    (setq n (normalize-line-number sym n))
1097    (setq value (restore-unbound value))
1098    (ecase n
1099      ((0 1 2 5) (setf-line-n-out-of-range sym n))
1100      (3 (setf resample-p (not (boundp sym))
1101               (symbol-value sym) value))
1102      (4 (setf resample-p (not (fboundp sym))
1103               (symbol-function sym) value))
1104      (6 (setf (symbol-plist sym) value)))
1105    (when resample-p (resample-it))
1106    value))
1107
1108(defun record-type-p (name &optional check-database)
1109  (declare (ignore check-database))
1110  (and (keywordp name)
1111       (ignore-errors (ccl::%foreign-type-or-record name))))
1112
1113; Add arglist here.
1114(defun symbol-type-line (sym)
1115  (let ((types (list
1116                (cond ((constantp sym)
1117                       "Constant")
1118                      ((proclaimed-special-p sym)
1119                       "Special Variable")
1120                      ((boundp sym)
1121                       "Non-special Variable")
1122                      (t nil))
1123                (cond ((special-operator-p sym)
1124                       "Special Operator")
1125                      ((macro-function sym)
1126                       "Macro")
1127                      ((fboundp sym)
1128                       "Function")
1129                      (t nil))
1130                (if (type-specifier-p sym) "Type Specifier")
1131                (if (record-type-p sym nil) "Record Type")
1132                (if (find-class sym nil) "Class Name")))
1133        flag)
1134    (with-output-to-string (s)
1135      (dolist (type types)
1136        (when type
1137          (if flag (write-string ", " s))
1138          (setq flag t)
1139          (write-string type s))))))
1140   
1141
1142(defmethod inspector-commands ((sym symbol))
1143  (let ((res nil))
1144    '(push (list "Documentation" #'(lambda () (show-documentation sym)))
1145          res)
1146    (let ((class (find-class sym nil)))
1147      (if class
1148        (push (list "Inspect Class" #'(lambda () (inspect class))) res)))
1149    (if (boundp sym)
1150      (push (list "MAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(makunbound ',sym)))
1151                                              (makunbound sym) (resample-it))))
1152            res))
1153    (if (fboundp sym)
1154      (push (list "FMAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(fmakunbound ',sym)))
1155                                               (fmakunbound sym) (resample-it))))
1156            res))
1157    '(if (record-type-p sym)
1158      (push (list "Inspect Record Type" #'(lambda () (inspect-record-type sym)))
1159            res))
1160    (nreverse res)))
1161
1162
1163(defmethod line-n-inspector ((sym symbol) n value label type)
1164  (declare (ignore label type))
1165  (setq n (normalize-line-number sym n))
1166  (if (eql n 6)
1167    (make-instance 'plist-inspector :symbol sym :object value)
1168    (call-next-method)))
1169
1170(defclass plist-inspector (inspector)
1171  ((symbol :initarg :symbol :reader plist-symbol)))
1172
1173(defmethod inspector-window-title ((i plist-inspector))
1174  (format nil "~a of ~s" 'plist (plist-symbol i)))
1175
1176(defmethod compute-line-count ((i plist-inspector))
1177  (+ 3 (/ (length (inspector-object i)) 2)))
1178
1179(defmethod line-n ((i plist-inspector) n)
1180  (let* ((plist (inspector-object i)))
1181    (cond ((eql 0 n) (values plist "Plist: "))
1182          ((eql 1 n) (values (plist-symbol i) "Symbol: " :static))
1183          ((eql 2 n) (values nil nil :comment))
1184          (t (let ((rest (nthcdr (* 2 (- n 3)) plist)))
1185               (values (cadr rest) (car rest) :colon))))))
1186
1187(defmethod (setf line-n) (new-value (i plist-inspector) n)
1188  (let* ((plist (inspector-object i)))
1189    (if (eql n 0)
1190      (replace-object i new-value)
1191      (if (< n 3)
1192        (setf-line-n-out-of-range i n)
1193        (let ((rest (nthcdr (* 2 (- n 3)) plist)))
1194          (setf (cadr rest) new-value)
1195          (resample-it))))))
1196
1197(defparameter *inspector-disassembly* nil)
1198
1199;;;;;;;
1200;;
1201;; Functions
1202;;
1203(defclass function-inspector (inspector)
1204  ((header-lines :initform nil :reader header-lines)
1205   (disasm-p :accessor disasm-p :initform *inspector-disassembly*)
1206   (disasm-info :accessor disasm-info)
1207   (pc-width :accessor pc-width)
1208   (pc :initarg :pc :initform nil :accessor pc)))
1209
1210(defmethod standard-header-count ((f function-inspector)) (length (header-lines f)))
1211
1212(defmethod header-count ((f function-inspector)) (standard-header-count f))
1213
1214(defclass closure-inspector (function-inspector)
1215  ((n-closed :accessor closure-n-closed)))
1216
1217(defmethod inspector-class ((f function)) 'function-inspector)
1218(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector)
1219
1220(defmethod compute-line-count :before ((f function-inspector))
1221  (let* ((o (inspector-object f))
1222         (doc (documentation o t))
1223         (sn (ccl::function-source-note o))
1224         (lines (nconc (list (list o ""))
1225                       (list (list (function-name o) "Name" :colon))
1226                       (list (multiple-value-bind (arglist type) (arglist o)
1227                               (let ((label (if type
1228                                              (format nil "Arglist (~(~a~))" type)
1229                                              "Arglist unknown")))
1230                                 (list arglist label (if type :colon '(:comment (:plain)))))))
1231                       (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon)))
1232                       (when sn (list (list sn "Source Location" :colon))))))
1233    (setf (slot-value f 'header-lines) lines)))
1234
1235(defmethod compute-line-count ((f function-inspector))
1236  (+ (header-count f) (compute-disassembly-lines f)))
1237
1238(defmethod line-n-strings ((f function-inspector) n)
1239  (if (< (decf n (header-count f)) 0)
1240    (call-next-method)
1241    (disassembly-line-n-strings f n)))
1242
1243(defmethod line-n-inspector ((f function-inspector) n value label type)
1244  (declare (ignore value label type))
1245  (if (< (decf n (header-count f)) 0)
1246    (call-next-method)
1247    (disassembly-line-n-inspector f n)))
1248
1249(defmethod line-n ((f function-inspector) n)
1250  (let* ((lines (header-lines f))
1251         (nlines (length lines)))
1252    (if (< n nlines)
1253      (apply #'values (nth n lines))
1254      (disassembly-line-n f (- n nlines)))))
1255
1256(defmethod compute-line-count :before ((f closure-inspector))
1257  (let* ((o (inspector-object f))
1258         (nclosed (nth-value 8 (function-args (ccl::closure-function o)))))
1259    (setf (closure-n-closed f) nclosed)))
1260
1261(defmethod header-count ((f closure-inspector))
1262  (+ (standard-header-count f)
1263     1                              ; the function we close over
1264     1                              ; "Closed over values"
1265     (closure-n-closed f)))
1266
1267(defmethod line-n ((f closure-inspector) n)
1268  (let ((o (inspector-object f))
1269        (nclosed (closure-n-closed f)))
1270    (if (< (decf n (standard-header-count f)) 0)
1271      (call-next-method)
1272      (cond ((< (decf n) 0)
1273             (values (ccl::closure-function o) "Inner lfun: " :static))
1274            ((< (decf n) 0)
1275             (values nclosed "Closed over values" :comment))
1276            ((< n nclosed)
1277             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
1278                    (map (car (ccl::function-symbol-map (ccl::closure-function o))))
1279                    (label (or (and map (svref map (+ n (- (length map) nclosed))))
1280                               n))
1281                    (cellp (ccl::closed-over-value-p value)))
1282               (when cellp
1283                 (setq value (ccl::closed-over-value value)
1284                       label (format nil "(~a)" label)))
1285               (values value label (if cellp :normal :static) #'prin1-colon-line)))
1286            (t (disassembly-line-n f (- n nclosed)))))))
1287
1288(defmethod (setf line-n) (new-value (f function-inspector) n)
1289  (let ((o (inspector-object f))
1290        (standard-header-count (standard-header-count f)))
1291    (if (< n standard-header-count)
1292      (case n
1293        (0 (replace-object f new-value))
1294        (1 (ccl::lfun-name o new-value) (resample-it))
1295        (t (setf-line-n-out-of-range f n)))
1296      (set-disassembly-line-n f (- n standard-header-count) new-value)))
1297  new-value)
1298
1299(defmethod (setf line-n) (new-value (f closure-inspector) en &aux (n en))
1300  (let ((o (inspector-object f))
1301        (nclosed (closure-n-closed f)))
1302    (if (< (decf n (standard-header-count f)) 0)
1303      (call-next-method)
1304      (cond ((< (decf n 2) 0)          ; inner-lfun or "Closed over values"
1305             (setf-line-n-out-of-range f en))
1306            ((< n nclosed)       ; closed-over variable
1307             (let* ((value (ccl::nth-immediate o (1+ (- nclosed n))))
1308                    (cellp (ccl::closed-over-value-p value)))
1309               (unless cellp (setf-line-n-out-of-range f en))
1310               (ccl::set-closed-over-value value new-value)))
1311            (t (set-disassembly-line-n f (- n nclosed) new-value))))))
1312
1313(defun compute-disassembly-lines (f &optional (function (inspector-object f)))
1314  (if (and (functionp function) (disasm-p f))
1315    (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr)
1316           (length (length lines))
1317           (last-label (loop for n from (1- length) downto 0 as line = (aref lines n)
1318                             thereis (and (consp line) (cadr line))))
1319           (max-pc (if (consp last-label) (cadr last-label) last-label)))
1320      (setf (pc-width f) (length (format nil "~d" max-pc)))
1321      (setf (disasm-info f) lines)
1322      (1+ length))
1323    0))
1324
1325(defun disassembly-line-n (f n)
1326  (if (< (decf n) 0)
1327    (values nil "Disassembly:" :comment)
1328    (let ((line (svref (disasm-info f) n)))
1329      (if (consp line)
1330        (destructuring-bind (object label instr) line
1331          (values object (cons label instr) :static))
1332        (values nil (cons nil line) :static)))))
1333
1334(defun disassembly-line-n-inspector (f n)
1335  (unless (< (decf n) 0)
1336    (let ((line (svref (disasm-info f) n)))
1337      (and (consp line)
1338           (car line)
1339           (make-inspector (car line))))))
1340
1341(defun disassembly-line-n-strings (f n)
1342  (if (< (decf n) 0)
1343    (values "Disassembly:" nil)
1344    (let ((line (svref (disasm-info f) n)))
1345      (if (consp line)
1346        (destructuring-bind (object label instr) line
1347          (declare (ignore object))
1348          (unless (stringp label)
1349            (setq label (with-output-to-string (stream)
1350                          (prin1-disassembly-label f stream label))))
1351          (values label instr))
1352        (values nil line)))))
1353
1354(defun set-disassembly-line-n (f n new-value &optional 
1355                                 (function (inspector-object f)))
1356  (declare (ignore new-value function))
1357  (setf-line-n-out-of-range f n))
1358
1359(defmethod prin1-label ((f function-inspector) stream value &optional data type)
1360  (declare (ignore value type))
1361  (if (atom data)                      ; not a disassembly line
1362    (call-next-method)
1363    (prin1-disassembly-label f stream (car data))))
1364
1365(defun prin1-disassembly-label (f stream label)
1366  (let* ((pc label)
1367         (label-p (and (consp pc) (setq pc (cadr pc))))
1368         (pc-mark (pc f))
1369         (pc-width (pc-width f)))
1370    (when pc
1371      (write-char (if (eql pc pc-mark) #\* #\Space) stream)
1372      (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc))))
1373
1374(defmethod prin1-value ((f function-inspector) stream value &optional data type)
1375  (declare (ignore value type))
1376  (if (atom data) ;; not a disassembly line
1377    (call-next-method)
1378    (princ (cdr data) stream)))
1379
1380
1381#+ppc-target
1382(defmethod prin1-value ((f function-inspector) stream value &optional label type)
1383  (if (atom label)                      ; not a disassembly line
1384    (unless (eq (if (consp type) (car type) type) :comment)
1385      (call-next-method))
1386    (let ((q (cdr label)))
1387      (write-char #\( stream)
1388      (loop (if (null q) (return))
1389        (ccl::disasm-prin1 (pop q) stream)
1390        (if q (write-char #\space stream)))
1391      (write-char #\) stream)))
1392  value)
1393
1394;; Generic-functions
1395;; Display the list of methods on a line of its own to make getting at them faster
1396;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
1397(defclass gf-inspector (function-inspector)
1398  ((method-count :accessor method-count)))
1399
1400(defmethod inspector-class ((f standard-generic-function))
1401  (if (functionp f) 
1402    'gf-inspector
1403    'standard-object-inspector))
1404
1405(defmethod compute-line-count :before ((f gf-inspector))
1406  (let* ((gf (inspector-object f))
1407         (count (length (generic-function-methods gf))))
1408    (setf (method-count f) count)))
1409
1410(defmethod header-count ((f gf-inspector))
1411  (+ (standard-header-count f) 1 (method-count f)))
1412
1413(defmethod line-n ((f gf-inspector) n)
1414  (let* ((count (method-count f))
1415         (methods (generic-function-methods (inspector-object f))))
1416    (cond ((< (decf n  (standard-header-count f)) 0)
1417           (call-next-method))
1418          ((< (decf n) 0)
1419           (values methods "Methods: " :comment))
1420          ((< n count)
1421           (values (nth n methods) nil :static))
1422          (t (disassembly-line-n f (- n count))))))
1423
1424(defmethod (setf line-n) (new-value (f gf-inspector) n)
1425  (let* ((count (method-count f))
1426         (en n))
1427    (cond ((< (decf n (standard-header-count f)) 0)
1428           (call-next-method))
1429          ((< (decf n) count)
1430           (setf-line-n-out-of-range f en))
1431          (t (set-disassembly-line-n f (- n count) new-value)))))
1432
1433#|
1434(defmethod inspector-commands ((f gf-inspector))
1435  (let* ((function (inspector-object f))
1436         (method (selected-object (inspector-view f))))
1437    (if (typep method 'method)
1438      (nconc
1439       (call-next-method)
1440       `(("Remove method"
1441         ,#'(lambda ()
1442              (remove-method function method)
1443              (resample-it)))))
1444      (call-next-method))))
1445|#
1446
1447;;;;;;;
1448;;
1449;; Structures
1450;;
1451(defmethod inspector-class ((s structure-object))
1452  'usual-basics-first-inspector)
1453
1454(defun structure-slots (s)
1455  (let ((slots (ccl::sd-slots (ccl::struct-def s))))
1456    (if (symbolp (caar slots))
1457      slots
1458      (cdr slots))))
1459
1460(defmethod compute-line-count ((s structure-object))
1461  (length (structure-slots s)))
1462
1463(defmethod line-n ((s structure-object) n)
1464  (let ((slot (nth n (structure-slots s))))
1465    (if slot
1466      (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon)
1467      (line-n-out-of-range s n))))
1468
1469(defmethod (setf line-n) (new-value (s structure-object) n)
1470  (let ((slot (nth n (structure-slots s))))
1471    (if slot
1472      (setf (uvref s (ccl::ssd-offset slot)) new-value)
1473      (setf-line-n-out-of-range s n))))
1474
1475
1476(defclass basic-stream-inspector (uvector-inspector) ())
1477
1478(defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector)
1479 
1480;;;;;;;
1481;;
1482;; packages
1483;;
1484(defclass package-inspector (uvector-inspector) ())
1485
1486(defmethod inspector-class ((p package)) 'package-inspector)
1487
1488(defmethod compute-line-count ((i package-inspector))
1489  (+ 2 (call-next-method)))
1490
1491(defmethod line-n ((i package-inspector) n)
1492  (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i)))
1493                           "Internal Symbols: " :static))
1494        ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i)))
1495                           "External Symbols: " :static))
1496        (t (call-next-method i (- n 2)))))
1497
1498(defmethod (setf line-n) (new-value (i package-inspector) n)
1499  (if (< n 2)
1500    (setf-line-n-out-of-range i n)
1501    (call-next-method new-value i (- n 2))))
1502
1503(defmethod inspector-commands ((i package-inspector))
1504  `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages))))
1505    (,(format nil "(setq *package* '~a" (inspector-object i))
1506     ,#'(lambda () (setq *package* (inspector-object i))))))
1507
1508;;;;;;;
1509;;
1510;; Records
1511;;
1512(defclass record-inspector (object-first-inspector)
1513  ((record-type :accessor record-type)
1514   (field-names :accessor field-names)
1515   (unlock :initform nil :accessor unlock)))
1516
1517(defmethod inspector-class ((o macptr))
1518  'record-inspector)
1519
1520
1521;;; Still needs work.
1522;;; Lots of work.
1523(defclass thread-inspector (uvector-inspector) ())
1524
1525(defmethod inspector-class ((thread ccl::lisp-thread))
1526  'thread-inspector)
1527
1528(defmethod compute-line-count :before ((i thread-inspector))
1529)
1530
1531(defmethod line-n ((thread thread-inspector) n)
1532  (declare (ignorable n))
1533  (call-next-method)
1534)
1535
1536#|
1537(defmethod line-n-inspector ((i thread-inspector) n value label type)
1538  (declare (ignore n type))
1539  (or (and value
1540           (macptrp value)
1541           (not (%null-ptr-p value)))
1542      (call-next-method)))
1543|#
1544
1545
1546(defmethod line-n-inspector (i n value label type)
1547  (declare (ignore i n label type))
1548  (make-inspector value))
1549
1550(defmethod line-n-inspector ((i usual-inspector) n value label type)
1551  (let ((object (inspector-object i)))
1552    (if (typep object 'usual-inspector)
1553      (make-inspector value)
1554      (line-n-inspector (inspector-object i) n value label type))))
1555
1556
1557
1558
1559;;;;;;;
1560;;
1561;; an ERROR-FRAME stores the stack addresses that the backtrace window displays
1562;;
1563
1564;; set to list of function you don't want to see
1565;; Functions can be symbols, nil for kernel, or #'functions
1566(defparameter *backtrace-internal-functions* 
1567  (list :kernel))
1568
1569(defvar *backtrace-hide-internal-functions-p* t)
1570
1571(defclass error-frame ()
1572  ((addresses :accessor addresses)
1573   (restart-info :accessor restart-info)
1574   (stack-start :initarg :stack-start  :reader stack-start)
1575   (stack-end :initarg :stack-end :reader stack-end)
1576   (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr)
1577   (context :initarg :context :reader context)
1578   (frame-count :accessor frame-count)
1579   (ignored-functions :accessor ignored-functions
1580                      :initform (and *backtrace-hide-internal-functions-p*
1581                                     *backtrace-internal-functions*))
1582   (break-condition :accessor break-condition
1583                    :initarg :break-condition)
1584   (unavailable-value-marker :initform (cons nil nil)
1585                             :accessor unavailable-value-marker)))
1586 
1587
1588
1589(defmethod initialize-instance ((f error-frame) &key)
1590  (call-next-method)
1591  (initialize-addresses f))
1592
1593(defmethod initialize-addresses ((f error-frame))
1594  (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector)))
1595      (setf (frame-count f) (length addresses)
1596            (addresses f) addresses)))
1597
1598(defmethod compute-frame-info ((f error-frame) n)
1599  (let* ((frame (svref (addresses f) n))
1600         (context (context f))
1601         (marker (unavailable-value-marker f)))
1602   
1603    (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame)
1604      (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker)
1605        (list (ccl::arglist-from-map lfun) args locals)))))
1606
1607(defun print-error-frame-limits (f stream)
1608  (format stream "#x~x - #x~x" (stack-start f) (stack-end f)))
1609
1610(defmethod print-object ((f error-frame) stream)
1611  (print-unreadable-object (f stream :type 'frame-ptr)
1612    (print-error-frame-limits f stream)))
1613
1614
1615
1616;;;;;;;
1617;;
1618;; The inspector for error-frame objects
1619;;
1620
1621
1622
1623;;; The "vsp-range" and "tsp-range" slots have to do with
1624;;; recognizing/validating stack-allocated objects
1625(defclass stack-inspector (inspector)
1626  ((vsp-range :accessor vsp-range :initarg :vsp-range)
1627   (tsp-range :accessor tsp-range :initarg :tsp-range)
1628   (csp-range :accessor csp-range :initarg :csp-range)))
1629
1630
1631
1632                           
1633(defmethod initialize-instance ((i stack-inspector) &rest initargs &key context)
1634  (declare (dynamic-extent initargs))
1635  (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context))
1636         (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context))
1637         (tcr (ccl::bt.tcr context)))
1638    (apply #'call-next-method
1639           i
1640           :object 
1641           (make-instance 'error-frame
1642             :stack-start start
1643             :stack-end end
1644             :tcr tcr
1645             :context context
1646             :break-condition (ccl::bt.break-condition context))
1647           :tsp-range (make-tsp-stack-range tcr context)
1648           :vsp-range (make-vsp-stack-range tcr context)
1649           :csp-range (make-csp-stack-range tcr context)
1650           initargs)))
1651
1652(defmethod print-object ((i stack-inspector) stream)
1653  (print-unreadable-object (i stream :type 'stack-inspector)
1654    (print-error-frame-limits (inspector-object i) stream)))
1655
1656(defmethod addresses ((f stack-inspector))
1657  (addresses (inspector-object f)))
1658
1659(defmethod compute-line-count ((f stack-inspector))
1660  (frame-count (inspector-object f)))
1661
1662(defmethod line-n ((f stack-inspector) n)
1663  (let* ((frame (svref (addresses (inspector-object f)) n)))
1664    (ccl::cfp-lfun frame)))
1665
1666
1667
1668 
1669
1670
1671;;; inspecting a single stack frame
1672;;; The inspector-object is expected to be an error-frame
1673(defclass stack-frame-inspector (inspector)
1674  ((frame-number :initarg :frame-number :initform nil :reader frame-number)
1675   (frame-info :initform nil :accessor frame-info)))
1676
1677
1678(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key
1679                                object frame-number)
1680  (declare (dynamic-extent initargs))
1681  (setq object (require-type object 'error-frame))
1682  (apply #'call-next-method i 
1683         :object object
1684         initargs)
1685  (setf (frame-number i) frame-number))
1686
1687   
1688
1689(defmethod compute-line-count ((i stack-frame-inspector))
1690  (let ((frame-number (frame-number i)))
1691    (if (null frame-number)
1692      0
1693      (let* ((error-frame (inspector-object i))
1694             (frame-info (or (frame-info i)
1695                             (setf (frame-info i) (compute-frame-info error-frame frame-number)))))
1696        (destructuring-bind (args locals) (cdr frame-info)
1697          (+ 1 (length args) 1 (length locals)))))))
1698
1699(defmethod line-n ((i stack-frame-inspector) n)
1700  (unless (< -1 n (inspector-line-count i))
1701    (line-n-out-of-range i n))
1702  (destructuring-bind (arglist args locals) (frame-info i)
1703    (if (zerop n)
1704      (values arglist nil :static)
1705      (let* ((nargs (length args)))
1706        (decf n)
1707        (if (< n nargs)
1708          (cons :arg (nth n args))
1709          (progn
1710            (decf n nargs)
1711            (if (zerop n)
1712              nil
1713              (cons :local (nth (1- n) locals)))))))))
1714
1715(defmethod (setf line-n) (value (i stack-frame-inspector) n)
1716  (declare (ignorable value n))
1717  (error "not yet!"))
1718
1719       
1720
1721
1722
1723(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type)
1724  (declare (ignore label type))
1725  (when value
1726    (if (or (atom value) (not (typep (car value) 'keyword)))
1727      (prin1 value stream)
1728      (progn
1729        (if (eq (car value) :arg)
1730          (format stream "   ")
1731          (format stream "  "))
1732        (when (cdr value)
1733          (destructuring-bind (label . val) (cdr value)
1734            (format stream "~a: " label)
1735            (if (eq val *unbound-marker*)
1736              (format stream "??")
1737              (prin1 val stream))))))))
1738
1739(defmethod (setf frame-number) (frame-number (i stack-frame-inspector))
1740  (let ((max (1- (frame-count (inspector-object i)))))
1741    (unless (or (null frame-number)
1742                (and (<= 0 frame-number max)))
1743      (setq frame-number (require-type frame-number `(or null (integer 0 ,max))))))
1744  (unless (eql frame-number (frame-number i))
1745    (setf (slot-value i 'frame-number) frame-number)
1746    (setf (inspector-line-count i) nil)
1747    frame-number))
1748
1749
1750;;; Each of these stack ranges defines the entire range of (control/value/temp)
1751;;; addresses; they can be used to addresses of stack-allocated objects
1752;;; for printing.
1753(defun make-tsp-stack-range (tcr bt-info)
1754  (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info))
1755              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area)
1756                                target::area.high))))
1757
1758#+ppc-target
1759(defun make-vsp-stack-range (tcr bt-info)
1760  (list (cons (ccl::%fixnum-ref
1761               (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell)
1762               target::lisp-frame.savevsp)
1763              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1764                                target::area.high))))
1765#+x8632-target
1766(defun make-vsp-stack-range (tcr bt-info)
1767  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.esp-cell)
1768              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1769                                target::area.high))))
1770
1771#+x8664-target
1772(defun make-vsp-stack-range (tcr bt-info)
1773  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell)
1774              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1775                                target::area.high))))
1776
1777#+ppc-target
1778(defun make-csp-stack-range (tcr bt-info)
1779  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell)
1780              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1781                                target::area.high))))
1782
1783#+x8632-target
1784(defun make-csp-stack-range (tcr bt-info)
1785  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
1786              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1787                                target::area.high))))
1788
1789#+x8664-target
1790(defun make-csp-stack-range (tcr bt-info)
1791  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
1792              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1793                                target::area.high))))
1794
1795;;; Inspector
1796
1797
1798(defvar *inspector-ui* ())
1799(defvar *previous-inspector-ui* nil)
1800
1801(defclass inspector-ui ()
1802    ((inspector :initarg :inspector :accessor inspector-ui-inspector)
1803     (level :initarg :level :accessor inspector-ui-level)))
1804
1805(defclass inspector-tty-ui (inspector-ui)
1806    ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin)
1807     (pagesize :initarg :pagesize :initform 20 :accessor
1808               inspector-tty-ui-pagesize)))
1809
1810(defmethod ui-initialize ((ui inspector-tty-ui)))
1811
1812(defmethod ui-present ((ui inspector-tty-ui))
1813  (let* ((inspector (inspector-ui-inspector ui)))
1814    (with-errorfree-printing
1815        (let* ((stream *debug-io*)
1816               (origin (inspector-tty-ui-origin ui))
1817               (pagesize (inspector-tty-ui-pagesize ui))
1818               (page-end (+ origin pagesize))
1819               (n (compute-line-count inspector))
1820               (end (min page-end n))
1821               (tag -1)
1822               (*print-pretty* (or *print-pretty* *describe-pretty*))
1823               (*print-length* 5)
1824               (*print-level* 5)
1825               (func #'(lambda (i index child &optional label-string value-string)
1826                         (declare (ignore i))
1827                         (when child (incf tag))
1828                         (unless (< index origin)
1829                           (format stream "~@[[~d]~]~8t" (and child tag))
1830                           (format-line-for-tty stream label-string value-string)
1831                           (terpri stream)))))
1832          (declare (dynamic-extent func))
1833          (map-lines inspector func 0 end)))
1834    (values)))
1835
1836(ccl::define-toplevel-command
1837    :tty-inspect i (n)
1838    "inspect <n>th item"
1839    (inspector-ui-inspect-nth *inspector-ui* n))
1840
1841(ccl::define-toplevel-command
1842    :tty-inspect pop ()
1843    "exit current inspector level"
1844    (invoke-restart 'exit-inspector))
1845
1846(ccl::define-toplevel-command
1847    :tty-inspect q ()
1848    "exit inspector"
1849  (invoke-restart 'end-inspect))
1850
1851(ccl::define-toplevel-command
1852    :tty-inspect show ()
1853    "re-show currently inspected object (the value of CCL:@)"
1854    (ui-present *inspector-ui*))
1855
1856(defmethod inspector-ui-next-page ((ui inspector-tty-ui))
1857  (let* ((nlines (compute-line-count (inspector-ui-inspector ui)))
1858         (origin (inspector-tty-ui-origin ui))
1859         (page-size (inspector-tty-ui-pagesize ui))
1860         (new-origin (+ origin page-size)))
1861    (if (< new-origin nlines)
1862      (setf (inspector-tty-ui-origin ui) new-origin))
1863    (ui-present ui)))
1864   
1865(ccl::define-toplevel-command
1866    :tty-inspect next ()
1867    "show next page of object data"
1868    (inspector-ui-next-page *inspector-ui*))
1869
1870(defmethod inspector-ui-prev-page ((ui inspector-tty-ui))
1871  (let* ((origin (inspector-tty-ui-origin ui))
1872         (page-size (inspector-tty-ui-pagesize ui))
1873         (new-origin (max 0 (- origin page-size))))
1874    (setf (inspector-tty-ui-origin ui) new-origin)
1875    (ui-present ui)))
1876
1877(ccl::define-toplevel-command
1878    :tty-inspect prev ()
1879    "show previous page of object data"
1880    (inspector-ui-prev-page *inspector-ui*))
1881
1882(ccl::define-toplevel-command
1883    :tty-inspect home ()
1884    "show first page of object data"
1885    (progn
1886      (setf (inspector-tty-ui-origin *inspector-ui*) 0)
1887      (ui-present *inspector-ui*)))
1888
1889(ccl::define-toplevel-command
1890    :tty-inspect s (n v)
1891    "set the <n>th line of object data to value <v>"
1892    (let* ((ui *inspector-ui*))
1893      (setf (line-n (inspector-ui-inspector ui) n) v)
1894      (ui-present ui)))
1895
1896
1897(defmethod ui-interact ((ui inspector-tty-ui))
1898  (let* ((level (inspector-ui-level ui))
1899         (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui))))))
1900    (declare (special ccl::*default-integer-command*))
1901    (restart-case
1902        (ccl:with-terminal-input
1903          (ccl::with-toplevel-commands :tty-inspect
1904            (ccl::read-loop
1905             :prompt-function #'(lambda (stream)
1906                                  (if (eql level 0)
1907                                    (format stream "~&Inspect> ")
1908                                    (format stream "~&Inspect ~d> " level))))))
1909      (exit-inspector ()
1910        (if *previous-inspector-ui*
1911          (ui-present *previous-inspector-ui*)
1912          (terpri *debug-io*))))))
1913
1914(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
1915  (let* ((inspector (inspector-ui-inspector ui))
1916         (new-inspector (block nil
1917                          (let* ((tag -1)
1918                                 (func #'(lambda (i index child &rest strings)
1919                                           (declare (ignore i index strings))
1920                                           (when (and child (eql (incf tag) n)) (return child)))))
1921                            (declare (dynamic-extent func))
1922                            (map-lines inspector func))))
1923         (ccl::@ (inspector-object new-inspector)))
1924    (inspector-ui-inspect
1925     (make-instance 'inspector-tty-ui
1926       :level (1+ (inspector-ui-level ui))
1927       :inspector new-inspector))))
1928
1929(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
1930
1931(defmethod inspector-ui-inspect ((ui inspector-ui))
1932  (let* ((*previous-inspector-ui* *inspector-ui*)
1933         (*inspector-ui* ui))
1934    (ui-initialize ui)
1935    (ui-present ui)
1936    (ui-interact ui)
1937    (values)))
1938
1939(defun tty-inspect (thing)
1940  (inspector-ui-inspect (make-instance *default-inspector-ui-class-name*
1941                                       :inspector (make-inspector thing)
1942                                         :level 0)))
1943
1944(defparameter *default-inspector-ui-creation-function* 'tty-inspect)
1945       
1946
1947(defun inspect (thing)
1948  (let* ((ccl::@ thing))
1949    (restart-case (funcall *default-inspector-ui-creation-function* thing)
1950      (end-inspect () thing))))
Note: See TracBrowser for help on using the repository browser.