[graphic-forms-cvs] r8 - in trunk: . src src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Feb 13 06:52:19 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list