[graphic-forms-cvs] r443 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 19 04:25:53 UTC 2007
Author: junrue
Date: Sun Mar 18 23:25:52 2007
New Revision: 443
Modified:
trunk/NEWS.txt
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/display.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
revised stdcall callback declarations to take advantage of built-in CFFI support
Modified: trunk/NEWS.txt
==============================================================================
--- trunk/NEWS.txt (original)
+++ trunk/NEWS.txt Sun Mar 18 23:25:52 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?download
+
+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: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Mar 18 23:25:52 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: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp (original)
+++ trunk/src/uitoolkit/widgets/display.lisp Sun Mar 18 23:25:52 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
+#-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: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Mar 18 23:25:52 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)
More information about the Graphic-forms-cvs
mailing list