[mcclim-cvs] CVS mcclim/Experimental/freetype

[ahefner]

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory clnet:/tmp/cvs-serv601/Experimental/freetype

Modified Files:
	freetype-fonts.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/Experimental/freetype/freetype-fonts.lisp	2008/01/05 23:04:15	1.14
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp	2008/01/06 01:37:06	1.15
@@ -458,9 +458,9 @@
                                           (call-next-method)))))))
                        (t
                         (call-next-method)))))))      
-      (if (eq (car lookaside) text-style)
-          (cdr lookaside)
-          (cdr (setf lookaside (cons text-style (f))))))))
+      (cdr (if (eq (car lookaside) text-style)
+               lookaside
+               (setf lookaside (cons text-style (f))))))))
 
 (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style)
   (error "You lost: ~S." text-style))
@@ -569,7 +569,7 @@
   (let* ((drawable (sheet-mirror (medium-sheet medium)))
          (port (port medium)))
     (let ((gc (xlib:create-gcontext :drawable drawable)))
-      (Let ((fn (text-style-to-X-font port text-style)))
+      (let ((fn (text-style-to-X-font port text-style)))
         (if (typep fn 'xlib:font)
             (setf (xlib:gcontext-font gc) fn)))
       (setf 
@@ -623,48 +623,6 @@
               (setf (xlib:gcontext-font gc)
                     fn))))))))
 
-(defmethod medium-gcontext ((medium clx-medium) (ink color))
-  (let* ((port (port medium))
-	 (mirror (port-lookup-mirror port (medium-sheet medium)))
-	 (line-style (medium-line-style medium)))
-    (with-slots (gc) medium
-      (unless gc
-	(setq gc (xlib:create-gcontext :drawable mirror))
-	;; this is kind of false, since the :unit should be taken
-	;; into account -RS 2001-08-24
-	(setf (xlib:gcontext-line-width gc) (line-style-thickness line-style)
-	      (xlib:gcontext-cap-style gc) (line-style-cap-shape line-style)
-	      (xlib:gcontext-join-style gc) (line-style-joint-shape line-style))
-	(let ((dashes (line-style-dashes line-style)))
-	  (unless (null dashes)
-	    (setf (xlib:gcontext-line-style gc) :dash
-		  (xlib:gcontext-dashes gc) (if (eq dashes t) 3
-						dashes)))))
-      (setf (xlib:gcontext-function gc) boole-1)
-      (let ((fn (text-style-to-X-font port (medium-text-style medium))))
-        (when (typep fn 'xlib:font)
-          (setf (xlib:gcontext-font gc) fn)))
-      (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)))))
-      gc)))
-
 ;;;
 ;;; This fixes the worst offenders making the assumption that drawing
 ;;; would be idempotent.