[clfswm-cvs] r299 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Thu Aug 26 11:43:46 UTC 2010
Author: pbrochard
Date: Thu Aug 26 07:43:46 2010
New Revision: 299
Log:
* src/*.lisp: Use the new child-equal-p to compare children. This prevent a bug with sbcl/cmucl when the standard equal function does not work with xlib:window. * src/clfswm-internal.lisp (child-equal-p): New predicate.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-circulate-mode.lisp
clfswm/src/clfswm-corner.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-layout.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
clfswm/src/xlib-util.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Thu Aug 26 07:43:46 2010
@@ -1,3 +1,11 @@
+2010-08-26 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/*.lisp: Use the new child-equal-p to compare children. This
+ prevent a bug with sbcl/cmucl when the standard equal function
+ does not work with xlib:window.
+
+ * src/clfswm-internal.lisp (child-equal-p): New predicate.
+
2010-08-25 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-generic-mode.lisp (generic-mode): Use an
Modified: clfswm/src/clfswm-circulate-mode.lisp
==============================================================================
--- clfswm/src/clfswm-circulate-mode.lisp (original)
+++ clfswm/src/clfswm-circulate-mode.lisp Thu Aug 26 07:43:46 2010
@@ -85,8 +85,8 @@
(defun reorder-brother (direction)
(no-focus)
- (let ((frame-is-root? (and (equal *current-root* *current-child*)
- (not (equal *current-root* *root-frame*)))))
+ (let ((frame-is-root? (and (child-equal-p *current-root* *current-child*)
+ (not (child-equal-p *current-root* *root-frame*)))))
(if frame-is-root?
(hide-all *current-root*)
(select-current-frame nil))
Modified: clfswm/src/clfswm-corner.lisp
==============================================================================
--- clfswm/src/clfswm-corner.lisp (original)
+++ clfswm/src/clfswm-corner.lisp Thu Aug 26 07:43:46 2010
@@ -128,7 +128,7 @@
(dolist (win (xlib:query-tree *root*))
(when (string-equal (xlib:wm-name win) *clfswm-terminal-name*)
(setf found t)
- (unless (equal *clfswm-terminal* win)
+ (unless (child-equal-p *clfswm-terminal* win)
(setf *clfswm-terminal* win)
(hide-window *clfswm-terminal*))))
(unless found
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Thu Aug 26 07:43:46 2010
@@ -127,6 +127,19 @@
+(defgeneric child-equal-p (child-1 child-2))
+
+(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
+ (xlib:window-equal child-1 child-2))
+
+(defmethod child-equal-p ((child-1 frame) (child-2 frame))
+ (equal child-1 child-2))
+
+(defmethod child-equal-p (child-1 child-2)
+ (declare (ignore child-1 child-2))
+ nil)
+
+
(defgeneric child-name (child))
@@ -319,7 +332,7 @@
(defun find-child (to-find root)
"Find to-find in root or in its children"
(with-all-children (root child)
- (when (equal child to-find)
+ (when (child-equal-p child to-find)
(return-from find-child t))))
@@ -360,7 +373,7 @@
(defun find-child-in-parent (child base)
"Return t if child is in base or in its parents"
(labels ((rec (base)
- (when (equal child base)
+ (when (child-equal-p child base)
(return-from find-child-in-parent t))
(let ((parent (find-parent-frame base)))
(when parent
@@ -409,15 +422,15 @@
(setf (xlib:gcontext-background gc) (get-color *frame-background*)
(xlib:window-background window) (get-color *frame-background*))
(clear-pixmap-buffer window gc)
- (setf (xlib:gcontext-foreground gc) (get-color (if (and (equal frame *current-root*)
- (equal frame *current-child*))
+ (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-equal-p frame *current-root*)
+ (child-equal-p frame *current-child*))
*frame-foreground-root* *frame-foreground*)))
(xlib:draw-glyphs *pixmap-buffer* gc 5 dy
(format nil "Frame: ~A~A"
number
(if name (format nil " - ~A" name) "")))
(let ((pos dy))
- (when (equal frame *current-root*)
+ (when (child-equal-p frame *current-root*)
(xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
(format nil "~A hidden windows" (length (get-hidden-windows))))
(when *child-selection*
@@ -508,7 +521,7 @@
(with-xlib-protect
(with-slots (window show-window-p) frame
(if show-window-p
- (when (or *show-root-frame-p* (not (equal frame *current-root*)))
+ (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*)))
(setf (xlib:window-background window) (get-color "Black"))
(map-window window)
(when raise-p (raise-window window)))
@@ -519,7 +532,7 @@
(defmethod show-child ((window xlib:window) parent raise-p)
(with-xlib-protect
(if (or (managed-window-p window parent)
- (equal parent *current-child*))
+ (child-equal-p parent *current-child*))
(progn
(map-window window)
(when raise-p (raise-window window)))
@@ -636,13 +649,13 @@
(labels ((rec-geom (root parent selected-p selected-parent-p)
(when (adapt-child-to-parent root parent)
(setf geometry-change t))
- (select-child root (cond ((equal root *current-child*) t)
+ (select-child root (cond ((child-equal-p root *current-child*) t)
((and selected-p selected-parent-p) :maybe)
(t nil)))
(when (frame-p root)
(let ((selected-child (frame-selected-child root)))
(dolist (child (reverse (frame-child root)))
- (rec-geom child root (equal child selected-child) (and selected-p selected-parent-p))))))
+ (rec-geom child root (child-equal-p child selected-child) (and selected-p selected-parent-p))))))
(rec (root parent raise-p)
(show-child root parent raise-p)
(when (frame-p root)
@@ -676,7 +689,7 @@
"Focus child - Return true if something has change"
(when (and (frame-p parent)
(member child (frame-child parent)))
- (when (not (equal child (frame-selected-child parent)))
+ (when (not (child-equal-p child (frame-selected-child parent)))
(with-slots ((parent-child child) selected-pos) parent
(setf parent-child (nth-insert selected-pos child (remove child parent-child))))
t)))
@@ -694,7 +707,7 @@
(defun set-current-child-generic (child)
- (unless (equal *current-child* child)
+ (unless (child-equal-p *current-child* child)
(setf *current-child* child)
t))
@@ -739,7 +752,7 @@
(defun select-previous-level ()
"Select the previous level in frame"
- (unless (equal *current-child* *current-root*)
+ (unless (child-equal-p *current-child* *current-root*)
(select-current-frame :maybe)
(awhen (find-parent-frame *current-child*)
(setf *current-child* it))
@@ -817,7 +830,7 @@
(defun remove-child-in-frame (child frame)
"Remove the child in frame"
(when (frame-p frame)
- (setf (frame-child frame) (remove child (frame-child frame) :test #'equal))))
+ (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))))
(defun remove-child-in-frames (child root)
"Remove child in the frame root and in all its children"
@@ -827,9 +840,9 @@
(defun remove-child-in-all-frames (child)
"Remove child in all frames from *root-frame*"
- (when (equal child *current-root*)
+ (when (child-equal-p child *current-root*)
(setf *current-root* (find-parent-frame child)))
- (when (equal child *current-child*)
+ (when (child-equal-p child *current-child*)
(setf *current-child* *current-root*))
(remove-child-in-frames child *root-frame*))
@@ -848,9 +861,9 @@
(defun delete-child-in-all-frames (child)
"Delete child in all frames from *root-frame*"
- (when (equal child *current-root*)
+ (when (child-equal-p child *current-root*)
(setf *current-root* (find-parent-frame child)))
- (when (equal child *current-child*)
+ (when (child-equal-p child *current-child*)
(setf *current-child* *current-root*))
(delete-child-in-frames child *root-frame*))
@@ -867,9 +880,9 @@
(defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
"Delete child and its children in all frames from *root-frame*"
- (when (equal child *current-root*)
+ (when (child-equal-p child *current-root*)
(setf *current-root* (find-parent-frame child)))
- (when (equal child *current-child*)
+ (when (child-equal-p child *current-child*)
(setf *current-child* *current-root*))
(delete-child-and-children-in-frames child *root-frame* close-methode))
Modified: clfswm/src/clfswm-layout.lisp
==============================================================================
--- clfswm/src/clfswm-layout.lisp (original)
+++ clfswm/src/clfswm-layout.lisp Thu Aug 26 07:43:46 2010
@@ -198,7 +198,7 @@
(unless (member ch managed-children)
(setf managed-children (append managed-children (list child)))))
(setf managed-children (remove-if-not (lambda (x)
- (member x managed-in-parent :test #'equal))
+ (member x managed-in-parent :test #'child-equal-p))
managed-children))
(setf (frame-data-slot parent :layout-managed-children) managed-children)
managed-children))
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Thu Aug 26 07:43:46 2010
@@ -108,7 +108,7 @@
(defun delete-focus-window-generic (close-fun)
(let ((window (xlib:input-focus *display*)))
(when (and window (not (xlib:window-equal window *no-focus-window*)))
- (when (equal window *current-child*)
+ (when (child-equal-p window *current-child*)
(setf *current-child* *current-root*))
(hide-child window)
(delete-child-and-children-in-all-frames window close-fun)
@@ -149,7 +149,7 @@
(with-xlib-protect
(let ((win *root*))
(with-all-windows-frames-and-parent (*current-root* child parent)
- (when (and (or (managed-window-p child parent) (equal parent *current-child*))
+ (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*))
(<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child)))
(<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child))))
(setf win child))
@@ -164,7 +164,7 @@
(with-xlib-protect
(let ((ret nil))
(with-all-windows-frames-and-parent (*current-root* child parent)
- (when (and (or (managed-window-p child parent) (equal parent *current-child*))
+ (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*))
(<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child)))
(<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child))))
(if first-foundp
@@ -433,10 +433,10 @@
;;; Delete by functions
(defun delete-frame-by (frame)
(hide-all *current-root*)
- (unless (equal frame *root-frame*)
- (when (equal frame *current-root*)
+ (unless (child-equal-p frame *root-frame*)
+ (when (child-equal-p frame *current-root*)
(setf *current-root* *root-frame*))
- (when (equal frame *current-child*)
+ (when (child-equal-p frame *current-child*)
(setf *current-child* *current-root*))
(remove-child-in-frame frame (find-parent-frame frame)))
(show-all-children *current-root*))
@@ -556,9 +556,9 @@
(let* ((to-replay t)
(child (find-child-under-mouse root-x root-y))
(parent (find-parent-frame child))
- (root-p (or (equal window *root*)
+ (root-p (or (child-equal-p window *root*)
(and (frame-p *current-root*)
- (equal child (frame-window *current-root*))))))
+ (child-equal-p child (frame-window *current-root*))))))
(labels ((add-new-frame ()
(setf child (create-frame)
parent *current-root*
@@ -612,7 +612,7 @@
For window: set current child to window or its parent according to window-parent"
(let* ((child (find-child-under-mouse root-x root-y))
(parent (find-parent-frame child)))
- (when (and (equal child *current-root*)
+ (when (and (child-equal-p child *current-root*)
(frame-p *current-root*))
(setf child (create-frame)
parent *current-root*
@@ -993,7 +993,7 @@
"Move the child under the mouse cursor to another frame"
(declare (ignore window))
(let ((child (find-child-under-mouse root-x root-y)))
- (unless (equal child *current-root*)
+ (unless (child-equal-p child *current-root*)
(hide-all child)
(remove-child-in-frame child (find-parent-frame child))
(wait-mouse-button-release 50 51)
@@ -1002,7 +1002,7 @@
(let ((dest (find-child-under-mouse x y)))
(when (xlib:window-p dest)
(setf dest (find-parent-frame dest)))
- (unless (equal child dest)
+ (unless (child-equal-p child dest)
(move-child-to child dest)
(show-all-children *current-root*))))))
(stop-button-event))
@@ -1190,7 +1190,7 @@
(when name1
(let ((acc nil))
(with-all-children (*root-frame* c)
- (unless (equal child c))
+ (unless (child-equal-p child c))
(multiple-value-bind (num2 name2)
(extract-number-from-name (child-name c))
(when (string-equal name1 name2)
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Thu Aug 26 07:43:46 2010
@@ -87,6 +87,7 @@
(delete-child-in-all-frames window)
(show-all-children))))
+
(define-handler main-mode :destroy-notify (send-event-p event-window window)
(unless (or send-event-p
(xlib:window-equal window event-window))
@@ -106,7 +107,7 @@
(focus-window window)))
(:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
(parent (find-parent-frame child)))
- (unless (or (equal child *current-root*)
+ (unless (or (child-equal-p child *current-root*)
(equal (typecase child
(xlib:window parent)
(t child))
Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp (original)
+++ clfswm/src/xlib-util.lisp Thu Aug 26 07:43:46 2010
@@ -69,10 +69,18 @@
(progn
, at body)
((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
- (dbg c))))
+ ;;(dbg c))))
;;(declare (ignore c)))))
+ (format t "~&Xlib-error: ~A~%Body:~%~A~%" c ',body)
+ (force-output))))
;;(dbg c ',body))))
+;;(defmacro with-xlib-protect (&body body)
+;; "Prevent Xlib errors"
+;; `(progn
+;; , at body))
+
+
@@ -147,9 +155,9 @@
(defun handle-event (&rest event-slots &key event-key &allow-other-keys)
(with-xlib-protect
- (if (fboundp event-key)
- (apply event-key event-slots)
- #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)))
+ (if (fboundp event-key)
+ (apply event-key event-slots)
+ #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)))
t)
@@ -787,7 +795,7 @@
(xlib:draw-rectangle *pixmap-buffer* gc
0 0 (xlib:drawable-width window) (xlib:drawable-height window)
t)
- (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc)))
+ (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc)))
(defun copy-pixmap-buffer (window gc)
(xlib:copy-area *pixmap-buffer* gc
More information about the clfswm-cvs
mailing list