[Eclipse-cvs] CVS eclipse

[ihatchondo]

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.