Author: junrue Date: Mon Feb 13 00:52:17 2006 New Revision: 8
Added: trunk/src/uitoolkit/widgets/thread-context.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: moved majority of global data into pre-thread data structure
Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Feb 13 00:52:17 2006 @@ -87,6 +87,7 @@ :components ((:file "widget-constants") (:file "widget-classes") + (:file "thread-context") (:file "message-generics") (:file "event-generics") (:file "layout-generics")
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Feb 13 00:52:17 2006 @@ -82,12 +82,6 @@
;; methods, functions, macros #:detail - #:get-menuitem-text - #:insert-menuitem - #:insert-separator - #:insert-submenu - #:process-message - #:register-window-class #:with-retrieved-dc
;; conditions
Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Mon Feb 13 00:52:17 2006 @@ -306,6 +306,14 @@ (remove-msg UINT))
(defcfun + ("PostMessageA" post-message) + BOOL + (hwnd HANDLE) + (msg UINT) + (wparam WPARAM) + (lparam LPARAM)) + +(defcfun ("PostQuitMessage" post-quit-message) :void (exit-code INT)) @@ -339,8 +347,8 @@ LRESULT (hwnd HANDLE) (msg UINT) - (wp WPARAM) - (lp WPARAM)) + (wparam WPARAM) + (lparam WPARAM))
(defcfun ("SetMenu" set-menu)
Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Feb 13 00:52:17 2006 @@ -51,7 +51,7 @@ (defmethod realize :after ((ctl control) parent &rest style) (let ((hwnd (gfi:handle ctl))) (subclass-wndproc hwnd) - (put-widget ctl) + (put-widget (thread-context) ctl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfi:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Feb 13 00:52:17 2006 @@ -38,12 +38,6 @@ gfs::+pm-qs-input+ gfs::+pm-qs-postmessage+))
-(defvar *last-event-time* 0) -(defvar *last-virtual-key* 0) -(defvar *mouse-event-pnt* (gfi:make-point)) -(defvar *move-event-pnt* (gfi:make-point)) -(defvar *size-event-size* (gfi:make-size)) - ;;; ;;; window procedures ;;; @@ -79,7 +73,7 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf *last-event-time* gfs::time) + (setf (event-time (thread-context)) gfs::time) (when (zerop gm) (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) @@ -103,11 +97,12 @@ (= (gfs::get-key-state key-code) 1))
(defun process-mouse-message (fn hwnd lparam btn-symbol) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (when w - (setf (gfi:point-x *mouse-event-pnt*) (lo-word lparam)) - (setf (gfi:point-y *mouse-event-pnt*) (hi-word lparam)) - (funcall fn (dispatcher w) *last-event-time* *mouse-event-pnt* btn-symbol))) + (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam)) + (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam)) + (funcall fn (dispatcher w) (event-time tc) (mouse-event-pnt tc) btn-symbol))) 0)
(defun get-class-wndproc (hwnd) @@ -132,35 +127,37 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (if w - (event-close (dispatcher w) *last-event-time*) + (event-close (dispatcher w) (event-time tc)) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) - (let ((wparam-hi (hi-word wparam)) - (owner (get-widget hwnd))) + (let* ((tc (thread-context)) + (wparam-hi (hi-word wparam)) + (owner (get-widget tc hwnd))) (if owner (cond ((zerop lparam) - (let ((item (get-menuitem (lo-word wparam)))) + (let ((item (get-menuitem tc (lo-word wparam)))) (if (null item) (error 'gfs:toolkit-error :detail "no menu item for id")) (unless (null (dispatcher item)) (event-select (dispatcher item) - *last-event-time* + (event-time tc) item (make-instance 'gfi:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t - (let ((w (get-widget (cffi:make-pointer lparam)))) + (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) (error 'gfs:toolkit-error :detail "no object for hwnd")) (unless (null (dispatcher w)) (event-select (dispatcher w) - *last-event-time* + (event-time tc) w (make-instance 'gfi:rectangle)))))) ; FIXME (error 'gfs:toolkit-error :detail "no object for hwnd"))) @@ -168,58 +165,63 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignorable hwnd lparam)) - (let ((menu (get-widget (cffi:make-pointer wparam)))) + (let* ((tc (thread-context)) + (menu (get-widget tc (cffi:make-pointer wparam)))) (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d *last-event-time*))))) + (event-activate d (event-time tc)))))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignorable hwnd lparam)) ; FIXME: handle system menus - (let ((item (get-menuitem (lo-word wparam)))) + (let* ((tc (thread-context)) + (item (get-menuitem tc (lo-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d) - (event-arm d *last-event-time* item))))) + (event-arm d (event-time tc) item))))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (declare (ignorable wparam lparam)) - (get-widget hwnd) ; has side-effect of setting handle slot + (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) - (let ((w (get-widget hwnd)) - (ch (code-char (lo-word wparam)))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (ch (code-char (lo-word wparam)))) (when w - (event-key-down (dispatcher w) *last-event-time* *last-virtual-key* ch))) + (event-key-down (dispatcher w) (event-time tc) (virtual-key tc) ch))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) - (let* ((wparam-lo (lo-word wparam)) + (let* ((tc (thread-context)) + (wparam-lo (lo-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget hwnd))) - (setf *last-virtual-key* wparam-lo) + (w (get-widget tc hwnd))) + (setf (virtual-key tc) wparam-lo) (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) - (event-key-down (dispatcher w) *last-event-time* wparam-lo (code-char ch)))) + (event-key-down (dispatcher w) (event-time tc) wparam-lo (code-char ch)))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) - (unless (zerop *last-virtual-key*) - (let* ((wparam-lo (lo-word wparam)) - (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget hwnd))) - (when w - (event-key-up (dispatcher w) *last-event-time* wparam-lo (code-char ch))))) - (setf *last-virtual-key* 0) + (let ((tc (thread-context))) + (unless (zerop (virtual-key tc)) + (let* ((wparam-lo (lo-word wparam)) + (ch (gfs::map-virtual-key wparam-lo 2)) + (w (get-widget tc hwnd))) + (when w + (event-key-up (dispatcher w) (event-time tc) wparam-lo (code-char ch))))) + (setf (virtual-key tc) 0)) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam) @@ -259,23 +261,26 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (when w - (outer-location w *move-event-pnt*) - (event-move (dispatcher w) *last-event-time* *move-event-pnt*))) + (outer-location w (move-event-pnt tc)) + (event-move (dispatcher w) (event-time tc) (move-event-pnt tc)))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) - (if (and w (event-pre-move (dispatcher w) *last-event-time*)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) + (if (and w (event-pre-move (dispatcher w) (event-time tc))) 1 0)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd)) - (gc (make-instance 'gfg:graphics-context))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (gc (make-instance 'gfg:graphics-context))) (if w (let ((rct (make-instance 'gfi:rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) @@ -290,7 +295,7 @@ (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (unwind-protect - (event-paint (dispatcher w) *last-event-time* gc rct) + (event-paint (dispatcher w) (event-time tc) gc rct) (gfs::end-paint hwnd ps-ptr))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -309,21 +314,23 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) - (let ((w (get-widget hwnd)) - (type (cond - ((= wparam gfs::+size-maximized+) 'maximized) - ((= wparam gfs::+size-minimized+) 'minimized) - ((= wparam gfs::+size-restored+) 'restored) - (t nil)))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (type (cond + ((= wparam gfs::+size-maximized+) 'maximized) + ((= wparam gfs::+size-minimized+) 'minimized) + ((= wparam gfs::+size-restored+) 'restored) + (t nil)))) (when w - (outer-size w *size-event-size*) - (event-resize (dispatcher w) *last-event-time* *size-event-size* type))) + (outer-size w (size-event-size tc)) + (event-resize (dispatcher w) (event-time tc) (size-event-size tc) type))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) - (if (and w (event-pre-resize (dispatcher w) *last-event-time*)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) + (if (and w (event-pre-resize (dispatcher w) (event-time tc))) 1 0)))
@@ -339,7 +346,7 @@
(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) (call-next-method))
;;;
Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Feb 13 00:52:17 2006 @@ -33,10 +33,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defparameter *next-menuitem-id* 10000) - -(defvar *menuitems-by-id* (make-hash-table :test #'eql)) - ;;; ;;; helper functions ;;; @@ -177,7 +173,7 @@ (error 'gfi:disposed-error)) (let ((hwnd (gfs::get-submenu (gfi:handle m) index))) (if (not (gfi:null-handle-p hwnd)) - (get-widget hwnd) + (get-widget (thread-context) hwnd) nil)))
(defun visit-menu-tree (menu fn) @@ -193,28 +189,30 @@ ;;;
(defun menu-cleanup-callback (menu item) - (remove-widget (gfi:handle menu)) - (remove-menuitem item)) + (let ((tc (thread-context))) + (remove-widget tc (gfi:handle menu)) + (remove-menuitem tc item)))
(defmethod gfi:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) (let ((hwnd (gfi:handle m))) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) (if (not (gfi:null-handle-p hwnd)) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) (setf (slot-value m 'gfi:handle) nil))
(defmethod item-append ((m menu) (it menu-item)) - (let ((id *next-menuitem-id*) - (hmenu (gfi:handle m))) + (let* ((tc (thread-context)) + (id (next-menuitem-id tc)) + (hmenu (gfi:handle m))) (if (gfi:null-handle-p hmenu) (error 'gfi:disposed-error)) - (setf *next-menuitem-id* (1+ id)) + (increment-menuitem-id tc) (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) (setf (item-id it) id) (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem it) + (put-menuitem tc it) (call-next-method)))
;;; @@ -223,7 +221,7 @@
(defmethod gfi:dispose ((it menu-item)) (setf (dispatcher it) nil) - (remove-menuitem it) + (remove-menuitem (thread-context) it) (let ((id (item-id it)) (owner (item-owner it))) (unless (null owner) @@ -239,7 +237,7 @@ (let ((hmenu (gfi:handle it))) (if (gfi:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget hmenu))) + (let ((m (get-widget (thread-context) hmenu))) (if (null m) (error 'gfs:toolkit-error :detail "no owner menu")) m))) @@ -444,19 +442,20 @@
(defmethod initialize-instance :after ((gen menu-generator) &key) (let ((m (make-instance 'menu :handle (gfs::create-menu)))) - (put-widget m) + (put-widget (thread-context) m) (setf (menu-stack gen) (list m))))
(defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image) - (let* ((owner (first (menu-stack gen))) + (let* ((tc (thread-context)) + (owner (first (menu-stack gen))) (it (make-instance 'menu-item :dispatcher dispatcher)) - (id *next-menuitem-id*) + (id (next-menuitem-id tc)) (hmenu (gfi:handle owner))) - (setf *next-menuitem-id* (1+ id)) + (increment-menuitem-id tc) (insert-menuitem hmenu id label (cffi:null-pointer)) (setf (item-id it) id) (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem it) + (put-menuitem tc it) (vector-push-extend it (items owner))))
(defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image) @@ -467,22 +466,23 @@ (let* ((owner (first (menu-stack gen))) (it (make-instance 'menu-item)) (hmenu (gfi:handle owner))) - (put-menuitem it) + (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfi:handle) hmenu) (vector-push-extend it (items owner))))
(defmethod define-menu ((gen menu-generator) label dispatcher) - (let* ((m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) + (let* ((tc (thread-context)) + (m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) (it (make-instance 'menu-item :handle (gfi:handle parent) :dispatcher dispatcher)) - (id *next-menuitem-id*)) - (setf *next-menuitem-id* (1+ id)) + (id (next-menuitem-id tc))) + (increment-menuitem-id tc) (insert-submenu (gfi:handle parent) id label (cffi:null-pointer) (gfi:handle m)) (setf (item-id it) id) (vector-push-extend it (items parent)) (push m (menu-stack gen)) - (put-widget m) + (put-widget tc m) m))
(defmethod complete-menu ((gen menu-generator)) @@ -493,21 +493,3 @@ `(let ((,gen (make-instance 'menu-generator))) (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp) (first (menu-stack ,gen))))) - -;;; -;;; menuitems table management -;;; - -(defun get-menuitem (id) - (gethash id *menuitems-by-id*)) - -(defun put-menuitem (it) - (setf (gethash (item-id it) *menuitems-by-id*) it)) - -(defun remove-menuitem (it) - (maphash - #'(lambda (k v) - (declare (ignore v)) - (if (eql k (item-id it)) - (remhash k *menuitems-by-id*))) - *menuitems-by-id*))
Added: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Feb 13 00:52:17 2006 @@ -0,0 +1,133 @@ +;;;; +;;;; thread-context.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.widgets) + +(defclass thread-context () + ((child-visitor-stack :initform nil) + (image-loaders-by-type :initform (make-hash-table :test #'equal)) + (job-table :initform (make-hash-table :test #'equal)) + (job-table-lock :initform nil) + (event-time :initform 0 :accessor event-time) + (virtual-key :initform 0 :accessor virtual-key) + (menuitems-by-id :initform (make-hash-table :test #'equal)) + (mouse-event-pnt :initform (gfi:make-point) :accessor mouse-event-pnt) + (move-event-pnt :initform (gfi:make-point) :accessor move-event-pnt) + (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (size-event-size :initform (gfi:make-size) :accessor size-event-size) + (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (wip :initform nil)) + (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) + +;; TODO: change this when CLISP acquires MT support +;; +#+clisp (defvar *the-thread-context* nil) + +#+clisp (defun thread-context () + *the-thread-context*) + +#+lispworks (defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) + tc)) + +(defmethod call-child-visitor-func ((tc thread-context) parent child) + "Call the closure at the top of the child window visitor function stack." + (let ((fn (first (slot-value tc 'child-visitor-stack)))) + (if (null fn) + (error 'gfs:toolkit-error :detail "child visitor function stack is empty")) + (funcall fn parent child))) + +(defmethod push-child-visitor-func ((tc thread-context) func) + "Push the supplied closure onto the child window visitor function stack." + (if (not (functionp func)) + (error 'gfs:toolkit-error :detail "function argument required")) + (push func (slot-value tc 'child-visitor-stack)) + nil) + +(defmethod pop-child-visitor-func ((tc thread-context)) + "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." + (pop (slot-value tc 'child-visitor-stack))) + +(defmethod get-widget ((tc thread-context) hwnd) + "Return the widget object corresponding to the specified native window handle." + (let ((tmp-widget (slot-value tc 'wip))) + (when tmp-widget + (setf (slot-value tmp-widget 'gfi:handle) hwnd) + (return-from get-widget tmp-widget))) + (unless (gfi:null-handle-p hwnd) + (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) + +(defmethod put-widget ((tc thread-context) (w widget)) + "Add the specified widget to the widget table using its native handle as the key." + (setf (gethash (cffi:pointer-address (gfi:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) + +(defmethod remove-widget ((tc thread-context) hwnd) + "Remove the widget object corresponding to the specified native window handle." + (when (not (slot-value tc 'wip)) + (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) + +(defmethod widget-in-progress ((tc thread-context)) + "Return the widget currently under construction." + (slot-value tc 'wip)) + +(defmethod (setf widget-in-progress) ((w widget) (tc thread-context)) + "Store the widget currently under construction." + (setf (slot-value tc 'wip) w)) + +(defmethod clear-widget-in-progress ((tc thread-context)) + "Store the widget currently under construction." + (setf (slot-value tc 'wip) nil)) + +(defmethod get-menuitem ((tc thread-context) id) + "Returns the menu item identified by id." + (gethash id (slot-value tc 'menuitems-by-id))) + +(defmethod put-menuitem ((tc thread-context) (it menu-item)) + "Stores a menu item using its id as the key." + (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) + +(defmethod remove-menuitem ((tc thread-context) (it menu-item)) + "Removes the menu item using its id as the key." + (maphash + #'(lambda (k v) + (declare (ignore v)) + (if (eql k (item-id it)) + (remhash k (slot-value tc 'menuitems-by-id)))) + (slot-value tc 'menuitems-by-id))) + +(defmethod increment-menuitem-id ((tc thread-context)) + "Bump up the next menu item ID." + (incf (slot-value tc 'next-menuitem-id)))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Feb 13 00:52:17 2006 @@ -35,6 +35,7 @@
#+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) + (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn))
#+lispworks (defun startup (thread-name start-fn)
Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Feb 13 00:52:17 2006 @@ -42,7 +42,7 @@
(defmethod clear-span ((w widget-with-items) (sp gfi:span)) (loop for index from (gfi:span-start sp) to (gfi:span-end sp) - collect (clear-item w index))) + collect (clear-item w 0)))
(defmethod item-append ((w widget-with-items) (i item)) (vector-push-extend i (items w)))
Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 13 00:52:17 2006 @@ -33,10 +33,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defvar *widgets-by-hwnd* (make-hash-table :test #'equal)) - -(defvar *widget-in-progress* nil) - ;;; ;;; helper functions ;;; @@ -47,7 +43,7 @@
(defmethod ancestor-p ((ancestor widget) (descendant widget)) (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) - (parent (get-widget parent-hwnd))) + (parent (get-widget (thread-context) parent-hwnd))) (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) (return-from ancestor-p t)) (if (null parent) @@ -136,27 +132,3 @@ (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) (gfs::update-window hwnd)))) - -;;; -;;; widget table management -;;; - -(defun clear-widget-in-progress () - (setf *widget-in-progress* nil)) - -(defun set-widget-in-progress (w) - (setf *widget-in-progress* w)) - -(defun get-widget (hwnd) - (when *widget-in-progress* - (setf (slot-value *widget-in-progress* 'gfi:handle) hwnd) - (return-from get-widget *widget-in-progress*)) - (unless (gfi:null-handle-p hwnd) - (gethash (cffi:pointer-address hwnd) *widgets-by-hwnd*))) - -(defun put-widget (w) - (setf (gethash (cffi:pointer-address (gfi:handle w)) *widgets-by-hwnd*) w)) - -(defun remove-widget (hwnd) - (when (not *widget-in-progress*) - (remhash (cffi:pointer-address hwnd) *widgets-by-hwnd*)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Feb 13 00:52:17 2006 @@ -37,8 +37,6 @@
(defconstant +default-window-title+ "New Window")
-(defvar *child-visiting-functions* nil) - ;;; ;;; helper functions ;;; @@ -48,18 +46,20 @@ ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let ((child (get-widget hwnd)) - (parent (get-widget (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) parent child))) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (call-child-visitor-func tc parent child))) 1)
#+clisp (defun child_window_visitor (hwnd lparam) - (let ((child (get-widget hwnd)) - (parent (get-widget (cffi:make-pointer lparam)))) - (unless (or (null child) (null parent) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) parent child))) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null child) (null parent)) + (call-child-visitor-func tc parent child))) 1)
(defun visit-child-widgets (win func) @@ -68,8 +68,9 @@ ;; parent window object ;; current child widget ;; - (push func *child-visiting-functions*) - (unwind-protect + (let ((tc (thread-context))) + (push-child-visitor-func tc func) + (unwind-protect #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address (gfi:handle win))) @@ -81,7 +82,8 @@ (gfs::enum-child-windows ptr #'child_window_visitor (cffi:pointer-address (gfi:handle win)))) - (pop *child-visiting-functions*))) + (pop-child-visitor-func tc))) + nil)
(defun register-window-class (class-name proc-ptr st) (let ((retval 0)) @@ -192,7 +194,7 @@ (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (gfi:handle m)))) + (remove-widget (thread-context) (gfi:handle m)))) (call-next-method))
(defmethod hide ((win window)) @@ -209,7 +211,7 @@ (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) (return-from menu-bar nil)) - (let ((m (get-widget hmenu))) + (let ((m (get-widget (thread-context) hmenu))) (if (null m) (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) @@ -217,7 +219,7 @@ (defmethod (setf menu-bar) ((m menu) (win window)) (let* ((hwnd (gfi:handle win)) (hmenu (gfs::get-menu hwnd)) - (old-menu (get-widget hmenu))) + (old-menu (get-widget (thread-context) hmenu))) (unless (gfi:null-handle-p hmenu) (gfs::destroy-menu hmenu)) (unless (null old-menu) @@ -230,29 +232,30 @@ (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) - (set-widget-in-progress win) - (register-workspace-window-class) - (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) - (create-window +workspace-window-classname+ - +default-window-title+ - (cffi:null-pointer) - std-style - ex-style)) - (clear-widget-in-progress) - (let ((hwnd (gfi:handle win))) - (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfs:win32-error :detail "create-window failed")) - (put-widget win))) + (let ((tc (thread-context))) + (setf (widget-in-progress tc) win) + (register-workspace-window-class) + (multiple-value-bind (std-style ex-style) + (compute-style-flags win style) + (create-window +workspace-window-classname+ + +default-window-title+ + (cffi:null-pointer) + std-style + ex-style)) + (clear-widget-in-progress tc) + (let ((hwnd (gfi:handle win))) + (if (not hwnd) ; handle slot should have been set during create-window + (error 'gfs:win32-error :detail "create-window failed")) + (put-widget tc win))))
(defmethod show ((win window)) (let ((hwnd (gfi:handle win))) (gfs::show-window hwnd gfs::+sw-shownormal+) (gfs::update-window hwnd)))
-(defmethod size ((w widget)) - (if (gfi:disposed-p w) +(defmethod size ((win window)) + (if (gfi:disposed-p win) (error 'gfi:disposed-error)) (let ((sz (gfi:make-size))) - (outer-size w sz) + (outer-size win sz) sz))