[graphic-forms-cvs] r60 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Mar 21 05:06:46 UTC 2006
Author: junrue
Date: Tue Mar 21 00:06:45 2006
New Revision: 60
Added:
trunk/src/uitoolkit/widgets/timer.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/event-generics.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented timer object and event handling -- crashes on CLISP need investigation
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Tue Mar 21 00:06:45 2006
@@ -89,6 +89,7 @@
(:file "widget-generics")
(:file "event-source")
(:file "widget-utils")
+ (:file "timer")
(:file "item")
(:file "widget")
(:file "control")
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Mar 21 00:06:45 2006
@@ -206,6 +206,7 @@
#:menu
#:menu-item
#:panel
+ #:timer
#:top-level
#:widget
#:widget-with-items
@@ -314,6 +315,7 @@
#:cut
#:default-item
#:defmenu
+ #:delay-of
#:disabled-image
#:dispatcher
#:display-to-object
@@ -353,6 +355,7 @@
#:event-resize
#:event-select
#:event-show
+ #:event-timer
#:expand
#:expanded-p
#:focus-index
@@ -364,6 +367,8 @@
#:header-visible-p
#:iconify
#:iconified-p
+ #:id-of
+ #:initial-delay-of
#:horizontal-scrollbar
#:image
#:item-at
@@ -412,6 +417,7 @@
#:retrieve-span
#:right-margin-of
#:run-default-message-loop
+ #:running-p
#:scroll
#:select
#:select-all
@@ -429,8 +435,10 @@
#:shutdown
#:size
#:spacing-of
+ #:start
#:startup
#:step-increment
+ #:stop
#:style-of
#:sub-menu
#:text
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Mar 21 00:06:45 2006
@@ -37,6 +37,7 @@
(defparameter *event-tester-text* "Hello!")
(defvar *event-counter* 0)
(defvar *mouse-down-flag* nil)
+(defvar *timer* nil)
(defun exit-event-tester ()
(let ((w *event-tester-window*))
@@ -119,6 +120,14 @@
(gfs:point-y pnt)
time
(text-for-modifiers)))
+
+(defun text-for-timer (time)
+ (format nil
+ "~a timer tick id: ~d time: 0x~x ~s"
+ (incf *event-counter*)
+ (gfw:id-of *timer*)
+ time
+ (text-for-modifiers)))
(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char)
(setf *event-tester-text* (text-for-key "down" time key-code char))
@@ -184,6 +193,33 @@
(setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated"))
(gfw:redraw *event-tester-window*))
+(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time)
+ (declare (ignore disp timer))
+ (setf *event-tester-text* (text-for-timer time))
+ (gfw:redraw *event-tester-window*))
+
+(defun manage-file-menu (disp menu time)
+ (declare (ignore disp time))
+ (let ((item (gfw:item-at menu 0)))
+ (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
+
+(defun manage-timer (disp item time rect)
+ (declare (ignore disp item time rect))
+ (if *timer*
+ (progn
+ (gfw:stop *timer*)
+ (setf *timer* nil)
+ (setf *event-tester-text* "timer stopped by user"))
+ (progn
+ (setf *timer* (make-instance 'gfw:timer :delay 1000 :dispatcher (make-instance 'event-tester-echo-dispatcher)))
+ (gfw:start *timer*)
+ (setf *event-tester-text* (format nil
+ "timer ~d started init delay: ~d delay ~d"
+ (gfw:id-of *timer*)
+ (gfw:initial-delay-of *timer*)
+ (gfw:delay-of *timer*)))))
+ (gfw:redraw *event-tester-window*))
+
(defun run-event-tester-internal ()
(setf *event-tester-text* "Hello!")
(setf *event-counter* 0)
@@ -192,16 +228,15 @@
(menubar nil))
(setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events)
:style '(:style-workspace)))
- (setf menubar (gfw:defmenu ((:item "&File" :dispatcher echo-md
- :submenu ((:item "&Open..." :dispatcher echo-md)
- (:item "&Save..." :disabled :dispatcher echo-md)
+ (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu
+ :submenu ((:item "Timer" :callback #'manage-timer)
(:item "" :separator)
(:item "E&xit" :dispatcher exit-md)))
- (:item "&Options" :dispatcher echo-md
- :submenu ((:item "&Enabled" :checked :dispatcher echo-md)
- (:item "&Tools" :dispatcher echo-md
- :submenu ((:item "&Fonts" :dispatcher echo-md :disabled)
- (:item "&Colors" :dispatcher echo-md)))))
+ (:item "&Test Menu" :dispatcher echo-md
+ :submenu ((:item "&Checked Item" :checked :dispatcher echo-md)
+ (:item "&Submenu" :dispatcher echo-md
+ :submenu ((:item "&Item A" :dispatcher echo-md :disabled)
+ (:item "&Item B" :dispatcher echo-md)))))
(:item "&Help" :dispatcher echo-md
:submenu ((:item "&About" :dispatcher echo-md))))))
(setf (gfw:menu-bar *event-tester-window*) menubar)
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Tue Mar 21 00:06:45 2006
@@ -562,6 +562,9 @@
(defconstant +tpm-noanimation+ #x4000)
(defconstant +tpm-layoutrtl+ #x8000)
+(defconstant +user-timer-maximum+ #x7FFFFFFF)
+(defconstant +user-timer-minimum+ #x0000000A)
+
(defconstant +wm-create+ #x0001)
(defconstant +wm-destroy+ #x0002)
(defconstant +wm-move+ #x0003)
@@ -595,6 +598,10 @@
(defconstant +wm-sysdeadchar+ #x0107)
(defconstant +wm-keylast+ #x0109) ; for use with peek-message
(defconstant +wm-command+ #x0111)
+(defconstant +wm-syscommand+ #x0112)
+(defconstant +wm-timer+ #x0113)
+(defconstant +wm-hscroll+ #x0114)
+(defconstant +wm-vscroll+ #x0115)
(defconstant +wm-initmenu+ #x0116)
(defconstant +wm-initmenupopup+ #x0117)
(defconstant +wm-menuselect+ #x011F)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 21 00:06:45 2006
@@ -166,10 +166,11 @@
#+lispworks
(fli:define-foreign-function
- (enum-child-windows "EnumChildWindows" :result-type :int)
+ (enum-child-windows "EnumChildWindows")
((hwnd :pointer)
(func :pointer)
- (lparam :long)))
+ (lparam :long))
+ :result-type :int)
#+clisp
(ffi:def-call-out enum-child-windows
@@ -326,6 +327,12 @@
(hwnd HANDLE))
(defcfun
+ ("KillTimer" kill-timer)
+ BOOL
+ (hwnd HANDLE)
+ (id UINT))
+
+(defcfun
("LoadImageA" load-image)
HANDLE
(instance HANDLE)
@@ -415,6 +422,47 @@
(by-pos BOOL)
(item-info LPTR))
+;;; FIXME: uncomment this when CFFI callbacks can
+;;; be tagged as stdcall or cdecl (only the latter
+;;; is supported as of 0.9.0)
+;;;
+#|
+(defcfun
+ ("SetTimer" set-timer)
+ UINT
+ (hwnd HANDLE)
+ (id UINT)
+ (elapse UINT)
+ (callback :pointer)) ;; TIMERPROC
+|#
+
+#+lispworks
+(fli:define-foreign-function
+ (set-timer "SetTimer")
+ ((hwnd :pointer)
+ (id :unsigned-int)
+ (elapse :unsigned-int)
+ (func :pointer))
+ :result-type :unsigned-int)
+
+#+clisp
+(ffi:def-call-out set-timer
+ (:name "SetTimer")
+ (:library "user32.dll")
+ (:language :stdc)
+ (:arguments (hwnd ffi:c-pointer)
+ (id ffi:uint)
+ (elapse ffi:uint)
+ (func (ffi:c-function
+ (:arguments
+ (hwnd ffi:c-pointer)
+ (msg ffi:uint)
+ (id ffi:uint)
+ (time ffi:long))
+ (:return-type nil)
+ (:language :stdc-stdcall))))
+ (:return-type ffi:uint))
+
;;; SetWindowLong is deprecated in favor of SetWindowLongPtr
;;; which can be used to write code compatible to both Win32
;;; and Win64. But on Win32, SetWindowLongPtr is actually
Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp Tue Mar 21 00:06:45 2006
@@ -187,3 +187,8 @@
(:documentation "Implement this to respond to an object being shown.")
(:method (dispatcher widget time)
(declare (ignorable dispatcher widget time))))
+
+(defgeneric event-timer (dispatcher timer time)
+ (:documentation "Implement this to respond to a tick from a specific timer.")
+ (:method (dispatcher timer time)
+ (declare (ignorable dispatcher timer time))))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Tue Mar 21 00:06:45 2006
@@ -42,6 +42,10 @@
;;; window procedures
;;;
+;;; NOTE: these defcallback's work even without stdcall support in
+;;; CFFI because Windows looks for wndprocs that are not stdcall
+;;; and takes care of stack fixup
+
(cffi:defcallback uit_widgets_wndproc
gfs::UINT
((hwnd gfs::HANDLE)
@@ -128,7 +132,7 @@
(gfs::def-window-proc hwnd msg wparam lparam))
(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
(if w
@@ -166,7 +170,7 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam)
- (declare (ignorable hwnd lparam))
+ (declare (ignore hwnd lparam))
(let* ((tc (thread-context))
(menu (get-widget tc (cffi:make-pointer wparam))))
(unless (null menu)
@@ -176,7 +180,7 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
- (declare (ignorable hwnd lparam)) ; FIXME: handle system menus
+ (declare (ignore hwnd lparam)) ; FIXME: handle system menus
(let* ((tc (thread-context))
(item (get-menuitem tc (lo-word wparam))))
(unless (null item)
@@ -186,12 +190,12 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(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))
+ (declare (ignore wparam lparam))
(remove-widget (thread-context) hwnd)
0)
@@ -262,7 +266,7 @@
(process-mouse-message #'event-mouse-move hwnd lparam btn-sym)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
(when w
@@ -271,7 +275,7 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
(if (and w (event-pre-move (dispatcher w) w (event-time tc)))
@@ -279,7 +283,7 @@
0)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd))
(gc (make-instance 'gfg:graphics-context)))
@@ -329,13 +333,25 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd)))
(if (and w (event-pre-resize (dispatcher w) w (event-time tc)))
1
0)))
+(defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam)
+ (declare (ignore hwnd lparam))
+ (let* ((tc (thread-context))
+ (timer (get-timer tc wparam)))
+ (if (null timer)
+ (gfs::kill-timer (cffi:null-pointer) wparam)
+ (progn
+ (event-timer (dispatcher timer) timer (event-time tc))
+ (when (<= (delay-of timer) 0)
+ (stop timer)))))
+ 0)
+
;;;
;;; process-subclass-message methods
;;;
@@ -347,7 +363,7 @@
(gfs::def-window-proc hwnd msg wparam lparam))))
(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
- (declare (ignorable wparam lparam))
+ (declare (ignore wparam lparam))
(remove-widget (thread-context) hwnd)
(call-next-method))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Mar 21 00:06:45 2006
@@ -46,6 +46,7 @@
(next-menuitem-id :initform 10000 :reader next-menuitem-id)
(size-event-size :initform (gfs:make-size) :accessor size-event-size)
(widgets-by-hwnd :initform (make-hash-table :test #'equal))
+ (timers-by-id :initform (make-hash-table :test #'equal))
(wip :initform nil))
(:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
@@ -139,3 +140,20 @@
(let ((id (next-menuitem-id tc)))
(incf (slot-value tc 'next-menuitem-id))
id))
+
+(defmethod get-timer ((tc thread-context) id)
+ "Returns the timer identified by the specified (system-defined) id."
+ (gethash id (slot-value tc 'timers-by-id)))
+
+(defmethod put-timer ((tc thread-context) (timer timer))
+ "Stores a timer using its id as the key."
+ (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer))
+
+(defmethod remove-timer ((tc thread-context) (timer timer))
+ "Removes the timer using its id as the key."
+ (maphash
+ #'(lambda (k v)
+ (declare (ignore v))
+ (if (eql k (id-of timer))
+ (remhash k (slot-value tc 'timers-by-id))))
+ (slot-value tc 'timers-by-id)))
Added: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/timer.lisp Tue Mar 21 00:06:45 2006
@@ -0,0 +1,122 @@
+;;;;
+;;;; timer.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)
+
+#+lispworks
+(fli:define-foreign-callable
+ ("timer_proc" :result-type :void :calling-convention :stdcall)
+ ((hwnd :pointer)
+ (msg :unsigned-int)
+ (id :unsigned-int)
+ (time :long))
+ (process-message hwnd gfs::+wm-timer+ id time))
+
+#+lispworks
+(defun gf-set-timer (delay)
+ (gfs::set-timer (cffi:null-pointer)
+ 0 delay
+ (fli:make-pointer :symbol-name "timer_proc")))
+
+#+clisp
+(defun timer_proc (hwnd msg id time)
+ (declare (ignore msg))
+ (process-message hwnd gfs::+wm-timer+ id time)
+ nil)
+
+#+clisp
+(defun gf-set-timer (delay)
+ (gfs::set-timer nil 0 delay #'timer_proc))
+
+(defun clamp-delay-values (init-delay delay)
+ "Adjust delay settings based on system-defined limits."
+ ;;
+ ;; SetTimer is going to impose them anyway, so might as
+ ;; well make the slot values agree with reality.
+ ;; On original WinXP (pre-SP1) and earlier, delay values less
+ ;; than USER_TIMER_MINIMUM get set to 1ms, which MS rectified
+ ;; in later releases.
+ ;;
+ (when (and (> init-delay 0) (< init-delay gfs::+user-timer-minimum+))
+ (setf init-delay gfs::+user-timer-minimum+))
+ (when (> init-delay gfs::+user-timer-maximum+)
+ (setf init-delay gfs::+user-timer-maximum+))
+ (when (and (> delay 0) (< delay gfs::+user-timer-minimum+))
+ (setf delay gfs::+user-timer-minimum+))
+ (when (> delay gfs::+user-timer-maximum+)
+ (setf delay gfs::+user-timer-maximum+))
+ (values init-delay delay))
+
+(defmethod (setf delay-of) :around (value (self timer))
+ (multiple-value-bind (init-delay delay)
+ (clamp-delay-values 0 value)
+ (declare (ignore init-delay))
+ (if (/= delay (slot-value self 'delay))
+ (setf (slot-value self 'delay) delay)
+ (let ((tc (thread-context))
+ (new-id (gf-set-timer delay)))
+ (unless (or (not (running-p self)) (= new-id (id-of self)))
+ (remove-timer tc self)
+ (put-timer tc self))
+ (setf (slot-value self 'id-of) new-id)))))
+
+(defmethod initialize-instance :after ((self timer) &key)
+ (if (null (delay-of self))
+ (error 'gfs:toolkit-error :detail ":delay value required"))
+ (if (null (initial-delay-of self))
+ (setf (slot-value self 'initial-delay) (delay-of self)))
+ (multiple-value-bind (init-delay delay)
+ (clamp-delay-values (initial-delay-of self) (delay-of self))
+ (setf (slot-value self 'initial-delay) init-delay)
+ (setf (slot-value self 'delay) delay)))
+
+(defmethod start ((self timer))
+ ;; use init-delay as the elapse interval for the very first
+ ;; tick; the interval will be adjusted (or the timer killed)
+ ;; as part of processing the first event
+ ;;
+ (let ((init-delay (initial-delay-of self))
+ (delay (delay-of self)))
+ (if (> init-delay 0)
+ (setf delay init-delay))
+ (let ((id (gf-set-timer delay)))
+ (if (zerop id)
+ (error 'gfs:win32-error :detail "set-timer failed"))
+ (setf (slot-value self 'id) id)
+ (put-timer (thread-context) self))))
+
+(defmethod stop ((self timer))
+ (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick
+
+(defmethod running-p ((self timer))
+ (get-timer (thread-context) (id-of self)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Mar 21 00:06:45 2006
@@ -93,3 +93,17 @@
(defclass top-level (window) ()
(:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars."))
+
+(defclass timer (event-source)
+ ((id
+ :reader id-of
+ :initform 0)
+ (initial-delay
+ :reader initial-delay-of
+ :initarg :initial-delay
+ :initform 1000)
+ (delay
+ :accessor delay-of
+ :initarg :delay
+ :initform 1000))
+ (:documentation "A timer is a non-windowed object that generates events at a regular (adjustable) frequency."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Mar 21 00:06:45 2006
@@ -282,6 +282,9 @@
(defgeneric retrieve-span (object)
(:documentation "Returns the span object indicating the range of values that are valid for the object."))
+(defgeneric running-p (object)
+ (:documentation "Returns T if the object is in event generation mode; nil otherwise."))
+
(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."))
@@ -327,9 +330,15 @@
(defgeneric size (object)
(:documentation "Returns a size object describing the size of the object in its parent's coordinate system."))
+(defgeneric start (object)
+ (:documentation "Enable event generation at regular intervals."))
+
(defgeneric step-increment (object)
(:documentation "Return an integer representing the configured step size for the object."))
+(defgeneric stop (object)
+ (:documentation "Stop producing events."))
+
(defgeneric text (object)
(:documentation "Returns the object's text."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 21 00:06:45 2006
@@ -98,7 +98,7 @@
(defmethod gfs:dispose ((w widget))
(unless (null (dispatcher w))
- (event-dispose (dispatcher w) w 0))
+ (event-dispose (dispatcher w) w (event-time (thread-context))))
(let ((hwnd (gfs:handle w)))
(if (not (gfs:null-handle-p hwnd))
(if (zerop (gfs::destroy-window hwnd))
More information about the Graphic-forms-cvs
mailing list