1 ;;;; Inspector for sb-aclrepl
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>.
7 ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP*
10 (cl:in-package
#:sb-aclrepl
)
12 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
13 (defconstant +default-inspect-length
+ 10))
16 ;; stack of parents of inspected object
18 ;; a stack of indices of parent object components
21 ;; FIXME - raw mode isn't currently used in object display
22 (defparameter *current-inspect
* nil
24 (defparameter *inspect-raw
* nil
25 "Raw mode for object display.")
26 (defparameter *inspect-length
* +default-inspect-length
+
27 "maximum number of components to print")
28 (defparameter *inspect-skip
* 0
29 "number of initial components to skip when displaying an object")
31 (defvar *inspect-help
*
32 ":istep takes between 0 to 3 arguments.
34 :i redisplay current object
35 :i = redisplay current object
36 :i nil redisplay current object
37 :i ? display this help
38 :i * inspect the current * value
39 :i + <form> inspect the (eval form)
40 :i <index> inspect the numbered component of object
41 :i <name> inspect the named component of object
42 :i <form> evaluation and inspect form
45 :i < inspect previous parent component
46 :i > inspect next parent component
47 :i set <index> <form> set indexed component to evalated form
48 i set <name> <form> set named component to evalated form
49 :i print <max> set the maximum number of components to print
50 :i skip <n> skip a number of components when printing
51 :i tree print inspect stack
54 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
55 ;;; indicates that that a slot is unbound.
56 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
57 (defvar *inspect-unbound-object-marker
* (gensym "INSPECT-UNBOUND-OBJECT-")))
60 ;; Setup binding for multithreading
61 (let ((*current-inspect
* nil
)
63 (*inspect-length
* +default-inspect-length
+)
66 (defun inspector (object input-stream output-stream
)
67 (declare (ignore input-stream
))
68 (setq object
(eval object
))
69 (setq *current-inspect
* (make-inspect))
70 (new-break :inspect
*current-inspect
*)
72 (setf (inspect-object-stack *current-inspect
*) (list object
))
73 (setf (inspect-select-stack *current-inspect
*)
74 (list (format nil
"(inspect ~S)" object
)))
75 (%inspect output-stream
))
77 (setq sb-impl
::*inspect-fun
* #'inspector
)
79 (defun istep (args stream
)
80 (unless *current-inspect
*
81 (setq *current-inspect
* (make-inspect)))
84 (when (first args
) (read-from-string (first args
)))
87 (defun istep-dispatch (args option-string option stream
)
89 ((or (string= "=" option-string
) (zerop (length args
)))
90 (istep-cmd-redisplay stream
))
91 ((or (string= "-" option-string
) (string= "^" option-string
))
92 (istep-cmd-parent stream
))
93 ((string= "*" option-string
)
94 (istep-cmd-inspect-* stream
))
95 ((string= "+" option-string
)
96 (istep-cmd-inspect-new-form (read-from-string (second args
)) stream
))
97 ((or (string= "<" option-string
)
98 (string= ">" option-string
))
99 (istep-cmd-select-parent-component option-string stream
))
100 ((string-equal "set" option-string
)
101 (istep-cmd-set (second args
) (third args
) stream
))
102 ((string-equal "raw" option-string
)
103 (istep-cmd-set-raw (second args
) stream
))
104 ((string-equal "q" option-string
)
106 ((string-equal "?" option-string
)
107 (istep-cmd-help stream
))
108 ((string-equal "skip" option-string
)
109 (istep-cmd-skip (second args
) stream
))
110 ((string-equal "tree" option-string
)
111 (istep-cmd-tree stream
))
112 ((string-equal "print" option-string
)
113 (istep-cmd-print (second args
) stream
))
114 ((or (symbolp option
)
116 (istep-cmd-select-component option stream
))
118 (istep-cmd-set-stack option stream
))))
120 (defun set-current-inspect (inspect)
121 (setq *current-inspect
* inspect
))
123 (defun reset-stack ()
124 (setf (inspect-object-stack *current-inspect
*) nil
)
125 (setf (inspect-select-stack *current-inspect
*) nil
))
127 (defun output-inspect-note (stream note
&rest args
)
128 (apply #'format stream note args
)
129 (princ #\Newline stream
))
132 (inspect-object-stack *current-inspect
*))
134 (defun redisplay (stream)
138 ;;; istep command processing
141 (defun istep-cmd-redisplay (stream)
144 (defun istep-cmd-parent (stream)
146 ((> (length (inspect-object-stack *current-inspect
*)) 1)
147 (setf (inspect-object-stack *current-inspect
*)
148 (cdr (inspect-object-stack *current-inspect
*)))
149 (setf (inspect-select-stack *current-inspect
*)
150 (cdr (inspect-select-stack *current-inspect
*)))
153 (output-inspect-note stream
"Object has no parent"))
155 (redisplay stream
))))
157 (defun istep-cmd-inspect-* (stream)
159 (setf (inspect-object-stack *current-inspect
*) (list *))
160 (setf (inspect-select-stack *current-inspect
*) (list "(inspect *)"))
161 (set-break-inspect *current-inspect
*)
164 (defun istep-cmd-inspect-new-form (form stream
)
165 (inspector (eval form
) nil stream
))
167 (defun istep-cmd-select-parent-component (option stream
)
169 (if (eql (length (stack)) 1)
170 (output-inspect-note stream
"Object does not have a parent")
171 (let ((parent (second (stack)))
172 (id (car (inspect-select-stack *current-inspect
*))))
173 (multiple-value-bind (position parts
)
174 (find-object-part-with-id parent id
)
175 (let ((new-position (if (string= ">" option
)
178 (if (< -
1 new-position
(parts-count parts
))
179 (let* ((value (element-at parts new-position
)))
180 (setf (car (inspect-object-stack *current-inspect
*))
182 (setf (car (inspect-select-stack *current-inspect
*))
185 (let ((label (label-at parts new-position
)))
187 (read-from-string label
)
190 (output-inspect-note stream
191 "Parent has no selectable component indexed by ~d"
195 (defun istep-cmd-set-raw (option-string stream
)
196 (when (inspect-object-stack *current-inspect
*)
198 ((null option-string
)
199 (setq *inspect-raw
* t
))
200 ((eq (read-from-string option-string
) t
)
201 (setq *inspect-raw
* t
))
202 ((eq (read-from-string option-string
) nil
)
203 (setq *inspect-raw
* nil
)))
206 (defun istep-cmd-reset ()
208 (set-break-inspect *current-inspect
*))
210 (defun istep-cmd-help (stream)
211 (format stream
*inspect-help
*))
213 (defun istep-cmd-skip (option-string stream
)
215 (let ((len (read-from-string option-string
)))
216 (if (and (integerp len
) (>= len
0))
217 (let ((*inspect-skip
* len
))
219 (output-inspect-note stream
"Skip length invalid")))
220 (output-inspect-note stream
"Skip length missing")))
222 (defun istep-cmd-print (option-string stream
)
224 (let ((len (read-from-string option-string
)))
225 (if (and (integerp len
) (plusp len
))
226 (setq *inspect-length
* len
)
227 (output-inspect-note stream
"Cannot set print limit to ~A~%" len
)))
228 (output-inspect-note stream
"Print length missing")))
230 (defun select-description (select)
233 (format nil
"which is componenent number ~d of" select
))
235 (format nil
"which is the ~a component of" select
))
237 (format nil
"which was selected by ~S" select
))
239 (write-to-string select
))))
241 (defun istep-cmd-tree (stream)
242 (let ((stack (inspect-object-stack *current-inspect
*)))
245 (output-inspect-note stream
"The current object is:")
246 (dotimes (i (length stack
))
249 (inspected-description (nth i stack
))
251 (nth i
(inspect-select-stack *current-inspect
*))))))
254 (defun istep-cmd-set (id-string value-string stream
)
256 (let ((id (when id-string
(read-from-string id-string
))))
257 (multiple-value-bind (position parts
)
258 (find-object-part-with-id (car (stack)) id
)
262 (let ((new-value (eval (read-from-string value-string
))))
263 (let ((result (set-component-value (car (stack))
270 (output-inspect-note stream result
))
272 (%inspect stream
))))))
275 "Object has no selectable component named by ~A" id
))
276 (output-inspect-note stream
277 "Object has no selectable components"))))
280 (defun istep-cmd-select-component (id stream
)
282 (multiple-value-bind (position parts
)
283 (find-object-part-with-id (car (stack)) id
)
286 (let* ((value (element-at parts position
)))
287 (cond ((eq value
*inspect-unbound-object-marker
*)
288 (output-inspect-note stream
"That slot is unbound"))
290 (push value
(inspect-object-stack *current-inspect
*))
291 (push id
(inspect-select-stack *current-inspect
*))
292 (redisplay stream
)))))
294 (output-inspect-note stream
"Object does not contain any subobjects"))
299 stream
"Object has no selectable component named ~A"
303 stream
"Object has no selectable component indexed by ~d"
306 stream
"Enter a valid index (~:[0-~W~;0~])"
307 (= (parts-count parts
) 1)
308 (1- (parts-count parts
))))))))
311 (defun istep-cmd-set-stack (form stream
)
313 (let ((object (eval form
)))
314 (setf (inspect-object-stack *current-inspect
*) (list object
))
315 (setf (inspect-select-stack *current-inspect
*)
316 (list (format nil
":i ~S" object
))))
317 (set-break-inspect *current-inspect
*)
321 ;;; aclrepl-specific inspection display
325 (if (inspect-object-stack *current-inspect
*)
327 (setq cl
:* (car (inspect-object-stack *current-inspect
*)))
328 (display-inspected-parts inspected s
*inspect-length
* *inspect-skip
*))
329 (output-inspect-note s
"No object is being inspected")))
330 ) ;; end binding for multithreading
333 (defun display-inspected-parts (object stream
&optional length skip
)
334 (multiple-value-bind (elements labels count
)
335 (inspected-elements object length skip
)
336 (format stream
"~&~A" (inspected-description object
))
337 (unless (or (characterp object
) (typep object
'fixnum
))
338 (format stream
" at #x~X" (sb-kernel:get-lisp-obj-address object
)))
339 (princ #\newline stream
)
342 (display-labelled-element (elt elements i
) (elt labels i
) stream
))))
344 (defun array-label-p (label)
345 (and (stringp (cdr label
)) (char= (char (cdr label
) 0) #\
[)))
347 (defun named-or-array-label-p (label)
350 (defun display-labelled-element (element label stream
)
352 ((eq label
:ellipses
)
353 (format stream
" ..."))
355 (format stream
"tail-> ~A" (inspected-description element
)))
356 ((named-or-array-label-p label
)
358 (if (array-label-p label
)
360 "~4,' D ~16,1,1,'-A> ~A")
362 (format nil
"~A " (cdr label
))
363 (inspected-description element
)))
365 (format stream
"~4,' D-> ~A" label
(inspected-description element
)))))
367 ;;; THE BEGINNINGS OF AN INSPECTOR API
368 ;;; which can be used to retrieve object descriptions as component values/labels and also
369 ;;; process print length and skip selectors
371 ;;; FUNCTIONS TO CONSIDER FOR EXPORT
372 ;;; FIND-OBJECT-PART-WITH-ID
375 ;;; INSPECTED-ELEMENTS
376 ;;; INSPECTED-DESCRIPTION
378 ;;; will also need hooks
379 ;;; *inspect-start-inspection*
380 ;;; (maybe. Would setup a window for a GUI inspector)
381 ;;; *inspect-prompt-fun*
382 ;;; *inspect-read-cmd*
384 ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook
385 ;;; That'll depend if choose to have standardized inspector commands such that
386 ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will
387 ;;; process and then call the *inspect-display* hook, or if the
388 ;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will
389 ;;; send to the contributed inspector for processing and display.
391 (defun find-object-part-with-id (object id
)
392 "COMPONENT-ID can be an integer or a name of a id.
393 Returns (VALUES POSITION PARTS).
394 POSITION is NIL if the id is invalid or not found."
396 (let* ((parts (inspected-parts object
))
397 (seq-type (parts-seq-type parts
))
398 (count (parts-count parts
))
399 (components (parts-components parts
)))
401 (setq id
(symbol-name id
)))
403 (cond ((and (eq seq-type
:named
)
405 (position id
(the list components
) :key
#'car
406 :test
#'string-equal
))
407 ((and (eq seq-type
:improper-list
)
409 (string-equal id
"tail"))
412 (when (< -
1 id count
)
414 (values position parts
)))
418 (defun element-at (parts position
)
419 (let ((count (parts-count parts
))
420 (components (parts-components parts
)))
421 (when (< -
1 position count
)
422 (case (parts-seq-type parts
)
424 (if (= position
(1- count
))
425 (cdr (last components
))
426 (elt components position
)))
428 (cdr (elt components position
)))
430 (aref (the array components
) position
))
432 (elt components position
))))))
434 (defun label-at (parts position
)
435 (let ((count (parts-count parts
)))
436 (when (< -
1 position count
)
437 (case (parts-seq-type parts
)
439 (if (= position
(1- count
))
443 (array-index-string position parts
))
445 (car (elt (parts-components parts
) position
)))
449 (defun label-at-maybe-with-index (parts position
)
450 "Helper function for inspected-elements. Conses the
451 position with the label is the label is a string."
452 (let ((label (label-at parts position
)))
453 (if (or (stringp label
)
454 (and (symbolp label
) (not (eq label
:tail
))))
455 (cons position label
)
458 (defun array-index-string (index parts
)
459 "Formats an array index in row major format."
460 (let ((rev-dimensions (parts-seq-hint parts
)))
461 (if (null rev-dimensions
)
464 (dolist (dim rev-dimensions
)
465 (multiple-value-bind (q r
) (floor index dim
)
468 (format nil
"[~W~{,~W~}]" (car list
) (cdr list
))))))
470 (defun inspected-elements (object &optional length skip
)
471 "Returns elements of an object that have been trimmed and labeled based on
472 length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT)
473 where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items.
474 LABELS may be a string, number, cons pair, :tail, or :ellipses.
475 This function may return an ELEMENT-COUNT of up to (+ 3 length) which would
476 include an :ellipses at the beginning, :ellipses at the end,
477 and the last element."
478 (let* ((parts (inspected-parts object
))
479 (count (parts-count parts
)))
480 (unless skip
(setq skip
0))
481 (unless length
(setq length count
))
482 (let* ((last (1- count
))
483 (last-req (min last
(+ skip length -
1))) ;; last requested element
484 (total (min (- count skip
) length
)))
485 (when (and (plusp total
) (plusp skip
)) ; starting ellipses
487 (when (< last-req last
) ; last value
489 (when (< last-req
(1- last
)) ; ending ellipses
494 (declare (type (or simple-vector null
) elements labels
))
496 (setq elements
(make-array total
:adjustable nil
:fill-pointer nil
:initial-element nil
))
497 (setq labels
(make-array total
:adjustable nil
:fill-pointer nil
))
499 (setf (aref labels
0) :ellipses
)
502 ((> i
(- last-req skip
)))
503 (setf (aref elements
(+ i index
)) (element-at parts
(+ i skip
)))
504 (setf (aref labels
(+ i index
)) (label-at-maybe-with-index parts
507 (when (< last-req last
) ; last value
508 (setf (aref elements
(- total
1)) (element-at parts last
))
509 (setf (aref labels
(- total
1)) (label-at-maybe-with-index parts
511 (when (< last-req
(1- last
)) ; ending ellipses or 2nd to last value
512 (if (= last-req
(- last
2))
514 (setf (aref elements
(- total
2)) (element-at parts
(1- last
)))
515 (setf (aref labels
(- total
2)) (label-at-maybe-with-index
517 (setf (aref labels
(- total
2)) :ellipses
)))))
518 (values elements labels total
)))))
522 ;;; INSPECTED-DESCRIPTION
524 ;;; Accepts an object and returns
525 ;;; DESCRIPTION is a summary description of the destructured object,
526 ;;; e.g. "the object is a CONS".
528 (defgeneric inspected-description
(object))
530 (defmethod inspected-description ((object symbol
))
531 (format nil
"the symbol ~A" object
))
533 (defmethod inspected-description ((object structure-object
))
534 (format nil
"~W" (find-class (type-of object
))))
536 (defmethod inspected-description ((object package
))
537 (format nil
"the ~A package" (package-name object
)))
539 (defmethod inspected-description ((object standard-object
))
540 (format nil
"~W" (class-of object
)))
542 (defmethod inspected-description ((object sb-kernel
:funcallable-instance
))
543 (format nil
"a funcallable-instance of type ~S" (type-of object
)))
545 (defmethod inspected-description ((object function
))
546 (format nil
"~S" object
) nil
)
548 (defmethod inspected-description ((object vector
))
549 (declare (vector object
))
550 (format nil
"a ~:[~;displaced ~]vector (~W)"
551 (and (sb-kernel:array-header-p object
)
552 (sb-kernel:%array-displaced-p object
))
555 (defmethod inspected-description ((object simple-vector
))
556 (declare (simple-vector object
))
557 (format nil
"a simple ~A vector (~D)"
558 (array-element-type object
)
561 (defmethod inspected-description ((object array
))
562 (declare (array object
))
563 (format nil
"~:[A displaced~;An~] array of ~A with dimensions ~W"
564 (and (sb-kernel:array-header-p object
)
565 (sb-kernel:%array-displaced-p object
))
566 (array-element-type object
)
567 (array-dimensions object
)))
569 (defun simple-cons-pair-p (object)
572 (defmethod inspected-description ((object cons
))
573 (if (simple-cons-pair-p object
)
575 (inspected-description-of-nontrivial-list object
)))
577 (defun dotted-safe-length (object)
578 "Returns (VALUES LENGTH PROPER-P) where length is the number of cons cells"
579 (do ((length 0 (1+ length
))
580 (lst object
(cdr lst
)))
584 (values length nil
)))
585 ;; nothing to do in body
588 (defun inspected-description-of-nontrivial-list (object)
589 (multiple-value-bind (length proper-p
) (dotted-safe-length object
)
591 (format nil
"a proper list with ~D element~:*~P" length
)
592 (format nil
"a dotted list with ~D element~:*~P + tail" length
))))
594 (defmethod inspected-description ((object double-float
))
595 (format nil
"double-float ~W" object
))
597 (defmethod inspected-description ((object single-float
))
598 (format nil
"single-float ~W" object
))
600 (defmethod inspected-description ((object fixnum
))
601 (format nil
"fixnum ~W" object
))
603 (defmethod inspected-description ((object complex
))
604 (format nil
"complex number ~W" object
))
606 (defmethod inspected-description ((object simple-string
))
607 (format nil
"a simple-string (~W) ~W" (length object
) object
))
609 (defmethod inspected-description ((object bignum
))
610 (format nil
"bignum ~W" object
))
612 (defmethod inspected-description ((object ratio
))
613 (format nil
"ratio ~W" object
))
615 (defmethod inspected-description ((object character
))
616 (format nil
"character ~W char-code #x~X" object
(char-code object
)))
618 (defmethod inspected-description ((object t
))
619 (format nil
"a generic object ~W" object
))
621 (defmethod inspected-description ((object (eql *inspect-unbound-object-marker
*)))
627 ;;; Accepts the arguments OBJECT LENGTH SKIP and returns,
628 ;;; (LIST COMPONENTS SEQ-TYPE COUNT SEQ-HINT)
631 ;;; COMPONENTS are the component parts of OBJECT (whose
632 ;;; representation is determined by SEQ-TYPE). Except for the
633 ;;; SEQ-TYPE :named and :array, components is just the OBJECT itself
635 ;;; SEQ-TYPE determines what representation is used for components
637 ;;; If SEQ-TYPE is :named, then each element is (CONS NAME VALUE)
638 ;;; If SEQ-TYPE is :improper-list, then each element is just value,
639 ;;; but the last element must be retrieved by
640 ;;; (cdr (last components))
641 ;;; If SEQ-TYPE is :list, then each element is a value of an array
642 ;;; If SEQ-TYPE is :vector, then each element is a value of an vector
643 ;;; If SEQ-TYPE is :array, then each element is a value of an array
644 ;;; with rank >= 2. The
646 ;;; COUNT is the total number of components in the OBJECT
648 ;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array
649 ;;; to hold the reverse-dimensions of the orignal array.
651 (declaim (inline parts-components
))
652 (defun parts-components (parts)
655 (declaim (inline parts-count
))
656 (defun parts-count (parts)
659 (declaim (inline parts-seq-type
))
660 (defun parts-seq-type (parts)
663 (declaim (inline parts-seq-hint
))
664 (defun parts-seq-hint (parts)
667 (defgeneric inspected-parts
(object)
670 (defmethod inspected-parts ((object symbol
))
672 (list (cons "name" (symbol-name object
))
673 (cons "package" (symbol-package object
))
674 (cons "value" (if (boundp object
)
675 (symbol-value object
)
676 *inspect-unbound-object-marker
*))
677 (cons "function" (if (fboundp object
)
678 (symbol-function object
)
679 *inspect-unbound-object-marker
*))
680 (cons "plist" (symbol-plist object
)))))
681 (list components
(length components
) :named nil
)))
683 (defun inspected-structure-parts (object)
684 (let ((components-list '())
685 (info (sb-kernel:layout-info
(sb-kernel:layout-of object
))))
686 (when (sb-kernel::defstruct-description-p info
)
687 (dolist (dd-slot (sb-kernel:dd-slots info
) (nreverse components-list
))
688 (push (cons (sb-kernel:dsd-%name dd-slot
)
689 (funcall (sb-kernel:dsd-accessor-name dd-slot
) object
))
692 (defmethod inspected-parts ((object structure-object
))
693 (let ((components (inspected-structure-parts object
)))
694 (list components
(length components
) :named nil
)))
696 (defun inspected-standard-object-parts (object)
697 (let ((reversed-components nil
)
698 (class-slots (sb-pcl::class-slots
(class-of object
))))
699 (dolist (class-slot class-slots reversed-components
)
700 (let* ((slot-name (slot-value class-slot
'sb-pcl
::name
))
701 (slot-value (if (slot-boundp object slot-name
)
702 (slot-value object slot-name
)
703 *inspect-unbound-object-marker
*)))
704 (push (cons slot-name slot-value
) reversed-components
)))))
707 (defmethod inspected-parts ((object standard-object
))
708 (let ((components (inspected-standard-object-parts object
)))
709 (list components
(length components
) :named nil
)))
711 (defmethod inspected-parts ((object sb-kernel
:funcallable-instance
))
712 (let ((components (inspected-structure-parts object
)))
713 (list components
(length components
) :named nil
)))
715 (defmethod inspected-parts ((object function
))
716 (let* ((type (sb-kernel:widetag-of object
))
717 (object (if (= type sb-vm
:closure-header-widetag
)
718 (sb-kernel:%closure-fun object
)
720 (components (list (cons "arglist"
721 (sb-kernel:%simple-fun-arglist object
)))))
722 (list components
(length components
) :named nil
)))
724 (defmethod inspected-parts ((object vector
))
725 (list object
(length object
) :vector nil
))
727 (defmethod inspected-parts ((object array
))
728 (let ((size (array-total-size object
)))
729 (list (make-array size
:displaced-to object
)
732 (reverse (array-dimensions object
)))))
734 (defmethod inspected-parts ((object cons
))
735 (if (simple-cons-pair-p object
)
736 (inspected-parts-of-simple-cons object
)
737 (inspected-parts-of-nontrivial-list object
)))
739 (defun inspected-parts-of-simple-cons (object)
740 (let ((components (list (cons "car" (car object
))
741 (cons "cdr" (cdr object
)))))
742 (list components
2 :named nil
)))
744 (defun inspected-parts-of-nontrivial-list (object)
745 (multiple-value-bind (count proper-p
) (dotted-safe-length object
)
747 (list object count
:list nil
)
748 ;; count tail element
749 (list object
(1+ count
) :improper-list nil
))))
751 (defmethod inspected-parts ((object complex
))
752 (let ((components (list (cons "real" (realpart object
))
753 (cons "imag" (imagpart object
)))))
754 (list components
(length components
) :named nil
)))
756 (defmethod inspected-parts ((object ratio
))
757 (let ((components (list (cons "numerator" (numerator object
))
758 (cons "denominator" (denominator object
)))))
759 (list components
(length components
) :named nil
)))
761 (defmethod inspected-parts ((object t
))
762 (list nil
0 nil nil
))
765 ;; FIXME - implement setting of component values
767 (defgeneric set-component-value
(object component-id value element
))
769 (defmethod set-component-value ((object cons
) id value element
)
770 (format nil
"Cons object does not support setting of component ~A" id
))
772 (defmethod set-component-value ((object array
) id value element
)
773 (format nil
"Array object does not support setting of component ~A" id
))
775 (defmethod set-component-value ((object symbol
) id value element
)
776 (format nil
"Symbol object does not support setting of component ~A" id
))
778 (defmethod set-component-value ((object structure-object
) id value element
)
779 (format nil
"Structure object does not support setting of component ~A" id
))
781 (defmethod set-component-value ((object standard-object
) id value element
)
782 (format nil
"Standard object does not support setting of component ~A" id
))
784 (defmethod set-component-value ((object t
) id value element
)
785 (format nil
"Object does not support setting of component ~A" id
))