[mcclim-cvs] CVS mcclim/Backends/CLX

[ahefner]

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory clnet:/tmp/cvs-serv601/Backends/CLX

Modified Files:
	medium.lisp 
Log Message:
Eliminate duplicated medium-gcontext method in freetype (it had fallen
behind in maintenance, anyway). Reduced or eliminated consing while
setting medium clipping region.



--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2007/07/19 06:55:39	1.82
+++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2008/01/06 01:37:06	1.83
@@ -37,6 +37,9 @@
 (defclass clx-medium (basic-medium)
   ((gc :initform nil)
    (picture :initform nil)
+   (clipping-region-tmp :initform (vector 0 0 0 0)
+     :documentation "This object is reused to avoid consing in the
+ most common case when configuring the clipping region.")
    (buffer :initform nil :accessor medium-buffer)))
 
 #+CLX-EXT-RENDER
@@ -100,25 +103,40 @@
 		  ((t nil) 3)
 		  (otherwise (line-style-dashes line-style)))))))))
 
+(defun %set-gc-clipping-region (medium gc)
+  (declare (type clx-medium medium))
+  (let ((clipping-region (medium-device-region medium))
+        (tmp (slot-value medium 'clipping-region-tmp))
+        (port (port medium)))
+    (cond 
+      ((region-equal clipping-region +nowhere+)
+       (setf (xlib:gcontext-clip-mask gc) #()))
+      ((typep clipping-region 'standard-rectangle)
+       (multiple-value-bind (x1 y1 width height)
+           (region->clipping-values clipping-region)
+         (setf (aref tmp 0) x1
+               (aref tmp 1) y1
+               (aref tmp 2) width
+               (aref tmp 3) height
+               (xlib:gcontext-clip-mask gc :unsorted) tmp)))
+      (t
+        (let ((rect-seq (clipping-region->rect-seq clipping-region)))
+          (when rect-seq
+            #+nil
+            ;; ok, what McCLIM is generating is not :yx-banded...
+            ;; (currently at least)
+            (setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq)
+            #-nil
+            ;; the region code doesn't support yx-banding...
+            ;; or does it? what does y-banding mean in this implementation?
+            ;; well, apparantly it doesn't mean what y-sorted means
+            ;; to clx :] we stick with :unsorted until that can be sorted out
+            (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq)))))))
+
 (defmethod (setf medium-clipping-region) :after (region (medium clx-medium))
   (declare (ignore region))
   (with-slots (gc) medium
-    (when gc
-      (let ((clipping-region (medium-device-region medium)))
-        (if (region-equal clipping-region +nowhere+)
-	    (setf (xlib:gcontext-clip-mask gc) #())
-	    (let ((rect-seq (clipping-region->rect-seq clipping-region)))
-	      (when rect-seq
-		#+nil
-		;; ok, what McCLIM is generating is not :yx-banded...
-		;; (currently at least)
-		(setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq)
-		#-nil
-		;; the region code doesn't support yx-banding...
-		;; or does it? what does y-banding mean in this implementation?
-		;; well, apparantly it doesn't mean what y-sorted means
-		;; to clx :] we stick with :unsorted until that can be sorted out
-		(setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))))))
+    (when gc (%set-gc-clipping-region medium gc))))
   
 
 (defgeneric medium-gcontext (medium ink))
@@ -133,6 +151,7 @@
              (setf (xlib:gcontext-fill-style gc) :solid))))))
 
 (defmethod medium-gcontext ((medium clx-medium) (ink color))
+  (declare (optimize (debug 3)))
   (let* ((port (port medium))
 	 (mirror (port-lookup-mirror port (medium-sheet medium)))
 	 (line-style (medium-line-style medium)))
@@ -151,26 +170,12 @@
 		  (xlib:gcontext-dashes gc) (if (eq dashes t) 3
 						dashes)))))
       (setf (xlib:gcontext-function gc) boole-1)
-      (setf (xlib:gcontext-font gc) (text-style-to-X-font port (medium-text-style medium)))
       (setf (xlib:gcontext-foreground gc) (X-pixel port ink)
 	    (xlib:gcontext-background gc) (X-pixel port (medium-background medium)))
-      ;; Here is a bug with regard to clipping ... ;-( --GB )
-      #-nil ; being fixed at the moment, a bit twitchy though -- BTS
-      (let ((clipping-region (medium-device-region medium)))
-        (if (region-equal clipping-region +nowhere+)
-	    (setf (xlib:gcontext-clip-mask gc) #())
-	    (let ((rect-seq (clipping-region->rect-seq clipping-region)))
-	      (when rect-seq
-		#+nil
-		;; ok, what McCLIM is generating is not :yx-banded...
-		;; (currently at least)
-		(setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq)
-		#-nil
-		;; the region code doesn't support yx-banding...
-		;; or does it? what does y-banding mean in this implementation?
-		;; well, apparantly it doesn't mean what y-sorted means
-		;; to clx :] we stick with :unsorted until that can be sorted out
-		(setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq)))))
+      (let ((fn (text-style-to-X-font port (medium-text-style medium))))
+        (when (typep fn 'xlib:font)
+          (setf (xlib:gcontext-font gc) fn)))
+      (%set-gc-clipping-region medium gc)
       gc)))
 
 (defmethod medium-gcontext ((medium clx-medium) (ink (eql +transparent-ink+)))
@@ -569,22 +574,28 @@
                        (round (rectangle-width rectangle))
                        (round (rectangle-height rectangle)))))
 
+(defun region->clipping-values (region)
+  (with-bounding-rectangle* (min-x min-y max-x max-y) region
+    (let ((clip-x (round-coordinate min-x))
+          (clip-y (round-coordinate min-y)))
+      (values clip-x
+              clip-y
+              (- (round-coordinate max-x) clip-x)
+              (- (round-coordinate max-y) clip-y)))))
+
 ; this seems to work, but find out why all of these +nowhere+s are coming from
 ; and kill them at the source...
 #-nil
 (defun clipping-region->rect-seq (clipping-region)
-  (loop
-     for region in (nreverse (mapcan
-			      (lambda (v) (unless (eq v +nowhere+) (list v)))
-			      (region-set-regions clipping-region
-						  :normalize :y-banding)))
-     as rectangle = (bounding-rectangle region)
-     for clip-x = (round-coordinate (rectangle-min-x rectangle))
-     for clip-y = (round-coordinate (rectangle-min-y rectangle))
-     nconcing (list clip-x
-		    clip-y
-		    (- (round-coordinate (rectangle-max-x rectangle)) clip-x)
-		    (- (round-coordinate (rectangle-max-y rectangle)) clip-y))))
+  (typecase clipping-region 
+    (area (multiple-value-list (region->clipping-values clipping-region)))
+    (t (loop 
+          for region in (nreverse (mapcan
+                                   (lambda (v) (unless (eq v +nowhere+) (list v)))
+                                   (region-set-regions clipping-region
+                                                       :normalize :y-banding)))
+          nconcing (multiple-value-list (region->clipping-values region))))))
+    
 
 (defmacro with-clx-graphics ((medium) &body body)
   `(let* ((port (port ,medium))