[graphic-forms-cvs] r447 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Wed Mar 28 00:26:10 2007
New Revision: 447

Modified:
   trunk/src/uitoolkit/widgets/thread-context.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
revised thread context and startup implementation to use Allegro MT support

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Wed Mar 28 00:26:10 2007
@@ -65,12 +65,10 @@
 ;;
 ;; TODO: change this once we understand SBCL MT support
 ;;
-;; TODO: support Allegro MT
-;;
-#+(or allegro clisp sbcl)
+#+(or clisp sbcl)
 (defvar *the-thread-context* nil)
 
-#+(or allegro clisp sbcl)
+#+(or clisp sbcl)
 (defun thread-context ()
   (when (null *the-thread-context*)
     (setf *the-thread-context* (make-instance 'thread-context))
@@ -81,13 +79,39 @@
         (format *error-output* "~a~%" e))))
   *the-thread-context*)
 
-#+(or allegro clisp sbcl)
+#+(or clisp sbcl)
 (defun dispose-thread-context ()
   (let ((hwnd (utility-hwnd *the-thread-context*)))
     (unless (gfs:null-handle-p hwnd)
       (gfs::destroy-window hwnd)))
   (setf *the-thread-context* nil))
 
+#+allegro
+(eval-when (:compile-top-level :load-top-level :execute) (require :process))
+
+#+allegro
+(defun thread-context ()
+  (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context)))
+    (when (null tc)
+      (setf tc (make-instance 'thread-context))
+      (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) tc)
+      (handler-case
+          (init-utility-hwnd tc)
+        (gfs:win32-error (e)
+          (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil)
+          (format *error-output* "~a~%" e))))
+    tc))
+
+#+allegro
+(defun dispose-thread-context ()
+  (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context)))
+    (if tc
+      (let ((hwnd (utility-hwnd tc)))
+        (unless (gfs:null-handle-p hwnd)
+          (gfs::destroy-window hwnd)))))
+  (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil))
+
+
 #+lispworks
 (defun thread-context ()
   (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context)))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Wed Mar 28 00:26:10 2007
@@ -87,12 +87,22 @@
        (translate-and-dispatch msg-ptr)
        nil)))
 
-#+(or allegro clisp sbcl)
+#+(or clisp sbcl)
 (defun startup (thread-name start-fn)
   (declare (ignore thread-name))
   (funcall start-fn)
   (message-loop #'default-message-filter))
 
+#+allegro
+(eval-when (:compile-top-level :load-top-level :execute) (require :process))
+
+#+allegro
+(defun startup (thread-name start-fn)
+  (mp:process-run-function thread-name
+                           (lambda ()
+                             (funcall start-fn)
+                             (message-loop #'default-message-filter))))
+
 #+lispworks
 (defun startup (thread-name start-fn)
   (hcl:add-special-free-action 'gfs::native-object-special-action)