April 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by pscott＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv26618 Modified Files: inspector.lisp Log Message: When inspecting packages, Clouseau now lists exported symbols. Date: Tue Apr 26 23:35:24 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.31 mcclim/Apps/Inspector/inspector.lisp:1.32 --- mcclim/Apps/Inspector/inspector.lisp:1.31 Sat Apr 2 20:03:59 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Apr 26 23:35:24 2005 @@ -512,6 +512,12 @@ (with-text-family (pane :fix) (princ (package-name object) pane)))) +(defun package-exported-symbols (package) + "Return a list of all symbols exported by PACKAGE" + (let (symbols) + (do-external-symbols (symbol package symbols) + (push symbol symbols)))) + (defmethod inspect-object ((object package) pane) (inspector-table (object pane) (format pane "Package: ~S" (package-name object)) @@ -526,7 +532,10 @@ (inspect-vertical-list (package-used-by-list object) pane)) (inspector-table-row (pane) (princ "Uses:") - (inspect-vertical-list (package-use-list object) pane)))) + (inspect-vertical-list (package-use-list object) pane)) + (inspector-table-row (pane) + (princ "Exports:") + (inspect-vertical-list (package-exported-symbols object) pane)))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Debugger/clim-debugger.lisp
by ahefner＠common-lisp.net 25 Apr '05

25 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Debugger In directory common-lisp.net:/tmp/cvs-serv26063/Debugger Added Files: clim-debugger.lisp Log Message: Checking in Peter Mechlenborg's CLIM debugger. Date: Tue Apr 26 05:19:35 2005 Author: ahefner

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Apps/Debugger
by ahefner＠common-lisp.net 25 Apr '05

25 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Debugger In directory common-lisp.net:/tmp/cvs-serv26023/Debugger Log Message: Directory /project/mcclim/cvsroot/mcclim/Apps/Debugger added to the repository Date: Tue Apr 26 05:16:16 2005 Author: ahefner New directory mcclim/Apps/Debugger added

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 23 Apr '05

23 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29580 Modified Files: graph-formatting.lisp Log Message: Check type of root-objects argument. Date: Sat Apr 23 22:02:02 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.13 mcclim/graph-formatting.lisp:1.14 --- mcclim/graph-formatting.lisp:1.13 Thu Apr 21 05:34:58 2005 +++ mcclim/graph-formatting.lisp Sat Apr 23 22:02:01 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.13 2005/04/21 03:34:58 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.14 2005/04/23 20:02:01 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -133,6 +133,7 @@ (declare (ignore orientation generation-separation within-generation-separation center-nodes)) ;; Mungle some arguments (check-type cutoff-depth (or null integer)) + (check-type root-objects sequence) (setf stream (or stream *standard-output*) graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp
by ahefner＠common-lisp.net 20 Apr '05

20 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv28867 Modified Files: dev-commands.lisp Log Message: Applied patched from Paolo adding vertical grapher orientation to listener commands. Date: Thu Apr 21 05:41:24 2005 Author: ahefner Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.28 mcclim/Apps/Listener/dev-commands.lisp:1.29 --- mcclim/Apps/Listener/dev-commands.lisp:1.28 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Thu Apr 21 05:41:24 2005 @@ -434,7 +434,7 @@ (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) (defparameter *graph-text-style* (make-text-style :fix :roman :normal)) -(defun class-grapher (stream class inferior-fun) +(defun class-grapher (stream class inferior-fun &key (orientation :horizontal)) "Does the graphing for Show Class Superclasses and Subclasses commands" (let ((normal-ink +foreground-ink+) (arrow-ink *graph-edge-ink*) @@ -453,7 +453,7 @@ :stream stream :merge-duplicates T :graph-type :tree - :orientation :horizontal + :orientation orientation :arc-drawer #'(lambda (stream foo bar x1 y1 x2 y2) (declare (ignore foo bar)) @@ -468,20 +468,26 @@ :command-table show-commands :menu "Class Superclasses" :provide-output-destination-keyword t) - ((class-spec 'class-name :prompt "class")) + ((class-spec 'class-name :prompt "class") + &key + (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (null class) (note "~A is not a defined class." class-spec) - (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses)))) + (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses + :orientation orientation)))) (define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands :menu "Class Subclasses" :provide-output-destination-keyword t) - ((class-spec 'class-name :prompt "class")) + ((class-spec 'class-name :prompt "class") + &key + (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (not (null class)) - (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses) + (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses + :orientation orientation) (note "~A is not a defined class." class-spec))))

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 20 Apr '05

20 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28776 Modified Files: graph-formatting.lisp Log Message: Fix bug causing misalignment of graph nodes and edges when using a non-identity medium transformation. (Tranform node positions by medium transformation before inserting into output history, then draw edges in stream coordinates with no medium transformation, so that medium transformation is not applied twice.) Date: Thu Apr 21 05:34:58 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.12 mcclim/graph-formatting.lisp:1.13 --- mcclim/graph-formatting.lisp:1.12 Tue Apr 12 22:43:26 2005 +++ mcclim/graph-formatting.lisp Thu Apr 21 05:34:58 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.12 2005/04/12 20:43:26 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.13 2005/04/21 03:34:58 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -338,8 +338,8 @@ (let ((v (+ v0 (/ (min 0 d) -2)))) (setf (output-record-position node) (if (eq orientation :vertical) - (values v u0) - (values u0 v))) + (transform-position (medium-transformation stream) v u0) + (transform-position (medium-transformation stream) u0 v))) (add-output-record node graph-output-record)) ;; (let ((u (+ u0 (car majors))) @@ -401,6 +401,11 @@ (defmethod layout-graph-edges ((graph standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (orientation) graph + ;; We tranformed the position of the nodes when we inserted them into + ;; output history, so the bounding rectangles queried below will be + ;; transformed. Therefore, disable the transformation now, otherwise + ;; the transformation is effectively applied twice to the edges. + (with-identity-transformation (stream) (traverse-graph-nodes graph (lambda (node children continuation) (unless (eq node graph) @@ -424,7 +429,7 @@ (/ (+ x1 x2) 2) from (/ (+ u1 u2) 2) to arc-drawing-options)))))))) - (map nil continuation children))))) + (map nil continuation children)))))) (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record) stream arc-drawer arc-drawing-options)

1 0

[mcclim-cvs] CVS update: mcclim/stream-output.lisp
by ahefner＠common-lisp.net 20 Apr '05

20 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25453 Modified Files: stream-output.lisp Log Message: Fix assumption in BEEP function that standard output must be a CLIM stream. Date: Thu Apr 21 04:43:20 2005 Author: ahefner Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.54 mcclim/stream-output.lisp:1.55 --- mcclim/stream-output.lisp:1.54 Sun Apr 17 18:42:47 2005 +++ mcclim/stream-output.lisp Thu Apr 21 04:43:19 2005 @@ -540,9 +540,10 @@ ,@body)) (defmethod beep (&optional medium) - (when (null medium) - (setq medium (sheet-medium *standard-output*))) - (medium-beep medium)) - + (if medium + (medium-beep medium) + (when (sheetp *standard-output*) + (medium-beep (sheet-medium *standard-output*))))) + (defmethod scroll-quantum ((sheet standard-extended-output-stream)) (stream-line-height sheet))

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 19 Apr '05

19 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24657 Modified Files: mcclim.asd Log Message: Make Allegro CL a McCLIM/asdf-supported lisp. Thanks for the patch go to rpgoldman. Date: Wed Apr 20 00:35:42 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.4 mcclim/mcclim.asd:1.5 --- mcclim/mcclim.asd:1.4 Tue Mar 1 16:46:13 2005 +++ mcclim/mcclim.asd Wed Apr 20 00:35:42 2005 @@ -48,6 +48,21 @@ #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) +;;; Make CLX asdf-loadable on Allegro 6.2 +;;; possibly this should be further refined to funciton properly for +;;; Allegro on Windows platforms. [2005/04/18:rpg] +#+allegro +(progn + (defclass requireable-system (asdf:system) + ()) + (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) + (require (intern (slot-value system 'asdf::name) "KEYWORD"))) + (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) + (list (cons op system))) + (defsystem :clx + :class requireable-system)) + + (pushnew :clim *features*) (pushnew :mcclim *features*) @@ -216,7 +231,7 @@ )) (defsystem :clim-clx - :depends-on (:clim #+(or sbcl openmcl ecl) :clx) + :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) :components ((:module "Backends/CLX" :pathname #.(make-pathname :directory '(:relative "Backends" "CLX")) @@ -276,7 +291,7 @@ :depends-on (:clim ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl openmcl ecl clx) :clim-clx + #+(or sbcl openmcl ecl clx allegro) :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X).

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp
by ahefner＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv1008 Modified Files: frames.lisp Log Message: Check in nyef's partial fix for changing frame layouts. Added comment protesting default of :use-keystrokes t in the spec. Corrected a spelling error. Date: Sun Apr 17 20:46:27 2005 Author: ahefner Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.106 mcclim/frames.lisp:1.107 --- mcclim/frames.lisp:1.106 Tue Feb 22 04:14:17 2005 +++ mcclim/frames.lisp Sun Apr 17 20:46:26 2005 @@ -272,8 +272,11 @@ (defmethod (setf frame-current-layout) :after (name (frame application-frame)) (declare (ignore name)) - (generate-panes (frame-manager frame) frame) - (signal 'frame-layout-changed :frame frame)) + (when (frame-manager frame) + (generate-panes (frame-manager frame) frame) + (multiple-value-bind (w h) (frame-geometry* frame) + (layout-frame frame w h)) + (signal 'frame-layout-changed :frame frame))) (defmethod generate-panes :before (fm (frame application-frame)) (declare (ignore fm)) @@ -578,6 +581,12 @@ (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*)) + ;; The following is the correct interpretation according to the spec. + ;; I think it is terribly counterintuitive and want to look into + ;; what existing CLIMs do before giving in to it. + ;; If we do things as the spec says, command accelerators will + ;; appear to not work, confusing new users. + #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) (defmethod execute-frame-command ((frame application-frame) command) @@ -876,11 +885,11 @@ ,@(if command-table `((define-command-table ,@command-table))) ,@(if command-definer - `((defmacro ,command-definer (name-and-options arguements &rest body) + `((defmacro ,command-definer (name-and-options arguments &rest body) (let ((name (if (listp name-and-options) (first name-and-options) name-and-options)) (options (if (listp name-and-options) (cdr name-and-options) nil)) (command-table ',(first command-table))) - `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body)))))))) + `(define-command (,name :command-table ,command-table ,@options) ,arguments ,@body)))))))) (defun get-application-frame-class-geometry (name indicator) (getf (get name 'application-frame-geometry) indicator nil))

1 0

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

17 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29185 Modified Files: gadgets.lisp Log Message: Answer anonymous wish for an :active-p initarg, but call it :active instead, as classic CLIM appeared to. Added documentation to the list-pane and option-pane listing what is left to be done, some performance considerations, user behavior, and extensions beyond the CLIM spec. Various fixes and cleanups to the list and option panes. Made it capable of handling an unbound gadget-value. Cleaned up the (still) scary event loop that manages the popup menu for option-pane. Fixed some bugs whose details I've forgotten. Also fixed bogus slot type declaration reported by David Christiansen last month. Date: Sun Apr 17 19:30:26 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.88 mcclim/gadgets.lisp:1.89 --- mcclim/gadgets.lisp:1.88 Fri Feb 25 07:03:02 2005 +++ mcclim/gadgets.lisp Sun Apr 17 19:30:26 2005 @@ -85,8 +85,6 @@ ;; - Should RADIO-BOX-PANE and CHECK-BOX-PANE use rack or box layout? -;; - I would like to have a :ACTIVE-P initarg - ;; - :CHOICES initarg to RADIO-BOX and CHECK-BOX is from Franz' user ;; guide. @@ -144,7 +142,8 @@ ;; ACTIVATE-GADGET after creating a gadget? ;; ;; I think, T is correct here --GB - (active-p :initform t + + (active-p :initform t :initarg :active :reader gadget-active-p) ;; ;; I am not so lucky with the armed slot in GADGET --GB @@ -1954,7 +1953,33 @@ ;; things in their list pane. Instead of :exclusive and :nonexclusive modes, ;; they call them :one-of and :some-of. I've supported these aliases for ;; compatibility. They also state the default mode is :some-of, which -;; contradicts the CLIM 2.0 Spec. Our default does not. +;; contradicts the CLIM 2.0 Spec and doesn't make a lot of sense. +;; McCLIM defaults to :one-of. + +;; TODO: Improve performance in order to scale to extremely large lists. +;; * Computing text-size for a 100k list items is expensive +;; * Need to share text size and cache of computed name-key/value-key +;; results with LIST-PANE when instantiated in the popup for +;; the OPTION-PANE. +;; * Improve repaint logic when items are selected to reduce flicker. +;; Currently the list and option panes are usable up to several thousand +;; items on a reasonably fast P4. + +;; TODO: Consider appearance of nonexclusive option-pane when multiple items are +;; selected. + +;; TODO: I think the list/option gadgets currently ignore enabled/disabled status. + +;; Notes +;; A some-of/nonexclusive list pane (or option-pane popup window) supports +;; the following behaviors: +;; single-click: toggle selected item +;; shift-click: select/deselect multiple items. Selection or deselection +;; is chosen according to the result of your previous click. +;; McCLIM adds an initarg :prefer-single-selection. If true, a nonexclusive pane +;; will deselect other items selected when a new selection is made. Multiple +;; items can be selected using control-click, or shift-click as before. This +;; imitates the behvior of certain GUIs and may be useful in applications. (define-abstract-pane-mapping 'list-pane 'generic-list-pane) @@ -1962,7 +1987,7 @@ ((mode :initarg :mode :initform :exclusive :reader list-pane-mode - :type (member :one-of :some-of)) + :type (member :one-of :some-of :exclusive :nonexclusive)) (items :initarg :items :initform nil :reader list-pane-items @@ -2009,6 +2034,14 @@ (defmethod initialize-instance :after ((gadget meta-list-pane) &rest rest) (declare (ignorable rest)) + ;; Initialize slot value if not specified + #+NIL ;; XXX + (when (slot-boundp gadget 'value) + (setf (slot-value gadget 'value) + (if (list-pane-exclusive-p gadget) + (funcall (list-pane-value-key gadget) (first (list-pane-items gadget))) + (mapcar #'list-pane-value-key (list (first (list-pane-items gadget))))))) + (when (and (not (list-pane-exclusive-p gadget)) (not (listp (gadget-value gadget)))) (error "A :nonexclusive list-pane cannot be initialized with a value which is not a list.")) @@ -2094,7 +2127,8 @@ (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (if (bounding-rectangle-p region) region - (sheet-region pane)) ; workaround for non-rectangular regions (such as +everywhere+) + (or (pane-viewport-region pane) ; workaround for +everywhere+ + (sheet-region pane))) (let ((item-height (generic-list-pane-item-height pane)) (highlight-ink (list-pane-highlight-ink pane))) (do ((index (floor (- ry0 sy0) item-height) (1+ index))) @@ -2103,14 +2137,16 @@ (let ((y0 (+ sy0 (* index item-height))) (y1 (+ sy0 (* (1+ index) item-height)))) (multiple-value-bind (background foreground) - (if (if (list-pane-exclusive-p pane) + (cond ((not (slot-boundp pane 'value)) + (values (pane-background pane) (pane-foreground pane))) + ((if (list-pane-exclusive-p pane) (funcall (list-pane-test pane) (elt (generic-list-pane-item-values pane) index) (gadget-value pane)) (member (elt (generic-list-pane-item-values pane) index) (gadget-value pane) :test (list-pane-test pane))) - (values highlight-ink (pane-background pane)) - (values (pane-background pane) (pane-foreground pane))) + (values highlight-ink (pane-background pane))) + (t (values (pane-background pane) (pane-foreground pane)))) (draw-rectangle* pane rx0 y0 rx1 y1 :filled t :ink background) (draw-text* pane (elt (generic-list-pane-item-strings pane) index) sx0 @@ -2261,9 +2297,11 @@ (defun generic-option-pane-compute-label (pane) (generic-option-pane-compute-label-from-value pane (gadget-value pane))) -(defmethod initialize-instance :after ((object generic-option-pane) &rest rest) +(defmethod initialize-instance :after ((object generic-option-pane) &rest rest) (setf (slot-value object 'current-label) - (generic-option-pane-compute-label object))) + (if (slot-boundp object 'value) + (generic-option-pane-compute-label object) + ""))) (defmethod (setf gadget-value) :after (new-value (gadget generic-option-pane) &key &allow-other-keys) (setf (slot-value gadget 'current-label) @@ -2391,13 +2429,14 @@ (t (values nil :above height))))))) (defun popup-init (parent manager frame) - (let ((list-pane (make-pane-1 manager frame 'generic-list-pane + (let ((list-pane (apply #'make-pane-1 manager frame 'generic-list-pane :items (list-pane-items parent) :mode (list-pane-mode parent) - :value (gadget-value parent) :name-key (list-pane-name-key parent) :value-key (list-pane-value-key parent) - :test (list-pane-test parent)))) + :test (list-pane-test parent) + (and (slot-boundp parent 'value) + (list :value (gadget-value parent)))))) (multiple-value-bind (scroll-p position height) (popup-compute-height parent list-pane) (with-bounding-rectangle* (cx0 cy0 cx1 cy1) parent @@ -2429,11 +2468,11 @@ (let* ((frame *application-frame*) (manager (frame-manager frame)) ;; Popup state - (ready-to-exit nil) - (inner-grab nil) ;; Gadget 'grabbing' the pointer, used to simulate the - ;; implicit pointer grabbing of X for the scrollbar + (final-change nil) ;; Menu should exit after next value change + (inner-grab nil) ;; Gadget is grabbing the pointer, used to simulate + ;; X implicit pointer grabbing (for the scrollbar) (retain-value nil) - (all-done nil) + (consume-and-exit nil) ;; If true, wait until a button release then exit (last-click-time nil) (last-item-index nil)) (with-look-and-feel-realization (manager *application-frame*) @@ -2458,16 +2497,16 @@ (< (/ (- now last-click-time) internal-time-units-per-second) *double-click-delay*)) (setf last-click-time now)))) (end-it () - (unless all-done - (setf all-done t) - (throw 'popup-list-box-done nil)))) + (throw 'popup-list-box-done nil))) (catch 'popup-list-box-done (setf (slot-value list-pane 'value-changed-callback) (lambda (pane value) (declare (ignore pane value)) - (when ready-to-exit (end-it)))) - + (when (and final-change + (not consume-and-exit)) + (end-it)))) + (tracking-pointer (list-pane :multiple-window t :highlight nil) (:pointer-motion (&key event window x y) (cond (inner-grab (handle-event inner-grab (rewrite-event-for-grab inner-grab event))) @@ -2484,30 +2523,33 @@ (multiple-value-bind (item current-index) (generic-list-pane-item-from-x-y list-pane x y) (declare (ignore item)) - (setf retain-value t) (let ((double-clicked (and (compute-double-clicked) (= (or last-item-index -1) (or current-index -2)))) (exclusive (list-pane-exclusive-p parent))) - (setf ready-to-exit (or exclusive double-clicked) - last-item-index current-index) - (if (and (not exclusive) - double-clicked) - (end-it) + (setf retain-value t + final-change (or exclusive double-clicked) + last-item-index current-index + consume-and-exit (or exclusive + (and (not exclusive) + double-clicked))) + (unless (and (not exclusive) + double-clicked) (handle-event list-pane event))))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event) (setf inner-grab (event-sheet event))) - (t (end-it))))) - + (t (setf consume-and-exit t))))) + (:pointer-button-release (&key event x y) + (when consume-and-exit (end-it)) (cond (inner-grab (handle-event inner-grab event) (setf inner-grab nil)) ((in-list (event-sheet event) x y) (when (list-pane-exclusive-p parent) - (setf ready-to-exit t - retain-value t) + (setf retain-value t + final-change t) (handle-event list-pane event))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event)))))))

1 0