[graphic-forms-cvs] r45 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Mar 16 05:17:32 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list