- (let ((parts (nth-value 1 (swank-backend:inspected-parts object))))
- (unless (and (endp (rest parts)) (eq object (cdar parts)))
- (loop
- for (prefix . part) in parts
- do (insert-object part store parent prefix)))))
-
-(defun propper-list-p (object)
- (and (listp object) (null (cdr (last object)))))
-
-(defmethod insert-parts ((object cons) store parent)
- (if (propper-list-p object)
- (loop
- for element in object
- do (insert-object element store parent))
- (progn
- (insert-object (car object) store parent)
- (insert-object (cdr object) store parent))))
-
-(defmethod insert-parts ((object vector) store parent)
- (loop
- for element across object
- do (insert-object element store parent)))
-
-(defmethod insert-parts ((object (eql t)) store parent)
- (declare (ignore object store parent)))
-
-(defmethod object-has-parts-p ((object (eql t)))
- (declare (ignore object))
- nil)
-
-(defmethod insert-parts ((object (eql nil)) store parent)
- (declare (ignore object store parent)))
-
-(defmethod object-has-parts-p ((object (eql nil)))
- (declare (ignore object))
- nil)
-
-(defvar *unbound-object-marker* (gensym "UNBOUND-OBJECT-"))
-
-(defmethod insert-parts ((object symbol) store parent)
- (insert-object
- (if (boundp object)
- (symbol-value object)
- *unbound-object-marker*)
- store parent "Value")
- (insert-object
- (if (fboundp object)
- (symbol-function object)
- *unbound-object-marker*)
- store parent "Function")
- (insert-object (symbol-plist object) store parent "Plist")
- (insert-object (symbol-package object) store parent "Package"))
-
-
-(defmethod insert-parts ((object standard-object) store parent)
- (loop
- for slotd in (class-slots (class-of object))
- do (let* ((slot-name (slot-value slotd 'pcl::name))
- (slot-value (if (slot-boundp object slot-name)
- (slot-value object slot-name)
- *unbound-object-marker*)))
- (insert-object slot-value store parent (string slot-name)))))
-
-(defmethod insert-object ((object (eql *unbound-object-marker*))
- store parent &optional prefix)
- (tree-store-append store parent (vector prefix "<unbound>" (make-instance 'gobject) t nil)))
-
-(defmethod insert-parts ((object (eql *unbound-object-marker*)) store parent)
- (declare (ignore object store parent)))
-
-(defmethod object-has-parts-p ((object character))
- (declare (ignore object))
- nil)
-
-(defmethod object-has-parts-p ((object number))
- (declare (ignore object))
- nil)
-
-(defmethod object-has-parts-p ((object alien:system-area-pointer))
- (declare (ignore object))
- nil)