[graphic-forms-cvs] r132 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Tue May 16 01:02:50 2006
New Revision: 132

Modified:
   trunk/src/uitoolkit/widgets/display.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/thread-context.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
simplified child visitor function management in preparation for refactoring visit-* functions into map-like functions

Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp	(original)
+++ trunk/src/uitoolkit/widgets/display.lisp	Tue May 16 01:02:50 2006
@@ -56,7 +56,7 @@
 
 (defun visit-displays (func)
   ;;
-  ;; supplied closure should expect three parameters:
+  ;; supplied closure should expect two parameters:
   ;;  display handle
   ;;  flag data
   ;;

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Tue May 16 01:02:50 2006
@@ -167,13 +167,6 @@
       (warn 'gfs:toolkit-warning :detail "no object for hwnd")))
   0)
 
-#|
-(defmethod process-message (hwnd (msg (eql gfs::+wm-initdialog+)) wparam lparam)
-  (declare (ignore hwnd lparam))
-  (format t "WM_INITDIALOG: ~x~%" wparam)
-  1)
-|#
-
 (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam)
   (declare (ignore hwnd lparam))
   (let* ((tc (thread-context))

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Tue May 16 01:02:50 2006
@@ -34,7 +34,7 @@
 (in-package #:graphic-forms.uitoolkit.widgets)
 
 (defclass thread-context ()
-  ((child-visitor-stack    :initform nil)
+  ((child-visitor-func     :initform nil :accessor child-visitor-func)
    (display-visitor-func   :initform nil :accessor display-visitor-func)
    (image-loaders-by-type  :initform (make-hash-table :test #'equal))
    (job-table              :initform (make-hash-table :test #'equal))
@@ -101,32 +101,22 @@
     (setf (slot-value tc 'utility-hwnd) hwnd)))
   
 (defmethod call-child-visitor-func ((tc thread-context) parent child)
-  "Call the closure at the top of the child window visitor function stack."
-  (let ((fn (first (slot-value tc 'child-visitor-stack))))
-    (if (null fn)
-      (error 'gfs:toolkit-error :detail "child visitor function stack is empty"))
-    (funcall fn parent child)))
-
-(defmethod push-child-visitor-func ((tc thread-context) func)
-  "Push the supplied closure onto the child window visitor function stack."
-  (if (not (functionp func))
-    (error 'gfs:toolkit-error :detail "function argument required"))
-  (push func (slot-value tc 'child-visitor-stack))
-  nil)
-
-(defmethod pop-child-visitor-func ((tc thread-context))
-  "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty."
-  (pop (slot-value tc 'child-visitor-stack)))
+  (let ((func (child-visitor-func tc)))
+    (if func
+      (funcall func parent child)
+      (warn 'gfs:toolkit-warning :detail "child visitor function is nil"))))
 
 (defmethod call-display-visitor-func ((tc thread-context) hmonitor data)
   (let ((func (display-visitor-func tc)))
-    (unless (null func)
-      (funcall func hmonitor data))))
+    (if func
+      (funcall func hmonitor data)
+      (warn 'gfs:toolkit-warning :detail "display visitor function is nil"))))
 
 (defmethod call-top-level-visitor-func ((tc thread-context) win)
   (let ((func (top-level-visitor-func tc)))
-    (unless (null func)
-      (funcall func win))))
+    (if func
+      (funcall func win)
+      (warn 'gfs:toolkit-warning :detail "top-level visitor function is nil"))))
 
 (defmethod get-widget ((tc thread-context) hwnd)
   "Return the widget object corresponding to the specified native window handle."

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Tue May 16 01:02:50 2006
@@ -87,7 +87,7 @@
   ;;  current child widget
   ;;
   (let ((tc (thread-context)))
-    (push-child-visitor-func tc func)
+    (setf (child-visitor-func tc) func)
     (unwind-protect
 #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win)))
                                      (fli:make-pointer :symbol-name "child_window_visitor")
@@ -100,7 +100,7 @@
               (gfs::enum-child-windows ptr
                                        #'child_window_visitor
                                        (cffi:pointer-address (gfs:handle win))))
-      (pop-child-visitor-func tc)))
+      (setf (child-visitor-func tc) nil)))
   nil)
 
 (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra)