source: branches/qres/ccl/lib/describe.lisp @ 14172

Last change on this file since 14172 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

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