January 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/system.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23128 Modified Files: system.lisp Log Message: Add method-browser to clim-examples system. Date: Sun Jan 30 22:24:58 2005 Author: ahefner Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.109 mcclim/system.lisp:1.110 --- mcclim/system.lisp:1.109 Tue Jan 18 04:20:15 2005 +++ mcclim/system.lisp Sun Jan 30 22:24:58 2005 @@ -210,6 +210,7 @@ "Examples/stream-test" "Examples/presentation-test" #+clx "Examples/gadget-test" + "Examples/method-browser" "Goatee/goatee-test" "Examples/accepting-values")

1 0

[mcclim-cvs] CVS update: mcclim/Examples/method-browser.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv23100 Added Files: method-browser.lisp Log Message: Added method-browser app to examples. Date: Sun Jan 30 22:24:24 2005 Author: ahefner

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv22327 Modified Files: gadgets.lisp Log Message: Add standard-sheet-input-mixin to superclasses of generic-list-pane in order to make it work within the popup menu of the option-pane in unithreaded SBCL (and presumably other non-MP lisps). This feels like a hack. Date: Sun Jan 30 22:09:55 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.86 mcclim/gadgets.lisp:1.87 --- mcclim/gadgets.lisp:1.86 Sat Jan 1 21:25:38 2005 +++ mcclim/gadgets.lisp Sun Jan 30 22:09:55 2005 @@ -100,8 +100,6 @@ ;; - the slider needs a total overhaul -;; - OPTION-PANE needs an implmentation - ;; - TEXT-FILED, TEXT-AREA dito ;; - GADGET-COLOR-MIXIN is currently kind of dangling, we should reuse @@ -1984,6 +1982,7 @@ :documentation "A function to compare two items for equality."))) (defclass generic-list-pane (list-pane meta-list-pane + standard-sheet-input-mixin ;; Hmm.. value-changed-repaint-mixin mouse-wheel-scroll-mixin) ((highlight-ink :initform +royalblue4+ @@ -2405,22 +2404,25 @@ (multiple-value-bind (x0 y0 x1 y1) (multiple-value-call #'values (transform-position (sheet-delta-transformation parent nil) cx0 cy0) - (transform-position (sheet-delta-transformation parent nil) cx1 cy1)) - (let* ((topmost-pane (if scroll-p + (transform-position (sheet-delta-transformation parent nil) cx1 cy1)) + ;; Note: This :suggested-width/height business is really a silly hack + ;; which I could have easily worked around without adding kludges + ;; to the scroller-pane.. + (let* ((topmost-pane (if scroll-p ;list-pane (scrolling (:scroll-bar :vertical :suggest-height height ;; Doesn't appear to be working.. :suggest-width (if scroll-p (+ 30 (bounding-rectangle-width list-pane)))) list-pane) list-pane)) - (topmost-pane (outlining (:thickness 1) topmost-pane)) + (topmost-pane (outlining (:thickness 1) topmost-pane)) (composed-height (space-requirement-height (compose-space topmost-pane :width (- x1 x0) :height height))) - (menu-frame (make-menu-frame topmost-pane - :min-width (bounding-rectangle-width parent) - :left x0 - :top (if (eq position :below) - y1 - (- y0 composed-height 1))))) + (menu-frame (make-menu-frame topmost-pane + :min-width (bounding-rectangle-width parent) + :left x0 + :top (if (eq position :below) + y1 + (- y0 composed-height 1))))) (values list-pane topmost-pane menu-frame))))))) (defun popup-list-box (parent)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv12131 Modified Files: inspector.lisp Log Message: Many improvements, both to functionality and to the structure of the code. (thanks to Vincent Arkesteijn) Date: Sat Jan 29 22:02:56 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.6 mcclim/Apps/Inspector/inspector.lisp:1.7 --- mcclim/Apps/Inspector/inspector.lisp:1.6 Sat Jan 29 07:57:28 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 22:02:56 2005 @@ -25,7 +25,7 @@ (in-package :inspector) (define-application-frame inspector () - ((dico :initform (make-hash-table :test #'eq) :reader dico) + ((dico :initform (make-hash-table) :reader dico) (obj :initarg :obj :reader obj)) (:pointer-documentation t) (:panes @@ -41,6 +41,14 @@ (declare (ignore args)) (setf (gethash (obj frame) (dico frame)) t)) +(defmethod redisplay-frame-pane :after ((frame inspector) + (pane application-pane) + &key force-p) + (declare (ignore force-p)) + (change-space-requirements + pane + :height (bounding-rectangle-height (stream-output-history pane)))) + (defun inspector (obj) (let ((*print-length* 10) (*print-level* 10)) @@ -49,31 +57,24 @@ (defparameter *inspected-objects* '()) -(defun currently-viewable (obj) - (multiple-value-bind (value present) - (gethash obj (dico *application-frame*)) - (if present - value - (setf (gethash obj - (dico *application-frame*)) - (or (symbolp obj) - (numberp obj) - (stringp obj)))))) - +(defgeneric inspect-object-briefly (object pane)) (defgeneric inspect-object (object pane)) (defmethod inspect-object :around (object pane) - (cond ((not (currently-viewable object)) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (princ "..."))) - ((member object *inspected-objects*) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (princ "==="))) - (t - (let ((*inspected-objects* (cons object *inspected-objects*))) - (call-next-method))))) + (cond ((member object *inspected-objects*) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ "==="))) + ((not (gethash object (dico *application-frame*))) + (inspect-object-briefly object pane)) + (t + (let ((*inspected-objects* (cons object *inspected-objects*))) + (call-next-method))))) + +(defmethod inspect-object-briefly (object pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ "..."))) (defmethod inspect-object (object pane) (with-output-as-presentation @@ -120,27 +121,40 @@ (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) +(defmacro inspector-table (header &body body) + `(with-output-as-presentation + (pane object (presentation-type-of object)) + (formatting-table (pane) + (formatting-column (pane) + (formatting-cell (pane) + (surrounding-output-with-border (pane) + ,header)) + (formatting-cell (pane) + (formatting-table (pane) + ,@body)))))) + +(defmacro inspector-table-row (left right) + `(formatting-row (pane) + (formatting-cell (pane :align-x :right) + ,left) + (formatting-cell (pane) + ,right))) + +(defmethod inspect-object-briefly ((object standard-object) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "instance of ~S" (class-name (class-of object))))) (defmethod inspect-object ((object standard-object) pane) (let ((class (class-of object))) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (formatting-table (pane) - (formatting-row (pane) - (formatting-cell (pane) - (surrounding-output-with-border (pane) - (print (class-name class) pane)))) - (formatting-row (pane) - (formatting-cell (pane) - (formatting-table (pane) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) - (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (with-output-as-presentation - (pane (cons object slot-name) 'settable-slot) - (format pane "~a:" slot-name))) - (formatting-cell (pane) - (inspect-object (slot-value object slot-name) pane)))))))))))) + (inspector-table + (print (class-name class) pane) + (loop for slot in (reverse (class-slots class)) + do (let ((slot-name (slot-definition-name slot))) + (inspector-table-row + (with-output-as-presentation + (pane (cons object slot-name) 'settable-slot) + (format pane "~a:" slot-name)) + (inspect-object (slot-value object slot-name) pane))))))) (defmethod inspect-object ((object cons) pane) (if (null (cdr object)) @@ -172,44 +186,135 @@ (formatting-cell (pane) (inspect-object (cdr object) pane)))))) +(defmethod inspect-object-briefly ((object hash-table) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ 'hash-table pane))) (defmethod inspect-object ((object hash-table) pane) + (inspector-table + (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (loop for key being the hash-keys of object + do (inspector-table-row + (formatting-cell (pane) + (inspect-object key pane) + (princ "=" pane)) + (inspect-object (gethash key object) pane))))) + +(defmethod inspect-object ((object generic-function) pane) + (inspector-table + (format pane "Generic Function: ~s" (generic-function-name object)) + (loop for method in (generic-function-methods object) + do (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (method-specializers method) + do (formatting-cell (pane) + (format pane "~s " (class-name specializer))))))))) + +(defmethod inspect-object-briefly ((object package) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "Package: ~S" (package-name object)))) +(defmethod inspect-object ((object package) pane) + (inspector-table + (format pane "Package: ~S" (package-name object)) + (inspector-table-row + (princ "Name:" pane) + (inspect-object (package-name object) pane)) + (inspector-table-row + (princ "Nicknames:" pane) + (dolist (nick (package-nicknames object)) + (inspect-object nick pane))) + (inspector-table-row + (princ "Used by:") + (dolist (used-by (package-used-by-list object)) + (inspect-object used-by pane))) + (inspector-table-row + (princ "Uses:") + (dolist (uses (package-use-list object)) + (inspect-object uses pane))))) + +(defmethod inspect-object ((object vector) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) - (formatting-column (pane) + (formatting-row (pane) (formatting-cell (pane) - (surrounding-output-with-border (pane) - (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)))) + (princ "#(" pane)) + (dotimes (i (length object)) + (formatting-cell (pane) + (inspect-object (aref object i) pane))) (formatting-cell (pane) - (formatting-table (pane) - (loop for key being the hash-keys of object - do (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (inspect-object key pane) - (princ "=" pane)) - (formatting-cell (pane) - (inspect-object (gethash key object) pane)))))))))) + (princ ")" pane)))))) -(defmethod inspect-object ((object generic-function) pane) +(defmethod inspect-object-briefly ((object string) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) + +(defmethod inspect-object-briefly ((object number) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) + +(defmethod inspect-object ((object complex) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) (formatting-row (pane) - (formatting-cell (pane) - (surrounding-output-with-border (pane) - (format pane "Generic Function: ~s" (generic-function-name object))))) - (formatting-row (pane) - (formatting-cell (pane) - (formatting-table (pane) - (loop for method in (generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) - do (formatting-cell (pane) - (format pane "~s " (class-name specializer))))))))))))) + (formatting-cell (pane) + (princ "#C(" pane)) + (formatting-cell (pane) + (inspect-object (realpart object) pane)) + (formatting-cell (pane) + (inspect-object (imagpart object) pane)) + (formatting-cell (pane) + (princ ")" pane)))))) + +(defmethod inspect-object ((object float) pane) + (inspector-table + (format pane "float ~S" object) + (multiple-value-bind (significand exponent sign) + (decode-float object) + (inspector-table-row + (princ "sign:") + (inspect-object sign pane)) + (inspector-table-row + (princ "significand:") + (inspect-object significand pane)) + (inspector-table-row + (princ "exponent:") + (inspect-object exponent pane))) + (inspector-table-row + (princ "radix:") + (inspect-object (float-radix object) pane)))) + +(defmethod inspect-object-briefly ((object symbol) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) +(defmethod inspect-object ((object symbol) pane) + (inspector-table + (format pane "Symbol ~S" (symbol-name object)) + (inspector-table-row + (princ "value:") + (if (boundp object) + (inspect-object (symbol-value object) pane) + (princ "unbound"))) + (inspector-table-row + (princ "function:") + (if (fboundp object) + (inspect-object (symbol-function object) pane) + (princ "unbound"))) + (inspector-table-row + (princ "package:") + (inspect-object (symbol-package object) pane)) + (inspector-table-row + (princ "propery list:") + (dolist (property (symbol-plist object)) + (inspect-object property pane))))) (defun display-app (frame pane) (inspect-object (obj frame) pane))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv784 Modified Files: inspector.lisp Log Message: Slots are now presentations. Selecting a slot makes it possible to alter its value. Date: Sat Jan 29 07:57:28 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.5 mcclim/Apps/Inspector/inspector.lisp:1.6 --- mcclim/Apps/Inspector/inspector.lisp:1.5 Sat Jan 29 07:27:36 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:57:28 2005 @@ -110,6 +110,16 @@ #+openmcl (ccl:method-generic-function method) #-(or sbcl openmcl) (error "no MOP")) +(define-presentation-type settable-slot () + :inherit-from t) + +(define-presentation-method present (object (type settable-slot) + stream + (view textual-view) + &key acceptably for-context-type) + (declare (ignore acceptably for-context-type)) + (format stream "~s" (cdr object))) + (defmethod inspect-object ((object standard-object) pane) (let ((class (class-of object))) (with-output-as-presentation @@ -127,7 +137,7 @@ (formatting-row (pane) (formatting-cell (pane :align-x :right) (with-output-as-presentation - (pane slot (present-type-of slot)) + (pane (cons object slot-name) 'settable-slot) (format pane "~a:" slot-name))) (formatting-cell (pane) (inspect-object (slot-value object slot-name) pane)))))))))))) @@ -221,3 +231,8 @@ (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) (remove-method (method-generic-function obj) obj)) + +(define-inspector-command (com-set-slot :name t) + ((slot 'settable-slot :gesture :select :prompt "Set slot")) + (setf (slot-value (car slot) (cdr slot)) + (accept t :prompt "New slot value")))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv31723 Modified Files: inspector.lisp Log Message: slots are now presentations in preparation for a command for assigning slot values. Date: Sat Jan 29 07:27:37 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.4 mcclim/Apps/Inspector/inspector.lisp:1.5 --- mcclim/Apps/Inspector/inspector.lisp:1.4 Sat Jan 29 07:02:57 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:27:36 2005 @@ -126,7 +126,9 @@ do (let ((slot-name (slot-definition-name slot))) (formatting-row (pane) (formatting-cell (pane :align-x :right) - (format pane "~a:" slot-name)) + (with-output-as-presentation + (pane slot (present-type-of slot)) + (format pane "~a:" slot-name))) (formatting-cell (pane) (inspect-object (slot-value object slot-name) pane))))))))))))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30908 Modified Files: inspector.lisp Log Message: Fixed some typos. Thanks to Vincent Arkesteijn. Date: Sat Jan 29 07:02:57 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.3 mcclim/Apps/Inspector/inspector.lisp:1.4 --- mcclim/Apps/Inspector/inspector.lisp:1.3 Sat Jan 29 06:58:29 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:02:57 2005 @@ -3,7 +3,7 @@ ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2005 by -;;; Vincent Arkesteij +;;; Vincent Arkesteijn ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -92,22 +92,22 @@ (defun generic-function-name (generic-function) #+sbcl (sb-mop:generic-function-name generic-function) - #+openmcl (ccl:generic-function-name slot) + #+openmcl (ccl:generic-function-name generic-function) #-(or sbcl openmcl) (error "no MOP")) (defun generic-function-methods (generic-function) #+sbcl (sb-mop:generic-function-methods generic-function) - #+openmcl (ccl:generic-function-methods slot) + #+openmcl (ccl:generic-function-methods generic-function) #-(or sbcl openmcl) (error "no MOP")) (defun method-specializers (method) #+sbcl (sb-mop:method-specializers method) - #+openmcl (ccl:method-specializers slot) + #+openmcl (ccl:method-specializers method) #-(or sbcl openmcl) (error "no MOP")) (defun method-generic-function (method) #+sbcl (sb-mop:method-generic-function method) - #+openmcl (ccl:method-generic-function slot) + #+openmcl (ccl:method-generic-function method) #-(or sbcl openmcl) (error "no MOP")) (defmethod inspect-object ((object standard-object) pane)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30166 Modified Files: inspector.lisp Log Message: Better layout for standard-object Date: Sat Jan 29 06:58:30 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.2 mcclim/Apps/Inspector/inspector.lisp:1.3 --- mcclim/Apps/Inspector/inspector.lisp:1.2 Sat Jan 29 06:48:38 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 06:58:29 2005 @@ -119,13 +119,16 @@ (formatting-cell (pane) (surrounding-output-with-border (pane) (print (class-name class) pane)))) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) - (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (format pane "~a:" slot-name)) - (formatting-cell (pane) - (inspect-object (slot-value object slot-name) pane))))))))) + (formatting-row (pane) + (formatting-cell (pane) + (formatting-table (pane) + (loop for slot in (reverse (class-slots class)) + do (let ((slot-name (slot-definition-name slot))) + (formatting-row (pane) + (formatting-cell (pane :align-x :right) + (format pane "~a:" slot-name)) + (formatting-cell (pane) + (inspect-object (slot-value object slot-name) pane)))))))))))) (defmethod inspect-object ((object cons) pane) (if (null (cdr object))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30104 Modified Files: inspector.lisp Log Message: Better layout for generic functions. Date: Sat Jan 29 06:48:38 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.1 mcclim/Apps/Inspector/inspector.lisp:1.2 --- mcclim/Apps/Inspector/inspector.lisp:1.1 Sat Jan 29 04:10:54 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 06:48:38 2005 @@ -182,16 +182,19 @@ (formatting-row (pane) (formatting-cell (pane) (surrounding-output-with-border (pane) - (print (generic-function-name object) pane)))) - (loop for method in (generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) - do (formatting-cell (pane) - (format pane "~s " (class-name specializer)))))))))) + (format pane "Generic Function: ~s" (generic-function-name object))))) + (formatting-row (pane) + (formatting-cell (pane) + (formatting-table (pane) + (loop for method in (generic-function-methods object) + do (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (method-specializers method) + do (formatting-cell (pane) + (format pane "~s " (class-name specializer))))))))))))) (defun display-app (frame pane) (inspect-object (obj frame) pane))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL mcclim/Apps/Inspector/inspector.asd mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21831 Added Files: INSTALL inspector.asd inspector.lisp Log Message: Embryonic inspector application. Date: Sat Jan 29 04:10:54 2005 Author: rstrandh

1 0