Update of /project/eclipse/cvsroot/eclipse In directory cl-net:/tmp/cvs-serv21062

Modified Files: menu.lisp widgets.lisp Log Message: Fix: use the window hashtable machinery.

--- /project/eclipse/cvsroot/eclipse/menu.lisp 2004/11/30 23:48:10 1.8 +++ /project/eclipse/cvsroot/eclipse/menu.lisp 2009/11/17 17:33:21 1.9 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: menu.lisp,v 1.8 2004/11/30 23:48:10 ihatchondo Exp $ +;;; $Id: menu.lisp,v 1.9 2009/11/17 17:33:21 ihatchondo Exp $ ;;; ;;; This file is part of Eclipse ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO, Robert STRANDH @@ -114,7 +114,7 @@ :key-press :key-release :owner-grab-button))) - (setf (gethash window *widget-table*) item) + (save-widget window item) (incf y *default-menu-height*) (when map (xlib:map-window window)))) items)) @@ -240,8 +240,8 @@ :background (make-background-pixmap root-window subwidth - subheight)) - (gethash item-container *widget-table*) sub-menu)) + subheight)))) + (save-widget item-container sub-menu) (decf subwidth (* 2 *menu-item-margin*)) (realize-menu-items item-container subwidth items))))

@@ -250,10 +250,10 @@ (when has-substructure (mapc #'(lambda (item) (destroy-substructure item) - (remhash (slot-value item 'window) *widget-table*) + (clear-widget (slot-value item 'window)) (setf (slot-value item 'window) nil)) items) - (remhash item-container *widget-table*) + (clear-widget item-container) (xlib:destroy-window item-container)) (setf armed nil has-substructure nil @@ -320,8 +320,8 @@ root-window (+ subwidth (* 2 *menu-item-margin*)) (+ subheight (* 2 *menu-item-margin*)))) - (gethash window *widget-table*) pop-up-menu armed t) + (save-widget window pop-up-menu) (xlib:map-window window) (realize-menu-items window subwidth items :map t))))

@@ -330,11 +330,11 @@ (when window (mapc #'(lambda (item) (destroy-substructure item) - (remhash (slot-value item 'window) *widget-table*) + (clear-widget (slot-value item 'window)) (setf (slot-value item 'window) nil)) items) (xlib:destroy-window window) - (remhash window *widget-table*) + (clear-widget window) (setf (slot-value pop-up-menu 'armed) nil window nil))))

--- /project/eclipse/cvsroot/eclipse/widgets.lisp 2009/02/20 18:07:01 1.57 +++ /project/eclipse/cvsroot/eclipse/widgets.lisp 2009/11/17 17:33:21 1.58 @@ -1,5 +1,5 @@ ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*- -;;; $Id: widgets.lisp,v 1.57 2009/02/20 18:07:01 ihatchondo Exp $ +;;; $Id: widgets.lisp,v 1.58 2009/11/17 17:33:21 ihatchondo Exp $ ;;; ;;; ECLIPSE. The Common Lisp Window Manager. ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO @@ -111,10 +111,10 @@

(defmethod initialize-instance :after ((widget base-widget) &rest rest) (declare (ignore rest)) - (setf (gethash (widget-window widget) *widget-table*) widget)) + (save-widget (widget-window widget) widget))

(defmethod remove-widget ((widget base-widget)) - (remhash (widget-window widget) *widget-table*)) + (clear-widget (widget-window widget)))

(defmethod put-on-top ((widget base-widget)) (setf (xlib:window-priority (widget-window widget)) :above)) @@ -127,10 +127,20 @@

(defun lookup-widget (window) "Returns the associated widget if any." - (declare (optimize (speed 3) (safety 1))) - (gethash window *widget-table*)) + (declare (optimize (speed 3) (safety 0))) + (declare (inline getwinhash)) + (getwinhash window *widget-table*)) + +(defun save-widget (window widget) + (declare (optimize (speed 3) (safety 0))) + (setf (getwinhash window *widget-table*) widget)) + +(defun clear-widget (window) + (declare (optimize (speed 3) (safety 0))) + (declare (inline remwinhash)) + (remwinhash window *widget-table*))

-(declaim (inline lookup-widget)) +(declaim (inline lookup-widget save-widget clear-widget))

(defclass standard-property-holder (base-widget) ())

@@ -245,11 +255,12 @@ (defmethod focused-p ((application application)) (loop with window = (widget-window application) with foc = (xlib:input-focus *display*) - until (or (xlib:window-equal window foc) (not (xlib:window-p foc))) + until (or (not (xlib:window-p foc)) (xlib:window-equal window foc)) do (multiple-value-bind (children parent) (xlib:query-tree foc) (declare (ignore children)) (setq foc parent)) - finally (return (xlib:window-equal window foc)))) + finally + (return (and (xlib:window-p foc) (xlib:window-equal window foc)))))

(defmethod shaded-p ((widget application)) (member :_net_wm_state_shaded (netwm:net-wm-state (widget-window widget)))) @@ -656,12 +667,13 @@ (defun timed-message-box (window &rest messages) "Map a small box, of parent `window', displaying the given string messages. This box will automatically destroyed two seconds after being mapped." - (with-slots (window) (create-message-box messages :parent window) - (xlib:map-window window) - (pt:arm-timer 2 (lambda () - (xlib:display-finish-output *display*) - (remhash window *widget-table*) - (xlib:destroy-window window))))) + (let ((box (create-message-box messages :parent window))) + (with-slots (window) box + (xlib:map-window window) + (pt:arm-timer 2 (lambda () + (xlib:display-finish-output *display*) + (remove-widget box) + (xlib:destroy-window window))))))

;;;; Push button ;; Everybody knows what a push button is.