[graphic-forms-cvs] r228 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 21 16:51:49 UTC 2006
Author: junrue
Date: Mon Aug 21 12:51:48 2006
New Revision: 228
Modified:
trunk/NEWS.txt
trunk/src/uitoolkit/graphics/color.lisp
trunk/src/uitoolkit/graphics/graphics-classes.lisp
trunk/src/uitoolkit/graphics/image.lisp
trunk/src/uitoolkit/system/system-utils.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
reviewed and fixed macro definitions
Modified: trunk/NEWS.txt
==============================================================================
--- trunk/NEWS.txt (original)
+++ trunk/NEWS.txt Mon Aug 21 12:51:48 2006
@@ -32,20 +32,22 @@
argument to every function (for which the vast majority of methods
had no use).
-. Provided a new generic function called event-session so applications
- can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol.
+. Defined the following new generic functions:
-. Provided event-activate and event-deactivate generic functions so
- applications can respond to window activation state changes.
+ * event-session GF so applications can participate in the
+ WM_QUERYENDSESSION / WM_ENDSESSION protocol.
-. Defined generic functions for querying undo and redo state. Implemented
- corresponding methods for edit controls.
+ * event-activate and event-deactivate GFs so applications can respond
+ to window activation state changes.
-. Defined generic functions for configuring auto-scrolling and scrollbar
- visibility. Implemented corresponding methods for edit controls.
+ * GFs for querying undo and redo state. Implemented corresponding
+ methods for edit controls.
-. Defined generic functions representing text clipboard data convenience
- functionality. Implemented corresponding methods for edit controls.
+ * GFs for configuring auto-scrolling and scrollbar visibility. Implemented
+ corresponding methods for edit controls.
+
+ * GFs representing text clipboard data convenience functionality.
+ Implemented corresponding methods for edit controls.
. Made other miscellaneous improvements to flesh out edit control
support.
Modified: trunk/src/uitoolkit/graphics/color.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/color.lisp (original)
+++ trunk/src/uitoolkit/graphics/color.lisp Mon Aug 21 12:51:48 2006
@@ -35,19 +35,21 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro color->rgb (color)
- (let ((result (gensym)))
- `(let ((,result 0))
- (setf (ldb (byte 8 0) ,result) (color-red ,color))
- (setf (ldb (byte 8 8) ,result) (color-green ,color))
- (setf (ldb (byte 8 16) ,result) (color-blue ,color))
+ (let ((tmp-color (gensym))
+ (result (gensym)))
+ `(let ((,tmp-color ,color)
+ (,result 0))
+ (setf (ldb (byte 8 0) ,result) (color-red ,tmp-color))
+ (setf (ldb (byte 8 8) ,result) (color-green ,tmp-color))
+ (setf (ldb (byte 8 16) ,result) (color-blue ,tmp-color))
,result)))
(defmacro rgb->color (colorref)
- (let ((color (gensym)))
- `(let ((,color (make-color :red (ldb (byte 8 0) ,colorref)
- :green (ldb (byte 8 8) ,colorref)
- :blue (ldb (byte 8 16) ,colorref))))
- ,color))))
+ (let ((tmp-colorref (gensym)))
+ `(let ((,tmp-colorref ,colorref))
+ (make-color :red (ldb (byte 8 0) ,tmp-colorref)
+ :green (ldb (byte 8 8) ,tmp-colorref)
+ :blue (ldb (byte 8 16) ,tmp-colorref))))))
(defvar *color-black* (make-color :red 0 :green 0 :blue 0))
(defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF))
@@ -57,4 +59,4 @@
(defmethod print-object ((obj color) stream)
(print-unreadable-object (obj stream :type t)
- (format stream "~a,~a,~a" (color-red obj) (color-green obj) (color-blue obj))))
+ (format stream "(~a,~a,~a)" (color-red obj) (color-green obj) (color-blue obj))))
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 21 12:51:48 2006
@@ -62,8 +62,10 @@
`(gfg::font-metrics-leading ,metrics))
(defmacro height (metrics)
- `(+ (gfg::font-metrics-ascent ,metrics)
- (gfg::font-metrics-descent ,metrics)))
+ (let ((tmp-metrics (gensym)))
+ `(let ((,tmp-metrics ,metrics))
+ (+ (gfg::font-metrics-ascent ,tmp-metrics)
+ (gfg::font-metrics-descent ,tmp-metrics)))))
(defmacro average-char-width (metrics)
`(gfg::font-metrics-avg-char-width ,metrics))
Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp (original)
+++ trunk/src/uitoolkit/graphics/image.lisp Mon Aug 21 12:51:48 2006
@@ -38,13 +38,15 @@
;;;
(defmacro with-image-transparency ((image pnt) &body body)
- (let ((orig-pnt (gensym)))
- `(let ((,orig-pnt (transparency-pixel-of ,image)))
+ (let ((tmp-image (gensym))
+ (orig-pnt (gensym)))
+ `(let* ((,tmp-image ,image)
+ (,orig-pnt (transparency-pixel-of ,tmp-image)))
(unwind-protect
(progn
- (setf (transparency-pixel-of ,image) ,pnt)
+ (setf (transparency-pixel-of ,tmp-image) ,pnt)
, at body)
- (setf (transparency-pixel-of ,image) ,orig-pnt)))))
+ (setf (transparency-pixel-of ,tmp-image) ,orig-pnt)))))
(defun clone-bitmap (horig)
(let ((hclone (cffi:null-pointer))
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Mon Aug 21 12:51:48 2006
@@ -50,9 +50,10 @@
`(loop for ,i from 0 below (foreign-type-size (quote ,type)) do
(setf (mem-aref ,object :char ,i) 0))))
-#+lispworks (defun native-object-special-action (obj)
- (if (typep obj 'gfs:native-object)
- (gfs:dispose obj)))
+#+lispworks
+(defun native-object-special-action (obj)
+ (if (typep obj 'gfs:native-object)
+ (gfs:dispose obj)))
;;;
;;; convenience macros
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Aug 21 12:51:48 2006
@@ -37,29 +37,33 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-graphics-context ((gc &optional thing) &body body)
- `(let ((,gc (cond
- ((null ,thing)
- (make-instance 'gfg:graphics-context)) ; DC compatible with display
- ((typep ,thing 'gfw:widget)
- (make-instance 'gfg:graphics-context :widget ,thing))
- ((typep ,thing 'gfg:image)
- (make-instance 'gfg:graphics-context :image ,thing))
- (t
- (error 'gfs:toolkit-error
- :detail (format nil "~a is an unsupported type" ,thing))))))
- (unwind-protect
- (progn
- , at body)
- (gfs:dispose ,gc))))
+ (let ((tmp-thing (gensym)))
+ `(let* ((,tmp-thing ,thing)
+ (,gc (cond
+ ((null ,tmp-thing)
+ (make-instance 'gfg:graphics-context)) ; DC compatible with display
+ ((typep ,tmp-thing 'gfw:widget)
+ (make-instance 'gfg:graphics-context :widget ,tmp-thing))
+ ((typep ,tmp-thing 'gfg:image)
+ (make-instance 'gfg:graphics-context :image ,tmp-thing))
+ (t
+ (error 'gfs:toolkit-error
+ :detail (format nil "~a is an unsupported type" ,tmp-thing))))))
+ (unwind-protect
+ (progn
+ , at body)
+ (gfs:dispose ,gc)))))
(defmacro with-drawing-disabled ((widget) &body body)
- `(unwind-protect
- (progn
- (unless (gfs:disposed-p ,widget)
- (error 'gfs:disposed-error))
- (gfs::lock-window-update (gfs:handle ,widget))
- , at body)
- (gfs::lock-window-update (cffi:null-pointer)))))
+ (let ((tmp-widget (gensym)))
+ `(let ((,tmp-widget ,widget))
+ (unwind-protect
+ (progn
+ (unless (gfs:disposed-p ,tmp-widget)
+ (error 'gfs:disposed-error))
+ (gfs::lock-window-update (gfs:handle ,tmp-widget))
+ , at body)
+ (gfs::lock-window-update (cffi:null-pointer)))))))
(defun translate-and-dispatch (msg-ptr)
(gfs::translate-message msg-ptr)
More information about the Graphic-forms-cvs
mailing list