1.0.10.33: Lesson: Test before commit.
[sbcl.git] / contrib / sb-aclrepl / inspect.lisp
1 ;;;; Inspector for sb-aclrepl
2 ;;;;
3 ;;;; The documentation, which may or may not apply in its entirety at
4 ;;;; any given time, for this functionality is on the ACL website:
5 ;;;;   <http://www.franz.com/support/documentation/6.2/doc/inspector.htm>.
6 ;;;;
7 ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
8 ;;;; variable.
9
10 (cl:in-package #:sb-aclrepl)
11
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13   (defconstant +default-inspect-length+ 20))
14
15 (defstruct (%inspect (:constructor make-inspect)
16                      (:conc-name inspect-))
17   ;; stack of parents of inspected object
18   object-stack
19   ;;  a stack of indices of parent object components
20   select-stack)
21
22 ;; FIXME - raw mode isn't currently used in object display
23 (defparameter *current-inspect* nil
24   "current inspect")
25 (defparameter *inspect-raw* nil
26   "Raw mode for object display.")
27 (defparameter *inspect-length* +default-inspect-length+
28   "maximum number of components to print")
29 (defparameter *skip-address-display* nil
30   "Skip displaying addresses of objects.")
31
32 (defvar *inspect-help*
33   ":istep takes between 0 to 3 arguments.
34 The commands are:
35 :i             redisplay current object
36 :i =           redisplay current object
37 :i nil         redisplay current object
38 :i ?           display this help
39 :i *           inspect the current * value
40 :i + <form>    inspect the (eval form)
41 :i slot <name> inspect component of object, even if name is an istep cmd
42 :i <index>     inspect the numbered component of object
43 :i <name>      inspect the named component of object
44 :i <form>      evaluation and inspect form
45 :i -           inspect parent
46 :i ^           inspect parent
47 :i <           inspect previous parent component
48 :i >           inspect next parent component
49 :i set <index> <form> set indexed component to evalated form
50 :i print <max> set the maximum number of components to print
51 :i skip <n>    skip a number of components when printing
52 :i tree        print inspect stack
53 ")
54
55 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
56 ;;; indicates that that a slot is unbound.
57 (eval-when (:compile-toplevel :load-toplevel :execute)
58   (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")))
59
60
61 (defun inspector-fun (object input-stream output-stream)
62   (let ((*current-inspect* nil)
63         (*inspect-raw* nil)
64         (*inspect-length* *inspect-length*)
65         (*skip-address-display* nil))
66     (setq *current-inspect* (make-inspect))
67     (reset-stack object "(inspect ...)")
68     (redisplay output-stream)
69     (let ((*input* input-stream)
70           (*output* output-stream))
71       (repl :inspect t)))
72   (values))
73
74 (setq sb-impl::*inspect-fun* #'inspector-fun)
75
76 (defun istep (args stream)
77   (unless *current-inspect*
78     (setq *current-inspect* (make-inspect)))
79   (istep-dispatch args
80                   (first args)
81                   (when (first args) (read-from-string (first args)))
82                   stream))
83
84 (defun istep-dispatch (args option-string option stream)
85   (cond
86     ((or (string= "=" option-string) (zerop (length args)))
87      (istep-cmd-redisplay stream))
88     ((or (string= "-" option-string) (string= "^" option-string))
89      (istep-cmd-parent stream))
90     ((string= "*" option-string)
91      (istep-cmd-inspect-* stream))
92     ((string= "+" option-string)
93      (istep-cmd-inspect-new-form (read-from-string (second args)) stream))
94     ((or (string= "<" option-string)
95          (string= ">" option-string))
96      (istep-cmd-select-parent-component option-string stream))
97     ((string-equal "set" option-string)
98      (istep-cmd-set (second args) (third args) stream))
99     ((string-equal "raw" option-string)
100      (istep-cmd-set-raw (second args) stream))
101     ((string-equal "q" option-string)
102      (istep-cmd-reset))
103     ((string-equal "?" option-string)
104      (istep-cmd-help stream))
105     ((string-equal "skip" option-string)
106      (istep-cmd-skip (second args) stream))
107     ((string-equal "tree" option-string)
108      (istep-cmd-tree stream))
109     ((string-equal "print" option-string)
110      (istep-cmd-print (second args) stream))
111     ((string-equal "slot" option-string)
112      (istep-cmd-select-component (read-from-string (second args)) stream))
113     ((or (symbolp option)
114          (integerp option))
115      (istep-cmd-select-component option stream))
116     (t
117      (istep-cmd-set-stack option stream))))
118
119 (defun set-current-inspect (inspect)
120   (setq *current-inspect* inspect))
121
122 (defun reset-stack (&optional object label)
123   (cond
124     ((null label)
125      (setf (inspect-object-stack *current-inspect*) nil)
126      (setf (inspect-select-stack *current-inspect*) nil))
127     (t
128      (setf (inspect-object-stack *current-inspect*) (list object))
129      (setf (inspect-select-stack *current-inspect*) (list label)))))
130
131 (defun output-inspect-note (stream note &rest args)
132   (apply #'format stream note args)
133   (princ #\Newline stream))
134
135 (defun stack ()
136   (inspect-object-stack *current-inspect*))
137
138 (defun redisplay (stream &optional (skip 0))
139   (display-current stream *inspect-length* skip))
140
141 ;;;
142 ;;; istep command processing
143 ;;;
144
145 (defun istep-cmd-redisplay (stream)
146   (redisplay stream))
147
148 (defun istep-cmd-parent (stream)
149   (cond
150     ((> (length (inspect-object-stack *current-inspect*)) 1)
151      (setf (inspect-object-stack *current-inspect*)
152            (cdr (inspect-object-stack *current-inspect*)))
153      (setf (inspect-select-stack *current-inspect*)
154            (cdr (inspect-select-stack *current-inspect*)))
155      (redisplay stream))
156     ((stack)
157        (output-inspect-note stream "Object has no parent"))
158     (t
159      (no-object-msg stream))))
160
161 (defun istep-cmd-inspect-* (stream)
162   (reset-stack * "(inspect *)")
163   (redisplay stream))
164
165 (defun istep-cmd-inspect-new-form (form stream)
166   (inspector-fun (eval form) nil stream))
167
168 (defun istep-cmd-select-parent-component (option stream)
169   (if (stack)
170       (if (eql (length (stack)) 1)
171           (output-inspect-note stream "Object does not have a parent")
172           (let ((parent (second (stack)))
173                 (id (car (inspect-select-stack *current-inspect*))))
174             (multiple-value-bind (position parts)
175                 (find-part-id parent id)
176               (let ((new-position (if (string= ">" option)
177                                       (1+ position)
178                                       (1- position))))
179                 (if (< -1 new-position (parts-count parts))
180                     (let* ((value (component-at parts new-position)))
181                       (setf (car (inspect-object-stack *current-inspect*))
182                             value)
183                       (setf (car (inspect-select-stack *current-inspect*))
184                             (id-at parts new-position))
185                       (redisplay stream))
186                     (output-inspect-note stream
187                                          "Parent has no selectable component indexed by ~d"
188                                          new-position))))))
189       (no-object-msg stream)))
190
191 (defun istep-cmd-set-raw (option-string stream)
192   (when (inspect-object-stack *current-inspect*)
193     (cond
194       ((null option-string)
195        (setq *inspect-raw* t))
196       ((eq (read-from-string option-string) t)
197        (setq *inspect-raw* t))
198       ((eq (read-from-string option-string) nil)
199        (setq *inspect-raw* nil)))
200     (redisplay stream)))
201
202 (defun istep-cmd-reset ()
203   (reset-stack)
204   (throw 'repl-catcher (values :inspect nil)))
205
206 (defun istep-cmd-help (stream)
207   (format stream *inspect-help*))
208
209 (defun istep-cmd-skip (option-string stream)
210   (if option-string
211       (let ((len (read-from-string option-string)))
212         (if (and (integerp len) (>= len 0))
213             (redisplay stream len)
214             (output-inspect-note stream "Skip length invalid")))
215       (output-inspect-note stream "Skip length missing")))
216
217 (defun istep-cmd-print (option-string stream)
218   (if option-string
219       (let ((len (read-from-string option-string)))
220         (if (and (integerp len) (plusp len))
221             (setq *inspect-length* len)
222             (output-inspect-note stream "Cannot set print limit to ~A~%" len)))
223       (output-inspect-note stream "Print length missing")))
224
225 (defun select-description (select)
226   (typecase select
227     (integer
228      (format nil "which is componenent number ~d of" select))
229     (symbol
230      (format nil "which is the ~a component of" select))
231     (string
232      (format nil "which was selected by ~A" select))
233     (t
234      (write-to-string select))))
235
236 (defun istep-cmd-tree (stream)
237   (let ((stack (inspect-object-stack *current-inspect*)))
238     (if stack
239         (progn
240           (output-inspect-note stream "The current object is:")
241           (dotimes (i (length stack))
242             (output-inspect-note
243                stream "~A, ~A"
244                (inspected-description (nth i stack))
245                (select-description
246                 (nth i (inspect-select-stack *current-inspect*))))))
247         (no-object-msg stream))))
248
249 (defun istep-cmd-set (id-string value-string stream)
250   (if (stack)
251       (let ((id (when id-string (read-from-string id-string))))
252         (multiple-value-bind (position parts)
253             (find-part-id (car (stack)) id)
254           (if parts
255               (if position
256                   (when value-string
257                     (let ((new-value (eval (read-from-string value-string))))
258                       (let ((result (set-component-value (car (stack))
259                                                          id
260                                                          new-value
261                                                          (component-at
262                                                           parts position))))
263                         (typecase result
264                           (string
265                            (output-inspect-note stream result))
266                           (t
267                            (redisplay stream))))))
268                   (output-inspect-note
269                    stream
270                    "Object has no selectable component named by ~A" id))
271               (output-inspect-note stream
272                                    "Object has no selectable components"))))
273       (no-object-msg stream)))
274
275 (defun istep-cmd-select-component (id stream)
276   (if (stack)
277       (multiple-value-bind (position parts)
278           (find-part-id (car (stack)) id)
279         (cond
280           ((integerp position)
281            (let* ((value (component-at parts position)))
282              (cond ((eq value *inspect-unbound-object-marker*)
283                     (output-inspect-note stream "That slot is unbound"))
284                    (t
285                     (push value (inspect-object-stack *current-inspect*))
286                     (push id (inspect-select-stack *current-inspect*))
287                     (redisplay stream)))))
288           ((null parts)
289            (output-inspect-note stream "Object does not contain any subobjects"))
290           (t
291            (typecase id
292              (symbol
293               (output-inspect-note
294                stream "Object has no selectable component named ~A"
295                id))
296              (integer
297               (output-inspect-note
298                stream "Object has no selectable component indexed by ~d"
299                id))))))
300       (no-object-msg stream)))
301
302 (defun istep-cmd-set-stack (form stream)
303   (reset-stack (eval form) ":i ...")
304   (redisplay stream))
305
306
307 (defun no-object-msg (s)
308   (output-inspect-note s "No object is being inspected"))
309
310 (defun display-current (s length skip)
311   (if (stack)
312       (let ((inspected (car (stack))))
313         (setq cl:* inspected)
314         (display-inspect inspected s length skip))
315       (no-object-msg s)))
316
317
318 ;;;
319 ;;; aclrepl-specific inspection display
320 ;;;
321
322 (defun display-inspect (object stream &optional length (skip 0))
323   (multiple-value-bind (elements labels count)
324       (inspected-elements object length skip)
325     (fresh-line stream)
326     (format stream "~A" (inspected-description object))
327     (unless (or *skip-address-display*
328                 (eq object *inspect-unbound-object-marker*)
329                 (characterp object) (typep object 'fixnum))
330       (write-string " at #x" stream)
331       (format stream (n-word-bits-hex-format)
332               (logand (sb-kernel:get-lisp-obj-address object)
333                       (lognot sb-vm:lowtag-mask))))
334     (dotimes (i count)
335       (fresh-line stream)
336       (display-labeled-element (elt elements i) (elt labels i) stream))))
337
338 (defun array-label-p (label)
339   (and (consp label)
340        (stringp (cdr label))
341        (char= (char (cdr label) 0) #\[)))
342
343 (defun named-or-array-label-p (label)
344   (and (consp label) (not (hex-label-p label))))
345
346 (defun hex-label-p (label &optional width)
347   (and (consp label)
348        (case width
349              (32 (eq (cdr label) :hex32))
350              (64 (eq (cdr label) :hex64))
351              (t (or (eq (cdr label) :hex32)
352                     (eq (cdr label) :hex64))))))
353
354 (defun display-labeled-element (element label stream)
355   (cond
356     ((eq label :ellipses)
357      (format stream "   ..."))
358     ((eq label :tail)
359      (format stream "tail-> ~A" (inspected-description element)))
360     ((named-or-array-label-p label)
361      (format stream
362              (if (array-label-p label)
363                  "~4,' D ~A-> ~A"
364                  "~4,' D ~16,1,1,'-A> ~A")
365              (car label)
366              (format nil "~A " (cdr label))
367              (inspected-description element)))
368     ((hex-label-p label 32)
369      (format stream "~4,' D-> #x~8,'0X" (car label) element))
370     ((hex-label-p label 64)
371      (format stream "~4,' D-> #x~16,'0X" (car label) element))
372     (t
373      (format stream "~4,' D-> ~A" label (inspected-description element)))))
374
375 ;;; THE BEGINNINGS OF AN INSPECTOR API
376 ;;; which can be used to retrieve object descriptions as component values/labels and also
377 ;;; process print length and skip selectors
378 ;;;
379 ;;; FUNCTIONS TO CONSIDER FOR EXPORT
380 ;;;   FIND-PART-ID
381 ;;;   COMPONENT-AT
382 ;;;   ID-AT
383 ;;;   INSPECTED-ELEMENTS
384 ;;;   INSPECTED-DESCRIPTION
385 ;;;
386 ;;; will also need hooks
387 ;;;    *inspect-start-inspection*
388 ;;;       (maybe. Would setup a window for a GUI inspector)
389 ;;;    *inspect-prompt-fun*
390 ;;;    *inspect-read-cmd*
391 ;;;
392 ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
393 ;;; That'll depend if choose to have standardized inspector commands such that
394 ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
395 ;;; process and then call the *inspect-display* hook, or if the
396 ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will
397 ;;; send to the contributed inspector for processing and display.
398
399 (defun find-part-id (object id)
400   "COMPONENT-ID can be an integer or a name of a id.
401 Returns (VALUES POSITION PARTS).
402 POSITION is NIL if the id is invalid or not found."
403   (let* ((parts (inspected-parts object))
404          (name (if (symbolp id) (symbol-name id) id)))
405     (values
406      (cond
407        ((and (numberp id)
408              (< -1 id (parts-count parts))
409              (not (eq (parts-seq-type parts) :bignum)))
410         id)
411        (t
412         (case (parts-seq-type parts)
413           (:named
414            (position name (the list (parts-components parts))
415                      :key #'car :test #'string-equal))
416           ((:dotted-list :cyclic-list)
417            (when (string-equal name "tail")
418              (1- (parts-count parts)))))))
419      parts)))
420
421 (defun component-at (parts position)
422   (let ((count (parts-count parts))
423         (components (parts-components parts)))
424     (when (< -1 position count)
425       (case (parts-seq-type parts)
426         (:dotted-list
427          (if (= position (1- count))
428              (cdr (last components))
429              (elt components position)))
430         (:cyclic-list
431          (if (= position (1- count))
432              components
433              (elt components position)))
434         (:named
435          (cdr (elt components position)))
436         (:array
437          (aref (the array components) position))
438         (:bignum
439          (bignum-component-at components position))
440         (t
441          (elt components position))))))
442
443 (defun id-at (parts position)
444   (let ((count (parts-count parts)))
445     (when (< -1 position count)
446       (case (parts-seq-type parts)
447         ((:dotted-list :cyclic-list)
448          (if (= position (1- count))
449              :tail
450              position))
451         (:array
452          (array-index-string position parts))
453         (:named
454          (car (elt (parts-components parts) position)))
455         (t
456          position)))))
457
458 (defun inspected-elements (object &optional length (skip 0))
459   "Returns elements of an object that have been trimmed and labeled based on
460 length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT)
461 where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items.
462 LABELS elements may be a string, number, cons pair, :tail, or :ellipses.
463 This function may return an ELEMENT-COUNT of up to (+ 3 length) which would
464 include an :ellipses at the beginning, :ellipses at the end,
465 and the last element."
466   (let* ((parts (inspected-parts object))
467          (print-length (if length length (parts-count parts)))
468          (last-part (last-part parts))
469          (last-requested (last-requested parts print-length skip))
470          (element-count (compute-elements-count parts print-length skip))
471          (first-to (if (first-element-ellipses-p parts skip) 1 0))
472          (elements (when (plusp element-count) (make-array element-count)))
473          (labels (when (plusp element-count) (make-array element-count))))
474     (when (plusp element-count)
475       ;; possible first ellipses
476       (when (first-element-ellipses-p parts skip)
477         (set-element-values elements labels 0 nil :ellipses))
478       ;; main elements
479       (do* ((i 0 (1+ i)))
480            ((> i (- last-requested skip)))
481         (set-element elements labels parts (+ i first-to) (+ i skip)))
482       ;; last parts value if needed
483       (when (< last-requested last-part)
484         (set-element elements labels parts (- element-count 1) last-part))
485       ;; ending ellipses or next to last parts value if needed
486       (when (< last-requested (1- last-part))
487         (if (= last-requested (- last-part 2))
488             (set-element elements labels parts (- element-count 2) (1- last-part))
489             (set-element-values elements labels (- element-count 2) nil :ellipses))))
490     (values elements labels element-count)))
491
492 (defun last-requested (parts print skip)
493   (min (1- (parts-count parts)) (+ skip print -1)))
494
495 (defun last-part (parts)
496   (1- (parts-count parts)))
497
498 (defun compute-elements-count (parts length skip)
499   "Compute the number of elements in parts given the print length and skip."
500   (let ((element-count (min (parts-count parts) length
501                             (max 0 (- (parts-count parts) skip)))))
502     (when (and (plusp (parts-count parts)) (plusp skip)) ; starting ellipses
503       (incf element-count))
504     (when (< (last-requested parts length skip)
505              (last-part parts)) ; last value
506       (incf element-count)
507       (when (< (last-requested parts length skip)
508                (1- (last-part parts))) ; ending ellipses
509         (incf element-count)))
510     element-count))
511
512 (defun set-element (elements labels parts to-index from-index)
513   (set-element-values elements labels to-index (component-at parts from-index)
514                       (label-at parts from-index)))
515
516 (defun set-element-values (elements labels index element label)
517   (setf (aref elements index) element)
518   (setf (aref labels index) label))
519
520 (defun first-element-ellipses-p (parts skip)
521   (and (parts-count parts) (plusp skip)))
522
523 (defun label-at (parts position)
524   "Helper function for inspected-elements. Conses the
525 position with the label if the label is a string."
526   (let ((id (id-at parts position)))
527     (cond
528       ((stringp id)
529        (cons position id))
530       ((eq (parts-seq-type parts) :bignum)
531        (cons position (case sb-vm::n-word-bits
532                             (32 :hex32)
533                             (64 :hex64))))
534       (t
535         id))))
536
537 (defun array-index-string (index parts)
538   "Formats an array index in row major format."
539   (let ((rev-dimensions (parts-seq-hint parts)))
540     (if (null rev-dimensions)
541         "[]"
542         (let ((list nil))
543           (dolist (dim rev-dimensions)
544             (multiple-value-bind (q r) (floor index dim)
545               (setq index q)
546               (push r list)))
547           (format nil "[~W~{,~W~}]" (car list) (cdr list))))))
548
549 \f
550 ;;; INSPECTED-DESCRIPTION
551 ;;;
552 ;;; Accepts an object and returns
553 ;;;   DESCRIPTION is a summary description of the destructured object,
554 ;;;   e.g. "the object is a CONS".
555
556 (defgeneric inspected-description (object))
557
558 (defmethod inspected-description ((object symbol))
559   (format nil "the symbol ~A" object))
560
561 (defmethod inspected-description ((object structure-object))
562   (format nil "~W" (find-class (type-of object))))
563
564 (defmethod inspected-description ((object package))
565   (format nil "the ~A package" (package-name object)))
566
567 (defmethod inspected-description ((object standard-object))
568   (format nil "~W" (class-of object)))
569
570 (defmethod inspected-description ((object function))
571   (format nil "~S" object) nil)
572
573 (defmethod inspected-description ((object vector))
574   (declare (vector object))
575   (format nil "a ~:[~;displaced ~]vector (~W)"
576           (and (sb-kernel:array-header-p object)
577                (sb-kernel:%array-displaced-p object))
578           (length object)))
579
580 (defmethod inspected-description ((object simple-vector))
581   (declare (simple-vector object))
582   (format nil "a simple ~A vector (~D)"
583           (array-element-type object)
584           (length object)))
585
586 (defmethod inspected-description ((object array))
587   (declare (array object))
588   (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
589           (and (sb-kernel:array-header-p object)
590                (sb-kernel:%array-displaced-p object))
591           (array-element-type object)
592           (array-dimensions object)))
593
594 (defun simple-cons-pair-p (object)
595   (atom (cdr object)))
596
597 (defmethod inspected-description ((object cons))
598   (if (simple-cons-pair-p object)
599       "a cons cell"
600       (inspected-description-of-nontrivial-list object)))
601
602 (defun cons-safe-length (object)
603   "Returns (VALUES LENGTH LIST-TYPE) where length is the number of
604 cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
605     (do ((length 1 (1+ length))
606          (lst (cdr object) (cdr lst)))
607         ((or (not (consp lst))
608              (eq object lst))
609          (cond
610            ((null lst)
611             (values length :normal))
612            ((atom lst)
613             (values length :dotted))
614            ((eq object lst)
615             (values length :cyclic))))
616       ;; nothing to do in body
617       ))
618
619 (defun inspected-description-of-nontrivial-list (object)
620   (multiple-value-bind (length list-type) (cons-safe-length object)
621     (format nil "a ~A list with ~D element~:*~P~A"
622             (string-downcase (symbol-name list-type)) length
623             (ecase list-type
624               ((:dotted :cyclic) "+tail")
625               (:normal "")))))
626
627 (defun n-word-bits-hex-format ()
628   (case sb-vm::n-word-bits
629     (64 "~16,'0X")
630     (32 "~8,'0X")
631     (t  "~X")))
632
633 (defun ref32-hexstr (obj &optional (offset 0))
634   (format nil "~8,'0X" (ref32 obj offset)))
635
636 (defun ref32 (obj &optional (offset 0))
637   (sb-sys::without-gcing
638    (sb-sys:sap-ref-32
639     (sb-sys:int-sap
640      (logand (sb-kernel:get-lisp-obj-address obj) (lognot sb-vm:lowtag-mask)))
641     offset)))
642
643 (defun description-maybe-internals (fmt objects internal-fmt &rest args)
644   (let ((base (apply #'format nil fmt objects)))
645     (if *skip-address-display*
646         base
647         (concatenate 'string
648                      base " " (apply #'format nil internal-fmt args)))))
649
650 (defmethod inspected-description ((object double-float))
651   (let ((start (round (* 2 sb-vm::n-word-bits) 8)))
652     (description-maybe-internals "double-float ~W" (list object)
653                                  "[#~A ~A]"
654                                  (ref32-hexstr object (+ start 4))
655                                  (ref32-hexstr object start))))
656
657 (defmethod inspected-description ((object single-float))
658   (description-maybe-internals "single-float ~W" (list object)
659                                "[#x~A]"
660                                (ref32-hexstr object (round sb-vm::n-word-bits 8))))
661
662 (defmethod inspected-description ((object fixnum))
663   (description-maybe-internals
664    "fixnum ~W" (list object)
665    (concatenate 'string "[#x" (n-word-bits-hex-format) "]")
666    (ash object (1- sb-vm:n-lowtag-bits))))
667
668 (defmethod inspected-description ((object complex))
669   (format nil "complex number ~W" object))
670
671 (defmethod inspected-description ((object simple-string))
672   (format nil "a simple-string (~W) ~W" (length object) object))
673
674 (defun bignum-words (bignum)
675   "Return the number of words in a bignum"
676   (ash
677    (logand (ref32 bignum) (lognot sb-vm:widetag-mask))
678    (- sb-vm:n-widetag-bits)))
679
680 (defun bignum-component-at (bignum offset)
681   "Return the word at offset"
682   (case sb-vm::n-word-bits
683         (32
684          (ref32 bignum (* 4 (1+ offset))))
685         (64
686          (let ((start (* 8 (1+ offset))))
687            (+ (ref32 bignum start)
688               (ash (ref32 bignum (+ 4 start)) 32))))))
689
690 (defmethod inspected-description ((object bignum))
691   (format nil  "bignum ~W with ~D ~A-bit word~P" object
692           (bignum-words object) sb-vm::n-word-bits (bignum-words object)))
693
694 (defmethod inspected-description ((object ratio))
695   (format nil "ratio ~W" object))
696
697 (defmethod inspected-description ((object character))
698   ;; FIXME: This will need to change as and when we get more characters
699   ;; than just the 256 we have today.
700   (description-maybe-internals
701    "character ~W char-code #x~2,'0X"
702    (list object (char-code object))
703    "[#x~8,'0X]"
704    (logior sb-vm:character-widetag (ash (char-code object)
705                                         sb-vm:n-widetag-bits))))
706
707 (defmethod inspected-description ((object t))
708   (format nil "a generic object ~W" object))
709
710 (defmethod inspected-description ((object (eql *inspect-unbound-object-marker*)))
711   "..unbound..")
712
713 \f
714 ;;; INSPECTED-PARTS
715 ;;;
716 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
717 ;;;   (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
718 ;;; where..
719 ;;;
720 ;;;   COMPONENTS are the component parts of OBJECT (whose
721 ;;;   representation is determined by SEQ-TYPE). Except for the
722 ;;;   SEQ-TYPE :named and :array, components is just the OBJECT itself
723 ;;;
724 ;;;   SEQ-TYPE determines what representation is used for components
725 ;;;   of COMPONENTS.
726 ;;;      If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
727 ;;;      If SEQ-TYPE is :dotted-list, then each element is just value,
728 ;;;        but the last element must be retrieved by
729 ;;;        (cdr (last components))
730 ;;;      If SEQ-TYPE is :cylic-list, then each element is just value,
731 ;;;      If SEQ-TYPE is :list, then each element is a value of an array
732 ;;;      If SEQ-TYPE is :vector, then each element is a value of an vector
733 ;;;      If SEQ-TYPE is :array, then each element is a value of an array
734 ;;;        with rank >= 2. The
735 ;;;      If SEQ-TYPE is :bignum, then object is just a bignum and not a
736 ;;;        a sequence
737 ;;;
738 ;;;   COUNT is the total number of components in the OBJECT
739 ;;;
740 ;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
741 ;;; to hold the reverse-dimensions of the orignal array.
742
743 (declaim (inline parts-components))
744 (defun parts-components (parts)
745   (first parts))
746
747 (declaim (inline parts-count))
748 (defun parts-count (parts)
749   (second parts))
750
751 (declaim (inline parts-seq-type))
752 (defun parts-seq-type (parts)
753   (third parts))
754
755 (declaim (inline parts-seq-hint))
756 (defun parts-seq-hint (parts)
757   (fourth parts))
758
759 ;;; FIXME: Most of this should be refactored to share the code
760 ;;; with the vanilla inspector. Also, we should check what the
761 ;;; Slime inspector does, and provide a an interface for it to
762 ;;; use that would propagate any SBCL inspector improvements
763 ;;; automagically to Slime. -- ns 2005-02-20
764 (defgeneric inspected-parts (object))
765
766 (defmethod inspected-parts ((object symbol))
767   (let ((components
768          (list (cons "NAME" (symbol-name object))
769                (cons "PACKAGE" (symbol-package object))
770                (cons "VALUE" (if (boundp object)
771                                  (symbol-value object)
772                                  *inspect-unbound-object-marker*))
773                (cons "FUNCTION" (if (fboundp object)
774                                     (symbol-function object)
775                                     *inspect-unbound-object-marker*))
776                (cons "PLIST" (symbol-plist object)))))
777     (list components (length components) :named nil)))
778
779 (defun inspected-structure-parts (object)
780   (let ((components-list '())
781         (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
782     (when (sb-kernel::defstruct-description-p info)
783       (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
784         (push (cons (string (sb-kernel:dsd-name dd-slot))
785                     (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
786               components-list)))))
787
788 (defmethod inspected-parts ((object structure-object))
789   (let ((components (inspected-structure-parts object)))
790     (list components (length components) :named nil)))
791
792 (defun inspected-standard-object-parts (object)
793   (let ((components nil)
794         (class-slots (sb-pcl::class-slots (class-of object))))
795     (dolist (class-slot class-slots (nreverse components))
796       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
797              (slot-value (if (slot-boundp object slot-name)
798                              (slot-value object slot-name)
799                              *inspect-unbound-object-marker*)))
800         (push (cons (symbol-name slot-name) slot-value) components)))))
801
802
803 (defmethod inspected-parts ((object standard-object))
804   (let ((components (inspected-standard-object-parts object)))
805     (list components (length components) :named nil)))
806
807 (defmethod inspected-parts ((object condition))
808   (let ((components (inspected-standard-object-parts object)))
809     (list components (length components) :named nil)))
810
811 (defmethod inspected-parts ((object function))
812   (let* ((type (sb-kernel:widetag-of object))
813          (object (if (= type sb-vm:closure-header-widetag)
814                      (sb-kernel:%closure-fun object)
815                      object))
816          (components (list (cons "arglist"
817                                (sb-kernel:%simple-fun-arglist object)))))
818     (list components (length components) :named nil)))
819
820 (defmethod inspected-parts ((object vector))
821   (list object (length object) :vector nil))
822
823 (defmethod inspected-parts ((object array))
824   (let ((size (array-total-size object)))
825     (list (make-array size
826                       :element-type (array-element-type object)
827                       :displaced-to object)
828             size
829             :array
830             (reverse (array-dimensions object)))))
831
832 (defmethod inspected-parts ((object cons))
833   (if (simple-cons-pair-p object)
834       (inspected-parts-of-simple-cons object)
835       (inspected-parts-of-nontrivial-list object)))
836
837 (defun inspected-parts-of-simple-cons (object)
838   (let ((components (list (cons "car" (car object))
839                         (cons "cdr" (cdr object)))))
840     (list components 2 :named nil)))
841
842 (defun inspected-parts-of-nontrivial-list (object)
843     (multiple-value-bind (count list-type) (cons-safe-length object)
844       (case list-type
845         (:normal
846          (list object count :list nil))
847         (:cyclic
848          (list object (1+ count) :cyclic-list nil))
849         (:dotted
850          ;; count tail element
851          (list object (1+ count) :dotted-list nil)))))
852
853 (defmethod inspected-parts ((object complex))
854   (let ((components (list (cons "real" (realpart object))
855                         (cons "imag" (imagpart object)))))
856     (list components (length components) :named nil)))
857
858 (defmethod inspected-parts ((object ratio))
859   (let ((components (list (cons "numerator" (numerator object))
860                         (cons "denominator" (denominator object)))))
861     (list components (length components) :named nil)))
862
863 (defmethod inspected-parts ((object bignum))
864     (list object (bignum-words object) :bignum nil))
865
866 (defmethod inspected-parts ((object t))
867   (list nil 0 nil nil))
868
869
870 ;; FIXME - implement setting of component values
871
872 (defgeneric set-component-value (object component-id value element))
873
874 (defmethod set-component-value ((object cons) id value element)
875   (format nil "Cons object does not support setting of component ~A" id))
876
877 (defmethod set-component-value ((object array) id value element)
878   (format nil "Array object does not support setting of component ~A" id))
879
880 (defmethod set-component-value ((object symbol) id value element)
881   (format nil "Symbol object does not support setting of component ~A" id))
882
883 (defmethod set-component-value ((object structure-object) id value element)
884   (format nil "Structure object does not support setting of component ~A" id))
885
886 (defmethod set-component-value ((object standard-object) id value element)
887   (format nil "Standard object does not support setting of component ~A" id))
888
889 (defmethod set-component-value ((object t) id value element)
890   (format nil "Object does not support setting of component ~A" id))