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+ 10))
  14
  15 (defstruct inspect
  16   ;; stack of parents of inspected object
  17   object-stack
  18   ;;  a stack of indices of parent object components
  19   parent-stack)
  20
  21 ;; FIXME - raw mode isn't currently used in object display
  22 (defparameter *current-inspect* nil
  23   "current inspect")
  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")
  30
  31 (defvar *inspect-help*
  32 ":istep takes between 0 to 3 arguments.
  33 The commands are:
  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
  43 :i -           inspect parent
  44 :i ^           inspect parent
  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
  52 ")
  53
  54 ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it
  55 ;;; indicates that that a slot is unbound.
  56 (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))
  57
  58
  59 ;; Setup binding for multithreading
  60 (let ((*current-inspect* nil)
  61       (*inspect-raw* nil)
  62       (*inspect-length* +default-inspect-length+)
  63       (*inspect-skip* 0))
  64
  65 (defun inspector (object input-stream output-stream)
  66   (declare (ignore input-stream))
  67   (setq object (eval object))
  68   (setq *current-inspect* (make-inspect))
  69   (new-break :inspect *current-inspect*)
  70   (reset-stack)
  71   (setf (inspect-object-stack *current-inspect*) (list object))
  72   (setf (inspect-parent-stack *current-inspect*)
  73         (list (format nil "(inspect ~S)" object)))
  74   (%inspect output-stream))
  75
  76
  77 (defun set-current-inspect (inspect)
  78   (setq *current-inspect* inspect))
  79
  80 (defun istep (arg-string output-stream)
  81   (%istep arg-string output-stream))
  82
  83 (setq sb-impl::*inspect-fun* #'inspector)
  84
  85 (defun reset-stack ()
  86   (setf (inspect-object-stack *current-inspect*) nil)
  87   (setf (inspect-parent-stack *current-inspect*) nil))
  88
  89 (defun %istep (arg-string output-stream)
  90   (unless *current-inspect*
  91     (setq *current-inspect* (make-inspect)))
  92   (let* ((args (when arg-string (string-to-list-skip-spaces arg-string)))
  93          (option (car args))
  94          (option-read (when arg-string
  95                         (read-from-string arg-string)))
  96          (stack (inspect-object-stack *current-inspect*)))
  97     (cond
  98       ;; Redisplay
  99       ((or (string= "=" option)
 100            (zerop (length args)))
 101        (%inspect output-stream))
 102       ;; Select parent
 103       ((or (string= "-" option)
 104            (string= "^" option))
 105        (cond
 106          ((> (length stack) 1)
 107           (pop stack)
 108           (%inspect output-stream))
 109          (stack
 110           (format output-stream "Object has no parent.~%"))
 111          (t
 112           (%inspect output-stream))))
 113       ;; Select * to inspect
 114       ((string= "*" option)
 115        (reset-stack)
 116        (setf (inspect-object-stack *current-inspect*) (list *))
 117        (setf (inspect-parent-stack *current-inspect*) (list "(inspect ...)"))
 118        (set-break-inspect *current-inspect*)
 119        (%inspect output-stream))
 120       ;; Start new inspect level for eval'd form
 121       ((string= "+" option)
 122        (inspector (eval (read-from-string (second args))) nil output-stream))
 123       ;; Next or previous parent component
 124       ((or (string= "<" option)
 125            (string= ">" option))
 126        (if stack
 127            (if (eq (length stack) 1)
 128                (format output-stream "Object does not have a parent")
 129                (let ((parent (second stack))
 130                      (id (car (inspect-parent-stack *current-inspect*))))
 131                  (multiple-value-bind (position list-type elements)
 132                      (find-object-component parent id)
 133                    (declare (list elements)
 134                             (ignore list-type))
 135                    (let ((new-position (if (string= ">" option)
 136                                            (1+ position)
 137                                            (1- position))))
 138                      (if (< -1 new-position (length elements))
 139                          (let ((new-object (elt elements new-position)))
 140                            (setf (car stack) new-object)
 141                            (setf (car (inspect-parent-stack *current-inspect*))
 142                                  (if (integerp id)
 143                                      new-position
 144                                      (read-from-string
 145                                       (car (nth new-position elements)))))
 146                            (%inspect output-stream))
 147                          (format output-stream "Parent has no selectable component indexed by ~d"
 148                                  new-position))))))
 149            (%inspect output-stream)))
 150       ;; Set component to eval'd form
 151       ((string-equal "set" option)
 152        (if stack
 153            (let ((id (when (second args)
 154                          (read-from-string (second args)))))
 155              (multiple-value-bind (position list-type elements)
 156                  (find-object-component (car stack) id)
 157                (declare (ignore list-type))
 158                (if elements
 159                    (if position
 160                        (let ((value-stirng (third args)))
 161                          (when value-stirng
 162                            (let ((new-value (eval (read-from-string (third args)))))
 163                              (let ((result
 164                                     (set-component-value (car stack)
 165                                                          id
 166                                                          new-value
 167                                                          (nth position elements))))
 168                                (typecase result
 169                                  (string
 170                                   (format output-stream result))
 171                                  (t
 172                                   (%inspect output-stream)))))))
 173                        (format output-stream
 174                                "Object has no selectable component named by ~A" id))
 175                    (format output-stream
 176                            "Object has no selectable components"))))
 177              (%inspect output-stream)))
 178       ;; Set/reset raw display mode for components
 179       ((string-equal "raw" option)
 180        (when stack
 181          (when (and (second args)
 182                     (or (null (second args))
 183                         (eq (read-from-string (second args)) t)))
 184            (setq *inspect-raw* t))
 185          (%inspect output-stream)))
 186       ;; Reset stack
 187       ((string-equal "q" option)
 188        (reset-stack)
 189        (set-break-inspect *current-inspect*))
 190       ;; Display help
 191       ((string-equal "?" option)
 192        (format output-stream *inspect-help*))
 193       ;; Set number of components to skip
 194       ((string-equal "skip" option)
 195        (let ((len (read-from-string (second args))))
 196          (if (and (integerp len) (>= len 0))
 197              (let ((*inspect-skip* len))
 198                (%inspect output-stream))
 199              (format output-stream "Skip missing or invalid~%"))))
 200       ;; Print stack tree
 201       ((string-equal "tree" option)
 202        (if stack
 203            (progn
 204              (format output-stream "The current object is:~%")
 205              (dotimes (i (length stack))
 206                (format output-stream "~A, ~A~%"
 207                        (inspected-parts (nth i stack) :description t)
 208                        (let ((select (nth i (inspect-parent-stack *current-inspect*))))
 209                          (typecase select
 210                            (integer
 211                             (format nil "which is componenent number ~d of" select))
 212                            (symbol
 213                             (format nil "which is the ~a component of" select))
 214                            (string
 215                             (format nil "which was selected by ~S" select))
 216                            (t
 217                             (write-to-string select)))))))
 218            (%inspect output-stream)))
 219       ;; Set maximum number of components to print
 220       ((string-equal "print" option)
 221        (let ((len (read-from-string (second args))))
 222          (if (and (integerp len) (plusp len))
 223              (setq *inspect-length* len)
 224              (format output-stream "Cannot set print limit to ~A~%" len))))
 225       ;; Select numbered or named component
 226       ((or (symbolp option-read)
 227            (integerp option-read))
 228        (if stack
 229            (multiple-value-bind (position list-type elements)
 230                (find-object-component (car stack) option-read)
 231              (cond
 232                ((integerp position)
 233                 (let* ((element (elt elements position))
 234                        (value (if (eq list-type :named) (cdr element) element)))
 235                   (cond ((eq value *inspect-unbound-object-marker*)
 236                          (format output-stream "That slot is unbound~%"))
 237                         (t
 238                          (push value (inspect-object-stack *current-inspect*))
 239                          (push option-read (inspect-parent-stack *current-inspect*))
 240                          (%inspect output-stream)))))
 241                ((null elements)
 242                 (format output-stream "Object does not contain any subobjects~%"))
 243                (t
 244                 (typecase option-read
 245                   (symbol
 246                    (format output-stream
 247                            "Object has no selectable component named ~A"
 248                            option))
 249                   (integer
 250                    (format output-stream
 251                            "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%"
 252                            option-read
 253                            (= (length elements) 1)
 254                            (1- (length elements))))))))
 255            (%inspect output-stream)))
 256       ;; Default is to select eval'd form
 257       (t
 258        (reset-stack)
 259        (let ((object (eval option-read)))
 260          (setf (inspect-object-stack *current-inspect*) (list object))
 261          (setf (inspect-parent-stack *current-inspect*)
 262                (list (format nil ":i ~S" object))))
 263        (set-break-inspect *current-inspect*)
 264        (%inspect output-stream))
 265       )))
 266
 267 (defun find-object-component (object id)
 268   "COMPONENT-ID can be an integer or a name of a id.
 269 Returns POSITION LIST-TYPE ELEMENTS
 270 POSITION is NIL if the id is invalid or not found."
 271   (if object
 272       (multiple-value-bind (description list-type elements)
 273           (inspected-parts object)
 274         (declare (ignore description)
 275                  (list elements))
 276         (when (symbolp id)
 277           (setq id (symbol-name id)))
 278         (let ((position
 279                (cond ((and (eq list-type :named)
 280                            (stringp id))
 281                       (position id elements :key #'car :test #'string-equal))
 282                      ((numberp id)
 283                       (when (< -1 id (length elements))
 284                         id)))))
 285           (values position list-type elements)))
 286       (values nil nil nil)))
 287
 288
 289 (defun %inspect (s)
 290   (if (inspect-object-stack *current-inspect*)
 291       (let ((inspected (car (inspect-object-stack *current-inspect*))))
 292         (setq cl:* inspected)
 293         (multiple-value-bind (description list-type elements)
 294             (inspected-parts inspected)
 295           (display-inspected-parts inspected description list-type elements s)))
 296       (format s "No object is being inspected")))
 297
 298
 299 (defun current-length ()
 300   "returns the current LENGTH for component display"
 301     *inspect-length*)
 302
 303 (defun current-skip ()
 304   "returns the current SKIP for component display"
 305     *inspect-skip*)
 306
 307
 308 (defun display-inspected-parts (object description list-type elements stream)
 309   (format stream "~&~A" description)
 310   (unless (or (characterp object) (typep object 'fixnum))
 311     (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object)))
 312   (princ #\newline stream)
 313   (when elements
 314     (let* ((n-elem (length elements))
 315            (last (1- n-elem))
 316            (max (min last (+ *inspect-skip* *inspect-length*))))
 317       (do* ((index *inspect-skip* (1+ index))
 318             (count (if (typep elements 'sequence)
 319                        (length elements)
 320                        0))
 321             (element))
 322            ((> index max))
 323         (setq element (elt elements index))
 324         (cond
 325           ((eq list-type :index-with-tail)
 326            (if (eql index (- count 1))
 327                (format stream "~4,' D ~A~%" "tail" (inspected-parts element :description t))
 328                (format stream "~4,' D ~A~%" index (inspected-parts element :description t))))
 329           ((eq list-type :named)
 330            (destructuring-bind (name . value) element
 331              (format stream "~4,' D ~16,1,1,'-A> ~A~%" index (format nil "~A "  name)
 332                      (if (eq value *inspect-unbound-object-marker*)
 333                          "..unbound.."
 334                          (inspected-parts value :description t)))))
 335           (t
 336            (format stream "~4,' D ~A~%" index (inspected-parts element :description t)))))
 337       (when (< (+ *inspect-skip* *inspect-length*) last)
 338         (format stream "~&   ...~%~4,' D ~A~%" last (elt elements last))))
 339     ))
 340
 341 ) ;; end binding for multithreading
 342
 343
 344 \f
 345 ;;; INSPECTED-PARTS
 346 ;;;
 347 ;;; 20030408 - Reworked by KMR to take a :DESCRIPTION keyword
 348 ;;;            and to return LIST-TYPE rather than NAMED-P
 349 ;;;
 350 ;;; Destructure an object for inspection, returning either
 351 ;;;   DESCRIPTION
 352 ;;; if description keyword is T, otherwise returns
 353 ;;;   (VALUES DESCRIPTION LIST-TYPE ELEMENTS),
 354 ;;; where..
 355 ;;;
 356 ;;;   DESCRIPTION is a summary description of the destructured object,
 357 ;;;   e.g. "the object is a CONS.~%".
 358 ;;;
 359 ;;;   LIST-TYPE determines what representation is used for elements
 360 ;;;   of ELEMENTS.
 361 ;;;      If LIST-TYPE is :named, then each element is (CONS NAME VALUE)
 362 ;;;      If LIST-TYPE is :index-with-tail, then each element is just value,
 363 ;;;        but the last element is labelled as "tail"
 364 ;;;      If LIST-TYPE is :long, then each element is just value,
 365 ;;;        and suspension points ('...) are shown before the last element.
 366 ;;;      Otherwise, each element is just VALUE.
 367 ;;;
 368 ;;;   ELEMENTS is a list of the component parts of OBJECT (whose
 369 ;;;   representation is determined by LIST-TYPE).
 370 ;;;
 371 ;;; (LIST-TYPE is useful because symbols and instances
 372 ;;; need to display both a slot name and a value, while lists and
 373 ;;; vectors need only display a value.)
 374
 375 (defgeneric inspected-parts (object &key description))
 376
 377 (defmethod inspected-parts ((object symbol) &key description)
 378   (let ((desc (format nil "the symbol ~A" object (sb-kernel:get-lisp-obj-address object))))
 379     (if description
 380         desc
 381         (values desc :named
 382                 (list (cons "name" (symbol-name object))
 383                       (cons "package" (symbol-package object))
 384                       (cons "value" (if (boundp object)
 385                                         (symbol-value object)
 386                                         *inspect-unbound-object-marker*))
 387                       (cons "function" (if (fboundp object)
 388                                            (symbol-function object)
 389                                            *inspect-unbound-object-marker*))
 390                       (cons "plist" (symbol-plist object)))))))
 391
 392 (defun inspected-structure-elements (object)
 393   (let ((parts-list '())
 394         (info (sb-kernel:layout-info (sb-kernel:layout-of object))))
 395     (when (sb-kernel::defstruct-description-p info)
 396       (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse parts-list))
 397         (push (cons (sb-kernel:dsd-%name dd-slot)
 398                     (funcall (sb-kernel:dsd-accessor-name dd-slot) object))
 399               parts-list)))))
 400
 401 (defmethod inspected-parts ((object structure-object) &key description)
 402   (let ((desc (format nil "~W" (find-class (type-of object)))))
 403     (if description
 404         desc
 405         (values desc :named (inspected-structure-elements object)))))
 406
 407 (defmethod inspected-parts ((object package) &key description)
 408   (let ((desc (format nil "the ~A package" (package-name object))))
 409     (if description
 410         desc
 411         (values desc :named (inspected-structure-elements object)))))
 412
 413 (defun inspected-standard-object-elements (object)
 414   (let ((reversed-elements nil)
 415         (class-slots (sb-pcl::class-slots (class-of object))))
 416     (dolist (class-slot class-slots (nreverse reversed-elements))
 417       (let* ((slot-name (slot-value class-slot 'sb-pcl::name))
 418              (slot-value (if (slot-boundp object slot-name)
 419                              (slot-value object slot-name)
 420                              *inspect-unbound-object-marker*)))
 421         (push (cons slot-name slot-value) reversed-elements)))))
 422
 423 (defmethod inspected-parts ((object standard-object) &key description)
 424   (let ((desc (format nil "~W" (class-of object))))
 425     (if description
 426         desc
 427         (values desc :named
 428                 (inspected-standard-object-elements object)))))
 429
 430 (defmethod inspected-parts ((object sb-kernel:funcallable-instance) &key description)
 431   (let ((desc (format nil "a funcallable-instance of type ~S"
 432                       (type-of object))))
 433     (if description
 434         desc
 435         (values desc :named
 436                 (inspected-structure-elements object)))))
 437
 438 (defmethod inspected-parts ((object function) &key description)
 439   (let* ((type (sb-kernel:widetag-of object))
 440          (object (if (= type sb-vm:closure-header-widetag)
 441                      (sb-kernel:%closure-fun object)
 442                      object))
 443          (desc (format nil "~S" object)))
 444     (if description
 445         desc
 446         (values desc :named
 447                 (list (cons "arglist" (sb-kernel:%simple-fun-arglist object)))))))
 448
 449 (defmethod inspected-parts ((object vector) &key description)
 450   (declare (vector object))
 451   (let ((desc  (format nil
 452                   "a ~:[~;displaced ~]vector (~W)"
 453                   (and (sb-kernel:array-header-p object)
 454                        (sb-kernel:%array-displaced-p object))
 455                   (length object)
 456                   (sb-kernel:get-lisp-obj-address object))))
 457     (if description
 458         desc
 459         (values desc nil object))))
 460
 461 (defun inspected-index-string (index rev-dimensions)
 462   (if (null rev-dimensions)
 463       "[]"
 464       (let ((list nil))
 465         (dolist (dim rev-dimensions)
 466           (multiple-value-bind (q r) (floor index dim)
 467             (setq index q)
 468             (push r list)))
 469         (format nil "[~W~{,~W~}]" (car list) (cdr list)))))
 470
 471 (defmethod inspected-parts ((object simple-vector) &key description)
 472   (declare (simple-vector object))
 473   (let ((desc (format nil "a simple ~A vector (~D)"
 474                       (array-element-type object)
 475                       (length object))))
 476     (if description
 477         desc
 478         (values desc nil object))))
 479
 480 (defmethod inspected-parts ((object array) &key description)
 481   (declare (array object))
 482   (let* ((length (array-total-size object))
 483          (reference-array (make-array length :displaced-to object))
 484          (dimensions (array-dimensions object))
 485          (reversed-elements nil)
 486          (desc (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W"
 487                        (and (sb-kernel:array-header-p object)
 488                             (sb-kernel:%array-displaced-p object))
 489                        (array-element-type object)
 490                        dimensions)))
 491     (declare (array reference-array))
 492     (if description
 493         desc
 494         (progn
 495           (dotimes (i length)
 496             (push (cons (format nil "~A "
 497                                 (inspected-index-string i (reverse dimensions)))
 498                         (aref reference-array i))
 499                   reversed-elements))
 500           (values desc :named (nreverse reversed-elements))))))
 501
 502 (defmethod inspected-parts ((object cons) &key description)
 503   (if (or (consp (cdr object)) (null (cdr object)))
 504       (inspected-parts-of-nontrivial-list object description)
 505       (inspected-parts-of-simple-cons object description)))
 506
 507 (defun inspected-parts-of-simple-cons (object description)
 508   (let ((desc (format nil "a cons pair")))
 509     (if description
 510         desc
 511         (values desc :named
 512                 (list (cons "car" (car object))
 513                       (cons "cdr" (cdr object)))))))
 514
 515 (defun inspected-parts-of-nontrivial-list (object description)
 516   (let ((length 0)
 517         (in-list object)
 518         (reversed-elements nil))
 519     (flet ((done (description-format list-type)
 520              (let ((desc (format nil description-format length length)))
 521                (return-from inspected-parts-of-nontrivial-list
 522                  (if description
 523                      desc
 524                      (values desc list-type (nreverse reversed-elements)))))))
 525       (loop
 526        (cond ((null in-list)
 527               (done "a proper list with ~D element~P" nil))
 528              ((consp in-list)
 529               (push (pop in-list) reversed-elements)
 530               (incf length))
 531              (t
 532               (push in-list reversed-elements)
 533               (done "a improper list with ~D element~P" :index-with-tail)))))))
 534
 535 (defmethod inspected-parts ((object simple-string) &key description)
 536   (let ((desc (format nil "a simple-string (~W) ~W" (length object) object)))
 537     (if description
 538         desc
 539         (values desc nil object))))
 540
 541 (defmethod inspected-parts ((object double-float) &key description)
 542   (let ((desc (format nil "double-float ~W" object)))
 543     (if description
 544         desc
 545         (values desc nil nil))))
 546
 547 (defmethod inspected-parts ((object single-float) &key description)
 548   (let ((desc (format nil "single-float ~W" object)))
 549     (if description
 550         desc
 551         (values desc nil nil))))
 552
 553 (defmethod inspected-parts ((object fixnum) &key description)
 554   (let ((desc (format nil "fixnum ~W" object)))
 555     (if description
 556         desc
 557         (values desc nil nil))))
 558
 559 (defmethod inspected-parts ((object complex) &key description)
 560   (let ((desc (format nil "complex number ~W" object)))
 561     (if description
 562         desc
 563         (values desc :named
 564                 (list (cons "real" (realpart object))
 565                       (cons "imag" (imagpart object)))))))
 566
 567 (defmethod inspected-parts ((object bignum) &key description)
 568   (let ((desc (format nil "bignum ~W" object)))
 569     (if description
 570         desc
 571         (values desc nil nil))))
 572
 573 (defmethod inspected-parts ((object ratio) &key description)
 574   (let ((desc (format nil "ratio ~W" object)))
 575     (if description
 576         desc
 577         (values desc :named
 578                 (list (cons "numerator" (numerator object))
 579                       (cons "denominator" (denominator object)))))))
 580
 581 (defmethod inspected-parts ((object character) &key description)
 582   (let ((desc (format nil "character ~W char-code #x~X" object (char-code object))))
 583     (if description
 584         desc
 585         (values desc nil nil))))
 586
 587 (defmethod inspected-parts ((object t) &key description)
 588   (let ((desc (format nil "a generic object ~W" object)))
 589     (if description
 590         desc
 591         (values desc nil nil))))
 592
 593 ;; FIXME - implement setting of component values
 594
 595 (defgeneric set-component-value (object component-id value element))
 596
 597 (defmethod set-component-value ((object cons) id value element)
 598   (format nil "Cons object does not support setting of component ~A" id))
 599
 600 (defmethod set-component-value ((object array) id value element)
 601   (format nil "Array object does not support setting of component ~A" id))
 602
 603 (defmethod set-component-value ((object symbol) id value element)
 604   (format nil "Symbol object does not support setting of component ~A" id))
 605
 606 (defmethod set-component-value ((object structure-object) id value element)
 607   (format nil "Structure object does not support setting of component ~A" id))
 608
 609 (defmethod set-component-value ((object standard-object) id value element)
 610   (format nil "Standard object does not support setting of component ~A" id))
 611
 612 (defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element)
 613   (format nil "Funcallable instance object does not support setting of component ~A" id))
 614
 615 (defmethod set-component-value ((object function) id value element)
 616   (format nil "Function object does not support setting of component ~A" id))
 617
 618 ;; whn believes it is unsafe to change components of this object
 619 (defmethod set-component-value ((object complex) id value element)
 620   (format nil "Object does not support setting of component ~A" id))
 621
 622 ;; whn believes it is unsafe to change components of this object
 623 (defmethod set-component-value ((object ratio) id value element)
 624   (format nil "Object does not support setting of component ~A" id))
 625
 626 (defmethod set-component-value ((object t) id value element)
 627   (format nil "Object does not support setting of component ~A" id))
 628