[graphic-forms-cvs] r127 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri May 12 03:20:05 UTC 2006
Author: junrue
Date: Thu May 11 23:20:03 2006
New Revision: 127
Modified:
trunk/docs/manual/api.texinfo
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/display.lisp
trunk/src/uitoolkit/widgets/file-dialog.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/panel.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
refactored compute-style-flags GF and implementations; added utility function for traversing top-level windows owned by UI thread
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu May 11 23:20:03 2006
@@ -189,10 +189,36 @@
@anchor{dialog}
@deftp Class dialog
This is the base class for system and application-defined dialogs. A
-dialog is a windowed UI component that is @emph{typically} defined to
-remain on top of the primary application window(s). Of course, some
+dialog is a windowed UI component, usually containing at least one
+ at ref{panel} or @ref{control}, that remains on top of application
+ at ref{window}(s). Dialogs typically serve to collect additional
+information from the user in a specific context. Note that some
applications are entirely dialog-based. This class derives from
- at ref{window}.
+ at ref{window}.@*@* A @emph{modal} dialog constrains the user to respond
+to it, whereas a @emph{modeless} dialog allows continued interaction
+with other windows.
+ at deffn Initarg :owner
+Specifies the @ref{owner} of the dialog.
+ at end deffn
+ at deffn Initarg :style
+ at table @code
+ at item :application-modal
+Specifies that the dialog is @emph{modal} with respect to all
+ at ref{top-level} windows and @ref{dialog}s created by the application
+(specifically those created by the calling thread which are still
+realized on-screen).
+ at item :modeless
+Specifies that the dialog is @emph{modeless}, meaning that while the
+dialog floats on top of all application-created windows, the user may
+still interact with other windows and dialogs.
+ at item :owner-modal
+Specifies that the dialog is @emph{modal} only in terms of its
+ at ref{owner} window or dialog.
+ at end table
+ at end deffn
+ at deffn Initarg :text
+Specifies the dialog's title.
+ at end deffn
@end deftp
@anchor{display}
@@ -485,19 +511,19 @@
@end deftp
@anchor{widget}
- at deftp Class widget
+ at deftp Class widget style
The widget class is the base class for all windowed user interface objects. It
-derives from @ref{event-source}.
+derives from @ref{event-source}. The @code{style} slot is a list of keyword
+symbols supplying additional information about the desired look-and-feel or
+behavior of the widget; style keywords are widget-specific.
@end deftp
- at anchor{widget-with-items}
+ at anchor{widget-with-items} items
@deftp Class widget-with-items
-The widget-with-items class is the base class for objects composed of sub-items.
-It derives from @ref{widget}.
- at deffn Initarg :items
- at end deffn
- at deffn Accessor items
- at end deffn
+The widget-with-items class is the base class for objects composed of
+sub-items. It derives from @ref{widget}. The @code{items} slot is an
+ at sc{adjustable} @sc{vector} containing @ref{item} objects,
+representing sub-elements of the widget.
@end deftp
@anchor{window}
@@ -583,20 +609,11 @@
@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 sc{t} is returned so that @ref{message-loop} will exit. When
+ at 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
@deffn GenericFunction event-activate dispatcher widget time
@@ -683,12 +700,8 @@
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. 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
+the loop should exit. The pre-defined implementation
+ at ref{default-message-filter} is provided.
@end deffn
@@ -752,10 +765,10 @@
be drawn within or can display data.
@end deffn
- at deffn GenericFunction compute-style-flags self &rest style
-Convert a list of keyword symbols to a pair of native bitmasks; the
-first conveys normal/standard flags, whereas the second any extended
-flags that the system supports.
+ at deffn GenericFunction compute-style-flags self &rest extra-data
+Convert a list of keyword symbols in the object's @code{style} slot to
+a values pair of native bitmasks; the first conveys normal/standard
+flags, whereas the second any extended flags that the system supports.
@end deffn
@deffn GenericFunction compute-outer-size self desired-client-size
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 23:20:03 2006
@@ -236,6 +236,42 @@
(data ffi:c-pointer))
(:return-type ffi:int))
+;;; FIXME: uncomment this when CFFI callbacks can
+;;; be tagged as stdcall or cdecl (only the latter
+;;; is supported as of 0.9.0)
+;;;
+#|
+(defcfun
+ ("EnumThreadWindows" enum-thread-windows)
+ BOOL
+ (threadid DWORD)
+ (func :pointer)
+ (lparam LPARAM))
+|#
+
+#+lispworks
+(fli:define-foreign-function
+ (enum-thread-windows "EnumThreadWindows")
+ ((threadid (:unsigned :long))
+ (func :pointer)
+ (lparam :long))
+ :result-type :int)
+
+#+clisp
+(ffi:def-call-out enum-thread-windows
+ (:name "EnumThreadWindows")
+ (:library "user32.dll")
+ (:language :stdc)
+ (:arguments (threadid ffi:ulong)
+ (func (ffi:c-function
+ (:arguments
+ (hwnd ffi:c-pointer)
+ (lparam ffi:long))
+ (:return-type ffi:int)
+ (:language :stdc-stdcall)))
+ (lparam ffi:long))
+ (:return-type ffi:int))
+
(defcfun
("GetAncestor" get-ancestor)
HANDLE
@@ -382,6 +418,12 @@
(max INT))
(defcfun
+ ("GetWindowThreadProcessId" get-window-thread-process-id)
+ DWORD
+ (hwnd HANDLE)
+ (pid LPTR))
+
+(defcfun
("InsertMenuItemA" insert-menu-item)
BOOL
(hmenu HANDLE)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Thu May 11 23:20:03 2006
@@ -37,14 +37,13 @@
;;; methods
;;;
-(defmethod compute-style-flags ((btn button) style &rest extra-data)
+(defmethod compute-style-flags ((btn button) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)))
- (setf style (gfs:flatten style))
;; FIXME: check whether any of the primary button
;; styles were specified, default to :push-button
;;
- (loop for sym in style
+ (loop for sym in (style-of btn)
do (cond
;; primary button styles
;;
@@ -60,11 +59,9 @@
(setf std-flags (logior std-flags gfs::+bs-pushbox+)))))
(values std-flags 0)))
-(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys)
- (if (not (listp style))
- (setf style (list style)))
+(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys)
(multiple-value-bind (std-style ex-style)
- (compute-style-flags btn style)
+ (compute-style-flags btn)
(let ((hwnd (create-window gfs::+button-classname+
" "
(gfs:handle parent)
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Thu May 11 23:20:03 2006
@@ -54,8 +54,8 @@
(defmethod gfg:background-color ((dlg dialog))
(gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))
-(defmethod compute-style-flags ((dlg dialog) style &rest extra-data)
- (declare (ignore style extra-data))
+(defmethod compute-style-flags ((dlg dialog) &rest extra-data)
+ (declare (ignore extra-data))
(values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+)
(logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+)))
@@ -63,10 +63,10 @@
(declare (ignore time))
(show dlg nil))
-(defmethod initialize-instance :after ((dlg dialog) &key owner style title &allow-other-keys)
+(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys)
(unless (null owner)
(if (gfs:disposed-p owner)
(error 'gfs:disposed-error)))
- (if (null title)
- (setf title +default-dialog-title+))
- (init-window dlg +dialog-classname+ #'register-dialog-class style owner title))
+ (if (null text)
+ (setf text +default-dialog-title+))
+ (init-window dlg +dialog-classname+ #'register-dialog-class owner text))
Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp (original)
+++ trunk/src/uitoolkit/widgets/display.lisp Thu May 11 23:20:03 2006
@@ -83,6 +83,43 @@
(defun obtain-primary-display ()
(find-if #'primary-p (obtain-displays)))
+#+lispworks
+(fli:define-foreign-callable
+ ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall)
+ ((hwnd :pointer)
+ (lparam :long))
+ (let* ((tc (thread-context))
+ (win (get-widget tc hwnd)))
+ (unless (null win)
+ (call-top-level-visitor-func tc win)))
+ 1)
+
+#+clisp
+(defun top_level_window_visitor (hwnd lparam)
+ (declare (ignore lparam))
+ (let* ((tc (thread-context))
+ (win (get-widget tc hwnd)))
+ (unless (null win)
+ (call-top-level-visitor-func tc win)))
+ 1)
+
+(defun visit-top-level-windows (func)
+ ;;
+ ;; supplied closure should expect one parameter:
+ ;; top-level window
+ ;;
+ (let ((tc (thread-context)))
+ (setf (top-level-visitor-func tc) func)
+ (unwind-protect
+#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+ (fli:make-pointer :symbol-name "top_level_window_visitor")
+ 0)
+#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer))
+ #'top_level_window_visitor
+ 0)
+ (setf (top-level-visitor-func tc) nil)))
+ nil)
+
;;;
;;; methods
;;;
Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/file-dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/file-dialog.lisp Thu May 11 23:20:03 2006
@@ -74,12 +74,12 @@
;;; methods
;;;
-(defmethod compute-style-flags ((dlg file-dialog) style &rest extra-data)
+(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+
gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+
gfs::+ofn-explorer+)))
- (loop for sym in style
+ (loop for sym in (style-of dlg)
do (cond
((eq sym :add-to-recent)
(setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+))))
@@ -137,7 +137,7 @@
(gfs::strncpy file-buffer tmp-str 1023))
(setf (cffi:mem-ref file-buffer :char) 0))
(multiple-value-bind (std-style ex-style)
- (compute-style-flags dlg style)
+ (compute-style-flags dlg)
(cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter
gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex
gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Thu May 11 23:20:03 2006
@@ -91,19 +91,20 @@
(setf (gfg:transparency-pixel-of image) pnt))
(setf (image label) image))))
-(defmethod compute-style-flags ((label label) style &rest extra-data)
- (declare (ignore label))
+(defmethod compute-style-flags ((label label) &rest extra-data)
(if (> (count-if-not #'null extra-data) 1)
(error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed"))
(let ((std-style (logior gfs::+ws-child+
gfs::+ws-visible+
(cond
((first extra-data)
- (compute-image-style-flags (gfs:flatten style)))
+ (compute-image-style-flags (style-of label)))
((second extra-data)
- (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+))
+ (if (find :vertical (style-of label))
+ gfs::+ss-etchedvert+
+ gfs::+ss-etchedhorz+))
(t
- (compute-text-style-flags (gfs:flatten style)))))))
+ (compute-text-style-flags (style-of label)))))))
(values std-style 0)))
(defmethod image ((label label))
@@ -152,11 +153,9 @@
gfs::+image-bitmap+
(cffi:pointer-address (gfs:handle image)))))
-(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys)
- (if (not (listp style))
- (setf style (list style)))
+(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys)
(multiple-value-bind (std-style ex-style)
- (compute-style-flags label style image separator text)
+ (compute-style-flags label image separator text)
(let ((hwnd (create-window gfs::+static-classname+
(or text " ")
(gfs:handle parent)
@@ -201,7 +200,7 @@
(etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+)
(logand orig-flags gfs::+ss-sunken+))))
(multiple-value-bind (std-flags ex-flags)
- (compute-style-flags label nil nil nil str)
+ (compute-style-flags label nil nil str)
(declare (ignore ex-flags))
(gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags
std-flags
Modified: trunk/src/uitoolkit/widgets/panel.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/panel.lisp (original)
+++ trunk/src/uitoolkit/widgets/panel.lisp Thu May 11 23:20:03 2006
@@ -49,24 +49,21 @@
;;; methods
;;;
-(defmethod compute-style-flags ((self panel) style &rest extra-data)
+(defmethod compute-style-flags ((self panel) &rest extra-data)
(declare (ignore extra-data))
- (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))
- (ex-flags 0))
+ (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)))
(mapc #'(lambda (sym)
(cond
;; styles that can be combined
;;
((eq sym :border)
(setf std-flags (logior std-flags gfs::+ws-border+)))))
- (gfs:flatten style))
- (values std-flags ex-flags)))
+ (style-of self))
+ (values std-flags 0)))
-(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys)
+(defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys)
(if (null parent)
(error 'gfs:toolkit-error :detail "parent is required for panel"))
(if (gfs:disposed-p parent)
(error 'gfs:disposed-error))
- (if (not (listp style))
- (setf style (list style)))
- (init-window self +panel-window-classname+ #'register-panel-window-class style parent ""))
+ (init-window self +panel-window-classname+ #'register-panel-window-class parent ""))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu May 11 23:20:03 2006
@@ -34,23 +34,24 @@
(in-package #:graphic-forms.uitoolkit.widgets)
(defclass thread-context ()
- ((child-visitor-stack :initform nil)
- (display-visitor-func :initform nil :accessor display-visitor-func)
- (image-loaders-by-type :initform (make-hash-table :test #'equal))
- (job-table :initform (make-hash-table :test #'equal))
- (job-table-lock :initform nil)
- (event-time :initform 0 :accessor event-time)
- (virtual-key :initform 0 :accessor virtual-key)
- (menuitems-by-id :initform (make-hash-table :test #'equal))
- (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)
- (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt)
- (next-menuitem-id :initform 10000 :reader next-menuitem-id)
- (next-timer-id :initform 1 :reader next-timer-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))
- (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd)
- (wip :initform nil))
+ ((child-visitor-stack :initform nil)
+ (display-visitor-func :initform nil :accessor display-visitor-func)
+ (image-loaders-by-type :initform (make-hash-table :test #'equal))
+ (job-table :initform (make-hash-table :test #'equal))
+ (job-table-lock :initform nil)
+ (event-time :initform 0 :accessor event-time)
+ (virtual-key :initform 0 :accessor virtual-key)
+ (menuitems-by-id :initform (make-hash-table :test #'equal))
+ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)
+ (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt)
+ (next-menuitem-id :initform 10000 :reader next-menuitem-id)
+ (next-timer-id :initform 1 :reader next-timer-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))
+ (top-level-visitor-func :initform nil :accessor top-level-visitor-func)
+ (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd)
+ (wip :initform nil))
(:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
;; TODO: change this when CLISP acquires MT support
@@ -122,6 +123,11 @@
(unless (null func)
(funcall func hmonitor data))))
+(defmethod call-top-level-visitor-func ((tc thread-context) win)
+ (let ((func (top-level-visitor-func tc)))
+ (unless (null func)
+ (funcall func win))))
+
(defmethod get-widget ((tc thread-context) hwnd)
"Return the widget object corresponding to the specified native window handle."
(let ((tmp-widget (slot-value tc 'wip)))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 11 23:20:03 2006
@@ -60,7 +60,7 @@
;;; methods
;;;
-(defmethod compute-style-flags ((win top-level) style &rest extra-data)
+(defmethod compute-style-flags ((win top-level) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags 0)
(ex-flags 0))
@@ -114,7 +114,7 @@
gfs::+ws-clipsiblings+
gfs::+ws-clipchildren+))
(setf ex-flags 0))))
- (gfs:flatten style))
+ (style-of win))
(values std-flags ex-flags)))
(defmethod gfs:dispose ((win top-level))
@@ -124,20 +124,18 @@
(remove-widget (thread-context) (gfs:handle m))))
(call-next-method))
-(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys)
+(defmethod initialize-instance :after ((win top-level) &key owner title &allow-other-keys)
(unless (null owner)
(if (gfs:disposed-p owner)
(error 'gfs:disposed-error)))
(if (null title)
(setf title +default-window-title+))
- (if (not (listp style))
- (setf style (list style)))
(let ((classname +toplevel-noerasebkgnd-window-classname+)
(register-func #'register-toplevel-noerasebkgnd-window-class))
- (when (find :workspace style)
+ (when (find :workspace (style-of win))
(setf classname +toplevel-erasebkgnd-window-classname+)
(setf register-func #'register-toplevel-erasebkgnd-window-class))
- (init-window win classname register-func style owner title)))
+ (init-window win classname register-func owner title)))
(defmethod menu-bar :before ((win top-level))
(if (gfs:disposed-p win)
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 11 23:20:03 2006
@@ -59,7 +59,11 @@
(defclass menu-item (item) ()
(:documentation "A subtype of item representing a menu item."))
-(defclass widget (event-source) ()
+(defclass widget (event-source)
+ ((style
+ :reader style-of
+ :initarg :style
+ :initform nil))
(:documentation "The widget class is the base class for all windowed user interface objects."))
(defclass caret (widget) ()
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 11 23:20:03 2006
@@ -105,7 +105,7 @@
(defgeneric columns (self)
(:documentation "Returns the column objects displayed by the object."))
-(defgeneric compute-style-flags (self style &rest extra-data)
+(defgeneric compute-style-flags (self &rest extra-data)
(:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports."))
(defgeneric compute-outer-size (self desired-client-size)
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Thu May 11 23:20:03 2006
@@ -167,6 +167,9 @@
(defmethod enabled-p ((w widget))
(not (zerop (gfs::is-window-enabled (gfs:handle w)))))
+(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys)
+ (setf (slot-value w 'style) (if (listp style) style (list style))))
+
(defmethod location :before ((w widget))
(if (gfs:disposed-p w)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Thu May 11 23:20:03 2006
@@ -42,12 +42,12 @@
;;; helper functions
;;;
-(defun init-window (win classname register-class-fn style parent text)
+(defun init-window (win classname register-class-fn parent text)
(let ((tc (thread-context)))
(setf (widget-in-progress tc) win)
(funcall register-class-fn)
(multiple-value-bind (std-style ex-style)
- (compute-style-flags win style)
+ (compute-style-flags win)
(create-window classname
text
(if (null parent) (cffi:null-pointer) (gfs:handle parent))
@@ -75,7 +75,7 @@
(defun child_window_visitor (hwnd lparam)
(let* ((tc (thread-context))
(child (get-widget tc hwnd))
- (parent (get-widget tc (cffi:make-pointer lparam))))
+ (parent (get-widget tc (cffi:make-pointer lparam))))
(unless (or (null child) (null parent))
(call-child-visitor-func tc parent child)))
1)
More information about the Graphic-forms-cvs
mailing list