[graphic-forms-cvs] r220 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Aug 18 17:18:50 UTC 2006
Author: junrue
Date: Fri Aug 18 13:18:48 2006
New Revision: 220
Modified:
trunk/docs/manual/widgets-api.texinfo
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/heap-layout.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented layout item registration, no longer directly using mapchildren to layout children
Modified: trunk/docs/manual/widgets-api.texinfo
==============================================================================
--- trunk/docs/manual/widgets-api.texinfo (original)
+++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006
@@ -539,8 +539,10 @@
Instances of this class employ a @ref{layout-manager} to maintain
the positions and sizes of their children.
@deffn Accessor layout-of
-Accepts or returns the @ref{layout-manager} associated with this
-container.
+Accepts or returns the layout-manager associated with this
+container. Note that children currently registered with the previous
+layout-manager are copied to the new one, but existing layout
+attributes that were set for each child are not copied.
@end deffn
@deffn Initarg :layout
Accepts a @ref{layout-manager} object whose responsibility is to manage
@@ -1701,11 +1703,10 @@
@anchor{compute-layout}
@deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint
-Returns a list of pairs @code{(item rectangle)} describing the
+Returns a list of conses @code{(child . rectangle)} describing the
new bounds of each child within @var{container}. A layout-manager subclass
implements this method based on its particular layout strategy, taking
-into account attributes set by the user via @ref{layout-attribute}. Certain
-Graphic-Forms functions call this method to accomplish layout within a container.
+into account attributes set by the user via @ref{layout-attribute}.
@table @var
@item layout-manager
The layout object dictating how children of @var{container}
Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 13:18:48 2006
@@ -57,8 +57,8 @@
(define-test layout-attributes-test
(let ((widget1 (make-instance 'mock-widget :handle 1234))
(widget2 (make-instance 'mock-widget :handle 5678)))
- (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2)))
- (data2 `(,(cffi:make-pointer 5678) (a 10 c 30)))
+ (let ((data1 `(,widget1 (a 1 b 2)))
+ (data2 `(,widget2 (a 10 c 30)))
(layout (make-instance 'gfw:layout-manager)))
(setf (slot-value layout 'gfw::data) (list data1 data2))
(assert-equal 1 (gfw:layout-attribute layout widget1 'a))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006
@@ -1014,6 +1014,14 @@
(defconstant +wm-displaychange+ #x007E)
(defconstant +wm-geticon+ #x007F)
(defconstant +wm-seticon+ #x0080)
+(defconstant +wm-nccreate+ #x0081)
+(defconstant +wm-ncdestroy+ #x0082)
+(defconstant +wm-nccalcsize+ #x0083)
+(defconstant +wm-nchittest+ #x0084)
+(defconstant +wm-ncpaint+ #x0085)
+(defconstant +wm-ncactivate+ #x0086)
+(defconstant +wm-getdlgcode+ #x0087)
+(defconstant +wm-syncpaint+ #x0088)
(defconstant +wm-ncmousemove+ #x00A0)
(defconstant +wm-nclbuttondown+ #x00A1)
(defconstant +wm-nclbuttonup+ #x00A2)
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006
@@ -43,7 +43,13 @@
(put-widget (thread-context) ctrl)
(let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
(unless (gfs:null-handle-p hfont)
- (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))))
+ (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))
+ ;; FIXME: this is a temporary hack to allow layout management testing;
+ ;; it breaks in the presence of virtual containers like group
+ ;;
+ (let ((parent (parent ctrl)))
+ (when (and parent (layout-of parent))
+ (append-layout-item (layout-of parent) ctrl)))))
;;;
;;; methods
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006
@@ -169,7 +169,7 @@
(error 'gfs:disposed-error)))
(if (null text)
(setf text *default-dialog-title*))
- ;; NOTE: do not allow apps to specify the desktop window as the
+ ;; Don't allow apps to specify the desktop window as the
;; owner of the dialog; it would cause the desktop to become
;; disabled.
;;
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006
@@ -33,10 +33,12 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+
- gfs::+pm-noyield+
- gfs::+pm-qs-input+
- gfs::+pm-qs-postmessage+))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +wm-gf-init-msg+ #xABCD)
+ (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+
+ gfs::+pm-noyield+
+ gfs::+pm-qs-input+
+ gfs::+pm-qs-postmessage+)))
;;;
;;; window procedures
@@ -139,6 +141,8 @@
(setf ret-val (cffi:pointer-address (brush-handle-of widget))))
ret-val))
+;;; FIXME: replace event-time slot with call to GetMessageTime
+;;;
(defun obtain-event-time ()
(event-time (thread-context)))
@@ -216,13 +220,30 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
- (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot
- (if (typep w 'dialog)
- (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam))))
+ (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot
+ (if (typep widget 'dialog)
+ (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam)))
+ (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget
+ (return-from process-message tmp))
+ (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget
+ 0)
+
+(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam)
+ (declare (ignore wparam lparam))
+ (let ((widget (get-widget (thread-context) hwnd)))
+ (unless widget
+ (return-from process-message 0)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
(declare (ignore wparam lparam))
+ (let ((widget (get-widget (thread-context) hwnd)))
+ (if widget
+ (event-dispose (dispatcher widget) widget)))
+ ;; If widget is registered with a layout manager, that reference
+ ;; is not cleared until the next time the layout manager is invoked.
+ ;; This alleviates the need for slow messy code here.
+ ;;
(delete-widget (thread-context) hwnd)
0)
@@ -242,10 +263,10 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
(declare (ignore lparam))
(let* ((tc (thread-context))
- (w (get-widget tc hwnd))
+ (widget (get-widget tc hwnd))
(ch (code-char (lo-word wparam))))
- (when w
- (event-key-down (dispatcher w) w (virtual-key tc) ch)))
+ (when widget
+ (event-key-down (dispatcher widget) widget (virtual-key tc) ch)))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006
@@ -170,18 +170,16 @@
;;; methods
;;;
-(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
- (let ((kids (mapchildren win (lambda (parent child)
- (declare (ignore parent))
- child))))
- (flow-container-size layout (visible-p win) kids width-hint height-hint)))
+(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
+ (let ((kids (loop for item in (data-of self) collect (first item))))
+ (flow-container-size self (visible-p container) kids width-hint height-hint)))
-(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
- (let ((kids (mapchildren win (lambda (parent child)
- (declare (ignore parent))
- child))))
- (flow-container-layout layout (visible-p win) kids width-hint height-hint)))
+(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
+ (let ((kids (loop for item in (data-of self) collect (first item))))
+ (flow-container-layout self (visible-p container) kids width-hint height-hint)))
-(defmethod initialize-instance :after ((layout flow-layout) &key)
- (unless (intersection (style-of layout) '(:horizontal :vertical))
- (setf (style-of layout) (list :horizontal))))
+(defmethod initialize-instance :after ((self flow-layout) &key)
+ (unless (intersection (style-of self) '(:horizontal :vertical))
+ (setf (style-of self) (list :horizontal))))
Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/heap-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006
@@ -37,21 +37,23 @@
;;; methods
;;;
-(defmethod compute-size ((self heap-layout) win width-hint height-hint)
+(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
(let ((size (gfs:make-size)))
- (mapchildren win (lambda (parent kid)
- (declare (ignore parent))
- (let ((kid-size (preferred-size kid width-hint height-hint)))
- (setf (gfs:size-width size) (max (gfs:size-width size)
- (gfs:size-width kid-size))
- (gfs:size-height size) (max (gfs:size-height size)
- (gfs:size-height kid-size))))))
+ (mapc (lambda (item)
+ (let ((kid-size (preferred-size (first item) width-hint height-hint)))
+ (setf (gfs:size-width size) (max (gfs:size-width size)
+ (gfs:size-width kid-size))
+ (gfs:size-height size) (max (gfs:size-height size)
+ (gfs:size-height kid-size)))))
+ (data-of self))
(incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self)))
(incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self)))
size))
-(defmethod compute-layout ((self heap-layout) win width-hint height-hint)
- (let* ((size (client-size win))
+(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
+ (let* ((size (client-size container))
(horz-margin (+ (left-margin-of self) (right-margin-of self)))
(vert-margin (+ (top-margin-of self) (bottom-margin-of self)))
(new-size (gfs:make-size :width (- (if (> width-hint horz-margin)
@@ -64,16 +66,19 @@
vert-margin)))
(new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self)))
(bounds (gfs:make-rectangle :size new-size :location new-pnt)))
- (mapchildren win (lambda (parent kid)
- (declare (ignore parent))
- (cons kid bounds)))))
+ (mapcar (lambda (item) (cons (first item) bounds)) (data-of self))))
(defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint)
- (let ((top (top-child-of self))
- (kid-specs (compute-layout self container width-hint height-hint)))
- (unless top
- (setf top (car (first kid-specs))))
- (arrange-children kid-specs (lambda (item)
- (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item))
- (logior +window-pos-flags+ gfs::+swp-showwindow+)
- (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))
+ (if (layout-p container)
+ (let ((top (top-child-of self))
+ (kid-specs (compute-layout self container width-hint height-hint)))
+ (unless top
+ (setf top (car (first kid-specs))))
+ (arrange-hwnds kid-specs (lambda (item)
+ (if (eql top item)
+ (logior +window-pos-flags+ gfs::+swp-showwindow+)
+ (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))))
+
+(defmethod (setf top-child-of) :after (child (self heap-layout))
+ (unless (typep child 'widget)
+ (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass")))
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006
@@ -43,27 +43,34 @@
;;; helper functions
;;;
-(defun layout-attribute (layout widget name)
- "Return the value associated with name for widget; or NIL if no value is set."
- (if (gfs:disposed-p widget)
- (error 'gfs:disposed-error))
- (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq)))
- (unless attrs
- (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout)))
- (getf (first (rest attrs)) name)))
-
-(defun set-layout-attribute (layout widget name value)
- "Sets a value associated with name for widget in the specified layout."
- (if (gfs:disposed-p widget)
- (error 'gfs:disposed-error))
- (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq)))
- (unless attrs
- (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout)))
- (setf (getf (first (rest attrs)) name) value)))
+(defun layout-attribute (layout thing name)
+ "Return the value associated with name for thing; or NIL if no value is set."
+ (let ((items (assoc thing (data-of layout))))
+ (unless items
+ (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout)))
+ (getf (first (rest items)) name)))
+
+(defun set-layout-attribute (layout thing name value)
+ "Sets a value associated with name for thing in the specified layout."
+ (let ((items (assoc thing (data-of layout))))
+ (unless items
+ (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout)))
+ (setf (getf (first (rest items)) name) value)))
(defsetf layout-attribute set-layout-attribute)
-(defun arrange-children (kid-specs flags-func)
+(defun append-layout-item (layout thing)
+ "Adds thing to layout unless it is already registered."
+ (setf (data-of layout) (nconc (data-of layout) (list (list thing nil)))))
+
+(defun delete-layout-item (layout thing)
+ "Removes thing from layout."
+ (delete thing (data-of layout) :key #'first))
+
+(defun cleanup-disposed-items (layout)
+ (delete-if #'gfs:disposed-p (data-of layout) :key #'first))
+
+(defun arrange-hwnds (kid-specs flags-func)
(let ((hdwp (gfs::begin-defer-window-pos (length kid-specs))))
(loop for k in kid-specs
for rect = (cdr k)
@@ -93,25 +100,37 @@
;;; methods
;;;
-(defmethod initialize-instance :after ((layout layout-manager)
+(defmethod initialize-instance :after ((self layout-manager)
&key style margins horizontal-margins vertical-margins
&allow-other-keys)
- (setf (style-of layout) (if (listp style) style (list style)))
+ (setf (style-of self) (if (listp style) style (list style)))
(unless (null margins)
- (setf (left-margin-of layout) margins
- (right-margin-of layout) margins
- (top-margin-of layout) margins
- (bottom-margin-of layout) margins))
+ (setf (left-margin-of self) margins
+ (right-margin-of self) margins
+ (top-margin-of self) margins
+ (bottom-margin-of self) margins))
(unless (null horizontal-margins)
- (setf (left-margin-of layout) horizontal-margins
- (right-margin-of layout) horizontal-margins))
+ (setf (left-margin-of self) horizontal-margins
+ (right-margin-of self) horizontal-margins))
(unless (null vertical-margins)
- (setf (top-margin-of layout) vertical-margins
- (bottom-margin-of layout) vertical-margins)))
+ (setf (top-margin-of self) vertical-margins
+ (bottom-margin-of self) vertical-margins)))
+
+(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed))
+ (let ((orig-layout (layout-of container)))
+ (if orig-layout
+ (setf (data-of self) (loop for item in (data-of orig-layout)
+ when (not (gfs:disposed-p (first item)))
+ collect item)
+ (data-of orig-layout) nil)
+ (if (typep container 'window)
+ (setf (data-of self) (mapchildren container (lambda (parent child)
+ (declare (ignore parent))
+ (list child nil))))))))
(defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint)
- (when (layout-p container)
- (arrange-children (compute-layout self container width-hint height-hint)
- (lambda (item)
- (declare (ignore item))
- +window-pos-flags+))))
+ (if (layout-p container)
+ (arrange-hwnds (compute-layout self container width-hint height-hint)
+ (lambda (item)
+ (declare (ignore item))
+ +window-pos-flags+))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006
@@ -40,7 +40,7 @@
(display-visitor-results :initform nil :accessor display-visitor-results)
(job-table :initform (make-hash-table :test #'equal))
(job-table-lock :initform nil)
- (event-time :initform 0 :accessor event-time)
+ (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime
(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)
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006
@@ -50,11 +50,7 @@
(:documentation "Instances of this class employ a layout manager to organize their children."))
(defclass group (layout-managed)
- ((children
- :accessor children-of
- :initarg :children
- :initform nil)
- (location
+ ((location
:accessor location-of
:initarg :location
:initform nil)
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006
@@ -219,37 +219,37 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys)
- (setf (slot-value w 'style) (if (listp style) style (list style))))
+(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys)
+ (setf (slot-value self 'style) (if (listp style) style (list style))))
-(defmethod location :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod location :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod location ((w widget))
+(defmethod location ((self widget))
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
(cffi:with-foreign-slots ((gfs::cbsize
gfs::clientleft
gfs::clienttop)
wi-ptr gfs::windowinfo)
(setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
- (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr))
+ (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr))
(error 'gfs:win32-error :detail "get-window-info failed"))
(cffi:with-foreign-object (pnt-ptr 'gfs::point)
(cffi:with-foreign-slots ((gfs::x gfs::y)
pnt-ptr gfs::point)
(setf gfs::x gfs::clientleft)
(setf gfs::y gfs::clienttop)
- (gfs::screen-to-client (gfs:handle w) pnt-ptr)
+ (gfs::screen-to-client (gfs:handle self) pnt-ptr)
(gfs:make-point :x gfs::x :y gfs::y))))))
-(defmethod (setf location) :before ((pnt gfs:point) (w widget))
+(defmethod (setf location) :before ((pnt gfs:point) (self widget))
(declare (ignore pnt))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod (setf location) ((pnt gfs:point) (w widget))
- (if (zerop (gfs::set-window-pos (gfs:handle w)
+(defmethod (setf location) ((pnt gfs:point) (self widget))
+ (if (zerop (gfs::set-window-pos (gfs:handle self)
(cffi:null-pointer)
(gfs:point-x pnt)
(gfs:point-y pnt)
@@ -272,12 +272,12 @@
nil
(get-widget (thread-context) hwnd))))
-(defmethod pack :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod pack :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod pack ((w widget))
- (setf (size w) (preferred-size w -1 -1)))
+(defmethod pack ((self widget))
+ (setf (size self) (preferred-size self -1 -1)))
(defmethod parent ((self widget))
;; Unlike the owner method, this method should
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006
@@ -58,7 +58,13 @@
(error 'gfs:win32-error :detail "create-window failed"))
(if (find :keyboard-navigation (style-of win))
(put-kbdnav-widget tc win))
- (put-widget tc win))))
+ (put-widget tc win))
+ ;; FIXME: this is a temporary hack to allow layout management testing;
+ ;; it breaks in the presence of virtual containers like group
+ ;;
+ (let ((parent (parent win)))
+ (if (and parent (layout-of parent))
+ (append-layout-item (layout-of parent) win)))))
(defun child-window-visitor (hwnd lparam)
(let* ((tc (thread-context))
More information about the Graphic-forms-cvs
mailing list