Author: junrue
Date: Mon Feb 20 21:58:21 2006
New Revision: 16
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
implement menu item check/uncheck; cleaned up some widget method names; added additional native handle error checking
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Feb 20 21:58:21 2006
@@ -292,6 +292,8 @@
#:background-pattern
#:border-width
#:caret
+ #:check
+ #:check-all
#:checked-p
#:clear-all
#:clear-item
@@ -376,7 +378,6 @@
#:hide-lines
#:horizontal-scrollbar
#:image
- #:item-append
#:item-at
#:item-count
#:item-height
@@ -422,8 +423,9 @@
#:retrieve-span
#:run-default-message-loop
#:scroll
+ #:select
#:select-all
- #:selected
+ #:selected-p
#:selection-count
#:selection-index
#:selection-indices
@@ -450,6 +452,8 @@
#:traverse-order
#:trim-sizes
#:unlock
+ #:uncheck
+ #:uncheck-all
#:update
#:vertical-scrollbar
#:visible-item-count
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 20 21:58:21 2006
@@ -109,6 +109,10 @@
((item-disp-class
:accessor item-disp-class
:initarg :item-disp-class
+ :initform nil)
+ (check-test-fn
+ :accessor check-test-fn
+ :initarg :check-test-fn
:initform nil)))
(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
@@ -117,10 +121,14 @@
(gfw:with-children (*layout-tester-win* kids)
(loop for k in kids
do (let ((it (make-instance 'gfw:menu-item)))
- (gfw:item-append menu it)
+ (gfw:append-item menu it)
(unless (null (item-disp-class d))
(setf (gfw:dispatcher it) (make-instance (item-disp-class d))))
- (setf (gfw:text it) (gfw:text k))))))
+ (setf (gfw:text it) (gfw:text k))
+ (unless (null (check-test-fn d))
+ (if (funcall (check-test-fn d) k)
+ (gfw::check it)
+ (gfw::uncheck it)))))))
(defclass remove-child-dispatcher (gfw:event-dispatcher) ())
@@ -136,9 +144,9 @@
(gfi:dispose victim)
(gfw:layout *layout-tester-win*))))
-(defclass hide-child-dispatcher (gfw:event-dispatcher) ())
+(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())
-(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect)
+(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect)
(declare (ignorable time rect))
(let ((text (gfw:text item))
(victim nil))
@@ -147,23 +155,11 @@
do (if (string= (gfw:text k) text)
(setf victim k))))
(unless (null victim)
- (gfw:hide victim)
+ (if (gfw:visible-p victim)
+ (gfw:hide victim)
+ (gfw:show victim))
(gfw:layout *layout-tester-win*))))
-(defclass show-child-dispatcher (gfw:event-dispatcher) ())
-
-(defmethod gfw:event-select ((d show-child-dispatcher) item time rect)
- (declare (ignorable time rect))
- (let ((text (gfw:text item))
- (victim nil))
- (gfw:with-children (*layout-tester-win* kids)
- (loop for k in kids
- do (if (string= (gfw:text k) text)
- (setf victim k))))
- (unless (null victim)
- (gfw:show victim)
- (gfw:pack *layout-tester-win*))))
-
(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
@@ -177,8 +173,8 @@
(pack-disp (make-instance 'pack-layout-dispatcher))
(add-btn-disp (make-instance 'add-child-dispatcher))
(rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher))
- (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher))
- (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher)))
+ (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher
+ :check-test-fn #'gfw:visible-p)))
(setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
:layout-manager (make-instance 'gfw:flow-layout)))
(gfw:realize *layout-tester-win* nil :style-workspace)
@@ -187,18 +183,13 @@
((:menu "&Children")
(:menuitem :submenu ((:menu "Add")
(:menuitem "Button" :dispatcher ,add-btn-disp)))
- (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)
- (:menuitem :separator)))
- (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp)
- (:menuitem :separator)))
- (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp)
- (:menuitem :separator))))
+ (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)))
+ (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp))))
((:menu "&Window")
(:menuitem "Pack" :dispatcher ,pack-disp)
(:menuitem :submenu ((:menu "Select Layout")
(:menuitem "Flow")))
- (:menuitem :submenu ((:menu "Modify Layout")
- (:menuitem :separator)))))))
+ (:menuitem :submenu ((:menu "Modify Layout")))))))
(setf (gfw:menu-bar *layout-tester-win*) menubar)
(dotimes (i 3)
(add-layout-tester-widget 'gfw:button :push-button))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Mon Feb 20 21:58:21 2006
@@ -43,12 +43,14 @@
(error 'gfi:disposed-error)))
(defmethod realize :before ((ctl control) parent &rest style)
+ (declare (ignore style))
(if (gfi:disposed-p parent)
(error 'gfi:disposed-error))
(if (not (gfi:disposed-p ctl))
(error 'gfs:toolkit-error :detail "object already realized")))
(defmethod realize :after ((ctl control) parent &rest style)
+ (declare (ignorable parent style))
(let ((hwnd (gfi:handle ctl)))
(subclass-wndproc hwnd)
(put-widget (thread-context) ctl)
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Mon Feb 20 21:58:21 2006
@@ -95,7 +95,54 @@
(if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr))
(error 'gfs:win32-error :detail "set-menu-item-info failed")))))
-(defun insert-menuitem (howner mid label hbmp)
+(defun check-menuitem (hmenu mid checked)
+ (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+ gfs::state gfs::id gfs::hsubmenu
+ gfs::hbmpchecked gfs::hbmpunchecked
+ gfs::idata gfs::tdata gfs::cch
+ gfs::hbmpitem)
+ mii-ptr gfs::menuiteminfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+ (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+))
+ (setf gfs::type 0)
+ (setf gfs::state (if checked gfs::+mfs-checked+ gfs::+mfs-unchecked+))
+ (setf gfs::id mid)
+ (setf gfs::hsubmenu (cffi:null-pointer))
+ (setf gfs::hbmpchecked (cffi:null-pointer))
+ (setf gfs::hbmpunchecked (cffi:null-pointer))
+ (setf gfs::idata 0)
+ (setf gfs::tdata (cffi:null-pointer))
+ (setf gfs::cch 0)
+ (setf gfs::hbmpitem (cffi:null-pointer)))
+ (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr))
+ (error 'gfs:win32-error :detail "set-menu-item-info failed"))))
+
+(defun is-menuitem-checked (hmenu mid)
+ (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+ gfs::state gfs::id gfs::hsubmenu
+ gfs::hbmpchecked gfs::hbmpunchecked
+ gfs::idata gfs::tdata gfs::cch
+ gfs::hbmpitem)
+ mii-ptr gfs::menuiteminfo)
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+ (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+))
+ (setf gfs::type 0)
+ (setf gfs::state 0)
+ (setf gfs::id mid)
+ (setf gfs::hsubmenu (cffi:null-pointer))
+ (setf gfs::hbmpchecked (cffi:null-pointer))
+ (setf gfs::hbmpunchecked (cffi:null-pointer))
+ (setf gfs::idata 0)
+ (setf gfs::tdata (cffi:null-pointer))
+ (setf gfs::cch 0)
+ (setf gfs::hbmpitem (cffi:null-pointer))
+ (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
+ (error 'gfs:win32-error :detail "set-menu-item-info failed"))
+ (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
+
+(defun insert-menuitem (hmenu mid label hbmp)
(cffi:with-foreign-string (str-ptr label)
(cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
(cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
@@ -116,7 +163,7 @@
(setf gfs::tdata str-ptr)
(setf gfs::cch (length label))
(setf gfs::hbmpitem hbmp))
- (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+ (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
(error 'gfs::win32-error :detail "insert-menu-item failed")))))
(defun insert-submenu (hparent mid label hbmp hchildmenu)
@@ -145,7 +192,7 @@
(if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
(error 'gfs::win32-error :detail "insert-menu-item failed")))))
-(defun insert-separator (howner)
+(defun insert-separator (hmenu)
(cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
(cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
gfs::state gfs::id gfs::hsubmenu
@@ -165,7 +212,7 @@
(setf gfs::tdata (cffi:null-pointer))
(setf gfs::cch 0)
(setf gfs::hbmpitem (cffi:null-pointer)))
- (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+ (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
(error 'gfs::win32-error :detail "insert-menu-item failed"))))
(defun sub-menu (m index)
@@ -188,6 +235,19 @@
;;; menu methods
;;;
+(defmethod append-item ((m menu) (it menu-item))
+ (let* ((tc (thread-context))
+ (id (next-menuitem-id tc))
+ (hmenu (gfi:handle m)))
+ (if (gfi:null-handle-p hmenu)
+ (error 'gfi:disposed-error))
+ (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 tc it)
+ (call-next-method)))
+
(defun menu-cleanup-callback (menu item)
(let ((tc (thread-context)))
(remove-widget tc (gfi:handle menu))
@@ -202,23 +262,22 @@
(error 'gfs:win32-error :detail "destroy-menu failed"))))
(setf (slot-value m 'gfi:handle) nil))
-(defmethod item-append ((m menu) (it menu-item))
- (let* ((tc (thread-context))
- (id (next-menuitem-id tc))
- (hmenu (gfi:handle m)))
- (if (gfi:null-handle-p hmenu)
- (error 'gfi:disposed-error))
- (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 tc it)
- (call-next-method)))
-
;;;
-;;; item methods
+;;; menu-item methods
;;;
+(defmethod check ((it menu-item))
+ (let ((hmenu (gfi:handle it)))
+ (if (gfi:null-handle-p hmenu)
+ (error 'gfs:toolkit-error :detail "null owner menu handle"))
+ (check-menuitem hmenu (item-id it) t)))
+
+(defmethod checked-p ((it menu-item))
+ (let ((hmenu (gfi:handle it)))
+ (if (gfi:null-handle-p hmenu)
+ (error 'gfs:toolkit-error :detail "null owner menu handle"))
+ (is-menuitem-checked hmenu (item-id it))))
+
(defmethod gfi:dispose ((it menu-item))
(setf (dispatcher it) nil)
(remove-menuitem (thread-context) it)
@@ -254,6 +313,12 @@
(error 'gfs:toolkit-error :detail "null owner menu handle"))
(set-menuitem-text hmenu (item-id it) str)))
+(defmethod uncheck ((it menu-item))
+ (let ((hmenu (gfi:handle it)))
+ (if (gfi:null-handle-p hmenu)
+ (error 'gfs:toolkit-error :detail "null owner menu handle"))
+ (check-menuitem hmenu (item-id it) nil)))
+
;;;
;;; menu language compiler
;;;
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Feb 20 21:58:21 2006
@@ -60,8 +60,14 @@
(defgeneric caret-position (object)
(:documentation "Returns a point describing the line number and character position of the caret."))
+(defgeneric check (object)
+ (:documentation "Sets the object into the checked state."))
+
+(defgeneric check-all (object)
+ (:documentation "Sets all items in this object to the checked state."))
+
(defgeneric checked-p (object)
- (:documentation "Returns T if the item is checked; nil otherwise."))
+ (:documentation "Returns T if the object is in the checked state; nil otherwise."))
(defgeneric clear-item (object index)
(:documentation "Clears the item at the zero-based index."))
@@ -117,8 +123,8 @@
(defgeneric deiconified-p (object)
(:documentation "Returns T if the object is in its normal, not iconified state."))
-(defgeneric deselect (object index)
- (:documentation "Deselects the item at the given zero-based index in the object."))
+(defgeneric deselect (object)
+ (:documentation "Sets the object into the unselected state."))
(defgeneric deselect-all (object)
(:documentation "Deselects all items in the object."))
@@ -201,9 +207,6 @@
(defgeneric image (object)
(:documentation "Returns the object's image object if it has one, or nil otherwise."))
-(defgeneric item-append (object other)
- (:documentation "Adds the item to the object."))
-
(defgeneric item-at (object index)
(:documentation "Return the item at the given zero-based index from the object."))
@@ -213,10 +216,10 @@
(defgeneric item-height (object)
(:documentation "Return the height of the area if one of the object's items were displayed."))
-(defgeneric item-index (object other)
+(defgeneric item-index (object item)
(:documentation "Return the zero-based index of the location of the other object in this object."))
-(defgeneric item-owner (object)
+(defgeneric item-owner (item)
(:documentation "Return the widget containing this item."))
(defgeneric layout (object)
@@ -315,10 +318,13 @@
(defgeneric scroll (object dest-pnt src-rect children-too)
(:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
+(defgeneric select (object)
+ (:documentation "Set this object into the selected state."))
+
(defgeneric select-all (object)
(:documentation "Set all items of this object to the selected state."))
-(defgeneric selected (object)
+(defgeneric selected-p (object)
(:documentation "Returns T if the object is in the selected state; nil otherwise."))
(defgeneric selection-count (object)
@@ -384,6 +390,12 @@
(defgeneric unlock (object)
(:documentation "Allows this object's contents to be modified."))
+(defgeneric uncheck (object)
+ (:documentation "Sets the object into the unchecked state."))
+
+(defgeneric uncheck-all (object)
+ (:documentation "Sets all items in this object to the unchecked state."))
+
(defgeneric update (object)
(:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))
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 20 21:58:21 2006
@@ -33,6 +33,19 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defmethod append-item :before ((w widget-with-items) (it item))
+ (declare (ignore it))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod append-item ((w widget-with-items) (it item))
+ (vector-push-extend it (items w)))
+
+(defmethod clear-item :before ((w widget-with-items) index)
+ (declare (ignore index))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod clear-item ((w widget-with-items) index)
(let ((it (item-at w index)))
(delete it (items w) :test #'items-equal-p)
@@ -40,24 +53,45 @@
(error 'gfi:disposed-error))
(gfi:dispose it)))
+(defmethod clear-span :before ((w widget-with-items) (sp gfi:span))
+ (declare (ignore sp))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(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 0)))
-(defmethod item-append ((w widget-with-items) (i item))
- (vector-push-extend i (items w)))
+(defmethod item-at :before ((w widget-with-items) index)
+ (declare (ignore index))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
(defmethod item-at ((w widget-with-items) index)
(elt (items w) index))
-(defmethod (setf item-at) (index (i item) (w widget-with-items))
+(defmethod (setf item-at) :before (index (it item) (w widget-with-items))
+ (declare (ignorable index it))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod (setf item-at) (index (it item) (w widget-with-items))
(error 'gfs:toolkit-error :detail "not yet implemented"))
+(defmethod item-count :before ((w widget-with-items))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod item-count ((w widget-with-items))
(length (items w)))
-(defmethod item-index ((w widget-with-items) (i item))
- (let ((pos (position i (items w) :test #'items-equal-p)))
+(defmethod item-index :before ((w widget-with-items) (it item))
+ (declare (ignore it))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod item-index ((w widget-with-items) (it item))
+ (let ((pos (position it (items w) :test #'items-equal-p)))
(if (null pos)
(return-from item-index 0))
0))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 20 21:58:21 2006
@@ -41,6 +41,11 @@
;;; widget methods
;;;
+(defmethod ancestor-p :before ((ancestor widget) (descendant widget))
+ (declare (ignore descendant))
+ (if (gfi:disposed-p ancestor)
+ (error 'gfi:disposed-error)))
+
(defmethod ancestor-p ((ancestor widget) (descendant widget))
(let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+))
(parent (get-widget (thread-context) parent-hwnd)))
@@ -50,6 +55,18 @@
(error 'gfs:toolkit-error :detail "no widget for parent handle"))
(ancestor-p ancestor parent)))
+(defmethod checked-p :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod checked-p ((w widget))
+ (declare (ignore w))
+ nil)
+
+(defmethod client-size :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod client-size ((w widget))
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
(cffi:with-foreign-slots ((gfs::cbsize
@@ -80,6 +97,10 @@
(defmethod hide ((w widget))
(gfs::show-window (gfi:handle w) gfs::+sw-hide+))
+(defmethod location :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod location ((w widget))
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
(cffi:with-foreign-slots ((gfs::cbsize
@@ -97,9 +118,12 @@
(gfs::screen-to-client (gfi:handle w) pnt-ptr)
(gfi:make-point :x gfs::x :y gfs::y))))))
-(defmethod (setf location) ((pnt gfi:point) (w widget))
+(defmethod (setf location) :before ((pnt gfi:point) (w widget))
+ (declare (ignore pnt))
(if (gfi:disposed-p w)
- (error 'gfi:disposed-error))
+ (error 'gfi:disposed-error)))
+
+(defmethod (setf location) ((pnt gfi:point) (w widget))
(if (zerop (gfs::set-window-pos (gfi:handle w)
(cffi:null-pointer)
(gfi:point-x pnt)
@@ -108,17 +132,38 @@
gfs::+swp-nosize+))
(error 'gfs:win32-error :detail "set-window-pos failed")))
+(defmethod pack :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod pack ((w widget))
(setf (size w) (preferred-size w -1 -1)))
+(defmethod redraw :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod redraw ((w widget))
(let ((hwnd (gfi:handle w)))
(unless (gfi:null-handle-p hwnd)
(gfs::invalidate-rect hwnd nil 1))))
+(defmethod selected-p :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod selected-p ((w widget))
+ (declare (ignore w))
+ nil)
+
(defmethod size ((w widget))
(client-size w))
+(defmethod (setf size) :before ((sz gfi:size) (w widget))
+ (declare (ignore sz))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod (setf size) ((sz gfi:size) (w widget))
(if (gfi:disposed-p w)
(error 'gfi:disposed-error))
@@ -137,6 +182,10 @@
(defmethod show ((w widget))
(gfs::show-window (gfi:handle w) gfs::+sw-showna+))
+(defmethod update :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
(defmethod update ((w widget))
(let ((hwnd (gfi:handle w)))
(unless (gfi:null-handle-p hwnd)
