[mcclim-cvs] CVS mcclim/Experimental/freetype

[crhodes]

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

Modified Files:
	freetype-fonts.lisp 
Log Message:
Merge a hacky but functional implementation of device-font-text-styles, 
working on CLX, mcclim-freetype and postscript backends.  No exported or 
documented functionality for now.


--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp	2005/08/13 14:28:33	1.11
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp	2006/03/10 10:56:01	1.12
@@ -301,9 +301,32 @@
 
 (fmakunbound 'clim-clx::text-style-to-x-font)
 
+(defstruct freetype-device-font-name
+  (font-file (error "missing argument"))
+  (size (error "missing argument")))
+
+(defmethod clim-clx::text-style-to-X-font :around 
+    ((port clim-clx::clx-port) (text-style climi::device-font-text-style))
+  (let ((display (slot-value port 'clim-clx::display))
+        (font-name (climi::device-font-name text-style)))
+    (make-free-type-face display
+                         (freetype-device-font-name-font-file font-name)
+                         (freetype-device-font-name-size font-name))))
+
+(defmethod text-style-mapping :around
+    ((port clim-clx::clx-port) (text-style climi::device-font-text-style)
+     &optional character-set)
+  (values (gethash text-style (clim-clx::port-text-style-mappings port))))
+(defmethod (setf text-style-mapping) :around
+    (value 
+     (port clim-clx::clx-port) 
+     (text-style climi::device-font-text-style)
+     &optional character-set)
+  (setf (gethash text-style (clim-clx::port-text-style-mappings port)) value))
+
 (defparameter *free-type-face-hash* (make-hash-table :test #'equal))
 
-(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) text-style)
+(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style))
   (multiple-value-bind (family face size) 
       (clim:text-style-components text-style)
     (let ((display (clim-clx::clx-port-display port)))