Mercurial > hg > xemacs-beta
changeset 3659:98af8a976fc3
[xemacs-hg @ 2006-11-05 22:31:31 by aidan]
Support specifying fonts for particular character sets in Mule; support
translation to ISO 10646-1 for Mule character sets without an otherwise
matching font; move to a vector of X11-charset-X11-registry instead of a
regex for the charset-registry property.
| author | aidan |
|---|---|
| date | Sun, 05 Nov 2006 22:31:46 +0000 |
| parents | 0db1aaedbbef |
| children | def257d9e948 |
| files | lisp/ChangeLog lisp/faces.el lisp/mule/arabic.el lisp/mule/chinese.el lisp/mule/english.el lisp/mule/ethiopic.el lisp/mule/european.el lisp/mule/indian.el lisp/mule/japanese.el lisp/mule/lao.el lisp/mule/misc-lang.el lisp/mule/mule-charset.el lisp/mule/thai-xtis.el lisp/mule/tibetan.el lisp/mule/vietnamese.el lisp/unicode.el lisp/x-faces.el lisp/x-font-menu.el src/ChangeLog src/charset.h src/console-impl.h src/faces.c src/faces.h src/font-mgr.h src/general-slots.h src/intl.c src/lisp.h src/mule-charset.c src/objects-gtk.c src/objects-msw.c src/objects-tty.c src/objects-x.c src/objects-xlike-inc.c src/objects.c src/objects.h src/redisplay-x.c src/redisplay.c src/specifier.c src/specifier.h src/unicode.c |
| diffstat | 40 files changed, 2485 insertions(+), 1476 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/ChangeLog Sun Nov 05 22:31:46 2006 +0000 @@ -1,3 +1,61 @@ +2006-11-05 Aidan Kehoe <kehoea@parhasard.net> + + * 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. + charset-registries returns the registries of a charset; + * mule/mule-charset.el (set-charset-registry): Moved here from C. + +2006-11-05 Aidan Kehoe <kehoea@parhasard.net> + + * faces.el (face-property-matching-instance): + Simplify. + * faces.el (face-font-instance): + Document CHARSET. + * faces.el (set-face-font): + Give more details on common values for font instantiators, + LOCALEs. + * unicode.el: + Remove a few comments that were only relevant to GNU Emacs. + * unicode.el (decode-char): + * unicode.el (encode-char): + Document CODE, CHAR using uppercase, since they're + parameters. Update commentary on GNU's mule-unicode charsets and + how we've solved the same problem. + * x-faces.el (x-init-face-from-resources): + Retain some of the fallbacks in the generated default face, since + it doesn't make sense to try Andale Mono's ISO-10646-1 encoding + for Amharic or Thai. + * x-font-menu.el (charset-registries): + * x-font-menu.el (x-reset-device-font-menus-core): + Use charset-registries instead of charset-registry. + 2006-11-02 Adrian Aichner <adrian@xemacs.org> * font-lock.el: Sync font-lock-add-keywords and
--- a/lisp/faces.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/faces.el Sun Nov 05 22:31:46 2006 +0000 @@ -250,19 +250,9 @@ (setq face (get-face face)) (let ((value (get face property))) - (if (specifierp value) - (setq value (if (or (charsetp matchspec) - (and (symbolp matchspec) - (find-charset matchspec))) - (or - (specifier-matching-instance - value (cons matchspec nil) domain default - no-fallback) - (specifier-matching-instance - value (cons matchspec t) domain default - no-fallback)) - (specifier-matching-instance value matchspec domain - default no-fallback)))) + (when (specifierp value) + (setq value (specifier-matching-instance value matchspec domain + default no-fallback))) value)) (defun set-face-property (face property value &optional locale tag-set @@ -473,25 +463,40 @@ and an instance object describing how the font appears in that particular window and buffer will be returned. +CHARSET is a Mule charset (meaning return the font used for that charset) or +nil (meaning return the font used for ASCII.) + See `face-property-instance' for more information." - (if charset - (face-property-matching-instance face 'font charset domain) - (face-property-instance face 'font domain))) + (if (null charset) + (face-property-instance face 'font domain) + (let (matchspec) + ;; get-charset signals an error if its argument doesn't have an + ;; associated charset. + (setq charset (get-charset charset) + matchspec (cons charset nil)) + (or (null (setcdr matchspec 'initial)) + (face-property-matching-instance + face 'font matchspec domain) + (null (setcdr matchspec 'final)) + (face-property-matching-instance + face 'font matchspec domain))))) (defun set-face-font (face font &optional locale tag-set how-to-add) "Change the font of FACE to FONT in LOCALE. 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 buffer + objects, window 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"))
--- a/lisp/mule/arabic.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/arabic.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/chinese.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/chinese.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/english.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/english.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/ethiopic.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/ethiopic.el Sun Nov 05 22:31:46 2006 +0000 @@ -32,7 +32,7 @@ (make-charset 'ethiopic "Ethiopic characters" '(dimension 2 - registry "Ethiopic-Unicode" + registries ["Ethiopic-Unicode"] chars 94 columns 2 direction l2r @@ -83,4 +83,7 @@ (sample-text . "$(3$Q#U!.(B") (documentation . t))) +;; In a more ideal world, we could set the default face fallback from here +;; to use one of the misc-fixed sizes that handles Ethiopic. + ;;; ethiopic.el ends here
--- a/lisp/mule/european.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/european.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/indian.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/indian.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/japanese.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/japanese.el Sun Nov 05 22:31:46 2006 +0000 @@ -33,80 +33,10 @@ ;;; Code: -; (make-charset 'katakana-jisx0201 -; "Katakana Part of JISX0201.1976" -; '(dimension -; 1 -; registry "JISX0201" -; chars 94 -; columns 1 -; direction l2r -; final ?I -; graphic 1 -; short-name "JISX0201 Katakana" -; long-name "Japanese Katakana (JISX0201.1976)" -; )) - -; (make-charset 'latin-jisx0201 -; "Roman Part of JISX0201.1976" -; '(dimension -; 1 -; registry "JISX0201" -; chars 94 -; columns 1 -; direction l2r -; final ?J -; graphic 0 -; short-name "JISX0201 Roman" -; long-name "Japanese Roman (JISX0201.1976)" -; )) - -; (make-charset 'japanese-jisx0208-1978 -; "JISX0208.1978 Japanese Kanji (so called \"old JIS\"): ISO-IR-42" -; '(dimension -; 2 -; registry "JISX0208.1990" -; registry "JISX0208.1978" -; chars 94 -; columns 2 -; direction l2r -; final ?@ -; graphic 0 -; short-name "JISX0208.1978" -; long-name "JISX0208.1978 (Japanese): ISO-IR-42" -; )) - -; (make-charset 'japanese-jisx0208 -; "JISX0208.1983/1990 Japanese Kanji: ISO-IR-87" -; '(dimension -; 2 -; chars 94 -; columns 2 -; direction l2r -; final ?B -; graphic 0 -; short-name "JISX0208" -; long-name "JISX0208.1983/1990 (Japanese): ISO-IR-87" -; )) - -; (make-charset 'japanese-jisx0212 -; "JISX0212 Japanese supplement: ISO-IR-159" -; '(dimension -; 2 -; registry "JISX0212" -; chars 94 -; columns 2 -; direction l2r -; final ?D -; graphic 0 -; short-name "JISX0212" -; long-name "JISX0212 (Japanese): ISO-IR-159" -; )) - (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 +50,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
--- a/lisp/mule/lao.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/lao.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/misc-lang.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/misc-lang.el Sun Nov 05 22:31:46 2006 +0000 @@ -34,7 +34,7 @@ (make-charset 'ipa "IPA (International Phonetic Association)" '(dimension 1 - registry "MuleIPA" + registries ["MuleIPA"] chars 96 columns 1 direction l2r
--- a/lisp/mule/mule-charset.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/mule-charset.el Sun Nov 05 22:31:46 2006 +0000 @@ -106,12 +106,31 @@ 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 (charset-property charset 'registries) 0))) + +(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)) + (unless (equal registry (regexp-quote registry)) + (lwarn 'xintl 'warning + "Regexps no longer allowed for charset-registry. Treating %s%s" + registry " as a string.")) + (set-charset-registries + charset + (apply 'vector registry (append (charset-registries charset) nil)))) (defun charset-ccl-program (charset) "Return the CCL program of CHARSET.
--- a/lisp/mule/thai-xtis.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/thai-xtis.el Sun Nov 05 22:31:46 2006 +0000 @@ -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)
--- a/lisp/mule/tibetan.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/tibetan.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/mule/vietnamese.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/mule/vietnamese.el Sun Nov 05 22:31:46 2006 +0000 @@ -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
--- a/lisp/unicode.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/unicode.el Sun Nov 05 22:31:46 2006 +0000 @@ -29,53 +29,18 @@ ;;; Code: -; ;; Subsets of Unicode. +;; GNU Emacs has the charsets: -; #### what is this bogosity ... "chars 96, final ?2" !!?! -; (make-charset 'mule-unicode-2500-33ff -; "Unicode characters of the range U+2500..U+33FF." -; '(dimension -; 2 -; registry "ISO10646-1" -; chars 96 -; columns 1 -; direction l2r -; final ?2 -; graphic 0 -; short-name "Unicode subset 2" -; long-name "Unicode subset (U+2500..U+33FF)" -; )) - +;; mule-unicode-2500-33ff +;; mule-unicode-e000-ffff +;; mule-unicode-0100-24ff -; (make-charset 'mule-unicode-e000-ffff -; "Unicode characters of the range U+E000..U+FFFF." -; '(dimension -; 2 -; registry "ISO10646-1" -; chars 96 -; columns 1 -; direction l2r -; final ?3 -; graphic 0 -; short-name "Unicode subset 3" -; long-name "Unicode subset (U+E000+FFFF)" -; )) - - -; (make-charset 'mule-unicode-0100-24ff -; "Unicode characters of the range U+0100..U+24FF." -; '(dimension -; 2 -; registry "ISO10646-1" -; chars 96 -; columns 1 -; direction l2r -; final ?1 -; graphic 0 -; short-name "Unicode subset" -; long-name "Unicode subset (U+0100..U+24FF)" -; )) - +;; built-in. This is hack--and an incomplete hack at that--against the +;; spirit and the letter of standard ISO 2022 character sets. Instead of +;; this, we have the jit-ucs-charset-N Mule character sets, created in +;; unicode.c on encountering a Unicode code point that we don't recognise, +;; and saved in ISO 2022 coding systems using the UTF-8 escape described in +;; ISO-IR 196. ;; accessed in loadup.el, mule-cmds.el; see discussion in unicode.c (defvar load-unicode-tables-at-dump-time (eq system-type 'windows-nt) @@ -305,51 +270,19 @@ need-bom t)) (defun decode-char (quote-ucs code &optional restriction) - "FSF compatibility--return Mule character with Unicode codepoint `code'. + "FSF compatibility--return Mule character with Unicode codepoint CODE. The second argument must be 'ucs, the third argument is ignored. " (assert (eq quote-ucs 'ucs) t "Sorry, decode-char doesn't yet support anything but the UCS. ") (unicode-to-char code)) (defun encode-char (char quote-ucs &optional restriction) - "FSF compatibility--return the Unicode code point of `char'. + "FSF compatibility--return the Unicode code point of CHAR. The second argument must be 'ucs, the third argument is ignored. " (assert (eq quote-ucs 'ucs) t "Sorry, encode-char doesn't yet support anything but the UCS. ") (char-to-unicode char)) -(when (featurep 'mule) - ;; This CCL program is used for displaying the fallback UCS character set, - ;; and can be repurposed to lao and the IPA, all going well. - ;; - ;; define-ccl-program is available after mule-ccl is loaded, much later - ;; than this file in the build process. The below is the result of - ;; - ;; (macroexpand - ;; '(define-ccl-program ccl-encode-to-ucs-2 - ;; `(1 - ;; ((r1 = (r1 << 8)) - ;; (r1 = (r1 | r2)) - ;; (mule-to-unicode r0 r1) - ;; (r1 = (r0 >> 8)) - ;; (r2 = (r0 & 255)))) - ;; "CCL program to transform Mule characters to UCS-2.")) - ;; - ;; and it should occasionally be confirmed that the correspondence still - ;; holds. - - (let ((prog [1 10 131127 8 98872 65823 147513 8 82009 255 22])) - (defconst ccl-encode-to-ucs-2 prog - "CCL program to transform Mule characters to UCS-2.") - (put (quote ccl-encode-to-ucs-2) (quote ccl-program-idx) - (register-ccl-program (quote ccl-encode-to-ucs-2) prog)) nil)) - -;; Won't do this just yet, though. -;; (set-charset-registry 'lao "iso10646-1") -;; (set-charset-ccl-program 'lao 'ccl-encode-to-ucs-2) -;; (set-charset-registry 'ipa "iso10646-1") -;; (set-charset-ccl-program 'ipa 'ccl-encode-to-ucs-2) - ;; #### UTF-7 is not yet implemented, and it's tricky to do. There's ;; an implementation in appendix A.1 of the Unicode Standard, Version ;; 2.0, but I don't know its licensing characteristics. @@ -358,8 +291,7 @@ ; 'utf-7 'unicode ; "UTF-7" ; '(mnemonic "UTF7" -; documentation -; "UTF-7 Unicode encoding -- 7-bit-ASCII modal Internet-mail-compatible +; documentation; "UTF-7 Unicode encoding -- 7-bit-ASCII modal Internet-mail-compatible ; encoding especially designed for headers, with the following ; properties:
--- a/lisp/x-faces.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/x-faces.el Sun Nov 05 22:31:46 2006 +0000 @@ -782,7 +782,28 @@ ;; globally. This means we should override global ;; defaults for all X device classes. (remove-specifier (face-font face) locale x-tag-set nil)) - (set-face-font face fn locale 'x append)) + (set-face-font face fn locale 'x append) + ; + ; (debug-print "the face is %s, locale %s, specifier %s" + ; face locale (face-font face)) + ; + ;; And retain some of the fallbacks in the generated default face, + ;; since we don't want to try andale-mono's ISO-10646-1 encoding for + ;; Amharic or Thai. This is fragile; it depends on the code in + ;; faces.c. + (dolist (assocked '((x encode-as-utf-8 initial) + (x two-dimensional initial) + (x one-dimensional final) + (x two-dimensional final))) + (when (and (specifierp (face-font face)) + (consp (specifier-fallback (face-font face))) + (setq assocked + (assoc assocked + (specifier-fallback + (face-font face))))) + (set-face-font face (cdr assocked) locale + (nreverse (car assocked)) append)))) + ;; Kludge-o-rooni. Set the foreground and background resources for ;; X devices only -- otherwise things tend to get all messed up ;; if you start up an X frame and then later create a TTY frame.
--- a/lisp/x-font-menu.el Sat Nov 04 22:51:03 2006 +0000 +++ b/lisp/x-font-menu.el Sun Nov 05 22:31:46 2006 +0000 @@ -43,7 +43,7 @@ x-font-regexp-spacing)) (globally-declare-fboundp - '(charset-registry)) + '(charset-registries)) (defvar x-font-menu-registry-encoding nil "Registry and encoding to use with font menu fonts.") @@ -157,9 +157,7 @@ ;; #### - this should implement a `menus-only' option, which would ;; recalculate the menus from the cache w/o having to do font-list again. (unless x-font-regexp-ascii - (setq x-font-regexp-ascii (if (featurep 'mule) - (charset-registry 'ascii) - "iso8859-1"))) + (setq x-font-regexp-ascii (elt (charset-registries 'ascii) 0))) (setq x-font-menu-registry-encoding (if (featurep 'mule) "*-*" "iso8859-1")) (let ((case-fold-search t)
--- a/src/ChangeLog Sat Nov 04 22:51:03 2006 +0000 +++ b/src/ChangeLog Sun Nov 05 22:31:46 2006 +0000 @@ -1,3 +1,136 @@ +2006-11-05 Aidan Kehoe <kehoea@parhasard.net> + + * charset.h: + Prefer the charset-registries property to the charset-registry + property; accept the latter for compatibility, warning when its + regexp functionality is used. + + * charset.h (XCHARSET_CCL_PROGRAM): + * charset.h (XCHARSET_NAME): + Make dummy versions of these available in non-Mule. + + * console-impl.h: + * console-impl.h (struct console_methods): + Rename the last parameter to a couple of methods; reformat their + declarations. + + * faces.c: + * faces.c (face_property_matching_instance): + * faces.c (ensure_face_cachel_contains_charset): + * faces.c (merge_face_cachel_data): + * faces.c (reset_face_cachel): + * faces.c (mark_face_cachels_as_not_updated): + * faces.c (syms_of_faces): + * faces.c (vars_of_faces): + * faces.c (complex_vars_of_faces): + Provide a DEBUG_FACES macro; use it to make debugging output + available in debug builds. + Implement multi-stage font lookup, assigning the stages names, not + numbers. + Re-implement the cachel->font_specified cache using the + infrastructure for Lisp bit vectors. + + * faces.h: + * faces.h (struct face_cachel): + * faces.h (FACE_CACHEL_FONT_UPDATED): + * faces.h (FACE_FONT): + Re-implement the cachel->font_specified cache using the + infrastructure for Lisp bit vectors. + + * font-mgr.h: + Move some XFT debug macros here from objects-x.c. + + * general-slots.h: + Provide a few new symbols for the multi-stage font resolution + process. + + * intl.c (init_intl): + Correct a comment. + + * lisp.h: + Provide a macro to declare an inline lisp bit vector where the + size is fixed. + Make Qregistries available all over, not Qregistry. + + * mule-charset.c: + * mule-charset.c (mark_charset): + * mule-charset.c (print_charset): + * mule-charset.c (make_charset): + * mule-charset.c (Fmake_charset): + * mule-charset.c (Fcharset_property): + * mule-charset.c (Fset_charset_ccl_program): + * mule-charset.c (syms_of_mule_charset): + * mule-charset.c (complex_vars_of_mule_charset): + * mule-charset.c (CHINESE_CNS_PLANE): + Prefer the charset-registries property to the charset-registry + property; accept the latter for compatibility, warning when its + regexp functionality is used. + + * objects-gtk.c: + * objects-gtk.c (gtk_font_spec_matches_charset): + * objects-gtk.c (gtk_find_charset_font): + * objects-msw.c (mswindows_find_charset_font): + * objects-tty.c (tty_find_charset_font): + Redeclare various functions to work with the multi-stage lookup + process. Include objects-xlike-inc. + + * objects-x.c: + Provide a DEBUG_OBJECTS macro; use it to make debugging output + available in debug builds. + + * objects-x.c (x_initialize_font_instance): + * objects-x.c (x_print_font_instance): + * objects-x.c (xlistfonts_checking_charset): + * objects-x.c (vars_of_objects_x): + Don't regex match on the output of XListFonts; instead, use the + fixed strings of the charset-registries to comparatively limit the + IPC that will happen. Include objects-xlike-inc.c + + * objects-xlike-inc.c: + * objects-xlike-inc.c (count_hyphens): + New. How many ASCII minus characters in a string? + + * objects-xlike-inc.c (xlistfonts_checking_charset): + * objects-xlike-inc.c (mule_to_fc_charset): + * objects-xlike-inc.c (xft_find_charset_font): + * objects-x.c (x_find_charset_font): + Move some methods here to share them with GTK. + + * objects.c (print_font_instance): + * objects.c (font_spec_matches_charset): + * objects.c (font_validate_matchspec): + * objects.c (font_instantiate): + Redeclare some methods to take enums rather than numeric stages. + + * objects.h (EXFUN): + Make Fregexp_quote available to mule-charset.c + + * redisplay-x.c: + * redisplay-x.c (separate_textual_runs): + Make this slightly faster, cleaner. Make it accept a face cachel + pointer argument, and check it as to whether a given charset + should be translated to UCS-2 before redisplay. + + * specifier.c: + * specifier.c (charset_matches_specifier_tag_set_p): + * specifier.c (define_specifier_tag): + * specifier.c (Fdefine_specifier_tag): + * specifier.c (setup_device_initial_specifier_tags): + * specifier.c (setup_charset_initial_specifier_tags): + * specifier.c (specifier_instance_from_inst_list): + * specifier.c (syms_of_specifier): + * specifier.c (vars_of_specifier): + * specifier.h: + Extend specifiers to allow limiting their applicability by using + charset predicates. Document this. + Run indent-region on the file, at Stephen's suggestion. + + * unicode.c (unicode_to_ichar): + * unicode.c (syms_of_unicode): + * unicode.c (vars_of_unicode): + Use unicode-registries, a dumped vector, as the charset-registries + of the on-the-fly JIT charsets. + 2006-11-01 Adrian Aichner <adrian@xemacs.org> * sysdep.c (wcslen): Check for NULL pointer.
--- a/src/charset.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/charset.h Sun Nov 05 22:31:46 2006 +0000 @@ -58,6 +58,8 @@ (byte1) = (ch); \ (byte2) = 0; \ } while (0) +#define XCHARSET_CCL_PROGRAM(cs) Qnil +#define XCHARSET_NAME(cs) Qascii #else /* MULE */ @@ -186,7 +188,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 +273,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 +282,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 +296,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))
--- a/src/console-impl.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/console-impl.h Sun Nov 05 22:31:46 2006 +0000 @@ -26,6 +26,7 @@ #define INCLUDED_console_impl_h_ #include "console.h" +#include "specifier.h" extern const struct sized_memory_description cted_description; extern const struct sized_memory_description console_methods_description; @@ -212,17 +213,13 @@ Lisp_Object (*font_list_method) (Lisp_Object pattern, Lisp_Object device, Lisp_Object maxnumber); - Lisp_Object (*find_charset_font_method) (Lisp_Object device, - Lisp_Object font, - Lisp_Object charset, - int stage); - int (*font_spec_matches_charset_method) (struct device *d, - Lisp_Object charset, - const Ibyte *nonreloc, - Lisp_Object reloc, - Bytecount offset, - Bytecount length, - int stage); + Lisp_Object (*find_charset_font_method) + (Lisp_Object device, Lisp_Object font, Lisp_Object charset, + enum font_specifier_matchspec_stages stage); + int (*font_spec_matches_charset_method) + (struct device *d, Lisp_Object charset, const Ibyte *nonreloc, + Lisp_Object reloc, Bytecount offset, Bytecount length, + enum font_specifier_matchspec_stages stage); /* image methods */ void (*mark_image_instance_method) (Lisp_Image_Instance *);
--- a/src/faces.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/faces.c Sun Nov 05 22:31:46 2006 +0000 @@ -72,6 +72,31 @@ Lisp_Object Vbuilt_in_face_specifiers; +#ifdef DEBUG_XEMACS +Fixnum debug_x_faces; +#endif + +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901) + +#ifdef DEBUG_XEMACS +# define DEBUG_FACES(FORMAT, ...) \ + do { if (debug_x_faces) stderr_out(FORMAT, __VA_ARGS__); } while (0) +#else /* DEBUG_XEMACS */ +# define DEBUG_FACES(format, ...) +#endif /* DEBUG_XEMACS */ + +#elif defined(__GNUC__) + +#ifdef DEBUG_XEMACS +# define DEBUG_FACES(format, args...) \ + do { if (debug_x_faces) stderr_out(format, args ); } while (0) +#else /* DEBUG_XEMACS */ +# define DEBUG_FACES(format, args...) +#endif /* DEBUG_XEMACS */ + +#else /* defined(__STDC_VERSION__) [...] */ +# define DEBUG_FACES (void) +#endif static Lisp_Object mark_face (Lisp_Object obj) @@ -554,37 +579,31 @@ face_property_matching_instance (Lisp_Object face, Lisp_Object property, Lisp_Object charset, Lisp_Object domain, Error_Behavior errb, int no_fallback, - Lisp_Object depth) + Lisp_Object depth, + enum font_specifier_matchspec_stages stage) { Lisp_Object retval; Lisp_Object matchspec = Qunbound; struct gcpro gcpro1; if (!NILP (charset)) - matchspec = noseeum_cons (charset, Qnil); + matchspec = noseeum_cons (charset, + stage == initial ? Qinitial : Qfinal); + GCPRO1 (matchspec); retval = specifier_instance_no_quit (Fget (face, property, Qnil), matchspec, domain, errb, no_fallback, depth); - if (UNBOUNDP (retval)) - { - if (CONSP (matchspec)) - Fsetcdr (matchspec, Qt); - retval = specifier_instance_no_quit (Fget (face, property, Qnil), - matchspec, domain, errb, - no_fallback, depth); - } UNGCPRO; if (CONSP (matchspec)) free_cons (matchspec); - if (UNBOUNDP (retval) && !no_fallback) + if (UNBOUNDP (retval) && !no_fallback && final == stage) { if (EQ (property, Qfont)) { if (NILP (memq_no_quit (charset, XFACE (face)->charsets_warned_about))) { -#ifdef MULE if (!UNBOUNDP (charset)) warn_when_safe (Qfont, Qnotice, @@ -593,12 +612,6 @@ (XSYMBOL (XCHARSET_NAME (charset)))), XSTRING_DATA (symbol_name (XSYMBOL (XFACE (face)->name)))); - else -#endif - warn_when_safe (Qfont, Qnotice, - "Unable to instantiate font for face %s", - XSTRING_DATA (symbol_name - (XSYMBOL (XFACE (face)->name)))); XFACE (face)->charsets_warned_about = Fcons (charset, XFACE (face)->charsets_warned_about); } @@ -1071,11 +1084,11 @@ { Lisp_Object new_val; Lisp_Object face = cachel->face; - int bound = 1; + int bound = 1, final_stage = 0; int offs = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; - if (!UNBOUNDP (cachel->font[offs]) - && cachel->font_updated[offs]) + if (!UNBOUNDP (cachel->font[offs]) && + bit_vector_bit(FACE_CACHEL_FONT_UPDATED (cachel), offs)) return cachel->font[offs]; if (UNBOUNDP (face)) @@ -1085,7 +1098,8 @@ struct window *w = XWINDOW (domain); new_val = Qunbound; - cachel->font_specified[offs] = 0; + set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 0); + for (i = 0; i < cachel->nfaces; i++) { struct face_cachel *oth; @@ -1095,15 +1109,18 @@ /* Tout le monde aime la recursion */ ensure_face_cachel_contains_charset (oth, domain, charset); - if (oth->font_specified[offs]) + if (bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(oth), offs)) { new_val = oth->font[offs]; - cachel->font_specified[offs] = 1; + set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 1); + set_bit_vector_bit + (FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, + bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(oth), offs)); break; } } - if (!cachel->font_specified[offs]) + if (!bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs)) /* need to do the default face. */ { struct face_cachel *oth = @@ -1113,31 +1130,108 @@ new_val = oth->font[offs]; } - if (!UNBOUNDP (cachel->font[offs]) && !EQ (cachel->font[offs], new_val)) + if (!UNBOUNDP (cachel->font[offs]) && + !EQ (cachel->font[offs], new_val)) cachel->dirty = 1; - cachel->font_updated[offs] = 1; + set_bit_vector_bit(FACE_CACHEL_FONT_UPDATED(cachel), offs, 1); cachel->font[offs] = new_val; + DEBUG_FACES("just recursed on the unbound face, returning " + "something %s\n", UNBOUNDP(new_val) ? "not bound" + : "bound"); return new_val; } - new_val = face_property_matching_instance (face, Qfont, charset, domain, - /* #### look into error flag */ - ERROR_ME_DEBUG_WARN, 1, Qzero); - if (UNBOUNDP (new_val)) - { - bound = 0; - new_val = face_property_matching_instance (face, Qfont, - charset, domain, - /* #### look into error - flag */ - ERROR_ME_DEBUG_WARN, 0, - Qzero); - } + do { + + /* Lookup the face, specifying the initial stage and that fallbacks + shouldn't happen. */ + new_val = face_property_matching_instance (face, Qfont, charset, domain, + /* ERROR_ME_DEBUG_WARN is + fine here. */ + ERROR_ME_DEBUG_WARN, 1, Qzero, + initial); + DEBUG_FACES("just called f_p_m_i on face %s, charset %s, initial, " + "result was something %s\n", + XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), + XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), + UNBOUNDP(new_val) ? "not bound" : "bound"); + + if (!UNBOUNDP (new_val)) break; + + bound = 0; + /* Lookup the face again, this time allowing the fallback. If this + succeeds, it'll give a font intended for the script in question, + which is preferable to translating to ISO10646-1 and using the + fixed-with fallback. */ + new_val = face_property_matching_instance (face, Qfont, + charset, domain, + ERROR_ME_DEBUG_WARN, 0, + Qzero, + initial); + + DEBUG_FACES("just called f_p_m_i on face %s, charset %s, initial, " + "allow fallback, result was something %s\n", + XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), + XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), + UNBOUNDP(new_val) ? "not bound" : "bound"); + + if (!UNBOUNDP(new_val)) + { + break; + } + + bound = 1; + /* Try the face itself with the final-stage specifiers. */ + new_val = face_property_matching_instance (face, Qfont, + charset, domain, + ERROR_ME_DEBUG_WARN, 1, + Qzero, + final); + + DEBUG_FACES("just called f_p_m_i on face %s, charset %s, final, " + "result was something %s\n", + XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), + XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), + UNBOUNDP(new_val) ? "not bound" : "bound"); + /* Tell X11 redisplay that it should translate to iso10646-1. */ + if (!UNBOUNDP(new_val)) + { + final_stage = 1; + break; + } + + bound = 0; + + /* Lookup the face again, this time both allowing the fallback and + allowing its final stage to be used. */ + new_val = face_property_matching_instance (face, Qfont, + charset, domain, + ERROR_ME_DEBUG_WARN, 0, + Qzero, + final); + + DEBUG_FACES("just called f_p_m_i on face %s, charset %s, initial, " + "allow fallback, result was something %s\n", + XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), + XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), + UNBOUNDP(new_val) ? "not bound" : "bound"); + if (!UNBOUNDP(new_val)) + { + /* Tell X11 redisplay that it should translate to iso10646-1. */ + final_stage = 1; + break; + } + } while (0); + if (!UNBOUNDP (cachel->font[offs]) && !EQ (new_val, cachel->font[offs])) cachel->dirty = 1; - cachel->font_updated[offs] = 1; + + set_bit_vector_bit(FACE_CACHEL_FONT_UPDATED(cachel), offs, 1); + set_bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, + final_stage); + set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, + (bound || EQ (face, Vdefault_face))); cachel->font[offs] = new_val; - cachel->font_specified[offs] = (bound || EQ (face, Vdefault_face)); return new_val; } @@ -1372,6 +1466,8 @@ merge_face_cachel_data (struct window *w, face_index findex, struct face_cachel *cachel) { + int offs; + #define FINDEX_FIELD(field) \ Dynarr_atp (w->face_cachels, findex)->field @@ -1395,18 +1491,24 @@ FROB (dim); FROB (reverse); FROB (blinking); - /* And do ASCII, of course. */ - { - int offs = LEADING_BYTE_ASCII - MIN_LEADING_BYTE; - if (!cachel->font_specified[offs] && FINDEX_FIELD (font_specified[offs])) - { - cachel->font[offs] = FINDEX_FIELD (font[offs]); - cachel->font_specified[offs] = 1; - cachel->dirty = 1; - } - } - + for (offs = 0; offs < NUM_LEADING_BYTES; ++offs) + { + if (!(bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs)) + && bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED + (Dynarr_atp(w->face_cachels, findex)), offs)) + { + cachel->font[offs] = FINDEX_FIELD (font[offs]); + set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 1); + /* Also propagate whether we're translating to Unicode for the + given face. */ + set_bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, + bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE + (Dynarr_atp(w->face_cachels, + findex)), offs)); + cachel->dirty = 1; + } + } #undef FROB #undef FINDEX_FIELD @@ -1433,6 +1535,8 @@ } cachel->display_table = Qunbound; cachel->background_pixmap = Qunbound; + FACE_CACHEL_FONT_SPECIFIED (cachel)->size = sizeof(cachel->font_specified); + FACE_CACHEL_FONT_UPDATED (cachel)->size = sizeof(cachel->font_updated); } /* Retrieve the index to a cachel for window W that corresponds to @@ -1505,11 +1609,10 @@ for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++) { struct face_cachel *cachel = Dynarr_atp (w->face_cachels, elt); - int i; cachel->updated = 0; - for (i = 0; i < NUM_LEADING_BYTES; i++) - cachel->font_updated[i] = 0; + memset(FACE_CACHEL_FONT_UPDATED(cachel)->bits, 0, + BIT_VECTOR_LONG_STORAGE (NUM_LEADING_BYTES)); } } @@ -1896,6 +1999,81 @@ return new_name; } +#ifdef MULE + +Lisp_Object Qone_dimensional, Qtwo_dimensional; + +DEFUN ("specifier-tag-one-dimensional-p", + Fspecifier_tag_one_dimensional_p, + 2, 2, 0, /* +Return non-nil if (charset-dimension CHARSET) is 1. + +Used by the X11 platform font code; see `define-specifier-tag'. You +shouldn't ever need to call this yourself. +*/ + (charset, UNUSED(stage))) +{ + CHECK_CHARSET(charset); + return (1 == XCHARSET_DIMENSION(charset)) ? Qt : Qnil; +} + +DEFUN ("specifier-tag-two-dimensional-p", + Fspecifier_tag_two_dimensional_p, + 2, 2, 0, /* +Return non-nil if (charset-dimension CHARSET) is 2. + +Used by the X11 platform font code; see `define-specifier-tag'. You +shouldn't ever need to call this yourself. +*/ + (charset, UNUSED(stage))) +{ + CHECK_CHARSET(charset); + return (2 == XCHARSET_DIMENSION(charset)) ? Qt : Qnil; +} + +DEFUN ("specifier-tag-final-stage-p", + Fspecifier_tag_final_stage_p, + 2, 2, 0, /* +Return non-nil if STAGE is 'final. + +Used by the X11 platform font code for giving fallbacks; see +`define-specifier-tag'. You shouldn't ever need to call this. +*/ + (UNUSED(charset), stage)) +{ + return EQ(stage, Qfinal) ? Qt : Qnil; +} + +DEFUN ("specifier-tag-initial-stage-p", + Fspecifier_tag_initial_stage_p, + 2, 2, 0, /* +Return non-nil if STAGE is 'initial. + +Used by the X11 platform font code for giving fallbacks; see +`define-specifier-tag'. You shouldn't ever need to call this. +*/ + (UNUSED(charset), stage)) +{ + return EQ(stage, Qinitial) ? Qt : Qnil; +} + +DEFUN ("specifier-tag-encode-as-utf-8-p", + Fspecifier_tag_encode_as_utf_8_p, + 2, 2, 0, /* +Return t if and only if (charset-property CHARSET 'encode-as-utf-8)). + +Used by the X11 platform font code; see `define-specifier-tag'. You +shouldn't ever need to call this. +*/ + (charset, UNUSED(stage))) +{ + /* Used to check that the stage was initial too. */ + CHECK_CHARSET(charset); + return XCHARSET_ENCODE_AS_UTF_8(charset) ? Qt : Qnil; +} + +#endif /* MULE */ + void syms_of_faces (void) @@ -1917,6 +2095,17 @@ DEFSUBR (Fmake_face); DEFSUBR (Fcopy_face); +#ifdef MULE + DEFSYMBOL (Qone_dimensional); + DEFSYMBOL (Qtwo_dimensional); + /* I would much prefer these were in Lisp. */ + DEFSUBR (Fspecifier_tag_one_dimensional_p); + DEFSUBR (Fspecifier_tag_two_dimensional_p); + DEFSUBR (Fspecifier_tag_initial_stage_p); + DEFSUBR (Fspecifier_tag_final_stage_p); + DEFSUBR (Fspecifier_tag_encode_as_utf_8_p); +#endif /* MULE */ + DEFSYMBOL (Qfacep); DEFSYMBOL (Qforeground); DEFSYMBOL (Qbackground); @@ -1980,6 +2169,13 @@ staticpro (&Vpointer_face); Vpointer_face = Qnil; +#ifdef DEBUG_XEMACS + DEFVAR_INT ("debug-x-faces", &debug_x_faces /* +If non-zero, display debug information about X faces +*/ ); + debug_x_faces = 0; +#endif + { Lisp_Object syms[20]; int n = 0; @@ -2046,6 +2242,14 @@ #if defined (HAVE_X_WINDOWS) || defined (HAVE_GTK) +#ifdef HAVE_GTK + Lisp_Object device_symbol = Qgtk; +#else + Lisp_Object device_symbol = Qx; +#endif + +#ifdef MULE + const Ascbyte *fonts[] = { #ifdef USE_XFT @@ -2053,165 +2257,128 @@ /* Note that fontconfig can search for several font families in one call. We should use this facility. */ - "monospace-12", /* Western #### add encoding info? */ + "Monospace-12", /* 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? */ + "Sazanami Mincho-12", + /* Japanese #### add encoding info? */ /* Arphic for Chinese? */ /* Korean */ #else - - /************** ISO-8859 fonts *************/ - - "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*", - /* under USE_XFT, we always succeed, so let's not waste the effort */ - "-*-fixed-medium-r-*-*-*-120-*-*-*-*-iso8859-*", - "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*", - "-*-fixed-*-r-*-*-*-120-*-*-*-*-iso8859-*", - /* Next try for any "medium" charcell or monospaced iso8859 font. */ - "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*", - "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*", - /* Next try for any charcell or monospaced iso8859 font. */ - "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*", - "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*", - - /* Repeat, any size */ - "-*-courier-medium-r-*-*-*-*-*-*-*-*-iso8859-*", - "-*-fixed-medium-r-*-*-*-*-*-*-*-*-iso8859-*", - "-*-courier-*-r-*-*-*-*-*-*-*-*-iso8859-*", - "-*-fixed-*-r-*-*-*-*-*-*-*-*-iso8859-*", - /* Next try for any "medium" charcell or monospaced iso8859 font. */ - "-*-*-medium-r-*-*-*-*-*-*-m-*-iso8859-*", - "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-*", - /* Next try for any charcell or monospaced iso8859 font. */ - "-*-*-*-r-*-*-*-*-*-*-m-*-iso8859-*", - "-*-*-*-r-*-*-*-*-*-*-c-*-iso8859-*", - - /* Non-proportional fonts -- last resort. */ - "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*", - "-*-*-*-r-*-*-*-*-*-*-*-*-iso8859-*", - "-*-*-*-*-*-*-*-*-*-*-*-*-iso8859-*", - - /************* Japanese fonts ************/ - - /* Following 3 fonts proposed by Teruhiko.Kurosaka@Japan.eng.sun */ - "-sun-gothic-medium-r-normal--14-120-75-75-c-60-jisx0201.1976-0", - "-sun-gothic-medium-r-normal--14-120-75-75-c-120-jisx0208.1983-0", - "-wadalab-gothic-medium-r-normal--14-120-75-75-c-120-jisx0212.1990-0", - - /* Other Japanese fonts */ - "-*-fixed-medium-r-*--*-jisx0201.1976-*", - "-*-fixed-medium-r-*--*-jisx0208.1983-*", - "-*-fixed-medium-r-*--*-jisx0212*-*", - "-*-*-*-r-*--*-jisx0201.1976-*", - "-*-*-*-r-*--*-jisx0208.1983-*", - "-*-*-*-r-*--*-jisx0212*-*", - - /************* Chinese fonts ************/ - - "-*-*-medium-r-*--*-gb2312.1980-*", - "-*-fixed-medium-r-*--*-cns11643*-*", - - "-*-fixed-medium-r-*--*-big5*-*," - "-*-fixed-medium-r-*--*-sisheng_cwnn-0", - - /************* Korean fonts *************/ - - "-*-mincho-medium-r-*--*-ksc5601.1987-*", - - /************* Thai fonts **************/ - - "-*-fixed-medium-r-*--*-tis620.2529-1", - - /************* Other fonts (nonstandard) *************/ - - "-*-fixed-medium-r-*--*-viscii1.1-1", - "-*-fixed-medium-r-*--*-mulearabic-*", - "-*-fixed-medium-r-*--*-muleipa-*", - "-*-fixed-medium-r-*--*-ethio-*", - - /************* Unicode fonts **************/ - - /* #### We don't yet support Unicode fonts, but doing so would not be - hard because all the machinery has already been added for Windows - support. We need to do this: - - (1) Add "stage 2" support in find_charset_font()/etc.; this finds - an appropriate Unicode font after all the charset-specific fonts - have been checked. This should look at the per-char font info and - check whether we have support for some of the chars in the - charset. (#### Bogus, but that's the way it currently works) - - sjt sez: With Xft/fontconfig that information is available as a - 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. - - (2) Record in the font instance a flag indicating when we're - dealing with a Unicode font. - - (3) Notice this flag in separate_textual_runs() and translate the - text into Unicode if so. - */ - - "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso10646-1", - "-*-fixed-medium-r-*-*-*-120-*-*-*-*-iso10646-1", - "-*-courier-*-r-*-*-*-120-*-*-*-*-iso10646-1", - "-*-fixed-*-r-*-*-*-120-*-*-*-*-iso10646-1", - /* Next try for any "medium" charcell or monospaced iso8859 font. */ - "-*-*-medium-r-*-*-*-120-*-*-m-*-iso10646-1", - "-*-*-medium-r-*-*-*-120-*-*-c-*-iso10646-1", - /* Next try for any charcell or monospaced iso8859 font. */ - "-*-*-*-r-*-*-*-120-*-*-m-*-iso10646-1", - "-*-*-*-r-*-*-*-120-*-*-c-*-iso10646-1", - - /* Repeat, any size */ - "-*-courier-medium-r-*-*-*-*-*-*-*-*-iso10646-1", - "-*-fixed-medium-r-*-*-*-*-*-*-*-*-iso10646-1", - "-*-courier-*-r-*-*-*-*-*-*-*-*-iso10646-1", - "-*-fixed-*-r-*-*-*-*-*-*-*-*-iso10646-1", - /* Next try for any "medium" charcell or monospaced iso8859 font. */ - "-*-*-medium-r-*-*-*-*-*-*-m-*-iso10646-1", - "-*-*-medium-r-*-*-*-*-*-*-c-*-iso10646-1", - /* Next try for any charcell or monospaced iso8859 font. */ - "-*-*-*-r-*-*-*-*-*-*-m-*-iso10646-1", - "-*-*-*-r-*-*-*-*-*-*-c-*-iso10646-1", - - /* Non-proportional fonts -- last resort. */ - "-*-*-*-r-*-*-*-120-*-*-*-*-iso10646-1", - "-*-*-*-r-*-*-*-*-*-*-*-*-iso10646-1", - "-*-*-*-*-*-*-*-*-*-*-*-*-iso10646-1", - - /*********** Last resort ***********/ - - /* Boy, we sure are losing now. Try the above, but in any encoding. */ - "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*", - "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*", - "-*-*-*-r-*-*-*-120-*-*-m-*-*-*", - "-*-*-*-r-*-*-*-120-*-*-c-*-*-*", - /* Hello? Please? */ - "-*-*-*-r-*-*-*-120-*-*-*-*-*-*", - "-*-*-*-*-*-*-*-120-*-*-*-*-*-*", - "-*-*-*-*-*-*-*-*-*-*-*-*-*-*", - "*" + /* The default Japanese fonts installed with XFree86 4.0 use this + point size, and the -misc-fixed fonts (which look really bad with + Han characters) don't. We need to prefer the former. */ + "-*-*-medium-r-*-*-*-150-*-*-c-*-*-*", + /* And the Chinese ones, maddeningly, use this one. (But on 4.0, while + XListFonts returns them, XLoadQueryFont on the fully-specified XLFD + corresponding to one of them fails!) */ + "-*-*-medium-r-*-*-*-160-*-*-c-*-*-*", + "-*-*-medium-r-*-*-*-170-*-*-c-*-*-*", #endif }; const Ascbyte **fontptr; -#ifdef HAVE_X_WINDOWS - for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--) - inst_list = Fcons (Fcons (list1 (Qx), build_string (*fontptr)), - inst_list); -#endif /* HAVE_X_WINDOWS */ + /* Define some specifier tags for classes of character sets. Combining + these allows for distinct fallback fonts for distinct dimensions of + character sets and stages. */ + + define_specifier_tag(Qtwo_dimensional, Qnil, + intern ("specifier-tag-two-dimensional-p")); + + define_specifier_tag(Qone_dimensional, Qnil, + intern ("specifier-tag-one-dimensional-p")); + + define_specifier_tag(Qinitial, Qnil, + intern ("specifier-tag-initial-stage-p")); + + define_specifier_tag(Qfinal, Qnil, + intern ("specifier-tag-final-stage-p")); + + define_specifier_tag (Qencode_as_utf_8, Qnil, + intern("specifier-tag-encode-as-utf-8-p")); + +#endif /* MULE */ + + inst_list = + Fcons + (Fcons + (list1 (device_symbol), + build_string ("*")), + inst_list); + +#ifdef MULE + + /* For Han characters and Ethiopic, we want the misc-fixed font used to + be distinct from that for alphabetic scripts, because the font + specified below is distractingly ugly when used for Han characters + (this is slightly less so) and because its coverage isn't up to + handling them (well, chiefly, it's not up to handling Ethiopic--we do + have charset-specific fallbacks for the East Asian charsets.) */ + inst_list = + Fcons + (Fcons + (list3(device_symbol, Qtwo_dimensional, Qfinal), + build_string + ("-misc-fixed-medium-r-normal--15-140-75-75-c-90-iso10646-1")), + inst_list); + + /* Use Markus Kuhn's version of misc-fixed as the font for the font for + when a given charset's registries can't be found and redisplay for + that charset falls back to iso10646-1. */ -#ifdef HAVE_GTK + inst_list = + Fcons + (Fcons + (list3(device_symbol, Qone_dimensional, Qfinal), + build_string + ("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), + inst_list); + for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--) - inst_list = Fcons (Fcons (list1 (Qgtk), build_string (*fontptr)), + inst_list = Fcons (Fcons (list3 (device_symbol, + Qtwo_dimensional, Qinitial), + build_string (*fontptr)), inst_list); -#endif /* HAVE_GTK */ + + /* We need to set the font for the JIT-ucs-charsets separately from the + final stage, since otherwise it picks up the two-dimensional + specification (see specifier-tag-two-dimensional-initial-stage-p + above). They also use Markus Kuhn's ISO 10646-1 fixed fonts for + redisplay. */ + + inst_list = + Fcons + (Fcons + (list3(device_symbol, Qencode_as_utf_8, Qinitial), + build_string + ("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), + inst_list); + +#endif /* MULE */ + + /* Needed to make sure that charsets with non-specified fonts don't + use bold and oblique first if medium and regular are available. */ + inst_list = + Fcons + (Fcons + (list1 (device_symbol), + build_string ("-*-*-medium-r-*-*-*-120-*-*-c-*-*-*")), + inst_list); + + /* With a Cygwin XFree86 install, this returns the best (clearest, + most readable) font I can find when scaling of bitmap fonts is + turned on, as it is by default. (WHO IN THE NAME OF CHRIST THOUGHT + THAT WAS A GOOD IDEA?!?!) The other fonts that used to be specified + here gave horrendous results. */ + + inst_list = + Fcons + (Fcons + (list1 (device_symbol), + build_string ("-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-*-*")), + inst_list); + #endif /* HAVE_X_WINDOWS || HAVE_GTK */ #ifdef HAVE_TTY
--- a/src/faces.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/faces.h Sun Nov 05 22:31:46 2006 +0000 @@ -25,6 +25,7 @@ #define INCLUDED_faces_h_ #include "charset.h" /* for NUM_LEADING_BYTES */ +#include "specifier.h" /* a Lisp_Face is the C object corresponding to a face. There is one of these per face. It basically contains all of the specifiers for @@ -181,8 +182,8 @@ /* Used when merging to tell if the above field represents an actual value of this face or a fallback value. */ - /* #### Of course we should use a bit array or something. */ - unsigned char font_specified[NUM_LEADING_BYTES]; + DECLARE_INLINE_LISP_BIT_VECTOR(NUM_LEADING_BYTES) font_specified; + unsigned int foreground_specified :1; unsigned int background_specified :1; unsigned int display_table_specified :1; @@ -223,8 +224,13 @@ storing a "blank font" if the instantiation fails. */ unsigned int dirty :1; unsigned int updated :1; - /* #### Of course we should use a bit array or something. */ - unsigned char font_updated[NUM_LEADING_BYTES]; + + DECLARE_INLINE_LISP_BIT_VECTOR(NUM_LEADING_BYTES) font_updated; + + /* Whether the font for the charset in question was determined in the + "final stage"; that is, the last stage Lisp code could specify it, + after the initial stage and before the fallback. */ + DECLARE_INLINE_LISP_BIT_VECTOR(NUM_LEADING_BYTES) font_final_stage; }; #ifdef NEW_GC @@ -303,6 +309,13 @@ #define FACE_CACHEL_FONT(cachel, charset) \ (cachel->font[XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE]) +#define FACE_CACHEL_FONT_UPDATED(x) \ + ((struct Lisp_Bit_Vector *)(&((x)->font_updated))) +#define FACE_CACHEL_FONT_SPECIFIED(x) \ + ((struct Lisp_Bit_Vector *)(&((x)->font_specified))) +#define FACE_CACHEL_FONT_FINAL_STAGE(x) \ + ((struct Lisp_Bit_Vector *)(&((x)->font_final_stage))) + #define WINDOW_FACE_CACHEL(window, index) \ Dynarr_atp ((window)->face_cachels, index) @@ -352,13 +365,15 @@ FACE_PROPERTY_INSTANCE_1 (face, property, domain, ERROR_ME_DEBUG_WARN, \ no_fallback, depth) -Lisp_Object face_property_matching_instance (Lisp_Object face, - Lisp_Object property, - Lisp_Object charset, - Lisp_Object domain, - Error_Behavior errb, - int no_fallback, - Lisp_Object depth); +Lisp_Object face_property_matching_instance + (Lisp_Object face, + Lisp_Object property, + Lisp_Object charset, + Lisp_Object domain, + Error_Behavior errb, + int no_fallback, + Lisp_Object depth, + enum font_specifier_matchspec_stages stages); #define FACE_PROPERTY_SPEC_LIST(face, property, locale) \ Fspecifier_spec_list (FACE_PROPERTY_SPECIFIER (face, property), \ @@ -373,7 +388,8 @@ FACE_PROPERTY_INSTANCE (face, Qbackground, domain, 0, Qzero) #define FACE_FONT(face, domain, charset) \ face_property_matching_instance (face, Qfont, charset, domain, \ - ERROR_ME_DEBUG_WARN, 0, Qzero) + ERROR_ME_DEBUG_WARN, 0, Qzero, \ + initial) #define FACE_DISPLAY_TABLE(face, domain) \ FACE_PROPERTY_INSTANCE (face, Qdisplay_table, domain, 0, Qzero) #define FACE_BACKGROUND_PIXMAP(face, domain) \
--- a/src/font-mgr.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/font-mgr.h Sun Nov 05 22:31:46 2006 +0000 @@ -68,4 +68,73 @@ #define CONCHECK_FCPATTERN(x) CONCHECK_RECORD (x, fc_pattern) #define XFCPATTERN_PTR(x) (XFCPATTERN(x)->fcpatPtr) +#ifdef USE_XFT +/* + 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_ */
--- a/src/general-slots.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/general-slots.h Sun Nov 05 22:31:46 2006 +0000 @@ -130,6 +130,7 @@ SYMBOL (Qfile); SYMBOL_MODULE_API (Qfile_name); SYMBOL_KEYWORD (Q_filter); +SYMBOL (Qfinal); SYMBOL (Qfixnum); SYMBOL (Qfloat); SYMBOL (Qfont); @@ -157,6 +158,7 @@ SYMBOL (Qicon); SYMBOL (Qid); SYMBOL (Qignore); +SYMBOL (Qinitial); SYMBOL (Qimage); SYMBOL_KEYWORD (Q_image); SYMBOL_KEYWORD (Q_included); @@ -286,6 +288,7 @@ SYMBOL (Qundecided); SYMBOL (Qundefined); SYMBOL (Qunimplemented); +SYMBOL (Qunicode_registries); SYMBOL (Quser_default); SYMBOL_KEYWORD (Q_value); SYMBOL (Qvalue_assoc);
--- a/src/intl.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/intl.c Sun Nov 05 22:31:46 2006 +0000 @@ -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 ();
--- a/src/lisp.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/lisp.h Sun Nov 05 22:31:46 2006 +0000 @@ -2623,6 +2623,13 @@ #define BIT_VECTOR_LONG_STORAGE(len) \ (((len) + LONGBITS_POWER_OF_2 - 1) >> LONGBITS_LOG2) +/* For when we want to include a bit vector in another structure, and we + know it's of a fixed size. */ +#define DECLARE_INLINE_LISP_BIT_VECTOR(numbits) struct { \ + struct LCRECORD_HEADER lheader; \ + Elemcount size; \ + unsigned long bits[BIT_VECTOR_LONG_STORAGE(numbits)]; \ +} /*------------------------------ symbol --------------------------------*/ @@ -5601,7 +5608,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;
--- a/src/mule-charset.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/mule-charset.c Sun Nov 05 22:31:46 2006 +0000 @@ -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, Qregistry; 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,27 @@ invalid_constant ("Invalid value for `graphic'", value); } + else if (EQ (keyword, Qregistries)) + { + CHECK_VECTOR (value); + registries = value; + } + else if (EQ (keyword, Qregistry)) { + Lisp_Object quoted_registry; + CHECK_STRING (value); - registry = value; + quoted_registry = Fregexp_quote(value); + if (strcmp(XSTRING_DATA(quoted_registry), + XSTRING_DATA(value))) + { + warn_when_safe + (Qregistry, Qwarning, + "Regexps no longer allowed for charset-registry. " + "Treating %s as string", XSTRING_DATA(value)); + } + registries = vector1(value); } else if (EQ (keyword, Qdirection)) @@ -613,8 +634,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 +645,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 +678,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 +705,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 +841,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); @@ -862,15 +883,39 @@ return Qnil; } -/* 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. +DEFUN ("set-charset-registries", Fset_charset_registries, 2, 2, 0, /* +Set the `registries' property of CHARSET to REGISTRIES. + +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,16 +1012,17 @@ 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 (Qregistry); DEFSYMBOL (Qdirection); DEFSYMBOL (Qreverse_direction_charset); DEFSYMBOL (Qshort_name); @@ -1056,7 +1102,7 @@ build_string ("ASCII"), build_msg_string ("ASCII"), build_msg_string ("ASCII (ISO646 IRV)"), - build_string ("\\(iso8859-[0-9]*\\|-ascii\\)"), 0, 0); + vector1(build_string("iso8859-1")), 0, 0); staticpro (&Vcharset_control_1); Vcharset_control_1 = make_charset (LEADING_BYTE_CONTROL_1, Qcontrol_1, 2, @@ -1065,7 +1111,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 +1120,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 +1129,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 +1138,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 +1147,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 +1156,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 +1165,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 +1174,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 +1183,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 +1192,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 +1201,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 +1210,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 +1219,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 +1228,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 +1238,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 +1248,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 +1258,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 +1268,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 +1277,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 +1289,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 +1299,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 +1309,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 +1319,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 +1334,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 +1346,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 */ }
--- a/src/objects-gtk.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects-gtk.c Sun Nov 05 22:31:46 2006 +0000 @@ -40,6 +40,14 @@ /* sigh */ #include <gdk/gdkx.h> +/* XListFonts doesn't allocate memory unconditionally based on this. (For + XFree86 in 2005, at least. */ +#define MAX_FONT_COUNT INT_MAX + +#ifdef DEBUG_XEMACS +Fixnum debug_x_objects; +#endif /* DEBUG_XEMACS */ + /************************************************************************/ /* color instances */ @@ -379,66 +387,9 @@ return (__gtk_font_list_internal (patternext)); } -#ifdef MULE - -static int -gtk_font_spec_matches_charset (struct device *UNUSED (d), Lisp_Object charset, - const Ibyte *nonreloc, Lisp_Object reloc, - Bytecount offset, Bytecount length, - int stage) -{ - if (stage) - return 0; - - 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 - long form; sorry buster. - */ - if (EQ (charset, Vcharset_ascii)) - { - 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 (fast_string_match (XCHARSET_REGISTRY (charset), - nonreloc, reloc, offset, length, 1, - ERROR_ME, 0) >= 0); -} - -/* find a font spec that matches font spec FONT and also matches - (the registry of) CHARSET. */ -static Lisp_Object gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, int stage); - -#endif /* MULE */ +/* Include the charset support, shared, for the moment, with X11. */ +#define THIS_IS_GTK +#include "objects-xlike-inc.c" /************************************************************************/ @@ -479,63 +430,14 @@ void vars_of_objects_gtk (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 } -/* #### BILL!!! Try to make this go away eventually */ -/* X Specific stuff */ -#include <X11/Xatom.h> - -#define MAX_FONT_COUNT INT_MAX - -#ifdef MULE -/* find a font spec that matches font spec FONT and also matches - (the registry of) CHARSET. */ -static Lisp_Object -gtk_find_charset_font (Lisp_Object device, Lisp_Object font, - Lisp_Object charset, int stage) -{ - char **names; - int count = 0; - Lisp_Object result = Qnil; - const char *patternext; - int i; - - if (stage) - return Qnil; - - TO_EXTERNAL_FORMAT (LISP_STRING, font, C_STRING_ALLOCA, patternext, Qbinary); - - names = XListFonts (GDK_DISPLAY (), - patternext, MAX_FONT_COUNT, &count); - /* #### This code seems awfully bogus -- mrb */ - for (i = 0; i < count; i ++) - { - const Ibyte *intname; - Bytecount intlen; - - TO_INTERNAL_FORMAT (C_STRING, names[i], ALLOCA, (intname, intlen), - Qctext); - if (gtk_font_spec_matches_charset (XDEVICE (device), charset, - intname, Qnil, 0, -1, 0)) - { - result = make_string (intname, intlen); - break; - } - } - - if (names) - XFreeFontNames (names); - - /* Check for a short font name. */ - if (NILP (result) - && gtk_font_spec_matches_charset (XDEVICE (device), charset, 0, - font, 0, -1, 0)) - return font; - - return result; -} -#endif /* MULE */ - static int valid_font_name_p (Display *dpy, char *name) {
--- a/src/objects-msw.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects-msw.c Sun Nov 05 22:31:46 2006 +0000 @@ -2182,7 +2182,8 @@ static Lisp_Object mswindows_find_charset_font (Lisp_Object device, Lisp_Object font, - Lisp_Object charset, int stage) + Lisp_Object charset, + enum font_specifier_matchspec_stages stage) { Lisp_Object fontlist, fonttail;
--- a/src/objects-tty.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects-tty.c Sun Nov 05 22:31:46 2006 +0000 @@ -367,7 +367,8 @@ (the registry of) CHARSET. */ static Lisp_Object tty_find_charset_font (Lisp_Object device, Lisp_Object font, - Lisp_Object charset, int stage) + Lisp_Object charset, + enum font_specifier_matchspec_stages stage) { Ibyte *fontname = XSTRING_DATA (font);
--- a/src/objects-x.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects-x.c Sun Nov 05 22:31:46 2006 +0000 @@ -37,6 +37,7 @@ #include "console-x-impl.h" #include "objects-x-impl.h" +#include "elhash.h" #ifdef USE_XFT #include "font-mgr.h" @@ -44,6 +45,10 @@ int x_handle_non_fully_specified_fonts; +#ifdef DEBUG_XEMACS +Fixnum debug_x_objects; +#endif /* DEBUG_XEMACS */ + /************************************************************************/ /* color instances */ @@ -205,74 +210,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), @@ -299,6 +236,12 @@ rf = xft_open_font_by_name (dpy, extname); #endif LISP_STRING_TO_EXTERNAL (f->name, extname, Qx_font_name_encoding); + /* With XFree86 4.0's fonts, XListFonts returns an entry for + -isas-fangsong ti-medium-r-normal--16-160-72-72-c-160-gb2312.1980-0 but + an XLoadQueryFont on the corresponding XLFD returns NULL. + + XListFonts is not trustworthy (of course, this is news to exactly + no-one used to reading XEmacs source.) */ fs = XLoadQueryFont (dpy, extname); if (!fs && !rf) @@ -461,9 +404,13 @@ Lisp_Object printcharfun, int UNUSED (escapeflag)) { + /* We should print information here about initial vs. final stages; we + can't rely on the device charset stage cache for that, + unfortunately. */ if (FONT_INSTANCE_X_FONT (f)) - write_fmt_string (printcharfun, " font id: 0x%lx", - (unsigned long) FONT_INSTANCE_X_FONT (f)->fid); + write_fmt_string (printcharfun, " font id: 0x%lx,", + (unsigned long) FONT_INSTANCE_X_FONT (f)->fid); + #ifdef USE_XFT /* #### What should we do here? For now, print the address. */ if (FONT_INSTANCE_X_XFTFONT (f)) @@ -944,534 +891,9 @@ return result; } -#ifdef MULE - -static int -x_font_spec_matches_charset (struct device * USED_IF_XFT (d), - Lisp_Object charset, - const Ibyte *nonreloc, Lisp_Object reloc, - Bytecount offset, Bytecount length, - int stage) -{ - if (stage) -#ifdef USE_XFT - { - Display *dpy = DEVICE_X_DISPLAY (d); - Extbyte *extname; - XftFont *rf; - const Ibyte *the_nonreloc; - - if (!NILP(reloc)) - { - the_nonreloc = XSTRING_DATA (reloc); - 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 ;) */ - } - } -#else - return 0; -#endif - - 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 - long form; sorry buster. - #### FMH: this screws fontconfig/Xft? - STRATEGY: use fontconfig's ability to hack languages and character - sets (lang and charset properties). - #### Maybe we can use the fontconfig model to eliminate the difference - 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)) - { - 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 (fast_string_match (XCHARSET_REGISTRY (charset), - nonreloc, reloc, offset, length, 1, - ERROR_ME, 0) >= 0); -} - -#ifdef USE_XFT -/* #### debug functions: find a better place for us */ -const char *FcResultToString (FcResult r); -const char * -FcResultToString (FcResult r) -{ - static char buffer[256]; - switch (r) - { - case FcResultMatch: - return "FcResultMatch"; - case FcResultNoMatch: - return "FcResultNoMatch"; - case FcResultTypeMismatch: - return "FcResultTypeMismatch"; - case FcResultNoId: - return "FcResultNoId"; - default: - snprintf (buffer, 255, "FcResultUndocumentedValue (%d)", r); - return buffer; - } -} - -const char *FcTypeOfValueToString (FcValue v); -const char * -FcTypeOfValueToString (FcValue v) -{ - static char buffer[256]; - switch (v.type) - { - case FcTypeMatrix: - return "FcTypeMatrix"; - case FcTypeString: - return "FcTypeString"; - case FcTypeVoid: - return "FcTypeVoid"; - case FcTypeDouble: - return "FcTypeDouble"; - case FcTypeInteger: - return "FcTypeInteger"; - case FcTypeBool: - return "FcTypeBool"; - case FcTypeCharSet: - return "FcTypeCharSet"; - case FcTypeLangSet: - return "FcTypeLangSet"; - /* #### There is no union member of this type, but there are void* and - FcPattern* members, as of fontconfig.h FC_VERSION 10002 */ - case FcTypeFTFace: - return "FcTypeFTFace"; - default: - snprintf (buffer, 255, "FcTypeUndocumentedType (%d)", v.type); - return buffer; - } -} - -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; -} - -struct charset_reporter { - Lisp_Object *charset; - /* This is a debug facility, require ASCII. */ - Extbyte *language; /* ASCII, please */ - /* Technically this is FcChar8, but fsckin' GCC 4 bitches. */ - Extbyte *rfc3066; /* ASCII, please */ -}; - -static struct charset_reporter charset_table[] = - { - /* #### It's my branch, my favorite charsets get checked first! - That's a joke, Son. - Ie, I don't know what I'm doing, so my charsets first is as good as - any other arbitrary order. If you have a better idea, speak up! */ - { &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", "el" }, - /* #### all the Chinese need checking - Damn the blood-sucking ISO anyway. */ - { &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, "Hebrew", "he" }, - { &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 } - }; - -/* Choose appropriate font name for debug messages. - Use only in the top half of next function (enforced with #undef). */ -#define DECLARE_DEBUG_FONTNAME(__xemacs_name) \ - Eistring *__xemacs_name; \ - do \ - { \ - __xemacs_name = debug_xft > 2 ? eistr_fullname \ - : debug_xft > 1 ? eistr_longname \ - : 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) -{ - 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. */ - - DEBUG_XFT1 (1, "confirming charset for font instance %s\n", - XSTRING_DATA(font)); - - /* #### this looks like a fair amount of work, but the basic design - has never been rethought, and it should be - - what really should happen here is that we use FcFontSort (FcFontList?) - to get a list of matching fonts, then pick the first (best) one that - gives language or repertoire coverage. - */ - - FcInit (); /* No-op if already initialized. - In fontconfig 2.3.2, this cannot return - failure, but that looks like a bug. We - check for it with FcGetCurrentConfig(), - which *can* fail. */ - if (!FcConfigGetCurrent()) /* #### We should expose FcInit* interfaces - to LISP and decide when to reinitialize - intelligently. */ - stderr_out ("Failed fontconfig initialization\n"); - else - { - FcPattern *fontxft; /* long-lived, freed at end of this block */ - FcResult fcresult; - FcConfig *fcc; - FcChar8 *lang = (FcChar8 *) "en"; /* #### fix this bogus hack! */ - FcCharSet *fccs = NULL; - DECLARE_EISTRING (eistr_shortname); /* user-friendly nickname */ - DECLARE_EISTRING (eistr_longname); /* omit FC_LANG and FC_CHARSET */ - DECLARE_EISTRING (eistr_fullname); /* everything */ - - LISP_STRING_TO_EXTERNAL (font, patternext, Qfc_font_name_encoding); - fcc = FcConfigGetCurrent (); - - /* parse the name, do the substitutions, and match the font */ - - { - FcPattern *p = FcNameParse ((FcChar8 *) patternext); - PRINT_XFT_PATTERN (3, "FcNameParse'ed name is %s\n", p); - /* #### Next two return FcBool, but what does the return mean? */ - /* The order is correct according the fontconfig docs. */ - FcConfigSubstitute (fcc, p, FcMatchPattern); - PRINT_XFT_PATTERN (2, "FcConfigSubstitute'ed name is %s\n", p); - FcDefaultSubstitute (p); - PRINT_XFT_PATTERN (3, "FcDefaultSubstitute'ed name is %s\n", p); - /* #### check fcresult of following match? */ - fontxft = FcFontMatch (fcc, p, &fcresult); - /* this prints the long fontconfig name */ - PRINT_XFT_PATTERN (1, "FcFontMatch'ed name is %s\n", fontxft); - FcPatternDestroy (p); - } - - /* heuristic to give reasonable-length names for debug reports - - I considered #ifdef SUPPORT_FULL_FONTCONFIG_NAME etc but that's - pointless. We're just going to remove this code once the font/ - face refactoring is done, but until then it could be very useful. - */ - { - FcPattern *p = FcFontRenderPrepare (fcc, fontxft, fontxft); - FcChar8 *name; - - /* full name, including language coverage and repertoire */ - name = FcNameUnparse (p); - eicpy_ext (eistr_fullname, (Extbyte *) name, Qfc_font_name_encoding); - free (name); - - /* long name, omitting coverage and repertoire, plus a number - of rarely useful properties */ - FcPatternDel (p, FC_CHARSET); - FcPatternDel (p, FC_LANG); - FcPatternDel (p, FC_WIDTH); - FcPatternDel (p, FC_SPACING); - FcPatternDel (p, FC_HINTING); - FcPatternDel (p, FC_VERTICAL_LAYOUT); - FcPatternDel (p, FC_AUTOHINT); - FcPatternDel (p, FC_GLOBAL_ADVANCE); - FcPatternDel (p, FC_INDEX); - FcPatternDel (p, FC_SCALE); - FcPatternDel (p, FC_FONTVERSION); - name = FcNameUnparse (p); - eicpy_ext (eistr_longname, (Extbyte *) name, Qfc_font_name_encoding); - free (name); - - /* nickname, just family and size, but - "family" names usually have style, slant, and weight */ - FcPatternDel (p, FC_FOUNDRY); - FcPatternDel (p, FC_STYLE); - FcPatternDel (p, FC_SLANT); - FcPatternDel (p, FC_WEIGHT); - FcPatternDel (p, FC_PIXEL_SIZE); - FcPatternDel (p, FC_OUTLINE); - FcPatternDel (p, FC_SCALABLE); - FcPatternDel (p, FC_DPI); - name = FcNameUnparse (p); - eicpy_ext (eistr_shortname, (Extbyte *) name, Qfc_font_name_encoding); - free (name); - - 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. */ - - { - /* This block possibly should be a function, but it generates - multiple values. I find the "pass an address to return the - value in" idiom opaque, so prefer a block. */ - struct charset_reporter *cr; - for (cr = charset_table; - cr->charset && !EQ (*(cr->charset), charset); - cr++) - ; - - if (cr->rfc3066) - { - DECLARE_DEBUG_FONTNAME (name); - CHECKING_LANG (0, eidata(name), cr->language); - lang = (FcChar8 *) cr->rfc3066; - } - else if (cr->charset) - { - /* what the hey, build 'em on the fly */ - /* #### in the case of error this could return NULL! */ - fccs = mule_to_fc_charset (charset); - lang = (FcChar8 *) XSTRING_DATA (XSYMBOL - (XCHARSET_NAME (charset))-> name); - } - else - { - /* OK, we fell off the end of the table */ - warn_when_safe_lispobj (intern ("xft"), intern ("alert"), - list2 (build_string ("unchecked charset"), - charset)); - /* default to "en" - #### THIS IS WRONG, WRONG, WRONG!! - It is why we never fall through to XLFD-checking. */ - } - - ASSERT_ASCTEXT_ASCII((Extbyte *) lang); - } - - if (fccs) - { - /* check for character set coverage */ - int i = 0; - FcCharSet *v; - FcResult r = FcPatternGetCharSet (fontxft, FC_CHARSET, i, &v); - - if (r == FcResultTypeMismatch) - { - DEBUG_XFT0 (0, "Unexpected type return in charset value\n"); - result = Qnil; - } - 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 - 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? */ - DECLARE_DEBUG_FONTNAME (name); - DEBUG_XFT2 (0, "Xft font %s supports %s\n", - eidata(name), lang); -#ifdef RETURN_LONG_FONTCONFIG_NAMES - result = eimake_string(eistr_fullname); -#else - result = eimake_string(eistr_longname); -#endif - } - else - { - DECLARE_DEBUG_FONTNAME (name); - DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", - eidata(name), lang); - result = Qnil; - } - - /* clean up */ - FcCharSetDestroy (fccs); - } - else - { - /* check for language coverage */ - int i = 0; - FcValue v; - /* the main event */ - FcResult r = FcPatternGet (fontxft, FC_LANG, i, &v); - - if (r == FcResultMatch) - { - if (v.type != FcTypeLangSet) /* excessive paranoia */ - { - ASSERT_ASCTEXT_ASCII(FcTypeOfValueToString(v)); - /* Urk! Fall back and punt to core font. */ - DEBUG_XFT1 (0, "Unexpected type of lang value (%s)\n", - FcTypeOfValueToString (v)); - result = Qnil; - } - else if (FcLangSetHasLang (v.u.l, lang) != FcLangDifferentLang) - { - DECLARE_DEBUG_FONTNAME (name); - DEBUG_XFT2 (0, "Xft font %s supports %s\n", - eidata(name), lang); -#ifdef RETURN_LONG_FONTCONFIG_NAMES - result = eimake_string(eistr_fullname); -#else - result = eimake_string(eistr_longname); -#endif - } - else - { - DECLARE_DEBUG_FONTNAME (name); - DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", - eidata(name), lang); - result = Qnil; - } - } - else - { - ASSERT_ASCTEXT_ASCII(FcResultToString(r)); - DEBUG_XFT1 (0, "Getting lang: unexpected result=%s\n", - FcResultToString (r)); - result = Qnil; - } - } - - /* clean up and maybe return */ - FcPatternDestroy (fontxft); - if (!UNBOUNDP (result)) - return result; - } - - DEBUG_XFT1 (0, "shit happens, try X11 charset match for %s\n", - XSTRING_DATA(font)); -#undef DECLARE_DEBUG_FONTNAME -#endif /* USE_XFT */ - - 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); - if (x_font_spec_matches_charset (XDEVICE (device), charset, - intname, Qnil, 0, -1, 0)) - { - result = build_ext_string ((const Extbyte *) intname, - Qx_font_name_encoding); - break; - } - } - - if (names) - XFreeFontNames (names); - - /* Check for a short font name. */ - if (NILP (result) - && x_font_spec_matches_charset (XDEVICE (device), charset, 0, - font, 0, -1, 0)) - return font; - - return result; -} - -#endif /* MULE */ +/* Include the charset support, shared, for the moment, with GTK. */ +#define THIS_IS_X +#include "objects-xlike-inc.c" /************************************************************************/ @@ -1512,6 +934,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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/objects-xlike-inc.c Sun Nov 05 22:31:46 2006 +0000 @@ -0,0 +1,776 @@ +/* Shared object code between X and GTK -- include file. + Copyright (C) 1991-5, 1997 Free Software Foundation, Inc. + Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 1996, 2001, 2002, 2003 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Pango is ready for prime-time now, as far as I understand it. The GTK + people should be using that. Oh well. (Aidan Kehoe, Sat Nov 4 12:41:12 + CET 2006) */ + +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901) + +#ifdef DEBUG_XEMACS +# define DEBUG_OBJECTS(FORMAT, ...) \ + do { if (debug_x_objects) stderr_out(FORMAT, __VA_ARGS__); } while (0) +#else /* DEBUG_XEMACS */ +# define DEBUG_OBJECTS(format, ...) +#endif /* DEBUG_XEMACS */ + +#elif defined(__GNUC__) + +#ifdef DEBUG_XEMACS +# define DEBUG_OBJECTS(format, args...) \ + do { if (debug_x_objects) stderr_out(format, args ); } while (0) +#else /* DEBUG_XEMACS */ +# define DEBUG_OBJECTS(format, args...) +#endif /* DEBUG_XEMACS */ + +#else /* defined(__STDC_VERSION__) [...] */ +# define DEBUG_OBJECTS (void) +#endif + +#ifdef MULE + +/* For some code it's reasonable to have only one copy and conditionalize + at run-time. For other code it isn't. */ + +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 +#ifdef THIS_IS_GTK +gtk_font_spec_matches_charset (struct device * USED_IF_XFT (d), + Lisp_Object charset, + const Ibyte *nonreloc, Lisp_Object reloc, + Bytecount offset, Bytecount length, + enum font_specifier_matchspec_stages stage) +#else +x_font_spec_matches_charset (struct device * USED_IF_XFT (d), + Lisp_Object charset, + const Ibyte *nonreloc, Lisp_Object reloc, + Bytecount offset, Bytecount length, + enum font_specifier_matchspec_stages stage) +#endif +{ + Lisp_Object registries = Qnil; + 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; + +#ifdef USE_XFT + if (stage) + { + Display *dpy = DEVICE_X_DISPLAY (d); + Extbyte *extname; + XftFont *rf; + const Ibyte *the_nonreloc; + + if (!NILP(reloc)) + { + the_nonreloc = XSTRING_DATA (reloc); + 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? */ + } + } +#endif + + /* Hmm, this smells bad. */ + 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 + long form; sorry buster. + #### FMH: this screws fontconfig/Xft? + STRATEGY: use fontconfig's ability to hack languages and character + sets (lang and charset properties). + #### Maybe we can use the fontconfig model to eliminate the difference + 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) && + (!memchr (the_nonreloc, '*', the_length)) + && (5 > (count_hyphens(the_nonreloc, the_length, NULL)))) + { + return 1; + } + + if (final == stage) + { + registries = Qunicode_registries; + } + else if (initial == stage) + { + registries = XCHARSET_REGISTRIES (charset); + if (NILP(registries)) + { + return 0; + } + } + else assert(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; +} + +static Lisp_Object +xlistfonts_checking_charset (Lisp_Object device, const Extbyte *xlfd, + Lisp_Object charset, + enum font_specifier_matchspec_stages stage) +{ + Extbyte **names; + Lisp_Object result = Qnil; + int count = 0, i; + DECLARE_EISTRING(ei_single_result); + + names = XListFonts ( +#ifdef THIS_IS_GTK + GDK_DISPLAY (), +#else + DEVICE_X_DISPLAY (XDEVICE (device)), +#endif + 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 (DEVMETH_OR_GIVEN(XDEVICE (device), font_spec_matches_charset, + (XDEVICE (device), charset, + eidata(ei_single_result), Qnil, 0, + -1, stage), 0)) + { + result = eimake_string(ei_single_result); + DEBUG_OBJECTS ("in xlistfonts_checking_charset, returning %s\n", + eidata(ei_single_result)); + break; + } + } + + if (names) + { + XFreeFontNames (names); + } + + return result; +} + +#ifdef USE_XFT +/* #### debug functions: find a better place for us */ +const char *FcResultToString (FcResult r); +const char * +FcResultToString (FcResult r) +{ + static char buffer[256]; + switch (r) + { + case FcResultMatch: + return "FcResultMatch"; + case FcResultNoMatch: + return "FcResultNoMatch"; + case FcResultTypeMismatch: + return "FcResultTypeMismatch"; + case FcResultNoId: + return "FcResultNoId"; + default: + snprintf (buffer, 255, "FcResultUndocumentedValue (%d)", r); + return buffer; + } +} + +const char *FcTypeOfValueToString (FcValue v); +const char * +FcTypeOfValueToString (FcValue v) +{ + static char buffer[256]; + switch (v.type) + { + case FcTypeMatrix: + return "FcTypeMatrix"; + case FcTypeString: + return "FcTypeString"; + case FcTypeVoid: + return "FcTypeVoid"; + case FcTypeDouble: + return "FcTypeDouble"; + case FcTypeInteger: + return "FcTypeInteger"; + case FcTypeBool: + return "FcTypeBool"; + case FcTypeCharSet: + return "FcTypeCharSet"; + case FcTypeLangSet: + return "FcTypeLangSet"; + /* #### There is no union member of this type, but there are void* and + FcPattern* members, as of fontconfig.h FC_VERSION 10002 */ + case FcTypeFTFace: + return "FcTypeFTFace"; + default: + snprintf (buffer, 255, "FcTypeUndocumentedType (%d)", v.type); + return buffer; + } +} + +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; +} + +struct charset_reporter { + Lisp_Object *charset; + /* This is a debug facility, require ASCII. */ + Extbyte *language; /* ASCII, please */ + /* Technically this is FcChar8, but fsckin' GCC 4 bitches. */ + Extbyte *rfc3066; /* ASCII, please */ +}; + +static struct charset_reporter charset_table[] = + { + /* #### It's my branch, my favorite charsets get checked first! + That's a joke, Son. + Ie, I don't know what I'm doing, so my charsets first is as good as + any other arbitrary order. If you have a better idea, speak up! */ + { &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", "el" }, + /* #### all the Chinese need checking + Damn the blood-sucking ISO anyway. */ + { &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, "Hebrew", "he" }, + { &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 } + }; + +/* Choose appropriate font name for debug messages. + Use only in the top half of next function (enforced with #undef). */ +#define DECLARE_DEBUG_FONTNAME(__xemacs_name) \ + Eistring *__xemacs_name; \ + do \ + { \ + __xemacs_name = debug_xft > 2 ? eistr_fullname \ + : debug_xft > 1 ? eistr_longname \ + : eistr_shortname; \ + } while (0) + +static Lisp_Object +xft_find_charset_font (Lisp_Object font, Lisp_Object charset, + enum font_specifier_matchspec_stages stage) +{ + const Extbyte *patternext; + Lisp_Object result = Qnil; + + /* #### with Xft need to handle second stage here -- sjt + Hm. Or maybe not. That would be cool. :-) */ + if (stage) + return Qnil; + + /* 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. */ + + DEBUG_XFT1 (1, "confirming charset for font instance %s\n", + XSTRING_DATA(font)); + + /* #### this looks like a fair amount of work, but the basic design + has never been rethought, and it should be + + what really should happen here is that we use FcFontSort (FcFontList?) + to get a list of matching fonts, then pick the first (best) one that + gives language or repertoire coverage. + */ + + FcInit (); /* No-op if already initialized. + In fontconfig 2.3.2, this cannot return + failure, but that looks like a bug. We + check for it with FcGetCurrentConfig(), + which *can* fail. */ + if (!FcConfigGetCurrent()) /* #### We should expose FcInit* interfaces + to LISP and decide when to reinitialize + intelligently. */ + stderr_out ("Failed fontconfig initialization\n"); + else + { + FcPattern *fontxft; /* long-lived, freed at end of this block */ + FcResult fcresult; + FcConfig *fcc; + FcChar8 *lang = (FcChar8 *) "en"; /* #### fix this bogus hack! */ + FcCharSet *fccs = NULL; + DECLARE_EISTRING (eistr_shortname); /* user-friendly nickname */ + DECLARE_EISTRING (eistr_longname); /* omit FC_LANG and FC_CHARSET */ + DECLARE_EISTRING (eistr_fullname); /* everything */ + + LISP_STRING_TO_EXTERNAL (font, patternext, Qfc_font_name_encoding); + fcc = FcConfigGetCurrent (); + + /* parse the name, do the substitutions, and match the font */ + + { + FcPattern *p = FcNameParse ((FcChar8 *) patternext); + PRINT_XFT_PATTERN (3, "FcNameParse'ed name is %s\n", p); + /* #### Next two return FcBool, but what does the return mean? */ + /* The order is correct according the fontconfig docs. */ + FcConfigSubstitute (fcc, p, FcMatchPattern); + PRINT_XFT_PATTERN (2, "FcConfigSubstitute'ed name is %s\n", p); + FcDefaultSubstitute (p); + PRINT_XFT_PATTERN (3, "FcDefaultSubstitute'ed name is %s\n", p); + /* #### check fcresult of following match? */ + fontxft = FcFontMatch (fcc, p, &fcresult); + /* this prints the long fontconfig name */ + PRINT_XFT_PATTERN (1, "FcFontMatch'ed name is %s\n", fontxft); + FcPatternDestroy (p); + } + + /* heuristic to give reasonable-length names for debug reports + + I considered #ifdef SUPPORT_FULL_FONTCONFIG_NAME etc but that's + pointless. We're just going to remove this code once the font/ + face refactoring is done, but until then it could be very useful. + */ + { + FcPattern *p = FcFontRenderPrepare (fcc, fontxft, fontxft); + FcChar8 *name; + + /* full name, including language coverage and repertoire */ + name = FcNameUnparse (p); + eicpy_ext (eistr_fullname, (Extbyte *) name, Qfc_font_name_encoding); + free (name); + + /* long name, omitting coverage and repertoire, plus a number + of rarely useful properties */ + FcPatternDel (p, FC_CHARSET); + FcPatternDel (p, FC_LANG); + FcPatternDel (p, FC_WIDTH); + FcPatternDel (p, FC_SPACING); + FcPatternDel (p, FC_HINTING); + FcPatternDel (p, FC_VERTICAL_LAYOUT); + FcPatternDel (p, FC_AUTOHINT); + FcPatternDel (p, FC_GLOBAL_ADVANCE); + FcPatternDel (p, FC_INDEX); + FcPatternDel (p, FC_SCALE); + FcPatternDel (p, FC_FONTVERSION); + name = FcNameUnparse (p); + eicpy_ext (eistr_longname, (Extbyte *) name, Qfc_font_name_encoding); + free (name); + + /* nickname, just family and size, but + "family" names usually have style, slant, and weight */ + FcPatternDel (p, FC_FOUNDRY); + FcPatternDel (p, FC_STYLE); + FcPatternDel (p, FC_SLANT); + FcPatternDel (p, FC_WEIGHT); + FcPatternDel (p, FC_PIXEL_SIZE); + FcPatternDel (p, FC_OUTLINE); + FcPatternDel (p, FC_SCALABLE); + FcPatternDel (p, FC_DPI); + name = FcNameUnparse (p); + eicpy_ext (eistr_shortname, (Extbyte *) name, Qfc_font_name_encoding); + free (name); + + 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. */ + + { + /* This block possibly should be a function, but it generates + multiple values. I find the "pass an address to return the + value in" idiom opaque, so prefer a block. */ + struct charset_reporter *cr; + for (cr = charset_table; + cr->charset && !EQ (*(cr->charset), charset); + cr++) + ; + + if (cr->rfc3066) + { + DECLARE_DEBUG_FONTNAME (name); + CHECKING_LANG (0, eidata(name), cr->language); + lang = (FcChar8 *) cr->rfc3066; + } + else if (cr->charset) + { + /* what the hey, build 'em on the fly */ + /* #### in the case of error this could return NULL! */ + fccs = mule_to_fc_charset (charset); + lang = (FcChar8 *) XSTRING_DATA (XSYMBOL + (XCHARSET_NAME (charset))-> name); + } + else + { + /* OK, we fell off the end of the table */ + warn_when_safe_lispobj (intern ("xft"), intern ("alert"), + list2 (build_string ("unchecked charset"), + charset)); + /* default to "en" + #### THIS IS WRONG, WRONG, WRONG!! + It is why we never fall through to XLFD-checking. */ + } + + ASSERT_ASCTEXT_ASCII((Extbyte *) lang); + + if (fccs) + { + /* check for character set coverage */ + int i = 0; + FcCharSet *v; + FcResult r = FcPatternGetCharSet (fontxft, FC_CHARSET, i, &v); + + if (r == FcResultTypeMismatch) + { + DEBUG_XFT0 (0, "Unexpected type return in charset value\n"); + result = Qnil; + } + else if (r == FcResultMatch && FcCharSetIsSubset (fccs, v)) + { + /* The full pattern with the bitmap coverage is massively + 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? */ + DECLARE_DEBUG_FONTNAME (name); + DEBUG_XFT2 (0, "Xft font %s supports %s\n", + eidata(name), lang); +#ifdef RETURN_LONG_FONTCONFIG_NAMES + result = eimake_string(eistr_fullname); +#else + result = eimake_string(eistr_longname); +#endif + } + else + { + DECLARE_DEBUG_FONTNAME (name); + DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", + eidata(name), lang); + result = Qnil; + } + + /* clean up */ + FcCharSetDestroy (fccs); + } + else + { + /* check for language coverage */ + int i = 0; + FcValue v; + /* the main event */ + FcResult r = FcPatternGet (fontxft, FC_LANG, i, &v); + + if (r == FcResultMatch) + { + if (v.type != FcTypeLangSet) /* excessive paranoia */ + { + ASSERT_ASCTEXT_ASCII(FcTypeOfValueToString(v)); + /* Urk! Fall back and punt to core font. */ + DEBUG_XFT1 (0, "Unexpected type of lang value (%s)\n", + FcTypeOfValueToString (v)); + result = Qnil; + } + else if (FcLangSetHasLang (v.u.l, lang) != FcLangDifferentLang) + { + DECLARE_DEBUG_FONTNAME (name); + DEBUG_XFT2 (0, "Xft font %s supports %s\n", + eidata(name), lang); +#ifdef RETURN_LONG_FONTCONFIG_NAMES + result = eimake_string(eistr_fullname); +#else + result = eimake_string(eistr_longname); +#endif + } + else + { + DECLARE_DEBUG_FONTNAME (name); + DEBUG_XFT2 (0, "Xft font %s doesn't support %s\n", + eidata(name), lang); + result = Qnil; + } + } + else + { + ASSERT_ASCTEXT_ASCII(FcResultToString(r)); + DEBUG_XFT1 (0, "Getting lang: unexpected result=%s\n", + FcResultToString (r)); + result = Qnil; + } + } + + /* clean up and maybe return */ + FcPatternDestroy (fontxft); + if (!UNBOUNDP (result)) + return result; + } + } + return Qnil; +} +#undef DECLARE_DEBUG_FONTNAME + +#endif /* USE_XFT */ + +/* find a font spec that matches font spec FONT and also matches + (the registry of) CHARSET. */ +static Lisp_Object +#ifdef THIS_IS_GTK +gtk_find_charset_font (Lisp_Object device, Lisp_Object font, + Lisp_Object charset, + enum font_specifier_matchspec_stages stage) +#else +x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, + enum font_specifier_matchspec_stages stage) +#endif +{ + Lisp_Object result = Qnil, registries = 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 + result = xft_find_charset_font(font, charset, stage); + if (!NILP(result)) + { + return result; + } +#endif + + switch (stage) + { + case initial: + { + if (!(NILP(XCHARSET_REGISTRIES(charset))) + && VECTORP(XCHARSET_REGISTRIES(charset))) + { + registries_len = XVECTOR_LENGTH(XCHARSET_REGISTRIES(charset)); + registries = XCHARSET_REGISTRIES(charset); + } + break; + } + case final: + { + registries_len = 1; + registries = Qunicode_registries; + break; + } + default: + { + assert(0); + break; + } + } + + eicpy_lstr(ei_xlfd, font); + hyphening = eidata(ei_xlfd); + xlfd_length = eilen(ei_xlfd); + + /* Count the hyphens in the string, moving new_hyphening 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, stage); + /* 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; + + 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(registries)[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, stage); + } + + /* 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; +} + +#endif /* MULE */
--- a/src/objects.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects.c Sun Nov 05 22:31:46 2006 +0000 @@ -323,8 +323,11 @@ write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); if (!NILP (f->device)) - MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, - (f, printcharfun, escapeflag)); + { + MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, + (f, printcharfun, escapeflag)); + + } write_fmt_string (printcharfun, " 0x%x>", f->header.uid); } @@ -776,7 +779,7 @@ font_spec_matches_charset (struct device *d, Lisp_Object charset, const Ibyte *nonreloc, Lisp_Object reloc, Bytecount offset, Bytecount length, - int stage) + enum font_specifier_matchspec_stages stage) { return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, (d, charset, nonreloc, reloc, offset, length, @@ -789,6 +792,21 @@ { CHECK_CONS (matchspec); Fget_charset (XCAR (matchspec)); + + do + { + if (EQ(XCDR(matchspec), Qinitial)) + { + break; + } + if (EQ(XCDR(matchspec), Qfinal)) + { + break; + } + + invalid_argument("Invalid font matchspec stage", + XCDR(matchspec)); + } while (0); } void @@ -836,12 +854,23 @@ Lisp_Object instance; Lisp_Object charset = Qnil; #ifdef MULE - int stage = 0; + enum font_specifier_matchspec_stages stage = initial; if (!UNBOUNDP (matchspec)) { charset = Fget_charset (XCAR (matchspec)); - stage = NILP (XCDR (matchspec)) ? 0 : 1; + +#define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ + { \ + stage = new_stage; \ + } + + FROB(initial) + else FROB(final) + else assert(0); + +#undef FROB + } #endif @@ -864,6 +893,7 @@ if (STRINGP (instantiator)) { #ifdef MULE + /* #### rename these caches. */ Lisp_Object cache = stage ? d->charset_font_cache_stage_2 : d->charset_font_cache_stage_1; #else @@ -921,10 +951,22 @@ } else if (VECTORP (instantiator)) { + Lisp_Object match_inst = Qunbound; assert (XVECTOR_LENGTH (instantiator) == 1); - return (face_property_matching_instance - (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, - charset, domain, ERROR_ME, 0, depth)); + + match_inst = face_property_matching_instance + (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, + charset, domain, ERROR_ME, 0, depth, initial); + + if (UNBOUNDP(match_inst)) + { + match_inst = face_property_matching_instance + (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, + charset, domain, ERROR_ME, 0, depth, final); + } + + return match_inst; + } else if (NILP (instantiator)) return Qunbound;
--- a/src/objects.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/objects.h Sun Nov 05 22:31:46 2006 +0000 @@ -76,4 +76,8 @@ void set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property); +/* Defined in search.c, used in mule-charset.c; slightly ugly to declare it + here, but oh well. */ +EXFUN (Fregexp_quote, 1); + #endif /* INCLUDED_objects_h_ */
--- a/src/redisplay-x.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/redisplay-x.c Sun Nov 05 22:31:46 2006 +0000 @@ -41,9 +41,8 @@ #include "sysdep.h" #include "window.h" -#ifdef MULE #include "mule-ccl.h" -#endif +#include "charset.h" #include "console-x-impl.h" #include "glyphs-x.h" @@ -154,138 +153,148 @@ static int separate_textual_runs (unsigned char *text_storage, struct textual_run *run_storage, - const Ichar *str, Charcount len) + const Ichar *str, Charcount len, + struct face_cachel *cachel) { Lisp_Object prev_charset = Qunbound; /* not Qnil because that is a possible valid charset when MULE is not defined */ - int runs_so_far = 0; - int i; -#ifdef MULE + int runs_so_far = 0, i; + Ibyte charset_leading_byte = LEADING_BYTE_ASCII; + int dimension = 1, graphic = 0, need_ccl_conversion = 0; + Lisp_Object ccl_prog; struct ccl_program char_converter; - int need_ccl_conversion = 0; -#endif + +#ifdef USE_XFT +#define translate_to_ucs_2 1 /* Translate to UTF-16 unconditionally. */ +#define MAYBE_ASSIGN_TRANSLATE_TO_UCS_2(arg) (void)(arg) /* Empty, + may avoid some + warnings. */ +#else /* USE_XFT */ +#ifndef MULE +#define translate_to_ucs_2 0 /* We don't support falling back to + iso10646-1 without MULE */ +#define MAYBE_ASSIGN_TRANSLATE_TO_UCS_2(arg) (void)(arg) +#else /* if MULE */ + int translate_to_ucs_2 = 0; +#define MAYBE_ASSIGN_TRANSLATE_TO_UCS_2(arg) translate_to_ucs_2 = (arg) +#endif /* MULE */ +#endif /* !USE_XFT */ for (i = 0; i < len; i++) { Ichar ch = str[i]; Lisp_Object charset; - int byte1, byte2; /* #### why aren't these UExtbytes? */ - int dimension; - int graphic; - + int byte1, byte2; /* Not UExbytes because BREAKUP_ICHAR takes + the addresses of its arguments and + dereferences those addresses as integer + pointers. */ BREAKUP_ICHAR (ch, charset, byte1, byte2); - dimension = XCHARSET_DIMENSION (charset); - graphic = XCHARSET_GRAPHIC (charset); if (!EQ (charset, prev_charset)) { run_storage[runs_so_far].ptr = text_storage; run_storage[runs_so_far].charset = charset; -#ifdef USE_XFT - run_storage[runs_so_far].dimension = 2; -#else - run_storage[runs_so_far].dimension = dimension; -#endif if (runs_so_far) { run_storage[runs_so_far - 1].len = text_storage - run_storage[runs_so_far - 1].ptr; - if (run_storage[runs_so_far - 1].dimension == 2) - run_storage[runs_so_far - 1].len >>= 1; + /* Checks the value for dimension from the previous run. */ + if (2 == dimension) run_storage[runs_so_far - 1].len >>= 1; } - runs_so_far++; - prev_charset = charset; + + charset_leading_byte = XCHARSET_LEADING_BYTE(charset); + + MAYBE_ASSIGN_TRANSLATE_TO_UCS_2 + (bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE + (cachel), + charset_leading_byte - MIN_LEADING_BYTE)); + + if (translate_to_ucs_2) + { + dimension = 2; + run_storage[runs_so_far].dimension = 2; + } + else + { + dimension = XCHARSET_DIMENSION (charset); + run_storage[runs_so_far].dimension = dimension; #ifdef MULE - { - Lisp_Object ccl_prog = XCHARSET_CCL_PROGRAM (charset); - if ((!NILP (ccl_prog)) + ccl_prog = XCHARSET_CCL_PROGRAM (charset); + if ((!NILP (ccl_prog)) && (setup_ccl_program (&char_converter, ccl_prog) >= 0)) - need_ccl_conversion = 1; - } -#endif - } + { + need_ccl_conversion = 1; + } + else + { + /* The graphic property is only relevant if we're neither + doing the CCL conversion nor doing the UTF-16 + conversion; it's irrelevant otherwise. */ + graphic = XCHARSET_GRAPHIC (charset); + need_ccl_conversion = 0; + } +#endif /* MULE */ + } + prev_charset = charset; -#ifndef USE_XFT - if (graphic == 0) + runs_so_far++; + } + + if (translate_to_ucs_2) { - byte1 &= 0x7F; - byte2 &= 0x7F; - } - else if (graphic == 1) - { - byte1 |= 0x80; - byte2 |= 0x80; + UINT_16_BIT ucs2; + int ucs = ichar_to_unicode(ch); + + /* If UCS is less than zero or greater than 0xFFFF, set ucs2 to + REPLACMENT CHARACTER. */ + ucs2 = (ucs & ~0xFFFF) ? 0xFFFD : ucs; + + /* Ignoring the "graphic" handling. */ +#ifdef USE_XFT + byte1 = ((unsigned char *) (&ucs2))[0]; + byte2 = ((unsigned char *) (&ucs2))[1]; +#else + byte1 = ((unsigned char *) (&ucs2))[1]; + byte2 = ((unsigned char *) (&ucs2))[0]; +#endif /* USE_XFT */ } #ifdef MULE - if (need_ccl_conversion) + else if (need_ccl_conversion) { - char_converter.reg[0] = XCHARSET_ID (charset); + char_converter.reg[0] = charset_leading_byte; char_converter.reg[1] = byte1; char_converter.reg[2] = byte2; ccl_driver (&char_converter, 0, 0, 0, 0, CCL_MODE_ENCODING); byte1 = char_converter.reg[1]; byte2 = char_converter.reg[2]; } + else if (graphic == 0) + { + byte1 &= 0x7F; + byte2 &= 0x7F; + } + else + { + byte1 |= 0x80; + byte2 |= 0x80; + } #endif /* MULE */ - *text_storage++ = (unsigned char) byte1; - /* This dimension stuff is broken if you want to use a two-dimensional - X11 font to display a single-dimensional character set, as is - appropriate for the IPA (use one of the -iso10646-1 fonts) or some - of the other non-standard character sets. */ - if (dimension == 2) - *text_storage++ = (unsigned char) byte2; -#else /* USE_XFT */ - /* #### This is bogus as hell. XftChar16, aka FcChar16, is actually - unsigned short, and therefore is not suitable for indexing matrix - fonts such as the JIS fonts supplied with X11. But if this were - consistent, the XftDraw*8 and XftDraw*16 functions are pretty - incoherent, as then we not should allow anything but ISO 8859/1 - (ie, the first 256 code points of Unicode) in XftDraw*8. So it - looks like this depends on the font, not the charset. */ - { - XftChar16 xftchar16 = 0xFFFD; /* unsigned short */ -#ifndef MULE - int unicode = ch; -#else - int unicode = ichar_to_unicode (ch); - if (unicode < 0) - /* abort(); */ /* #### serious error, tables are corrupt - Unfortunately, not a valid assumption; this can happen with - composite characters. Fake it. */ - unicode = 0xFFFD; /* REPLACEMENT CHARACTER, can't represent */ - else if (need_ccl_conversion) - /* #### maybe we should just ignore this and hope the font wins? */ - unicode = 0xFFFD; /* REPLACEMENT CHARACTER, can't represent */ - else if (unicode > 65535) - unicode = 0xFFFD; /* REPLACEMENT CHARACTER, can't represent */ - else -#endif - xftchar16 = (XftChar16) unicode; - /* #### endianness dependency? No, - apparently xft handles endianness for us; - the "big-endian" code works on Intel and PPC */ -#if 1 - /* big-endian or auto-endian */ - byte1 = ((unsigned char *) (&xftchar16))[0]; - byte2 = ((unsigned char *) (&xftchar16))[1]; -#else - /* little-endian */ - byte1 = ((unsigned char *) (&xftchar16))[1]; - byte2 = ((unsigned char *) (&xftchar16))[0]; -#endif - } - *text_storage++ = (unsigned char) byte1; - *text_storage++ = (unsigned char) byte2; -#endif /* USE_XFT */ + + *text_storage++ = (unsigned char)byte1; + + /* dimension can be two in non-Mule if we're translating to + Unicode. */ + if (2 == dimension) *text_storage++ = (unsigned char)byte2; } if (runs_so_far) { run_storage[runs_so_far - 1].len = text_storage - run_storage[runs_so_far - 1].ptr; - if (run_storage[runs_so_far - 1].dimension == 2) + /* Dimension retains the relevant value for the run before it. */ + if (2 == dimension) run_storage[runs_so_far - 1].len >>= 1; } @@ -361,7 +370,8 @@ int nruns; int i; - nruns = separate_textual_runs (text_storage, runs, str, len); + nruns = separate_textual_runs (text_storage, runs, str, len, + cachel); for (i = 0; i < nruns; i++) width_so_far += x_text_width_single_run (f, cachel, runs + i); @@ -1014,7 +1024,7 @@ } nruns = separate_textual_runs (text_storage, runs, Dynarr_atp (buf, 0), - Dynarr_length (buf)); + Dynarr_length (buf), cachel); for (i = 0; i < nruns; i++) {
--- a/src/redisplay.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/redisplay.c Sun Nov 05 22:31:46 2006 +0000 @@ -760,7 +760,7 @@ static int space_width (struct window *w) { - /* While tabs are traditional composed of spaces, for variable-width + /* While tabs are traditionally composed of spaces, for variable-width fonts the space character tends to give too narrow a value. So we use 'n' instead. Except that we don't. We use the default character width for the default face. If this is actually
--- a/src/specifier.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/specifier.c Sun Nov 05 22:31:46 2006 +0000 @@ -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 @@ -428,9 +429,9 @@ }; static const struct memory_description specifier_empty_extra_description_1[] = -{ - { XD_END } -}; + { + { XD_END } + }; const struct sized_memory_description specifier_empty_extra_description = { 0, specifier_empty_extra_description_1 @@ -471,7 +472,7 @@ } maybe_invalid_argument ("Invalid specifier type", - type, Qspecifier, errb); + type, Qspecifier, errb); return 0; } @@ -683,7 +684,7 @@ instantiation will actually occur in the window the image instance itself is instantiated in. */ - (domain)) + (domain)) { /* This cannot GC. */ return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) || @@ -694,14 +695,14 @@ ? Qt : Qnil; } -DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, - /* +DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, + 1, 0, /* Given a specifier LOCALE-TYPE, return non-nil if it is valid. Valid locale types are `global', `device', `frame', `window', and `buffer'. \(Note, however, that in functions that accept either a locale or a locale type, `global' is considered an individual locale.) */ - (locale_type)) + (locale_type)) { /* This cannot GC. */ return (EQ (locale_type, Qglobal) || @@ -731,7 +732,7 @@ /* This cannot GC. */ if (NILP (Fvalid_specifier_locale_p (locale))) invalid_argument ("Invalid specifier locale", - locale); + locale); if (DEVICEP (locale)) return Qdevice; if (FRAMEP (locale)) return Qframe; if (WINDOWP (locale)) return Qwindow; @@ -750,7 +751,7 @@ return locale; else invalid_argument ("Invalid specifier locale", - locale); + locale); return Qnil; } @@ -766,7 +767,7 @@ if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER; invalid_argument ("Invalid specifier locale type", - locale_type); + locale_type); RETURN_NOT_REACHED (LOCALE_GLOBAL); } @@ -803,7 +804,7 @@ { if (NILP (Fvalid_specifier_domain_p (domain))) invalid_argument ("Invalid specifier domain", - domain); + domain); } Lisp_Object @@ -834,10 +835,10 @@ DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /* Return non-nil if TAG-SET is a valid specifier tag set. -A specifier tag set is an entity that is attached to an instantiator -and can be used to restrict the scope of that instantiator to a -particular device class or device type and/or to mark instantiators -added by a particular package so that they can be later removed. +A specifier tag set is an entity that is attached to an instantiator and can +be used to restrict the scope of that instantiator to a particular device +class, device type, or charset. It can also be used to mark instantiators +added by a particular package so that they can be later removed as a group. A specifier tag set consists of a list of zero of more specifier tags, each of which is a symbol that is recognized by XEmacs as a tag. @@ -846,18 +847,25 @@ \(as opposed to a list) because the order of the tags or the number of times a particular tag occurs does not matter. -Each tag has a predicate associated with it, which specifies whether -that tag applies to a particular device. The tags which are device types -and classes match devices of that type or class. User-defined tags can -have any predicate, or none (meaning that all devices match). When -attempting to instantiate a specifier, a particular instantiator is only -considered if the device of the domain being instantiated over matches -all tags in the tag set attached to that instantiator. +Each tag has two predicates associated with it, which specify, respectively, +whether that tag applies to a particular device and whether it applies to a +particular character set. The predefined tags which are device types and +classes match devices of that type or class. User-defined tags can have any +device predicate, or none (meaning that all devices match). When attempting +to instantiate a specifier, a particular instantiator is only considered if +the device of the domain being instantiated over matches all tags in the tag +set attached to that instantiator. + +If a charset is to be considered--which is only the case for face +instantiators--this consideration may be done twice. The first iteration +pays attention to the character set predicates; if no instantiator can be +found in that case, the search is repeated ignoring the character set +predicates. Most of the time, a tag set is not specified, and the instantiator gets a null tag set, which matches all devices. */ - (tag_set)) + (tag_set)) { Lisp_Object rest; @@ -880,7 +888,7 @@ return list1 (tag_set); if (NILP (Fvalid_specifier_tag_set_p (tag_set))) invalid_argument ("Invalid specifier tag-set", - tag_set); + tag_set); return tag_set; } @@ -973,6 +981,63 @@ return 1; } +static int +charset_matches_specifier_tag_set_p (Lisp_Object charset, + Lisp_Object tag_set, + enum font_specifier_matchspec_stages + stage) +{ + Lisp_Object rest; + int res = 0; + + assert(stage != impossible); + + LIST_LOOP (rest, tag_set) + { + Lisp_Object tag = XCAR (rest); + Lisp_Object assoc; + + /* This function will not ever be called with a charset for which the + relevant information hasn't been calculated (the information is + calculated with the creation of every charset). */ + assert (!NILP(XVECTOR_DATA + (Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) + - MIN_LEADING_BYTE])); + + /* Now, find out what the pre-calculated value is. */ + assoc = assq_no_quit(tag, + XVECTOR_DATA(Vcharset_tag_lists) + [XCHARSET_LEADING_BYTE(charset) + - MIN_LEADING_BYTE]); + + if (!(NILP(assoc)) && !(NILP(XCDR(assoc)))) + { + assert(VECTORP(XCDR(assoc))); + + /* In the event that a tag specifies a charset, then the specifier + must match for (this stage and this charset) for all + charset-specifying tags. */ + if (NILP(XVECTOR_DATA(XCDR(assoc))[stage])) + { + /* It doesn't match for this tag, even though the tag + specifies a charset. Return 0. */ + return 0; + } + + /* This tag specifies charset limitations, and this charset and + stage match those charset limitations. + + In the event that a later tag specifies charset limitations + that don't match, the return 0 above prevents us giving a + positive match. */ + res = 1; + } + } + + return res; +} + + 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,56 +1055,71 @@ return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil; } -DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 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. - -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)) +Lisp_Object +define_specifier_tag(Lisp_Object tag, Lisp_Object device_predicate, + Lisp_Object charset_predicate) { - Lisp_Object assoc, devcons, concons; - int recompute = 0; - - CHECK_SYMBOL (tag); - if (valid_device_class_p (tag) || - valid_console_type_p (tag)) - invalid_change ("Cannot redefine built-in specifier tags", tag); - /* Try to prevent common instantiators and locales from being - redefined, to reduce ambiguity */ - if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) - invalid_change ("Cannot define nil, t, `all', or `global'", tag); - assoc = assq_no_quit (tag, Vuser_defined_tags); + Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags), + concons, devcons, charpres = Qnil; + int recompute_devices = 0, recompute_charsets = 0, i, max_args = -1; + 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)); } + + if (!NILP (charset_predicate)) + { + max_args = XINT(Ffunction_max_args(charset_predicate)); + if (max_args < 1) + { + invalid_argument + ("Charset predicate must be able to take an argument", tag); + } + } } - else if (!NILP (predicate) && !NILP (XCDR (assoc))) + else if (!NILP (device_predicate) && !NILP (XCADR (assoc))) { - recompute = 1; - XCDR (assoc) = predicate; + recompute_devices = 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.) */ - - if (recompute) + else if (!NILP (charset_predicate) || !NILP(XCADDR (assoc))) + { + max_args = XINT(Ffunction_max_args(charset_predicate)); + if (max_args < 1) + { + invalid_argument + ("Charset predicate must be able to take an argument", tag); + } + + /* 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 contrasts 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 and charsets, if necessary. In + the special case where both the old and new device_predicates are nil, + we know that we don't have to do it for the device. (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_devices) { DEVICE_LOOP_NO_BREAK (devcons, concons) { @@ -1047,14 +1127,157 @@ 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 (predicate, device)) ? Qt : Qnil; + XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt + : Qnil; } } - return 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)) + { + static int line_1147_calls; + ++line_1147_calls; + charpres = make_vector(impossible, Qnil); + + /* If you want to extend the number of stages available, here + in setup_charset_initial_specifier_tags, and in specifier.h + is where you want to go. */ + +#define DEFINE_SPECIFIER_TAG_FROB(stage) do { \ + if (max_args > 1) \ + { \ + XVECTOR_DATA(charpres)[stage] = \ + call2_trapping_problems \ + ("Error during specifier tag charset predicate," \ + " stage " #stage, charset_predicate, \ + charset_by_leading_byte(MIN_LEADING_BYTE + i), \ + Q##stage, 0); \ + } \ + else \ + { \ + XVECTOR_DATA(charpres)[stage] = \ + call1_trapping_problems \ + ("Error during specifier tag charset predicate," \ + " stage " #stage, charset_predicate, \ + charset_by_leading_byte(MIN_LEADING_BYTE + i), \ + 0); \ + } \ + \ + if (UNBOUNDP(XVECTOR_DATA(charpres)[stage])) \ + { \ + XVECTOR_DATA(charpres)[stage] = Qnil; \ + } \ + else if (!NILP(XVECTOR_DATA(charpres)[stage])) \ + { \ + /* Don't want refs to random other objects. */ \ + XVECTOR_DATA(charpres)[stage] = Qt; \ + } \ + } while (0) + + DEFINE_SPECIFIER_TAG_FROB (initial); + DEFINE_SPECIFIER_TAG_FROB (final); + +#undef DEFINE_SPECIFIER_TAG_FROB + + } + + if (!NILP(assoc)) + { + assert(CONSP(assoc)); + XCDR (assoc) = charpres; + } + else + { + XVECTOR_DATA(Vcharset_tag_lists)[i] + = Fcons(Fcons(tag, charpres), + XVECTOR_DATA (Vcharset_tag_lists)[i]); + } + } + } + return Qt; +} + +DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* +Define a new specifier tag. + +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 a single +Lisp character set argument. A tag's charset predicate is primarily used to +determine what font to use for a given \(set of) charset\(s) when that tag +is used in a set-face-font call; a non-nil return value indicates that the +tag matches the charset. + +The font matching process also has a concept of stages; the defined stages +are currently `initial' and `final', and there exist specifier tags with +those names that correspond to those stages. On X11, 'initial is used when +the font matching process is looking for fonts that match the desired +registries of the charset--see the `charset-registries' function. If that +match process fails, then the 'final tag becomes relevant; this means that a +more general lookup is desired, and that a font doesn't necessarily have to +match the desired XLFD for the face, just the charset repertoire for this +charset. It also means that the charset registry and encoding used will be +`iso10646-1', and the characters will be converted to display using that +registry. + +If a tag set 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 most of the built-in specifier tags \(the device types and +classes, `initial', and `final') or the symbols nil, t, `all', or `global'. +Note that if a device type is not supported in this XEmacs, it will not be +available as a built-in specifier tag; this is probably something we should +change. +*/ + (tag, device_predicate, charset_predicate)) +{ + int max_args; + + CHECK_SYMBOL (tag); + if (valid_device_class_p (tag) || + valid_console_type_p (tag) || + EQ (tag, Qinitial) || EQ (tag, Qfinal)) + invalid_change ("Cannot redefine built-in specifier tags", tag); + /* Try to prevent common instantiators and locales from being + redefined, to reduce ambiguity */ + if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) + invalid_change ("Cannot define nil, t, `all', or `global'", tag); + + if (!NILP (charset_predicate)) + { + max_args = XINT(Ffunction_max_args(charset_predicate)); + if (max_args != 1) + { + /* We only allow the stage argument to be specifed from C. */ + invalid_change ("Charset predicate must take one argument", + tag); + } + } + + return define_specifier_tag(tag, device_predicate, charset_predicate); } /* Called at device-creation time to initialize the user-defined @@ -1065,6 +1288,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,21 +1300,89 @@ 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, new_value; + 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; + } + + new_value = make_vector(impossible, Qnil); + +#define SETUP_CHARSET_TAGS_FROB(stage) do { \ + \ + XVECTOR_DATA(new_value)[stage] = call2_trapping_problems \ + ("Error during specifier tag charset predicate," \ + " stage " #stage, \ + charset_predicate, charset, Q##stage, 0); \ + \ + if (UNBOUNDP(XVECTOR_DATA(new_value)[stage])) \ + { \ + XVECTOR_DATA(new_value)[stage] = Qnil; \ + } \ + else if (!NILP(XVECTOR_DATA(new_value)[stage])) \ + { \ + /* Don't want random other objects hanging around. */ \ + XVECTOR_DATA(new_value)[stage] = Qt; \ + } \ + \ + } while (0) + + SETUP_CHARSET_TAGS_FROB (initial); + SETUP_CHARSET_TAGS_FROB (final); + /* More later? */ + +#undef SETUP_CHARSET_TAGS_FROB + + charset_tag_list = Fcons(Fcons(tag, new_value), charset_tag_list); + } + + XVECTOR_DATA + (Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) - MIN_LEADING_BYTE] + = charset_tag_list; +} + +#ifdef DEBUG_XEMACS + +/* Nothing's calling this, I see no reason to keep it in the production + builds. */ + DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list, 0, 1, 0, /* -Return a list of all specifier tags matching DEVICE. -DEVICE defaults to the selected device if omitted. -*/ + Return a list of all specifier tags matching DEVICE. + DEVICE defaults to the selected device if omitted. + */ (device)) { struct device *d = decode_device (device); @@ -1100,7 +1393,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); } @@ -1111,6 +1404,8 @@ RETURN_UNGCPRO (list); } +#endif /* DEBUG_XEMACS */ + DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /* Return a list of all currently-defined specifier tags. This includes the built-in ones (the device types and classes). @@ -1132,8 +1427,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)) { @@ -1142,7 +1438,7 @@ if (NILP (Fvalid_specifier_tag_p (tag))) invalid_argument ("Invalid specifier tag", - tag); + tag); /* Make up some predicates for the built-in types */ @@ -1156,11 +1452,27 @@ 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. */ + Otherwise, A must be `equal' to B. The sets must be canonicalized. */ static int tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p) { @@ -1268,15 +1580,15 @@ if (!CONSP (inst_pair)) { maybe_sferror ( - "Invalid instantiator pair", inst_pair, - Qspecifier, errb); + "Invalid instantiator pair", inst_pair, + Qspecifier, errb); return Qnil; } if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair)))) { maybe_invalid_argument ( - "Invalid specifier tag", tag_set, - Qspecifier, errb); + "Invalid specifier tag", tag_set, + Qspecifier, errb); return Qnil; } @@ -1317,15 +1629,15 @@ if (!CONSP (spec)) { maybe_sferror ( - "Invalid specification list", spec_list, - Qspecifier, errb); + "Invalid specification list", spec_list, + Qspecifier, errb); return Qnil; } if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec)))) { maybe_invalid_argument ( - "Invalid specifier locale", locale, - Qspecifier, errb); + "Invalid specifier locale", locale, + Qspecifier, errb); return Qnil; } @@ -1414,13 +1726,13 @@ out the frequency with which this is called with the various types and reorder the check accordingly. */ #define SPECIFIER_GET_SPEC_LIST(specifier, type) \ -(type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ - type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ - type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ - type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ - (XSPECIFIER (specifier)->window_specs)) : \ - type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ - 0) + (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ + type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ + type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ + type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ + (XSPECIFIER (specifier)->window_specs)) : \ + type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ + 0) static Lisp_Object * specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale, @@ -1759,8 +2071,8 @@ validating LOCALE and INST-LIST, but the tag-sets in INST-LIST do not need to be canonicalized. */ - /* #### I really need to rethink the after-change - functions to make them easier to use and more efficient. */ +/* #### I really need to rethink the after-change + functions to make them easier to use and more efficient. */ static void specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, @@ -1856,9 +2168,9 @@ /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE. CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of - -- nil (same as `all') - -- a single locale, locale type, or `all' - -- a list of locales, locale types, and/or `all' + -- nil (same as `all') + -- a single locale, locale type, or `all' + -- a list of locales, locale types, and/or `all' MAPFUN is called for each locale and locale type given; for `all', it is called for the locale `global' and for the four possible @@ -1868,7 +2180,7 @@ If MAPFUN ever returns non-zero, the mapping is halted and the value returned is returned from map_specifier(). Otherwise, the mapping proceeds to the end and map_specifier() returns 0. - */ +*/ static int map_specifier (Lisp_Object specifier, Lisp_Object locale, @@ -2148,7 +2460,7 @@ TAG-SET must be equal to an instantiator's tag set for the instantiator to be returned. */ - (specifier, locale, tag_set, exact_p)) + (specifier, locale, tag_set, exact_p)) { struct specifier_spec_list_closure cl; struct gcpro gcpro1, gcpro2; @@ -2347,7 +2659,7 @@ CHECK_SPECIFIER (dest); check_modifiable_specifier (dest); if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods) - invalid_argument ("Specifiers not of same type", Qunbound); + invalid_argument ("Specifiers not of same type", Qunbound); } cl.dest = dest; @@ -2496,10 +2808,13 @@ { /* 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; + enum font_specifier_matchspec_stages stage = initial; +#ifdef DEBUG_XEMACS + int non_ascii; +#endif GCPRO2 (specifier, inst_list); @@ -2507,37 +2822,125 @@ device = DOMAIN_DEVICE (domain); if (no_quit) - /* The instantiate method is allowed to call eval. Since it - is quite common for this function to get called from somewhere in - redisplay we need to make sure that quits are ignored. Otherwise - Fsignal will abort. */ + /* The instantiate method is allowed to call eval. Since it + is quite common for this function to get called from somewhere in + redisplay we need to make sure that quits are ignored. Otherwise + Fsignal will abort. */ specbind (Qinhibit_quit, Qt); +#ifdef MULE + if (CONSP(matchspec) && (CHARSETP(XCAR(matchspec)))) + { + charset = Ffind_charset(XCAR(matchspec)); + +#ifdef DEBUG_XEMACS + /* This is mostly to have somewhere to set debug breakpoints. */ + if (!EQ(charset, Vcharset_ascii)) + { + non_ascii = 1; + } +#endif /* DEBUG_XEMACS */ + + if (!NILP(XCDR(matchspec))) + { + +#define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ + { \ + stage = new_stage; \ + } + + FROB(initial) + else FROB(final) + else assert(0); +#undef FROB + + } + } +#endif /* MULE */ + + 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, stage))) + { + ++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); - - if (device_matches_specifier_tag_set_p (device, tag_set)) + Lisp_Object val, the_instantiator; + + if (!device_matches_specifier_tag_set_p (device, tag_set)) { - Lisp_Object val = XCDR (tagged_inst); - Lisp_Object 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 (!UNBOUNDP (val)) - { - unbind_to (count); - UNGCPRO; - if (instantiator) - *instantiator = the_instantiator; - return 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 (!UNBOUNDP (val)) + { + unbind_to (count); + UNGCPRO; + if (instantiator) + *instantiator = the_instantiator; + return val; } } @@ -2552,19 +2955,19 @@ return it. Otherwise return Qunbound. */ #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ - Lisp_Object *CIE_inst_list = \ - specifier_get_inst_list (specifier, key, type); \ - if (CIE_inst_list) \ - { \ - Lisp_Object CIE_val = \ - specifier_instance_from_inst_list (specifier, matchspec, \ - domain, *CIE_inst_list, \ - errb, no_quit, depth, \ - instantiator); \ - if (!UNBOUNDP (CIE_val)) \ - return CIE_val; \ - } \ -} while (0) + Lisp_Object *CIE_inst_list = \ + specifier_get_inst_list (specifier, key, type); \ + if (CIE_inst_list) \ + { \ + Lisp_Object CIE_val = \ + specifier_instance_from_inst_list (specifier, matchspec, \ + domain, *CIE_inst_list, \ + errb, no_quit, depth, \ + instantiator); \ + if (!UNBOUNDP (CIE_val)) \ + return CIE_val; \ + } \ + } while (0) /* We accept any window, frame or device domain and do our checking starting from as specific a locale type as we can determine from the @@ -2919,8 +3322,8 @@ 0); } -DEFUN ("specifier-instantiator-from-inst-list", Fspecifier_instantiator_from_inst_list, - 3, 4, 0, /* +DEFUN ("specifier-instantiator-from-inst-list", + Fspecifier_instantiator_from_inst_list, 3, 4, 0, /* Attempt to convert an inst-list into an instance; return instantiator. This is identical to `specifier-instance-from-inst-list' but returns the instantiator used to generate the instance, rather than the instance @@ -2988,17 +3391,17 @@ If you create a built-in specifier, you should do the following: - Make sure the file you create the specifier in has a - specifier_vars_of_foo() function. If not, create it, declare it in - symsinit.h, and make sure it's called in the appropriate place in - emacs.c. + specifier_vars_of_foo() function. If not, create it, declare it in + symsinit.h, and make sure it's called in the appropriate place in + emacs.c. - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by - initializing the specifier using Fmake_specifier(), followed by - set_specifier_fallback(), followed (optionally) by - set_specifier_caching(). + initializing the specifier using Fmake_specifier(), followed by + set_specifier_fallback(), followed (optionally) by + set_specifier_caching(). - If you used set_specifier_caching(), make sure to create the - appropriate value-changed functions. Also make sure to add the - appropriate slots where the values are cached to frameslots.h and - winslots.h. + appropriate value-changed functions. Also make sure to add the + appropriate slots where the values are cached to frameslots.h and + winslots.h. Do a grep for menubar_visible_p for an example. */ @@ -3025,7 +3428,7 @@ sp->caching = alloc_lrecord_type (struct specifier_caching, &lrecord_specifier_caching); #else /* not NEW_GC */ - sp->caching = xnew_and_zero (struct specifier_caching); + sp->caching = xnew_and_zero (struct specifier_caching); #endif /* not NEW_GC */ sp->caching->offset_into_struct_window = struct_window_offset; sp->caching->value_changed_in_window = value_changed_in_window; @@ -3326,10 +3729,10 @@ DEFINE_SPECIFIER_TYPE (display_table); -#define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ - (VECTORP (instantiator) \ - || (CHAR_TABLEP (instantiator) \ - && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ +#define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ + (VECTORP (instantiator) \ + || (CHAR_TABLEP (instantiator) \ + && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ || RANGE_TABLEP (instantiator)) @@ -3354,7 +3757,7 @@ lose: dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol, - instantiator); + instantiator); } } } @@ -3408,7 +3811,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 +3913,7 @@ Vunlock_ghost_specifiers = Qnil; staticpro (&Vunlock_ghost_specifiers); + + Vcharset_tag_lists = make_vector(NUM_LEADING_BYTES, Qnil); + staticpro (&Vcharset_tag_lists); }
--- a/src/specifier.h Sat Nov 04 22:51:03 2006 +0000 +++ b/src/specifier.h Sun Nov 05 22:31:46 2006 +0000 @@ -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); @@ -567,4 +568,18 @@ #define CHECK_DISPLAYTABLE_SPECIFIER(x) CHECK_SPECIFIER_TYPE (x, display_table) #define CONCHECK_DISPLAYTABLE_SPECIFIER(x) CONCHECK_SPECIFIER_TYPE (x, display_table) +/* The various stages of font instantiation; initial means "find a font for + CHARSET that matches the charset's registries" and final means "find a + font for CHARSET that matches iso10646-1, since we haven't found a font + that matches its registry." */ +enum font_specifier_matchspec_stages { + initial, + final, + impossible, +}; + +Lisp_Object define_specifier_tag(Lisp_Object tag, + Lisp_Object device_predicate, + Lisp_Object charset_predicate); + #endif /* INCLUDED_specifier_h_ */
--- a/src/unicode.c Sat Nov 04 22:51:03 2006 +0000 +++ b/src/unicode.c Sun Nov 05 22:31:46 2006 +0000 @@ -1115,9 +1115,8 @@ 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"); - struct gcpro gcpro1, gcpro2; + struct gcpro gcpro1; if ('\0' == last_jit_charset_final) { @@ -1138,7 +1137,7 @@ Lisp reader. We GCPRO in case it GCs in the future and no-one checks all the C callers. */ - GCPRO2 (charset_descr, charset_regr); + GCPRO1 (charset_descr); Vcurrent_jit_charset = Fmake_charset (intern((const CIbyte *)setname), charset_descr, /* Set encode-as-utf-8 to t, to have this character set written @@ -1148,7 +1147,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, Qunicode_registries, Qfinal, make_char(last_jit_charset_final++), /* This CCL program is initialised in unicode.el. */ @@ -2539,6 +2538,8 @@ DEFSYMBOL (Qccl_encode_to_ucs_2); DEFSYMBOL (Qlast_allocated_character); DEFSYMBOL (Qignore_first_column); + + DEFSYMBOL (Qunicode_registries); #endif /* MULE */ DEFSUBR (Fchar_to_unicode); @@ -2611,6 +2612,8 @@ dump_add_root_block_ptr (&unicode_precedence_dynarr, &lisp_object_dynarr_description); + + init_blank_unicode_tables (); staticpro (&Vcurrent_jit_charset); @@ -2636,5 +2639,16 @@ from_unicode_level_3_desc_1); dump_add_root_block (&from_unicode_blank_4, sizeof (void *), from_unicode_level_4_desc_1); + + DEFVAR_LISP ("unicode-registries", &Qunicode_registries /* +Vector describing the X11 registries searched when using fallback fonts. + +"Fallback fonts" here includes by default those fonts used by redisplay when +displaying charsets for which the `encode-as-utf-8' property is true, and +those used when no font matching the charset's registries property has been +found (that is, they're probably Mule-specific charsets like Ethiopic or +IPA.) +*/ ); + Qunicode_registries = vector1(build_string("iso10646-1")); #endif /* MULE */ }