X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/234b4f80d856564a7349989b7f4ab528d4e520a5..fcdb9e3641b6b833f7f02538c2a777dda1d43602:/examples/ginspect.lisp diff --git a/examples/ginspect.lisp b/examples/ginspect.lisp index 66e5e99..c6de18e 100644 --- a/examples/ginspect.lisp +++ b/examples/ginspect.lisp @@ -1,7 +1,39 @@ -(in-package :gtk) +;; Common Lisp bindings for GTK+ 2.x +;; Copyright 2005 Espen S. Johnsen +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; $Id: ginspect.lisp,v 1.13 2006-09-06 11:43:41 espen Exp $ + +#+sbcl(require :gtk) +#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk) + +(defpackage "GINSPECT" + (:use "COMMON-LISP" "GFFI" "GLIB" "GTK" #+cmu"PCL" #+sbcl"SB-PCL" #+clisp"MOP") + #+clisp(:shadowing-import-from "MOP" "SLOT-DEFINITION-TYPE") + (:export "GINSPECT" "GINSPECT-TOPLEVELS")) + +(in-package "GINSPECT") (defvar *ginspect-unbound-object-marker* - #+cmu (gensym "UNBOUND-OBJECT-") + #+(or cmu clisp)(gensym "UNBOUND-OBJECT-") #+sbcl sb-impl::*inspect-unbound-object-marker*) @@ -11,6 +43,12 @@ (defgeneric object-has-parts-p (object)) (defgeneric decompose-describe-object (object)) +;; A container to hold lisp objects "inside" the tree store +(defclass object-container (gobject) + ((object :initarg :object)) + (:metaclass gobject-class)) + + (defun ginspect (object) (let* ((store (make-instance 'tree-store :column-types '(string string gobject boolean) @@ -38,8 +76,8 @@ (defun ginspect (object) ;; Remove old children (when valid (loop while (tree-store-remove store child-iter)))) - (let ((gobject (tree-model-value store iter 'object))) - (insert-parts (object-data gobject 'object) store iter)) + (let ((container (tree-model-value store iter 'object))) + (insert-parts (slot-value container 'object) store iter)) (tree-view-expand-row view path nil)))) (make-instance 'dialog @@ -57,7 +95,8 @@ (defmethod decompose-describe-object ((object t)) (if (equal parts (list object)) (values description nil nil) (values description named-p parts))) - (sb-impl::inspected-parts object)) + #+sbcl(sb-impl::inspected-parts object) + #+clisp(values (format nil "The object is an ATOM of type ~A" (type-of object) nil nil))) (defmethod decompose-describe-object ((object (eql t))) (values (call-next-method) nil nil)) @@ -73,6 +112,7 @@ (defmethod decompose-describe-object ((object cons)) (values (call-next-method) nil object) (values "The object is a CONS." nil (list (car object) (cdr object))))) +#+(or cmu sbcl) (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer #+sbcl sb-alien:system-area-pointer)) (values "The object is a SYSTEM-AREA-POINTER" nil nil)) @@ -80,32 +120,42 @@ (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer (defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*))) (values "The slot is unbound" nil nil)) -#+cmu +#+(or cmu clisp) (defmethod decompose-describe-object ((object symbol)) (values (call-next-method) t - (cons "Name" (symbol-name object)) - (cons "Package" (symbol-package objecy)) - (cons "Value" (if (boundp object) - (symbol-value object) - *ginspect-unbound-object-marker*)) - (cons "Function" (if (fboundp object) - (symbol-function object) - *ginspect-unbound-object-marker*)) - (cons "Plist" (symbol-plist object)))) - -#+cmu + (list + (cons "Name" (symbol-name object)) + (cons "Package" (symbol-package object)) + (cons "Value" (if (boundp object) + (symbol-value object) + *ginspect-unbound-object-marker*)) + (cons "Function" (if (fboundp object) + (symbol-function object) + *ginspect-unbound-object-marker*)) + (cons "Plist" (symbol-plist object))))) + (defmethod decompose-describe-object ((object standard-object)) (values - (call-next-method) t + (format nil "The instance is an object of type ~A" + (class-name (class-of object))) + t (loop for slotd in (class-slots (class-of object)) - collect (let* ((slot-name (pcl:slot-definition-name slotd)) + when (slot-readable-p slotd) + collect (let* ((slot-name (slot-definition-name slotd)) (slot-value (if (slot-boundp object slot-name) (slot-value object slot-name) *ginspect-unbound-object-marker*))) (cons (string slot-name) slot-value))))) +#+clisp +(defmethod decompose-describe-object ((object vector)) + (values + (format nil "The object is a ~A of length ~A" (type-of object) (length object)) + nil + (coerce object 'list))) + (defmethod object-has-parts-p ((object t)) (nth-value 2 (decompose-describe-object object))) @@ -128,15 +178,14 @@ (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*))) "") (defmethod insert-object ((object t) store parent &optional (name "")) - (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on + (let ((container (make-instance 'object-container :object object)) (has-parts (object-has-parts-p object))) - (setf (object-data gobject 'object) object) (let ((iter (tree-store-append store parent (vector name (object-to-string object) - gobject (not has-parts))))) + container (not has-parts))))) (when has-parts ;; Insert dummy child - (tree-store-append store iter (vector "" "" gobject t)))))) + (tree-store-append store iter (vector "" "" container t)))))) (defmethod insert-parts :around ((object t) store parent) (when (object-has-parts-p object)