[graphic-forms-cvs] r126 - in trunk: docs/manual src src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu May 11 20:41:48 UTC 2006
Author: junrue
Date: Thu May 11 16:41:47 2006
New Revision: 126
Modified:
trunk/docs/manual/api.texinfo
trunk/src/packages.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
refactored message loop in preparation for supporting app-defined dialogs
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu May 11 16:41:47 2006
@@ -577,9 +577,27 @@
@node event functions
@section event functions
- at strong{NOTE:} There are (and will be) additional event methods defined
-in future releases, they just aren't all documented or implemented at
-this time.
+ at anchor{default-message-filter}
+ at deffn Function default-message-filter gm-code msg-ptr
+Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and
+ at 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
+ at sc{t} is returned so that @ref{message-loop} will
+exit. @code{gm-code} is zero when @code{msg-ptr} identifies a
+ at sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is
+-1, then the system has indicated an error during message retrieval
+that should be reported, followed by an orderly
+shutdown. @xref{dialog-message-filter}.
+ at end deffn
+
+ at anchor{dialog-message-filter}
+ at deffn Function dialog-message-filter gm-code msg-ptr
+This function is similar to @ref{default-message-filter}, except that
+it is intended to be called from a nested @code{message-loop}
+invocation, usually on behalf of a modal @ref{dialog}. In this case,
+the function returns @sc{nil} as long as the dialog continues to live.
+ at end deffn
@deffn GenericFunction event-activate dispatcher widget time
Implement this to respond to an object being activated.
@@ -656,6 +674,23 @@
Implement this to respond to a tick from a specific timer.
@end deffn
+ at anchor{message-loop}
+ at deffn Function 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
+that it may be translated and dispatched. The return value of the
+ at 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
+ at sc{nil} if @code{message-loop} should continue, or not @sc{nil} if
+the loop should exit. Two pre-defined implementations of message
+filter functions are provided:
+ at itemize @bullet
+ at item @ref{default-message-filter}
+ at item @ref{dialog-message-filter}
+ at end itemize
+ at end deffn
+
@node widget functions
@section widget functions
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu May 11 16:41:47 2006
@@ -342,6 +342,7 @@
#:cursor
#:cut
#:default-item
+ #:default-message-filter
#:defmenu
#:delay-of
#:disabled-image
@@ -420,6 +421,7 @@
#:maximum-size
#:menu
#:menu-bar
+ #:message-loop
#:minimum-size
#:mouse-over-image
#:move-above
@@ -446,7 +448,6 @@
#:resizable-p
#:retrieve-span
#:right-margin-of
- #:run-default-message-loop
#:scroll
#:select
#:select-all
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 16:41:47 2006
@@ -397,6 +397,12 @@
(erase BOOL))
(defcfun
+ ("IsDialogMessageA" is-dialog-message)
+ BOOL
+ (hwnd HANDLE)
+ (msg LPTR))
+
+(defcfun
("IsWindowEnabled" is-window-enabled)
BOOL
(hwnd HANDLE))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Thu May 11 16:41:47 2006
@@ -66,7 +66,7 @@
;;; helper functions
;;;
-(defun run-default-message-loop ()
+(defun message-loop (msg-filter)
(cffi:with-foreign-object (msg-ptr 'gfs::msg)
(loop
(let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)))
@@ -78,14 +78,8 @@
gfs::pnt)
msg-ptr gfs::msg)
(setf (event-time (thread-context)) gfs::time)
- (when (zerop gm)
- (dispose-thread-context)
- (return-from run-default-message-loop gfs::wparam))
- (when (= gm -1)
- (warn 'gfs:win32-warning :detail "get-message failed")
- (return-from run-default-message-loop gfs::wparam)))
- (gfs::translate-message msg-ptr)
- (gfs::dispatch-message msg-ptr)))))
+ (when (funcall msg-filter gm msg-ptr)
+ (return-from message-loop gfs::wparam)))))))
(defmacro hi-word (lparam)
`(ash (logand #xFFFF0000 ,lparam) -16))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu May 11 16:41:47 2006
@@ -33,11 +33,24 @@
(in-package #:graphic-forms.uitoolkit.widgets)
+(defun default-message-filter (gm-code msg-ptr)
+ (cond
+ ((zerop gm-code)
+ (dispose-thread-context)
+ t)
+ ((= gm-code -1)
+ (warn 'gfs:win32-warning :detail "get-message failed")
+ t)
+ (t
+ (gfs::translate-message msg-ptr)
+ (gfs::dispatch-message msg-ptr)
+ nil)))
+
#+clisp (defun startup (thread-name start-fn)
(declare (ignore thread-name))
(gfg::initialize-magick (cffi:null-pointer))
(funcall start-fn)
- (run-default-message-loop))
+ (message-loop #'default-message-filter))
#+lispworks (defun startup (thread-name start-fn)
(hcl:add-special-free-action 'gfs::native-object-special-action)
@@ -46,9 +59,9 @@
(mp:initialize-multiprocessing))
(mp:process-run-function thread-name
nil
- #'(lambda () (progn
- (funcall start-fn)
- (run-default-message-loop)))))
+ (lambda ()
+ (funcall start-fn)
+ (message-loop #'default-message-filter))))
(defun shutdown (exit-code)
(gfg::destroy-magick)
More information about the Graphic-forms-cvs
mailing list