[mcclim-cvs] CVS mcclim

[ahefner]

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv10292

Modified Files:
	gadgets.lisp 
Log Message:
Nicer gadget range handling, and handle stream designators in w-o-a-g.


--- /project/mcclim/cvsroot/mcclim/gadgets.lisp	2008/05/09 22:16:11	1.111
+++ /project/mcclim/cvsroot/mcclim/gadgets.lisp	2008/11/09 19:49:17	1.112
@@ -1405,12 +1405,15 @@
     (:vertical   +identity-transformation+)
     (:horizontal (make-transformation 0 1 1 0 0 0))))
 
-(defun translate-range-value (a mina maxa mino maxo)
+(defun translate-range-value (a mina maxa mino maxo 
+                              &optional (empty-result (/ (+ mino maxo) 2)))
   "When \arg{a} is some value in the range from \arg{mina} to \arg{maxa},
    proportionally translate the value into the range \arg{mino} to \arg{maxo}."
-  (+ mino (* (/ (- a mina)
-                (- maxa mina))          ;### avoid divide by zero here.
-             (- maxo mino))))
+  (if (zerop (- maxa mina))
+      empty-result
+      (+ mino (* (/ (- a mina)
+                    (- maxa mina))
+                 (- maxo mino)))))
 
 ;;;; SETF :after methods
 
@@ -1487,18 +1490,13 @@
   (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
     (declare (ignore y3))
     (multiple-value-bind (minv maxv) (gadget-range* sb)
-      (if (= y1 y2)             ;### fix this in translate-range-value
-          minv
-          (translate-range-value y y1 y2 minv maxv)))))
+      (translate-range-value y y1 y2 minv maxv minv))))
 
 (defun scroll-bar/map-value-to-coordinate (sb v)
   (multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
     (declare (ignore y3))
     (multiple-value-bind (minv maxv) (gadget-range* sb)
-      ;; oops, if the range is empty we lose!
-      (if (= minv maxv)         ;### fix this in translate-range-value
-          y1
-          (round (translate-range-value v minv maxv y1 y2))))))
+      (round (translate-range-value v minv maxv y1 y2 y1)))))
 
 (defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
   (with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
@@ -2666,6 +2664,7 @@
   ;; gadget is ever adopted, and an erase-output-record called on a newer
   ;; gadget-output-record will face a sheet-not-child error when trying
   ;; to disown the never adopted gadget.
+  (setf stream (stream-designator-symbol stream '*standard-output*))
   (let ((gadget-output-record (gensym))
 	(x (gensym))
 	(y (gensym)))