520 lines
16 KiB
Scheme
520 lines
16 KiB
Scheme
|
|
(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)
|
|
|
|
(define-syntax lookup-shared-valued
|
|
(syntax-rules ()
|
|
((lookup-shared-valued str)
|
|
(shared-binding-ref
|
|
(lookup-imported-binding str)))))
|
|
|
|
(define-finite-type xft-pattern-object :xft-pattern-object
|
|
(id)
|
|
xft-pattern-object?
|
|
xft-pattern-object-elements
|
|
xft-pattern-object-name
|
|
xft-pattern-object-index
|
|
(id xft-pattern-object-id)
|
|
((family (lookup-shared-valued "scx-xft-pattern-family"))
|
|
(style (lookup-shared-valued "scx-xft-pattern-style"))
|
|
(slant (lookup-shared-valued "scx-xft-pattern-slant"))
|
|
(weight (lookup-shared-valued "scx-xft-pattern-weight"))
|
|
(size (lookup-shared-valued "scx-xft-pattern-size"))
|
|
(pixel-size (lookup-shared-valued "scx-xft-pattern-pixel-size"))
|
|
(encoding (lookup-shared-valued "scx-xft-pattern-encoding"))
|
|
(spacing (lookup-shared-valued "scx-xft-pattern-spacing"))
|
|
(foundry (lookup-shared-valued "scx-xft-pattern-foundry"))
|
|
(core (lookup-shared-valued "scx-xft-pattern-core"))
|
|
(antialias (lookup-shared-valued "scx-xft-pattern-antialias"))
|
|
(xlfd (lookup-shared-valued "scx-xft-pattern-xlfd"))
|
|
(file (lookup-shared-valued "scx-xft-pattern-file"))
|
|
(index (lookup-shared-valued "scx-xft-pattern-index"))
|
|
(rasterizer (lookup-shared-valued "scx-xft-pattern-rasterizer"))
|
|
(outline (lookup-shared-valued "scx-xft-pattern-outline"))
|
|
(scalable (lookup-shared-valued "scx-xft-pattern-scalable"))
|
|
(rgba (lookup-shared-valued "scx-xft-pattern-rgba"))
|
|
(scale (lookup-shared-valued "scx-xft-pattern-scale"))
|
|
(render (lookup-shared-valued "scx-xft-pattern-render"))
|
|
(minspace (lookup-shared-valued "scx-xft-pattern-minspace"))
|
|
(dpi (lookup-shared-valued "scx-xft-pattern-dpi"))
|
|
(char-width (lookup-shared-valued "scx-xft-pattern-char-width"))
|
|
(char-height (lookup-shared-valued "scx-xft-pattern-char-height"))))
|
|
|
|
(define-finite-type xft-weight :xft-weight
|
|
(id)
|
|
xft-weight?
|
|
xft-weight-elements
|
|
xft-weight-name
|
|
xft-weight-index
|
|
(id xft-weight-id)
|
|
((light (lookup-shared-valued "scx-xft-weight-light"))
|
|
(medium (lookup-shared-valued "scx-xft-weight-medium"))
|
|
(demibold (lookup-shared-valued "scx-xft-weight-demibold"))
|
|
(bold (lookup-shared-valued "scx-xft-weight-bold"))
|
|
(black (lookup-shared-valued "scx-xft-weight-black"))))
|
|
|
|
(define-finite-type xft-slant :xft-slant
|
|
(id)
|
|
xft-slant?
|
|
xft-slant-elements
|
|
xft-slant-name
|
|
xft-slant-index
|
|
(id xft-slant-id)
|
|
((roman (lookup-shared-valued "scx-xft-slant-roman"))
|
|
(italic (lookup-shared-valued "scx-xft-slant-italic"))
|
|
(oblique (lookup-shared-valued "scx-xft-slant-oblique"))))
|
|
|
|
(define-finite-type xft-spacing :xft-spacing
|
|
(id)
|
|
xft-spacing?
|
|
xft-spacing-elements
|
|
xft-spacing-name
|
|
xft-spacing-index
|
|
(id xft-spacing-id)
|
|
((proportional (lookup-shared-valued "scx-xft-spacing-proportional"))
|
|
(mono (lookup-shared-valued "scx-xft-spacing-mono"))
|
|
(charcell (lookup-shared-valued "scx-xft-spacing-charcell"))))
|
|
|
|
(define-finite-type xft-rgba :xft-rgba
|
|
(id)
|
|
xft-rgba?
|
|
xft-rgba-elements
|
|
xft-rgba-name
|
|
xft-rgba-index
|
|
(id xft-rgba-id)
|
|
((none (lookup-shared-valued "scx-xft-rgba-none"))
|
|
(rgb (lookup-shared-valued "scx-xft-rgba-rgb"))
|
|
(bgr (lookup-shared-valued "scx-xft-rgba-bgr"))
|
|
(vrgb (lookup-shared-valued "scx-xft-rgba-vrgb"))
|
|
(vbgr (lookup-shared-valued "scx-xft-rgba-vbgr"))))
|
|
|
|
(define (make-finite-type-alist elements id-proc)
|
|
(map (lambda (e)
|
|
(cons (id-proc e) e))
|
|
(vector->list elements)))
|
|
|
|
(define xft-weight-id->xft-weight
|
|
(let ((alist
|
|
(make-finite-type-alist xft-weight-elements xft-weight-id)))
|
|
(lambda (id)
|
|
(cond
|
|
((assoc id alist) => cdr)
|
|
(else
|
|
(error "scx: internal error. Could not map weight id to finite type"))))))
|
|
|
|
(define xft-slant-id->xft-slant
|
|
(let ((alist
|
|
(make-finite-type-alist xft-slant-elements xft-slant-id)))
|
|
(lambda (id)
|
|
(cond
|
|
((assoc id alist) => cdr)
|
|
(else
|
|
(error "scx: internal error. Could not map slant id to finite type"))))))
|
|
|
|
(define xft-spacing-id->xft-spacing
|
|
(let ((alist
|
|
(make-finite-type-alist xft-spacing-elements xft-spacing-id)))
|
|
(lambda (id)
|
|
(cond
|
|
((assoc id alist) => cdr)
|
|
(else
|
|
(error "scx: internal error. Could not map spacing id to finite type"))))))
|
|
|
|
(define xft-rgba-id->xft-rgba
|
|
(let ((alist
|
|
(make-finite-type-alist xft-rgba-elements xft-rgba-id)))
|
|
(lambda (id)
|
|
(cond
|
|
((assoc id alist) => cdr)
|
|
(else
|
|
(error "scx: internal error. Could not map rgba id to finite type"))))))
|
|
|
|
;;; 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-pattern-get pattern object id)
|
|
(let ((object-id (xft-pattern-object-id object)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(scx-xft-pattern-get-internal pattern object-id id)))
|
|
(lambda (code value)
|
|
(values code
|
|
(cond
|
|
((not (scx-xft-result-match? code))
|
|
#f)
|
|
((equal? object (xft-pattern-object weight))
|
|
(xft-weight-id->xft-weight value))
|
|
((equal? object (xft-pattern-object slant))
|
|
(xft-slant-id->xft-slant value))
|
|
((equal? object (xft-pattern-object spacing))
|
|
(xft-spacing-id->xft-spacing value))
|
|
((equal? object (xft-pattern-object rgba))
|
|
(xft-rgba-id->xft-rgba value))
|
|
(else value)))))))
|
|
|
|
(define (scx-xft-pattern-add pattern object value append?)
|
|
(let* ((object-id (xft-pattern-object-id object))
|
|
(call (lambda (value)
|
|
(scx-xft-pattern-add-internal
|
|
pattern object-id value append?))))
|
|
(cond
|
|
((equal? object (xft-pattern-object weight))
|
|
(call (xft-weight-id value)))
|
|
((equal? object (xft-pattern-object slant))
|
|
(call (xft-slant-id value)))
|
|
((equal? object (xft-pattern-object spacing))
|
|
(call (xft-spacing-id value)))
|
|
((equal? object (xft-pattern-object rgba))
|
|
(call (xft-rgba-id value)))
|
|
(else (call value)))))
|
|
|
|
(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-objectset-add xft-objectset xft-pattern-object)
|
|
(scx-xft-objectset-add-internal
|
|
xft-objectset (xft-pattern-object-id xft-pattern-object)))
|
|
|
|
(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)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(scx-xft-color-alloc-value-internal display visual colormap xrendercolor)))
|
|
(lambda (success? xft-color)
|
|
(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?
|
|
(let ((code (shared-binding-ref
|
|
(lookup-imported-binding "scx-xft-result-match"))))
|
|
(lambda (value)
|
|
(equal? value code))))
|
|
|
|
(define scx-xft-result-no-match?
|
|
(let ((code (shared-binding-ref
|
|
(lookup-imported-binding "scx-xft-result-no-match"))))
|
|
(lambda (value)
|
|
(equal? value code))))
|
|
|
|
(define scx-xft-result-type-mismatch?
|
|
(let ((code (shared-binding-ref
|
|
(lookup-imported-binding "scx-xft-result-type-mismatch"))))
|
|
(lambda (value)
|
|
(equal? value code))))
|
|
|
|
(define scx-xft-result-no-id?
|
|
(let ((code (shared-binding-ref
|
|
(lookup-imported-binding "scx-xft-result-no-id"))))
|
|
(lambda (value)
|
|
(equal? value code))))
|
|
|
|
;;; 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-internal
|
|
(xft-pattern object id)
|
|
"scx_XftPatternGet")
|
|
|
|
(import-lambda-definition scx-xft-pattern-add-internal
|
|
(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-internal
|
|
(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")
|
|
|