[graphic-forms-cvs] r186 - in trunk: docs/manual src src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets

Author: junrue Date: Sun Jul 9 02:35:37 2006 New Revision: 186

Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored event-*** functions by removing time argument - call OBTAIN-EVENT-TIME instead now; added type argument to event-activate; significantly enhanced documentation of event functions

Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 02:35:37 2006 @@ -834,112 +834,297 @@ @node event functions @section event functions

+This chapter documents two types of functions: +@itemize @bullet +@item generic functions implemented in order to handle system events +@item functions provided to help implement application message pumps +@end itemize + @anchor{default-message-filter} -@deffn Function default-message-filter gm-code msg-ptr +@defun default-message-filter gm-code msg-ptr Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and @ref{control}s. Accelerator keys are also translated by this function. Returns @sc{nil} so that @ref{message-loop} will continue, -unless @code{gm-code} is less than or equal to zero, in which case +unless @var{gm-code} is less than or equal to zero, in which case @sc{t} is returned so that @ref{message-loop} will exit. When -@code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT} -message indicating normal shutdown. If @code{gm-code} is -1, then the -system has reported an error during message retrieval which should be -handled by (hopefully) graceful shutdown. -@end deffn +@var{gm-code} is zero, @var{msg-ptr} identifies a @sc{WM_QUIT} +message indicating normal shutdown. If @var{gm-code} is -1, then the +system has reported an error during message retrieval; in this +situation, the application should attempt a graceful shutdown. +@table @var +@item gm-code +The code returned by the @code{GetMessage} Win32 @sc{api} call. +@item msg-ptr +A pointer to a Win32 @sc{api} @code{MSG} data structure, filled in +by @code{GetMessage} and containing raw event data to be +translated and dispatched. +@end table +@end defun

-@deffn GenericFunction event-activate dispatcher widget time -Implement this to respond to an object being activated. +@deffn GenericFunction event-activate dispatcher widget type +Implement this method to respond to @var{widget} being activated. For +a @ref{top-level} @ref{window} or @ref{dialog}, this means that +@var{widget} was brought to the foreground and its trim (titlebar and +border) was highlighted to indicate that it is now the active +window. For a @ref{menu}, it means that the user has clicked on the +@ref{item} invoking @ref{widget} and it is about to be shown; this is +an opportunity to update the menu's contents. +@table @var +@event-dispatcher-arg +@item widget +The menu, dialog, or window that has been activated. +@item type +Provides a hint as to how activation occurred, via one of the following +keywords: +@table @code +@item :click +Indicates that @var{widget} was activated as the result of a mouse click. +@item :programmatic +Indicates that @var{widget} was activated as the result of the keyboard +interface to select a window, or programmatically via a call to +@sc{activate}. +@end table +@end table @end deffn

-@deffn GenericFunction event-arm dispatcher item time -Implement this to respond to an object about to be selected. +@deffn GenericFunction event-arm dispatcher item +Implement this method to respond to the prior notice of @var{item} +being selected. Of course, an arm event is not necessarily always +followed by a selection, such as if the user moves the mouse across +items on a @ref{menu}. +@table @var +@event-dispatcher-arg +@item item +The @ref{item} about to be selected. +@end table @end deffn

-@deffn GenericFunction event-close dispatcher widget time -Implement this to respond to an object being closed. +@deffn GenericFunction event-close dispatcher widget +Implement this method to respond to @var{widget} being closed by the user. +Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close +events. +@table @var +@event-dispatcher-arg +@item widget +The dialog or window being closed. +@end table @end deffn

-@deffn GenericFunction event-dispose dispatcher widget time -Implement this to respond to an object being disposed (via -@ref{dispose}, not the garbage collector). +@deffn GenericFunction event-dispose dispatcher widget +Implement this method to respond to @var{widget} being disposed (explicitly +via @ref{dispose}, not collected via the garbage collector). This +event function is called while the contents of @var{widget} are still +valid. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} being disposed. +@end table @end deffn

@anchor{event-focus-gain} -@deffn GenericFunction event-focus-gain dispatcher widget time -Implement this to respond to an object gaining keyboard focus. +@deffn GenericFunction event-focus-gain dispatcher widget +Implement this method to respond to @var{widget} gaining keyboard focus. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} gaining keyboard focus. +@end table @end deffn

@anchor{event-focus-loss} -@deffn GenericFunction event-focus-loss dispatcher widget time -Implement this to respond to an object losing keyboard focus. +@deffn GenericFunction event-focus-loss dispatcher widget +Implement this method to respond to @var{widget} losing keyboard focus. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} losing keyboard focus. +@end table @end deffn

-@deffn GenericFunction event-key-down dispatcher widget time keycode char -Implement this to respond to a key down event. +@deffn GenericFunction event-key-down dispatcher widget keycode char +Implement this method to respond to a key being pressed within +@var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} in which the key was pressed. +@item keycode +The virtual key code of the key that was pressed. +@item char +The character value resulting from translation of the virtual key code, +or @sc{nil} if the key code cannot be translated. +@end table @end deffn

-@deffn GenericFunction event-key-up dispatcher widget time keycode char -Implement this to respond to a key up event. +@deffn GenericFunction event-key-up dispatcher widget keycode char +Implement this method to respond to a key being released within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} in which the key was released. +@item keycode +The virtual key code of the key that was released. +@item char +The character value resulting from translation of the virtual key code, +or @sc{nil} if the key code cannot be translated. +@end table @end deffn

@anchor{event-modify} -@deffn GenericFunction event-modify dispatcher widget time -Implement this to respond to changes within a @ref{widget}, for example -when the user types text inside an @ref{edit} control. +@deffn GenericFunction event-modify dispatcher widget +Implement this method to respond to changes due to user input within +@ref{widget}, for example when the user types text inside an +@ref{edit} @ref{control}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} that was modified by the user. +@end table @end deffn

-@deffn GenericFunction event-mouse-double dispatcher widget time point button -Implement this to respond to a mouse double-click. +@deffn GenericFunction event-mouse-double dispatcher widget point button +Implement this method to respond to a mouse button double-click within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was double-clicked. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn

-@deffn GenericFunction event-mouse-down dispatcher widget time point button -Implement this to respond to a mouse down event. +@deffn GenericFunction event-mouse-down dispatcher widget point button +Implement this method to respond to a mouse button click within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was clicked. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn

-@deffn GenericFunction event-mouse-move dispatcher widget time point button -Implement this to respond to a mouse move event. +@deffn GenericFunction event-mouse-move dispatcher widget point button +Implement this method to respond to a mouse move event within @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse was moved. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn

-@deffn GenericFunction event-mouse-up dispatcher widget time point button -Implement this to respond to a mouse up event. +@deffn GenericFunction event-mouse-up dispatcher widget point button +Implement this method to respond to a mouse button being released within +@var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} inside of which the mouse button was released. +@event-mouse-point-arg +@event-mouse-button-arg +@end table @end deffn

-@deffn GenericFunction event-move dispatcher widget time point -Implement this to respond to an object being moved within its parent's -coordinate system. +@deffn GenericFunction event-move dispatcher widget point +Implement this method to respond to @var{widget} being moved within its +@ref{parent}'s coordinate system. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} being moved. +@item point +The destination @ref{point} to which @var{widget} was moved. +@end table @end deffn

@anchor{event-paint} -@deffn GenericFunction event-paint dispatcher widget time gc rect -Implement this to respond to paint requests. +@deffn GenericFunction event-paint dispatcher widget gc rect +Implement this method to respond to system requests to repaint @var{widget}. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} whose contents need to be repainted. +@item gc +A @ref{graphics-context} initialized for use during this paint event and +which will be @ref{dispose}d after this method returns. +@item rect +The specific @ref{rectangle} within @var{widget} needing to be repainted. +@end table @end deffn

-@deffn GenericFunction event-resize dispatcher widget time size type -Implement this to respond to an object being resized. +@deffn GenericFunction event-resize dispatcher widget size type +Implement this method to respond to @var{widget} being resized. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} whose dimensions are being changed. +@item size +A @ref{size} object describing @var{widget}'s new dimensions. +@item type +Identifies three different kinds of resizing actions: +@table @code +@item :maximized +Indicates that @var{widget} was expanded to its maximum size, such as +when the user clicks on the maximize button in a @ref{window} frame. +@item :minimized +Indicates that @var{widget} was minimized to the taskbar. +@item :restored +Indicates that @var{widget} was either restored from a minimized +state, or that resizing occurred while @var{widget} was already +in a visible, non-maximized state. +@end table +@end table @end deffn

@anchor{event-select} -@deffn GenericFunction event-select dispatcher item time rect -Implement this to respond to an object (or item within) being selected. +@deffn GenericFunction event-select dispatcher widget rect +Implement this method to handle notification that @var{widget} (or some +@ref{item} within @var{widget}) has been clicked on by the user in order +to invoke some action. +@table @var +@event-dispatcher-arg +@item widget +The @ref{widget} (or item) that was selected. +@item rect +The @ref{rectangle} bounding @var{widget}. +@end table @end deffn

@anchor{event-timer} -@deffn GenericFunction event-timer dispatcher timer time -Implement this to respond to a tick from a specific timer. +@deffn GenericFunction event-timer dispatcher timer +Implement this method to respond to expiration of the current +delay configured for @var{timer}. +@table @var +@event-dispatcher-arg +@item timer +The @ref{timer} that generated this event. +@end table @end deffn

@anchor{message-loop} -@deffn Function message-loop msg-filter +@defun message-loop msg-filter This function retrieves messages from the system with the intent of -passing each one to the function specified by @code{msg-filter} so +passing each one to the function specified by @var{msg-filter} so that it may be translated and dispatched. The return value of the -@code{msg-filter} function determines whether @code{message-loop} -continues or returns, and this termination condition depends on the -context of the message loop being executed. The return value is -@sc{nil} if @code{message-loop} should continue, or not @sc{nil} if -the loop should exit. The pre-defined implementation -@ref{default-message-filter} is provided. -@end deffn +@var{msg-filter} function determines whether @code{message-loop} +continues or returns. The return value must be @sc{nil} if +@code{message-loop} should continue, or not @sc{nil} if the +loop should exit. +@table @var +@item msg-filter +A @sc{function} object; see @ref{default-message-filter} for more +details. +@end table +@end defun + +@anchor{obtain-event-time} +@defun obtain-event-time => milliseconds +Returns the timestamp for the event currently being processed, or +zero if called prior to the delivery of any events. +@end defun

@node widget functions

Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun Jul 9 02:35:37 2006 @@ -75,6 +75,31 @@ @end quotation @end macro

+@macro event-dispatcher-arg +@item dispatcher +The @ref{event-dispatcher} to process this event. +@end macro + +@macro event-mouse-button-arg +@item button +A keyword identifying which mouse button was used: +@table @code +@item :left-button +@item :middle-button +@item :right-button +@end table +@end macro + +@macro event-mouse-point-arg +@item point +The @ref{point} location of the mouse cursor. +@end macro + +@macro event-time-arg +@item time +This event's timestamp in milliseconds. +@end macro + @c Info "requires" that x-refs end in a period or comma, or ) in the @c case of @pxref. So the following implements that requirement for @c the "See also" subheadings that permeate this manual, but only in

Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jul 9 02:35:37 2006 @@ -40,19 +40,19 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*")))

-(defun manage-textedit-file-menu (disp menu time) - (declare (ignore disp time)) +(defun manage-textedit-file-menu (disp menu type) + (declare (ignore disp type)) (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))

-(defun textedit-file-new (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-new (disp item rect) + (declare (ignore disp item rect)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) (setf (file-path *textedit-model*) nil)))

-(defun textedit-file-open (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-open (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*textedit-win* '(:open :add-to-recent :path-must-exist) paths @@ -61,14 +61,14 @@ (load-textedit-doc (first paths)) (setf (file-path *textedit-model*) (namestring (first paths))))))

-(defun textedit-file-save (disp item time rect) +(defun textedit-file-save (disp item rect) (if (file-path *textedit-model*) (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) - (textedit-file-save-as disp item time rect)) + (textedit-file-save-as disp item rect)) (setf (gfw:text-modified-p *textedit-control*) nil))

-(defun textedit-file-save-as (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-save-as (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*textedit-win* '(:save :add-to-recent) paths @@ -79,15 +79,15 @@ (setf (file-path *textedit-model*) (namestring (first paths))) (setf (gfw:text-modified-p *textedit-control*) nil))))

-(defun textedit-file-quit (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-file-quit (disp item rect) + (declare (ignore disp item rect)) (setf *textedit-control* nil) (gfs:dispose *textedit-win*) (setf *textedit-win* nil) (gfw:shutdown 0))

-(defun textedit-font (disp item time rect) - (declare (ignore disp item time rect)) +(defun textedit-font (disp item rect) + (declare (ignore disp item rect)) (gfw:with-graphics-context (gc *textedit-control*) (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) (if font @@ -95,24 +95,23 @@

(defclass textedit-win-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((disp textedit-win-events) window time) - (declare (ignore window time)) - (textedit-file-quit disp nil nil nil)) +(defmethod gfw:event-close ((disp textedit-win-events) window) + (declare (ignore window)) + (textedit-file-quit disp nil nil))

-(defmethod gfw:event-focus-gain ((self textedit-win-events) window time) - (declare (ignore window time)) +(defmethod gfw:event-focus-gain ((self textedit-win-events) window) + (declare (ignore window)) (if *textedit-control* (gfw:give-focus *textedit-control*)))

(defclass textedit-about-dialog-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) +(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg))

-(defun about-textedit (disp item time rect) - (declare (ignore disp item time rect)) +(defun about-textedit (disp item rect) + (declare (ignore disp item rect)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) @@ -153,8 +152,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close"

Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Sun Jul 9 02:35:37 2006 @@ -60,6 +60,6 @@ (defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size) (setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size)))

-(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect) - (declare (ignore window time rect)) +(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window gc rect) + (declare (ignore window rect)) (gfg:draw-image gc (image-buffer-of self) (gfs:make-point)))

Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jul 9 02:35:37 2006 @@ -94,8 +94,7 @@ (setf (gethash kind table) image) (incf kind)))))

-(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button) - (declare (ignore time)) +(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button) (let* ((tiles (game-tiles)) (tile-pnt (window->tiles point)) (tile-kind (obtain-tile tiles tile-pnt)) @@ -114,8 +113,7 @@ (setf (shape-pnts-of self) (shape-tile-points tmp-table)) (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+))))

-(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) - (declare (ignore time)) +(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button) (gfw:release-mouse) (let ((tile-pnt (window->tiles point)) (shape-pnts (shape-pnts-of self)))

Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 9 02:35:37 2006 @@ -52,14 +52,14 @@ (defun get-scoreboard-panel () *scoreboard-panel*)

-(defun new-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun new-unblocked (disp item rect) + (declare (ignore disp item rect)) (new-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*))

-(defun restart-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun restart-unblocked (disp item rect) + (declare (ignore disp item rect)) (restart-game) (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) @@ -69,8 +69,8 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+))))

-(defun reveal-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun reveal-unblocked (disp item rect) + (declare (ignore disp item rect)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) (when shape (let ((shape-pnts (shape-tile-points shape)) @@ -80,8 +80,8 @@ (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) (gfw:enable timer t)))))

-(defun quit-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun quit-unblocked (disp item rect) + (declare (ignore disp item rect)) (setf *scoreboard-panel* nil) (setf *tiles-panel* nil) (gfs:dispose *unblocked-win*) @@ -90,23 +90,22 @@

(defclass unblocked-win-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((disp unblocked-win-events) window time) - (declare (ignore window time)) - (quit-unblocked disp nil nil nil)) +(defmethod gfw:event-close ((disp unblocked-win-events) window) + (declare (ignore window)) + (quit-unblocked disp nil nil))

-(defmethod gfw:event-timer ((disp unblocked-win-events) timer time) - (declare (ignore timer time)) +(defmethod gfw:event-timer ((disp unblocked-win-events) timer) + (declare (ignore timer)) (update-panel *tiles-panel*))

(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) +(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg))

-(defun about-unblocked (disp item time rect) - (declare (ignore disp item time rect)) +(defun about-unblocked (disp item rect) + (declare (ignore disp item rect)) (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) @@ -147,8 +146,8 @@ :spacing 0 :style '(:vertical :normalize)))) (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Close" @@ -204,7 +203,7 @@ (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size))

- (new-unblocked nil nil nil nil) + (new-unblocked nil nil nil) (gfw:show *unblocked-win* t)))

(defun unblocked ()

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jul 9 02:35:37 2006 @@ -441,6 +441,7 @@ #:moveable-p #:object-to-display #:obtain-displays + #:obtain-event-time #:obtain-primary-display #:owner #:pack

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Jul 9 02:35:37 2006 @@ -42,16 +42,16 @@ (gfw:check *last-checked-drawing-item* nil)) (gfw:check item t))

-(defun find-checked-item (disp menu time) - (declare (ignore disp time)) +(defun find-checked-item (disp menu type) + (declare (ignore disp type)) (dotimes (i (length (gfw:items menu))) (let ((item (elt (gfw:items menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return)))))

-(defun drawing-exit-fn (disp item time rect) - (declare (ignore disp item time rect)) +(defun drawing-exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *drawing-win*) (setf *drawing-win* nil) (gfw:shutdown 0)) @@ -61,12 +61,12 @@ :accessor draw-func-of :initform nil)))

-(defmethod gfw:event-close ((self drawing-win-events) window time) - (declare (ignore window time)) - (drawing-exit-fn self nil nil 0)) +(defmethod gfw:event-close ((self drawing-win-events) window) + (declare (ignore window)) + (drawing-exit-fn self nil nil))

-(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((self drawing-win-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) @@ -162,8 +162,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil)))

-(defun select-arcs (disp item time rect) - (declare (ignore disp time rect)) +(defun select-arcs (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) @@ -185,8 +185,8 @@ (setf (gfg:pen-style gc) '(:dot :square-endcap)) (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts))))

-(defun select-beziers (disp item time rect) - (declare (ignore disp time rect)) +(defun select-beziers (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) @@ -202,8 +202,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil)))

-(defun select-ellipses (disp item time rect) - (declare (ignore disp time rect)) +(defun select-ellipses (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) (gfw:redraw *drawing-win*)) @@ -240,8 +240,8 @@ #'gfg:draw-line nil)))

-(defun select-lines (disp item time rect) - (declare (ignore disp time rect)) +(defun select-lines (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) (gfw:redraw *drawing-win*)) @@ -264,8 +264,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil)))

-(defun select-rects (disp item time rect) - (declare (ignore disp time rect)) +(defun select-rects (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) @@ -314,8 +314,8 @@ (setf (gfg:foreground-color gc) gfg:*color-red*) (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent))))

-(defun select-text (disp item time rect) - (declare (ignore disp time rect)) +(defun select-text (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) (gfw:redraw *drawing-win*)) @@ -336,8 +336,8 @@ (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil)))

-(defun select-wedges (disp item time rect) - (declare (ignore disp time rect)) +(defun select-wedges (disp item rect) + (declare (ignore disp rect)) (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*))

Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Jul 9 02:35:37 2006 @@ -47,16 +47,16 @@

(defclass event-tester-window-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) - (declare (ignorable time rect)) +(defmethod gfw:event-paint ((d event-tester-window-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2)))) (gfg:draw-text gc *event-tester-text* pnt)))

-(defmethod gfw:event-close ((d event-tester-window-events) widget time) - (declare (ignore widget time)) +(defmethod gfw:event-close ((d event-tester-window-events) widget) + (declare (ignore widget)) (exit-event-tester))

(defun text-for-modifiers () @@ -72,7 +72,7 @@ (not (gfw:key-toggled-p gfw:+vk-num-lock+)) (not (gfw:key-toggled-p gfw:+vk-scroll-lock+))))

-(defun text-for-mouse (action time button pnt) +(defun text-for-mouse (action button pnt) (format nil "~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) @@ -80,131 +80,130 @@ button (gfs:point-x pnt) (gfs:point-y pnt) - time + (gfw:obtain-event-time) (text-for-modifiers)))

-(defun text-for-key (action time key-code char) +(defun text-for-key (action key-code char) (format nil "~a key action: ~s char: ~s code: 0x~x time: 0x~x ~s" (incf *event-counter*) action char key-code - time + (gfw:obtain-event-time) (text-for-modifiers)))

-(defun text-for-item (text time desc) +(defun text-for-item (text desc) (format nil "~a ~s: ~s time: 0x~x ~s" (incf *event-counter*) desc text - time + (gfw:obtain-event-time) (text-for-modifiers)))

-(defun text-for-size (type time size) +(defun text-for-size (type size) (format nil "~a resize action: ~s size: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (symbol-name type) (gfs:size-width size) (gfs:size-height size) - time + (gfw:obtain-event-time) (text-for-modifiers)))

-(defun text-for-move (time pnt) +(defun text-for-move (pnt) (format nil "~a move point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (gfs:point-x pnt) (gfs:point-y pnt) - time + (gfw:obtain-event-time) (text-for-modifiers)))

-(defun text-for-timer (time) +(defun text-for-timer () (format nil "~a timer tick id: ~d time: 0x~x ~s" (incf *event-counter*) (gfw:id-of *timer*) - time + (gfw:obtain-event-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)) +(defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char) + (setf *event-tester-text* (text-for-key "down" key-code char)) (gfw:redraw window))

-(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char) - (setf *event-tester-text* (text-for-key "up" time key-code char)) +(defmethod gfw:event-key-up ((d event-tester-window-events) window key-code char) + (setf *event-tester-text* (text-for-key "up" key-code char)) (gfw:redraw window))

-(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "double" time button pnt)) +(defmethod gfw:event-mouse-double ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "double" button pnt)) (gfw:redraw window))

-(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "down" time button pnt)) +(defmethod gfw:event-mouse-down ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "down" button pnt)) (setf *mouse-down-flag* t) (gfw:redraw window))

-(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button) +(defmethod gfw:event-mouse-move ((d event-tester-window-events) window pnt button) (when *mouse-down-flag* - (setf *event-tester-text* (text-for-mouse "move" time button pnt)) + (setf *event-tester-text* (text-for-mouse "move" button pnt)) (gfw:redraw window)))

-(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button) - (setf *event-tester-text* (text-for-mouse "up" time button pnt)) +(defmethod gfw:event-mouse-up ((d event-tester-window-events) window pnt button) + (setf *event-tester-text* (text-for-mouse "up" button pnt)) (setf *mouse-down-flag* nil) (gfw:redraw window))

-(defmethod gfw:event-move ((d event-tester-window-events) window time pnt) - (setf *event-tester-text* (text-for-move time pnt)) +(defmethod gfw:event-move ((d event-tester-window-events) window pnt) + (setf *event-tester-text* (text-for-move pnt)) (gfw:redraw window) 0)

-(defmethod gfw:event-resize ((d event-tester-window-events) window time size type) - (setf *event-tester-text* (text-for-size type time size)) +(defmethod gfw:event-resize ((d event-tester-window-events) window size type) + (setf *event-tester-text* (text-for-size type size)) (gfw:redraw window) 0)

(defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect) + (declare (ignore item rect)) (exit-event-tester))

-(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time) - (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) +(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item) + (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*))

(defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect) (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected")) + (setf *event-tester-text* (text-for-item (gfw:text item) "item selected")) (gfw:redraw *event-tester-window*))

-(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time) - (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) +(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item) + (setf *event-tester-text* (text-for-item (gfw:text item) "item armed")) (gfw:redraw *event-tester-window*))

-(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time) - (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated")) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type) + (declare (ignore type)) + (setf *event-tester-text* (text-for-item (format nil "~a" widget) "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)) +(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer) + (declare (ignore timer)) + (setf *event-tester-text* (text-for-timer)) (gfw:redraw *event-tester-window*))

-(defun manage-file-menu (disp menu time) - (declare (ignore disp time)) +(defun manage-file-menu (disp menu type) + (declare (ignore disp type)) (let ((item (elt (gfw:items 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)) +(defun manage-timer (disp item rect) + (declare (ignore disp item rect)) (if *timer* (progn (gfw:enable *timer* nil)

Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Jul 9 02:35:37 2006 @@ -37,18 +37,18 @@

(defclass hellowin-events (gfw:event-dispatcher) ())

-(defun exit-fn (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0))

-(defmethod gfw:event-close ((disp hellowin-events) window time) +(defmethod gfw:event-close ((disp hellowin-events) window) (declare (ignore window)) - (exit-fn disp nil time nil)) + (exit-fn disp nil nil))

-(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((disp hellowin-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))

Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Jul 9 02:35:37 2006 @@ -48,15 +48,15 @@ (gfs:dispose *true-image*) (setf *true-image* nil))

-(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defmethod gfw:event-close ((d image-events) window) + (declare (ignore window)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0))

-(defmethod gfw:event-paint ((d image-events) window time gc rect) - (declare (ignore window time rect)) +(defmethod gfw:event-paint ((d image-events) window gc rect) + (declare (ignore window rect)) (let ((pnt (gfs:make-point)) (pixel-pnt1 (gfs:make-point)) (pixel-pnt2 (gfs:make-point :x 0 :y 15))) @@ -86,8 +86,8 @@ (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt))))

-(defun exit-image-fn (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-image-fn (disp item rect) + (declare (ignorable disp item rect)) (dispose-images) (gfs:dispose *image-win*) (setf *image-win* nil)

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jul 9 02:35:37 2006 @@ -52,14 +52,14 @@

(defclass layout-tester-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((d layout-tester-events) widget time) - (declare (ignore widget time)) +(defmethod gfw:event-close ((d layout-tester-events) widget) + (declare (ignore widget)) (exit-layout-tester))

(defclass pack-layout-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect) + (declare (ignore item rect)) (gfw:pack *layout-tester-win*))

(defclass layout-tester-widget-events (gfw:event-dispatcher) @@ -71,8 +71,8 @@ :initarg :id :initform 0)))

-(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) @@ -139,8 +139,8 @@ :dispatcher be)))) (incf *widget-counter*)))

-(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect) + (declare (ignore rect)) (setf (gfw:text btn) (funcall (toggle-fn d))) (gfw:layout *layout-tester-win*))

@@ -154,8 +154,8 @@ :initarg :subtype :initform :push-button)))

-(defmethod gfw:event-select ((d add-child-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defmethod gfw:event-select ((d add-child-dispatcher) item rect) + (declare (ignorable item rect)) (add-layout-tester-widget (widget-class d) (subtype d)) (gfw:pack *layout-tester-win*))

@@ -169,8 +169,8 @@ :initarg :sub-disp-class :initform nil)))

-(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) - (declare (ignore time)) +(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type) + (declare (ignore type)) (gfw:clear-all menu) (gfw:mapchildren *layout-tester-win* (lambda (parent child) @@ -192,8 +192,8 @@

(defclass remove-child-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d remove-child-dispatcher) item rect) + (declare (ignore rect)) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfs:dispose victim) @@ -201,21 +201,21 @@

(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) - (declare (ignorable time rect)) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect) + (declare (ignore rect)) (let ((victim (find-victim (gfw:text item)))) (unless (null victim) (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*))))

-(defun check-flow-orient-items (disp menu time) - (declare (ignore disp time)) +(defun check-flow-orient-items (disp menu type) + (declare (ignore disp type)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))

-(defun set-flow-horizontal (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-horizontal (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) @@ -223,8 +223,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*)))

-(defun set-flow-vertical (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-vertical (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) @@ -232,8 +232,8 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*)))

-(defun set-flow-layout-normalize (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-layout-normalize (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :normalize style) @@ -241,8 +241,8 @@ (setf (gfw:style-of layout) (push :normalize style))) (gfw:layout *layout-tester-win*)))

-(defun set-flow-layout-wrap (disp item time rect) - (declare (ignorable disp item time rect)) +(defun set-flow-layout-wrap (disp item rect) + (declare (ignorable disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) @@ -250,13 +250,13 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*)))

-(defun enable-flow-spacing-items (disp menu time) - (declare (ignore disp time)) +(defun enable-flow-spacing-items (disp menu type) + (declare (ignore disp type)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) (gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))

-(defun decrease-flow-spacing (disp item time rect) - (declare (ignore disp item time rect)) +(defun decrease-flow-spacing (disp item rect) + (declare (ignore disp item rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) (spacing (gfw:spacing-of layout))) (unless (zerop spacing) @@ -264,82 +264,82 @@ (setf (gfw:spacing-of layout) spacing) (gfw:layout *layout-tester-win*))))

-(defun increase-flow-spacing (disp item time rect) - (declare (ignore disp item time rect)) +(defun increase-flow-spacing (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*)))

-(defun enable-left-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-left-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0))))

-(defun enable-top-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-top-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0))))

-(defun enable-right-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-right-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0))))

-(defun enable-bottom-flow-margin-items (disp menu time) - (declare (ignore disp time)) +(defun enable-bottom-flow-margin-items (disp menu rect) + (declare (ignore disp rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0))))

-(defun inc-left-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-left-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun inc-top-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-top-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun inc-right-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-right-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun inc-bottom-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun inc-bottom-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (incf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun dec-left-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-left-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:left-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun dec-top-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-top-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:top-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun dec-right-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-right-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:right-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun dec-bottom-flow-margin (disp item time rect) - (declare (ignore disp item time rect)) +(defun dec-bottom-flow-margin (disp item rect) + (declare (ignore disp item rect)) (let ((layout (gfw:layout-of *layout-tester-win*))) (decf (gfw:bottom-margin-of layout) +margin-delta+) (gfw:layout *layout-tester-win*)))

-(defun flow-mod-callback (disp menu time) - (declare (ignore disp time)) +(defun flow-mod-callback (disp menu type) + (declare (ignore disp type)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenu ((:item "Left" @@ -383,8 +383,8 @@ (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) (gfw:check it (find :wrap style)))))

-(defun exit-layout-callback (disp item time rect) - (declare (ignorable disp item time rect)) +(defun exit-layout-callback (disp item rect) + (declare (ignorable disp item rect)) (exit-layout-tester))

(defun run-layout-tester-internal ()

Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 9 02:35:37 2006 @@ -37,38 +37,37 @@

(defclass main-win-events (gfw:event-dispatcher) ())

-(defun windlg-exit-fn (disp item time rect) - (declare (ignore disp item time rect)) +(defun windlg-exit-fn (disp item rect) + (declare (ignore disp item rect)) (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0))

-(defmethod gfw:event-close ((self main-win-events) window time) - (declare (ignore window time)) - (windlg-exit-fn self nil nil 0)) +(defmethod gfw:event-close ((self main-win-events) window) + (declare (ignore window)) + (windlg-exit-fn self nil nil))

(defclass test-win-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-paint ((d test-win-events) window time gc rect) - (declare (ignore time rect)) +(defmethod gfw:event-paint ((d test-win-events) window gc rect) + (declare (ignore rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))

(defclass test-mini-events (test-win-events) ())

-(defmethod gfw:event-close ((d test-mini-events) window time) - (declare (ignore time)) +(defmethod gfw:event-close ((d test-mini-events) window) (gfs:dispose window))

(defclass test-borderless-events (test-win-events) ())

-(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) - (declare (ignore time point button)) +(defmethod gfw:event-mouse-down ((d test-borderless-events) window point button) + (declare (ignore point button)) (gfs:dispose window))

-(defun create-borderless-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-borderless-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:borderless)))) @@ -76,8 +75,8 @@ (gfw:center-on-owner window) (gfw:show window t)))

-(defun create-miniframe-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-miniframe-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Mini Frame" @@ -86,8 +85,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t)))

-(defun create-palette-win (disp item time rect) - (declare (ignore disp item time rect)) +(defun create-palette-win (disp item rect) + (declare (ignore disp item rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :text "Palette" @@ -96,8 +95,8 @@ (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (gfw:show window t)))

-(defun open-file-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-file-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*main-win* '(:open :add-to-recent :multiple-select) paths @@ -108,8 +107,8 @@ :text "Select Lisp-related files...") (print paths)))

-(defun save-file-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun save-file-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-file-dialog (*main-win* '(:save) paths @@ -118,8 +117,8 @@ :initial-directory #P"c:/") (print paths)))

-(defun choose-font-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun choose-font-dlg (disp item rect) + (declare (ignore disp item rect)) (gfw:with-graphics-context (gc *main-win*) (gfw:with-font-dialog (*main-win* nil font color :gc gc) (if color @@ -129,9 +128,7 @@

(defclass dialog-events (gfw:event-dispatcher) ())

-(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) - (declare (ignore time)) - (format t "dialog-events event-close called~%") +(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog)) (call-next-method) (gfs:dispose dlg))

@@ -140,16 +137,13 @@ (defun truncate-text (str) (subseq str 0 (min (length str) 5)))

-(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit)) (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl))))

-(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit)) (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl))))

-(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time) - (declare (ignore time)) +(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit)) (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl))))

(defun open-dlg (title style) @@ -204,15 +198,15 @@ :style '(:vertical :normalize)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp btn time rect)) + :callback (lambda (disp btn rect) + (declare (ignore disp btn rect)) (gfs:dispose dlg)) :style '(:cancel-button) :text "Cancel" @@ -226,12 +220,12 @@ (gfw:show dlg t) dlg))

-(defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-modal-dlg (disp item rect) + (declare (ignore disp item rect)) (open-dlg "Modal" '(:owner-modal)))

-(defun open-modeless-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defun open-modeless-dlg (disp item rect) + (declare (ignore disp item rect)) (open-dlg "Modeless" '(:modeless)))

(defun run-windlg-internal ()

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 9 02:35:37 2006 @@ -889,6 +889,10 @@ (defconstant +user-timer-maximum+ #x7FFFFFFF) (defconstant +user-timer-minimum+ #x0000000A)

+(defconstant +wa-inactive+ 0) +(defconstant +wa-active+ 1) +(defconstant +wa-clickactive+ 2) + (defconstant +wb-left+ 0) (defconstant +wb-right+ 1) (defconstant +wb-isdelimiter+ 2)

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Jul 9 02:35:37 2006 @@ -33,162 +33,157 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(defgeneric event-activate (dispatcher widget time) +(defgeneric event-activate (dispatcher widget type) (:documentation "Implement this to respond to an object being activated.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget type) + (declare (ignorable dispatcher widget type))))

-(defgeneric event-arm (dispatcher item time) +(defgeneric event-arm (dispatcher item) (:documentation "Implement this to respond to an object about to be selected.") - (:method (dispatcher item time) - (declare (ignorable dispatcher item time)))) + (:method (dispatcher item) + (declare (ignorable dispatcher item))))

-(defgeneric event-close (dispatcher widget time) +(defgeneric event-close (dispatcher widget) (:documentation "Implement this to respond to an object being closed.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-collapse (dispatcher item time rect) +(defgeneric event-collapse (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being collapsed.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect))))

-(defgeneric event-deactivate (dispatcher widget time) +(defgeneric event-deactivate (dispatcher widget type) (:documentation "Implement this to respond to an object being deactivated.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget type) + (declare (ignorable dispatcher widget type))))

-(defgeneric event-deiconify (dispatcher widget time) +(defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-dispose (dispatcher widget time) +(defgeneric event-dispose (dispatcher widget) (:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-expand (dispatcher item time rect) +(defgeneric event-expand (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being expanded.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect))))

-(defgeneric event-focus-gain (dispatcher widget time) +(defgeneric event-focus-gain (dispatcher widget) (:documentation "Implement this to respond to an object gaining keyboard focus.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-focus-loss (dispatcher widget time) +(defgeneric event-focus-loss (dispatcher widget) (:documentation "Implement this to respond to an object losing keyboard focus.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-hide (dispatcher widget time) +(defgeneric event-hide (dispatcher widget) (:documentation "Implement this to respond to an object being hidden.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-iconify (dispatcher widget time) +(defgeneric event-iconify (dispatcher widget) (:documentation "Implement this to respond to an object being iconified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-key-down (dispatcher widget time keycode char) +(defgeneric event-key-down (dispatcher widget keycode char) (:documentation "Implement this to respond to a key down event.") - (:method (dispatcher widget time keycode char) - (declare (ignorable dispatcher widget time keycode char)))) + (:method (dispatcher widget keycode char) + (declare (ignorable dispatcher widget keycode char))))

-(defgeneric event-key-traverse (dispatcher widget time keycode char type) - (:documentation "Implement this to respond to a key traversal event.") - (:method (dispatcher widget time keycode char type) - (declare (ignorable dispatcher widget time keycode char type)))) - -(defgeneric event-key-up (dispatcher widget time keycode char) +(defgeneric event-key-up (dispatcher widget keycode char) (:documentation "Implement this to respond to a key up event.") - (:method (dispatcher widget time keycode char) - (declare (ignorable dispatcher widget time keycode char)))) + (:method (dispatcher widget keycode char) + (declare (ignorable dispatcher widget keycode char))))

-(defgeneric event-modify (dispatcher widget time) +(defgeneric event-modify (dispatcher widget) (:documentation "Implement this to respond to content (e.g., text) in an object being modified.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-mouse-double (dispatcher widget time point button) +(defgeneric event-mouse-double (dispatcher widget point button) (:documentation "Implement this to respond to a mouse double-click.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-down (dispatcher widget time point button) +(defgeneric event-mouse-down (dispatcher widget point button) (:documentation "Implement this to respond to a mouse down event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-enter (dispatcher widget time point button) +(defgeneric event-mouse-enter (dispatcher widget point button) (:documentation "Implement this to respond to a mouse passing into the bounds of an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-exit (dispatcher widget time point button) +(defgeneric event-mouse-exit (dispatcher widget point button) (:documentation "Implement this to respond to a mouse leaving the bounds an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-hover (dispatcher widget time point button) +(defgeneric event-mouse-hover (dispatcher widget point button) (:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-move (dispatcher widget time point button) +(defgeneric event-mouse-move (dispatcher widget point button) (:documentation "Implement this to respond to a mouse move event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-mouse-up (dispatcher widget time point button) +(defgeneric event-mouse-up (dispatcher widget point button) (:documentation "Implement this to respond to a mouse up event.") - (:method (dispatcher widget time point button) - (declare (ignorable dispatcher widget time point button)))) + (:method (dispatcher widget point button) + (declare (ignorable dispatcher widget point button))))

-(defgeneric event-move (dispatcher widget time point) +(defgeneric event-move (dispatcher widget point) (:documentation "Implement this to respond to an object being moved within its parent's coordinate system.") - (:method (dispatcher widget time point) - (declare (ignorable dispatcher widget time point)))) + (:method (dispatcher widget point) + (declare (ignorable dispatcher widget point))))

-(defgeneric event-paint (dispatcher widget time gc rect) +(defgeneric event-paint (dispatcher widget gc rect) (:documentation "Implement this to respond to paint requests.") - (:method (dispatcher widget time gc rect) - (declare (ignorable dispatcher widget time gc rect)))) + (:method (dispatcher widget gc rect) + (declare (ignorable dispatcher widget gc rect))))

-(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content) +(defgeneric event-pre-modify (dispatcher widget keycode char span new-content) (:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.") - (:method (dispatcher widget time keycode char span new-content) - (declare (ignorable dispatcher widget time keycode char span new-content)))) + (:method (dispatcher widget keycode char span new-content) + (declare (ignorable dispatcher widget keycode char span new-content))))

-(defgeneric event-pre-move (dispatcher widget time) +(defgeneric event-pre-move (dispatcher widget) (:documentation "Implement this to preempt moving; return T if processed or nil if not.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-pre-resize (dispatcher widget time) +(defgeneric event-pre-resize (dispatcher widget) (:documentation "Implement this to preempt resizing; return T if processed or nil if not.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-resize (dispatcher widget time size type) +(defgeneric event-resize (dispatcher widget size type) (:documentation "Implement this to respond to an object being resized.") - (:method (dispatcher widget time size type) - (declare (ignorable dispatcher widget time size type)))) + (:method (dispatcher widget size type) + (declare (ignorable dispatcher widget size type))))

-(defgeneric event-select (dispatcher item time rect) +(defgeneric event-select (dispatcher item rect) (:documentation "Implement this to respond to an object (or item within) being selected.") - (:method (dispatcher item time rect) - (declare (ignorable dispatcher item time rect)))) + (:method (dispatcher item rect) + (declare (ignorable dispatcher item rect))))

-(defgeneric event-show (dispatcher widget time) +(defgeneric event-show (dispatcher widget) (:documentation "Implement this to respond to an object being shown.") - (:method (dispatcher widget time) - (declare (ignorable dispatcher widget time)))) + (:method (dispatcher widget) + (declare (ignorable dispatcher widget))))

-(defgeneric event-timer (dispatcher timer time) +(defgeneric event-timer (dispatcher timer) (:documentation "Implement this to respond to a tick from a specific timer.") - (:method (dispatcher timer time) - (declare (ignorable dispatcher timer time)))) + (:method (dispatcher timer) + (declare (ignorable dispatcher timer))))

Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 02:35:37 2006 @@ -33,9 +33,9 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) - (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:event-source integer gfs:rectangle)))) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-select . (gfw:event-source gfs:rectangle))))

(defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info)))

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Jul 9 02:35:37 2006 @@ -102,7 +102,7 @@ (when w (setf (gfs:point-x pnt) (lo-word lparam)) (setf (gfs:point-y pnt) (hi-word lparam)) - (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol))) + (funcall fn (dispatcher w) w pnt btn-symbol))) 0)

(defun get-class-wndproc (hwnd) @@ -118,17 +118,15 @@ (error 'gfs:win32-error :detail "set-window-long failed")))

(defun dispatch-notification (widget wparam-hi) - (let ((disp (dispatcher widget)) - (time (event-time (thread-context)))) + (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug - (#.gfs::+en-killfocus+ (event-focus-loss disp widget time)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) - (#.gfs::+en-update+ (event-modify disp widget time))))) + (0 (event-select disp widget (gfs:make-rectangle))) ; FIXME + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget)))))

(defun process-ctlcolor-message (wparam lparam) - (let* ((tc (thread-context)) - (widget (get-widget tc (cffi:make-pointer lparam))) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) (hdc (cffi:make-pointer wparam)) (bkgdcolor (brush-color-of widget)) (textcolor (text-color-of widget)) @@ -141,6 +139,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val))

+(defun obtain-event-time () + (event-time (thread-context))) + ;;; ;;; process-message methods ;;; @@ -153,10 +154,9 @@

(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (w (get-widget tc hwnd))) + (let ((w (get-widget (thread-context) hwnd))) (if w - (event-close (dispatcher w) w (event-time tc)) + (event-close (dispatcher w) w) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)

@@ -172,10 +172,7 @@ (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) - (event-select (dispatcher item) - item - (event-time tc) - (gfs:make-rectangle)))))) ; FIXME + (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t @@ -193,7 +190,7 @@ (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d menu (event-time tc)))))) + (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) @@ -203,7 +200,7 @@ (unless (null item) (let ((d (dispatcher item))) (unless (null d) - (event-arm d item (event-time tc)))))) + (event-arm d item))))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) @@ -223,7 +220,7 @@ (w (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) (when w - (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch))) + (event-key-down (dispatcher w) w (virtual-key tc) ch))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) @@ -234,7 +231,7 @@ (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) (when (and w (zerop ch)) - (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) + (event-key-down (dispatcher w) w wparam-lo (code-char ch)))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) @@ -244,7 +241,7 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (when w - (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) + (event-key-up (dispatcher w) w wparam-lo (code-char ch)))) (setf (virtual-key tc) 0)) 0)

@@ -289,14 +286,14 @@ (w (get-widget tc hwnd))) (when w (outer-location w (move-event-pnt tc)) - (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc)))) + (event-move (dispatcher w) w (move-event-pnt tc)))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) 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))) + (if (and w (event-pre-move (dispatcher w) w)) 1 0)))

@@ -318,7 +315,7 @@ :height gfs::rcpaint-height)) (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) (unwind-protect - (event-paint (dispatcher widget) widget (event-time tc) gc rct) + (event-paint (dispatcher widget) widget gc rct) (gfs:dispose gc) (gfs::end-paint hwnd ps-ptr)))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) @@ -357,7 +354,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (event-focus-loss (dispatcher widget) widget (event-time tc)))) + (event-focus-loss (dispatcher widget) widget))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) @@ -365,7 +362,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (event-focus-gain (dispatcher widget) widget (event-time tc)))) + (event-focus-gain (dispatcher widget) widget))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) @@ -407,15 +404,14 @@ (t nil)))) (when w (outer-size w (size-event-size tc)) - #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd) - (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type))) + (event-resize (dispatcher w) w (size-event-size tc) type))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) 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))) + (if (and w (event-pre-resize (dispatcher w) w)) 1 0)))

@@ -427,15 +423,15 @@ (gfs::kill-timer hwnd wparam) (cond ((<= (delay-of timer) 0) - (event-timer (dispatcher timer) timer (event-time tc)) + (event-timer (dispatcher timer) timer) (gfs:dispose timer)) ((/= (delay-of timer) (initial-delay-of timer)) (let ((delay (reset-timer-to-delay timer (delay-of timer)))) (setf (slot-value timer 'delay) delay) (setf (slot-value timer 'initial-delay) delay)) - (event-timer (dispatcher timer) timer (event-time tc))) + (event-timer (dispatcher timer) timer)) (t - (event-timer (dispatcher timer) timer (event-time tc)))))) + (event-timer (dispatcher timer) timer))))) 0)

;;;

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 9 02:35:37 2006 @@ -153,7 +153,7 @@

(defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) - (event-dispose (dispatcher w) w (event-time (thread-context)))) + (event-dispose (dispatcher w) w)) (let ((hwnd (gfs:handle w))) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd))

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 9 02:35:37 2006 @@ -180,8 +180,8 @@ (let ((sz (client-size win))) (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))

-(defmethod event-resize ((d event-dispatcher) (win window) time size type) - (declare (ignorable d time size type)) +(defmethod event-resize ((d event-dispatcher) (win window) size type) + (declare (ignore size type)) (unless (null (layout-of win)) (let ((sz (client-size win))) (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))