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)