source: trunk/ccl/lib/describe.lisp @ 6926

Last change on this file since 6926 was 6926, checked in by gb, 13 years ago

Some (signigicant) stack-frame changes.

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