[graphic-forms-cvs] r6 - in trunk/src/uitoolkit: system widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sun Feb 12 02:29:46 2006
New Revision: 6

Modified:
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
cannot specific stdcall for CFFI callable funcs, use vendor-specific FFI instead for visit-child-widgets

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Sun Feb 12 02:29:46 2006
@@ -116,12 +116,40 @@
   (hwnd HANDLE)
   (ps LPTR))
 
+;;; FIXME: uncomment this when CFFI callbacks can
+;;; be tagged as stdcall or cdecl (only the latter
+;;; is supported as of 0.9.0)
+;;;
+#|
 (defcfun
   ("EnumChildWindows" enum-child-windows)
   BOOL
   (hwnd HANDLE)
   (func :pointer)
   (lparam LPARAM))
+|#
+
+#+lispworks
+(fli:define-foreign-function
+  (enum-child-windows "EnumChildWindows" :result-type :int)
+  ((hwnd :pointer)
+   (func :pointer)
+   (lparam :long)))
+
+#+clisp
+(ffi:def-call-out enum-child-windows
+  (:name "EnumChildWindows")
+  (:library "user32.dll")
+  (:language :stdc)
+  (:arguments (hwnd ffi:c-pointer)
+              (func (ffi:c-function
+                (:arguments
+                  (hwnd ffi:c-pointer)
+                  (lparam ffi:long))
+                (:return-type ffi:int)
+                (:language :stdc-stdcall)))
+              (lparam ffi:long))
+  (:return-type ffi:int))
 
 (defcfun
   ("GetAsyncKeyState" get-async-key-state)

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Sun Feb 12 02:29:46 2006
@@ -79,6 +79,7 @@
          (hwnd (gfi:handle w))
          (len (gfs::get-window-text-length hwnd)))
     (unless (zerop len)
+      (incf len)
       (let ((str-ptr (cffi:foreign-alloc :char :count len)))
         (unwind-protect
             (unless (zerop (gfs::get-window-text hwnd str-ptr len))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 12 02:29:46 2006
@@ -43,15 +43,21 @@
 ;;; helper functions
 ;;;
 
-;; FIXME: causes GPF
-;;
-(cffi:defcallback child_hwnd_collector
-                  gfs::BOOL
-                  ((hwnd gfs::HANDLE)
-                   (lparam gfs::LPARAM))
+#+lispworks
+(fli:define-foreign-callable
+  ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
+  ((hwnd :pointer)
+   (lparam :long))
   (let ((w (get-widget hwnd)))
     (unless (or (null w) (null *child-visiting-functions*))
-      (funcall (car *child-visiting-functions*) w lparam)))
+      (funcall (first *child-visiting-functions*) w lparam)))
+  1)
+
+#+clisp
+(defun child_window_visitor (hwnd lparam)
+  (let ((w (get-widget hwnd)))
+    (unless (or (null w) (null *child-visiting-functions*))
+      (funcall (first *child-visiting-functions*) w lparam)))
   1)
 
 (defun visit-child-widgets (win func val)
@@ -62,7 +68,17 @@
   ;;
   (push func *child-visiting-functions*)
   (unwind-protect
-      (gfs::enum-child-windows (gfi:handle win) (cffi:get-callback 'child_hwnd_collector) val)
+#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win)))
+                                     (fli:make-pointer :symbol-name "child_window_visitor")
+                                     0)
+#+clisp     (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
+              (setf ptr (ffi:set-foreign-pointer
+                          (ffi:unsigned-foreign-address
+                            (cffi:pointer-address (gfi:handle win)))
+                          ptr))
+              (gfs::enum-child-windows ptr
+                                       #'child_window_visitor
+                                       0))
     (pop *child-visiting-functions*)))
 
 (defun register-window-class (class-name proc-ptr st)