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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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