First shot at a CFFI-based freetype to replace sbcl/cmucl-specific original.

4 files changed, 1293 insertions, 0 deletions

diff --git a/Experimental/freetype/freetype-cffi.lisp b/Experimental/freetype/freetype-cffi.lisp
new file mode 100644
index 00000000..4df3cf9e
--- /dev/null
+++ b/Experimental/freetype/freetype-cffi.lisp
@@ -0,0 +1,490 @@
+;;; automatically generated, hand tweaked, do not regenerate.
+
+(in-package :freetype)
+
+(define-foreign-library libfreetype
+    (:unix (:or "libfreetype.so.6" "libfreetype"))
+  (t (:default "libfreetype")))
+(use-foreign-library libfreetype)
+
+(defmacro define-alien-type (&rest rest)
+  ;; cffi seems to have a much simpler model of pointer
+  ;; types... [2006/05/23:rpg]
+  (cond ((and (= (length rest) 2)
+	      (eq (car (second rest)) '*))
+	 `(defctype ,(first rest) :pointer))
+	((error "Don't understand how to translate alien type definition ~S"
+		`(define-alien-type ,@rest)))))  
+
+(defmacro define-alien-routine (name retval &rest args)
+  `(defcfun ,name ,retval
+     ,@(loop for (name type) in args
+	     for new-type = (if (and (listp type)
+				     (eq (car type) '*))
+				:pointer
+				type)
+	     collect (list name new-type))))
+
+(defmacro defcstruct (name &rest slots)
+  `(cffi:defcstruct ,name 
+     ,@(loop for (name type) in slots
+	     for new-type = (if (and (listp type)
+				     (eq (car type) '*))
+				:pointer
+				type)
+	     collect (list name new-type))))
+				     
+(declaim (optimize (speed 3)))
+
+(define-alien-type freetype:memory (* (struct freetype::memory-rec-)))
+(define-alien-type freetype:stream (* (struct freetype::stream-rec-)))
+(define-alien-type freetype:raster (* (struct freetype::raster-rec-)))
+(define-alien-type freetype:list-node (* (struct freetype::list-node-rec-)))
+(define-alien-type freetype:list (* (struct freetype::list-rec-)))
+(define-alien-type freetype:library (* (struct freetype::library-rec-)))
+(define-alien-type freetype:module (* (struct freetype::module-rec-)))
+(define-alien-type freetype:driver (* (struct freetype::driver-rec-)))
+(define-alien-type freetype:renderer (* (struct freetype::renderer-rec-)))
+(define-alien-type freetype:char-map (* (struct freetype::char-map-rec-)))
+(define-alien-type freetype:face-internal (* (struct freetype::face-internal-rec-)))
+(define-alien-type freetype:slot-internal (* (struct freetype::slot-internal-rec-)))
+(define-alien-type freetype:size-internal (* (struct freetype::size-internal-rec-)))
+
+(defctype freetype:int16 :int16)
+
+(defctype freetype:uint16 :uint16)
+
+(defctype freetype:int32 :int32)
+
+(defctype freetype:uint32 :uint32)
+
+(defctype freetype:fast :int32)
+
+(defctype freetype:ufast :uint32)
+
+(defctype freetype:ptrdiff-t :int32)
+
+(defctype freetype:size-t :uint32)
+
+(defctype freetype:wchar-t :int32)
+
+(defctype freetype:wint-t :uint32)
+
+(defctype freetype:bool :uint8)
+
+(defctype freetype:fword :int16)
+
+(defctype freetype:ufword :uint16)
+
+(defctype freetype:char :int8)
+
+(defctype freetype:byte :uint8)
+
+(defctype freetype:string :int8)
+
+(defctype freetype:short :int16)
+
+(defctype freetype:ushort :uint16)
+
+(defctype freetype:int :int32)
+
+(defctype freetype:uint :uint32)
+
+(defctype freetype:long :long)
+
+(defctype freetype:ulong :unsigned-long)
+
+(defctype freetype:f2dot14 :int16)
+
+(defctype freetype:f26dot6 :long)
+
+(defctype freetype:fixed :long)
+
+(defctype freetype:error :int32)
+
+(defctype freetype:pointer :pointer)
+
+(defctype freetype:offset freetype:size-t)
+
+(defctype freetype:ptr-dist freetype:size-t)
+
+(define-alien-type freetype:face (* freetype:face-rec))
+
+
+(defcenum mod-err
+    (:mod-err-base #.#x000)
+  (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300)
+  (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800)
+  (:mod-err-sfnt #.#x900) (:mod-err-smooth #.#xA00) (:mod-err-true-type #.#xB00) (:mod-err-type1 #.#xC00)
+  (:mod-err-winfonts #.#xD00)
+  :mod-err-max)
+
+(defcenum error-enum
+ (:err-ok #.#x00) (:err-cannot-open-resource #.(+ #x01 0)) (:err-unknown-file-format #.(+ #x02 0))
+  (:err-invalid-file-format #.(+ #x03 0)) (:err-invalid-version #.(+ #x04 0)) (:err-lower-module-version #.(+ #x05 0))
+  (:err-invalid-argument #.(+ #x06 0)) (:err-unimplemented-feature #.(+ #x07 0)) (:err-invalid-glyph-index #.(+ #x10 0))
+  (:err-invalid-character-code #.(+ #x11 0)) (:err-invalid-glyph-format #.(+ #x12 0)) (:err-cannot-render-glyph #.(+ #x13 0))
+  (:err-invalid-outline #.(+ #x14 0)) (:err-invalid-composite #.(+ #x15 0)) (:err-too-many-hints #.(+ #x16 0))
+  (:err-invalid-pixel-size #.(+ #x17 0)) (:err-invalid-handle #.(+ #x20 0)) (:err-invalid-library-handle #.(+ #x21 0))
+  (:err-invalid-driver-handle #.(+ #x22 0)) (:err-invalid-face-handle #.(+ #x23 0)) (:err-invalid-size-handle #.(+ #x24 0))
+  (:err-invalid-slot-handle #.(+ #x25 0)) (:err-invalid-char-map-handle #.(+ #x26 0)) (:err-invalid-cache-handle #.(+ #x27 0))
+  (:err-invalid-stream-handle #.(+ #x28 0)) (:err-too-many-drivers #.(+ #x30 0)) (:err-too-many-extensions #.(+ #x31 0))
+  (:err-out-of-memory #.(+ #x40 0)) (:err-unlisted-object #.(+ #x41 0)) (:err-cannot-open-stream #.(+ #x51 0))
+  (:err-invalid-stream-seek #.(+ #x52 0)) (:err-invalid-stream-skip #.(+ #x53 0)) (:err-invalid-stream-read #.(+ #x54 0))
+  (:err-invalid-stream-operation #.(+ #x55 0)) (:err-invalid-frame-operation #.(+ #x56 0))
+  (:err-nested-frame-access #.(+ #x57 0)) (:err-invalid-frame-read #.(+ #x58 0)) (:err-raster-uninitialized #.(+ #x60 0))
+  (:err-raster-corrupted #.(+ #x61 0)) (:err-raster-overflow #.(+ #x62 0)) (:err-raster-negative-height #.(+ #x63 0))
+  (:err-too-many-caches #.(+ #x70 0)) (:err-invalid-opcode #.(+ #x80 0)) (:err-too-few-arguments #.(+ #x81 0))
+  (:err-stack-overflow #.(+ #x82 0)) (:err-code-overflow #.(+ #x83 0)) (:err-bad-argument #.(+ #x84 0))
+  (:err-divide-by-zero #.(+ #x85 0)) (:err-invalid-reference #.(+ #x86 0)) (:err-debug-op-code #.(+ #x87 0))
+  (:err-endf-in-exec-stream #.(+ #x88 0)) (:err-nested-defs #.(+ #x89 0)) (:err-invalid-code-range #.(+ #x8A 0))
+  (:err-execution-too-long #.(+ #x8B 0)) (:err-too-many-function-defs #.(+ #x8C 0))
+  (:err-too-many-instruction-defs #.(+ #x8D 0)) (:err-table-missing #.(+ #x8E 0)) (:err-horiz-header-missing #.(+ #x8F 0))
+  (:err-locations-missing #.(+ #x90 0)) (:err-name-table-missing #.(+ #x91 0)) (:err-cmap-table-missing #.(+ #x92 0))
+  (:err-hmtx-table-missing #.(+ #x93 0)) (:err-post-table-missing #.(+ #x94 0)) (:err-invalid-horiz-metrics #.(+ #x95 0))
+  (:err-invalid-char-map-format #.(+ #x96 0)) (:err-invalid-ppem #.(+ #x97 0)) (:err-invalid-vert-metrics #.(+ #x98 0))
+  (:err-could-not-find-context #.(+ #x99 0)) (:err-invalid-post-table-format #.(+ #x9A 0))
+  (:err-invalid-post-table #.(+ #x9B 0)) (:err-syntax-error #.(+ #xA0 0)) (:err-stack-underflow #.(+ #xA1 0)) :err-max)
+
+(defctype freetype:alloc-func :pointer)
+
+(defctype freetype:free-func :pointer)
+
+(defctype freetype:realloc-func :pointer)
+
+(defcstruct freetype::memory-rec-
+    (freetype:user :pointer) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func)
+  (freetype:realloc freetype:realloc-func))
+
+(defcunion freetype:stream-desc 
+      (freetype:value :long) 
+      (freetype:pointer :pointer))
+
+(defctype freetype:stream-io :pointer)
+
+(defctype freetype:stream-close :pointer)
+
+(defcstruct freetype::stream-rec-
+            (freetype:base (* :uint8))
+            (freetype:size freetype:ulong)
+            (freetype:pos freetype:ulong)
+            (freetype:descriptor freetype:stream-desc)
+            (freetype:pathname freetype:stream-desc)
+            (freetype:read freetype:stream-io)
+            (freetype:close freetype:stream-close)
+            (freetype:memory freetype:memory)
+            (freetype:cursor (* :uint8))
+            (freetype:limit (* :uint8)))
+
+(defctype freetype:pos :long)
+
+(defcstruct freetype:vector (freetype:x freetype:pos) (freetype:y freetype:pos))
+
+(defcstruct freetype:bbox
+    (freetype:x-min freetype:pos) (freetype:y-min freetype:pos) (freetype:x-max freetype:pos)
+    (freetype:y-max freetype:pos))
+
+;; seems like pixel-mode- might possibly be an alias for this...
+(defcenum freetype:pixel-mode
+    (:ft-pixel-mode-none #.#o0) :ft-pixel-mode-mono :ft-pixel-mode-grays :ft-pixel-mode-pal2
+  :ft-pixel-mode-pal4 :ft-pixel-mode-pal8 :ft-pixel-mode-rgb15 :ft-pixel-mode-rgb16 :ft-pixel-mode-rgb24 :ft-pixel-mode-rgb32
+  :ft-pixel-mode-max)
+
+;;; palette-mode-
+(defcenum freetype:palette-mode
+ (:ft-palette-mode-rgb #.#o0) :ft-palette-mode-rgba :ft-palettte-mode-max)
+
+(defcstruct freetype:bitmap
+ (freetype:rows :int32) (freetype:width :int32) (freetype:pitch :int32)
+  (freetype:buffer (* :uint8)) (freetype:num-grays :int16) (freetype:pixel-mode :int8)
+  (freetype:palette-mode :int8) (freetype:palette :pointer))
+
+(defcstruct freetype:outline
+ (freetype:n-contours :int16) (freetype:n-points :int16)
+  (freetype:points (* freetype:vector)) (freetype:tags (* :int8)) (freetype:contours (* :int16))
+  (freetype:flags :int32))
+
+(defcenum freetype:outline-flags
+ (:ft-outline-none #.#o0) (:ft-outline-owner #.1) (:ft-outline-even-odd-fill #.2)
+  (:ft-outline-reverse-fill #.4) (:ft-outline-ignore-dropouts #.8) (:ft-outline-high-precision #.256)
+  (:ft-outline-single-pass #.512))
+
+(defctype freetype:outline-move-to-func :pointer)
+
+(defctype freetype:outline-line-to-func :pointer)
+
+(defctype freetype:outline-conic-to-func :pointer)
+
+(defctype freetype:outline-cubic-to-func :pointer)
+
+(defcstruct freetype:outline-funcs
+  (freetype:move-to freetype:outline-move-to-func)
+  (freetype:line-to freetype:outline-line-to-func) (freetype:conic-to freetype:outline-conic-to-func)
+  (freetype:cubic-to freetype:outline-cubic-to-func) (freetype:shift :int32) (freetype:delta freetype:pos))
+
+(defcenum freetype:glyph-format
+  (:ft-glyph-format-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0))
+  (:ft-glyph-format-composite
+   #.(logior (logior (logior (ash #.(char-code #\c) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\m) 8))
+             #.(char-code #\p)))
+  (:ft-glyph-format-bitmap
+   #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\t) 8))
+             #.(char-code #\s)))
+  (:ft-glyph-format-outline
+   #.(logior (logior (logior (ash #.(char-code #\o) 24) (ash #.(char-code #\u) 16)) (ash #.(char-code #\t) 8))
+             #.(char-code #\l)))
+  (:ft-glyph-format-plotter
+   #.(logior (logior (logior (ash #.(char-code #\p) 24) (ash #.(char-code #\l) 16)) (ash #.(char-code #\o) 8))
+             #.(char-code #\t))))
+
+(defcstruct freetype:span
+  (freetype:x :int16) (freetype:len :uint16) (freetype:coverage :uint8))
+
+(defctype freetype:raster-span-func :pointer)
+
+(defctype freetype:raster-bit-test-func :pointer)
+
+(defctype freetype:raster-bit-set-func :pointer)
+
+(defcenum freetype:raster-flag
+  (:ft-raster-flag-default #.#o0) (:ft-raster-flag-aa #.1) (:ft-raster-flag-direct #.2) (:ft-raster-flag-clip #.4))
+
+(defcstruct freetype:raster-params
+  (freetype:target (* freetype:bitmap)) (freetype:source :pointer) (freetype:flags :int32)
+  (freetype:gray-spans freetype:raster-span-func) (freetype:black-spans freetype:raster-span-func)
+  (freetype:bit-test freetype:raster-bit-test-func) (freetype:bit-set freetype:raster-bit-set-func) (freetype:user :pointer)
+  (freetype:clip-box freetype:bbox))
+
+(defctype freetype:raster-new-func :pointer)
+
+(defctype freetype:raster-done-func :pointer)
+
+(defctype freetype:raster-reset-func :pointer)
+
+(defctype freetype:raster-set-mode-func :pointer)
+
+(defctype freetype:raster-render-func :pointer)
+
+(defcstruct freetype:raster-funcs
+ (freetype:glyph-format freetype:glyph-format) (freetype:raster-new freetype:raster-new-func)
+  (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func)
+  (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))
+
+(defcstruct freetype:unit-vector
+ (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))
+
+(defcstruct freetype:matrix
+ (freetype:xx freetype:fixed) (freetype:xy freetype:fixed) (freetype:yx freetype:fixed)
+  (freetype:yy freetype:fixed))
+
+(defctype freetype:generic-finalizer :pointer)
+
+(defcstruct freetype:generic
+ (freetype:data :pointer) (freetype:finalizer freetype:generic-finalizer))
+
+(defcstruct freetype:list-node-rec
+ (freetype:prev freetype:list-node) (freetype:next freetype:list-node) (freetype:data :pointer))
+
+(defcstruct freetype:list-rec
+ (freetype:head freetype:list-node) (freetype:tail freetype:list-node))
+
+(defcstruct freetype:glyph-metrics
+ (freetype:width freetype:pos) (freetype:height freetype:pos)
+  (freetype:hori-bearing-x freetype:pos) (freetype:hori-bearing-y freetype:pos) (freetype:hori-advance freetype:pos)
+  (freetype:vert-bearing-x freetype:pos) (freetype:vert-bearing-y freetype:pos) (freetype:vert-advance freetype:pos))
+
+(defcstruct freetype:bitmap-size
+ (freetype:height freetype:short) (freetype:width freetype:short))
+
+(defctype freetype:sub-glyph :pointer)
+;;    (struct freetype::sub-glyph-))
+
+(defcstruct freetype:glyph-slot-rec
+ (freetype:library freetype:library) (freetype:face (* (struct freetype::face-rec-)))
+  (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic)
+  (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed)
+  (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format)
+  (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int)
+  (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph))
+  (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer)
+  (freetype:internal freetype:slot-internal))
+
+(defcstruct freetype:size-metrics
+ (freetype:x-ppem freetype:ushort) (freetype:y-ppem freetype:ushort)
+  (freetype:x-scale freetype:fixed) (freetype:y-scale freetype:fixed) (freetype:ascender freetype:pos)
+  (freetype:descender freetype:pos) (freetype:height freetype:pos) (freetype:max-advance freetype:pos))
+
+(defcstruct freetype:size-rec
+ (freetype:face (* (struct freetype::face-rec-))) (freetype:generic freetype:generic)
+  (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal))
+
+(defcstruct freetype:face-rec
+ (freetype:num-faces freetype:long) (freetype:face-index freetype:long)
+            (freetype:face-flags freetype:long) (freetype:style-flags freetype:long) (freetype:num-glyphs freetype:long)
+            (freetype:family-name (* freetype:string)) (freetype:style-name (* freetype:string)) (freetype:num-fixed-sizes freetype:int)
+            (freetype:available-sizes (* freetype:bitmap-size)) (freetype:num-charmaps freetype:int)
+            (freetype:charmaps (* freetype:char-map)) (freetype:generic freetype:generic) (freetype:bbox freetype:bbox)
+            (freetype:units-per-em freetype:ushort) (freetype:ascender freetype:short) (freetype:descender freetype:short)
+            (freetype:height freetype:short) (freetype:max-advance-width freetype:short) (freetype:max-advance-height freetype:short)
+            (freetype:underline-position freetype:short) (freetype:underline-thickness freetype:short)
+            (freetype:glyph (* (struct freetype::glyph-slot-rec-)))
+	    (freetype:size_s (* (struct freetype:size-rec))) (freetype:charmap freetype:char-map)
+            (freetype:driver freetype:driver) (freetype:memory freetype:memory) (freetype:stream freetype:stream)
+            (freetype:sizes-list freetype:list-rec) (freetype:autohint freetype:generic) (freetype:extensions :pointer)
+            (freetype:internal freetype:face-internal))
+
+(defcstruct freetype:size-rec
+    (freetype:face (* freetype:face-rec))
+  (freetype:generic freetype:generic)
+  (freetype:metrics freetype:size-metrics)
+  (freetype:internal freetype:size-internal))
+
+(defcstruct freetype:glyph-slot-rec
+ (freetype:library freetype:library) (freetype:face (* freetype:face-rec))
+  (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic)
+  (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed)
+  (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format)
+  (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int)
+  (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph))
+  (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer)
+  (freetype:internal freetype:slot-internal))
+
+(define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec))
+(define-alien-type freetype:size (* freetype:size-rec))
+
+(define-alien-routine ("FT_Init_FreeType" freetype:init-free-type) freetype:error (freetype::alibrary (* freetype:library)))
+
+(define-alien-routine ("FT_Done_FreeType" freetype:done-free-type) freetype:error (freetype:library freetype:library))
+
+(defcenum freetype:open-flags
+  (:ft-open-memory #.1) (:ft-open-stream #.2) (:ft-open-pathname #.4) (:ft-open-driver #.8) (:ft-open-params #.16))
+
+(defcstruct freetype:parameter (freetype:tag freetype:ulong) (freetype:data freetype:pointer))
+
+(defcstruct freetype:open-args
+ (freetype:flags freetype:open-flags) (freetype:memory-base (* freetype:byte))
+  (freetype:memory-size freetype:long) (freetype:pathname (* freetype:string)) (freetype:stream freetype:stream)
+  (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter)))
+
+(define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error
+  (freetype:library freetype:library)
+  (freetype::filepathname :string)
+  (freetype::face_index freetype:long)
+  ;; this is a pointer to a pointer to a face-rec...
+  (freetype::aface (* (* freetype:face-rec))))
+
+(define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library)
+ (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long)
+ (freetype::aface (* freetype:face)))
+
+(define-alien-routine ("FT_Open_Face" freetype:open-face) freetype:error (freetype:library freetype:library)
+ (freetype::args (* freetype:open-args)) (freetype::face_index freetype:long) (freetype::aface (* freetype:face)))
+
+(define-alien-routine ("FT_Attach_File" freetype:attach-file) freetype:error (freetype:face freetype:face)
+ (freetype::filepathname (* :int8)))
+
+(define-alien-routine ("FT_Attach_Stream" freetype:attach-stream) freetype:error (freetype:face freetype:face)
+ (freetype::parameters (* freetype:open-args)))
+
+(define-alien-routine ("FT_Done_Face" freetype:done-face) freetype:error (freetype:face freetype:face))
+
+(define-alien-routine ("FT_Set_Char_Size" freetype:set-char-size) freetype:error (freetype:face freetype:face)
+ (freetype::char_width freetype:f26dot6) (freetype::char_height freetype:f26dot6) (freetype::horz_resolution freetype:uint)
+ (freetype::vert_resolution freetype:uint))
+
+(define-alien-routine ("FT_Set_Pixel_Sizes" freetype:set-pixel-sizes) freetype:error (freetype:face freetype:face)
+ (freetype::pixel_width freetype:uint) (freetype::pixel_height freetype:uint))
+
+(define-alien-routine ("FT_Load_Glyph" freetype:load-glyph) freetype:error (freetype:face freetype:face)
+ (freetype::glyph_index freetype:uint) (freetype::load_flags freetype:int))
+
+(define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face)
+ (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int))
+
+(define-alien-routine ("FT_Set_Transform" freetype:set-transform) :void (freetype:face freetype:face)
+ (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector)))
+
+(defcenum freetype:render-mode
+    (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1))
+
+(define-alien-routine ("FT_Render_Glyph" freetype:render-glyph) freetype:error (freetype::slot freetype:glyph-slot)
+ (freetype::render_mode freetype:uint))
+
+(defcenum freetype::kerning-mode-
+    (:ft-kerning-default #.#o0) :ft-kerning-unfitted :ft-kerning-unscaled)
+
+(define-alien-routine ("FT_Get_Kerning" freetype:get-kerning) freetype:error (freetype:face freetype:face)
+ (freetype::left_glyph freetype:uint) (freetype::right_glyph freetype:uint) (freetype::kern_mode freetype:uint)
+ (freetype::akerning (* freetype:vector)))
+
+(define-alien-routine ("FT_Get_Glyph_Name" freetype:get-glyph-name) freetype:error (freetype:face freetype:face)
+ (freetype::glyph_index freetype:uint) (freetype:buffer freetype:pointer) (freetype::buffer_max freetype:uint))
+
+(define-alien-routine ("FT_Get_Char_Index" freetype:get-char-index) freetype:uint (freetype:face freetype:face)
+ (freetype::charcode freetype:ulong))
+
+(define-alien-routine ("FT_MulDiv" freetype:mul-div) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)
+ (freetype::c freetype:long))
+
+(define-alien-routine ("FT_MulFix" freetype:mul-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long))
+
+(define-alien-routine ("FT_DivFix" freetype:div-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long))
+
+(define-alien-routine ("FT_RoundFix" freetype:round-fix) freetype:fixed (freetype::a freetype:fixed))
+
+(define-alien-routine ("FT_CeilFix" freetype:ceil-fix) freetype:fixed (freetype::a freetype:fixed))
+
+(define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed))
+
+(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) :void (freetype::vec (* freetype:vector))
+ (freetype:matrix (* freetype:matrix)))
+
+(defcenum freetype:encoding
+ (:ft-encoding-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0))
+  (:ft-encoding-symbol
+   #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\y) 16)) (ash #.(char-code #\m) 8))
+             #.(char-code #\b)))
+  (:ft-encoding-unicode
+   #.(logior (logior (logior (ash #.(char-code #\u) 24) (ash #.(char-code #\n) 16)) (ash #.(char-code #\i) 8))
+             #.(char-code #\c)))
+  (:ft-encoding-latin-2
+   #.(logior (logior (logior (ash #.(char-code #\l) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\t) 8))
+             #.(char-code #\2)))
+  (:ft-encoding-sjis
+   #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\j) 16)) (ash #.(char-code #\i) 8))
+             #.(char-code #\s)))
+  (:ft-encoding-gb2312
+   #.(logior (logior (logior (ash #.(char-code #\g) 24) (ash #.(char-code #\b) 16)) (ash #.(char-code #\ ) 8))
+             #.(char-code #\ )))
+  (:ft-encoding-big5
+   #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\g) 8))
+             #.(char-code #\5)))
+  (:ft-encoding-wansung
+   #.(logior (logior (logior (ash #.(char-code #\w) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\n) 8))
+             #.(char-code #\s)))
+  (:ft-encoding-johab
+   #.(logior (logior (logior (ash #.(char-code #\j) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\h) 8))
+             #.(char-code #\a)))
+  (:ft-encoding-adobe-standard
+   #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\O) 8))
+             #.(char-code #\B)))
+  (:ft-encoding-adobe-expert
+   #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8))
+             #.(char-code #\E)))
+  (:ft-encoding-adobe-custom
+   #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8))
+             #.(char-code #\C)))
+  (:ft-encoding-apple-roman
+   #.(logior (logior (logior (ash #.(char-code #\a) 24) (ash #.(char-code #\r) 16)) (ash #.(char-code #\m) 8))
+             #.(char-code #\n))))
+
+#|
+(define-alien-type freetype:char-map-rec
+ (struct freetype::char-map-rec- (freetype:face freetype:face) (freetype:encoding freetype:encoding)
+  (freetype:platform-id freetype:ushort) (freetype:encoding-id freetype:ushort)))
+|#
+
+(define-alien-routine ("FT_Select_Charmap" freetype:select-charmap) freetype:error (freetype:face freetype:face)
+ (freetype:encoding freetype:encoding))
+
+(define-alien-routine ("FT_Set_Charmap" freetype:set-charmap) freetype:error (freetype:face freetype:face) (freetype:charmap freetype:char-map))
diff --git a/Experimental/freetype/freetype-fonts-cffi.lisp b/Experimental/freetype/freetype-fonts-cffi.lisp
new file mode 100644
index 00000000..afe884c9
--- /dev/null
+++ b/Experimental/freetype/freetype-fonts-cffi.lisp
@@ -0,0 +1,635 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-FREETYPE; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Experimental FreeType support
+;;;   Created: 2003-05-25 16:32
+;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
+;;;   License: LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2003 by Gilbert Baumann
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :MCCLIM-FREETYPE)
+
+;;; reset safety up to 3 to try to work out some of my problems.  If
+;;; this gets fixed, presumably it should be dropped back down to
+;;; 1... [2006/05/24:rpg]
+(declaim (optimize (speed 3) (safety 3) (debug 3) (space 3)))
+
+;;;; Notes
+
+;; You might need to tweak mcclim-freetype::*families/faces* to point
+;; to where ever there are suitable TTF fonts on your system.
+
+(defclass vague-font ()
+  ((lib :initarg :lib)
+   (filename :initarg :filename)))
+
+(defparameter *vague-font-hash* (make-hash-table :test #'equal))
+
+(defun make-vague-font (filename)
+  (let ((val (gethash filename *vague-font-hash*)))
+    (or val
+        (setf (gethash filename *vague-font-hash*)
+	      (make-instance 'vague-font
+		:lib
+		;; I am not at all sure that this is the
+		;; right translation --- because of the
+		;; difference between SBCL aliens and
+		;; CFFI, I'm not sure what the deref was
+		;; intended to achieve... [2006/05/24:rpg]
+		(let ((libf (cffi:foreign-alloc 'freetype:library)))
+		  (freetype:init-free-type libf)
+		  (cffi:mem-aref libf 'freetype:library))
+;;;			     (let ((libf (make-alien freetype:library)))
+;;;                                    (declare (type (alien (* freetype:library)) libf))
+;;;                                    (freetype:init-free-type libf)
+;;;                                    (deref libf))
+		:filename filename)))))
+
+(defparameter *dpi* 72)
+
+(defparameter *concrete-font-hash* (make-hash-table :test #'equal))
+
+(defun make-concrete-font (vague-font size &key (dpi *dpi*))
+  (with-slots (lib filename) vague-font
+    (let* ((key (cons lib filename))
+           (val (gethash key *concrete-font-hash*)))
+      (unless val
+        (let ((facef
+	       ;; this will allocate a pointer (notionally to a
+	       ;; face-rec), and return a pointer to it (the pointer).
+	       (foreign-alloc 'freetype:face)
+	       ;;(make-alien freetype:face))
+	      ))
+          ;;(declare (type (alien (* freetype:face)) facef))
+          (if (zerop (freetype:new-face lib filename 0 facef))
+              (setf val (setf (gethash key *concrete-font-hash*)
+			      (cffi:mem-ref facef 'freetype:face)))
+	      
+;;;	      (setf val (setf (gethash key *concrete-font-hash*)
+;;;                              (deref facef)))
+              (error "Freetype error in make-concrete-font"))))
+      (let ((face val))
+        ;; (declare (type (alien freetype:face) face))
+        (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi))
+        face))))
+
+(declaim (inline make-concrete-font))
+
+(defun glyph-pixarray (face char)
+;;;  (declare (optimize (speed 3) (debug 1))
+;;;           (inline freetype:load-glyph freetype:render-glyph)
+;;;           (type (alien freetype:face) face))
+  (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0)
+  (freetype:render-glyph (foreign-slot-value face 'freetype:face-rec 'freetype:glyph) 0)
+  (with-foreign-slots ((glyph) face freetype:face-rec)
+    (with-foreign-slots ((bitmap) glyph freetype:glyph-slot-rec)
+      (with-foreign-slots ((width pitch rows buffer) bitmap freetype:bitmap)
+	(let ((res
+	       (make-array (list rows width)
+			   :element-type '(unsigned-byte 8))))
+;;;    (let* ((width  (slot bm 'freetype:width))
+;;;           (pitch  (slot bm 'freetype:pitch))
+;;;           (height (slot bm 'freetype:rows))
+;;;           (buffer (slot bm 'freetype:buffer))
+;;;           (res    (make-array (list height width) :element-type '(unsigned-byte 8))))
+	  (declare (type (simple-array (unsigned-byte 8) (* *)) res))
+	  (let ((m (* width rows)))
+	    (locally
+		(declare (optimize (speed 3) (safety 0)))
+	      (loop for y*width of-type fixnum below m by width 
+		  for y*pitch of-type fixnum from 0 by pitch do
+		    (loop for x of-type fixnum below width do
+			  (setf (row-major-aref res (+ x y*width))
+				(cffi:mem-aref buffer :uint8 (+ x y*pitch))
+			    ;; (deref buffer (+ x y*pitch))
+				)))))
+	  (with-foreign-slots ((bitmap-left
+				bitmap-top
+				advance) glyph freetype:glyph-slot-rec)
+	    (with-foreign-slots ((x y) advance freetype:vector)
+	      (values
+	       res
+	       bitmap-left
+	       ;; (slot glyph 'freetype:bitmap-left)
+	       bitmap-top
+	       ;;(slot glyph 'freetype:bitmap-top)
+	       (/ x 64)
+	       ;;(/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64)
+	       (/ y 64)
+	       ;;(/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64)
+	       )
+	      )))))))
+
+(defun glyph-advance (face char)
+  ;; I believe that face is a pointer to a face-rec...
+  ;; note that we're not catching error result here...
+  (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0)
+  (let* ((glyph (foreign-slot-value face 'freetype:face-rec 'freetype:glyph)))
+    ;;; glyph will be a glyph-slot-rec...
+    (with-foreign-slots ((advance) glyph freetype:glyph-slot-rec)
+      (with-foreign-slots ((x y) advance freetype:vector)
+	(values
+	 (/ x 64)
+	 (/ y 64))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun display-glyph-cache (display)
+  (or (getf (xlib:display-plist display) 'glyph-cache)
+      (setf (getf (xlib:display-plist display) 'glyph-cache)
+            (make-hash-table :test #'equalp))))
+
+(defun display-the-glyph-set (display)
+  (or (getf (xlib:display-plist display) 'the-glyph-set)
+      (setf (getf (xlib:display-plist display) 'the-glyph-set)
+            (xlib::render-create-glyph-set
+             (first (xlib::find-matching-picture-formats display
+                                                         :alpha 8 :red 0 :green 0 :blue 0))))))
+
+(defun display-free-glyph-ids (display)
+  (getf (xlib:display-plist display) 'free-glyph-ids))
+
+(defun (setf display-free-glyph-ids) (new-value display)
+  (setf (getf (xlib:display-plist display) 'free-glyph-ids) new-value))
+
+(defun display-free-glyph-id-counter (display)
+  (getf (xlib:display-plist display) 'free-glyph-id-counter 0))
+
+(defun (setf display-free-glyph-id-counter) (new-value display)
+  (setf (getf (xlib:display-plist display) 'free-glyph-id-counter) new-value))
+
+(defun display-draw-glyph-id (display)
+  (or (pop (display-free-glyph-ids display))
+      (incf (display-free-glyph-id-counter display))))
+
+(defun display-get-glyph (display font matrix glyph-index)
+  (or (gethash (list font matrix glyph-index) (display-glyph-cache display))
+      (setf (gethash (list font matrix glyph-index) (display-glyph-cache display))
+            (display-generate-glyph display font matrix glyph-index))))
+
+(defvar *font-hash*
+  (make-hash-table :test #'equalp))
+
+(defun display-generate-glyph (display font matrix glyph-index)
+  (let* ((glyph-id (display-draw-glyph-id display))
+         (font (or (gethash font *font-hash*)
+		   (setf (gethash font *font-hash*)
+			 (make-vague-font font))))
+         (face (make-concrete-font font matrix)))
+    (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index))
+      (when (= (array-dimension arr 0) 0)
+        (setf arr (make-array (list 1 1) :element-type '(unsigned-byte 8) :initial-element 0)))
+      (xlib::render-add-glyph (display-the-glyph-set display) glyph-id
+                              :data arr
+                              :x-origin (- left)
+                              :y-origin top
+                              :x-advance dx
+                              :y-advance dy)
+      (let ((right (+ left (array-dimension arr 1))))
+        (list glyph-id dx dy left right top)))))
+
+;;;;;;; mcclim interface
+
+(defclass freetype-face ()
+  ((display :initarg :display)
+   (font :initarg :font)
+   (matrix :initarg :matrix)
+   (ascent :initarg :ascent)
+   (descent :initarg :descent)))
+
+(defmethod clim-clx::font-ascent ((font freetype-face))
+  (with-slots (ascent) font
+    ascent))
+
+(defmethod clim-clx::font-descent ((font freetype-face))
+  (with-slots (descent) font
+    descent))
+
+(defmethod clim-clx::font-glyph-width ((font freetype-face) char)
+  (with-slots (display font matrix) font
+    (nth 1 (display-get-glyph display font matrix char))))
+(defmethod clim-clx::font-glyph-left ((font freetype-face) char)
+  (with-slots (display font matrix) font
+    (nth 3 (display-get-glyph display font matrix char))))
+(defmethod clim-clx::font-glyph-right ((font freetype-face) char)
+  (with-slots (display font matrix) font
+    (nth 4 (display-get-glyph display font matrix char))))
+
+;;; this is a hacky copy of XLIB:TEXT-EXTENTS
+(defmethod clim-clx::font-text-extents ((font freetype-face) string
+                                        &key (start 0) (end (length string)) translate)
+  ;; -> (width ascent descent left right
+  ;; font-ascent font-descent direction
+  ;; first-not-done)
+  translate
+  (let ((width (loop for i from start below end 
+                     sum (clim-clx::font-glyph-width font (char-code (aref string i))))))
+    (values
+     width
+     (clim-clx::font-ascent font)
+     (clim-clx::font-descent font)
+     (clim-clx::font-glyph-left font (char-code (char string start)))
+     (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end))))
+                 (clim-clx::font-glyph-right font (char-code (char string (1- end))))))
+     (clim-clx::font-ascent font)
+     (clim-clx::font-descent font)
+     0 end)))
+
+(defun drawable-picture (drawable)
+  (or (getf (xlib:drawable-plist drawable) 'picture)
+      (setf (getf (xlib:drawable-plist drawable) 'picture)
+            (xlib::render-create-picture drawable
+                                         :format
+                                         (xlib::find-window-picture-format
+                                          (xlib:drawable-root drawable))))))
+
+(defun gcontext-picture (drawable gcontext)
+  (or (getf (xlib:gcontext-plist gcontext) 'picture)
+      (setf (getf (xlib:gcontext-plist gcontext) 'picture)
+            (let ((pixmap (xlib:create-pixmap :drawable drawable
+                           :depth (xlib:drawable-depth drawable)
+                           :width 1 :height 1)))
+              (list
+               (xlib::render-create-picture
+                pixmap
+                :format (xlib::find-window-picture-format (xlib:drawable-root drawable))
+                :repeat :on)
+               pixmap)))))
+
+(defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate)
+  (declare (ignore translate))
+  (let ((display (xlib:drawable-display mirror)))
+    (with-slots (font matrix) font
+      (destructuring-bind (source-picture source-pixmap)
+	  (gcontext-picture mirror gc)
+	(declare (ignore source-pixmap))
+        (let ((fg (xlib:gcontext-foreground gc)))
+          (xlib::render-fill-rectangle source-picture
+                                       :src
+                                       (list (ash (ldb (byte 8 16) fg) 8)
+                                             (ash (ldb (byte 8 8) fg) 8)
+                                             (ash (ldb (byte 8 0) fg) 8)
+                                             #xFFFF)
+                                       0 0 1 1))
+        (setf (xlib::picture-clip-mask (drawable-picture mirror))
+              (xlib::gcontext-clip-mask gc))
+        (xlib::render-composite-glyphs
+         (drawable-picture mirror)
+         (display-the-glyph-set display)
+         source-picture
+         x y
+         (map 'vector (lambda (x)
+                        (first
+                         (display-get-glyph display font matrix (char-code x))))
+              (subseq string start end)))))))
+
+(let ((cache (make-hash-table :test #'equal)))
+  (defun make-free-type-face (display font size)
+    (or (gethash (list display font size) cache)
+        (setf (gethash (list display font size) cache)
+	  (let* ((f.font (or (gethash font *font-hash*)
+			     (setf (gethash font *font-hash*)
+			       (make-vague-font font))))
+		 (f (make-concrete-font f.font size)))
+	    (with-foreign-slots ((size_s) f freetype:face-rec)
+	      (with-foreign-slots ((metrics) size_s freetype:size-rec)
+		(with-foreign-slots ((ascender descender) metrics freetype:size-metrics)
+		  (make-instance 'freetype-face
+		    :display display
+		    :font font
+		    :matrix size
+		    :ascent  (/ ascender 64)
+		    :descent (/ descender -64))))))))))
+
+(defparameter *sizes*
+  '(:normal 12
+    :small 10
+    :very-small 8
+    :tiny 8
+    :large 14
+    :very-large 18
+    :huge 24))
+
+(defparameter *families/faces*
+  '(((:fix :roman) . "VeraMono.ttf")
+    ((:fix :italic) . "VeraMoIt.ttf")
+    ((:fix (:bold :italic)) . "VeraMoBI.ttf")
+    ((:fix (:italic :bold)) . "VeraMoBI.ttf")
+    ((:fix :bold) . "VeraMoBd.ttf")
+    ((:serif :roman) . "VeraSe.ttf")
+    ((:serif :italic) . "VeraSe.ttf")
+    ((:serif (:bold :italic)) . "VeraSeBd.ttf")
+    ((:serif (:italic :bold)) . "VeraSeBd.ttf")
+    ((:serif :bold) . "VeraSeBd.ttf")
+    ((:sans-serif :roman) . "Vera.ttf")
+    ((:sans-serif :italic) . "VeraIt.ttf")
+    ((:sans-serif (:bold :italic)) . "VeraBI.ttf")
+    ((:sans-serif (:italic :bold)) . "VeraBI.ttf")
+    ((:sans-serif :bold) . "VeraBd.ttf")))
+
+(defvar *freetype-font-path*)
+
+(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)
+  (declare (ignore 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)
+  (declare (ignore 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 standard-text-style))
+  (multiple-value-bind (family face size) 
+      (clim:text-style-components text-style)
+    (let ((display (clim-clx::clx-port-display port)))
+      (setf face (or face :roman))
+      (setf size (or size :normal))
+      (cond (size
+	     (setf size (getf *sizes* size size))
+	     (let ((val (gethash (list display family face size) *free-type-face-hash*)))
+	       (if val val
+		   (setf (gethash (list display family face size) *free-type-face-hash*)
+			 (let* ((font-path-relative (cdr (assoc (list family face) *families/faces*
+								:test #'equal)))
+				(font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*))))
+			   (if (and font-path (probe-file font-path))
+			       (make-free-type-face display font-path size)
+			       (call-next-method)))))))
+	    (t
+	     (call-next-method))))))
+
+(defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style)
+  ;; ok, this isn't the most helpful error message... [2006/05/24:rpg]
+  (error "You lost: ~S." text-style))
+
+;;;;;;
+
+(in-package :clim-clx)
+
+(defmethod text-style-ascent (text-style (medium clx-medium))
+  (let ((font (text-style-to-X-font (port medium) text-style)))
+    (clim-clx::font-ascent font)))
+
+(defmethod text-style-descent (text-style (medium clx-medium))
+  (let ((font (text-style-to-X-font (port medium) text-style)))
+    (clim-clx::font-descent font)))
+
+(defmethod text-style-height (text-style (medium clx-medium))
+  (let ((font (text-style-to-X-font (port medium) text-style)))
+    (+ (clim-clx::font-ascent font) (clim-clx::font-descent font))))
+
+(defmethod text-style-character-width (text-style (medium clx-medium) char)
+  (clim-clx::font-glyph-width (text-style-to-X-font (port medium) text-style) (char-code char)))
+
+(defmethod text-style-width (text-style (medium clx-medium))
+  (text-style-character-width text-style medium #\m))
+
+(defmethod text-size ((medium clx-medium) string &key text-style (start 0) end)
+  (when (characterp string)
+    (setf string (make-string 1 :initial-element string)))
+  (unless end (setf end (length string)))
+  (unless text-style (setf text-style (medium-text-style medium)))
+  (let ((xfont (text-style-to-X-font (port medium) text-style)))
+    (cond ((= start end)
+           (values 0 0 0 0 0))
+          (t
+           (let ((position-newline (position #\newline string :start start)))
+             (cond ((not (null position-newline))
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (font-text-extents xfont string
+                                           :start start :end position-newline
+                                           :translate #'translate)
+                      (declare (ignorable left right
+                                          font-ascent font-descent
+                                          direction first-not-done))
+                      (multiple-value-bind (w h x y baseline)
+                          (text-size medium string :text-style text-style
+                                     :start (1+ position-newline) :end end)
+                        (values (max w width) (+ ascent descent h)
+                                x (+ ascent descent y) (+ ascent descent baseline)))))
+                   (t
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (font-text-extents xfont string
+                                   :start start :end end
+                                   :translate #'translate)
+                      (declare (ignorable left right
+                                          font-ascent font-descent
+                                          direction first-not-done))
+                      (values width (+ ascent descent) width 0 ascent)) )))))) )
+
+(defmethod climi::text-bounding-rectangle*
+    ((medium clx-medium) string &key text-style (start 0) end)
+  (when (characterp string)
+    (setf string (make-string 1 :initial-element string)))
+  (unless end (setf end (length string)))
+  (unless text-style (setf text-style (medium-text-style medium)))
+  (let ((xfont (text-style-to-X-font (port medium) text-style)))
+    (cond ((= start end)
+           (values 0 0 0 0))
+          (t
+           (let ((position-newline (position #\newline string :start start)))
+             (cond ((not (null position-newline))
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (font-text-extents xfont string
+                                           :start start :end position-newline
+                                           :translate #'translate)
+                      (declare (ignorable left right
+                                          font-ascent font-descent
+                                          direction first-not-done)
+			       (ignore width))
+                      (multiple-value-bind (minx miny maxx maxy)
+                          (climi::text-bounding-rectangle*
+                           medium string :text-style text-style
+                           :start (1+ position-newline) :end end)
+			(declare (ignore miny))
+                        (values (min minx left) (- ascent)
+                                (max maxx right) (+ descent maxy)))))
+                   (t
+                    (multiple-value-bind (width ascent descent left right
+                                                font-ascent font-descent direction
+                                                first-not-done)
+                        (font-text-extents xfont string
+                                   :start start :end end
+                                   :translate #'translate)
+                      (declare (ignore width direction first-not-done
+				       descent ascent))
+                      ;; FIXME: Potential style points:
+                      ;; * (min 0 left), (max width right)
+                      ;; * font-ascent / ascent
+                      (values left (- font-ascent) right font-descent)))))))))
+
+
+(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region)
+  (declare (ignore clipping-region line-style background foreground))
+  (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)))
+        (if (typep fn 'xlib:font)
+            (setf (xlib:gcontext-font gc) fn)))
+      (setf 
+            (xlib:gcontext-foreground gc) (X-pixel port ink)
+            )
+      gc)))
+
+(defmethod medium-draw-text* ((medium clx-medium) string x y
+                              start end
+                              align-x align-y
+                              toward-x toward-y transform-glyphs)
+  (declare (ignore toward-x toward-y transform-glyphs))
+  (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
+                              x y)
+    (with-clx-graphics (medium)
+      (when (characterp string)
+        (setq string (make-string 1 :initial-element string)))
+      (when (null end) (setq end (length string)))
+      (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) 
+          (text-size medium string :start start :end end)
+        (declare (ignore x-cursor y-cursor))
+        (unless (and (eq align-x :left) (eq align-y :baseline))	    
+          (setq x (- x (ecase align-x
+                         (:left 0)
+                         (:center (round text-width 2))
+                         (:right text-width))))
+          (setq y (ecase align-y
+                    (:top (+ y baseline))
+                    (:center (+ y baseline (- (floor text-height 2))))
+                    (:baseline y)
+                    (:bottom (+ y baseline (- text-height)))))))
+      (let ((x (round-coordinate x))
+            (y (round-coordinate y)))
+        (when (and (<= #x-8000 x #x7FFF)
+                   (<= #x-8000 y #x7FFF))
+          (multiple-value-bind (halt width)
+              (font-draw-glyphs
+               (text-style-to-X-font (port medium) (medium-text-style medium))
+               mirror gc x y string
+                                :start start :end end
+                                :translate #'translate)))))))
+
+
+(defmethod (setf medium-text-style) :before (text-style (medium clx-medium))
+  (with-slots (gc) medium
+    (when gc
+      (let ((old-text-style (medium-text-style medium)))
+	(unless (eq text-style old-text-style)
+          (let ((fn (text-style-to-X-font (port medium) (medium-text-style medium))))
+            (when (typep fn 'xlib:font)
+              (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.
+;;;
+
+(defmethod clim:handle-repaint :around ((s clim:sheet-with-medium-mixin) r)
+  (let ((m (clim:sheet-medium s))
+        (r (clim:bounding-rectangle
+            (clim:region-intersection r (clim:sheet-region s)))))
+    (unless (eql r clim:+nowhere+)
+      (clim:with-drawing-options (m :clipping-region r)
+        (clim:draw-design m r :ink clim:+background-ink+)
+        (call-next-method s r)))))
+
+
+;;;---------------------------------------------------------------------------
+;;; compiler warnings
+;;;---------------------------------------------------------------------------
+#|
+; While compiling (METHOD CLIM-INTERNALS::TEXT-BOUNDING-RECTANGLE* (CLX-MEDIUM T)):
+Warning: Variable MINY is never used.
+Warning: Variable WIDTH is never used.
+; While compiling (METHOD MAKE-MEDIUM-GCONTEXT* (T T T T T COLOR T)):
+Warning: Variable CLIPPING-REGION is never used.
+Warning: Variable LINE-STYLE is never used.
+Warning: Variable BACKGROUND is never used.
+Warning: Variable FOREGROUND is never used.
+; While compiling (METHOD MEDIUM-DRAW-TEXT* (CLX-MEDIUM T T T T T T T T T T)):
+Warning: Variable WIDTH is never used.
+Warning: Variable HALT is never used.
+|#
\ No newline at end of file
diff --git a/Experimental/freetype/freetype-package-cffi.lisp b/Experimental/freetype/freetype-package-cffi.lisp
new file mode 100644
index 00000000..7e400ebc
--- /dev/null
+++ b/Experimental/freetype/freetype-package-cffi.lisp
@@ -0,0 +1,82 @@
+;;;---------------------------------------------------------------------------
+;;; Moved this here to make loading more convenient for the way I edit
+;;; code [2006/05/23:rpg]
+;;;---------------------------------------------------------------------------
+(DEFPACKAGE :FREETYPE
+    (:import-from :cffi #:define-foreign-library
+		  #:use-foreign-library
+		  #:defctype
+		  #:defcenum
+		  ;;#:defcstruct
+		  #:defcunion
+		  #:defcfun
+		  )
+  (:USE :cl 
+;;;        #+sbcl :sb-alien 
+;;;        #+(or cmu scl) :alien #+(or cmu scl) :c-call
+	)
+            (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS"
+             "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC"
+             "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE"
+             "BITMAP-TOP" "CURSOR" "BITMAP-LEFT" "MODULE" "PIXEL-MODE" "FREE-FUNC" "PITCH" "EXTENSIONS" "RASTER-RENDER-FUNC"
+             "GET-KERNING" "UFWORD" "OPEN-ARGS" "RASTER-FUNCS" "INT32" "PREV" "LOAD-CHAR" "PATHNAME" "HORI-BEARING-Y"
+             "RASTER-RENDER" "ENCODING" "OUTLINE-CONIC-TO-FUNC" "STREAM" "RASTER-RESET" "MOVE-TO" "GENERIC" "ATTACH-STREAM"
+             "Y-MAX" "X-MAX" "FACE-INDEX" "SUBGLYPHS" "BITMAP" "BITMAP-SIZE" "ADVANCE" "MUL-FIX" "SET-PIXEL-SIZES"
+             "OUTLINE-CUBIC-TO-FUNC" "FACE-INTERNAL" "WCHAR-T" "BLACK-SPANS" "TAGS" "N-CONTOURS" "YY" "XY" "CONIC-TO" "INT"
+             "UNDERLINE-THICKNESS" "NUM-FACES" "Y-PPEM" "X-PPEM" "PLATFORM-ID" "ASCENDER" "DIV-FIX" "USHORT" "WINT-T"
+             "CONTROL-LEN" "WIDTH" "NEW-FACE" "CHAR-MAP-REC" "Y-SCALE" "X-SCALE" "ALLOC-FUNC" "OUTLINE-FUNCS" "RASTER-DONE"
+             "UINT16" "FINALIZER" "RENDER-GLYPH" "GLYPH-METRICS" "RASTER-SPAN-FUNC" "CONTOURS" "GLYPH-SLOT-REC"
+             "VERT-BEARING-Y" "INIT-FREE-TYPE" "CLIP-BOX" "RASTER-RESET-FUNC" "FLAGS" "USER" "MEMORY-SIZE" "HEIGHT" "N-POINTS"
+             "UINT" "VECTOR" "NEXT" "LIST" "MEMORY" "BUFFER" "MUL-DIV" "PARAMS" "GET-GLYPH-NAME" "PTRDIFF-T" "CHAR-MAP" "FWORD"
+             "OUTLINE-MOVE-TO-FUNC" "STREAM-CLOSE" "SET-TRANSFORM" "FLOOR-FIX" "GLYPH-FORMAT" "GLYPH-SLOT" "KERNING-MODE"
+             "INT16" "POS" "FAST" "CONTROL-DATA" "NUM-PARAMS" "STYLE-FLAGS" "CHARMAP" "OUTLINE-LINE-TO-FUNC" "SELECT-CHARMAP"
+             "TARGET" "TAIL" "SLOT-INTERNAL" "OUTLINE-FLAGS" "RASTER-SET-MODE" "LIST-NODE" "NEW-MEMORY-FACE" "SIZE-REC"
+             "RASTER-DONE-FUNC" "HORI-ADVANCE" "RASTER" "REALLOC-FUNC" "READ" "ROUND-FIX" "LIST-REC" "UINT32" "ULONG" "HEAD"
+             "DRIVER" "MAX-ADVANCE-HEIGHT" "SIZE-T" "Y-MIN" "X-MIN" "RASTER-SET-MODE-FUNC" "SIZE-METRICS" "ROWS" "OUTLINE" "Y"
+             "X" "ENCODING-ID" "FORMAT" "REALLOC" "INTERNAL" "SIZES-LIST" "MAX-ADVANCE-WIDTH" "DONE-FACE" "SIZE" "SUB-GLYPH"
+             "BBOX" "POINTER" "DELTA" "CEIL-FIX" "PARAMETER" "OFFSET" "MATRIX" "FACE-REC" "GRAY-SPANS" "PALETTE-MODE"
+             "NUM-FIXED-SIZES" "BYTE" "SPAN" "VECTOR-TRANSFORM" "NUM-GRAYS" "RASTER-BIT-SET-FUNC" "RENDERER" "VALUE" "BIT-TEST"
+             "SOURCE" "STYLE-NAME" "LINE-TO" "STREAM-DESC" "LONG" "UNIT-VECTOR" "LIST-NODE-REC" "HORI-BEARING-X" "VERT-ADVANCE"
+             "CUBIC-TO" "GENERIC-FINALIZER" "CHAR" "PTR-DIST" "UFAST" "DESCRIPTOR" "SET-CHAR-SIZE" "LINEAR-HORI-ADVANCE"
+             "MAX-ADVANCE" "AUTOHINT" "FIXED" "OPEN-FLAGS" "BASE" "ERROR" "NUM-GLYPHS" "DATA" "RENDER-MODE" "CHARMAPS" "FACE"
+             "F26DOT6" "OTHER" "RASTER-PARAMS" "SET-CHARMAP" "NUM-CHARMAPS" "LOAD-GLYPH" "RASTER-BIT-TEST-FUNC" "RASTER-NEW"
+             "FAMILY-NAME" "DONE-FREE-TYPE" "BIT-SET" "VERT-BEARING-X" "F2DOT14" "CLOSE" "STREAM-IO" "FACE-FLAGS" "BOOL"
+             "SHORT" "PALETTE" "C" "PALETTE-MODE-" "SIZE-REC-" "B" "A" "RENDER_MODE" "RIGHT_GLYPH" "SIZE-INTERNAL-REC-"
+             "CHAR-MAP-REC-" "RASTER-FUNCS-" "SUB-GLYPH-" "SLOT-INTERNAL-REC-" "OUTLINE-" "RENDER-MODE-" "GLYPH-METRICS-"
+             "PARAMETER-" "LOAD_FLAGS" "MATRIX-" "ARGS" "GLYPH_INDEX" "OUTLINE-FLAGS-" "MEMORY-REC-" "PIXEL_WIDTH" "VEC"
+             "HORZ_RESOLUTION" "LIST-REC-" "STREAM-REC-" "BUFFER_MAX" "LIBRARY-REC-" "SPAN-" "GLYPH-SLOT-REC-"
+             "VERT_RESOLUTION" "LEFT_GLYPH" "PIXEL-MODE-" "AFACE" "MODULE-REC-" "PIXEL_HEIGHT" "CHARCODE" "AKERNING" "ALIBRARY"
+             "LIST-NODE-REC-" "KERNING-MODE-" "FACE-REC-" "BITMAP-SIZE-" "DRIVER-REC-" "FILE_SIZE" "STREAM-DESC-"
+             "FACE-INTERNAL-REC-" "FILEPATHNAME" "UNIT-VECTOR-" "PARAMETERS" "RASTER-PARAMS-" "OUTLINE-FUNCS-" "CHAR_HEIGHT"
+             "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH"
+             "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S"))
+
+
+    
+(defpackage :mcclim-freetype
+    (:use :climi :clim :clim-lisp)
+    (:export :*freetype-font-path*)
+    (:import-from :cffi
+		  #:with-foreign-slots
+		  #:foreign-slot-value
+		  #:foreign-alloc)
+    (:import-from :freetype
+		  #:glyph
+		  #:bitmap
+		  #:width
+		  #:pitch
+		  #:rows
+		  #:buffer
+		  #:x #:y
+		  #:bitmap-left
+		  #:bitmap-top
+		  #:advance
+		  #:ascender
+		  #:descender
+		  #:size_s
+		  #:metrics)
+		  
+;;;    (:import-from #+cmucl :alien
+;;;                  #+sbcl :sb-alien
+;;;                  :slot :make-alien :alien :deref)
+    )
diff --git a/Experimental/freetype/mcclim-freetype-cffi.asd b/Experimental/freetype/mcclim-freetype-cffi.asd
new file mode 100644
index 00000000..eb749229
--- /dev/null
+++ b/Experimental/freetype/mcclim-freetype-cffi.asd
@@ -0,0 +1,86 @@
+;;;; -*- Lisp -*-
+
+;;;---------------------------------------------------------------------------
+;;; This is currently a *NON-FUNCTIONING* system definition for
+;;; FREETYPE with CFFI instead of CMUCL/SBCL style alien definitions.
+;;; This is a work in progress and should not be used by anyone until
+;;; its availability is announced. [2006/05/23:rpg]
+;;;---------------------------------------------------------------------------
+
+
+#|
+To autoload mcclim-freetype after mcclim, link this file to a
+directory in your asdf:*central-registry* and add the following to
+your lisp's init file:
+
+ (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx))))
+   (asdf:oos 'asdf:load-op :mcclim-freetype))
+|#
+
+(defpackage :mcclim-freetype-system (:use :cl :asdf))
+(in-package :mcclim-freetype-system)
+
+(defclass uncompiled-cl-source-file (source-file) ())
+
+(defmethod perform ((o compile-op) (f uncompiled-cl-source-file))
+  t)
+(defmethod perform ((o load-op) (f uncompiled-cl-source-file))
+  (mapcar #'load (input-files o f)))
+(defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file))
+  nil)
+(defmethod input-files ((operation load-op) (c uncompiled-cl-source-file))
+  (list (component-pathname c)))
+(defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file))
+  t)
+(defmethod source-file-type ((c uncompiled-cl-source-file) (s module))
+  "lisp")
+
+(defsystem :mcclim-freetype
+  :depends-on (:clim-clx :cffi)
+  :serial t
+  :components
+  ((:file "freetype-package-cffi")
+   (:uncompiled-cl-source-file "freetype-cffi")
+   (:file "freetype-fonts-cffi")))
+
+
+;;; Freetype autodetection
+
+(defun parse-fontconfig-output (s)
+  (let* ((match-string (concatenate 'string (string #\Tab) "file:"))
+         (matching-line
+          (loop for l = (read-line s nil nil)
+                while l
+                if (= (mismatch l match-string) (length match-string))
+                   do (return l)))
+         (filename (when matching-line
+                     (probe-file
+                      (subseq matching-line
+                              (1+ (position #\" matching-line :from-end nil :test #'char=))
+                              (position #\" matching-line :from-end t   :test #'char=))))))
+    (when filename
+      (make-pathname :directory (pathname-directory filename)))))
+
+(defun warn-about-unset-font-path ()
+  (warn "~%~%NOTE:~%~
+* Remember to set mcclim-freetype:*freetype-font-path* to the
+  location of the Bitstream Vera family of fonts on disk. If you
+  don't have them, get them from http://www.gnome.org/fonts/~%~%~%"))
+
+#+sbcl
+(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype))))
+  (let ((fc-match  (sb-ext:find-executable-in-search-path "fc-match")))
+    (if (null fc-match)
+        (warn-about-unset-font-path)
+        (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera")
+                                            :output :stream
+                                            :input nil))
+               (font-path (parse-fontconfig-output (sb-ext:process-output process))))
+          (if (null font-path)
+              (warn-about-unset-font-path)
+              (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype))
+                    font-path))))))
+
+#-sbcl
+(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype))))
+  (warn-about-unset-font-path))