[graphic-forms-cvs] r134 - trunk/src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue May 16 16:08:55 UTC 2006
Author: junrue
Date: Tue May 16 12:08:55 2006
New Revision: 134
Modified:
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/display.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
replaced display/top-level/child visit functions with mapcar-like replacements; implemented top-level disabling for :application-modal style
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Tue May 16 12:08:55 2006
@@ -36,6 +36,8 @@
(defconstant +default-dialog-title+ " ")
(defconstant +dlgwindowextra+ 48)
+(defvar *disabled-top-levels* nil)
+
;;;
;;; helper functions
;;;
@@ -66,13 +68,10 @@
(error 'gfs:disposed-error)))
(defmethod cancel-widget ((self dialog))
- (let ((def-widget nil))
- (visit-child-widgets self (lambda (parent kid)
- (declare (ignore parent))
- (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+)
- gfs::+idcancel+)
- (setf def-widget kid))))
- def-widget))
+ (with-children (self kids)
+ (loop for kid in kids
+ until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+)
+ finally (return kid))))
(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog))
(if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))
@@ -104,13 +103,10 @@
(error 'gfs:disposed-error)))
(defmethod default-widget ((self dialog))
- (let ((def-widget nil))
- (visit-child-widgets self (lambda (parent kid)
- (declare (ignore parent))
- (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+)
- gfs::+idok+)
- (setf def-widget kid))))
- def-widget))
+ (with-children (self kids)
+ (loop for kid in kids
+ until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+)
+ finally (return kid))))
(defmethod (setf default-widget) :before ((def-widget widget) (self dialog))
(if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))
@@ -174,14 +170,18 @@
(owner (owner self))
(hdlg (gfs:handle self)))
(cond
- ((and app-modal owner)
- ;; FIXME: need to save and restore each window's prior
- ;; enabled state
- ;;
- (visit-top-level-windows (lambda (win)
- (unless (or (cffi:pointer-eq (gfs:handle win) hdlg)
- (cffi:pointer-eq (gfs:handle win) hutility))
- (enable win (null flag))))))
+ ((and app-modal flag)
+ (setf *disabled-top-levels* nil)
+ (maptoplevels (lambda (win)
+ (unless (or (cffi:pointer-eq (gfs:handle win) hdlg)
+ (cffi:pointer-eq (gfs:handle win) hutility))
+ (if (enabled-p win)
+ (push win *disabled-top-levels*))
+ (enable win nil)))))
+ ((and app-modal (null flag))
+ (loop for win in *disabled-top-levels*
+ do (enable win t))
+ (setf *disabled-top-levels* nil))
((and owner-modal owner)
(enable owner (null flag))))
(gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))
Modified: trunk/src/uitoolkit/widgets/display.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/display.lisp (original)
+++ trunk/src/uitoolkit/widgets/display.lisp Tue May 16 12:08:55 2006
@@ -54,9 +54,9 @@
(call-display-visitor-func (thread-context) hmonitor data)
1)
-(defun visit-displays (func)
+(defun mapdisplays (func)
;;
- ;; supplied closure should expect two parameters:
+ ;; func should expect two parameters:
;; display handle
;; flag data
;;
@@ -67,18 +67,18 @@
(gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0))
#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
(gfs::enum-display-monitors ptr ptr #'display_visitor 0))
- (setf (display-visitor-func tc) nil)))
- nil)
+ (setf (display-visitor-func tc) nil))
+ (let ((tmp (reverse (display-visitor-results tc))))
+ (setf (display-visitor-results tc) nil)
+ tmp)))
(defun obtain-displays ()
- (let ((display-list nil))
- (visit-displays #'(lambda (hmonitor data)
- (let ((pflag (= (logand data gfs::+monitorinfoof-primary+)
- gfs::+monitorinfoof-primary+))
- (display (make-instance 'display :handle hmonitor)))
- (setf (slot-value display 'primary) pflag)
- (push display display-list))))
- display-list))
+ (mapdisplays (lambda (hmonitor data)
+ (let ((pflag (= (logand data gfs::+monitorinfoof-primary+)
+ gfs::+monitorinfoof-primary+))
+ (display (make-instance 'display :handle hmonitor)))
+ (setf (slot-value display 'primary) pflag)
+ (push display (display-visitor-results (thread-context)))))))
(defun obtain-primary-display ()
(find-if #'primary-p (obtain-displays)))
@@ -103,9 +103,9 @@
(call-top-level-visitor-func tc win)))
1)
-(defun visit-top-level-windows (func)
+(defun maptoplevels (func)
;;
- ;; supplied closure should expect one parameter:
+ ;; func should expect one parameter:
;; top-level window
;;
(let ((tc (thread-context)))
@@ -117,8 +117,10 @@
#+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)
+ (setf (top-level-visitor-func tc) nil))
+ (let ((tmp (reverse (top-level-visitor-results tc))))
+ (setf (top-level-visitor-results tc) nil)
+ tmp)))
;;;
;;; methods
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue May 16 12:08:55 2006
@@ -34,24 +34,27 @@
(in-package #:graphic-forms.uitoolkit.widgets)
(defclass thread-context ()
- ((child-visitor-func :initform nil :accessor child-visitor-func)
- (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-widget-id :initform 100 :reader next-widget-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))
+ ((child-visitor-func :initform nil :accessor child-visitor-func)
+ (child-visitor-results :initform nil :accessor child-visitor-results)
+ (display-visitor-func :initform nil :accessor display-visitor-func)
+ (display-visitor-results :initform nil :accessor display-visitor-results)
+ (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-widget-id :initform 100 :reader next-widget-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)
+ (top-level-visitor-results :initform nil :accessor top-level-visitor-results)
+ (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
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Tue May 16 12:08:55 2006
@@ -80,7 +80,7 @@
(call-child-visitor-func tc parent child)))
1)
-(defun visit-child-widgets (win func)
+(defun mapchildren (win func)
;;
;; supplied closure should expect two parameters:
;; parent window object
@@ -100,8 +100,10 @@
(gfs::enum-child-windows ptr
#'child_window_visitor
(cffi:pointer-address (gfs:handle win))))
- (setf (child-visitor-func tc) nil)))
- nil)
+ (setf (child-visitor-func tc) nil))
+ (let ((tmp (reverse (child-visitor-results tc))))
+ (setf (child-visitor-results tc) nil)
+ tmp)))
(defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra)
(let ((retval 0))
@@ -144,12 +146,12 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-children ((win var) &body body)
(let ((hwnd (gensym)))
- `(let ((,var nil))
- (visit-child-widgets ,win (lambda (parent child)
- (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)))
- (if (cffi:pointer-eq (gfs:handle parent) ,hwnd)
- (push child ,var)))))
- (setf ,var (reverse ,var))
+ `(let ((,var (mapchildren ,win (lambda (parent child)
+ (let ((,hwnd (gfs::get-ancestor
+ (gfs:handle child)
+ gfs::+ga-parent+)))
+ (if (cffi:pointer-eq (gfs:handle parent) ,hwnd)
+ (push child (child-visitor-results (thread-context)))))))))
, at body))))
;;;
More information about the Graphic-forms-cvs
mailing list