[graphic-forms-cvs] r145 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Jun 2 22:59:14 UTC 2006
Author: junrue
Date: Fri Jun 2 18:59:13 2006
New Revision: 145
Modified:
trunk/build.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/system/system-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
added with-rect macro to simplify code using Win32 rect structure
Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp (original)
+++ trunk/build.lisp Fri Jun 2 18:59:13 2006
@@ -45,7 +45,7 @@
(defvar *project-root* "c:/projects/public/")
(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/"))
-(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060514/"))
+(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/"))
(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/"))
(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/"))
(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Jun 2 18:59:13 2006
@@ -175,15 +175,10 @@
(setf gfs::tablength tab-width)
(setf gfs::leftmargin 0)
(setf gfs::rightmargin 0)
- (cffi:with-foreign-object (rect-ptr 'gfs::rect)
- (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect)
- (setf gfs::left 0
- gfs::right 0
- gfs::top 0
- gfs::bottom 0)
- (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
- (setf (gfs:size-width sz) (- gfs::right gfs::left))
- (setf (gfs:size-height sz) (- gfs::bottom gfs::top)))))))
+ (gfs::with-rect
+ (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr)
+ (setf (gfs:size-width sz) (- gfs::right gfs::left))
+ (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))
(when (or (zerop len) (zerop (gfs:size-height sz)))
(cffi:with-foreign-object (tm-ptr 'gfs::textmetrics)
(cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics)
@@ -297,21 +292,19 @@
(let ((hdc (gfs:handle self))
(pnt (gfs:location rect))
(size (gfs:size rect)))
- (cffi:with-foreign-object (rect-ptr 'gfs::rect)
- (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
- rect-ptr gfs::rect)
- (setf gfs::top (gfs:point-y pnt))
- (setf gfs::left (gfs:point-x pnt))
- (setf gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)))
- (setf gfs::right (+ (gfs:point-x pnt) (gfs:size-width size)))
- (gfs::ext-text-out hdc
- (gfs:point-x pnt)
- (gfs:point-y pnt)
- gfs::+eto-opaque+
- rect-ptr
- ""
- 0
- (cffi:null-pointer))))))
+ (gfs::with-rect
+ (setf gfs::top (gfs:point-y pnt)
+ gfs::left (gfs:point-x pnt)
+ gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))
+ gfs::right (+ (gfs:point-x pnt) (gfs:size-width size)))
+ (gfs::ext-text-out hdc
+ (gfs:point-x pnt)
+ (gfs:point-y pnt)
+ gfs::+eto-opaque+
+ rect-ptr
+ ""
+ 0
+ (cffi:null-pointer)))))
|#
(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size)
@@ -448,24 +441,22 @@
(setf gfs::tablength tb-width)
(setf gfs::leftmargin 0)
(setf gfs::rightmargin 0)
- (cffi:with-foreign-object (rect-ptr 'gfs::rect)
- (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
- rect-ptr gfs::rect)
- (setf gfs::left (gfs:point-x pnt))
- (setf gfs::top (gfs:point-y pnt))
- (gfs::draw-text-ex (gfs:handle self)
- text
- -1
- rect-ptr
- (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+)))
- dt-ptr)
- (gfs::draw-text-ex (gfs:handle self)
- text
- (length text)
- rect-ptr
- flags
- dt-ptr)
- (gfs::set-bk-mode (gfs:handle self) old-bk-mode)))))))
+ (gfs::with-rect
+ (setf gfs::left (gfs:point-x pnt))
+ (setf gfs::top (gfs:point-y pnt))
+ (gfs::draw-text-ex (gfs:handle self)
+ text
+ -1
+ gfs::rect-ptr
+ (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+)))
+ dt-ptr)
+ (gfs::draw-text-ex (gfs:handle self)
+ text
+ (length text)
+ gfs::rect-ptr
+ flags
+ dt-ptr)
+ (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))
(defmethod (setf font) ((font font) (self graphics-context))
(if (gfs:disposed-p self)
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Fri Jun 2 18:59:13 2006
@@ -58,6 +58,13 @@
;;; convenience macros
;;;
+(defmacro with-rect (&body body)
+ `(cffi:with-foreign-object (rect-ptr 'gfs::rect)
+ (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
+ rect-ptr gfs::rect)
+ (zero-mem rect-ptr gfs::rect)
+ , at body)))
+
(defmacro with-hfont-selected ((hdc hfont) &body body)
(let ((hfont-old (gensym)))
`(let ((,hfont-old nil))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Fri Jun 2 18:59:13 2006
@@ -169,19 +169,16 @@
(defmethod compute-outer-size ((win window) desired-client-size)
(let ((hwnd (gfs:handle win))
(new-size (gfs:make-size)))
- (cffi:with-foreign-object (rect-ptr 'gfs::rect)
- (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) rect-ptr gfs::rect)
- (setf gfs::left 0
- gfs::top 0
- gfs::right (gfs:size-width desired-client-size)
- gfs::bottom (gfs:size-height desired-client-size))
- (if (zerop (gfs::adjust-window-rect rect-ptr
- (gfs::get-window-long hwnd gfs::+gwl-style+)
- (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1)
- (gfs::get-window-long hwnd gfs::+gwl-exstyle+)))
- (error 'gfs:win32-error :detail "adjust-window-rect failed"))
- (setf (gfs:size-width new-size) (- gfs::right gfs::left)
- (gfs:size-height new-size) (- gfs::bottom gfs::top))))
+ (gfs::with-rect
+ (setf gfs::right (gfs:size-width desired-client-size)
+ gfs::bottom (gfs:size-height desired-client-size))
+ (if (zerop (gfs::adjust-window-rect gfs::rect-ptr
+ (gfs::get-window-long hwnd gfs::+gwl-style+)
+ (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1)
+ (gfs::get-window-long hwnd gfs::+gwl-exstyle+)))
+ (error 'gfs:win32-error :detail "adjust-window-rect failed"))
+ (setf (gfs:size-width new-size) (- gfs::right gfs::left)
+ (gfs:size-height new-size) (- gfs::bottom gfs::top)))
new-size))
(defmethod enable-layout :before ((win window) flag)
More information about the Graphic-forms-cvs
mailing list