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)