In the spirit of communication, here’s a draft patch of some work to make Mule redisplay suck less, mainly on server-side X11. It involves: 1. No longer supporting the registry charset property (which was a regexp to match against X11 registries and encodings) to the same extent. Instead, each charset has a registries property, an ordered vector of non-regexp strings, specifying the actual X11 registries and encodings that have been seen in the wild for that charset, in order of preference. Patterns passed to XListFonts() are modified to have the X11 registries and encodings included. This gives a huge performance increase for looking up non-ASCII fonts, especially for negative results. Without this, in an xemacs -vanilla, M-? h takes a count of fifteen from typing the h to completed redisplay of HELLO, and that remains the same after a restart; with it, the same operation takes a count of 2, and is instantaneous after a restart. (This will be dependent on how many server-side fonts you have available; xlsfonts | wc -l gives me 4602.) Also a big improvement is that, if there is a font available that’s identical to that specified by default in the desired face except that it has the registry and encoding of the desired charset, that font is now selected immediately. A version of set-charset-registry is provided that prepends the given pattern to the registries supplied, and warns if it contains characters that would need to be quoted in a regexp. This is actually compatible with most places that use the charset registry; outside of the Mule implementors, very few people use it to its full extent. 2. Providing an optional third argument, CHARSET-PREDICATE to define-specifier-tag, and supporting this to allow you to choose the X11 font for a face - charset - device combination from Lisp, which was previously impossible. Sample code: (define-specifier-tag 'encode-as-utf-8 nil (lambda (charset) (charset-property charset 'encode-as-utf-8))) (define-specifier-tag 'x-server-side-fonts (lambda (device) (and (eq 'x (device-type device)) (not (featurep 'fontconfig))))) (set-face-font 'default "-misc-fixed-medium-r-normal--13-120-75-75-c-70-iso10646-1" nil '(x-server-side-fonts encode-as-utf-8) 'append) Remaining to do here before I feel comfortable with the changes are: 1. Charset-specific fallback XLFDs. (The below allows you to specify an XLFD for a face + charset + device combination; it doesn’t attempt any fallbacks.) This will be mostly device-independent once in place, so I intend adding charset-specific fallbacks for XFT (and perhaps even Windows) at the same time. 2.“Stage-2” X11 support; that is, when lookup of a font with the registry "Ethiopic-Unicode" fails, make a device-specific note of that, and try again with the registry "iso10646-1" and Unicode conversion in place. 3. Mechanical copying of the X11-specific code to the GTK port; perhaps a move to something like event-xlike-inc.c 4. Addition of a heuristic to xft_find_charset_font to accept reasonable font values for the fallback Unicode charsets. lisp/ChangeLog addition: 2006-08-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; * mule/arabic.el (arabic-digit): * mule/arabic.el (arabic-1-column): * mule/arabic.el (arabic-2-column): * mule/chinese.el (make-chinese-cns11643-charset): * mule/chinese.el (chinese-sisheng): * mule/english.el (ascii-right-to-left): * mule/ethiopic.el (ethiopic): * mule/european.el (latin-iso8859-14): * mule/european.el (latin-iso8859-16): * mule/indian.el (indian-is13194): * mule/indian.el (indian-1-column): * mule/indian.el (indian-2-column): * mule/japanese.el (japanese-jisx0213-1): * mule/japanese.el (japanese-jisx0213-2): * mule/lao.el (lao): * mule/misc-lang.el (ipa): * mule/mule-charset.el: * mule/thai-xtis.el (thai-xtis): * mule/tibetan.el (tibetan-1-column): * mule/tibetan.el (tibetan): * mule/vietnamese.el (vietnamese-viscii-lower): * mule/vietnamese.el (vietnamese-viscii-upper): Stop using the `registry' charset property; use `registries' instead. The difference is that registries is an ordered vector of X11 registries and encodings rather than a regexp; this means we can leave the matching to the X11 server, avoiding transferring huge amounts of data (perhaps across the network!) in order to do a regexp search on it. * mule/mule-charset.el (charset-registries): New. * mule/mule-charset.el (set-charset-registry): New. charset-registries returns the registries of a charset; 2006-08-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; * faces.el (set-face-font): Give more details on common values for font instantiators, LOCALEs. src/ChangeLog addition: 2006-08-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; * font-mgr.h: Move some XFT debug macros here from objects-x.c. * intl.c (init_intl): Correct a comment on garbage collecting. * faces.c (complex_vars_of_faces): Minimize the use of fallbacks for the moment. * charset.h: * lisp.h: * mule-charset.c: Remove the `registry' charset property; add the `registries' charset property; call setup_charset_initial_specifier_tags on charset creation. * objects-x.c: Handle Mule font instantiation less resource-intensively ; if we have the XLFD of a desired font, modify it to include the desired registry and encoding, _then_ call XListFonts. Eliminates calling XListFonts on a pattern of "*", which is nice, because the huge IPC necessary to parse that was a problem. * specifier.c: * specifier.h: Add a new optional argument, CHARSET-PREDICATE to define-specifier-tag. This is a function taking one charset argument; if the tag is to match that charset, it should return true, otherwise false. We want charset predicates to be false by default -- in contrast to device predicates -- and this means we now need two passes to match specifiers, if charset predicates have been specified. The implementation -- with caching of the predicate results -- is modelled on the device specifier tag cache. * unicode.c (unicode_to_ichar): Use the `registries' property when initialising the just-in-time Mule character setss. XEmacs Trunk source patch: Diff command: cvs -q diff -Nu Files affected: src/unicode.c src/specifier.h src/specifier.c src/objects-x.c src/mule-charset.c src/lisp.h src/intl.c src/font-mgr.h src/faces.c src/charset.h lisp/mule/vietnamese.el lisp/mule/tibetan.el lisp/mule/thai-xtis.el lisp/mule/mule-charset.el lisp/mule/misc-lang.el lisp/mule/lao.el lisp/mule/japanese.el lisp/mule/indian.el lisp/mule/european.el lisp/mule/ethiopic.el lisp/mule/english.el lisp/mule/chinese.el lisp/mule/arabic.el lisp/faces.el Index: lisp/faces.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/faces.el,v retrieving revision 1.38 diff -u -u -r1.38 faces.el --- lisp/faces.el 2006/04/25 14:01:52 1.38 +++ lisp/faces.el 2006/08/06 16:42:01 ＠＠ -483,15 +483,17 ＠＠ FACE may be either a face object or a symbol representing a face. -FONT should be an instantiator (see `make-font-specifier'), a list of - instantiators, an alist of specifications (each mapping a - locale to an instantiator list), or a font specifier object. +FONT should be an instantiator (see `make-font-specifier'; a common + instantiator is a platform-dependent string naming the font), a list + of instantiators, an alist of specifications (each mapping a locale + to an instantiator list), or a font specifier object. -If FONT is an alist, LOCALE must be omitted. If FONT is a - specifier object, LOCALE can be a locale, a locale type, `all', - or nil; see `copy-specifier' for its semantics. Otherwise LOCALE - specifies the locale under which the specified instantiator(s) - will be added, and defaults to `global'. +If FONT is an alist, LOCALE must be omitted. If FONT is a specifier + object, LOCALE can be a locale, a locale type, `all', or nil; see + `copy-specifier' for its semantics. Common LOCALEs are buffers + objects, windows objects, device objects and `global'. Otherwise + LOCALE specifies the locale under which the specified + instantiator(s) will be added, and defaults to `global'. See `set-face-property' for more information." (interactive (face-interactive "font")) Index: lisp/mule/arabic.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/arabic.el,v retrieving revision 1.7 diff -u -u -r1.7 arabic.el --- lisp/mule/arabic.el 2002/03/16 10:39:05 1.7 +++ lisp/mule/arabic.el 2006/08/06 16:42:01 ＠＠ -47,9 +47,8 ＠＠ ;; Others are of direction right-to-left and of width 1-column or ;; 2-column. (make-charset 'arabic-digit "Arabic digit" - '(dimension - 1 - registry "MuleArabic-0" + '(dimension 1 + registries ["MuleArabic-0"] chars 94 columns 1 direction l2r ＠＠ -62,7 +61,7 ＠＠ (make-charset 'arabic-1-column "Arabic 1-column" '(dimension 1 - registry "MuleArabic-1" + registries ["MuleArabic-1"] chars 94 columns 1 direction r2l ＠＠ -75,7 +74,7 ＠＠ (make-charset 'arabic-2-column "Arabic 2-column" '(dimension 1 - registry "MuleArabic-2" + registries ["MuleArabic-2"] chars 94 columns 2 direction r2l Index: lisp/mule/chinese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/chinese.el,v retrieving revision 1.12 diff -u -u -r1.12 chinese.el --- lisp/mule/chinese.el 2005/12/24 22:31:51 1.12 +++ lisp/mule/chinese.el 2006/08/06 16:42:01 ＠＠ -146,8 +146,8 ＠＠ (name plane final) (make-charset name (concat "CNS 11643 Plane " plane " (Chinese traditional)") - `(registry - ,(concat "CNS11643[.-]\\(.*[.-]\\)?" plane "$") + `(registries + ,(vector (concat "cns11643.1992-" plane )) dimension 2 chars 94 final ,final ＠＠ -171,7 +171,7 ＠＠ (make-charset ;; not in FSF 21.1 'chinese-isoir165 "ISO-IR-165 (CCITT Extended GB; Chinese simplified)" - `(registry "isoir165" + `(registries ["isoir165-0"] dimension 2 chars 94 final ?E ＠＠ -185,7 +185,7 ＠＠ '(dimension 1 ;; XEmacs addition: second half of registry spec - registry "sisheng_cwnn\\|OMRON_UDC_ZH" + registries ["omron_udc_zh-0" "sisheng_cwnn-0"] chars 94 columns 1 direction l2r Index: lisp/mule/english.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/english.el,v retrieving revision 1.6 diff -u -u -r1.6 english.el --- lisp/mule/english.el 2002/03/29 04:46:41 1.6 +++ lisp/mule/english.el 2006/08/06 16:42:01 ＠＠ -36,7 +36,7 ＠＠ "ASCII (left half of ISO 8859-1) with right-to-left direction" '(dimension 1 - registry "ISO8859-1" + registries ["ISO8859-1"] chars 94 columns 1 direction r2l Index: lisp/mule/ethiopic.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/ethiopic.el,v retrieving revision 1.6 diff -u -u -r1.6 ethiopic.el --- lisp/mule/ethiopic.el 2002/03/16 10:39:06 1.6 +++ lisp/mule/ethiopic.el 2006/08/06 16:42:01 ＠＠ -32,7 +32,7 ＠＠ (make-charset 'ethiopic "Ethiopic characters" '(dimension 2 - registry "Ethiopic-Unicode" + registries ["Ethiopic-Unicode"] chars 94 columns 2 direction l2r Index: lisp/mule/european.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/european.el,v retrieving revision 1.12 diff -u -u -r1.12 european.el --- lisp/mule/european.el 2005/05/10 17:02:59 1.12 +++ lisp/mule/european.el 2006/08/06 16:42:01 ＠＠ -121,7 +121,7 ＠＠ "Right-Hand Part of Latin Alphabet 8 (ISO/IEC 8859-14)" '(dimension 1 - registry "ISO8859-14" + registries ["ISO8859-14"] chars 96 columns 1 direction l2r ＠＠ -135,7 +135,7 ＠＠ "Right-Hand Part of Latin Alphabet 10 (ISO/IEC 8859-16)" '(dimension 1 - registry "ISO8859-16" + registries ["ISO8859-16"] chars 96 columns 1 direction l2r Index: lisp/mule/indian.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/indian.el,v retrieving revision 1.3 diff -u -u -r1.3 indian.el --- lisp/mule/indian.el 2002/03/16 10:39:06 1.3 +++ lisp/mule/indian.el 2006/08/06 16:42:01 ＠＠ -99,7 +99,7 ＠＠ "Generic Indian charset for data exchange with IS 13194" '(dimension 1 - registry "IS13194-Devanagari" + registries ["IS13194-Devanagari"] chars 94 columns 2 direction l2r ＠＠ -114,7 +114,7 ＠＠ "Indian charset for 2-column width glyphs" '(dimension 2 - registry "MuleIndian-1" + registries ["MuleIndian-1"] chars 94 columns 1 direction l2r ＠＠ -129,7 +129,7 ＠＠ "Indian charset for 2-column width glyphs" '(dimension 2 - registry "MuleIndian-2" + registries ["MuleIndian-2"] chars 94 columns 2 direction l2r Index: lisp/mule/japanese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/japanese.el,v retrieving revision 1.11 diff -u -u -r1.11 japanese.el --- lisp/mule/japanese.el 2004/01/29 05:22:40 1.11 +++ lisp/mule/japanese.el 2006/08/06 16:42:01 ＠＠ -106,7 +106,7 ＠＠ (make-charset 'japanese-jisx0213-1 "JISX0213 Plane 1 (Japanese)" '(dimension 2 - registry "JISX0213.2000-1" + registries ["JISX0213.2000-1"] chars 94 columns 2 direction l2r ＠＠ -120,7 +120,7 ＠＠ (make-charset 'japanese-jisx0213-2 "JISX0213 Plane 2 (Japanese)" '(dimension 2 - registry "JISX0213.2000-2" + registries ["JISX0213.2000-2"] chars 94 columns 2 direction l2r Index: lisp/mule/lao.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/lao.el,v retrieving revision 1.4 diff -u -u -r1.4 lao.el --- lisp/mule/lao.el 2002/03/18 10:07:37 1.4 +++ lisp/mule/lao.el 2006/08/06 16:42:01 ＠＠ -33,7 +33,7 ＠＠ (make-charset 'lao "Lao characters (ISO10646 0E80..0EDF)" '(dimension 1 - registry "MuleLao-1" + registries ["MuleLao-1"] chars 94 columns 1 direction l2r Index: lisp/mule/misc-lang.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/misc-lang.el,v retrieving revision 1.5 diff -u -u -r1.5 misc-lang.el --- lisp/mule/misc-lang.el 2002/03/16 10:39:07 1.5 +++ lisp/mule/misc-lang.el 2006/08/06 16:42:01 ＠＠ -34,7 +34,7 ＠＠ (make-charset 'ipa "IPA (International Phonetic Association)" '(dimension 1 - registry "MuleIPA" + registries ["MuleIPA"] chars 96 columns 1 direction l2r Index: lisp/mule/mule-charset.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/mule-charset.el,v retrieving revision 1.18 diff -u -u -r1.18 mule-charset.el --- lisp/mule/mule-charset.el 2005/12/23 11:42:35 1.18 +++ lisp/mule/mule-charset.el 2006/08/06 16:42:02 ＠＠ -106,12 +106,29 ＠＠ 0 1)) -;; Not in Emacs/Mule +;; Not in GNU Emacs/Mule (defun charset-registry (charset) "Return the registry of CHARSET. This is a regular expression matching the registry field of fonts that can display the characters in CHARSET." - (charset-property charset 'registry)) + (lwarn 'xintl 'warning + "charset-registry is obsolete--use charset-registries instead. ") + (when (charset-property charset 'registries) + (elt 0 (charset-property charset 'registries)))) + +(defun charset-registries (charset) + "Return the registries of CHARSET." + (charset-property charset 'registries)) + +(defun set-charset-registry (charset registry) + "Obsolete; use set-charset-registries instead. " + (check-argument-type 'stringp registry) + (check-argument-type 'charsetp (find-charset charset)) + (assert (equal registry (regexp-quote registry)) t + "We don't accept regexps in set-charset-registry any more.") + (set-charset-registries + charset + (apply 'vector registry (append (charset-registries charset) nil)))) (defun charset-ccl-program (charset) "Return the CCL program of CHARSET. Index: lisp/mule/thai-xtis.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/thai-xtis.el,v retrieving revision 1.4 diff -u -u -r1.4 thai-xtis.el --- lisp/mule/thai-xtis.el 2002/03/18 10:07:37 1.4 +++ lisp/mule/thai-xtis.el 2006/08/06 16:42:02 ＠＠ -35,12 +35,12 ＠＠ ;;; Code: (make-charset 'thai-xtis "Precomposed Thai (XTIS by Virach)." - '(registry "xtis-0" - dimension 2 - columns 1 - chars 94 - final ?? - graphic 0)) + '(registries ["xtis-0"] + dimension 2 + columns 1 + chars 94 + final ?? + graphic 0)) (define-category ?x "Precomposed Thai character.") (modify-category-entry 'thai-xtis ?x) Index: lisp/mule/tibetan.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/tibetan.el,v retrieving revision 1.3 diff -u -u -r1.3 tibetan.el --- lisp/mule/tibetan.el 2002/03/16 10:39:07 1.3 +++ lisp/mule/tibetan.el 2006/08/06 16:42:02 ＠＠ -87,7 +87,7 ＠＠ (make-charset 'tibetan-1-column "Tibetan 1 column glyph" '(dimension 2 - registry "MuleTibetan-1" + registries ["MuleTibetan-1"] chars 94 columns 1 direction l2r ＠＠ -101,7 +101,7 ＠＠ (make-charset 'tibetan "Tibetan characters" '(dimension 2 - registry "MuleTibetan-2" + registries ["MuleTibetan-2"] chars 94 columns 2 direction l2r Index: lisp/mule/vietnamese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/vietnamese.el,v retrieving revision 1.6 diff -u -u -r1.6 vietnamese.el --- lisp/mule/vietnamese.el 2002/03/21 07:30:24 1.6 +++ lisp/mule/vietnamese.el 2006/08/06 16:42:02 ＠＠ -37,7 +37,7 ＠＠ (make-charset 'vietnamese-viscii-lower "VISCII1.1 lower-case" '(dimension 1 - registry "VISCII1.1" + registries ["VISCII1.1"] chars 96 columns 1 direction l2r ＠＠ -50,7 +50,7 ＠＠ (make-charset 'vietnamese-viscii-upper "VISCII1.1 upper-case" '(dimension 1 - registry "VISCII1.1" + registries ["VISCII1.1"] chars 96 columns 1 direction l2r Index: src/charset.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/charset.h,v retrieving revision 1.14 diff -u -u -r1.14 charset.h --- src/charset.h 2006/07/07 23:01:11 1.14 +++ src/charset.h 2006/08/06 16:42:03 ＠＠ -186,7 +186,7 ＠＠ int id; Lisp_Object name; Lisp_Object doc_string; - Lisp_Object registry; + Lisp_Object registries; Lisp_Object short_name; Lisp_Object long_name; ＠＠ -271,7 +271,7 ＠＠ #define CHARSET_DIRECTION(cs) ((cs)->direction) #define CHARSET_FINAL(cs) ((cs)->final) #define CHARSET_DOC_STRING(cs) ((cs)->doc_string) -#define CHARSET_REGISTRY(cs) ((cs)->registry) +#define CHARSET_REGISTRIES(cs) ((cs)->registries) #define CHARSET_CCL_PROGRAM(cs) ((cs)->ccl_program) #define CHARSET_DIMENSION(cs) ((cs)->dimension) #define CHARSET_CHARS(cs) ((cs)->chars) ＠＠ -280,7 +280,6 ＠＠ #define CHARSET_FROM_UNICODE_TABLE(cs) ((cs)->from_unicode_table) #define CHARSET_FROM_UNICODE_LEVELS(cs) ((cs)->from_unicode_levels) - #define CHARSET_PRIVATE_P(cs) leading_byte_private_p (CHARSET_LEADING_BYTE (cs)) #define XCHARSET_ID(cs) CHARSET_ID (XCHARSET (cs)) ＠＠ -295,11 +294,12 ＠＠ #define XCHARSET_DIRECTION(cs) CHARSET_DIRECTION (XCHARSET (cs)) #define XCHARSET_FINAL(cs) CHARSET_FINAL (XCHARSET (cs)) #define XCHARSET_DOC_STRING(cs) CHARSET_DOC_STRING (XCHARSET (cs)) -#define XCHARSET_REGISTRY(cs) CHARSET_REGISTRY (XCHARSET (cs)) +#define XCHARSET_REGISTRIES(cs) CHARSET_REGISTRIES (XCHARSET (cs)) #define XCHARSET_LEADING_BYTE(cs) CHARSET_LEADING_BYTE (XCHARSET (cs)) #define XCHARSET_CCL_PROGRAM(cs) CHARSET_CCL_PROGRAM (XCHARSET (cs)) #define XCHARSET_DIMENSION(cs) CHARSET_DIMENSION (XCHARSET (cs)) #define XCHARSET_CHARS(cs) CHARSET_CHARS (XCHARSET (cs)) + #define XCHARSET_PRIVATE_P(cs) CHARSET_PRIVATE_P (XCHARSET (cs)) #define XCHARSET_REVERSE_DIRECTION_CHARSET(cs) \ CHARSET_REVERSE_DIRECTION_CHARSET (XCHARSET (cs)) Index: src/faces.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.c,v retrieving revision 1.49 diff -u -u -r1.49 faces.c --- src/faces.c 2005/11/26 11:46:08 1.49 +++ src/faces.c 2006/08/06 16:42:04 ＠＠ -2063,7 +2063,7 ＠＠ #else /************** ISO-8859 fonts *************/ - +#ifndef MULE "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*", /* under USE_XFT, we always succeed, so let's not waste the effort */ "-*-fixed-medium-r-*-*-*-120-*-*-*-*-iso8859-*", ＠＠ -2092,7 +2092,6 ＠＠ "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*", "-*-*-*-r-*-*-*-*-*-*-*-*-iso8859-*", "-*-*-*-*-*-*-*-*-*-*-*-*-iso8859-*", - /************* Japanese fonts ************/ /* Following 3 fonts proposed by Teruhiko.Kurosaka(a)Japan.eng.sun */ ＠＠ -2196,6 +2195,7 ＠＠ "-*-*-*-r-*-*-*-120-*-*-*-*-*-*", "-*-*-*-*-*-*-*-120-*-*-*-*-*-*", "-*-*-*-*-*-*-*-*-*-*-*-*-*-*", +#endif /* MULE */ "*" #endif }; Index: src/font-mgr.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/font-mgr.h,v retrieving revision 1.2 diff -u -u -r1.2 font-mgr.h --- src/font-mgr.h 2006/04/25 14:02:09 1.2 +++ src/font-mgr.h 2006/08/06 16:42:04 ＠＠ -68,4 +68,75 ＠＠ #define CONCHECK_FCPATTERN(x) CONCHECK_RECORD (x, fc_pattern) #define XFCPATTERN_PTR(x) (XFCPATTERN(x)->fcpatPtr) +#ifdef USE_XFT +/* #### all these #defines should probably move to font-mgr.h */ + +/* + The format of a fontname (as returned by fontconfig) is not well-documented, + But the character repertoire is represented in an ASCII-compatible way. See + fccharset.c (FcCharSetUnparse). So we can use UTF-8 for long names. + + Currently we have a hack where different versions of the unparsed name are + used in different contexts fairly arbitrarily. I don't think this is close + to coherency; even without the charset and lang properties fontconfig names + are too unwieldy to use. We need to rethink the approach here. I think + probably Lisp_Font_Instance.name should contain the font name as specified + to Lisp (almost surely much shorter than shortname, even, and most likely + wildcarded), while Lisp_Font_Instance.truename should contain the longname. + For now, I'm going to #ifdef the return values defaulting to short. -- sjt +*/ + +/* DEBUGGING STUFF */ + +/* print message to stderr: one internal-format string argument */ +#define DEBUG_XFT0(level,s) \ + if (debug_xft > level) stderr_out (s) + +/* print message to stderr: one formatted argument */ +#define DEBUG_XFT1(level,format,x1) \ + if (debug_xft > level) stderr_out (format, x1) + +/* print message to stderr: two formatted arguments */ +#define DEBUG_XFT2(level,format,x1,x2) \ + if (debug_xft > level) stderr_out (format, x1, x2) + +/* print message to stderr: three formatted arguments */ +#define DEBUG_XFT3(level,format,x1,x2,x3) \ + if (debug_xft > level) stderr_out (format, x1, x2, x3) + +/* print message to stderr: four formatted arguments */ +#define DEBUG_XFT4(level,format,x1,x2,x3,x4) \ + if (debug_xft > level) stderr_out (format, x1, x2, x3, x4) + +/* 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 + and must be internal format (eg, pure ASCII) + PATTERN is an FcPattern *. */ +#define PRINT_XFT_PATTERN(level,format,pattern) \ + do { \ + DECLARE_EISTRING (eistrpxft_name); \ + FcChar8 *name = FcNameUnparse (pattern); \ + \ + eicpy_ext(eistrpxft_name, name, Qfc_font_name_encoding); \ + DEBUG_XFT1 (level, format, eidata(eistrpxft_name)); \ + free (name); \ + } while (0) + +/* print a progress message + LEVEL is the debug level (to compare to debug_xft) + FONT is the Xft font name in UTF-8 (the native encoding of Xft) + LANG is the language being checked for support (must be ASCII). */ +#define CHECKING_LANG(level,font,lang) \ + do { \ + DECLARE_EISTRING (eistrcl_name); \ + eicpy_ext(eistrcl_name, font, Qfc_font_name_encoding); \ + DEBUG_XFT2 (level, "checking if %s handles %s\n", \ + eidata(eistrcl_name), lang); \ + } while (0) + +#else /* USE_XFT */ + +#endif /* USE_XFT */ + #endif /* INCLUDED_font_mgr_h_ */ Index: src/intl.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/intl.c,v retrieving revision 1.10 diff -u -u -r1.10 intl.c --- src/intl.c 2005/09/24 16:31:39 1.10 +++ src/intl.c 2006/08/06 16:42:05 ＠＠ -167,7 +167,7 ＠＠ void init_intl (void) { - /* This function can GC */ + /* This function cannot GC, because it explicitly prevents it. */ if (initialized) { int count = begin_gc_forbidden (); Index: src/lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.143 diff -u -u -r1.143 lisp.h --- src/lisp.h 2006/07/08 16:15:56 1.143 +++ src/lisp.h 2006/08/06 16:42:07 ＠＠ -5601,7 +5601,7 ＠＠ extern Lisp_Object Qprogn, Qquit, Qquote, Qrange_error; extern Lisp_Object Qread_char, Qread_from_minibuffer; extern Lisp_Object Qreally_early_error_handler, Qregion_beginning; -extern Lisp_Object Qregion_end, Qregistry, Qreverse_direction_charset; +extern Lisp_Object Qregion_end, Qregistries, Qreverse_direction_charset; extern Lisp_Object Qrun_hooks, Qsans_modifiers, Qsave_buffers_kill_emacs; extern Lisp_Object Qself_insert_command, Qself_insert_defer_undo, Qsequencep; extern Lisp_Object Qset, Qsetting_constant, Qshort_name, Qsingularity_error; Index: src/mule-charset.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mule-charset.c,v retrieving revision 1.47 diff -u -u -r1.47 mule-charset.c --- src/mule-charset.c 2006/06/03 17:50:54 1.47 +++ src/mule-charset.c 2006/08/06 16:42:08 ＠＠ -35,6 +35,7 ＠＠ #include "lstream.h" #include "mule-ccl.h" #include "objects.h" +#include "specifier.h" /* The various pre-defined charsets. */ ＠＠ -79,7 +80,7 ＠＠ Lisp_Object Qcharsetp; /* Qdoc_string, Qdimension, Qchars defined in general.c */ -Lisp_Object Qregistry, Qfinal, Qgraphic; +Lisp_Object Qregistries, Qfinal, Qgraphic; Lisp_Object Qdirection; Lisp_Object Qreverse_direction_charset; Lisp_Object Qshort_name, Qlong_name; ＠＠ -128,7 +129,7 ＠＠ mark_object (cs->short_name); mark_object (cs->long_name); mark_object (cs->doc_string); - mark_object (cs->registry); + mark_object (cs->registries); mark_object (cs->ccl_program); return cs->name; } ＠＠ -158,7 +159,7 ＠＠ CHARSET_COLUMNS (cs), CHARSET_GRAPHIC (cs), CHARSET_FINAL (cs)); - print_internal (CHARSET_REGISTRY (cs), printcharfun, 0); + print_internal (CHARSET_REGISTRIES (cs), printcharfun, 0); write_fmt_string (printcharfun, " 0x%x>", cs->header.uid); } ＠＠ -167,7 +168,7 ＠＠ { XD_INT, offsetof (Lisp_Charset, from_unicode_levels) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, name) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, doc_string) }, - { XD_LISP_OBJECT, offsetof (Lisp_Charset, registry) }, + { XD_LISP_OBJECT, offsetof (Lisp_Charset, registries) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, short_name) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, long_name) }, { XD_LISP_OBJECT, offsetof (Lisp_Charset, reverse_direction_charset) }, ＠＠ -239,7 +240,8 ＠＠ CHARSET_GRAPHIC (cs) = graphic; CHARSET_FINAL (cs) = final; CHARSET_DOC_STRING (cs) = doc; - CHARSET_REGISTRY (cs) = reg; + CHECK_VECTOR(reg); + CHARSET_REGISTRIES (cs) = reg; CHARSET_ENCODE_AS_UTF_8 (cs) = encode_as_utf_8 ? 1 : 0; CHARSET_CCL_PROGRAM (cs) = Qnil; CHARSET_REVERSE_DIRECTION_CHARSET (cs) = Qnil; ＠＠ -271,6 +273,8 ＠＠ } recalculate_unicode_precedence (); + setup_charset_initial_specifier_tags (obj); + return obj; } ＠＠ -419,8 +423,8 ＠＠ `short-name' Short version of the charset name (ex: Latin-1) `long-name' Long version of the charset name (ex: ISO8859-1 (Latin-1)) -`registry' A regular expression matching the font registry field for - this character set. +`registries' A vector of possible XLFD REGISTRY-ENCODING combinations for + this character set. Note that this is not a regular expression. `dimension' Number of octets used to index a character in this charset. Either 1 or 2. Defaults to 1. `columns' Number of columns used to display a character in this charset. ＠＠ -468,7 +472,7 ＠＠ Ibyte final = 0; int direction = CHARSET_LEFT_TO_RIGHT; int type; - Lisp_Object registry = Qnil; + Lisp_Object registries = Qnil; Lisp_Object charset = Qnil; Lisp_Object ccl_program = Qnil; Lisp_Object short_name = Qnil, long_name = Qnil; ＠＠ -538,10 +542,10 ＠＠ invalid_constant ("Invalid value for `graphic'", value); } - else if (EQ (keyword, Qregistry)) + else if (EQ (keyword, Qregistries)) { - CHECK_STRING (value); - registry = value; + CHECK_VECTOR (value); + registries = value; } else if (EQ (keyword, Qdirection)) ＠＠ -613,8 +617,8 ＠＠ } if (NILP (doc_string)) doc_string = build_string (""); - if (NILP (registry)) - registry = build_string (""); + if (NILP (registries)) + registries = make_vector(0, Qnil); if (NILP (short_name)) short_name = XSYMBOL (name)->name; if (NILP (long_name)) ＠＠ -624,7 +628,7 ＠＠ charset = make_charset (id, name, dimension + 2, type, columns, graphic, final, direction, short_name, long_name, - doc_string, registry, !NILP (existing_charset), + doc_string, registries, !NILP (existing_charset), encode_as_utf_8); XCHARSET (charset)->temporary = temporary; ＠＠ -657,7 +661,7 ＠＠ int id, dimension, columns, graphic, encode_as_utf_8; Ibyte final; int direction, type; - Lisp_Object registry, doc_string, short_name, long_name; + Lisp_Object registries, doc_string, short_name, long_name; Lisp_Charset *cs; charset = Fget_charset (charset); ＠＠ -684,12 +688,12 ＠＠ doc_string = CHARSET_DOC_STRING (cs); short_name = CHARSET_SHORT_NAME (cs); long_name = CHARSET_LONG_NAME (cs); - registry = CHARSET_REGISTRY (cs); + registries = CHARSET_REGISTRIES (cs); encode_as_utf_8 = CHARSET_ENCODE_AS_UTF_8 (cs); new_charset = make_charset (id, new_name, dimension + 2, type, columns, graphic, final, direction, short_name, long_name, - doc_string, registry, 0, encode_as_utf_8); + doc_string, registries, 0, encode_as_utf_8); CHARSET_REVERSE_DIRECTION_CHARSET (cs) = new_charset; XCHARSET_REVERSE_DIRECTION_CHARSET (new_charset) = charset; ＠＠ -820,7 +824,7 ＠＠ if (EQ (prop, Qgraphic)) return make_int (CHARSET_GRAPHIC (cs)); if (EQ (prop, Qfinal)) return make_char (CHARSET_FINAL (cs)); if (EQ (prop, Qchars)) return make_int (CHARSET_CHARS (cs)); - if (EQ (prop, Qregistry)) return CHARSET_REGISTRY (cs); + if (EQ (prop, Qregistries)) return CHARSET_REGISTRIES (cs); if (EQ (prop, Qencode_as_utf_8)) return CHARSET_ENCODE_AS_UTF_8 (cs) ? Qt : Qnil; if (EQ (prop, Qccl_program)) return CHARSET_CCL_PROGRAM (cs); ＠＠ -861,16 +865,40 ＠＠ face_property_was_changed (Vdefault_face, Qfont, Qglobal); return Qnil; } + +DEFUN ("set-charset-registries", Fset_charset_registries, 2, 2, 0, /* +Set the `registries' property of CHARSET to REGISTRIES. -/* Japanese folks may want to (set-charset-registry 'ascii "jisx0201") */ -DEFUN ("set-charset-registry", Fset_charset_registry, 2, 2, 0, /* -Set the `registry' property of CHARSET to REGISTRY. +REGISTRIES is an ordered vector of strings that describe the X11 +CHARSET_REGISTRY and the CHARSET_ENCODINGs appropriate for this charset. +Separate each registry from the corresponding encoding with a dash. The +strings are not regular expressions, in contrast to the old behavior of +the `charset-registry' property. + +One reason to call this function might be if you're in Japan and you'd +prefer the backslash to display as a Yen sign; the corresponding syntax +would be: + +(set-charset-registries 'ascii ["jisx0201.1976-0"]) + */ - (charset, registry)) + (charset, registries)) { + int i; charset = Fget_charset (charset); - CHECK_STRING (registry); - XCHARSET_REGISTRY (charset) = registry; + CHECK_VECTOR (registries); + + for (i = 0; i < XVECTOR_LENGTH(registries); ++i) + { + CHECK_STRING (XVECTOR_DATA(registries)[i]); + if (NULL == qxestrchr(XSTRING_DATA(XVECTOR_DATA(registries)[i]), '-')) + { + invalid_argument("Not an X11 REGISTRY-ENCODING combination", + XVECTOR_DATA(registries)[i]); + } + } + + XCHARSET_REGISTRIES (charset) = registries; invalidate_charset_font_caches (charset); face_property_was_changed (Vdefault_face, Qfont, Qglobal); return Qnil; ＠＠ -967,14 +995,14 ＠＠ DEFSUBR (Fcharset_property); DEFSUBR (Fcharset_id); DEFSUBR (Fset_charset_ccl_program); - DEFSUBR (Fset_charset_registry); + DEFSUBR (Fset_charset_registries); #ifdef MEMORY_USAGE_STATS DEFSUBR (Fcharset_memory_usage); #endif DEFSYMBOL (Qcharsetp); - DEFSYMBOL (Qregistry); + DEFSYMBOL (Qregistries); DEFSYMBOL (Qfinal); DEFSYMBOL (Qgraphic); DEFSYMBOL (Qdirection); ＠＠ -1056,7 +1084,9 ＠＠ build_string ("ASCII"), build_msg_string ("ASCII"), build_msg_string ("ASCII (ISO646 IRV)"), - build_string ("\\(iso8859-[0-9]*\\|-ascii\\)"), 0, 0); + vector3(build_string("iso8859-1"), + build_string("ascii-0"), + build_string("iso8859-2")), 0, 0); staticpro (&Vcharset_control_1); Vcharset_control_1 = make_charset (LEADING_BYTE_CONTROL_1, Qcontrol_1, 2, ＠＠ -1065,7 +1095,7 ＠＠ build_string ("C1"), build_msg_string ("Control characters"), build_msg_string ("Control characters 128-191"), - build_string (""), 0, 0); + vector1(build_string("iso8859-1")), 0, 0); staticpro (&Vcharset_latin_iso8859_1); Vcharset_latin_iso8859_1 = make_charset (LEADING_BYTE_LATIN_ISO8859_1, Qlatin_iso8859_1, 2, ＠＠ -1074,7 +1104,7 ＠＠ build_string ("Latin-1"), build_msg_string ("ISO8859-1 (Latin-1)"), build_msg_string ("ISO8859-1 (Latin-1)"), - build_string ("iso8859-1"), 0, 0); + vector1(build_string("iso8859-1")), 0, 0); staticpro (&Vcharset_latin_iso8859_2); Vcharset_latin_iso8859_2 = make_charset (LEADING_BYTE_LATIN_ISO8859_2, Qlatin_iso8859_2, 2, ＠＠ -1083,7 +1113,7 ＠＠ build_string ("Latin-2"), build_msg_string ("ISO8859-2 (Latin-2)"), build_msg_string ("ISO8859-2 (Latin-2)"), - build_string ("iso8859-2"), 0, 0); + vector1(build_string("iso8859-2")), 0, 0); staticpro (&Vcharset_latin_iso8859_3); Vcharset_latin_iso8859_3 = make_charset (LEADING_BYTE_LATIN_ISO8859_3, Qlatin_iso8859_3, 2, ＠＠ -1092,7 +1122,7 ＠＠ build_string ("Latin-3"), build_msg_string ("ISO8859-3 (Latin-3)"), build_msg_string ("ISO8859-3 (Latin-3)"), - build_string ("iso8859-3"), 0, 0); + vector1(build_string("iso8859-3")), 0, 0); staticpro (&Vcharset_latin_iso8859_4); Vcharset_latin_iso8859_4 = make_charset (LEADING_BYTE_LATIN_ISO8859_4, Qlatin_iso8859_4, 2, ＠＠ -1101,7 +1131,7 ＠＠ build_string ("Latin-4"), build_msg_string ("ISO8859-4 (Latin-4)"), build_msg_string ("ISO8859-4 (Latin-4)"), - build_string ("iso8859-4"), 0, 0); + vector1(build_string("iso8859-2")), 0, 0); staticpro (&Vcharset_thai_tis620); Vcharset_thai_tis620 = make_charset (LEADING_BYTE_THAI_TIS620, Qthai_tis620, 2, ＠＠ -1110,7 +1140,7 ＠＠ build_string ("TIS620"), build_msg_string ("TIS620 (Thai)"), build_msg_string ("TIS620.2529 (Thai)"), - build_string ("tis620"), 0, 0); + vector1(build_string("tis620.2529-1")), 0, 0); staticpro (&Vcharset_greek_iso8859_7); Vcharset_greek_iso8859_7 = make_charset (LEADING_BYTE_GREEK_ISO8859_7, Qgreek_iso8859_7, 2, ＠＠ -1119,7 +1149,7 ＠＠ build_string ("ISO8859-7"), build_msg_string ("ISO8859-7 (Greek)"), build_msg_string ("ISO8859-7 (Greek)"), - build_string ("iso8859-7"), 0, 0); + vector1(build_string("iso8859-7")), 0, 0); staticpro (&Vcharset_arabic_iso8859_6); Vcharset_arabic_iso8859_6 = make_charset (LEADING_BYTE_ARABIC_ISO8859_6, Qarabic_iso8859_6, 2, ＠＠ -1128,7 +1158,7 ＠＠ build_string ("ISO8859-6"), build_msg_string ("ISO8859-6 (Arabic)"), build_msg_string ("ISO8859-6 (Arabic)"), - build_string ("iso8859-6"), 0, 0); + vector1(build_string ("iso8859-6")), 0, 0); staticpro (&Vcharset_hebrew_iso8859_8); Vcharset_hebrew_iso8859_8 = make_charset (LEADING_BYTE_HEBREW_ISO8859_8, Qhebrew_iso8859_8, 2, ＠＠ -1137,7 +1167,7 ＠＠ build_string ("ISO8859-8"), build_msg_string ("ISO8859-8 (Hebrew)"), build_msg_string ("ISO8859-8 (Hebrew)"), - build_string ("iso8859-8"), 0, 0); + vector1(build_string ("iso8859-8")), 0, 0); staticpro (&Vcharset_katakana_jisx0201); Vcharset_katakana_jisx0201 = make_charset (LEADING_BYTE_KATAKANA_JISX0201, Qkatakana_jisx0201, 2, ＠＠ -1146,7 +1176,7 ＠＠ build_string ("JISX0201 Kana"), build_msg_string ("JISX0201.1976 (Japanese Kana)"), build_msg_string ("JISX0201.1976 Japanese Kana"), - build_string ("jisx0201.1976"), 0, 0); + vector1(build_string ("jisx0201.1976-0")), 0, 0); staticpro (&Vcharset_latin_jisx0201); Vcharset_latin_jisx0201 = make_charset (LEADING_BYTE_LATIN_JISX0201, Qlatin_jisx0201, 2, ＠＠ -1155,7 +1185,7 ＠＠ build_string ("JISX0201 Roman"), build_msg_string ("JISX0201.1976 (Japanese Roman)"), build_msg_string ("JISX0201.1976 Japanese Roman"), - build_string ("jisx0201.1976"), 0, 0); + vector1(build_string ("jisx0201.1976-0")), 0, 0); staticpro (&Vcharset_cyrillic_iso8859_5); Vcharset_cyrillic_iso8859_5 = make_charset (LEADING_BYTE_CYRILLIC_ISO8859_5, Qcyrillic_iso8859_5, 2, ＠＠ -1164,7 +1194,7 ＠＠ build_string ("ISO8859-5"), build_msg_string ("ISO8859-5 (Cyrillic)"), build_msg_string ("ISO8859-5 (Cyrillic)"), - build_string ("iso8859-5"), 0, 0); + vector1(build_string ("iso8859-5")), 0, 0); staticpro (&Vcharset_latin_iso8859_9); Vcharset_latin_iso8859_9 = make_charset (LEADING_BYTE_LATIN_ISO8859_9, Qlatin_iso8859_9, 2, ＠＠ -1173,7 +1203,7 ＠＠ build_string ("Latin-5"), build_msg_string ("ISO8859-9 (Latin-5)"), build_msg_string ("ISO8859-9 (Latin-5)"), - build_string ("iso8859-9"), 0, 0); + vector1(build_string ("iso8859-9")), 0, 0); staticpro (&Vcharset_latin_iso8859_15); Vcharset_latin_iso8859_15 = make_charset (LEADING_BYTE_LATIN_ISO8859_15, Qlatin_iso8859_15, 2, ＠＠ -1182,7 +1212,7 ＠＠ build_string ("Latin-9"), build_msg_string ("ISO8859-15 (Latin-9)"), build_msg_string ("ISO8859-15 (Latin-9)"), - build_string ("iso8859-15"), 0, 0); + vector1(build_string ("iso8859-15")), 0, 0); staticpro (&Vcharset_japanese_jisx0208_1978); Vcharset_japanese_jisx0208_1978 = make_charset (LEADING_BYTE_JAPANESE_JISX0208_1978, Qjapanese_jisx0208_1978, 3, ＠＠ -1192,7 +1222,8 ＠＠ build_msg_string ("JISX0208.1978 (Japanese)"), build_msg_string ("JISX0208.1978 Japanese Kanji (so called \"old JIS\")"), - build_string ("\\(jisx0208\\|jisc6226\\)\\.1978"), 0, 0); + vector2(build_string("jisx0208.1978-0"), + build_string("jisc6226.1978-0")), 0, 0); staticpro (&Vcharset_chinese_gb2312); Vcharset_chinese_gb2312 = make_charset (LEADING_BYTE_CHINESE_GB2312, Qchinese_gb2312, 3, ＠＠ -1201,7 +1232,8 ＠＠ build_string ("GB2312"), build_msg_string ("GB2312)"), build_msg_string ("GB2312 Chinese simplified"), - build_string ("gb2312"), 0, 0); + vector2(build_string("gb2312.1980-0"), + build_string("gb2312.80&gb8565.88-0")), 0, 0); staticpro (&Vcharset_japanese_jisx0208); Vcharset_japanese_jisx0208 = make_charset (LEADING_BYTE_JAPANESE_JISX0208, Qjapanese_jisx0208, 3, ＠＠ -1210,7 +1242,8 ＠＠ build_string ("JISX0208"), build_msg_string ("JISX0208.1983/1990 (Japanese)"), build_msg_string ("JISX0208.1983/1990 Japanese Kanji"), - build_string ("jisx0208.19\\(83\\|90\\)"), 0, 0); + vector2(build_string("jisx0208.1983-0"), + build_string("jisx0208.1990-0")), 0, 0); staticpro (&Vcharset_korean_ksc5601); Vcharset_korean_ksc5601 = make_charset (LEADING_BYTE_KOREAN_KSC5601, Qkorean_ksc5601, 3, ＠＠ -1219,7 +1252,7 ＠＠ build_string ("KSC5601"), build_msg_string ("KSC5601 (Korean"), build_msg_string ("KSC5601 Korean Hangul and Hanja"), - build_string ("ksc5601"), 0, 0); + vector1(build_string("ksc5601.1987-0")), 0, 0); staticpro (&Vcharset_japanese_jisx0212); Vcharset_japanese_jisx0212 = make_charset (LEADING_BYTE_JAPANESE_JISX0212, Qjapanese_jisx0212, 3, ＠＠ -1228,9 +1261,9 ＠＠ build_string ("JISX0212"), build_msg_string ("JISX0212 (Japanese)"), build_msg_string ("JISX0212 Japanese Supplement"), - build_string ("jisx0212"), 0, 0); + vector1(build_string("jisx0212.1990-0")), 0, 0); -#define CHINESE_CNS_PLANE_RE(n) "cns11643[.-]\\(.*[.-]\\)?" n "$" +#define CHINESE_CNS_PLANE(n) "cns11643.1992-" n staticpro (&Vcharset_chinese_cns11643_1); Vcharset_chinese_cns11643_1 = make_charset (LEADING_BYTE_CHINESE_CNS11643_1, Qchinese_cns11643_1, 3, ＠＠ -1240,7 +1273,7 ＠＠ build_msg_string ("CNS11643-1 (Chinese traditional)"), build_msg_string ("CNS 11643 Plane 1 Chinese traditional"), - build_string (CHINESE_CNS_PLANE_RE("1")), 0, 0); + vector1(build_string (CHINESE_CNS_PLANE("1"))), 0, 0); staticpro (&Vcharset_chinese_cns11643_2); Vcharset_chinese_cns11643_2 = make_charset (LEADING_BYTE_CHINESE_CNS11643_2, Qchinese_cns11643_2, 3, ＠＠ -1250,7 +1283,7 ＠＠ build_msg_string ("CNS11643-2 (Chinese traditional)"), build_msg_string ("CNS 11643 Plane 2 Chinese traditional"), - build_string (CHINESE_CNS_PLANE_RE("2")), 0, 0); + vector1(build_string (CHINESE_CNS_PLANE("2"))), 0, 0); staticpro (&Vcharset_chinese_big5_1); Vcharset_chinese_big5_1 = make_charset (LEADING_BYTE_CHINESE_BIG5_1, Qchinese_big5_1, 3, ＠＠ -1260,7 +1293,7 ＠＠ build_msg_string ("Big5 (Level-1)"), build_msg_string ("Big5 Level-1 Chinese traditional"), - build_string ("big5"), 0, 0); + vector1(build_string ("big5.eten-0")), 0, 0); staticpro (&Vcharset_chinese_big5_2); Vcharset_chinese_big5_2 = make_charset (LEADING_BYTE_CHINESE_BIG5_2, Qchinese_big5_2, 3, ＠＠ -1270,7 +1303,7 ＠＠ build_msg_string ("Big5 (Level-2)"), build_msg_string ("Big5 Level-2 Chinese traditional"), - build_string ("big5"), 0, 0); + vector1(build_string ("big5.eten-0")), 0, 0); #ifdef ENABLE_COMPOSITE_CHARS ＠＠ -1285,7 +1318,7 ＠＠ build_string ("Composite"), build_msg_string ("Composite characters"), build_msg_string ("Composite characters"), - build_string (""), 0, 0); + vector1(build_string ("")), 0, 0); #else /* We create a hack so that we have a way of storing ESC 0 and ESC 1 sequences as "characters", so that they will be output correctly. */ ＠＠ -1297,6 +1330,6 ＠＠ build_string ("Composite hack"), build_msg_string ("Composite characters hack"), build_msg_string ("Composite characters hack"), - build_string (""), 0, 0); + vector1(build_string ("")), 0, 0); #endif /* ENABLE_COMPOSITE_CHARS */ } Index: src/objects-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-x.c,v retrieving revision 1.43 diff -u -u -r1.43 objects-x.c --- src/objects-x.c 2006/06/23 15:45:03 1.43 +++ src/objects-x.c 2006/08/06 16:42:09 ＠＠ -44,6 +44,15 ＠＠ int x_handle_non_fully_specified_fonts; +#ifdef DEBUG_XEMACS +Fixnum debug_x_objects; + +#define DEBUG_OBJECTS(FORMAT, ...) \ + do { if (debug_x_objects) stderr_out(FORMAT, __VA_ARGS__); } while (0) +#else +#define DEBUG_OBJECTS(X) +#endif +  /************************************************************************/ /* color instances */ ＠＠ -205,74 +214,6 ＠＠ /* font instances */ /************************************************************************/ -#ifdef USE_XFT -/* #### all these #defines should probably move to font-mgr.h */ - -/* - The format of a fontname (as returned by fontconfig) is not well-documented, - But the character repertoire is represented in an ASCII-compatible way. See - fccharset.c (FcCharSetUnparse). So we can use UTF-8 for long names. - - Currently we have a hack where different versions of the unparsed name are - used in different contexts fairly arbitrarily. I don't think this is close - to coherency; even without the charset and lang properties fontconfig names - are too unwieldy to use. We need to rethink the approach here. I think - probably Lisp_Font_Instance.name should contain the font name as specified - to Lisp (almost surely much shorter than shortname, even, and most likely - wildcarded), while Lisp_Font_Instance.truename should contain the longname. - For now, I'm going to #ifdef the return values defaulting to short. -- sjt -*/ - -/* DEBUGGING STUFF */ - -/* print message to stderr: one internal-format string argument */ -#define DEBUG_XFT0(level,s) \ - if (debug_xft > level) stderr_out (s) - -/* print message to stderr: one formatted argument */ -#define DEBUG_XFT1(level,format,x1) \ - if (debug_xft > level) stderr_out (format, x1) - -/* print message to stderr: two formatted arguments */ -#define DEBUG_XFT2(level,format,x1,x2) \ - if (debug_xft > level) stderr_out (format, x1, x2) - -/* print message to stderr: three formatted arguments */ -#define DEBUG_XFT3(level,format,x1,x2,x3) \ - if (debug_xft > level) stderr_out (format, x1, x2, x3) - -/* print message to stderr: four formatted arguments */ -#define DEBUG_XFT4(level,format,x1,x2,x3,x4) \ - if (debug_xft > level) stderr_out (format, x1, x2, x3, x4) - -/* 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 - and must be internal format (eg, pure ASCII) - PATTERN is an FcPattern *. */ -#define PRINT_XFT_PATTERN(level,format,pattern) \ - do { \ - DECLARE_EISTRING (eistrpxft_name); \ - Extbyte *name = (Extbyte *) FcNameUnparse (pattern); \ - \ - eicpy_ext(eistrpxft_name, name, Qfc_font_name_encoding); \ - DEBUG_XFT1 (level, format, eidata(eistrpxft_name)); \ - free (name); \ - } while (0) - -/* print a progress message - LEVEL is the debug level (to compare to debug_xft) - FONT is the Xft font name in UTF-8 (the native encoding of Xft) - LANG is the language being checked for support (must be ASCII). */ -#define CHECKING_LANG(level,font,lang) \ - do { \ - DECLARE_EISTRING (eistrcl_name); \ - eicpy_ext(eistrcl_name, (Extbyte *) font, Qfc_font_name_encoding); \ - DEBUG_XFT2 (level, "checking if %s handles %s\n", \ - eidata(eistrcl_name), lang); \ - } while (0) - -#endif /* USE_XFT */ static int x_initialize_font_instance (Lisp_Font_Instance *f, Lisp_Object UNUSED (name), ＠＠ -814,7 +755,7 ＠＠ if (res) { FONT_INSTANCE_TRUENAME (f) = - build_ext_string ((Extbyte *) res, Qfc_font_name_encoding); + build_ext_string ((Extbyte *)res, Qfc_font_name_encoding); free (res); return FONT_INSTANCE_TRUENAME (f); } ＠＠ -946,6 +887,30 ＠＠ #ifdef MULE +static int +count_hyphens(const Ibyte *str, Bytecount length, Ibyte **last_hyphen) +{ + int hyphen_count = 0; + const Ibyte *hyphening = str; + const Ibyte *new_hyphening; + + for (hyphen_count = 0; + NULL != (new_hyphening = memchr((const void *)hyphening, '-', length)); + hyphen_count++) + { + ++new_hyphening; + length -= new_hyphening - hyphening; + hyphening = new_hyphening; + } + + if (NULL != last_hyphen) + { + *last_hyphen = (Ibyte *)hyphening; + } + + return hyphen_count; +} + static int x_font_spec_matches_charset (struct device * USED_IF_XFT (d), Lisp_Object charset, ＠＠ -953,6 +918,19 ＠＠ Bytecount offset, Bytecount length, int stage) { + Lisp_Object registries; + long i, registries_len; + const Ibyte *the_nonreloc; + Bytecount the_length; + + the_nonreloc = nonreloc; + the_length = length; + + if (!the_nonreloc) + the_nonreloc = XSTRING_DATA (reloc); + fixup_internal_substring (nonreloc, reloc, offset, &the_length); + the_nonreloc += offset; + if (stage) #ifdef USE_XFT { ＠＠ -967,6 +945,7 ＠＠ LISP_STRING_TO_EXTERNAL (reloc, extname, Qx_font_name_encoding); rf = xft_open_font_by_name (dpy, extname); return 0; /* #### maybe this will compile and run ;) */ + /* Jesus, Stephen, what the fuck? */ } } #else ＠＠ -975,6 +954,7 ＠＠ if (UNBOUNDP (charset)) return 1; + /* Hack! Short font names don't have the registry in them, so we just assume the user knows what they're doing in the case of ASCII. For other charsets, you gotta give the ＠＠ -986,41 +966,45 ＠＠ between faces and fonts? No - it looks like that would be an abuse (fontconfig doesn't know about colors, although Xft does). */ - if (EQ (charset, Vcharset_ascii)) + if (EQ (charset, Vcharset_ascii) && (!memchr (the_nonreloc, '*', the_length)) + && (5 > (count_hyphens(the_nonreloc, the_length, NULL)))) { - const Ibyte *the_nonreloc = nonreloc; - int i; - Bytecount the_length = length; - - if (!the_nonreloc) - the_nonreloc = XSTRING_DATA (reloc); - fixup_internal_substring (nonreloc, reloc, offset, &the_length); - the_nonreloc += offset; - if (!memchr (the_nonreloc, '*', the_length)) - { - for (i = 0;; i++) - { - const Ibyte *new_nonreloc = (const Ibyte *) - memchr (the_nonreloc, '-', the_length); - if (!new_nonreloc) - break; - new_nonreloc++; - the_length -= new_nonreloc - the_nonreloc; - the_nonreloc = new_nonreloc; - } - - /* If it has less than 5 dashes, it's a short font. - Of course, long fonts always have 14 dashes or so, but short - fonts never have more than 1 or 2 dashes, so this is some - sort of reasonable heuristic. */ - if (i < 5) - return 1; - } + return 1; } - return (fast_string_match (XCHARSET_REGISTRY (charset), - nonreloc, reloc, offset, length, 1, - ERROR_ME, 0) >= 0); + registries = XCHARSET_REGISTRIES (charset); + + if (NILP(registries)) + { + return 0; + } + + CHECK_VECTOR (registries); + registries_len = XVECTOR_LENGTH(registries); + + for (i = 0; i < registries_len; ++i) + { + if (!(STRINGP(XVECTOR_DATA(registries)[i])) + || (XSTRING_LENGTH(XVECTOR_DATA(registries)[i]) > the_length)) + { + continue; + } + + /* Check if the font spec ends in the registry specified. X11 says + this comparison is case insensitive: XLFD, section 3.11: + + "Alphabetic case distinctions are allowed but are for human + readability concerns only. Conforming X servers will perform + matching on font name query or open requests independent of case." */ + if (0 == qxestrcasecmp(XSTRING_DATA(XVECTOR_DATA(registries)[i]), + the_nonreloc + (the_length - + XSTRING_LENGTH + (XVECTOR_DATA(registries)[i])))) + { + return 1; + } + } + return 0; } #ifdef USE_XFT ＠＠ -1170,26 +1154,17 ＠＠ : eistr_shortname; \ } while (0) -#endif /* USE_XFT */ - -/* find a font spec that matches font spec FONT and also matches - (the registry of) CHARSET. */ static Lisp_Object -x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, - int stage) +xft_find_charset_font (Lisp_Object font, Lisp_Object charset, int stage) { - Extbyte **names; - int count = 0; const Extbyte *patternext; Lisp_Object result = Qnil; - int i; /* #### with Xft need to handle second stage here -- sjt Hm. Or maybe not. That would be cool. :-) */ if (stage) return Qnil; -#ifdef USE_XFT /* Fontconfig converts all FreeType names to UTF-8 before passing them back to callers---see fcfreetype.c (FcFreeTypeQuery). I don't believe this is documented. */ ＠＠ -1339,7 +1314,6 ＠＠ } ASSERT_ASCTEXT_ASCII((Extbyte *) lang); - } if (fccs) { ＠＠ -1356,7 +1330,7 ＠＠ else if (r == FcResultMatch && FcCharSetIsSubset (fccs, v)) { /* The full pattern with the bitmap coverage is massively - unwieldy, but the shorter names are's just *wrong*. We + unwieldy, but the shorter names are just *wrong*. We should have the full thing internally as truename, and filter stuff the client doesn't want to see on output. Should we just store it into the truename right here? */ ＠＠ -1432,42 +1406,156 ＠＠ return result; } - DEBUG_XFT1 (0, "shit happens, try X11 charset match for %s\n", - XSTRING_DATA(font)); + return Qnil; #undef DECLARE_DEBUG_FONTNAME +} + #endif /* USE_XFT */ + +static Lisp_Object +xlistfonts_checking_charset (Lisp_Object device, const Extbyte *xlfd, + Lisp_Object charset) +{ + Extbyte **names; + Lisp_Object result = Qnil; + int count = 0, i; + DECLARE_EISTRING(ei_single_result); - LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding); names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)), - patternext, MAX_FONT_COUNT, &count); - /* #### This code seems awfully bogus -- mrb */ - /* #### fontconfig does it better -- sjt */ - for (i = 0; i < count; i ++) - { - const Ibyte *intname; - Bytecount intlen; - - TO_INTERNAL_FORMAT (C_STRING, names[i], - ALLOCA, (intname, intlen), - Qx_font_name_encoding); + xlfd, MAX_FONT_COUNT, &count); + for (i = 0; i < count; ++i) + { + eireset(ei_single_result); + eicpy_ext(ei_single_result, names[i], Qx_font_name_encoding); + if (x_font_spec_matches_charset (XDEVICE (device), charset, - intname, Qnil, 0, -1, 0)) + eidata(ei_single_result), Qnil, 0, + -1, 0)) { - result = build_ext_string ((const Extbyte *) intname, - Qx_font_name_encoding); + result = eimake_string(ei_single_result); + DEBUG_OBJECTS ("in xlistfonts_checking_charset, returning %s\n", + eidata(ei_single_result)); break; } } if (names) - XFreeFontNames (names); + { + XFreeFontNames (names); + } + + return result; +} + +/* find a font spec that matches font spec FONT and also matches + (the registry of) CHARSET. */ +static Lisp_Object +x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, + int stage) +{ + Lisp_Object result = Qnil; + int j, hyphen_count, registries_len = 0; + Ibyte *hyphening, *new_hyphening; + Bytecount xlfd_length; + + DECLARE_EISTRING(ei_xlfd_without_registry); + DECLARE_EISTRING(ei_xlfd); + +#ifdef USE_XFT + return xft_find_charset_font(font, charset, stage); +#endif + + if (stage) + { + return Qnil; + } + + if (!(NILP(XCHARSET_REGISTRIES(charset))) + && VECTORP(XCHARSET_REGISTRIES(charset))) + { + registries_len = XVECTOR_LENGTH(XCHARSET_REGISTRIES(charset)); + } + + eicpy_lstr(ei_xlfd, font); + hyphening = eidata(ei_xlfd); + xlfd_length = eilen(ei_xlfd); + + /* Count the hyphens in the string, moving new_hyphen to just after the + last one. */ + hyphen_count = count_hyphens(hyphening, xlfd_length, &new_hyphening); + + if (0 == registries_len || (5 > hyphen_count && + !(1 == xlfd_length && '*' == *hyphening))) + { + /* No proper XLFD specified, or we can't modify the pattern to change + the registry and encoding to match what we want, or we have no + information on the registry needed. */ + eito_external(ei_xlfd, Qx_font_name_encoding); + DEBUG_OBJECTS ("about to xlistfonts_checking_charset, XLFD %s\n", + eidata(ei_xlfd)); + result = xlistfonts_checking_charset (device, eiextdata(ei_xlfd), + charset); + /* No need to loop through the available registries; return + immediately. */ + return result; + } + else if (1 == xlfd_length && '*' == *hyphening) + { + /* It's a single asterisk. We can add the registry directly to the + end. */ + eicpy_ch(ei_xlfd_without_registry, '*'); + } + else + { + /* It's a fully-specified XLFD. Work out where the registry and + encoding are, and initialise ei_xlfd_without_registry to the string + without them. */ + + /* count_hyphens has set new_hyphening to just after the last + hyphen. Move back to just after the hyphen before it. */ + + for (new_hyphening -= 2; new_hyphening > hyphening + && '-' != *new_hyphening; --new_hyphening) + ; + ++new_hyphening; - /* Check for a short font name. */ - if (NILP (result) - && x_font_spec_matches_charset (XDEVICE (device), charset, 0, - font, 0, -1, 0)) - return font; + eicpy_ei(ei_xlfd_without_registry, ei_xlfd); + /* Manipulate ei_xlfd_without_registry, using the information about + ei_xlfd, to which it's identical. */ + eidel(ei_xlfd_without_registry, new_hyphening - hyphening, -1, + eilen(ei_xlfd) - (new_hyphening - hyphening), -1); + + } + + /* Now, loop through the registries and encodings defined for this + charset, doing an XListFonts each time with the pattern modified to + specify the regisry and encoding. This avoids huge amounts of IPC and + duplicated searching; now we use the searching the X server was doing + anyway, where before the X server did its search, transferred huge + amounts of data, and then we proceeded to do a regexp search on that + data. */ + for (j = 0; j < registries_len && NILP(result); ++j) + { + eireset(ei_xlfd); + eicpy_ei(ei_xlfd, ei_xlfd_without_registry); + + eicat_lstr(ei_xlfd, XVECTOR_DATA(XCHARSET_REGISTRIES(charset))[j]); + + eito_external(ei_xlfd, Qx_font_name_encoding); + + DEBUG_OBJECTS ("about to xlistfonts_checking_charset, XLFD %s\n", + eidata(ei_xlfd)); + result = xlistfonts_checking_charset (device, eiextdata(ei_xlfd), + charset); + } + + /* This function used to return the font spec, in the case where a font + didn't exist on the X server but it did match the charset. We're not + doing that any more, because none of the other platform code does, and + the old behaviour was badly-judged in other respects, so I don't trust + the original author to have had a good reason for it. */ + return result; } ＠＠ -1512,6 +1600,13 ＠＠ void vars_of_objects_x (void) { +#ifdef DEBUG_XEMACS + DEFVAR_INT ("debug-x-objects", &debug_x_objects /* +If non-zero, display debug information about X objects +*/ ); + debug_x_objects = 0; +#endif + DEFVAR_BOOL ("x-handle-non-fully-specified-fonts", &x_handle_non_fully_specified_fonts /* If this is true then fonts which do not have all characters specified Index: src/specifier.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.c,v retrieving revision 1.44 diff -u -u -r1.44 specifier.c --- src/specifier.c 2006/02/27 16:29:28 1.44 +++ src/specifier.c 2006/08/06 16:42:10 ＠＠ -47,6 +47,7 ＠＠ Lisp_Object Qconsole_type, Qdevice_class; static Lisp_Object Vuser_defined_tags; +static Lisp_Object Vcharset_tag_lists; typedef struct specifier_type_entry specifier_type_entry; struct specifier_type_entry ＠＠ -973,6 +974,38 ＠＠ return 1; } +static int +charset_matches_specifier_tag_set_p (Lisp_Object charset, + Lisp_Object tag_set) +{ + Lisp_Object rest; + + LIST_LOOP (rest, tag_set) + { + Lisp_Object tag = XCAR (rest); + Lisp_Object assoc; + + if (NILP(XVECTOR_DATA + (Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) + - MIN_LEADING_BYTE])) + { + continue; + } + + assoc = assq_no_quit(tag, XVECTOR_DATA + (Vcharset_tag_lists) + [XCHARSET_LEADING_BYTE(charset) + - MIN_LEADING_BYTE]); + if (!(NILP(assoc)) && !(NILP(XCDR(assoc)))) + { + return 1; + } + } + + return 0; +} + + DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /* Return non-nil if DEVICE matches specifier tag set TAG-SET. ＠＠ -990,20 +1023,28 ＠＠ return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil; } -DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /* +DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* Define a new specifier tag. -If PREDICATE is specified, it should be a function of one argument -\(a device) that specifies whether the tag matches that particular -device. If PREDICATE is omitted, the tag matches all devices. + +If DEVICE-PREDICATE is specified, it should be a function of one argument +\(a device) that specifies whether the tag matches that particular device. +If DEVICE-PREDICATE is omitted, the tag matches all devices. + +If CHARSET-PREDICATE is supplied, it should be a function taking one +argument \(a Lisp character set\) that retuns whether the tag matches that +character set--used when instantiating faces, chiefly. If omitted, the tag +matches no character set; the two-stage match process will ignore the tag on +its first pass, but if no match is found, it will respect it on the second +pass, where character set information is ignored. You can redefine an existing user-defined specifier tag. However, you cannot redefine the built-in specifier tags (the device types and classes) or the symbols nil, t, `all', or `global'. */ - (tag, predicate)) + (tag, device_predicate, charset_predicate)) { - Lisp_Object assoc, devcons, concons; - int recompute = 0; + Lisp_Object assoc, devcons, concons, charpres; + int recompute_devices = 0, recompute_charsets = 0, i; CHECK_SYMBOL (tag); if (valid_device_class_p (tag) || ＠＠ -1016,30 +1057,42 ＠＠ assoc = assq_no_quit (tag, Vuser_defined_tags); if (NILP (assoc)) { - recompute = 1; - Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags); + recompute_devices = recompute_charsets = 1; + Vuser_defined_tags = Fcons (list3 (tag, device_predicate, + charset_predicate), + Vuser_defined_tags); DEVICE_LOOP_NO_BREAK (devcons, concons) { struct device *d = XDEVICE (XCAR (devcons)); /* Initially set the value to t in case of error - in predicate */ + in device_predicate */ DEVICE_USER_DEFINED_TAGS (d) = Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d)); } + } + else if (!NILP (device_predicate) && !NILP (XCADR (assoc))) + { + recompute_devices = 1; + XCDR (assoc) = list2(device_predicate, charset_predicate); } - else if (!NILP (predicate) && !NILP (XCDR (assoc))) + else if (!NILP (charset_predicate) || !NILP(XCADDR (assoc))) { - recompute = 1; - XCDR (assoc) = predicate; + /* If there exists a charset_predicate for the tag currently (even if + the new charset_predicate is nil), or if we're adding one, we need + to recompute. This contrast with the device predicates, where we + don't need to recompute if the old and new device predicates are + both nil. */ + recompute_charsets = 1; + XCDR (assoc) = list2(device_predicate, charset_predicate); } - /* recompute the tag values for all devices. However, in the special - case where both the old and new predicates are nil, we know that - we don't have to do this. (It's probably common for people to - call (define-specifier-tag) more than once on the same tag, - and the most common case is where PREDICATE is not specified.) */ + /* recompute the tag values for all devices and charsets. However, in the + special case where both the old and new device_predicates are nil, we + know that we don't have to do this. (It's probably common for people to + call (define-specifier-tag) more than once on the same tag, and the + most common case is where DEVICE_PREDICATE is not specified.) */ - if (recompute) + if (recompute_devices) { DEVICE_LOOP_NO_BREAK (devcons, concons) { ＠＠ -1047,10 +1100,60 ＠＠ assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (XDEVICE (device))); assert (CONSP (assoc)); - if (NILP (predicate)) + if (NILP (device_predicate)) XCDR (assoc) = Qt; + else + XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt + : Qnil; + } + } + + if (recompute_charsets) + { + if (NILP(charset_predicate)) + { + charpres = Qnil; + } + + for (i = 0; i < NUM_LEADING_BYTES; ++i) + { + if (NILP(charset_by_leading_byte(MIN_LEADING_BYTE + i))) + { + continue; + } + + assoc = assq_no_quit (tag, + XVECTOR_DATA(Vcharset_tag_lists)[i]); + + if (!NILP(charset_predicate)) + { + charpres = call1_trapping_problems + ("Error during specifier tag charset predicate", + charset_predicate, + charset_by_leading_byte(MIN_LEADING_BYTE + i), 0); + + if (UNBOUNDP(charpres)) + { + charpres = Qnil; + } + else if (!NILP(charpres)) + { + /* Don't want to keep random other objects hanging around. */ + charpres = Qt; + } + } + + if (!NILP(assoc)) + { + assert(CONSP(assoc)); + XCDR (assoc) = charpres; + } else - XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil; + { + XVECTOR_DATA(Vcharset_tag_lists)[i] + = Fcons(Fcons(tag, charpres), + XVECTOR_DATA (Vcharset_tag_lists)[i]); + } } } ＠＠ -1065,6 +1168,8 ＠＠ { Lisp_Object rest, rest2; Lisp_Object device = wrap_device (d); + Lisp_Object device_predicate, charset_predicate; + int list_len; DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags); ＠＠ -1075,13 +1180,64 ＠＠ for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d); !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2)) { - Lisp_Object predicate = XCDR (XCAR (rest)); - if (NILP (predicate)) - XCDR (XCAR (rest2)) = Qt; + GET_LIST_LENGTH(XCAR(rest), list_len); + + assert(3 == list_len); + + device_predicate = XCADR(XCAR (rest)); + charset_predicate = XCADDR(XCAR (rest)); + + if (NILP (device_predicate)) + { + XCDR (XCAR (rest2)) = list2(Qt, charset_predicate); + } else - XCDR (XCAR (rest2)) = - !NILP (call_critical_lisp_code (d, predicate, device)) ? Qt : Qnil; + { + device_predicate = !NILP (call_critical_lisp_code + (d, device_predicate, device)) + ? Qt : Qnil; + XCDR (XCAR (rest2)) = list2(device_predicate, charset_predicate); + } + } +} + +void +setup_charset_initial_specifier_tags (Lisp_Object charset) +{ + Lisp_Object rest, charset_predicate, tag; + Lisp_Object charset_tag_list = Qnil; + + LIST_LOOP (rest, Vuser_defined_tags) + { + tag = XCAR(XCAR(rest)); + charset_predicate = XCADDR(XCAR (rest)); + + if (NILP(charset_predicate)) + { + continue; + } + + charset_predicate = call1_trapping_problems + ("Error during specifier tag charset predicate", charset_predicate, + charset, 0); + + if (UNBOUNDP(charset_predicate)) + { + charset_predicate = Qnil; + } + else if (!NILP(charset_predicate)) + { + /* Don't want to keep random other objects hanging around. */ + charset_predicate = Qt; + } + + charset_tag_list = Fcons(Fcons(tag, charset_predicate), + charset_tag_list); } + + XVECTOR_DATA + (Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) - MIN_LEADING_BYTE] + = charset_tag_list; } DEFUN ("device-matching-specifier-tag-list", ＠＠ -1100,7 +1256,7 ＠＠ LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) { - if (!NILP (XCDR (XCAR (rest)))) + if (!NILP (XCADR (XCAR (rest)))) list = Fcons (XCAR (XCAR (rest)), list); } ＠＠ -1132,8 +1288,9 ＠＠ RETURN_UNGCPRO (list); } -DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /* -Return the predicate for the given specifier tag. +DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate, + 1, 1, 0, /* +Return the device predicate for the given specifier tag. */ (tag)) { ＠＠ -1156,9 +1313,25 ＠＠ list3 (Qeq, list2 (Qquote, tag), list2 (Qdevice_class, Qdevice))); - return XCDR (assq_no_quit (tag, Vuser_defined_tags)); + return XCADR (assq_no_quit (tag, Vuser_defined_tags)); } +DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate, + 1, 1, 0, /* +Return the charset predicate for the given specifier tag. +*/ + (tag)) +{ + /* The return value of this function must be GCPRO'd. */ + CHECK_SYMBOL (tag); + + if (NILP (Fvalid_specifier_tag_p (tag))) + invalid_argument ("Invalid specifier tag", + tag); + + return XCADDR (assq_no_quit (tag, Vuser_defined_tags)); +} + /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B. Otherwise, A must be `equal' to B. The sets must be canonicalized. */ static int ＠＠ -2496,9 +2669,8 ＠＠ { /* This function can GC */ Lisp_Specifier *sp; - Lisp_Object device; - Lisp_Object rest; - int count = specpdl_depth (); + Lisp_Object device, charset = Qnil, rest; + int count = specpdl_depth (), respected_charsets = 0; struct gcpro gcpro1, gcpro2; GCPRO2 (specifier, inst_list); ＠＠ -2513,31 +2685,94 ＠＠ Fsignal will abort. */ specbind (Qinhibit_quit, Qt); + if (CONSP(matchspec) && (CHARSETP(XCAR(matchspec)))) + { + charset = Ffind_charset(XCAR(matchspec)); + } + + LIST_LOOP(rest, inst_list) + { + Lisp_Object tagged_inst = XCAR (rest); + Lisp_Object tag_set = XCAR (tagged_inst); + Lisp_Object val, the_instantiator; + + if (!device_matches_specifier_tag_set_p (device, tag_set)) + { + continue; + } + + val = XCDR (tagged_inst); + the_instantiator = val; + + if (!NILP(charset) && + !(charset_matches_specifier_tag_set_p (charset, tag_set))) + { + ++respected_charsets; + continue; + } + + if (HAS_SPECMETH_P (sp, instantiate)) + val = call_with_suspended_errors + ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), + Qunbound, Qspecifier, errb, 5, specifier, + matchspec, domain, val, depth); + + if (!UNBOUNDP (val)) + { + unbind_to (count); + UNGCPRO; + if (instantiator) + *instantiator = the_instantiator; + return val; + } + } + + /* We've checked all the tag sets, and checking the charset part of the + specifier never returned 0 (preventing the attempted instantiation), so + there's no need to loop for the second time to avoid checking the + charsets. */ + if (!respected_charsets) + { + unbind_to (count); + UNGCPRO; + return Qunbound; + } + + /* Right, didn't instantiate a specifier last time, perhaps because we + paid attention to the charset-specific aspects of the specifier. Try + again without checking the charset information. + + We can't emulate the approach for devices, defaulting to matching all + character sets for a given specifier, because $random font instantiator + cannot usefully show all character sets, and indeed having it try is a + failure on our part. */ LIST_LOOP (rest, inst_list) { Lisp_Object tagged_inst = XCAR (rest); Lisp_Object tag_set = XCAR (tagged_inst); + Lisp_Object val, the_instantiator; - if (device_matches_specifier_tag_set_p (device, tag_set)) + if (!device_matches_specifier_tag_set_p (device, tag_set)) { - Lisp_Object val = XCDR (tagged_inst); - Lisp_Object the_instantiator = val; + continue; + } + val = XCDR (tagged_inst); + the_instantiator = val; - if (HAS_SPECMETH_P (sp, instantiate)) - val = call_with_suspended_errors - ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), - Qunbound, Qspecifier, errb, 5, specifier, - matchspec, domain, val, depth); + if (HAS_SPECMETH_P (sp, instantiate)) + val = call_with_suspended_errors + ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), + Qunbound, Qspecifier, errb, 5, specifier, + matchspec, domain, val, depth); - if (!UNBOUNDP (val)) - { - unbind_to (count); - UNGCPRO; - if (instantiator) - *instantiator = the_instantiator; - return val; - } + if (!UNBOUNDP (val)) + { + unbind_to (count); + UNGCPRO; + if (instantiator) + *instantiator = the_instantiator; + return val; } } ＠＠ -3408,7 +3643,8 ＠＠ DEFSUBR (Fdefine_specifier_tag); DEFSUBR (Fdevice_matching_specifier_tag_list); DEFSUBR (Fspecifier_tag_list); - DEFSUBR (Fspecifier_tag_predicate); + DEFSUBR (Fspecifier_tag_device_predicate); + DEFSUBR (Fspecifier_tag_charset_predicate); DEFSUBR (Fcheck_valid_instantiator); DEFSUBR (Fvalid_instantiator_p); ＠＠ -3509,4 +3745,7 ＠＠ Vunlock_ghost_specifiers = Qnil; staticpro (&Vunlock_ghost_specifiers); + + Vcharset_tag_lists = make_vector(NUM_LEADING_BYTES, Qnil); + staticpro (&Vcharset_tag_lists); } Index: src/specifier.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.h,v retrieving revision 1.19 diff -u -u -r1.19 specifier.h --- src/specifier.h 2005/11/25 01:42:06 1.19 +++ src/specifier.h 2006/08/06 16:42:10 ＠＠ -535,6 +535,7 ＠＠ void cleanup_specifiers (void); void prune_specifiers (void); void setup_device_initial_specifier_tags (struct device *d); +void setup_charset_initial_specifier_tags (Lisp_Object charset); void kill_specifier_buffer_locals (Lisp_Object buffer); DECLARE_SPECIFIER_TYPE (generic); Index: src/unicode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/unicode.c,v retrieving revision 1.34 diff -u -u -r1.34 unicode.c --- src/unicode.c 2006/06/14 06:10:10 1.34 +++ src/unicode.c 2006/08/06 16:42:11 ＠＠ -1115,7 +1115,7 ＠＠ Ibyte setname[32]; Lisp_Object charset_descr = build_string ("Mule charset for otherwise unknown Unicode code points."); - Lisp_Object charset_regr = build_string("iso10646-1"); + Lisp_Object charset_regr = vector1(build_string("iso10646-1")); struct gcpro gcpro1, gcpro2; ＠＠ -1148,7 +1148,7 ＠＠ nconc2 (list2(Qencode_as_utf_8, Qt), nconc2 (list6(Qcolumns, make_int(1), Qchars, make_int(96), Qdimension, make_int(2)), - list6(Qregistry, charset_regr, + list6(Qregistries, charset_regr, Qfinal, make_char(last_jit_charset_final++), /* This CCL program is initialised in unicode.el. */ -- Santa Maradona, priez pour moi!