[graphic-forms-cvs] r13 - in trunk/src: tests/uitoolkit uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sun Feb 19 21:23:23 2006
New Revision: 13

Modified:
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed regression in with-children under LispWorks

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 19 21:23:23 2006
@@ -53,11 +53,7 @@
   (exit-layout-tester))
 
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
-  ((widget
-    :accessor widget
-    :initarg :widget
-    :initform nil)
-   (toggle-fn
+  ((toggle-fn
     :accessor toggle-fn
     :initform nil)
    (id
@@ -68,7 +64,6 @@
 (defun add-layout-tester-widget (primary-type sub-type)
   (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
          (w (make-instance primary-type :dispatcher be)))
-    (setf (widget be) w)
     (cond
       ((eql sub-type :push-button)
          (setf (toggle-fn be) (let ((flag nil))
@@ -81,20 +76,13 @@
                                         (setf flag nil)
                                         (format nil "~d ~a" (id be) +btn-text-after+))))))
          (incf *button-counter*)))
-#|
-    (gfw:with-children (*layout-tester-win* child-list)
-      (let ((child (first (reverse (rest child-list)))))
-        (unless (null child)
-          (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child))
-                                     (gfi:size-width (gfw:size child)))))))
-|#
     (gfw:realize w *layout-tester-win* sub-type)
     (setf (gfw:text w) (funcall (toggle-fn be)))))
 
-(defmethod gfw:event-select ((d layout-tester-widget-events) item time rect)
-  (declare (ignorable item time rect))
-  (let ((btn (widget d)))
-    (setf (gfw:text btn) (funcall (toggle-fn d)))))
+(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
+  (declare (ignorable time rect))
+  (setf (gfw:text btn) (funcall (toggle-fn d)))
+  (gfw:layout *layout-tester-win*))
 
 (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
 
@@ -130,7 +118,6 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
-    (gfw:layout *layout-tester-win*)
     (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Feb 19 21:23:23 2006
@@ -113,9 +113,9 @@
 
 (defun subclass-wndproc (hwnd)
   (if (zerop (gfs::set-window-long hwnd
-                                    gfs::+gwlp-wndproc+
-                                    (cffi:pointer-address
-                                      (cffi:get-callback 'subclassing_wndproc))))
+                                   gfs::+gwlp-wndproc+
+                                   (cffi:pointer-address
+                                     (cffi:get-callback 'subclassing_wndproc))))
     (error 'gfs:win32-error :detail "set-window-long failed")))
 
 ;;;

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 19 21:23:23 2006
@@ -121,13 +121,14 @@
             retval
             (error 'gfs::win32-error :detail "register-class failed")))))))
 
-(defmacro with-children ((win var) &body body)
-  `(let ((,var nil))
-     (visit-child-widgets ,win #'(lambda (parent child)
-                                  (if (gfw:ancestor-p parent child)
-                                    (push child ,var))))
-     (nreverse ,var)
-     , at body))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-children ((win var) &body body)
+    `(let ((,var nil))
+       (visit-child-widgets ,win #'(lambda (parent child)
+                                     (when (gfw:ancestor-p parent child)
+                                       (push child ,var))))
+       (setf ,var (reverse ,var))
+       , at body)))
 
 (defun register-workspace-window-class ()
   (register-window-class +workspace-window-classname+