[graphic-forms-cvs] r414 - in trunk/src/uitoolkit: system widgets - graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

17 Dec 2006

Author: junrue
Date: Sat Dec 16 23:12:03 2006
New Revision: 414
Modified:
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/display.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
ACL port: fix mistakes in callback definitions
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================

--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Sat Dec 16 23:12:03 2006
@@ -220,14 +220,6 @@
 |#
#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address)
-                                                          (lparam :long))
-    (declare (:convention :stdcall)))
-
-  (ff:register-foreign-callable 'enum-child-windows-callback :reuse t))
-
-#+allegro
 (ff:def-foreign-call (enum-child-windows "EnumChildWindows")
   ((hwnd :foreign-address)
    (func :foreign-address)
@@ -277,16 +269,6 @@
 |#
#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address)
-                                                             (hdc :foreign-address)
-                                                             (monitorrect :foreign-address)
-                                                             (data :long))
-    (declare (:convention :stdcall)))
-
-  (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t))
-
-#+allegro
 (ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors")
   ((hdc :foreign-address)
    (cliprect :foreign-address)
@@ -341,14 +323,6 @@
 |#
#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address)
-                                                           (lparam :long))
-    (declare (:convention :stdcall)))
-
-  (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t))
-
-#+allegro
 (ff:def-foreign-call (enum-thread-windows "EnumThreadWindows")
   ((thread-id :unsigned-long)
    (func :foreign-address)
Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp	(original)
+++ trunk/src/uitoolkit/widgets/display.lisp	Sat Dec 16 23:12:03 2006
@@ -37,6 +37,23 @@
 ;;; helper functions
 ;;;
+(defun display-visitor (hmonitor hdc monitorrect data)
+  (declare (ignore hdc monitorrect))
+  (call-display-visitor-func (thread-context) hmonitor data)
+  1)
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address)
+                                                             (hdc :foreign-address)
+                                                             (monitorrect :foreign-address)
+                                                             (data :long))
+    (declare (:convention :stdcall))
+    (call-display-visitor-func (thread-context) hmonitor data))
+
+  (defvar *monitors-enum-proc*
+          (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t)))
+
 #+lispworks
 (fli:define-foreign-callable
   ("display_visitor" :result-type :integer :calling-convention :stdcall)
@@ -48,11 +65,6 @@
   (call-display-visitor-func (thread-context) hmonitor data)
   1)
-(defun display-visitor (hmonitor hdc monitorrect data)
-  (declare (ignore hdc monitorrect))
-  (call-display-visitor-func (thread-context) hmonitor data)
-  1)
-
 #+sbcl
 (defvar *monitors-enum-proc*
   (sb-alien::alien-callback
@@ -97,7 +109,10 @@
   (let ((tc (thread-context)))
     (setf (display-visitor-func tc) func)
     (unwind-protect
-#+(or allegro clisp)
+#+allegro
+        (let ((ptr (cffi:null-pointer)))
+          (gfs::enum-display-monitors ptr ptr (cffi:pointer-address *monitors-enum-proc*) 0))
+#+clisp
         (gfs::enum-display-monitors nil nil #'display-visitor nil)
 #+lispworks
         (let ((ptr (fli:make-pointer :address 0)))
@@ -127,6 +142,16 @@
       (call-top-level-visitor-func tc win)))
   1)
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address)
+                                                           (lparam :long))
+    (declare (:convention :stdcall))
+    (top-level-window-visitor hwnd lparam))
+
+  (defvar *enum-thread-wnd-proc*
+          (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t)))
+
 #+lispworks
 (fli:define-foreign-callable
   ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall)
@@ -152,7 +177,11 @@
   (let ((tc (thread-context)))
     (setf (top-level-visitor-func tc) func)
     (unwind-protect
-#+(or allegro clisp)
+#+allegro
+        (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+                                 (cffi:pointer-address *enum-thread-wnd-proc*)
+                                 0)
+#+clisp
         (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
                                  #'top-level-window-visitor
                                  0)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sat Dec 16 23:12:03 2006
@@ -79,6 +79,16 @@
           (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list))))))
   1)
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address)
+                                                          (lparam :long))
+    (declare (:convention :stdcall))
+    (child-window-visitor hwnd lparam))
+
+  (defvar *enum-child-proc*
+          (ff:register-foreign-callable 'enum-child-windows-callback :reuse t)))
+
 #+lispworks
 (fli:define-foreign-callable
   ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
@@ -329,7 +339,11 @@
         (hwnd (gfs:handle self)))
     (setf (child-visitor-func tc) func)
     (unwind-protect
-#+(or allegro clisp)
+#+allegro
+        (gfs::enum-child-windows hwnd
+                                 (cffi:pointer-address *enum-child-proc*)
+                                 (cffi:pointer-address hwnd))
+#+clisp
         (gfs::enum-child-windows hwnd
                                  #'child-window-visitor
                                  (cffi:pointer-address hwnd))

    