[graphic-forms-cvs] r413 - in trunk/src/uitoolkit: system widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Dec 17 03:47:26 UTC 2006
Author: junrue
Date: Sat Dec 16 22:47:24 2006
New Revision: 413
Modified:
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/display.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
AllegroCL 8.0 port
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sat Dec 16 22:47:24 2006
@@ -219,13 +219,19 @@
(lparam LPARAM))
|#
-#+lispworks
-(fli:define-foreign-function
- (enum-child-windows "EnumChildWindows")
- ((hwnd :pointer)
- (func :pointer)
- (lparam :long))
- :result-type :int)
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address)
+ (lparam :long))
+ (declare (:convention :stdcall)))
+
+ (ff:register-foreign-callable 'enum-child-windows-callback :reuse t))
+
+#+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
@@ -242,6 +248,14 @@
(lparam ffi:long))
(:return-type ffi:int))
+#+lispworks
+(fli:define-foreign-function
+ (enum-child-windows "EnumChildWindows")
+ ((hwnd :pointer)
+ (func :pointer)
+ (lparam :long))
+ :result-type :int)
+
#+sbcl
(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int
(hwnd sb-alien:system-area-pointer)
@@ -262,14 +276,22 @@
(data LPARAM))
|#
-#+lispworks
-(fli:define-foreign-function
- (enum-display-monitors "EnumDisplayMonitors")
- ((hdc :pointer)
- (cliprect :pointer)
- (enumproc :pointer)
- (data :long))
- :result-type :int)
+#+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)))
+
+ (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t))
+
+#+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
@@ -289,6 +311,15 @@
(data ffi:c-pointer))
(:return-type ffi:int))
+#+lispworks
+(fli:define-foreign-function
+ (enum-display-monitors "EnumDisplayMonitors")
+ ((hdc :pointer)
+ (cliprect :pointer)
+ (enumproc :pointer)
+ (data :long))
+ :result-type :int)
+
#+sbcl
(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int
(hdc sb-alien:system-area-pointer)
@@ -309,13 +340,19 @@
(lparam LPARAM))
|#
-#+lispworks
-(fli:define-foreign-function
- (enum-thread-windows "EnumThreadWindows")
- ((threadid (:unsigned :long))
- (func :pointer)
- (lparam :long))
- :result-type :int)
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address)
+ (lparam :long))
+ (declare (:convention :stdcall)))
+
+ (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t))
+
+#+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
@@ -332,6 +369,14 @@
(lparam ffi:long))
(:return-type ffi:int))
+#+lispworks
+(fli:define-foreign-function
+ (enum-thread-windows "EnumThreadWindows")
+ ((threadid (:unsigned :long))
+ (func :pointer)
+ (lparam :long))
+ :result-type :int)
+
#+sbcl
(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int
(id sb-alien:unsigned-long)
Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp (original)
+++ trunk/src/uitoolkit/widgets/display.lisp Sat Dec 16 22:47:24 2006
@@ -97,14 +97,14 @@
(let ((tc (thread-context)))
(setf (display-visitor-func tc) func)
(unwind-protect
-#+sbcl
- (let ((ptr (cffi:null-pointer)))
- (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0))
+#+(or allegro clisp)
+ (gfs::enum-display-monitors nil nil #'display-visitor nil)
#+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)
+#+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)
@@ -152,17 +152,17 @@
(let ((tc (thread-context)))
(setf (top-level-visitor-func tc) func)
(unwind-protect
-#+sbcl
+#+(or allegro clisp)
(gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
- (sb-alien:alien-sap *enum-thread-wnd-proc*)
+ #'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)
-#+clisp
+#+sbcl
(gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
- #'top-level-window-visitor
+ (sb-alien:alien-sap *enum-thread-wnd-proc*)
0)
(setf (top-level-visitor-func tc) nil))
(let ((tmp (reverse (top-level-visitor-results tc))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Dec 16 22:47:24 2006
@@ -62,10 +62,12 @@
;;
;; TODO: change this once we understand SBCL MT support
;;
-#+(or clisp sbcl)
+;; TODO: support Allegro MT
+;;
+#+(or allegro clisp sbcl)
(defvar *the-thread-context* nil)
-#+(or clisp sbcl)
+#+(or allegro clisp sbcl)
(defun thread-context ()
(when (null *the-thread-context*)
(setf *the-thread-context* (make-instance 'thread-context))
@@ -76,7 +78,7 @@
(format *error-output* "~a~%" e))))
*the-thread-context*)
-#+(or clisp sbcl)
+#+(or allegro clisp sbcl)
(defun dispose-thread-context ()
(let ((hwnd (utility-hwnd *the-thread-context*)))
(unless (gfs:null-handle-p hwnd)
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat Dec 16 22:47:24 2006
@@ -87,7 +87,7 @@
(translate-and-dispatch msg-ptr)
nil)))
-#+(or clisp sbcl)
+#+(or allegro clisp sbcl)
(defun startup (thread-name start-fn)
(declare (ignore thread-name))
(funcall start-fn)
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sat Dec 16 22:47:24 2006
@@ -306,7 +306,6 @@
(gfs:make-point :x gfs::x :y gfs::y))))))
(defmethod (setf location) :before ((pnt gfs:point) (self widget))
- (declare (ignore pnt))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
@@ -433,7 +432,6 @@
(client-size self))
(defmethod (setf size) :before ((size gfs:size) (self widget))
- (declare (ignore size))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sat Dec 16 22:47:24 2006
@@ -329,17 +329,17 @@
(hwnd (gfs:handle self)))
(setf (child-visitor-func tc) func)
(unwind-protect
-#+sbcl
+#+(or allegro clisp)
(gfs::enum-child-windows hwnd
- (sb-alien:alien-sap *enum-child-proc*)
+ #'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))
-#+clisp
+#+sbcl
(gfs::enum-child-windows hwnd
- #'child-window-visitor
+ (sb-alien:alien-sap *enum-child-proc*)
(cffi:pointer-address hwnd))
(setf (child-visitor-func tc) nil))
(let ((tmp (reverse (child-visitor-results tc))))
More information about the Graphic-forms-cvs
mailing list