[graphic-forms-cvs] r205 - in trunk: . src/external-libraries/sbcl-callback-patch src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Aug 10 21:33:31 UTC 2006
Author: junrue
Date: Thu Aug 10 17:33:31 2006
New Revision: 205
Added:
trunk/src/external-libraries/sbcl-callback-patch/
trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp
trunk/src/external-libraries/sbcl-callback-patch/readme.txt
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/uitoolkit/system/system-types.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/display.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
integrated stdcall callback patch for SBCL and implemented various enum procs for SBCL
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 17:33:31 2006
@@ -47,8 +47,13 @@
((:module "src"
:components
((:file "packages")
+#+sbcl (:module "external-libraries"
+ :components
+ ((:module "sbcl-callback-patch"
+ :components
+ ((:file "callback-hacking")))))
(:module "uitoolkit"
- :depends-on ("packages")
+ :depends-on ("packages" #+sbcl "external-libraries")
:components
((:module "system"
:serial t
Added: trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp
==============================================================================
--- (empty file)
+++ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp Thu Aug 10 17:33:31 2006
@@ -0,0 +1,125 @@
+;;;;
+;;;; hacking.lisp
+;;;;
+;;;; Compiler and runtime damage for callbacks
+;;;;
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-VM")
+
+(sb-ext:without-package-locks
+ (defun alien-callback-assembler-wrapper (index return-type arg-types &optional (stack-offset 0))
+ "Cons up a piece of code which calls call-callback with INDEX and a
+pointer to the arguments."
+ (declare (ignore arg-types))
+ (let* ((segment (make-segment))
+ (eax eax-tn)
+ (edx edx-tn)
+ (ebp ebp-tn)
+ (esp esp-tn)
+ ([ebp-8] (make-ea :dword :base ebp :disp -8))
+ ([ebp-4] (make-ea :dword :base ebp :disp -4)))
+ (assemble (segment)
+ (inst push ebp) ; save old frame pointer
+ (inst mov ebp esp) ; establish new frame
+ (inst mov eax esp) ;
+ (inst sub eax 8) ; place for result
+ (inst push eax) ; arg2
+ (inst add eax 16) ; arguments
+ (inst push eax) ; arg1
+ (inst push (ash index 2)) ; arg0
+ (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function
+ (inst mov eax (foreign-symbol-address "funcall3"))
+ (inst call eax)
+ ;; now put the result into the right register
+ (cond
+ ((and (alien-integer-type-p return-type)
+ (eql (alien-type-bits return-type) 64))
+ (inst mov eax [ebp-8])
+ (inst mov edx [ebp-4]))
+ ((or (alien-integer-type-p return-type)
+ (alien-pointer-type-p return-type)
+ (alien-type-= #.(parse-alien-type 'system-area-pointer nil)
+ return-type))
+ (inst mov eax [ebp-8]))
+ ((alien-single-float-type-p return-type)
+ (inst fld [ebp-8]))
+ ((alien-double-float-type-p return-type)
+ (inst fldd [ebp-8]))
+ ((alien-void-type-p return-type))
+ (t
+ (error "unrecognized alien type: ~A" return-type)))
+ (inst mov esp ebp) ; discard frame
+ (inst pop ebp) ; restore frame pointer
+ (inst ret stack-offset))
+ (finalize-segment segment)
+ ;; Now that the segment is done, convert it to a static
+ ;; vector we can point foreign code to.
+ (let ((buffer (sb-assem::segment-buffer segment)))
+ (make-static-vector (length buffer)
+ :element-type '(unsigned-byte 8)
+ :initial-contents buffer)))))
+
+(in-package "SB-ALIEN")
+
+(defun %alien-callback-sap (specifier result-type argument-types function wrapper &optional (call-type :cdecl))
+ (let ((key (list specifier function call-type)))
+ (or (gethash key *alien-callbacks*)
+ (setf (gethash key *alien-callbacks*)
+ (let* ((index (fill-pointer *alien-callback-trampolines*))
+ ;; Aside from the INDEX this is known at
+ ;; compile-time, which could be utilized by
+ ;; having the two-stage assembler tramp &
+ ;; wrapper mentioned in [1] above: only the
+ ;; per-function tramp would need assembler at
+ ;; runtime. Possibly we could even pregenerate
+ ;; the code and just patch the index in later.
+ (assembler-wrapper (alien-callback-assembler-wrapper
+ index result-type argument-types
+ (if (eq call-type :stdcall)
+ (* 4 (length argument-types))
+ 0))))
+ (vector-push-extend
+ (alien-callback-lisp-trampoline wrapper function)
+ *alien-callback-trampolines*)
+ (let ((sap (vector-sap assembler-wrapper)))
+ (push (cons sap (make-callback-info :specifier specifier
+ :function function
+ :wrapper wrapper
+ :index index))
+ *alien-callback-info*)
+ sap))))))
+
+(sb-ext:without-package-locks
+ (defmacro alien-callback (specifier function &optional (call-type :cdecl) &environment env)
+ "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to
+an alien function as a pointer to the FUNCTION. If a callback for the given
+SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
+one."
+ ;; Pull out as much work as is convenient to macro-expansion time, specifically
+ ;; everything that can be done given just the SPECIFIER and ENV.
+ (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
+ `(%sap-alien
+ (%alien-callback-sap ',specifier ',result-type ',argument-types
+ ,function
+ (or (gethash ',specifier *alien-callback-wrappers*)
+ (setf (gethash ',specifier *alien-callback-wrappers*)
+ ,(alien-callback-lisp-wrapper-lambda
+ specifier result-type argument-types env))) ,call-type)
+ ',(parse-alien-type specifier env)))))
+
+#|
+(sb-alien::alien-callback (function int int int) #'+ :stdcall)
+ => #<SB-ALIEN-INTERNALS:ALIEN-VAUE :SAP ... :TYPE ...>
+(alien-funcall-stdcall * 3 4) => 9
+"Hey everybody, callbacks work!"
+|#
+
+;;; EOF
Added: trunk/src/external-libraries/sbcl-callback-patch/readme.txt
==============================================================================
--- (empty file)
+++ trunk/src/external-libraries/sbcl-callback-patch/readme.txt Thu Aug 10 17:33:31 2006
@@ -0,0 +1,8 @@
+This directory contains callback-hacking.lisp, authored by
+Alastair Bridgewater. This code updates an SBCL image such
+that stdcall callbacks are supported.
+
+The full distribution including sample code is available from:
+
+ http://www.lisphacker.com/files/lisp-winapi.tgz
+ http://www.lisphacker.com/files/hello-win32.tgz
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 17:33:31 2006
@@ -45,9 +45,9 @@
:unicode
:ascii))
-(defctype ATOM :unsigned-short) ; shadowed in defpackage
+(defctype ATOM :unsigned-short) ; shadowed in gfs: package
(defctype BOOL :int)
-(defctype BOOLEAN :char) ; shadowed in defpackage
+(defctype BOOLEAN :char) ; shadowed in gfs: package
(defctype BYTE :unsigned-char)
(defctype COLORREF :unsigned-long)
(defctype DWORD :unsigned-long)
@@ -73,6 +73,26 @@
(defctype WORD :short)
(defctype WPARAM :unsigned-int)
+#+sbcl
+(sb-alien:define-alien-type enumchildproc
+ (sb-alien:* (sb-alien:function sb-alien:int
+ sb-alien:system-area-pointer
+ sb-alien:long)))
+
+#+sbcl
+(sb-alien:define-alien-type enumthreadwndproc
+ (sb-alien:* (sb-alien:function sb-alien:int
+ sb-alien:system-area-pointer
+ sb-alien:long)))
+
+#+sbcl
+(sb-alien:define-alien-type monitorsenumproc
+ (sb-alien:* (sb-alien:function sb-alien:int
+ sb-alien:system-area-pointer
+ sb-alien:system-area-pointer
+ sb-alien:system-area-pointer
+ sb-alien:long)))
+
(defcstruct actctx
(cbsize ULONG)
(flags DWORD)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 17:33:31 2006
@@ -223,6 +223,12 @@
(lparam ffi:long))
(:return-type ffi:int))
+#+sbcl
+(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int
+ (hwnd sb-alien:system-area-pointer)
+ (func enumchildproc)
+ (lparam sb-alien:long))
+
;;; FIXME: uncomment this when CFFI callbacks can
;;; be tagged as stdcall or cdecl (only the latter
;;; is supported as of 0.9.0)
@@ -264,6 +270,13 @@
(data ffi:c-pointer))
(:return-type ffi:int))
+#+sbcl
+(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int
+ (hdc sb-alien:system-area-pointer)
+ (rect sb-alien:system-area-pointer)
+ (func monitorsenumproc)
+ (lparam sb-alien:long))
+
;;; FIXME: uncomment this when CFFI callbacks can
;;; be tagged as stdcall or cdecl (only the latter
;;; is supported as of 0.9.0)
@@ -300,6 +313,12 @@
(lparam ffi:long))
(:return-type ffi:int))
+#+sbcl
+(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int
+ (id sb-alien:unsigned-long)
+ (func enumthreadwndproc)
+ (lparam sb-alien:unsigned-long))
+
(defcfun
("GetAncestor" get-ancestor)
HANDLE
Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp (original)
+++ trunk/src/uitoolkit/widgets/display.lisp Thu Aug 10 17:33:31 2006
@@ -48,12 +48,22 @@
(call-display-visitor-func (thread-context) hmonitor data)
1)
-#+clisp
-(defun display_visitor (hmonitor hdc monitorrect data)
+(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
+ (sb-alien:function sb-alien:int
+ sb-alien:system-area-pointer
+ sb-alien:system-area-pointer
+ sb-alien:system-area-pointer
+ sb-alien:long)
+ #'display-visitor
+ :stdcall))
+
(defun query-display-info (hmonitor)
(let ((info nil))
(cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex)
@@ -87,9 +97,14 @@
(let ((tc (thread-context)))
(setf (display-visitor-func tc) func)
(unwind-protect
-#+lispworks (let ((ptr (fli:make-pointer :address 0)))
+#+sbcl
+ (let ((ptr (cffi:null-pointer)))
+ (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0))
+#+lispworks
+ (let ((ptr (fli:make-pointer :address 0)))
(gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0))
-#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil)
+#+clisp
+ (gfs::enum-display-monitors nil nil #'display-visitor nil)
(setf (display-visitor-func tc) nil))
(let ((tmp (reverse (display-visitor-results tc))))
(setf (display-visitor-results tc) nil)
@@ -104,26 +119,31 @@
(defun obtain-primary-display ()
(find-if #'primary-p (obtain-displays)))
-#+lispworks
-(fli:define-foreign-callable
- ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall)
- ((hwnd :pointer)
- (lparam :long))
+(defun top-level-window-visitor (hwnd lparam)
+ (declare (ignore lparam))
(let* ((tc (thread-context))
(win (get-widget tc hwnd)))
(unless (null win)
(call-top-level-visitor-func tc win)))
1)
-#+clisp
-(defun top_level_window_visitor (hwnd lparam)
- (declare (ignore lparam))
- (let* ((tc (thread-context))
- (win (get-widget tc hwnd)))
- (unless (null win)
- (call-top-level-visitor-func tc win)))
+#+lispworks
+(fli:define-foreign-callable
+ ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall)
+ ((hwnd :pointer)
+ (lparam :long))
+ (top-level-window-visitor hwnd lparam)
1)
+#+sbcl
+(defvar *enum-thread-wnd-proc*
+ (sb-alien::alien-callback
+ (sb-alien:function sb-alien:int
+ sb-alien:system-area-pointer
+ sb-alien:long)
+ #'top-level-window-visitor
+ :stdcall))
+
(defun maptoplevels (func)
;;
;; func should expect one parameter:
@@ -132,12 +152,18 @@
(let ((tc (thread-context)))
(setf (top-level-visitor-func tc) func)
(unwind-protect
-#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
- (fli:make-pointer :symbol-name "top_level_window_visitor")
- 0)
-#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
- #'top_level_window_visitor
- 0)
+#+sbcl
+ (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+ (sb-alien:alien-sap *enum-thread-wnd-proc*)
+ 0)
+#+lispworks
+ (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+ (fli:make-pointer :symbol-name "top_level_window_visitor")
+ 0)
+#+clisp
+ (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+ #'top-level-window-visitor
+ 0)
(setf (top-level-visitor-func tc) nil))
(let ((tmp (reverse (top-level-visitor-results tc))))
(setf (top-level-visitor-results tc) nil)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 17:33:31 2006
@@ -60,34 +60,31 @@
(put-kbdnav-widget tc win))
(put-widget tc win))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmacro child-visitor-proper (hwnd lparam)
- (let ((tc (gensym))
- (tmp-list (gensym))
- (child (gensym))
- (parent (gensym))
- (ancestor-hwnd (gensym)))
- `(let* ((,tc (thread-context))
- (,child (get-widget ,tc ,hwnd))
- (,parent (get-widget ,tc (cffi:make-pointer ,lparam))))
- (unless (or (null ,parent) (null ,child))
- (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+))
- (,tmp-list (child-visitor-results ,tc)))
- (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd)
- (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list)))))))))
+(defun child-window-visitor (hwnd lparam)
+ (let* ((tc (thread-context))
+ (child (get-widget tc hwnd))
+ (parent (get-widget tc (cffi:make-pointer lparam))))
+ (unless (or (null parent) (null child))
+ (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))
+ (tmp-list (child-visitor-results tc)))
+ (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)
+ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list))))))
+ 1)
#+lispworks
(fli:define-foreign-callable
("child_window_visitor" :result-type :integer :calling-convention :stdcall)
((hwnd :pointer)
(lparam :long))
- (child-visitor-proper hwnd lparam)
+ (child-window-visitor hwnd lparam)
1)
-#+clisp
-(defun child_window_visitor (hwnd lparam)
- (child-visitor-proper hwnd lparam)
- 1)
+#+sbcl
+(defvar *enum-child-proc*
+ (sb-alien::alien-callback
+ (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long)
+ #'child-window-visitor
+ :stdcall))
(defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra)
(let ((retval 0))
@@ -213,22 +210,22 @@
(perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
(defmethod mapchildren ((self window) func)
- (let ((tc (thread-context)))
+ (let ((tc (thread-context))
+ (hwnd (gfs:handle self)))
(setf (child-visitor-func tc) func)
(unwind-protect
+#+sbcl
+ (gfs::enum-child-windows hwnd
+ (sb-alien:alien-sap *enum-child-proc*)
+ (cffi:pointer-address hwnd))
#+lispworks
- (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self)))
+ (gfs::enum-child-windows hwnd
(fli:make-pointer :symbol-name "child_window_visitor")
- (cffi:pointer-address (gfs:handle self)))
+ (cffi:pointer-address hwnd))
#+clisp
- (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
- (setf ptr (ffi:set-foreign-pointer
- (ffi:unsigned-foreign-address
- (cffi:pointer-address (gfs:handle self)))
- ptr))
- (gfs::enum-child-windows ptr
- #'child_window_visitor
- (cffi:pointer-address (gfs:handle self))))
+ (gfs::enum-child-windows hwnd
+ #'child_window_visitor
+ (cffi:pointer-address hwnd))
(setf (child-visitor-func tc) nil))
(let ((tmp (reverse (child-visitor-results tc))))
(setf (child-visitor-results tc) nil)
More information about the Graphic-forms-cvs
mailing list