source: branches/objc-gf/ccl/lib/describe.lisp @ 6102

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

Start to (barely) conditionalize inspector stack stuff for x86-64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 74.8 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  (ignore-errors (ccl::%foreign-type-or-record name)))
1044
1045; Add arglist here.
1046(defun symbol-type-line (sym)
1047  (let ((types (list
1048                (cond ((constantp sym)
1049                       "Constant")
1050                      ((proclaimed-special-p sym)
1051                       "Special Variable")
1052                      ((boundp sym)
1053                       "Non-special Variable")
1054                      (t nil))
1055                (cond ((special-operator-p sym)
1056                       "Special Form")
1057                      ((macro-function sym)
1058                       "Macro")
1059                      ((fboundp sym)
1060                       "Function")
1061                      (t nil))
1062                (if (type-specifier-p sym) "Type Specifier")
1063                (if (record-type-p sym nil) "Record Type")
1064                (if (find-class sym nil) "Class Name")))
1065        flag)
1066    (with-output-to-string (s)
1067      (dolist (type types)
1068        (when type
1069          (if flag (write-string ", " s))
1070          (setq flag t)
1071          (write-string type s))))))
1072   
1073
1074(defmethod inspector-commands ((sym symbol))
1075  (let ((res nil))
1076    '(push (list "Documentation" #'(lambda () (show-documentation sym)))
1077          res)
1078    (let ((class (find-class sym nil)))
1079      (if class
1080        (push (list "Inspect Class" #'(lambda () (inspect class))) res)))
1081    (if (boundp sym)
1082      (push (list "MAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(makunbound ',sym)))
1083                                              (makunbound sym) (resample-it))))
1084            res))
1085    (if (fboundp sym)
1086      (push (list "FMAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(fmakunbound ',sym)))
1087                                               (fmakunbound sym) (resample-it))))
1088            res))
1089    '(if (record-type-p sym)
1090      (push (list "Inspect Record Type" #'(lambda () (inspect-record-type sym)))
1091            res))
1092    (nreverse res)))
1093
1094
1095(defmethod line-n-inspector ((sym symbol) n value label type)
1096  (declare (ignore label type))
1097  (setq n (normalize-line-number sym n))
1098  (if (eql n 7)
1099    (make-instance 'plist-inspector :symbol sym :object value)
1100    (call-next-method)))
1101
1102(defclass plist-inspector (inspector)
1103  ((symbol :initarg :symbol :reader plist-symbol)))
1104
1105(defmethod inspector-window-title ((i plist-inspector))
1106  (format nil "~a of ~s" 'plist (plist-symbol i)))
1107
1108(defmethod compute-line-count ((i plist-inspector))
1109  (+ 3 (/ (length (inspector-object i)) 2)))
1110
1111(defmethod line-n ((i plist-inspector) n)
1112  (let* ((plist (inspector-object i)))
1113    (cond ((eql 0 n) (values plist "Plist: "))
1114          ((eql 1 n) (values (plist-symbol i) "Symbol: " :static))
1115          ((eql 2 n) (values nil nil :comment))
1116          (t (let ((rest (nthcdr (* 2 (- n 3)) plist)))
1117               (values (cadr rest) (car rest) :colon))))))
1118
1119(defmethod (setf line-n) (new-value (i plist-inspector) n)
1120  (let* ((plist (inspector-object i)))
1121    (if (eql n 0)
1122      (replace-object i new-value)
1123      (if (< n 3)
1124        (setf-line-n-out-of-range i n)
1125        (let ((rest (nthcdr (* 2 (- n 3)) plist)))
1126          (setf (cadr rest) new-value)
1127          (resample-it))))))
1128
1129(defparameter *inspector-disassembly* nil)
1130
1131;;;;;;;
1132;;
1133;; Functions
1134;;
1135(defclass function-inspector (inspector)
1136  ((disasm-p :accessor disasm-p :initform *inspector-disassembly*)
1137   (disasm-info :accessor disasm-info)
1138   (pc-width :accessor pc-width)
1139   (pc :initarg :pc :initform nil :accessor pc)))
1140
1141(defclass closure-inspector (function-inspector)
1142  ((n-closed :accessor closure-n-closed)))
1143
1144
1145
1146(defmethod inspector-class ((f function)) 'function-inspector)
1147(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector)
1148
1149(defmethod compute-line-count ((f function-inspector))
1150  (+ 1                                  ; the function
1151     1                                  ; name
1152     1                                  ; arglist
1153     (compute-disassembly-lines f))) 
1154
1155(defmethod line-n ((f function-inspector) n)
1156  (let ((o (inspector-object f)))
1157    (case n
1158      (0 (values o ""))
1159      (1 (values (function-name o) "Name" :colon))
1160      (2 (multiple-value-bind (arglist type) (arglist o)
1161           (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown")))
1162             (values arglist label (if type :colon '(:comment (:plain)))))))
1163      (t (disassembly-line-n f (- n 3))))))
1164
1165(defmethod compute-line-count ((f closure-inspector))
1166  (let* ((o (inspector-object f))
1167         (nclosed (nth-value 8 (function-args (ccl::closure-function o)))))
1168    (setf (closure-n-closed f) nclosed)
1169    (+ (call-next-method)
1170       1                              ; the function we close over
1171       1                              ; "Closed over values"
1172       nclosed
1173       (if (disasm-p f) 1 0))))      ; "Disassembly"
1174
1175(defmethod line-n ((f closure-inspector) n)
1176  (let ((o (inspector-object f))
1177        (nclosed (closure-n-closed f)))
1178    (if (<= (decf n 2) 0)
1179      (call-next-method)
1180      (cond ((eql (decf n) 0)
1181             (values (ccl::closure-function o) "Inner lfun: " :static))
1182            ((eql (decf n) 0)
1183             (values nclosed "Closed over values" :comment #'prin1-comment))
1184            ((< (decf n) nclosed)
1185             (let* ((value (ccl::%svref o (1+ (- nclosed n))))
1186                    (map (car (ccl::function-symbol-map (ccl::closure-function o))))
1187                    (label (or (and map (svref map (+ n (- (length map) nclosed))))
1188                               n))
1189                    (cellp (ccl::closed-over-value-p value)))
1190               (when cellp
1191                 (setq value (ccl::closed-over-value value)
1192                       label (format nil "(~a)" label)))
1193               (values value label (if cellp :normal :static) #'prin1-colon-line)))
1194            ((eql (decf n nclosed) 0)
1195             (values 0 "Disassembly" :comment #'prin1-comment))
1196            (t (disassembly-line-n f (- n 1)))))))
1197
1198(defmethod (setf line-n) (new-value (f function-inspector) n)
1199  (let ((o (inspector-object f)))
1200    (case n
1201      (0 (replace-object f new-value))
1202      (1 (ccl::lfun-name o new-value) (resample-it))
1203      (2 (setf (arglist o) new-value))
1204      (t
1205       (if (>= n 3) 
1206         (set-disassembly-line-n f (- n 3) new-value)
1207         (setf-line-n-out-of-range f n)))))
1208  new-value)
1209
1210(defmethod (setf line-n) (new-value (f closure-inspector) en &aux (n en))
1211  (let ((o (inspector-object f))
1212        (nclosed (closure-n-closed f)))
1213    (if (<= (decf n 2) 0)               ; function itself, name, or arglist
1214      (call-next-method)
1215      (cond ((<= (decf n 2) 0)          ; inner-lfun or "Closed over values"
1216             (setf-line-n-out-of-range f en))
1217            ((< (decf n) nclosed)       ; closed-over variable
1218             (let* ((value (ccl::%svref o (1+ (- nclosed n))))
1219                    (cellp (ccl::closed-over-value-p value)))
1220               (unless cellp (setf-line-n-out-of-range f en))
1221               (ccl::set-closed-over-value value new-value)))
1222            ((eql (decf n nclosed) 0)   ; "Disassembly"
1223             (setf-line-n-out-of-range f en))
1224            (t (set-disassembly-line-n f (- n 1) new-value))))))
1225
1226(defun compute-disassembly-lines (f &optional (function (inspector-object f)))
1227  (if (functionp function)
1228    (let* ((info (and (disasm-p f) #+ppc-target (list-to-vector (ccl::disassemble-list function))))
1229           (length (length info))
1230           (last-pc (if info (car (svref info (1- length))) 0)))
1231      (if (listp last-pc) (setq last-pc (cadr last-pc)))
1232      (setf (pc-width f) (length (format nil "~d" last-pc)))
1233      (setf (disasm-info f) info)
1234      length)
1235    0))
1236
1237(defun list-to-vector (list)
1238  (let* ((length (length list))
1239         (vec (make-array length)))
1240    (dotimes (i length)
1241      (declare (fixnum i))
1242      (setf (svref vec i) (pop list)))
1243    vec))
1244
1245(defun disassembly-line-n (f n)
1246  (let* ((line (svref (disasm-info f) n))
1247         (value (disasm-line-immediate line)))
1248    (values value line (if value :static :comment))))
1249
1250(defun set-disassembly-line-n (f n new-value &optional 
1251                                 (function (inspector-object f)))
1252  (declare (ignore new-value function))
1253  (setf-line-n-out-of-range f n))
1254
1255(defun disasm-line-immediate (line &optional (lookup-functions t))
1256  (pop line)                        ; remove address
1257  (when (eq (car line) 'ccl::jsr_subprim)
1258    (return-from disasm-line-immediate (find-symbol (cadr line) :ccl)))
1259  (let ((res nil))
1260    (labels ((inner-last (l)
1261               (cond ((atom l) l)
1262                     ((null (cdr l)) (car l))
1263                     (t (inner-last (last l))))))
1264      (dolist (e line)
1265        (cond ((numberp e) (when (null res) (setq res e)))
1266              ((consp e)
1267               (cond ((eq (car e) 'function)
1268                      (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
1269                     ((eq (car e) 17)   ; locative
1270                      (setq e (cadr e))
1271                      (unless (atom e)
1272                        (cond ((eq (car e) 'special) 
1273                               (setq res (cadr e)))
1274                              ((eq (car e) 'function) 
1275                               (setq res (or (and lookup-functions (fboundp (cadr e))) (cadr e))))
1276                              (t (setq res (inner-last e))))))
1277                     ((or (null res) (numberp res))
1278                      (setq res (inner-last e))))))))
1279    res))
1280
1281(defmethod inspector-print-function ((i function-inspector) type)
1282  (declare (ignore type))
1283  'prin1-normal-line)
1284
1285(defmethod prin1-label ((f function-inspector) stream value &optional label type)
1286  (declare (ignore value type))
1287  (if (atom label)                      ; not a disassembly line
1288    (call-next-method)
1289    (let* ((pc (car label))
1290           (label-p (and (listp pc) (setq pc (cadr pc))))
1291           (pc-mark (pc f)))
1292      (if (eq pc pc-mark)
1293        (format stream "*~vd" (pc-width f) pc)
1294        (format stream "~vd" (+ (pc-width f) (if pc-mark 1 0)) pc))
1295      (write-char (if label-p #\= #\ ) stream))))
1296
1297#+ppc-target
1298(defmethod prin1-value ((f function-inspector) stream value &optional label type)
1299  (if (atom label)                      ; not a disassembly line
1300    (unless (eq (if (consp type) (car type) type) :comment)
1301      (call-next-method))
1302    (let ((q (cdr label)))
1303      (write-char #\( stream)
1304      (loop (if (null q) (return))
1305        (ccl::disasm-prin1 (pop q) stream)
1306        (if q (write-char #\space stream)))
1307      (write-char #\) stream)))
1308  value)
1309
1310;; Generic-functions
1311;; Display the list of methods on a line of its own to make getting at them faster
1312;; (They're also inside the dispatch-table which is the first immediate in the disassembly).
1313(defclass gf-inspector (function-inspector)
1314  ((method-count :accessor method-count)
1315   (slot-count :accessor slot-count :initform 0)))
1316
1317(defmethod inspector-class ((f standard-generic-function))
1318  (if (functionp f) 
1319    'gf-inspector
1320    'standard-object-inspector))
1321
1322(defmethod compute-line-count ((f gf-inspector))
1323  (let* ((gf (inspector-object f))
1324         (count (length (generic-function-methods gf)))
1325         (res (+ 1 (setf (method-count f) count) 
1326                 (call-next-method))))
1327    (if (disasm-p f) (1+ res) res)))
1328
1329(defmethod line-n ((f gf-inspector) n)
1330  (let* ((count (method-count f))
1331         (slot-count (slot-count f))
1332         (lines (1+ count)))
1333    (if (<= 3 n (+ lines slot-count 3))
1334      (let ((methods (generic-function-methods (inspector-object f))))
1335        (cond ((eql (decf n 3) 0) (values methods "Methods: " :static))
1336              ((<= n count)
1337               (values (nth (- n 1) methods) nil :static))
1338              ((< (decf n (1+ count)) slot-count)
1339               (standard-object-line-n f n))
1340              (t
1341               (values 0 "Disassembly" :comment #'prin1-comment))))
1342      (call-next-method f (if (< n 3) n (- n lines slot-count 1))))))
1343
1344(defmethod (setf line-n) (new-value (f gf-inspector) n)
1345  (let* ((count (method-count f))
1346         (slot-count (slot-count f))
1347         (lines (1+ count)))
1348    (if (<= 3 n (+ lines slot-count 3))
1349      (let ((en n))
1350        (cond ((<= (decf en 3) count)
1351               (setf-line-n-out-of-range f n))
1352              ((< (decf en (1+ count)) slot-count)
1353               (standard-object-setf-line-n new-value f en))
1354              (t (setf-line-n-out-of-range f n))))
1355      (call-next-method new-value f (if (< n 3) n (- n lines slot-count 1))))))
1356
1357#|
1358(defmethod inspector-commands ((f gf-inspector))
1359  (let* ((function (inspector-object f))
1360         (method (selected-object (inspector-view f))))
1361    (if (typep method 'method)
1362      (nconc
1363       (call-next-method)
1364       `(("Remove method"
1365         ,#'(lambda ()
1366              (remove-method function method)
1367              (resample-it)))))
1368      (call-next-method))))
1369|#
1370
1371(defclass method-inspector (standard-object-inspector function-inspector)
1372  ((standard-object-lines :accessor standard-object-lines)))
1373
1374(defmethod inspector-class ((object standard-method))
1375  'method-inspector)
1376
1377(defmethod compute-line-count ((i method-inspector))
1378  (+ (setf (standard-object-lines i) (call-next-method))
1379     (if (disasm-p i) 1 0)              ; "Disassembly"
1380     (compute-disassembly-lines i (method-function (inspector-object i)))))
1381
1382(defmethod line-n ((i method-inspector) n)
1383  (let ((sol (standard-object-lines i)))
1384    (cond ((< n sol) (call-next-method))
1385          ((eql n sol) (values nil "Disassembly" :comment))
1386          (t (disassembly-line-n i (- n sol 1))))))
1387
1388(defmethod (setf line-n) (new-value (i method-inspector) n)
1389  (let ((sol (standard-object-lines i)))
1390    (cond ((< n sol) (call-next-method))
1391          ((eql n sol) (setf-line-n-out-of-range i n))
1392          (t (set-disassembly-line-n
1393              i n new-value (method-function (inspector-object i)))))))
1394
1395;;; funtion-inspector never does prin1-comment.
1396(defmethod prin1-normal-line ((i method-inspector) stream value &optional
1397                              label type colon-p)
1398  (declare (ignore colon-p))
1399  (if (eq type :comment)
1400    (prin1-comment i stream value label type)
1401    (call-next-method)))
1402
1403
1404;;;;;;;
1405;;
1406;; Structures
1407;;
1408(defmethod inspector-class ((s structure-object))
1409  'usual-basics-first-inspector)
1410
1411(defun structure-slots (s)
1412  (let ((slots (ccl::sd-slots (ccl::struct-def s))))
1413    (if (symbolp (caar slots))
1414      slots
1415      (cdr slots))))
1416
1417(defmethod compute-line-count ((s structure-object))
1418  (length (structure-slots s)))
1419
1420(defmethod line-n ((s structure-object) n)
1421  (let ((slot (nth n (structure-slots s))))
1422    (if slot
1423      (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon)
1424      (line-n-out-of-range s n))))
1425
1426(defmethod (setf line-n) (new-value (s structure-object) n)
1427  (let ((slot (nth n (structure-slots s))))
1428    (if slot
1429      (setf (uvref s (ccl::ssd-offset slot)) new-value)
1430      (setf-line-n-out-of-range s n))))
1431
1432
1433(defclass basic-stream-inspector (uvector-inspector) ())
1434
1435(defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector)
1436 
1437;;;;;;;
1438;;
1439;; packages
1440;;
1441(defclass package-inspector (uvector-inspector) ())
1442
1443(defmethod inspector-class ((p package)) 'package-inspector)
1444
1445(defmethod compute-line-count ((i package-inspector))
1446  (+ 2 (call-next-method)))
1447
1448(defmethod line-n ((i package-inspector) n)
1449  (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i)))
1450                           "Internal Symbols: " :static))
1451        ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i)))
1452                           "External Symbols: " :static))
1453        (t (call-next-method i (- n 2)))))
1454
1455(defmethod (setf line-n) (new-value (i package-inspector) n)
1456  (if (< n 2)
1457    (setf-line-n-out-of-range i n)
1458    (call-next-method new-value i (- n 2))))
1459
1460(defmethod inspector-commands ((i package-inspector))
1461  `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages))))
1462    (,(format nil "(setq *package* '~a" (inspector-object i))
1463     ,#'(lambda () (setq *package* (inspector-object i))))))
1464
1465;;;;;;;
1466;;
1467;; Records
1468;;
1469(defclass record-inspector (object-first-inspector)
1470  ((record-type :accessor record-type)
1471   (field-names :accessor field-names)
1472   (unlock :initform nil :accessor unlock)))
1473
1474(defmethod inspector-class ((o macptr))
1475  'record-inspector)
1476
1477
1478;;; Still needs work.
1479(defclass thread-inspector (uvector-inspector) ())
1480
1481(defmethod inspector-class ((thread ccl::lisp-thread))
1482  'thread-inspector)
1483
1484(defmethod compute-line-count :before ((i thread-inspector))
1485  (when (eq (inspector-object i) ccl::*current-lisp-thread*)
1486    (ccl::%normalize-areas)))
1487
1488(defmethod line-n ((thread thread-inspector) n)
1489  (declare (ignore n))
1490  (multiple-value-bind (value label type) (call-next-method)
1491    (values
1492     (or (and (fixnump value)
1493              (>= value 0)
1494              (memq label '(ccl::sg.xframe ccl::sg.cs-area ccl::sg.vs-area
1495                            ccl::sg.ts-area ccl::sg.cs-overflow-limit))
1496              (%int-to-ptr (ash value 2)))
1497         value)
1498     label
1499     type)))
1500
1501#|
1502(defmethod line-n-inspector ((i thread-inspector) n value label type)
1503  (declare (ignore n type))
1504  (or (and value
1505           (macptrp value)
1506           (not (%null-ptr-p value)))
1507      (call-next-method)))
1508|#
1509
1510
1511(defmethod line-n-inspector (i n value label type)
1512  (declare (ignore i n label type))
1513  (make-inspector value))
1514
1515(defmethod line-n-inspector ((i usual-inspector) n value label type)
1516  (let ((object (inspector-object i)))
1517    (if (typep object 'usual-inspector)
1518      (make-inspector value)
1519      (line-n-inspector (inspector-object i) n value label type))))
1520
1521
1522
1523#+ppc-target
1524(progn
1525;;;;;;;
1526;;
1527;; an ERROR-FRAME stores the stack addresses that the backtrace window displays
1528;;
1529
1530;; set to list of function you don't want to see
1531;; Functions can be symbols, nil for kernel, or #'functions
1532(defparameter *backtrace-internal-functions* 
1533  (list :kernel))
1534
1535(defvar *backtrace-hide-internal-functions-p* t)
1536
1537(defclass error-frame ()
1538  ((addresses :accessor addresses)
1539   (restart-info :accessor restart-info)
1540   (sampling-period :initarg :sampling-period :initform 32 :reader sampling-period)
1541   (stack-start :initarg :stack-start :initform (ccl::%get-frame-ptr) :reader stack-start)
1542   (stack-end :initarg :stack-end :initform (ccl::last-frame-ptr) :reader stack-end)
1543   (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr)
1544   (context :initarg :context :reader context)
1545   (frame-count :accessor frame-count)
1546   (ignored-functions :accessor ignored-functions
1547                      :initform (and *backtrace-hide-internal-functions-p*
1548                                     *backtrace-internal-functions*))
1549   (break-condition :accessor break-condition
1550                    :initarg :break-condition)))
1551 
1552
1553; This is set up to access the result of
1554; (multiple-value-call #'vector (ccl::parent-frame-saved-vars ...))
1555(ccl::def-accessors svref
1556  %sv.frame
1557  %sv.last-catch
1558  %sv.srv)
1559
1560
1561
1562(defun ignore-function-in-backtrace? (error-frame function)
1563  (loop for ignored-fn in (ignored-functions error-frame)
1564        when (and (null function) (eq ignored-fn :kernel)) return t
1565        when (and (symbolp ignored-fn) (eq (function-name function) ignored-fn)) return t
1566        when (eq ignored-fn function) return t
1567        finally (return nil)))
1568
1569; use parent-frame-saved-vars to cons a vector for each element of ADDRESSES
1570(defmethod initialize-instance ((f error-frame) &key)
1571  (call-next-method)
1572  (initialize-addresses f))
1573
1574(defmethod initialize-addresses ((f error-frame))
1575  (let ((end (stack-end f)))
1576    (flet ((skip-to-important-frame (frame context)
1577             (loop for this? = (or (eq frame end)
1578                                   (not (ignore-function-in-backtrace?
1579                                         f
1580                                         (ccl::cfp-lfun frame))))
1581                   until this?
1582                   do (setf frame (ccl::parent-frame frame context))
1583                   finally (return frame))))
1584      (setf (slot-value f 'stack-start)
1585            (skip-to-important-frame (stack-start f) (context f)))))
1586  (let* ((count 0)
1587         (context (context f))
1588         (p (stack-start f))
1589         (p-child (ccl::child-frame p context))
1590         (q (stack-end f))
1591         (period (sampling-period f))
1592         (addresses nil)
1593         (last-frame nil))
1594    (multiple-value-bind (frame catch srv)
1595        (ccl::last-catch-since-saved-vars p-child context)
1596      (loop
1597        (if (null frame) (error "Can't find saved vars info"))
1598        (if (eq frame p-child) (return))
1599        (multiple-value-setq (frame catch srv)
1600          (ccl::parent-frame-saved-vars context frame catch srv srv)))
1601      (push (vector p-child catch (ccl::copy-srv srv))
1602            addresses)
1603      (setq last-frame frame)
1604      (multiple-value-setq (frame catch srv)
1605        (ccl::parent-frame-saved-vars context frame catch srv srv))
1606      (unless (eq frame p) (error "(~s (~s ~d)) <> ~d"
1607                                  'ccl::parent-frame 'ccl::child-frame p p))
1608      (push (vector frame catch (ccl::copy-srv srv))
1609            addresses)
1610      (flet ((done-p ()
1611               (or (null frame) (eql last-frame q))))
1612        (block loop
1613          (do* ((cnt (1+ period)))
1614               ((done-p))
1615            (loop while (ignore-function-in-backtrace?
1616                         f (ccl::cfp-lfun frame))
1617                  do 
1618                  (setq last-frame frame)
1619                  (multiple-value-setq (frame catch srv)
1620                    (ccl::parent-frame-saved-vars context frame catch srv srv))
1621                  (when (done-p) (return-from loop)))
1622            (when (eql 0 (decf cnt))
1623              (setq cnt period)
1624              (push (vector frame catch (ccl::copy-srv srv))
1625                    addresses))
1626            (setq last-frame frame)
1627            (multiple-value-setq (frame catch srv)
1628              (ccl::parent-frame-saved-vars context frame catch srv srv))
1629            (incf count))))
1630      (setf (frame-count f) count
1631            (addresses f) (list-to-vector (nreverse addresses))))))
1632
1633(defun error-frame-n (error-frame n)
1634  (let* ((addresses (addresses error-frame))
1635         (period (sampling-period error-frame))
1636         (context (context error-frame))
1637         p child)
1638    (flet ((skipping-uninteresting-parent-frames (child)
1639            (loop while (ignore-function-in-backtrace? 
1640                         error-frame (ccl::cfp-lfun (ccl::parent-frame child context)))
1641                  do (setq child (ccl::parent-frame child context))
1642                  finally (return child))))
1643      (unless (< -1 n (frame-count error-frame))
1644        (setq n (require-type n `(integer 0 ,(1- (frame-count error-frame))))))
1645      (if (eql 0 n)
1646        (setq child (%sv.frame (svref addresses 0))
1647              p (%sv.frame (svref addresses 1)))
1648        (multiple-value-bind (idx offset) (floor (1- n) period)
1649          (setq child (skipping-uninteresting-parent-frames 
1650                       (%sv.frame (svref addresses (1+ idx)))))
1651          (dotimes (i offset)
1652            (declare (fixnum i))
1653            (setq child (skipping-uninteresting-parent-frames 
1654                         (ccl::parent-frame child context))))
1655          (setq p (ccl::parent-frame child context))))
1656      (values p child))))
1657
1658(defmethod error-frame-address-n ((f error-frame) n)
1659  (multiple-value-bind (p child) (error-frame-n f n)
1660    (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
1661      (values p lfun pc child))))
1662
1663; Returns 6 values:
1664; p lfun pc child last-catch srv
1665; Where the last-catch & register values are those for the CHILD's frame
1666; (the ones we need to look at to display values for frame P).
1667(defmethod error-frame-regs-n ((f error-frame) n)
1668  (let* ((addresses (addresses f))
1669         (period (sampling-period f))
1670         (context (context f))
1671         p child last-catch srv)
1672    (unless (< -1 n (frame-count f))
1673      (setq n (require-type n `(integer 0 ,(1- (frame-count f))))))
1674    (if (eql 0 n)
1675      (let ((child-sv (svref addresses 0)))
1676        (setq child (%sv.frame child-sv)
1677              last-catch (%sv.last-catch child-sv)
1678              srv (ccl::copy-srv (%sv.srv child-sv))))
1679      (multiple-value-bind (idx offset) (floor (1- n) period)
1680        (let ((child-sv (svref addresses (1+ idx))))
1681          (setq child (%sv.frame child-sv)
1682                last-catch (%sv.last-catch child-sv)
1683                srv (ccl::copy-srv (%sv.srv child-sv))))
1684        (flet ((maybe-ignore ()
1685                 (loop while (ignore-function-in-backtrace? 
1686                              f
1687                              (ccl::cfp-lfun (ccl::parent-frame child context))) 
1688                     do (multiple-value-setq (child last-catch srv)
1689                          (ccl::parent-frame-saved-vars context child last-catch srv srv)))))
1690         (maybe-ignore)
1691           (dotimes (i offset)
1692             (declare (fixnum i))
1693             (multiple-value-setq (child last-catch srv)
1694               (ccl::parent-frame-saved-vars context child last-catch srv srv))
1695            (maybe-ignore)
1696            ))))
1697    (unless child (error "shouldn't happen"))
1698    (setq p (ccl::parent-frame child context))
1699    (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
1700      (values p lfun pc child last-catch srv))))
1701     
1702
1703(defun print-error-frame-limits (f stream)
1704  (format stream "#x~x - #x~x" (stack-start f) (stack-end f)))
1705
1706(defmethod print-object ((f error-frame) stream)
1707  (print-unreadable-object (f stream :type 'frame-ptr)
1708    (print-error-frame-limits f stream)))
1709
1710
1711
1712;;;;;;;
1713;;
1714;; The inspector for error-frame objects
1715;;
1716
1717;;; True to show more info about backtrace frames
1718(defvar *show-backtrace-frame-addresses* nil)
1719
1720(defclass stack-inspector (inspector)
1721  ((show-frame-addresses :initform *show-backtrace-frame-addresses*
1722                         :accessor show-frame-addresses)
1723   (vsp-range :accessor vsp-range :initarg :vsp-range)
1724   (tsp-range :accessor tsp-range :initarg :tsp-range)))
1725
1726
1727
1728                           
1729(defmethod initialize-instance ((i stack-inspector) &rest initargs &key context)
1730  (declare (dynamic-extent initargs))
1731  (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context))
1732         (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context))
1733         (tcr (ccl::bt.tcr context)))
1734    (apply #'call-next-method
1735           i
1736           :object 
1737           (make-instance 'error-frame
1738             :stack-start start
1739             :stack-end end
1740             :tcr tcr
1741             :context context
1742             :break-condition (ccl::bt.break-condition context))
1743           :tsp-range (make-tsp-stack-range tcr context)
1744           :vsp-range (make-vsp-stack-range tcr context)
1745           initargs)))
1746
1747(defmethod print-object ((i stack-inspector) stream)
1748  (print-unreadable-object (i stream :type 'stack-inspector)
1749    (print-error-frame-limits (inspector-object i) stream)))
1750
1751(defmethod addresses ((f stack-inspector))
1752  (addresses (inspector-object f)))
1753
1754(defmethod error-frame-address-n ((f stack-inspector) n)
1755  (error-frame-address-n (inspector-object f) n))
1756
1757(defmethod error-frame-regs-n ((f stack-inspector) n)
1758  (error-frame-regs-n (inspector-object f) n))
1759
1760(defmethod compute-line-count ((f stack-inspector))
1761  (setf (show-frame-addresses f) *show-backtrace-frame-addresses*)
1762  (frame-count (inspector-object f)))
1763
1764(defmethod line-n ((f stack-inspector) n)
1765  (multiple-value-bind (p lfun) (error-frame-address-n (inspector-object f) n)
1766    (values lfun 
1767            (if (show-frame-addresses f) p n)
1768            (if lfun :static '(:comment (:bold) (:plain :italic))) 'prin1-colon-line)))
1769
1770(defmethod prin1-label ((i stack-inspector) stream value &optional label type)
1771  (declare (ignore value type))
1772  (if (show-frame-addresses i)
1773    (format stream "#x~x/#x~x"
1774            (ccl::index->address label) (ccl::index->address (ccl::%frame-savevsp label)))
1775    (call-next-method)))
1776
1777(defmethod prin1-value ((i stack-inspector) stream value &optional label type)
1778  (declare (ignore label type))
1779  (if value
1780    (ccl::%lfun-name-string value stream)
1781    (write-string "kernel" stream)))
1782
1783(defmethod line-n-inspector ((f stack-inspector) n value label type)
1784  (declare (ignore value label type))
1785  (multiple-value-bind (p lfun pc) (error-frame-address-n (inspector-object f) n)
1786    (declare (ignore p))
1787    (make-instance (inspector-class lfun) :object lfun :pc pc)))
1788
1789;;; inspecting a single stack frame
1790;;; The inspector-object is expected to be an error-frame
1791(defclass stack-frame-inspector (inspector)
1792  ((frame-number :initarg :frame-number :initform nil :reader frame-number)
1793   (frame-info :accessor frame-info)
1794   (label-columns :accessor label-columns)
1795   (saved-register-count :accessor saved-register-count)))
1796
1797
1798(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key
1799                                object frame-number)
1800  (declare (dynamic-extent initargs))
1801  (setq object (require-type object 'error-frame))
1802  (apply #'call-next-method i 
1803         :object object
1804         initargs)
1805  (setf (frame-number i) frame-number))
1806
1807(defun integer-digits (integer &optional (base 10))
1808  (setq integer (require-type integer 'fixnum))
1809  (do ((digits (if (< integer 0) 2 1) (1+ digits))
1810       (n (abs integer) (floor n base)))
1811      ((if (< n base) (return digits)))))   
1812
1813(defmethod compute-line-count ((i stack-frame-inspector))
1814  (let ((frame-number (frame-number i)))
1815    (if (null frame-number)
1816      0
1817      (let* ((error-frame (inspector-object i))
1818             (frame-info (multiple-value-list 
1819                          (error-frame-regs-n error-frame frame-number))))
1820        (setf (frame-info i) frame-info)
1821        (let ((count (ccl::count-values-in-frame
1822                      (car frame-info)          ; this frame
1823                      (context error-frame)
1824                      (cadddr frame-info))))    ; child frame
1825          (setf (label-columns i) (integer-digits count))
1826          (let ((lfun (cadr frame-info))
1827                (pc (caddr frame-info)))
1828            (declare (ignore p))
1829            (+ count (setf (saved-register-count i)
1830                           (logcount (or (ccl::registers-used-by lfun pc) 0))))))))))
1831
1832(defmethod line-n ((i stack-frame-inspector) n)
1833  (unless (< -1 n (inspector-line-count i))
1834    (line-n-out-of-range i n))
1835  (let ((frame-info (frame-info i))
1836        (saved-register-count (saved-register-count i)))
1837    (if (< n saved-register-count)
1838      (multiple-value-bind (mask regs) (apply #'ccl::saved-register-values (cdr frame-info))
1839        (let* ((srv (nth 5 frame-info))
1840               (unresolved (ccl::srv.unresolved srv))
1841               (j ccl::*saved-register-count*)
1842               (i n))
1843          (loop
1844            (loop (if (logbitp (decf j) mask) (return)))
1845            (if (< (decf i) 0) (return)))
1846          (let ((name (saved-register-name
1847                       (elt ccl::*saved-register-numbers* (- ccl::*saved-register-count* 1 j)) (cadr frame-info) (caddr frame-info))))
1848            (values (if (setq unresolved (logbitp j unresolved))
1849                      *unbound-marker*
1850                      (ccl::srv.register-n regs (- ccl::*saved-register-count* 1 j)))
1851                    (cons n
1852                          (cons (elt ccl::*saved-register-names* j) name))
1853                    (if unresolved :static :normal)))))
1854      (destructuring-bind (p lfun pc &rest rest) frame-info
1855        (declare (ignore rest))
1856        (let ((offset (- n saved-register-count)))
1857          (multiple-value-bind (var type name)
1858                               (ccl::nth-value-in-frame p offset (context (inspector-object i)) lfun pc)
1859            (values var (cons n (cons type name)) :normal)))))))
1860
1861(defmethod (setf line-n) (value (i stack-frame-inspector) n)
1862  (unless (< -1 n (inspector-line-count i))
1863    (line-n-out-of-range i n))
1864  (let ((frame-info (frame-info i))
1865        (saved-register-count (saved-register-count i)))
1866    (if (< n saved-register-count)
1867      (let* ((mask (apply #'ccl::saved-register-values (cdr frame-info)))
1868             (srv (nth 5 frame-info))
1869             (unresolved (ccl::srv.unresolved srv))
1870             (j ccl::*saved-register-count*)
1871             (i n))
1872        (loop
1873          (loop (if (logbitp (decf j) mask) (return)))
1874          (if (< (decf i) 0) (return)))
1875        (if (logbitp j unresolved) (line-n-out-of-range i n))
1876        (apply #'ccl::set-saved-register value (- ccl::*saved-register-count* 1 j) (cdr frame-info)))
1877      (destructuring-bind (p lfun pc child &rest rest) frame-info
1878        (declare (ignore lfun pc rest))
1879        (let ((offset (- n saved-register-count))
1880              (context (context (inspector-object i))))
1881          (ccl::set-nth-value-in-frame p offset context value child))))))
1882
1883(defun saved-register-name (reg lfun pc)
1884  (let* ((map (ccl::function-symbol-map lfun))
1885         (names (car map))
1886         (info (cdr map))
1887         (j 0))
1888    (dotimes (i (length names))
1889      (when (and (eq reg (aref info j))
1890                 (<= (aref info (1+ j)) pc (aref info (+ j 2))))
1891        (return (aref names i)))
1892      (incf j 3))))
1893       
1894
1895(defmethod prin1-label ((i stack-frame-inspector) stream value &optional label type)
1896  (declare (ignore value type))
1897  (format stream "~vd: " (label-columns i) (car label)))
1898
1899(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type)
1900  (declare (ignore type))
1901  (destructuring-bind (n type . name) label
1902    (declare (ignore n))
1903    (if name (format stream "~s " name))
1904    (if type (format stream "(~a) " type))
1905    (if (eq value *unbound-marker*)
1906      (format stream "??")
1907      (prin1 value stream))))
1908
1909(defmethod (setf frame-number) (frame-number (i stack-frame-inspector))
1910  (let ((max (1- (frame-count (inspector-object i)))))
1911    (unless (or (null frame-number)
1912                (and (<= 0 frame-number max)))
1913      (setq frame-number (require-type frame-number `(or null (integer 0 ,max))))))
1914  (unless (eql frame-number (frame-number i))
1915    (setf (slot-value i 'frame-number) frame-number)
1916    (setf (inspector-line-count i) nil)
1917    frame-number))
1918)
1919
1920(defun make-tsp-stack-range (tcr bt-info)
1921  (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info))
1922              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area)
1923                                target::area.high))))
1924
1925#+ppc-target
1926(defun make-vsp-stack-range (tcr bt-info)
1927  (list (cons (ccl::%fixnum-ref
1928               (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell)
1929               target::lisp-frame.savevsp)
1930              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1931                                target::area.high))))
1932
1933#+x8664-target
1934(defun make-vsp-stack-range (tcr bt-info)
1935  (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell)
1936              (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area)
1937                                target::area.high))))
1938
1939
1940;;; Inspector
1941
1942
1943(defvar *inspector-ui* ())
1944
1945(defclass inspector-ui ()
1946    ((inspector :initarg :inspector :accessor inspector-ui-inspector)
1947     (level :initarg :level :accessor inspector-ui-level)))
1948
1949(defclass inspector-tty-ui (inspector-ui)
1950    ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin)
1951     (pagesize :initarg :pagesize :initform 20 :accessor
1952               inspector-tty-ui-pagesize)))
1953
1954(defmethod ui-initialize ((ui inspector-tty-ui)))
1955
1956(defmethod ui-present ((ui inspector-tty-ui))
1957  (let* ((inspector (inspector-ui-inspector ui)))
1958    (when (null (inspector-line-count inspector))
1959      (update-line-count inspector))
1960    (with-errorfree-printing
1961        (let* ((stream *debug-io*)
1962               (origin (inspector-tty-ui-origin ui))
1963               (pagesize (inspector-tty-ui-pagesize ui))
1964               (page-end (+ origin pagesize))
1965               (n (compute-line-count inspector))
1966               (end (min page-end n))
1967               (tag origin)
1968               (*print-pretty* (or *print-pretty* *describe-pretty*))
1969               (*print-length* 5)
1970               (*print-level* 5)
1971               (func #'(lambda (i value &rest rest)
1972                         (declare (dynamic-extent rest))
1973                         (let* ((type (cadr rest)))
1974                           (unless (or (eq type :comment)
1975                                   (and (consp type)
1976                                        (eq (car type) :comment)))
1977                             (format stream "[~d] " tag))
1978                           (incf tag))
1979                         (format stream "~8t")
1980                         (apply #'prin1-line i stream value rest)
1981                         (terpri stream))))
1982          (declare (dynamic-extent func))
1983          (map-lines inspector func origin end)))
1984    (values)))
1985
1986(ccl::define-toplevel-command
1987    :tty-inspect i (n)
1988    "inspect <n>th item"
1989    (inspector-ui-inspect-nth *inspector-ui* n))
1990
1991(ccl::define-toplevel-command
1992    :tty-inspect pop ()
1993    "exit current inspector"
1994    (invoke-restart 'exit-inspector))
1995
1996(ccl::define-toplevel-command
1997    :tty-inspect show ()
1998    "re-show currently inspected object"
1999    (ui-present *inspector-ui*))
2000
2001(defmethod inspector-ui-next-page ((ui inspector-tty-ui))
2002  (let* ((nlines (compute-line-count (inspector-ui-inspector ui)))
2003         (origin (inspector-tty-ui-origin ui))
2004         (page-size (inspector-tty-ui-pagesize ui))
2005         (new-origin (+ origin page-size)))
2006    (if (< new-origin nlines)
2007      (setf (inspector-tty-ui-origin ui) new-origin))
2008    (ui-present ui)))
2009   
2010(ccl::define-toplevel-command
2011    :tty-inspect next ()
2012    "show next page of object data"
2013    (inspector-ui-next-page *inspector-ui*))
2014
2015(defmethod inspector-ui-prev-page ((ui inspector-tty-ui))
2016  (let* ((origin (inspector-tty-ui-origin ui))
2017         (page-size (inspector-tty-ui-pagesize ui))
2018         (new-origin (max 0 (- origin page-size))))
2019    (setf (inspector-tty-ui-origin ui) new-origin)
2020    (ui-present ui)))
2021
2022(ccl::define-toplevel-command
2023    :tty-inspect prev ()
2024    "show previous page of object data"
2025    (inspector-ui-prev-page *inspector-ui*))
2026
2027(ccl::define-toplevel-command
2028    :tty-inspect home ()
2029    "show first page of object data"
2030    (progn
2031      (setf (inspector-tty-ui-origin *inspector-ui*) 0)
2032      (ui-present *inspector-ui*)))
2033
2034(ccl::define-toplevel-command
2035    :tty-inspect s (n v)
2036    "set the <n>th line of object data to value <v>"
2037    (let* ((ui *inspector-ui*))
2038      (setf (line-n (inspector-ui-inspector ui) n) v)
2039      (ui-present ui)))
2040
2041
2042(defmethod ui-interact ((ui inspector-tty-ui))
2043  (let* ((level (inspector-ui-level ui)))
2044    (restart-case
2045     (ccl:with-terminal-input
2046         (ccl::with-toplevel-commands :tty-inspect
2047           (ccl::read-loop
2048            :prompt-function #'(lambda (stream)
2049                                 (if (eql level 0)
2050                                   (format stream "~&Inspect> ")
2051                                   (format stream "~&Inspect ~d> " level))))))
2052     (exit-inspector () (terpri *debug-io*)))))
2053
2054(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n)
2055  (let* ((inspector (inspector-ui-inspector ui)))
2056    (multiple-value-bind (value label type)
2057        (line-n inspector n)
2058      (unless (or (eq type :comment)
2059                  (and (consp type) (eq (car type) :comment)))
2060        (let* ((new-inspector (line-n-inspector inspector n value label type))
2061               (ccl::@ value))
2062          (inspector-ui-inspect
2063           (make-instance 'inspector-tty-ui
2064                          :level (1+ (inspector-ui-level ui))
2065                          :inspector new-inspector)))))))
2066     
2067(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui)
2068
2069(defmethod inspector-ui-inspect ((ui inspector-ui))
2070  (let* ((*inspector-ui* ui))
2071    (ui-initialize ui)
2072    (ui-present ui)
2073    (ui-interact ui)
2074    (values)))
2075
2076(defun inspect (thing)
2077  (let* ((ccl::@ thing))
2078    (inspector-ui-inspect (make-instance *default-inspector-ui-class-name*
2079                                         :inspector (make-inspector thing)
2080                                         :level 0))))
Note: See TracBrowser for help on using the repository browser.