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) ,@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 - ,@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 + ,@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)) - ,@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)) + ,@body) + (gfs::lock-window-update (cffi:null-pointer)))))))

(defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr)