[graphic-forms-cvs] r413 - in trunk/src/uitoolkit: system widgets - graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

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

    