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))))