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) + ,@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)