Author: junrue Date: Thu Mar 16 00:17:31 2006 New Revision: 45
Modified: trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced +style-popup+ with +style-palette+ and associated implementation; implemented +style-miniframe+ and +style-borderless+; relocated thread context cleanup function call to a more robust location
Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Thu Mar 16 00:17:31 2006 @@ -33,14 +33,17 @@
(in-package #:graphic-forms.uitoolkit.tests)
+(defvar *hello-win* nil) + (defclass hellowin-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((d hellowin-events) widget time) +(defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore widget time)) + (gfi:dispose window) (gfw:shutdown 0))
(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignore window time rect)) + (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:+color-white+) @@ -51,17 +54,18 @@
(defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) + (gfi:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0))
(defun run-hello-world-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize *hello-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (setf (gfw:menu-bar *hello-win*) menubar) + (gfw:show *hello-win* t)))
(defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal))
Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Thu Mar 16 00:17:31 2006 @@ -33,19 +33,18 @@
(in-package #:graphic-forms.uitoolkit.tests)
+(defvar *main-win* nil) + (defclass main-win-events (gfw:event-dispatcher) ())
(defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) + (setf *main-win* nil) (gfi:dispose window) (gfw:shutdown 0))
(defclass test-win-events (gfw:event-dispatcher) ())
-(defmethod gfw:event-close ((d test-win-events) window time) - (declare (ignore time)) - (gfi:dispose window)) - (defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) @@ -53,36 +52,62 @@ (setf (gfg:background-color gc) gfg:+color-white+) (gfg:draw-filled-rectangle gc rect))
-(defun create-borderless-win ()) +(defclass test-mini-events (test-win-events) ())
-(defun create-miniframe-win ()) +(defmethod gfw:event-close ((d test-mini-events) window time) + (declare (ignore time)) + (gfi: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)) + (gfi:dispose window))
-(defun create-popup-win (disp item time rect) +(defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) - (gfw:realize window nil :style-popup) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) + (gfw:realize window *main-win* :style-borderless) + (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (gfw:show window t))) + +(defun create-miniframe-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-miniframe) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Mini Frame") + (gfw:show window t))) + +(defun create-palette-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-palette) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) - (setf (gfw:text window) "Popup") + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Palette") (gfw:show window t)))
(defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) + (gfi:dispose *main-win*) + (setf *main-win* nil) (gfw:shutdown 0))
(defun run-windlg-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize *main-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Popup" :callback #'create-popup-win)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (:item "&Palette" :callback #'create-palette-win)))))) + (setf (gfw:menu-bar *main-win*) menubar) + (gfw:show *main-win* t)))
(defun run-windlg () (gfw:startup "Window/Dialog Tester" #'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 Thu Mar 16 00:17:31 2006 @@ -232,6 +232,11 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) +(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h +(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h +(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h +(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h +(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000)
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 16 00:17:31 2006 @@ -75,6 +75,7 @@ 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")
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Mar 16 00:17:31 2006 @@ -49,8 +49,7 @@ (run-default-message-loop)))))
(defun shutdown (exit-code) - (gfs::post-quit-message exit-code) - (dispose-thread-context)) + (gfs::post-quit-message exit-code))
(defun clear-all (w) (let ((count (gfw:item-count w)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 16 00:17:31 2006 @@ -179,19 +179,28 @@
;; pre-packaged combinations of window styles ;; - ((eq sym :style-popup) - (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) - (setf ex-flags gfs::+ws-ex-toolwindow+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) ((eq sym :style-workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ @@ -266,10 +275,11 @@ (size win))))
(defmethod realize ((win window) parent &rest style) - (if (not (null parent)) - (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) + (unless (null parent) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (register-workspace-window-class) @@ -277,7 +287,7 @@ (compute-style-flags win style) (create-window +workspace-window-classname+ +default-window-title+ - (cffi:null-pointer) + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) std-style ex-style)) (clear-widget-in-progress tc)