Author: junrue Date: Sun Mar 18 23:25:30 2007 New Revision: 442 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: revised stdcall callback declarations to take advantage of built-in CFFI support Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Sun Mar 18 23:25:30 2007 @@ -1,5 +1,5 @@ -. Latest CFFI is required to take advantage of newly-added support for the +. Latest CFFI is required to take advantage of built-in support for the stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). @@ -8,12 +8,27 @@ . Ported the library to Allegro CL 8.0. +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) + . Implemented a new graphics context function GFG:CLEAR that is a convenient way to fill a window or image with a background color. . GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll and shell32.dll. +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.8.0.zip?dow... + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +xx xxxxxxx 2007 + ============================================================================== Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp Sun Mar 18 23:25:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; user32.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -206,39 +206,13 @@ (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) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumChildWindows" enum-child-windows) - BOOL + ("EnumChildWindows" enum-child-windows :cconv :stdcall) + INT (hwnd HANDLE) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-child-windows "EnumChildWindows") - ((hwnd :foreign-address) - (func :foreign-address) - (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)) #+lispworks (fli:define-foreign-function @@ -248,50 +222,14 @@ (lparam :long)) :result-type :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) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumDisplayMonitors" enum-display-monitors) - BOOL + ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) + INT (hdc HANDLE) (cliprect LPTR) (enumproc LPTR) (data LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors") - ((hdc :foreign-address) - (cliprect :foreign-address) - (func :foreign-address) - (data :foreign-address))) - -#+clisp -(ffi:def-call-out enum-display-monitors - (:name "EnumDisplayMonitors") - (:library "user32.dll") - (:language :stdc) - (:arguments (hdc ffi:c-pointer) - (cliprect ffi:c-pointer) - (func (ffi:c-function - (:arguments - (hmonitor ffi:c-pointer) - (hdc ffi:c-pointer) - (monitorrect ffi:c-pointer) - (data ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (data ffi:c-pointer)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -302,46 +240,13 @@ (data :long)) :result-type :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) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumThreadWindows" enum-thread-windows) - BOOL + ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) + INT (threadid DWORD) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-thread-windows "EnumThreadWindows") - ((thread-id :unsigned-long) - (func :foreign-address) - (lparam :long))) - -#+clisp -(ffi:def-call-out enum-thread-windows - (:name "EnumThreadWindows") - (:library "user32.dll") - (:language :stdc) - (:arguments (threadid ffi:ulong) - (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)) #+lispworks (fli:define-foreign-function @@ -351,12 +256,6 @@ (lparam :long)) :result-type :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: branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp Sun Mar 18 23:25:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; display.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -37,23 +37,13 @@ ;;; helper functions ;;; -(defun display-visitor (hmonitor hdc monitorrect data) +#-cffi-features:no-stdcall +(cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL + ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (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) @@ -65,17 +55,6 @@ (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) @@ -109,17 +88,13 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+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) +#-cffi-features:no-stdcall + (gfs::enum-display-monitors (cffi:null-pointer) + (cffi:null-pointer) + (cffi:callback display-visitor) 0) #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+sbcl - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -134,7 +109,9 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -(defun top-level-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) @@ -142,16 +119,6 @@ (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) @@ -160,15 +127,6 @@ (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: @@ -177,22 +135,14 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+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) +#-cffi-features:no-stdcall + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (cffi:callback top-level-window-visitor) + 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) -#+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) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Sun Mar 18 23:25:30 2007 @@ -70,7 +70,9 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -(defun child-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) @@ -81,16 +83,6 @@ (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) @@ -99,13 +91,6 @@ (child-window-visitor 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 window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -341,22 +326,14 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#+allegro +#-cffi-features:no-stdcall (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:callback child-window-visitor) (cffi:pointer-address hwnd)) #+lispworks (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address hwnd)) -#+sbcl - (gfs::enum-child-windows hwnd - (sb-alien:alien-sap *enum-child-proc*) - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil)