scx/scheme/libs/xft.scm

(define-record-type xft-pattern :xft-pattern
  (really-make-xft-pattern c-pointer)
  xft-pattern?
  (c-pointer xft-pattern-c-pointer))

(define-exported-binding "xft-pattern" :xft-pattern)

(define-record-type xft-font :xft-font
  (make-xft-font x-pointer)
  xft-font?
  (x-pointer xft-font-x-pointer))

(define-exported-binding "xft-font" :xft-font)

(define-record-type xft-draw :xft-draw
  (make-xft-draw c-pointer)
  xft-draw?
  (c-pointer xft-draw-c-pointer))

(define-exported-binding "xft-draw" :xft-draw)

(define-record-type xft-color :xft-color
  (make-xft-color c-pointer display visual colormap)
  xft-color?
  (c-pointer xft-color-c-pointer)
  (display xft-color-display set-xft-color-display!)
  (visual xft-color-visual set-xft-color-visual!)
  (colormap xft-color-colormap set-xft-color-colormap!))

(define-exported-binding "xft-color" :xft-color)

(define-record-type xft-objectset :xft-objectset
  (make-xft-objectset c-pointer)
  xft-objectset?
  (c-pointer xft-objectset-c-pointer))

(define-exported-binding "xft-objectset" :xft-objectset)

(define-record-type xft-fontset :xft-fontset
  (really-make-xft-fontset c-pointer patterns)
  xft-fontset?
  (c-pointer xft-fontset-c-pointer)
  (patterns xft-fontset-patterns set-xft-fontset-patterns!))

(define-exported-binding "xft-fontset" :xft-fontset)

;;; add finalizers

(define (make-xft-pattern)
  (let ((xft-pattern (scx-xft-pattern-create)))
    (add-finalizer! xft-pattern scx-xft-pattern-destroy)
    xft-pattern))

(define (scx-xft-pattern-duplicate xft-pattern)
  (let ((copy (scx-xft-pattern-duplicate-internal xft-pattern)))
    (add-finalizer! copy scx-xft-pattern-destroy)
    copy))

(define (scx-xft-font-match display screen xft-pattern)
  (call-with-values
   (lambda ()
     (let ((screen-number (screen:number screen)))
       (scx-xft-font-match-internal display screen-number xft-pattern)))
   (lambda (result xft-pattern)
     (add-finalizer! xft-pattern scx-xft-pattern-destroy)
     (values result xft-pattern))))

(define (scx-xft-font-open-pattern display xft-pattern)
  (let ((xft-font (scx-xft-font-open-pattern-internal display xft-pattern)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-font-open-name display screen name)
  (let* ((screen-number (screen:number screen))
	 (xft-font (scx-xft-font-open-name-internal display screen-number name)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-font-open-xlfd display screen name)
  (let* ((screen-numer (screen:number screen))
	 (xft-font (scx-xft-font-open-xlfd-internal display screen-numer name)))
    (add-finalizer! xft-font scx-xft-font-close)
    xft-font))

(define (scx-xft-draw-create display drawable visual colormap)
  (let ((xft-draw (scx-xft-draw-create-internal display drawable visual colormap)))
    (add-finalizer! xft-draw scx-xft-draw-destroy)
    xft-draw))

(define (scx-xft-draw-create-bitmap display drawable)
  (let ((xft-draw (scx-xft-draw-create-bitmap-internal display drawable)))
    (add-finalizer! xft-draw scx-xft-draw-destroy)
    xft-draw))

(define (make-xft-objectset)
  (let ((xft-objectset (scx-xft-objectset-create)))
    (add-finalizer! xft-objectset scx-xft-objectset-destroy)
    xft-objectset))

(define (scx-xft-draw-display xft-draw)
  (let ((display (scx-xft-draw-display-internal xft-draw)))
    (if display
	display
	(error "XftDrawDisplay() unavailable in this version of Xft"))))

(define (scx-xft-draw-drawable xft-draw)
  (let ((drawable (scx-xft-draw-drawable-internal xft-draw)))
    (if drawable
	drawable
	(error "XftDrawDrawable() unavailable in this version of Xft"))))

(define (scx-xft-draw-colormap xft-draw)
  (let ((colormap (scx-xft-draw-colormap-internal xft-draw)))
    (if colormap
	colormap
	(error "XftDrawColormap() unavailable in this version of Xft"))))

(define (scx-xft-draw-visual xft-draw)
  (let ((visual (scx-xft-draw-visual-internal xft-draw)))
    (if visual
	visual
	(error "XftDrawVisual() unavailable in this version of Xft"))))

(define (scx-xft-list-fonts-pattern-objects display screen xft-pattern xft-objectset)
  (let* ((screen-number (screen:number screen))
	 (fontset (scx-xft-list-fonts-pattern-objects-internal
		   display screen-number xft-pattern xft-objectset)))
    (add-finalizer! fontset scx-xft-fontset-destroy)
    fontset))

(define (make-xft-fontset)
  (let ((fontset (scx-xft-fontset-create)))
    (set-xft-fontset-patterns! fontset '())
    (add-finalizer! fontset scx-xft-fontset-create)
    fontset))

(define (scx-xft-fontset-add xft-fontset xft-pattern)
  (set-xft-fontset-patterns! 
   xft-fontset (lset-adjoin eq? xft-pattern (xft-fontset-patterns xft-fontset)))
  (scx-xft-fontset-add-internal xft-fontset xft-pattern))

(define (scx-xft-color-alloc-name display visual colormap name)
  (call-with-values
   (lambda ()
     (apply values
	    (scx-xft-color-alloc-name-internal display visual colormap name)))
   (lambda (success? xft-color)
     (if success?
	 (begin
	   (set-xft-color-display! xft-color display)
	   (set-xft-color-visual! xft-color visual)
	   (set-xft-color-colormap! xft-color colormap)
	   (add-finalizer! xft-color xft-color-finalizer)
	   xft-color)
	 ;;; FIXME: raise error
	 #f))))

(define (scx-xft-color-alloc-value display visual colormap xrendercolor)
  (let ((xft-color (scx-xft-color-alloc-value-internal display visual colormap xrendercolor)))
    (set-xft-color-display! xft-color display)
    (set-xft-color-visual! xft-color visual)
    (set-xft-color-colormap! xft-color colormap)
    (add-finalizer! xft-color xft-color-finalizer)
    xft-color))

(define (xft-color-finalizer xft-color)
  (scx-xft-color-free (xft-color-display xft-color)
		      (xft-color-visual xft-color)
		      (xft-color-colormap xft-color)
		      xft-color))

;;; import values from C code
(define scx-xft-version-major
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-version-major")))

(define scx-xft-version-minor
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-version-minor")))

(define scx-xft-result-match
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-result-match")))

(define scx-xft-result-no-match
 (shared-binding-ref
  (lookup-imported-binding "scx-xft-result-no-match")))

(define scx-xft-result-type-mismatch
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-result-type-mismatch")))

(define scx-xft-result-no-id
  (shared-binding-ref
   (lookup-imported-binding "scx-xft-result-no-id")))

;;; import functions from C code

(import-lambda-definition scx-xft-pattern-create 
			  ()
			  "scx_XftPatternCreate")

(import-lambda-definition scx-xft-pattern-destroy
			  ()
			  "scx_XftPatternDestroy")

(import-lambda-definition scx-xft-pattern-duplicate-internal
			  (xft-pattern)
			  "scx_XftPatternDuplicate")

(import-lambda-definition scx-xft-pattern-get
			  (xft-pattern object id)
			  "scx_XftPatternGet")

(import-lambda-definition scx-xft-pattern-add
			  (xft-pattern object value append?)
			  "scx_XftPatternAdd")

(import-lambda-definition scx-xft-font-match-internal
			  (display screen-number xft-pattern)
			  "scx_XftFontMatch")

(import-lambda-definition scx-xft-font-open-pattern-internal
			  (display xft-pattern)
			  "scx_XftFontOpenPattern")

(import-lambda-definition scx-xft-font-open-name-internal
			  (display screen-number name)
			  "scx_XftFontOpenName")

(import-lambda-definition scx-xft-font-open-xlfd-internal
			  (display screen-number xlfd-name)
			  "scx_XftFontOpenXlfd")

(import-lambda-definition scx-xft-font-close
			  (display xft-font)
			  "scx_XftFontClose")

(import-lambda-definition scx-xft-draw-create-internal
			  (display drawable visual colormap)
			  "scx_XftDrawCreate")

(import-lambda-definition scx-xft-draw-create-bitmap-internal
			  (display drawable)
			  "scx_XftDrawCreateBitmap")

(import-lambda-definition scx-xft-draw-change
			  (xft-draw drawable)
			  "scx_XftDrawChange")

(import-lambda-definition scx-xft-draw-display-internal
			  (xft-draw)
			  "scx_XftDrawDisplay")

(import-lambda-definition scx-xft-draw-drawable-internal
			  (xft-draw)
			  "scx_XftDrawDrawable")

(import-lambda-definition scx-xft-draw-colormap-internal
			  (xft-draw)
			  "scx_XftDrawColormap")

(import-lambda-definition scx-xft-draw-visual-internal
			  (xft-draw)
			  "scx_XftDrawVisual")

(import-lambda-definition scx-xft-draw-destroy
			  (xft-draw)
			  "scx_XftDrawDestroy")

(import-lambda-definition scx-xft-text-extents-8bit
			  (display xft-font string)
			  "scx_XftTextExtents8")

(import-lambda-definition scx-xft-draw-string-8bit
			  (xft-draw xft-color xft-font x y string)
			  "scx_XftDrawString8")

(import-lambda-definition scx-xft-draw-rect
			  (xft-draw xft-color x y w h)
			  "scx_XftDrawRect")

(import-lambda-definition scx-xft-draw-set-clip
			  (xft-draw region)
			  "scx_XftDrawSetClip")

(import-lambda-definition scx-xft-objectset-create
			  ()
			  "scx_XftObjectSetCreate")

(import-lambda-definition scx-xft-objectset-destroy
			  (xft-objectset)
			  "scx_XftObjectSetDestroy")

(import-lambda-definition scx-xft-objectset-add
			  (xft-objectset object)
			  "scx_XftObjectSetAdd")

(import-lambda-definition scx-xft-list-fonts-pattern-objects-internal
			  (display screen-number xft-pattern xft-objectset)
			  "scx_XftListFontsPatternObjects")

(import-lambda-definition scx-xft-fontset-create
			  ()
			  "scx_XftFontSetCreate")

(import-lambda-definition scx-xft-fontset-destroy
			  (xft-fontset)
			  "scx_XftFontSetDestroy")

(import-lambda-definition scx-xft-fontset-add-internal
			  (xft-fontset xft-pattern)
			  "scx_XftFontSetAdd")

(import-lambda-definition scx-xft-color-alloc-name-internal
			  (display visual colormap name)
			  "scx_XftColorAllocName")

(import-lambda-definition scx-xft-color-alloc-value-internal
			  (display visual colormap xrendercolor)
			  "scx_XftColorAllocValue")

(import-lambda-definition scx-xft-color-free
			  (display visual colormap xft-color)
			  "scx_XftColorFree")

(import-lambda-definition scx-xft-pattern-print
			  (xft-pattern)
			  "scx_XftPatternPrint")

(import-lambda-definition scx-xft-fontset-print
			  (xft-fontset)
			  "scx_XftFontSetPrint")

(import-lambda-definition scx-xft-default-has-render?
			  (display)
			  "scx_XftDefaultHasRender")