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

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

fixes for slots with non-standard allocation (r12760,r12761,r12762,r12765, r12905)

  • 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#+x86-target
1375(defmethod prin1-value ((f function-inspector) stream value &optional data type)
1376  (declare (ignore value type))
1377  (if (atom data) ;; not a disassembly line
1378    (call-next-method)
1379    (princ (cdr data) stream)))
1380
1381
1382#+ppc-target
1383(defmethod prin1-value ((f function-inspector) stream value &optional label type)
1384  (if (atom label)                      ; not a disassembly line
1385    (unless (eq (if (consp type) (car type) type) :comment)
1386      (call-next-method))
1387    (let ((q (cdr label)))
1388      (write-char #\( stream)
1389      (loop (if (null q) (return))
1390        (ccl::disasm-prin1 (pop q) stream)
1391        (if q (write-char #\space stream)))
1392      (write-char #\) stream)))
1393  value)
1394
1395;; Generic-functions
1396;; Display the list of methods on a line of its own to make getting at them faster
1397;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
1398(defclass gf-inspector (function-inspector)
1399  ((method-count :accessor method-count)))
1400
1401(defmethod inspector-class ((f standard-generic-function))
1402  (if (functionp f) 
1403    'gf-inspector
1404    'standard-object-inspector))
1405
1406(defmethod compute-line-count :before ((f gf-inspector))
1407  (let* ((gf (inspector-object f))
1408         (count (length (generic-function-methods gf))))
1409    (setf (method-count f) count)))
1410
1411(defmethod header-count ((f gf-inspector))
1412  (+ (standard-header-count f) 1 (method-count f)))
1413
1414(defmethod line-n ((f gf-inspector) n)
1415  (let* ((count (method-count f))
1416         (methods (generic-function-methods (inspector-object f))))
1417    (cond ((< (decf n  (standard-header-count f)) 0)
1418           (call-next-method))
1419          ((< (decf n) 0)
1420           (values methods "Methods: " :comment))
1421          ((< n count)
1422           (values (nth n methods) nil :static))
1423          (t (disassembly-line-n f (- n count))))))
1424
1425(defmethod (setf line-n) (new-value (f gf-inspector) n)
1426  (let* ((count (method-count f))
1427         (en n))
1428    (cond ((< (decf n (standard-header-count f)) 0)
1429           (call-next-method))
1430          ((< (decf n) count)
1431           (setf-line-n-out-of-range f en))
1432          (t (set-disassembly-line-n f (- n count) new-value)))))
1433
1434#|
1435(defmethod inspector-commands ((f gf-inspector))
1436  (let* ((function (inspector-object f))
1437         (method (selected-object (inspector-view f))))
1438    (if (typep method 'method)
1439      (nconc
1440       (call-next-method)
1441       `(("Remove method"
1442         ,#'(lambda ()
1443              (remove-method function method)
1444              (resample-it)))))
1445      (call-next-method))))
1446|#
1447
1448;;;;;;;
1449;;
1450;; Structures
1451;;
1452(defmethod inspector-class ((s structure-object))
1453  'usual-basics-first-inspector)
1454
1455(defun structure-slots (s)
1456  (let ((slots (ccl::sd-slots (ccl::struct-def s))))
1457    (if (symbolp (caar slots))
1458      slots
1459      (cdr slots))))
1460
1461(defmethod compute-line-count ((s structure-object))
1462  (length (structure-slots s)))
1463
1464(defmethod line-n ((s structure-object) n)
1465  (let ((slot (nth n (structure-slots s))))
1466    (if slot
1467      (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon)
1468      (line-n-out-of-range s n))))
1469
1470(defmethod (setf line-n) (new-value (s structure-object) n)
1471  (let ((slot (nth n (structure-slots s))))
1472    (if slot
1473      (setf (uvref s (ccl::ssd-offset slot)) new-value)
1474      (setf-line-n-out-of-range s n))))
1475
1476
1477(defclass basic-stream-inspector (uvector-inspector) ())
1478
1479(defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector)
1480 
1481;;;;;;;
1482;;
1483;; packages
1484;;
1485(defclass package-inspector (uvector-inspector) ())
1486
1487(defmethod inspector-class ((p package)) 'package-inspector)
1488
1489(defmethod compute-line-count ((i package-inspector))
1490  (+ 2 (call-next-method)))
1491
1492(defmethod line-n ((i package-inspector) n)
1493  (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i)))
1494                           "Internal Symbols: " :static))
1495        ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i)))
1496                           "External Symbols: " :static))
1497        (t (call-next-method i (- n 2)))))
1498
1499(defmethod (setf line-n) (new-value (i package-inspector) n)
1500  (if (< n 2)
1501    (setf-line-n-out-of-range i n)
1502    (call-next-method new-value i (- n 2))))
1503
1504(defmethod inspector-commands ((i package-inspector))
1505  `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages))))
1506    (,(format nil "(setq *package* '~a" (inspector-object i))
1507     ,#'(lambda () (setq *package* (inspector-object i))))))
1508
1509;;;;;;;
1510;;
1511;; Records
1512;;
1513(defclass record-inspector (object-first-inspector)
1514  ((record-type :accessor record-type)
1515   (field-names :accessor field-names)
1516   (unlock :initform nil :accessor unlock)))
1517
1518(defmethod inspector-class ((o macptr))
1519  'record-inspector)
1520
1521
1522;;; Still needs work.
1523;;; Lots of work.
1524(defclass thread-inspector (uvector-inspector) ())
1525
1526(defmethod inspector-class ((thread ccl::lisp-thread))
1527  'thread-inspector)
1528
1529(defmethod compute-line-count :before ((i thread-inspector))
1530)
1531
1532(defmethod line-n ((thread thread-inspector) n)
1533  (declare (ignorable n))
1534  (call-next-method)
1535)
1536
1537#|
1538(defmethod line-n-inspector ((i thread-inspector) n value label type)
1539  (declare (ignore n type))
1540  (or (and value
1541           (macptrp value)
1542           (not (%null-ptr-p value)))
1543      (call-next-method)))
1544|#
1545
1546
1547(defmethod line-n-inspector (i n value label type)
1548  (declare (ignore i n label type))
1549  (make-inspector value))
1550
1551(defmethod line-n-inspector ((i usual-inspector) n value label type)
1552  (let ((object (inspector-object i)))
1553    (if (typep object 'usual-inspector)
1554      (make-inspector value)
1555      (line-n-inspector (inspector-object i) n value label type))))
1556
1557
1558
1559
1560;;;;;;;
1561;;
1562;; an ERROR-FRAME stores the stack addresses that the backtrace window displays
1563;;
1564
1565;; set to list of function you don't want to see
1566;; Functions can be symbols, nil for kernel, or #'functions
1567(defparameter *backtrace-internal-functions* 
1568  (list :kernel))
1569
1570(defvar *backtrace-hide-internal-functions-p* t)
1571
1572(defclass error-frame ()
1573  ((addresses :accessor addresses)
1574   (restart-info :accessor restart-info)
1575   (stack-start :initarg :stack-start  :reader stack-start)
1576   (stack-end :initarg :stack-end :reader stack-end)
1577   (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr)
1578   (context :initarg :context :reader context)
1579   (frame-count :accessor frame-count)
1580   (ignored-functions :accessor ignored-functions
1581                      :initform (and *backtrace-hide-internal-functions-p*
1582                                     *backtrace-internal-functions*))
1583   (break-condition :accessor break-condition
1584                    :initarg :break-condition)
1585   (unavailable-value-marker :initform (cons nil nil)
1586                             :accessor unavailable-value-marker)))
1587 
1588
1589
1590(defmethod initialize-instance ((f error-frame) &key)
1591  (call-next-method)
1592  (initialize-addresses f))
1593
1594(defmethod initialize-addresses ((f error-frame))
1595  (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector)))
1596      (setf (frame-count f) (length addresses)
1597            (addresses f) addresses)))
1598
1599(defmethod compute-frame-info ((f error-frame) n)
1600  (let* ((frame (svref (addresses f) n))
1601         (context (context f))
1602         (marker (unavailable-value-marker f)))
1603   
1604    (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame)
1605      (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker)
1606        (list (ccl::arglist-from-map lfun) args locals)))))
1607
1608(defun print-error-frame-limits (f stream)
1609  (format stream "#x~x - #x~x" (stack-start f) (stack-end f)))
1610
1611(defmethod print-object ((f error-frame) stream)
1612  (print-unreadable-object (f stream :type 'frame-ptr)
1613    (print-error-frame-limits f stream)))
1614
1615
1616
1617;;;;;;;
1618;;
1619;; The inspector for error-frame objects
1620;;
1621
1622
1623
1624;;; The "vsp-range" and "tsp-range" slots have to do with
1625;;; recognizing/validating stack-allocated objects
1626(defclass stack-inspector (inspector)
1627  ((vsp-range :accessor vsp-range :initarg :vsp-range)
1628   (tsp-range :accessor tsp-range :initarg :tsp-range)
1629   (csp-range :accessor csp-range :initarg :csp-range)))
1630
1631
1632
1633                           
1634(defmethod initialize-instance ((i stack-inspector) &rest initargs &key context)
1635  (declare (dynamic-extent initargs))
1636  (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context))
1637         (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context))
1638         (tcr (ccl::bt.tcr context)))
1639    (apply #'call-next-method
1640           i
1641           :object 
1642           (make-instance 'error-frame
1643             :stack-start start
1644             :stack-end end
1645             :tcr tcr
1646             :context context
1647             :break-condition (ccl::bt.break-condition context))
1648           :tsp-range (make-tsp-stack-range tcr context)
1649           :vsp-range (make-vsp-stack-range tcr context)
1650           :csp-range (make-csp-stack-range tcr context)
1651           initargs)))
1652
1653(defmethod print-object ((i stack-inspector) stream)
1654  (print-unreadable-object (i stream :type 'stack-inspector)
1655    (print-error-frame-limits (inspector-object i) stream)))
1656
1657(defmethod addresses ((f stack-inspector))
1658  (addresses (inspector-object f)))
1659
1660(defmethod compute-line-count ((f stack-inspector))
1661  (frame-count (inspector-object f)))
1662
1663(defmethod line-n ((f stack-inspector) n)
1664  (let* ((frame (svref (addresses (inspector-object f)) n)))
1665    (ccl::cfp-lfun frame)))
1666
1667
1668
1669 
1670
1671
1672;;; inspecting a single stack frame
1673;;; The inspector-object is expected to be an error-frame
1674(defclass stack-frame-inspector (inspector)
1675  ((frame-number :initarg :frame-number :initform nil :reader frame-number)
1676   (frame-info :initform nil :accessor frame-info)))
1677
1678
1679(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key
1680                                object frame-number)
1681  (declare (dynamic-extent initargs))
1682  (setq object (require-type object 'error-frame))
1683  (apply #'call-next-method i 
1684         :object object
1685         initargs)
1686  (setf (frame-number i) frame-number))
1687
1688   
1689
1690(defmethod compute-line-count ((i stack-frame-inspector))
1691  (let ((frame-number (frame-number i)))
1692    (if (null frame-number)
1693      0
1694      (let* ((error-frame (inspector-object i))
1695             (frame-info (or (frame-info i)
1696                             (setf (frame-info i) (compute-frame-info error-frame frame-number)))))
1697        (destructuring-bind (args locals) (cdr frame-info)
1698          (+ 1 (length args) 1 (length locals)))))))
1699
1700(defmethod line-n ((i stack-frame-inspector) n)
1701  (unless (< -1 n (inspector-line-count i))
1702    (line-n-out-of-range i n))
1703  (destructuring-bind (arglist args locals) (frame-info i)
1704    (if (zerop n)
1705      (values arglist nil :static)
1706      (let* ((nargs (length args)))
1707        (decf n)
1708        (if (< n nargs)
1709          (cons :arg (nth n args))
1710          (progn
1711            (decf n nargs)
1712            (if (zerop n)
1713              nil
1714              (cons :local (nth (1- n) locals)))))))))
1715
1716(defmethod (setf line-n) (value (i stack-frame-inspector) n)
1717  (declare (ignorable value n))
1718  (error "not yet!"))
1719
1720       
1721
1722
1723
1724(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type)
1725  (declare (ignore label type))
1726  (when value
1727    (if (or (atom value) (not (typep (car value) 'keyword)))
1728      (prin1 value stream)
1729      (progn
1730        (if (eq (car value) :arg)
1731          (format stream "   ")
1732          (format stream "  "))
1733        (when (cdr value)
1734          (destructuring-bind (label . val) (cdr value)
1735            (format stream "~a: " label)
1736            (if (eq val *unbound-marker*)
1737              (format stream "??")
1738              (prin1 val stream))))))))
1739
1740(defmethod (setf frame-number) (frame-number (i stack-frame-inspector))
1741  (let ((max (1- (frame-count (inspector-object i)))))
1742    (unless (or (null frame-number)
1743                (and (<= 0 frame-number max)))
1744      (setq frame-number (require-type frame-number `(or null (integer 0 ,max))))))
1745  (unless (eql frame-number (frame-number i))
1746    (setf (slot-value i 'frame-number) frame-number)
1747    (setf (inspector-line-count i) nil)
1748    frame-number))
1749
1750
1751;;; Each of these stack ranges defines the entire range of (control/value/temp)
1752;;; addresses; they can be used to addresses of stack-allocated objects
1753;;; for printing.
1754(defun make-tsp-stack-range (tcr bt-info)
1755  (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info))
1756              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area)
1757                                target::area.high))))
1758
1759#+ppc-target
1760(defun make-vsp-stack-range (tcr bt-info)
1761  (list (cons (ccl::%fixnum-ref
1762               (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell)
1763               target::lisp-frame.savevsp)
1764              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1765                                target::area.high))))
1766#+x8632-target
1767(defun make-vsp-stack-range (tcr bt-info)
1768  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.esp-cell)
1769              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1770                                target::area.high))))
1771
1772#+x8664-target
1773(defun make-vsp-stack-range (tcr bt-info)
1774  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell)
1775              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1776                                target::area.high))))
1777
1778#+ppc-target
1779(defun make-csp-stack-range (tcr bt-info)
1780  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell)
1781              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1782                                target::area.high))))
1783
1784#+x8632-target
1785(defun make-csp-stack-range (tcr bt-info)
1786  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
1787              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1788                                target::area.high))))
1789
1790#+x8664-target
1791(defun make-csp-stack-range (tcr bt-info)
1792  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
1793              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area)
1794                                target::area.high))))
1795
1796;;; Inspector
1797
1798
1799(defvar *inspector-ui* ())
1800(defvar *previous-inspector-ui* nil)
1801
1802(defclass inspector-ui ()
1803    ((inspector :initarg :inspector :accessor inspector-ui-inspector)
1804     (level :initarg :level :accessor inspector-ui-level)))
1805
1806(defclass inspector-tty-ui (inspector-ui)
1807    ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin)
1808     (pagesize :initarg :pagesize :initform 20 :accessor
1809               inspector-tty-ui-pagesize)))
1810
1811(defmethod ui-initialize ((ui inspector-tty-ui)))
1812
1813(defmethod ui-present ((ui inspector-tty-ui))
1814  (let* ((inspector (inspector-ui-inspector ui)))
1815    (with-errorfree-printing
1816        (let* ((stream *debug-io*)
1817               (origin (inspector-tty-ui-origin ui))
1818               (pagesize (inspector-tty-ui-pagesize ui))
1819               (page-end (+ origin pagesize))
1820               (n (compute-line-count inspector))
1821               (end (min page-end n))
1822               (tag -1)
1823               (*print-pretty* (or *print-pretty* *describe-pretty*))
1824               (*print-length* 5)
1825               (*print-level* 5)
1826               (func #'(lambda (i index child &optional label-string value-string)
1827                         (declare (ignore i))
1828                         (when child (incf tag))
1829                         (unless (< index origin)
1830                           (format stream "~@[[~d]~]~8t" (and child tag))
1831                           (format-line-for-tty stream label-string value-string)
1832                           (terpri stream)))))
1833          (declare (dynamic-extent func))
1834          (map-lines inspector func 0 end)))
1835    (values)))
1836
1837(ccl::define-toplevel-command
1838    :tty-inspect i (n)
1839    "inspect <n>th item"
1840    (inspector-ui-inspect-nth *inspector-ui* n))
1841
1842(ccl::define-toplevel-command
1843    :tty-inspect pop ()
1844    "exit current inspector level"
1845    (invoke-restart 'exit-inspector))
1846
1847(ccl::define-toplevel-command
1848    :tty-inspect q ()
1849    "exit inspector"
1850  (invoke-restart 'end-inspect))
1851
1852(ccl::define-toplevel-command
1853    :tty-inspect show ()
1854    "re-show currently inspected object (the value of CCL:@)"
1855    (ui-present *inspector-ui*))
1856
1857(defmethod inspector-ui-next-page ((ui inspector-tty-ui))
1858  (let* ((nlines (compute-line-count (inspector-ui-inspector ui)))
1859         (origin (inspector-tty-ui-origin ui))
1860         (page-size (inspector-tty-ui-pagesize ui))
1861         (new-origin (+ origin page-size)))
1862    (if (< new-origin nlines)
1863      (setf (inspector-tty-ui-origin ui) new-origin))
1864    (ui-present ui)))
1865   
1866(ccl::define-toplevel-command
1867    :tty-inspect next ()
1868    "show next page of object data"
1869    (inspector-ui-next-page *inspector-ui*))
1870
1871(defmethod inspector-ui-prev-page ((ui inspector-tty-ui))
1872  (let* ((origin (inspector-tty-ui-origin ui))
1873         (page-size (inspector-tty-ui-pagesize ui))
1874         (new-origin (max 0 (- origin page-size))))
1875    (setf (inspector-tty-ui-origin ui) new-origin)
1876    (ui-present ui)))
1877
1878(ccl::define-toplevel-command
1879    :tty-inspect prev ()
1880    "show previous page of object data"
1881    (inspector-ui-prev-page *inspector-ui*))
1882
1883(ccl::define-toplevel-command
1884    :tty-inspect home ()
1885    "show first page of object data"
1886    (progn
1887      (setf (inspector-tty-ui-origin *inspector-ui*) 0)
1888      (ui-present *inspector-ui*)))
1889
1890(ccl::define-toplevel-command
1891    :tty-inspect s (n v)
1892    "set the <n>th line of object data to value <v>"
1893    (let* ((ui *inspector-ui*))
1894      (setf (line-n (inspector-ui-inspector ui) n) v)
1895      (ui-present ui)))
1896
1897
1898(defmethod ui-interact ((ui inspector-tty-ui))
1899  (let* ((level (inspector-ui-level ui))
1900         (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui))))))
1901    (declare (special ccl::*default-integer-command*))
1902    (restart-case
1903        (ccl:with-terminal-input
1904          (ccl::with-toplevel-commands :tty-inspect
1905            (ccl::read-loop
1906             :prompt-function #'(lambda (stream)
1907                                  (if (eql level 0)
1908                                    (format stream "~&Inspect> ")
1909                                    (format stream "~&Inspect ~d> " level))))))
1910      (exit-inspector ()
1911        (if *previous-inspector-ui*
1912          (ui-present *previous-inspector-ui*)
1913          (terpri *debug-io*))))))
1914
1915(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
1916  (let* ((inspector (inspector-ui-inspector ui))
1917         (new-inspector (block nil
1918                          (let* ((tag -1)
1919                                 (func #'(lambda (i index child &rest strings)
1920                                           (declare (ignore i index strings))
1921                                           (when (and child (eql (incf tag) n)) (return child)))))
1922                            (declare (dynamic-extent func))
1923                            (map-lines inspector func))))
1924         (ccl::@ (inspector-object new-inspector)))
1925    (inspector-ui-inspect
1926     (make-instance 'inspector-tty-ui
1927       :level (1+ (inspector-ui-level ui))
1928       :inspector new-inspector))))
1929
1930(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
1931
1932(defmethod inspector-ui-inspect ((ui inspector-ui))
1933  (let* ((*previous-inspector-ui* *inspector-ui*)
1934         (*inspector-ui* ui))
1935    (ui-initialize ui)
1936    (ui-present ui)
1937    (ui-interact ui)
1938    (values)))
1939
1940(defun tty-inspect (thing)
1941  (inspector-ui-inspect (make-instance *default-inspector-ui-class-name*
1942                                       :inspector (make-inspector thing)
1943                                         :level 0)))
1944
1945(defparameter *default-inspector-ui-creation-function* 'tty-inspect)
1946       
1947
1948(defun inspect (thing)
1949  (let* ((ccl::@ thing))
1950    (restart-case (funcall *default-inspector-ui-creation-function* thing)
1951      (end-inspect () thing))))
Note: See TracBrowser for help on using the repository browser.