[AC sjt-xft] Refactor charset/lang checking

AC sjt-xft Big user-visible change: Xft debug level is now Lisp-accessible in xft-debug-level, a primitive Lisp integer variable. I've turned debug information back on, but you can stifle it after the initialization phase with (setq xft-debug-level 0) in init.el. The window manager debug information has been suppressed, that won't come back. This patch adds font charset support checking for multi-language character sets like Latin-1, and extends the language-based checking to Greek, Korean, simplified Chinese, and traditional Chinese. I don't really know if it works, but it should be easier to see what's going on so that people who actually use Latin-X etc can start to debug it. Also, I've started work on refactoring font.el. So far limited to removing unused or irrelevant junk, like the font-running-xemacs variable and the code to make keywords evaluate to themselves (since keywords have been supported natively for aeons). Index: lisp/ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.599.2.4 diff -u -r1.599.2.4 ChangeLog --- lisp/ChangeLog 1 Mar 2005 13:14:00 -0000 1.599.2.4 +++ lisp/ChangeLog 5 Mar 2005 11:21:45 -0000 ＠＠ -0,0 +1,18 ＠＠ +2005-03-02 Stephen J. Turnbull <stephen(a)xemacs.org&gt; + + * font.el (font-running-xemacs): Remove definition. + (font-x-font-regexp): + (font-x-registry-and-encoding-regexp): + (font-default-font-for-device): + (x-font-create-name-core): + (mswindows-font-create-name): + (font-set-face-font): + (font-blink-callback): + Remove references. + + (define-font-keywords): Remove definition and top-level references. + + (set-font-style-by-keywords): + (font-properties-from-style): + Comment out. + Index: lisp/font.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/font.el,v retrieving revision 1.15.2.2 diff -u -r1.15.2.2 font.el --- lisp/font.el 1 Mar 2005 13:14:01 -0000 1.15.2.2 +++ lisp/font.el 5 Mar 2005 11:21:45 -0000 ＠＠ -29,6 +29,18 ＠＠ ;;; Commentary: +;; This file is totally bogus in the context of Emacs. Much of what it does +;; is really in the provice of faces (for example all the style parameters), +;; and that's the way it is in GNU Emacs. +;; +;; What is needed for fonts at the Lisp level is a consistent way to access +;; face properties that are actually associated with fonts for some rendering +;; engine, in other words, the kinds of facilities provided by fontconfig +;; patterns. We just need to provide an interface to looking up, storing, +;; and manipulating font specifications with certain properties. There will +;; be some engine-specific stuff, like the bogosity of X11's character set +;; registries. + ;;; Code: (globally-declare-fboundp ＠＠ -96,23 +108,14 ＠＠ ;;; Lots of variables / keywords for use later in the program ;;; Not much should need to be modified ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) - "Whether we are running in XEmacs or not.") - -(defmacro define-font-keywords (&rest keys) - `(eval-and-compile - (let ((keywords (quote ,keys))) - (while keywords - (or (boundp (car keywords)) - (set (car keywords) (car keywords))) - (setq keywords (cdr keywords)))))) - +;; #### These aren't window system mappings (defconst font-window-system-mappings '((x . (x-font-create-name x-font-create-object)) (gtk . (x-font-create-name x-font-create-object)) (ns . (ns-font-create-name ns-font-create-object)) (mswindows . (mswindows-font-create-name mswindows-font-create-object)) (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME + ;; #### what is this bogosity? (tty . (tty-font-create-plist tty-font-create-object))) "An assoc list mapping device types to a list of translations. ＠＠ -155,12 +158,11 ＠＠ "How much a font is allowed to vary from the desired size.") ;; Canonical (internal) sizes are in points. -;; Registry -(define-font-keywords:family :style :size :registry :encoding) -(define-font-keywords -:weight :extra-light :light :demi-light :medium :normal :demi-bold -:bold :extra-bold) +;; Property keywords: :family :style :size :registry :encoding :weight +;; Weight keywords: :extra-light :light :demi-light :medium +;;:normal :demi-bold :bold :extra-bold +;; See GNU Emacs 21.4 for more properties and keywords we should support (defvar font-style-keywords nil) ＠＠ -268,27 +270,31 ＠＠ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun set-font-style-by-keywords (fontobj styles) - (make-local-variable 'font-func) - (declare (special font-func)) - (if (listp styles) - (while styles - (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords))) - styles (cdr styles)) - (and (fboundp font-func) (funcall font-func fontobj t))) - (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords)))) - (and (fboundp font-func) (funcall font-func fontobj t)))) - -(defun font-properties-from-style (fontobj) - (let ((todo font-style-keywords) - type func retval) - (while todo - (setq func (cdr (cdr (car todo))) - type (car (pop todo))) - (if (funcall func fontobj) - (setq retval (cons type retval)))) - retval)) +;; #### unused? +; (defun set-font-style-by-keywords (fontobj styles) +; (make-local-variable 'font-func) +; (declare (special font-func)) +; (if (listp styles) +; (while styles +; (setq font-func (car-safe (cdr-safe (assq (car styles) +; font-style-keywords))) +; styles (cdr styles)) +; (and (fboundp font-func) (funcall font-func fontobj t))) +; (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords)))) +; (and (fboundp font-func) (funcall font-func fontobj t)))) + +;; #### unused? +; (defun font-properties-from-style (fontobj) +; (let ((todo font-style-keywords) +; type func retval) +; (while todo +; (setq func (cdr (cdr (car todo))) +; type (car (pop todo))) +; (if (funcall func fontobj) +; (setq retval (cons type retval)))) +; retval)) +;; #### only used in this file; maybe there's a cl.el function? (defun font-unique (list) (let ((retval) (cur)) ＠＠ -475,9 +481,8 ＠＠ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The window-system dependent code (X-style) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar font-x-font-regexp (or (and font-running-xemacs - (boundp 'x-font-regexp) - x-font-regexp) +(defvar font-x-font-regexp (when (and (boundp 'x-font-regexp) + x-font-regexp) (let ((- "[-?]") (foundry "[^-]*") ＠＠ -504,13 +509,12 ＠＠ )))) (defvar font-x-registry-and-encoding-regexp - (or (and font-running-xemacs - (boundp 'x-font-regexp-registry-and-encoding) - (symbol-value 'x-font-regexp-registry-and-encoding)) - (let ((- "[-?]") - (registry "[^-]*") - (encoding "[^-]+")) - (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))) + (when (and (boundp 'x-font-regexp-registry-and-encoding) + (symbol-value 'x-font-regexp-registry-and-encoding)) + (let ((- "[-?]") + (registry "[^-]*") + (encoding "[^-]+")) + (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))) (defvar font-x-family-mappings '( ＠＠ -638,14 +642,13 ＠＠ ;;;###autoload (defun font-default-font-for-device (&optional device) (or device (setq device (selected-device))) - (if font-running-xemacs - (font-truename - (make-font-specifier - (face-font-name 'default device))) + (font-truename + (make-font-specifier + (face-font-name 'default device))) (let ((font (cdr-safe (assq 'font (frame-parameters device))))) (if (and (fboundp 'fontsetp) (fontsetp font)) (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) - font)))) + font))) ;;;###autoload (defun font-default-object-for-device (&optional device) ＠＠ -702,8 +705,7 ＠＠ (font-family default) (x-font-families-for-device device))) (weight (or (font-weight fontobj) :medium)) - (size (or (if font-running-xemacs - (font-size fontobj)) + (size (or (font-size fontobj) (font-size default))) (registry (or (font-registry fontobj) (font-registry default) ＠＠ -916,8 +918,7 ＠＠ (family (or (font-family fontobj) (font-family default))) (weight (or (font-weight fontobj) :regular)) - (size (or (if font-running-xemacs - (font-size fontobj)) + (size (or (font-size fontobj) (font-size default))) (underline-p (font-underline-p fontobj)) (strikeout-p (font-strikethru-p fontobj)) ＠＠ -1013,7 +1014,7 ＠＠ (setq cur (car font-name) font-name (cdr font-name)) (apply 'set-face-property face (car cur) (cdr cur) args)))) - (font-running-xemacs + (t (apply 'set-face-font face font-name args) (apply 'set-face-underline-p face (font-underline-p font) args) (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) ＠＠ -1024,16 +1025,18 ＠＠ (font-linethrough-p font) (font-strikethru-p font)) args)) - (t - (condition-case nil - (apply 'set-face-font face font-name args) - (error - (let ((args (car-safe args))) - (and (or (font-bold-p font) - (memq (font-weight font) '(:bold :demi-bold))) - (make-face-bold face args t)) - (and (font-italic-p font) (make-face-italic face args t))))) - (apply 'set-face-underline-p face (font-underline-p font) args))))) +;;; this used to be default with preceding conditioned on font-running-xemacs +; (t +; (condition-case nil +; (apply 'set-face-font face font-name args) +; (error +; (let ((args (car-safe args))) +; (and (or (font-bold-p font) +; (memq (font-weight font) '(:bold :demi-bold))) +; (make-face-bold face args t)) +; (and (font-italic-p font) (make-face-italic face args t))))) +; (apply 'set-face-underline-p face (font-underline-p font) args)) + ))) (t ;; Let the original set-face-font signal any errors (set-face-property face 'font-specification nil) ＠＠ -1408,13 +1411,14 ＠＠ (defun font-blink-callback () ;; Optimized to never invert the face unless one of the visible windows ;; is showing it. - (let ((faces (if font-running-xemacs (face-list t) (face-list))) + (let ((faces (face-list t)) (obj nil)) (while faces (if (and (setq obj (face-property (car faces) 'font-specification)) (font-blink-p obj) (memq t - (font-map-windows 'font-face-visible-in-window-p (car faces)))) + (font-map-windows 'font-face-visible-in-window-p + (car faces)))) (invert-face (car faces))) (pop faces)))) Index: src/ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/ChangeLog,v retrieving revision 1.758.2.15 diff -u -r1.758.2.15 ChangeLog --- src/ChangeLog 24 Feb 2005 11:08:24 -0000 1.758.2.15 +++ src/ChangeLog 5 Mar 2005 11:22:04 -0000 ＠＠ -0,0 +1,56 ＠＠ +2005-03-05 Stephen J. Turnbull <stephen(a)xemacs.org&gt; + + Refactor language/charset checking in Xft. + + * objects-x.c (struct charset_reporter): New type. + (charset_table): New internal table. + (DEBUG_XFT0): + (DEBUG_XFT1): + (DEBUG_XFT2): + (PRINT_XFT_PATTERN): + (CHECKING_LANG): + New debugging macros. + (mule_to_fc_charset): New function. + (x_find_charset_font): Completely rewrite Xft part using the above. + + Cache knowledge of charset in font instances. + + * objects-impl.h (struct Lisp_Font_Instance): New member charset. + Update comment on use of truename. + * objects.c (syms_of_objects): DEFSUBR Ffont_instance_charset. + (Ffont_instance_charset): New accessor. + (Fmake_font_instance): New argument CHARSET, update charset member. + (font_instantiate): Update call to Fmake_font_instance. + (font_instance_description): Add charset member. + * objects.h (Fmake_font_instance): Update EXFUN. + (Ffont_instance_charset): New EXFUN. + + Make Xft debug level adjustable from Lisp. + + * xft-fonts.c (vars_of_xft_fonts): New DEFVAR_INT + xft-debug-level (from debug_xft), adjust style of xft-version. + * xft-fonts.h (debug_xft): Now Lisp-visible, change declaration. + + Miscellaneous. + + * lisp.h (Vcharset_iso8859_15): Export it. + * faces.h (struct face_cachel): Update comment on space usage. + * faces.c: Comment proposed changes to improve font handling. + * frame-x.c: + * EmacsShell-sub.c: + Disable geometry debugging. + +2005-02-24 Stephen J. Turnbull <stephen(a)xemacs.org&gt; + + * xft-fonts.h: + * xft-fonts.c: + Update copyright notices. + + * xft.fonts.h (string_list_to_fcobjectset): + (extract_fcapi_string): + Delete; static function declarations don't belong in headers. + + * xft.fonts.c (string_list_to_fcobjectset): + (extract_fcapi_string): + Declare. + Index: src/EmacsShell-sub.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/EmacsShell-sub.c,v retrieving revision 1.6.2.1 diff -u -r1.6.2.1 EmacsShell-sub.c --- src/EmacsShell-sub.c 1 Feb 2005 15:46:52 -0000 1.6.2.1 +++ src/EmacsShell-sub.c 5 Mar 2005 11:22:04 -0000 ＠＠ -245,7 +245,6 ＠＠ cell_height = w->wm.size_hints.height_inc; base_width = width - cell_width * w->emacs_shell.width_cells; base_height = height - cell_height * w->emacs_shell.height_cells; -#define DEBUG_GEOMETRY_MANAGEMENT #ifdef DEBUG_GEOMETRY_MANAGEMENT /* Very useful info when debugging geometry management problems. When it's guaranteed that no more such problems exist, take Index: src/faces.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.c,v retrieving revision 1.43.2.3 diff -u -r1.43.2.3 faces.c --- src/faces.c 24 Feb 2005 09:32:27 -0000 1.43.2.3 +++ src/faces.c 5 Mar 2005 11:22:05 -0000 ＠＠ -1033,7 +1033,10 ＠＠ } /* ensure that the given cachel contains an updated font value for - the given charset. Return the updated font value. */ + the given charset. Return the updated font value (which can be + Qunbound, so this value must not be passed unchecked to Lisp). + + #### Xft: This function will need to be updated for new font model. */ Lisp_Object ensure_face_cachel_contains_charset (struct face_cachel *cachel, ＠＠ -1384,6 +1387,7 ＠＠ } /* Initialize a cachel. */ +/* #### Xft: this function will need to be changed for new font model. */ void reset_face_cachel (struct face_cachel *cachel) ＠＠ -1465,6 +1469,7 ＠＠ Dynarr_atp (w->face_cachels, elt)->dirty = 0; } +/* #### Xft: this function will need to be changed for new font model. */ void mark_face_cachels_as_not_updated (struct window *w) { ＠＠ -2019,7 +2024,9 ＠＠ /* Note that fontconfig can search for several font families in one call. We should use this facility. */ "monospace-12", /* Western #### add encoding info? */ - /* do we need to worry about non-Latin characters for monospace? */ + /* do we need to worry about non-Latin characters for monospace? + No, at least in Debian's implementation of Xft. + We should recommend that "gothic" and "mincho" aliases be created? */ "Sazanami Mincho-12", /* Japanese #### add encoding info? */ /* Arphic for Chinese? */ /* Korean */ ＠＠ -2107,7 +2114,8 ＠＠ charset. (#### Bogus, but that's the way it currently works) sjt sez: With Xft/fontconfig that information is available as a - language support property. So what we need to do is to map charset + language support property. The character set (actually a bit + vector) is also available. So what we need to do is to map charset -> language (Mule redesign Phase 1) and eventually use language information in the buffer, then map to charsets (Phase 2) at font instantiation time. Index: src/faces.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.h,v retrieving revision 1.12.8.1 diff -u -r1.12.8.1 faces.h --- src/faces.h 25 Nov 2004 12:44:13 -0000 1.12.8.1 +++ src/faces.h 5 Mar 2005 11:22:06 -0000 ＠＠ -161,7 +161,9 ＠＠ of them. This avoids messing with Dynarrs. #### We should look into this and probably clean it up - to use Dynarrs. This may be a big space hog as is. */ + to use Dynarrs. This may be a big space hog as is. + sjt sez: doesn't look like it, my total face cache is 170KB. + Could be reduced to maybe 50KB. */ Lisp_Object font[NUM_LEADING_BYTES]; Lisp_Object display_table; Index: src/frame-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame-x.c,v retrieving revision 1.68.2.2 diff -u -r1.68.2.2 frame-x.c --- src/frame-x.c 1 Feb 2005 15:46:54 -0000 1.68.2.2 +++ src/frame-x.c 5 Mar 2005 11:22:07 -0000 ＠＠ -283,7 +283,6 ＠＠ if (!XtIsWMShell (wmshell)) abort (); -#define DEBUG_GEOMETRY_MANAGEMENT #ifdef DEBUG_GEOMETRY_MANAGEMENT /* See comment in EmacsShell.c */ printf ("x_wm_set_variable_size: %d %d\n", width, height); Index: src/lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.116.2.1 diff -u -r1.116.2.1 lisp.h --- src/lisp.h 11 Dec 2004 05:16:19 -0000 1.116.2.1 +++ src/lisp.h 5 Mar 2005 11:22:09 -0000 ＠＠ -4851,6 +4851,7 ＠＠ extern Lisp_Object Vcharset_latin_jisx0201; extern Lisp_Object Vcharset_cyrillic_iso8859_5; extern Lisp_Object Vcharset_latin_iso8859_9; +extern Lisp_Object Vcharset_latin_iso8859_15; extern Lisp_Object Vcharset_japanese_jisx0208_1978; extern Lisp_Object Vcharset_chinese_gb2312; extern Lisp_Object Vcharset_japanese_jisx0208; Index: src/objects-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-impl.h,v retrieving revision 1.3 diff -u -r1.3 objects-impl.h --- src/objects-impl.h 12 Jan 2003 11:08:19 -0000 1.3 +++ src/objects-impl.h 5 Mar 2005 11:22:09 -0000 ＠＠ -125,8 +125,13 ＠＠ call them to get the truename (#### in reality, they all probably just store the truename here if they know it, and nil otherwise; we should - check this and enforce it as a general policy) */ + check this and enforce it as a general policy + X and GTK do this, except that when they don't + know they return NAME and don't update TRUENAME. + MS Windows initializes TRUENAME when the font is + initialized. TTY doesn't do truename.) */ Lisp_Object device; + Lisp_Object charset; /* Mule charset, or whatever */ /* See comment in struct console about console variants. */ enum console_variant font_instance_type; ＠＠ -142,7 +147,8 ＠＠ }; #define FONT_INSTANCE_NAME(f) ((f)->name) -#define FONT_INSTANCE_TRUENAME(f) ((f)->name) +#define FONT_INSTANCE_TRUENAME(f) ((f)->truename) +#define FONT_INSTANCE_CHARSET(f) ((f)->charset) #define FONT_INSTANCE_DEVICE(f) ((f)->device) #define FONT_INSTANCE_ASCENT(f) ((f)->ascent) #define FONT_INSTANCE_DESCENT(f) ((f)->descent) ＠＠ -151,6 +157,7 ＠＠ #define XFONT_INSTANCE_NAME(f) FONT_INSTANCE_NAME (XFONT_INSTANCE (f)) #define XFONT_INSTANCE_TRUENAME(f) FONT_INSTANCE_TRUENAME (XFONT_INSTANCE (f)) +#define XFONT_INSTANCE_CHARSET(f) FONT_INSTANCE_CHARSET (XFONT_INSTANCE (f)) #define XFONT_INSTANCE_DEVICE(f) FONT_INSTANCE_DEVICE (XFONT_INSTANCE (f)) #define XFONT_INSTANCE_ASCENT(f) FONT_INSTANCE_ASCENT (XFONT_INSTANCE (f)) #define XFONT_INSTANCE_DESCENT(f) FONT_INSTANCE_DESCENT (XFONT_INSTANCE (f)) Index: src/objects-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-x.c,v retrieving revision 1.26.2.9 diff -u -r1.26.2.9 objects-x.c --- src/objects-x.c 24 Feb 2005 11:08:27 -0000 1.26.2.9 +++ src/objects-x.c 5 Mar 2005 11:22:10 -0000 ＠＠ -1019,7 +1019,113 ＠＠ return buffer; } } -#endif + +static FcCharSet * +mule_to_fc_charset (Lisp_Object cs) +{ + int ucode, i, j; + FcCharSet *fccs; + + CHECK_CHARSET (cs); + fccs = FcCharSetCreate (); + /* #### do we also need to deal with 94 vs. 96 charsets? + ie, how are SP and DEL treated in ASCII? non-graphic should return -1 */ + if (1 == XCHARSET_DIMENSION (cs)) + /* Unicode tables are indexed by offsets from ASCII SP, not by ASCII */ + for (i = 0; i < 96; i++) + { + ucode = ((int *) XCHARSET_TO_UNICODE_TABLE (cs))[i]; + if (ucode >= 0) + /* #### should check for allocation failure */ + FcCharSetAddChar (fccs, (FcChar32) ucode); + } + else if (2 == XCHARSET_DIMENSION (cs)) + /* Unicode tables are indexed by offsets from ASCII SP, not by ASCII */ + for (i = 0; i < 96; i++) + for (j = 0; j < 96; j++) + { + ucode = ((int **) XCHARSET_TO_UNICODE_TABLE (cs))[i][j]; + if (ucode >= 0) + /* #### should check for allocation failure */ + FcCharSetAddChar (fccs, (FcChar32) ucode); + } + else + { + FcCharSetDestroy (fccs); + fccs = NULL; + } + return fccs; +} + +/* print message to stderr: one string argument */ +#define DEBUG_XFT0(level,s) \ + if (debug_xft > level) stderr_out (s) + +/* print message to stderr: one formatted string argument */ +#define DEBUG_XFT1(level,format,s) \ + if (debug_xft > level) stderr_out (format, s) + +/* print message to stderr: two formatted string arguments */ +#define DEBUG_XFT2(level,format,s1,s2) \ + if (debug_xft > level) stderr_out (format, s1, s2) + +/* print an Xft pattern to stderr + LEVEL is the debug level (to compare to debug_xft) + FORMAT is a newline-terminated printf format with one %s for the pattern + PATTERN is an FcPattern *. */ +#define PRINT_XFT_PATTERN(level,format,pattern) \ + do { \ + FcChar8 *name = FcNameUnparse (pattern); \ + DEBUG_XFT1 (level, format, name); \ + free (name); \ + } while (0) + +/* print a progress message + LEVEL is the debug level (to compare to debug_xft) + FORMAT is a newline-terminated printf format with two %s for font and lang + FONT is the Xft font + LANG is the language being checked for support. */ +#define CHECKING_LANG(level,font,lang) \ + DEBUG_XFT2 (level, "checking if %s handles %s\n", font, lang) + +struct charset_reporter { + Lisp_Object *charset; + /* #### Mule-ize these strings? */ + Extbyte *language; + FcChar8 *rfc3066; +}; + +static struct charset_reporter charset_table[] = + { + /* #### it's my branch, my favorite charsets get checked first */ + { &Vcharset_ascii, "English", "en" }, + { &Vcharset_japanese_jisx0208, "Japanese", "ja" }, + { &Vcharset_japanese_jisx0212, "Japanese", "ja" }, + { &Vcharset_katakana_jisx0201, "Japanese", "ja" }, + { &Vcharset_latin_jisx0201, "Japanese", "ja" }, + { &Vcharset_japanese_jisx0208_1978, "Japanese", "ja" }, + { &Vcharset_greek_iso8859_7, "Greek", "gr" }, + { &Vcharset_chinese_gb2312, "simplified Chinese", "zh-CN" }, + { &Vcharset_korean_ksc5601, "Korean", "ko" }, + { &Vcharset_chinese_cns11643_1, "traditional Chinese", "zh-TW" }, + { &Vcharset_chinese_cns11643_2, "traditional Chinese", "zh-TW" }, + { &Vcharset_latin_iso8859_1, NULL, NULL }, + { &Vcharset_latin_iso8859_2, NULL, NULL }, + { &Vcharset_latin_iso8859_3, NULL, NULL }, + { &Vcharset_latin_iso8859_4, NULL, NULL }, + { &Vcharset_latin_iso8859_9, NULL, NULL }, + { &Vcharset_latin_iso8859_15, NULL, NULL }, + { &Vcharset_thai_tis620, NULL, NULL }, + { &Vcharset_arabic_iso8859_6, NULL, NULL }, + { &Vcharset_hebrew_iso8859_8, NULL, NULL }, + { &Vcharset_cyrillic_iso8859_5, NULL, NULL }, + /* #### these probably are not quite right */ + { &Vcharset_chinese_big5_1, "traditional Chinese", "zh-TW" }, + { &Vcharset_chinese_big5_2, "traditional Chinese", "zh-TW" }, + { NULL, NULL, NULL } + }; + +#endif /* USE_XFT */ /* find a font spec that matches font spec FONT and also matches (the registry of) CHARSET. */ ＠＠ -1044,126 +1150,158 ＠＠ if (stage) return Qnil; +#ifdef USE_XFT /* #### does Xft permit/require a different encoding? */ LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding); -#ifdef USE_XFT - if (debug_xft > 1) - stderr_out ("confirming charset for font instance %s\n", patternext); - /* #### totally lazy, let's just get something out the door */ + DEBUG_XFT1 (1, "confirming charset for font instance %s\n", patternext); + + /* #### this looks like a fair amount of work, but the basic design + has never been rethought, and it should be + + #### ALL THE OBJECTS CONSTRUCTED BY FcName(Un)Parse MUST BE FREED! + */ + waste = FcInit (); - if (waste) /* I don't think this can fail */ + if (!waste && debug_xft > 0) /* I don't think this can fail */ /* #### should we init in xft_fonts_init() and FcInitBringUpToDate() here? */ + stderr_out ("Failed fontconfig initialization\n"); + else if (waste) { FcChar8 *lang = "en"; + FcCharSet *fccs = NULL; + FcChar8 *shortname; + fcc = FcConfigGetCurrent (); - patternxft = FcNameParse (patternext); - if (debug_xft > 1) - stderr_out ("FcNameParse'ed name is %s\n", - FcNameUnparse (patternxft)); + patternxft = FcNameParse (patternext); /* #### needs freeing */ + PRINT_XFT_PATTERN (1,"FcNameParse'ed name is %s\n",patternxft); /* #### Next two return FcBool, but what does the return mean? */ - /* #### I wonder if the order of the next two should be reversed. */ + /* The order is correct according the fontconfig docs. */ FcConfigSubstitute (fcc, patternxft, FcMatchPattern); - if (debug_xft > 1) - stderr_out ("FcConfigSubstitute'ed name is %s\n", - FcNameUnparse (patternxft)); + PRINT_XFT_PATTERN (0,"FcConfigSubstitute'ed name is %s\n",patternxft); FcDefaultSubstitute (patternxft); - if (debug_xft > 0) - stderr_out ("FcDefaultSubstitute'ed name is %s\n", - FcNameUnparse (patternxft)); + PRINT_XFT_PATTERN (1,"FcDefaultSubstitute'ed name is %s\n",patternxft); patternxft = FcFontMatch (fcc, patternxft, &fcresult); - if (debug_xft > 0) - stderr_out ("FcFontMatch'ed name is %s\n", - FcNameUnparse (patternxft)); - - /* #### There's probably a way to do this with FcCharsets, but isn't - the language approach better in the long run? */ - /* #### can we regression test this, or does it break too early? */ - if (EQ (charset, Fget_charset (intern ("katakana-jisx0201"))) - || EQ (charset, Fget_charset (intern ("japanese-jisx0208"))) - || EQ (charset, Fget_charset (intern ("japanese-jisx0212")))) + PRINT_XFT_PATTERN (0,"FcFontMatch'ed name is %s\n",patternxft); + + /* heuristic to give reasonable-length names */ + { + FcPattern *p = FcFontRenderPrepare (fcc, patternxft, patternxft); + FcPatternDel (p, FC_CHARSET); + FcPatternDel (p, FC_LANG); + shortname = FcNameUnparse (p); /* #### needs freeing */ + FcPatternDestroy (p); + } + + /* The language approach may better in the long run, but we can't use + it based on Mule charsets; fontconfig doesn't provide a way to test + for unions of languages, etc. That will require support from the + text module. + + Optimization: cache the generated FcCharSet in the Mule charset. + Don't forget to destroy it if the Mule charset gets deallocated. */ + + struct charset_reporter *cr; + for (cr = charset_table; + cr->charset && !EQ (*(cr->charset), charset); + cr++) + ; + + if (cr->rfc3066) { - if (debug_xft > 0) - stderr_out ("checking if %s handles Japanese\n", patternext); - lang = "ja"; + CHECKING_LANG (0, shortname, cr->language); + lang = cr->rfc3066; } - else if (EQ (charset, Fget_charset (intern ("ascii")))) + else if (cr->charset) { - if (debug_xft > 0) - stderr_out ("checking if %s handles English\n", patternext); - lang = "en"; + /* #### what the hey, build 'em on the fly */ + /* #### in the case of error this could return NULL! */ + fccs = mule_to_fc_charset (charset); + lang = XSTRING_DATA (XSYMBOL (XCHARSET_NAME (charset))-> name); } else { - /* #### is this the right way to make a warning? */ + /* OK, we fell off the end of the table */ warn_when_safe_lispobj (intern ("xft"), intern ("alert"), list2 (build_string ("unchecked charset"), charset)); + /* #### THIS IS WRONG, WRONG, WRONG!! + It is why we never fall through to XLFD-checking. */ /* default to "en" */ } - /* #### stderr_out crashed in the next block; why? - probably because FcTypeOfValueToString below didn't get - an argument!! Fixed now, but watch for crashes. */ - { - int i = 0; - FcValue v; - /* the main event */ - FcResult r = FcPatternGet (patternxft, FC_LANG, i, &v); - if (r == FcResultMatch) - { - if (v.type != FcTypeLangSet) /* excessive paranoia */ - { - /* Urk! Fall back and punt to core font. */ - if (debug_xft > 0) - stderr_out ("Unexpected type of lang value (%s)\n", - FcTypeOfValueToString (v)); - /* uncomment this to not try core font */ - /* return Qnil; */ - } - else if (FcLangSetHasLang (v.u.l, lang) != FcLangDifferentLang) - { - if (debug_xft > 0) - stderr_out ("Xft font %s supports %s\n", patternext, lang); - /* heuristic to give reasonable-length names */ - FcPatternDel (patternxft, FC_CHARSET); - FcPatternDel (patternxft, FC_LANG); - return (build_string (FcNameUnparse (patternxft))); - } - /* assume everything supports English */ -#if 0 - /* KLUDGE!! */ - else if (!strcmp (lang, "en")) - { - if (debug_xft > 0) - stderr_out ("Xft font %s doesn't support en, using anyway\n", - patternext); - /* heuristic to give reasonable-length names */ - FcPatternDel (patternxft, FC_CHARSET); - FcPatternDel (patternxft, FC_LANG); - return (build_string (FcNameUnparse (patternxft))); - } -#endif - else - { - if (debug_xft > 0) - stderr_out ("Xft font %s doesn't support %s\n", - patternext, lang); - return Qnil; - } - } - if (debug_xft > 0) - stderr_out ("Unexpected result getting lang=%s\n", - FcResultToString (r)); - } + if (fccs) + { + /* check for character set coverage */ + Lisp_Object retval = Qunbound; + int i = 0; + FcCharSet *v; + FcResult r = FcPatternGetCharSet (patternxft, FC_CHARSET, i, &v); + + if (r == FcResultTypeMismatch) + { + /* Urk! Fall back and punt to core font. */ + DEBUG_XFT0 (0, "Unexpected type return in charset value\n"); + /* uncomment this to not try core font */ + /* retval = Qnil; */ + } + else if (r == FcResultMatch && FcCharSetIsSubset (fccs, v)) + { + DEBUG_XFT2 (0, "Xft font %s supports %s\n", shortname, lang); + /* #### would it be better to return shortname? */ + retval = (build_string (FcNameUnparse (patternxft))); + } + else + { + DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", + shortname, lang); + /* comment this to try the core font */ + retval = Qnil; + } + + /* clean up and maybe return */ + FcCharSetDestroy (fccs); + if (!UNBOUNDP (retval)) + return retval; + } + else + { + /* check for language coverage */ + int i = 0; + FcValue v; + /* the main event */ + FcResult r = FcPatternGet (patternxft, FC_LANG, i, &v); + if (r == FcResultMatch) + { + if (v.type != FcTypeLangSet) /* excessive paranoia */ + { + /* Urk! Fall back and punt to core font. */ + DEBUG_XFT1 (0, "Unexpected type of lang value (%s)\n", + FcTypeOfValueToString (v)); + /* uncomment this to not try core font */ + /* return Qnil; */ + } + else if (FcLangSetHasLang (v.u.l, lang) != FcLangDifferentLang) + { + DEBUG_XFT2 (0, "Xft font %s supports %s\n", shortname, lang); + /* #### would it be better to return shortname? */ + return (build_string (FcNameUnparse (patternxft))); + } + else + { + DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", + shortname, lang); + return Qnil; + } + } + DEBUG_XFT1 (0, "Unexpected result getting lang=%s\n", + FcResultToString (r)); + } } - else if (debug_xft > 0) - stderr_out ("Failed fontconfig initialization\n"); - if (debug_xft > 0) - stderr_out ("shit happens, try X11 charset match for %s\n", patternext); -#endif + DEBUG_XFT1 (0, "shit happens, try X11 charset match for %s\n", patternext); +#endif /* USE_XFT */ names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)), patternext, MAX_FONT_COUNT, &count); Index: src/objects.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.c,v retrieving revision 1.23 diff -u -r1.23 objects.c --- src/objects.c 4 Nov 2004 23:06:46 -0000 1.23 +++ src/objects.c 5 Mar 2005 11:22:10 -0000 ＠＠ -274,6 +274,7 ＠＠ { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, name)}, { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, truename)}, { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, device)}, + { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, charset)}, { XD_UNION, offsetof (Lisp_Font_Instance, data), XD_INDIRECT (0, 0), &font_instance_data_description }, { XD_END } ＠＠ -350,19 +351,23 ＠＠ Lisp_Font_Instance);  -DEFUN ("make-font-instance", Fmake_font_instance, 1, 3, 0, /* +/* #### Why is this exposed to Lisp? Used in: +x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft, +x-font-menu-load-font-core, mswindows-font-menu-load-font, +mswindows-frob-font-style-and-sizify, mswindows-frob-font-size. */ +DEFUN ("make-font-instance", Fmake_font_instance, 1, 4, 0, /* Return a new `font-instance' object named NAME. DEVICE specifies the device this object applies to and defaults to the selected device. An error is signalled if the font is unknown or cannot be allocated; however, if NOERROR is non-nil, nil is simply returned in -this case. +this case. CHARSET is used internally. #### make helper function? The returned object is a normal, first-class lisp object. The way you `deallocate' the font is the way you deallocate any other lisp object: you drop all pointers to it and allow it to be garbage collected. When -these objects are GCed, the underlying X data is deallocated as well. +these objects are GCed, the underlying GUI data is deallocated as well. */ - (name, device, noerror)) + (name, device, noerror, charset)) { Lisp_Font_Instance *f; int retval = 0; ＠＠ -387,6 +392,7 ＠＠ f->ascent = f->height = 1; f->descent = 0; f->width = 1; + f->charset = charset; f->proportional_p = 0; retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance, ＠＠ -489,6 +495,15 ＠＠ return font_instance_truename_internal (font_instance, ERROR_ME); } +DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* +Return the Mule charset that FONT-INSTANCE was allocated to handle. +*/ + (font_instance)) +{ + CHECK_FONT_INSTANCE (font_instance); + return XFONT_INSTANCE (font_instance)->charset; +} + DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* Return the properties (an alist or nil) of FONT-INSTANCE. */ ＠＠ -878,7 +893,7 ＠＠ if (UNBOUNDP (instance)) { /* make sure we cache the failures, too. */ - instance = Fmake_font_instance (instantiator, device, Qt); + instance = Fmake_font_instance (instantiator, device, Qt, charset); Fputhash (instantiator, instance, cache); } ＠＠ -1129,6 +1144,7 ＠＠ DEFSUBR (Ffont_instance_ascent); DEFSUBR (Ffont_instance_descent); DEFSUBR (Ffont_instance_width); + DEFSUBR (Ffont_instance_charset); DEFSUBR (Ffont_instance_proportional_p); DEFSUBR (Ffont_instance_truename); DEFSUBR (Ffont_instance_properties); Index: src/objects.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.h,v retrieving revision 1.10 diff -u -r1.10 objects.h --- src/objects.h 14 Sep 2004 14:32:52 -0000 1.10 +++ src/objects.h 5 Mar 2005 11:22:10 -0000 ＠＠ -58,10 +58,11 ＠＠ #define CHECK_FONT_INSTANCE(x) CHECK_RECORD (x, font_instance) #define CONCHECK_FONT_INSTANCE(x) CONCHECK_RECORD (x, font_instance) -EXFUN (Fmake_font_instance, 3); +EXFUN (Fmake_font_instance, 4); EXFUN (Ffont_instance_name, 1); EXFUN (Ffont_instance_p, 1); EXFUN (Ffont_instance_truename, 1); +EXFUN (Ffont_instance_charset, 1); extern Lisp_Object Vthe_null_font_instance; Index: src/xft-fonts.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/Attic/xft-fonts.c,v retrieving revision 1.1.2.7 diff -u -r1.1.2.7 xft-fonts.c --- src/xft-fonts.c 22 Feb 2005 13:03:12 -0000 1.1.2.7 +++ src/xft-fonts.c 5 Mar 2005 11:22:11 -0000 ＠＠ -1,13 +1,14 ＠＠ /* Lisp font handling implementation for X with Xft. Copyright (C) 2003 Eric Knauel and Matthias Neubauer -Copyright (C) 2004 Free Software Foundation, Inc. +Copyright (C) 2005 Eric Knauel +Copyright (C) 2004, 2005 Free Software Foundation, Inc. Authors: Eric Knauel <knauel(a)informatik.uni-tuebingen.de&gt; Matthias Neubauer <neubauer(a)informatik.uni-freiburg.de&gt; Stephen J. Turnbull <stephen(a)xemacs.org&gt; Created: 27 Oct 2003 -Updated: 24 Jul 2004 by Stephen J. Turnbull +Updated: 05 Mar 2005 by Stephen J. Turnbull This file is part of XEmacs. ＠＠ -46,9 +47,6 ＠＠ #include "objects-x-impl.h" #include "xft-fonts.h" -int debug_xft = 0; /* Set to 1 enables lots of obnoxious messages. - Setting it to 2 or 3 enables even more. */ - /* #### TO DO #### . The "x-xft-*" and "x_xft_*" nomenclature is mostly redundant, especially if we separate X fonts from Xft fonts, and use fontconfig more generally. ＠＠ -78,8 +76,13 ＠＠ Lisp_Object Qfc_internal_error; Lisp_Object Vxlfd_font_name_regexp; /* Really needed in initialization? */ Lisp_Object Vxft_version; +Fixnum debug_xft; /* Set to 1 enables lots of obnoxious messages. + Setting it to 2 or 3 enables even more. */ static Lisp_Object make_xlfd_font_regexp (void); +static void string_list_to_fcobjectset (Lisp_Object list, FcObjectSet *os); +/* #### need to change this to proper FcChar* */ +static inline char *extract_fcapi_string (Lisp_Object str); static const struct memory_description fcpattern_description [] = { { XD_LISP_OBJECT, offsetof (struct fc_pattern, fontset) }, ＠＠ -1091,10 +1094,20 ＠＠ void vars_of_xft_fonts (void) { + /* #### I know, but the right fix is use the generic debug facility. */ + DEFVAR_INT ("xft-debug-level", &debug_xft /* +Level of debugging messages to issue to stderr for Xft. +A nonnegative integer. Set to 0 to suppress all warnings. +Default is 1 to ensure a minimum of debugging output at initialization. +Higher levels give even more information. +*/ ); + debug_xft = 1; + DEFVAR_LISP("xft-version", &Vxft_version /* -The major version number of the Xft library being used */ - ); +The major version number of the Xft library being used. +*/ ); Vxft_version = make_int(XFT_VERSION); + Fprovide (intern ("xft")); } Index: src/xft-fonts.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/Attic/xft-fonts.h,v retrieving revision 1.1.2.4 diff -u -r1.1.2.4 xft-fonts.h --- src/xft-fonts.h 11 Feb 2005 15:39:08 -0000 1.1.2.4 +++ src/xft-fonts.h 5 Mar 2005 11:22:11 -0000 ＠＠ -1,13 +1,14 ＠＠ /* Lisp font data structures for X and Xft. Copyright (C) 2003 Eric Knauel and Matthias Neubauer -Copyright (C) 2004 Free Software Foundation, Inc. +Copyright (C) 2005 Eric Knauel +Copyright (C) 2004, 2005 Free Software Foundation, Inc. Authors: Eric Knauel <knauel(a)informatik.uni-tuebingen.de&gt; Matthias Neubauer <neubauer(a)informatik.uni-freiburg.de&gt; Stephen J. Turnbull <stephen(a)xemacs.org&gt; Created: 27 Oct 2003 -Updated: 24 Jul 2004 by Stephen J. Turnbull +Updated: 05 Mar 2005 by Stephen J. Turnbull This file is part of XEmacs. ＠＠ -44,7 +45,7 ＠＠ #include "../lwlib/lwlib-fonts.h" #include "../lwlib/lwlib-colors.h" -extern int debug_xft; +extern Fixnum debug_xft; /* #### new in xft reloaded #3; where is this used? */ XftColor xft_get_color (Display *dpy, Colormap cmap, Lisp_Object c, int dim); ＠＠ -89,11 +90,5 ＠＠ Lisp_Object fc_get_pattern_integer(Lisp_Object fcpat, Lisp_Object id, const char* objid); Lisp_Object fc_get_pattern_bool(Lisp_Object fcpat, Lisp_Object id, const char* objid); Lisp_Object fc_get_pattern_string(Lisp_Object fcpat, Lisp_Object id, const char* objid); - -static void -string_list_to_fcobjectset (Lisp_Object, FcObjectSet*); - -inline static char * -extract_fcapi_string (Lisp_Object str); #endif /* INCLUDED_xft_fonts_h_ */ -- Institute of Policy and Planning Sciences http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software.