From 736a828fbeb6176ada0b8455dcc4f1e447185f26 Mon Sep 17 00:00:00 2001 From: frese Date: Wed, 18 Jul 2001 15:48:22 +0000 Subject: [PATCH] first implementation. --- scheme/xlib/font-type.scm | 77 ++++++++++++++++ scheme/xlib/font.scm | 185 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 262 insertions(+) create mode 100644 scheme/xlib/font-type.scm create mode 100644 scheme/xlib/font.scm diff --git a/scheme/xlib/font-type.scm b/scheme/xlib/font-type.scm new file mode 100644 index 0000000..a8a2e77 --- /dev/null +++ b/scheme/xlib/font-type.scm @@ -0,0 +1,77 @@ +(define-record-type font :font + (really-make-font name Xfont Xfontstruct display) + font? + (name font-name font-set-name!) + (Xfont font-Xfont font-set-Xfont!) + (Xfontstruct font-Xfontstruct font-set-Xfontstruct!) + (display font-display font-set-display!)) + +;; creates a font object. name can be #f. if Xfont is #f then it is obtained +;; from the Xfontstruct. + +(define (make-font name Xfont Xfontstruct display) + (let ((maybe-font (font-list-find Xfontstruct))) + (if maybe-font + maybe-font + (let* ((Xfont (if Xfont Xfont + (%Get_Xfont Xfontstruct))) + (font (really-make-font name Xfont Xfontstruct display))) + (add-finalizer! font unload-font) + (font-list-set! Xfontstruct font) + font)))) + +;; load-font loads a font by its name. See XLoadQueryFont. + +(define (load-font display font-name) + (let ((Xfontstruct (%load-font (display-Xdisplay display) + (if (symbol? font-name) + (symbol->string font-name) + font-name)))) + (make-font font-name #f Xfontstruct display))) + +(import-lambda-definition %load-font (Xdisplay font_name) + "Load_Font") + +;; for compatibility with Elk: + +(define open-font load-font) + +;; unload-font unloads a font. This is also automatically called on +;; garbage collection. See XUnloadFont. + +(define (unload-font font) + (let ((Xfontstruct (font-Xfontstruct font)) + (Xdisplay (display-Xdisplay (font-display font)))) + (if (integer? Xfontstruct) + (%free-font Xdisplay Xfontstruct)) + (font-set-Xfontstruct! font 'already-freed) + (font-set-Xfont! font 'already-freed) + (font-list-delete! Xfont))) + +;; for compatibility with Elk: +(define close-font unload-font) + +;; %free-font frees the Xfontstruct and also deletes the association between +;; the Xfont (the resource id) and the specified font. See XFreeFont. +;; Elk uses only XUnloadFont, but then the XFontStruct is not freed ?? + +(import-lambda-definition %free-font (Xdisplay Xfontstruct) + "Free_Font") + +;; All font records need to be saved in a weak-list, to have only one record +;; for the same font in the heap. + +(define *weak-font-list* (make-integer-table)) + +(define (font-list-find Xfont) + (let ((r (table-ref *weak-font-list* Xfont))) + (if r + (weak-pointer-ref r) + r))) + +(define (font-list-set! Xfont font) + (let ((p (make-weak-pointer font))) + (table-set! *weak-font-list* Xfont p))) + +(define (font-list-delete! Xfont) + (table-set! *weak-font-list* Xfont #f)) diff --git a/scheme/xlib/font.scm b/scheme/xlib/font.scm new file mode 100644 index 0000000..87b036b --- /dev/null +++ b/scheme/xlib/font.scm @@ -0,0 +1,185 @@ +(define (gcontext-font gcontext) + (let* ((display (gcontext-display gcontext)) + (Xfontstruct (%gcontext-font + (display-Xdisplay display) + (gcontext-Xgcontext gcontext)))) + (make-font #f #f Xfontstruct display))) + +(import-lambda-definition %gcontext-font (Xdisplay Xgcontext) + "GContext_Font") + +(define (list-font-names display pattern) + (%list-font-names (display-Xdisplay) + (if (symbol? pattern) + (symbol->string pattern) + pattern))) + +(import-lambda-definition %list-font-names (Xdisplay pattern) + "List_Font_Names") + +(define (list-fonts display pattern) + (let ((v (%list-fonts (display-Xdisplay display) + (if (symbol? pattern) + (symbol->string pattern) + pattern)))) + (vector->list (vector-map! (lambda (name-Xfontstruct) + (make-font (car name-Xfontstruct) + #f + (cdr name-Xfontstruct) + display)) + v)))) + +(import-lambda-definition %list-fonts (Xdisplay pattern) + "List_Fonts") + +(define (font-properties font) + (let ((v (%font-properties (font-Xfontstruct font)))) + (vector->list (vector-map! (lambda (XAtom-Val) + (cons (make-atom (car XAtom-Val)) + (cdr XAtom-Val))) + v)))) + +(import-lambda-definition %font-properties (Xfontstruct) + "Font_Properties") + +(define (font-property font property-name) + (let ((atom (intern-atom (font-display font) + property-name))) + (%font-property (font-Xfontstruct font) + (atom-Xatom atom)))) + +(import-lambda-definition %font-property (Xfontstruct Xatom) + "Font_Property") + +(define (font-path display) + (vector->list (%font-path (display-Xdisplay display)))) + +(import-lambda-definition %font-path (Xdisplay) + "Font_Path") + +(define (set-font-path! display path) + (%set-font-path! (display-Xdisplay display) + (map (lambda (s) + (if (symbol? s) + (symbol->string s) + s)) + (list->vector path)))) + +(import-lambda-definition %set-font-path! (Xdisplay path) + "Set_Font_Path") + +;; ............ + +(define (font-info font) + (%font-info (font-Xfontstruct font))) + +(import-lambda-definition %font-info (Xfontstruct) + "Font_Info") + +(define (font-info-getter num) + (lambda (font) + (vector-ref (font-info font) + num))) + +(define font-direction (font-info-getter 0)) +(define font-min-byte2 (font-info-getter 1)) +(define font-max-byte2 (font-info-getter 2)) +(define font-min-byte1 (font-info-getter 3)) +(define font-max-byte1 (font-info-getter 4)) +(define font-all-chars-exist? (font-info-getter 5)) +(define font-default-char (font-info-getter 6)) +(define font-ascent (font-info-getter 7)) +(define font-descent (font-info-getter 8)) + +;; .................. + +(define (char-info font index) + (%char-info (font-Xfontstruct font) + (cond + ((eq? index 'min) #f) + ((eq? index 'max) #t) + (else (let ((i (if (char? index) + (char->integer index) + index))) + (calc-index font i)))))) + +(import-lambda-definition %char-info (Xfontstruct index) + "Char_Info") + +;; calc-index calculates the array-position in XFontStruct.per_char by giving +;; the character index which ranges between [font-min-byte2...font-max-byte2] +;; for one-byte fonts or for two-byte fonts the lower 8 bits must be between +;; [font-min-byte1...font-max-byte1] and the higher 8 bits must be between +;; [font-min-byte2...font-max-byte2]. An error is raised if the index does not +;; fit into these boundaries. +(define (calc-index font index) + (let ((min1 (font-min-byte1 font)) + (max1 (font-max-byte1 font)) + (min2 (font-min-byte2 font)) + (max2 (font-max-byte2 font)) + (check-bounds + (lambda (min max i s) + (if (or (< i min) + (> i max)) + (error (string-append s + (integer->string min) + " and " + (integer->string max) + "; given") + index))))) + (if (and (= 0 min1) (= 0 max1)) + ;; two-byte font + (let ((b1 (bitwise-and index 255)) + (b2 (bitwise-and (arithmetic-shift index -8) 255))) + (check-bounds min1 max1 b1 + "expected an integer with lower 8 bits between ") + (check-bounds min2 max2 b2 + "expected an integer with higher 8 bits between ") + (+ (* b1 (+ (- max2 min2) 1)) + b2)) + ;; one-byte font + (begin + (check-bounds min2 max2 index + "expected an integer between ") + index)))) + + +(define (char-info-getter num) + (lambda (font index) + (vector-ref (char-info font index) + num))) + +(define char-rbearing (char-info-getter 0)) +(define char-lbearing (char-info-getter 1)) +(define char-width (char-info-getter 2)) +(define char-ascent (char-info-getter 3)) +(define char-descent (char-info-getter 4)) +(define char-attributes (char-info-getter 5)) + +(define (max-char-info-getter num) + (lambda (font) + (vector-ref (char-info font 'max) + num))) + +(define (max-char-info font) + (char-info font 'max)) +(define max-char-rbearing (max-char-info-getter 0)) +(define max-char-lbearing (max-char-info-getter 1)) +(define max-char-width (max-char-info-getter 2)) +(define max-char-ascent (max-char-info-getter 3)) +(define max-char-descent (max-char-info-getter 4)) +(define max-char-attributes (max-char-info-getter 5)) + +(define (min-char-info-getter num) + (lambda (font) + (vector-ref (char-info font 'min) + num))) + +(define (min-char-info font) + (char-info font 'min)) +(define min-char-rbearing (min-char-info-getter 0)) +(define min-char-lbearing (min-char-info-getter 1)) +(define min-char-width (min-char-info-getter 2)) +(define min-char-ascent (min-char-info-getter 3)) +(define min-char-descent (min-char-info-getter 4)) +(define min-char-attributes (min-char-info-getter 5))