Andrey, this is the patch I mentioned that will make GHE WITH UPTURN display properly on X11. There remains more work to be done on it than I thought :-( SUPERSEDES 17622.10738.650649.122673(a)parhasard.net Remaining to do as listed in that message: [...] 3. Mechanical copying of the X11-specific code to the GTK port; perhaps a move to something like event-xlike-inc.c [...] Also the XFT heuristics, but I’ll do that separately if I do it at all. Apart from that, I need to look into some odd behaviour that happens when non-ASCII text is selected lisp/ChangeLog addition: 2006-10-31 Aidan Kehoe <kehoea(a)parhasard.net&gt; * mule/arabic.el (arabic-digit): * mule/arabic.el (arabic-1-column): * mule/arabic.el (arabic-2-column): * mule/chinese.el (make-chinese-cns11643-charset): * mule/chinese.el (chinese-sisheng): * mule/english.el (ascii-right-to-left): * mule/ethiopic.el (ethiopic): * mule/european.el (latin-iso8859-14): * mule/european.el (latin-iso8859-16): * mule/indian.el (indian-is13194): * mule/indian.el (indian-1-column): * mule/indian.el (indian-2-column): * mule/japanese.el (japanese-jisx0213-1): * mule/japanese.el (japanese-jisx0213-2): * mule/lao.el (lao): * mule/misc-lang.el (ipa): * mule/mule-charset.el: * mule/thai-xtis.el (thai-xtis): * mule/tibetan.el (tibetan-1-column): * mule/tibetan.el (tibetan): * mule/vietnamese.el (vietnamese-viscii-lower): * mule/vietnamese.el (vietnamese-viscii-upper): Stop using the `registry' charset property; use `registries' instead. The difference is that registries is an ordered vector of X11 registries and encodings rather than a regexp; this means we can leave the matching to the X11 server, avoiding transferring huge amounts of data (perhaps across the network!) in order to do a regexp search on it. * mule/mule-charset.el (charset-registries): New. * mule/mule-charset.el (set-charset-registry): New. charset-registries returns the registries of a charset; 2006-10-31 Aidan Kehoe <kehoea(a)parhasard.net&gt; * 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. * 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. src/ChangeLog addition: 2006-10-31 Aidan Kehoe <kehoea(a)parhasard.net&gt; * 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. * objects-x.c: Provide a DEBUG_OBJECTS macro; use it to make debugging output available in debug builds. * objects-x.c (count_hyphens): New. How many ASCII minus characters in a string? * objects-x.c (x_initialize_font_instance): * objects-x.c (x_print_font_instance): * objects-x.c (x_font_spec_matches_charset): * objects-x.c (xlistfonts_checking_charset): * objects-x.c (x_find_charset_font): * 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. * 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. * 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. XEmacs Trunk source patch: Diff command: cvs -q diff -Nu Files affected: src/unicode.c src/specifier.h src/specifier.c src/redisplay.c src/redisplay-x.c src/objects.h src/objects.c src/objects-x.c src/objects-tty.c src/objects-msw.c src/objects-gtk.c src/mule-charset.c src/lisp.h src/intl.c src/general-slots.h src/font-mgr.h src/fileio.c src/faces.h src/faces.c src/console-impl.h src/charset.h lisp/mule/vietnamese.el lisp/mule/tibetan.el lisp/mule/thai-xtis.el lisp/mule/mule-charset.el lisp/mule/misc-lang.el lisp/mule/lao.el lisp/mule/japanese.el lisp/mule/indian.el lisp/mule/european.el lisp/mule/ethiopic.el lisp/mule/english.el lisp/mule/chinese.el lisp/mule/arabic.el lisp/x-font-menu.el lisp/x-faces.el lisp/unicode.el lisp/faces.el Index: lisp/faces.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/faces.el,v retrieving revision 1.38 diff -u -u -r1.38 faces.el --- lisp/faces.el 2006/04/25 14:01:52 1.38 +++ lisp/faces.el 2006/10/31 22:06:50 ＠＠ -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. - -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'. +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. 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")) Index: lisp/unicode.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/unicode.el,v retrieving revision 1.14 diff -u -u -r1.14 unicode.el --- lisp/unicode.el 2006/07/13 20:45:49 1.14 +++ lisp/unicode.el 2006/10/31 22:06:56 ＠＠ -29,54 +29,6 ＠＠ ;;; Code: -; ;; Subsets of Unicode. - -; #### 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)" -; )) - - -; (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)" -; )) - - ;; accessed in loadup.el, mule-cmds.el; see discussion in unicode.c (defvar load-unicode-tables-at-dump-time (eq system-type 'windows-nt) "[INTERNAL] Whether to load the Unicode tables at dump time. ＠＠ -305,14 +257,14 ＠＠ 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. ") ＠＠ -343,12 +295,6 ＠＠ "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 Index: lisp/x-faces.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/x-faces.el,v retrieving revision 1.25 diff -u -u -r1.25 x-faces.el --- lisp/x-faces.el 2006/04/25 14:01:54 1.25 +++ lisp/x-faces.el 2006/10/31 22:06:57 ＠＠ -782,7 +782,27 ＠＠ ;; 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 encode-as-utf-8 final) + (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 (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. Index: lisp/x-font-menu.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/x-font-menu.el,v retrieving revision 1.17 diff -u -u -r1.17 x-font-menu.el --- lisp/x-font-menu.el 2006/05/11 14:57:05 1.17 +++ lisp/x-font-menu.el 2006/10/31 22:06:57 ＠＠ -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) Index: lisp/mule/arabic.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/arabic.el,v retrieving revision 1.7 diff -u -u -r1.7 arabic.el --- lisp/mule/arabic.el 2002/03/16 10:39:05 1.7 +++ lisp/mule/arabic.el 2006/10/31 22:06:57 ＠＠ -47,9 +47,8 ＠＠ ;; Others are of direction right-to-left and of width 1-column or ;; 2-column. (make-charset 'arabic-digit "Arabic digit" - '(dimension - 1 - registry "MuleArabic-0" + '(dimension 1 + registries ["MuleArabic-0"] chars 94 columns 1 direction l2r ＠＠ -62,7 +61,7 ＠＠ (make-charset 'arabic-1-column "Arabic 1-column" '(dimension 1 - registry "MuleArabic-1" + registries ["MuleArabic-1"] chars 94 columns 1 direction r2l ＠＠ -75,7 +74,7 ＠＠ (make-charset 'arabic-2-column "Arabic 2-column" '(dimension 1 - registry "MuleArabic-2" + registries ["MuleArabic-2"] chars 94 columns 2 direction r2l Index: lisp/mule/chinese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/chinese.el,v retrieving revision 1.12 diff -u -u -r1.12 chinese.el --- lisp/mule/chinese.el 2005/12/24 22:31:51 1.12 +++ lisp/mule/chinese.el 2006/10/31 22:06:58 ＠＠ -146,8 +146,8 ＠＠ (name plane final) (make-charset name (concat "CNS 11643 Plane " plane " (Chinese traditional)") - `(registry - ,(concat "CNS11643[.-]\\(.*[.-]\\)?" plane "$") + `(registries + ,(vector (concat "cns11643.1992-" plane )) dimension 2 chars 94 final ,final ＠＠ -171,7 +171,7 ＠＠ (make-charset ;; not in FSF 21.1 'chinese-isoir165 "ISO-IR-165 (CCITT Extended GB; Chinese simplified)" - `(registry "isoir165" + `(registries ["isoir165-0"] dimension 2 chars 94 final ?E ＠＠ -185,7 +185,7 ＠＠ '(dimension 1 ;; XEmacs addition: second half of registry spec - registry "sisheng_cwnn\\|OMRON_UDC_ZH" + registries ["omron_udc_zh-0" "sisheng_cwnn-0"] chars 94 columns 1 direction l2r Index: lisp/mule/english.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/english.el,v retrieving revision 1.6 diff -u -u -r1.6 english.el --- lisp/mule/english.el 2002/03/29 04:46:41 1.6 +++ lisp/mule/english.el 2006/10/31 22:06:58 ＠＠ -36,7 +36,7 ＠＠ "ASCII (left half of ISO 8859-1) with right-to-left direction" '(dimension 1 - registry "ISO8859-1" + registries ["ISO8859-1"] chars 94 columns 1 direction r2l Index: lisp/mule/ethiopic.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/ethiopic.el,v retrieving revision 1.6 diff -u -u -r1.6 ethiopic.el --- lisp/mule/ethiopic.el 2002/03/16 10:39:06 1.6 +++ lisp/mule/ethiopic.el 2006/10/31 22:06:58 ＠＠ -32,7 +32,7 ＠＠ (make-charset 'ethiopic "Ethiopic characters" '(dimension 2 - registry "Ethiopic-Unicode" + registries ["Ethiopic-Unicode"] chars 94 columns 2 direction l2r ＠＠ -82,5 +82,8 ＠＠ (features ethio-util) (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 Index: lisp/mule/european.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/european.el,v retrieving revision 1.12 diff -u -u -r1.12 european.el --- lisp/mule/european.el 2005/05/10 17:02:59 1.12 +++ lisp/mule/european.el 2006/10/31 22:06:58 ＠＠ -121,7 +121,7 ＠＠ "Right-Hand Part of Latin Alphabet 8 (ISO/IEC 8859-14)" '(dimension 1 - registry "ISO8859-14" + registries ["ISO8859-14"] chars 96 columns 1 direction l2r ＠＠ -135,7 +135,7 ＠＠ "Right-Hand Part of Latin Alphabet 10 (ISO/IEC 8859-16)" '(dimension 1 - registry "ISO8859-16" + registries ["ISO8859-16"] chars 96 columns 1 direction l2r Index: lisp/mule/indian.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/indian.el,v retrieving revision 1.3 diff -u -u -r1.3 indian.el --- lisp/mule/indian.el 2002/03/16 10:39:06 1.3 +++ lisp/mule/indian.el 2006/10/31 22:06:58 ＠＠ -99,7 +99,7 ＠＠ "Generic Indian charset for data exchange with IS 13194" '(dimension 1 - registry "IS13194-Devanagari" + registries ["IS13194-Devanagari"] chars 94 columns 2 direction l2r ＠＠ -114,7 +114,7 ＠＠ "Indian charset for 2-column width glyphs" '(dimension 2 - registry "MuleIndian-1" + registries ["MuleIndian-1"] chars 94 columns 1 direction l2r ＠＠ -129,7 +129,7 ＠＠ "Indian charset for 2-column width glyphs" '(dimension 2 - registry "MuleIndian-2" + registries ["MuleIndian-2"] chars 94 columns 2 direction l2r Index: lisp/mule/japanese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/japanese.el,v retrieving revision 1.11 diff -u -u -r1.11 japanese.el --- lisp/mule/japanese.el 2004/01/29 05:22:40 1.11 +++ lisp/mule/japanese.el 2006/10/31 22:06:58 ＠＠ -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 ＠＠ -130,6 +60,28 ＠＠ long-name "JISX0213-2" )) +(when nil + +(when (and (memq 'x (device-type-list)) (not (featurep 'xft))) + ;; X11 fonts; these are available in XFree86 4.0. + (loop + for (character-set default-font) in + '((japanese-jisx0208 + "-jis-fixed-medium-r-normal--16-150-75-75-c-160-jisx0208.1983-0")) + do + (define-specifier-tag character-set nil + (list 'lambda '(charset stage) + (list 'eq 'charset + (list 'find-charset (list 'quote character-set))))) + (set-face-font 'default default-font 'global + (list 'x character-set) 'append))) + +;; japanese-jisx0213-1 +;;japanese-jisx0213-2 +;; katakana-jisx0201 +;; latin-jisx0201 + +) ;;; Syntax of Japanese characters. (modify-syntax-entry 'katakana-jisx0201 "w") (modify-syntax-entry 'japanese-jisx0212 "w") Index: lisp/mule/lao.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/lao.el,v retrieving revision 1.4 diff -u -u -r1.4 lao.el --- lisp/mule/lao.el 2002/03/18 10:07:37 1.4 +++ lisp/mule/lao.el 2006/10/31 22:06:58 ＠＠ -33,7 +33,7 ＠＠ (make-charset 'lao "Lao characters (ISO10646 0E80..0EDF)" '(dimension 1 - registry "MuleLao-1" + registries ["MuleLao-1"] chars 94 columns 1 direction l2r Index: lisp/mule/misc-lang.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/misc-lang.el,v retrieving revision 1.5 diff -u -u -r1.5 misc-lang.el --- lisp/mule/misc-lang.el 2002/03/16 10:39:07 1.5 +++ lisp/mule/misc-lang.el 2006/10/31 22:06:58 ＠＠ -34,7 +34,7 ＠＠ (make-charset 'ipa "IPA (International Phonetic Association)" '(dimension 1 - registry "MuleIPA" + registries ["MuleIPA"] chars 96 columns 1 direction l2r Index: lisp/mule/mule-charset.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/mule-charset.el,v retrieving revision 1.18 diff -u -u -r1.18 mule-charset.el --- lisp/mule/mule-charset.el 2005/12/23 11:42:35 1.18 +++ lisp/mule/mule-charset.el 2006/10/31 22:06:58 ＠＠ -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. Index: lisp/mule/thai-xtis.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/thai-xtis.el,v retrieving revision 1.4 diff -u -u -r1.4 thai-xtis.el --- lisp/mule/thai-xtis.el 2002/03/18 10:07:37 1.4 +++ lisp/mule/thai-xtis.el 2006/10/31 22:06:58 ＠＠ -35,12 +35,12 ＠＠ ;;; Code: (make-charset 'thai-xtis "Precomposed Thai (XTIS by Virach)." - '(registry "xtis-0" - dimension 2 - columns 1 - chars 94 - final ?? - graphic 0)) + '(registries ["xtis-0"] + dimension 2 + columns 1 + chars 94 + final ?? + graphic 0)) (define-category ?x "Precomposed Thai character.") (modify-category-entry 'thai-xtis ?x) Index: lisp/mule/tibetan.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/tibetan.el,v retrieving revision 1.3 diff -u -u -r1.3 tibetan.el --- lisp/mule/tibetan.el 2002/03/16 10:39:07 1.3 +++ lisp/mule/tibetan.el 2006/10/31 22:06:59 ＠＠ -87,7 +87,7 ＠＠ (make-charset 'tibetan-1-column "Tibetan 1 column glyph" '(dimension 2 - registry "MuleTibetan-1" + registries ["MuleTibetan-1"] chars 94 columns 1 direction l2r ＠＠ -101,7 +101,7 ＠＠ (make-charset 'tibetan "Tibetan characters" '(dimension 2 - registry "MuleTibetan-2" + registries ["MuleTibetan-2"] chars 94 columns 2 direction l2r Index: lisp/mule/vietnamese.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/mule/vietnamese.el,v retrieving revision 1.6 diff -u -u -r1.6 vietnamese.el --- lisp/mule/vietnamese.el 2002/03/21 07:30:24 1.6 +++ lisp/mule/vietnamese.el 2006/10/31 22:06:59 ＠＠ -37,7 +37,7 ＠＠ (make-charset 'vietnamese-viscii-lower "VISCII1.1 lower-case" '(dimension 1 - registry "VISCII1.1" + registries ["VISCII1.1"] chars 96 columns 1 direction l2r ＠＠ -50,7 +50,7 ＠＠ (make-charset 'vietnamese-viscii-upper "VISCII1.1 upper-case" '(dimension 1 - registry "VISCII1.1" + registries ["VISCII1.1"] chars 96 columns 1 direction l2r Index: src/charset.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/charset.h,v retrieving revision 1.14 diff -u -u -r1.14 charset.h --- src/charset.h 2006/07/07 23:01:11 1.14 +++ src/charset.h 2006/10/31 22:06:59 ＠＠ -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)) Index: src/console-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-impl.h,v retrieving revision 1.12 diff -u -u -r1.12 console-impl.h --- src/console-impl.h 2005/10/24 10:07:34 1.12 +++ src/console-impl.h 2006/10/31 22:07:00 ＠＠ -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 *); Index: src/faces.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.c,v retrieving revision 1.49 diff -u -u -r1.49 faces.c --- src/faces.c 2005/11/26 11:46:08 1.49 +++ src/faces.c 2006/10/31 22:07:02 ＠＠ -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,15 ＠＠ /* 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); 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 +1127,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; } ＠＠ -1399,10 +1490,12 ＠＠ { int offs = LEADING_BYTE_ASCII - MIN_LEADING_BYTE; - if (!cachel->font_specified[offs] && FINDEX_FIELD (font_specified[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]); - cachel->font_specified[offs] = 1; + set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 1); cachel->dirty = 1; } } ＠＠ -1433,6 +1526,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 +1600,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 +1990,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 +2086,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 +2160,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 +2233,12 ＠＠ #if defined (HAVE_X_WINDOWS) || defined (HAVE_GTK) +#ifdef HAVE_GTK + Lisp_Object device_symbol = Qgtk; +#else + Lisp_Object device_symbol = Qx; +#endif + const Ascbyte *fonts[] = { #ifdef USE_XFT ＠＠ -2053,165 +2246,122 ＠＠ /* 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", Qnil, /* Western #### add encoding info? */ /* 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", Vcharset_katakana_jisx0201, + /* 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(a)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")); + + inst_list = + Fcons + (Fcons + (list1 (device_symbol), + build_string ("*")), + inst_list); + + /* 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. */ + + 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); -#ifdef HAVE_GTK 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); + + /* 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 Index: src/faces.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.h,v retrieving revision 1.17 diff -u -u -r1.17 faces.h --- src/faces.h 2006/02/27 16:29:25 1.17 +++ src/faces.h 2006/10/31 22:07:02 ＠＠ -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) \ Index: src/fileio.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/fileio.c,v retrieving revision 1.105 diff -u -u -r1.105 fileio.c --- src/fileio.c 2006/06/19 18:19:37 1.105 +++ src/fileio.c 2006/10/31 22:07:04 ＠＠ -2948,6 +2948,13 ＠＠ reasonable maximum file size on the files. Is any of this worth it? --ben + + It's probably not worth it, and despite what you might take from the + above, we don't do it currently; that is, for non-"binary" coding + systems, we don't try to implement replace-mode at all. See the + do_speedy_insert variable above. The upside of this is that our API + is consistent and not buggy. -- Aidan Kehoe, Fri Oct 27 21:02:30 CEST + 2006 */ if (!NILP (replace)) Index: src/font-mgr.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/font-mgr.h,v retrieving revision 1.2 diff -u -u -r1.2 font-mgr.h --- src/font-mgr.h 2006/04/25 14:02:09 1.2 +++ src/font-mgr.h 2006/10/31 22:07:04 ＠＠ -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_ */ Index: src/general-slots.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/general-slots.h,v retrieving revision 1.17 diff -u -u -r1.17 general-slots.h --- src/general-slots.h 2006/06/03 17:50:54 1.17 +++ src/general-slots.h 2006/10/31 22:07:05 ＠＠ -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); Index: src/intl.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/intl.c,v retrieving revision 1.10 diff -u -u -r1.10 intl.c --- src/intl.c 2005/09/24 16:31:39 1.10 +++ src/intl.c 2006/10/31 22:07:06 ＠＠ -167,7 +167,7 ＠＠ void init_intl (void) { - /* This function can GC */ + /* This function cannot GC, because it explicitly prevents it. */ if (initialized) { int count = begin_gc_forbidden (); Index: src/lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.143 diff -u -u -r1.143 lisp.h --- src/lisp.h 2006/07/08 16:15:56 1.143 +++ src/lisp.h 2006/10/31 22:07:10 ＠＠ -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; Index: src/mule-charset.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mule-charset.c,v retrieving revision 1.47 diff -u -u -r1.47 mule-charset.c --- src/mule-charset.c 2006/06/03 17:50:54 1.47 +++ src/mule-charset.c 2006/10/31 22:07:10 ＠＠ -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 */ } Index: src/objects-gtk.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-gtk.c,v retrieving revision 1.17 diff -u -u -r1.17 objects-gtk.c --- src/objects-gtk.c 2005/12/24 17:33:34 1.17 +++ src/objects-gtk.c 2006/10/31 22:07:11 ＠＠ -385,7 +385,7 ＠＠ gtk_font_spec_matches_charset (struct device *UNUSED (d), Lisp_Object charset, const Ibyte *nonreloc, Lisp_Object reloc, Bytecount offset, Bytecount length, - int stage) + enum font_specifier_matchspec_stages stage) { if (stage) return 0; ＠＠ -436,7 +436,10 ＠＠ /* 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); +static Lisp_Object +gtk_find_charset_font (Lisp_Object device, Lisp_Object font, + Lisp_Object charset, + enum font_specifier_matchspec_stages stage); #endif /* MULE */ ＠＠ -492,7 +495,8 ＠＠ (the registry of) CHARSET. */ static Lisp_Object gtk_find_charset_font (Lisp_Object device, Lisp_Object font, - Lisp_Object charset, int stage) + Lisp_Object charset, + enum font_specifier_matchspec_stages stage) { char **names; int count = 0; ＠＠ -516,7 +520,7 ＠＠ 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)) + intname, Qnil, 0, -1, stage)) { result = make_string (intname, intlen); break; Index: src/objects-msw.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-msw.c,v retrieving revision 1.47 diff -u -u -r1.47 objects-msw.c --- src/objects-msw.c 2005/01/28 02:58:51 1.47 +++ src/objects-msw.c 2006/10/31 22:07:12 ＠＠ -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; Index: src/objects-tty.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-tty.c,v retrieving revision 1.17 diff -u -u -r1.17 objects-tty.c --- src/objects-tty.c 2005/11/25 01:42:06 1.17 +++ src/objects-tty.c 2006/10/31 22:07:12 ＠＠ -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); Index: src/objects-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-x.c,v retrieving revision 1.43 diff -u -u -r1.43 objects-x.c --- src/objects-x.c 2006/06/23 15:45:03 1.43 +++ src/objects-x.c 2006/10/31 22:07:13 ＠＠ -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,36 ＠＠ int x_handle_non_fully_specified_fonts; +#ifdef DEBUG_XEMACS +Fixnum debug_x_objects; +#endif /* DEBUG_XEMACS */ + +#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 + +#define THIS_IS_X +#include "objects-xlike-inc.c" + +  /************************************************************************/ /* color instances */ ＠＠ -205,75 +236,7 ＠＠ /* 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), Lisp_Object device, Error_Behavior errb) ＠＠ -299,6 +262,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 +430,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)) ＠＠ -946,15 +919,52 ＠＠ #ifdef MULE +static int +count_hyphens(const Ibyte *str, Bytecount length, Ibyte **last_hyphen) +{ + int hyphen_count = 0; + const Ibyte *hyphening = str; + const Ibyte *new_hyphening; + + for (hyphen_count = 0; + NULL != (new_hyphening = memchr((const void *)hyphening, '-', length)); + hyphen_count++) + { + ++new_hyphening; + length -= new_hyphening - hyphening; + hyphening = new_hyphening; + } + + if (NULL != last_hyphen) + { + *last_hyphen = (Ibyte *)hyphening; + } + + return hyphen_count; +} + static int x_font_spec_matches_charset (struct device * USED_IF_XFT (d), Lisp_Object charset, const Ibyte *nonreloc, Lisp_Object reloc, Bytecount offset, Bytecount length, - int stage) + enum font_specifier_matchspec_stages stage) { - if (stage) + 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; ＠＠ -967,14 +977,15 ＠＠ LISP_STRING_TO_EXTERNAL (reloc, extname, Qx_font_name_encoding); rf = xft_open_font_by_name (dpy, extname); return 0; /* #### maybe this will compile and run ;) */ + /* Jesus, Stephen, what the fuck? */ } } -#else - return 0; #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 ＠＠ -986,41 +997,53 ＠＠ between faces and fonts? No - it looks like that would be an abuse (fontconfig doesn't know about colors, although Xft does). */ - if (EQ (charset, Vcharset_ascii)) + if (EQ (charset, Vcharset_ascii) && + (!memchr (the_nonreloc, '*', the_length)) + && (5 > (count_hyphens(the_nonreloc, the_length, NULL)))) { - const Ibyte *the_nonreloc = nonreloc; - int i; - Bytecount the_length = length; - - if (!the_nonreloc) - the_nonreloc = XSTRING_DATA (reloc); - fixup_internal_substring (nonreloc, reloc, offset, &the_length); - the_nonreloc += offset; - if (!memchr (the_nonreloc, '*', the_length)) - { - for (i = 0;; i++) - { - const Ibyte *new_nonreloc = (const Ibyte *) - memchr (the_nonreloc, '-', the_length); - if (!new_nonreloc) - break; - new_nonreloc++; - the_length -= new_nonreloc - the_nonreloc; - the_nonreloc = new_nonreloc; - } + return 1; + } - /* 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; + 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); - return (fast_string_match (XCHARSET_REGISTRY (charset), - nonreloc, reloc, offset, length, 1, - ERROR_ME, 0) >= 0); + for (i = 0; i < registries_len; ++i) + { + if (!(STRINGP(XVECTOR_DATA(registries)[i])) + || (XSTRING_LENGTH(XVECTOR_DATA(registries)[i]) > the_length)) + { + continue; + } + + /* Check if the font spec ends in the registry specified. X11 says + this comparison is case insensitive: XLFD, section 3.11: + + "Alphabetic case distinctions are allowed but are for human + readability concerns only. Conforming X servers will perform + matching on font name query or open requests independent of case." */ + if (0 == qxestrcasecmp(XSTRING_DATA(XVECTOR_DATA(registries)[i]), + the_nonreloc + (the_length - + XSTRING_LENGTH + (XVECTOR_DATA(registries)[i])))) + { + return 1; + } + } + return 0; } #ifdef USE_XFT ＠＠ -1170,26 +1193,18 ＠＠ : eistr_shortname; \ } while (0) -#endif /* USE_XFT */ - -/* find a font spec that matches font spec FONT and also matches - (the registry of) CHARSET. */ static Lisp_Object -x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, - int stage) +xft_find_charset_font (Lisp_Object font, Lisp_Object charset, + enum font_specifier_matchspec_stages stage) { - Extbyte **names; - int count = 0; const Extbyte *patternext; Lisp_Object result = Qnil; - int i; /* #### with Xft need to handle second stage here -- sjt Hm. Or maybe not. That would be cool. :-) */ if (stage) return Qnil; -#ifdef USE_XFT /* Fontconfig converts all FreeType names to UTF-8 before passing them back to callers---see fcfreetype.c (FcFreeTypeQuery). I don't believe this is documented. */ ＠＠ -1339,7 +1354,6 ＠＠ } ASSERT_ASCTEXT_ASCII((Extbyte *) lang); - } if (fccs) { ＠＠ -1356,7 +1370,7 ＠＠ else if (r == FcResultMatch && FcCharSetIsSubset (fccs, v)) { /* The full pattern with the bitmap coverage is massively - unwieldy, but the shorter names are's just *wrong*. We + unwieldy, but the shorter names are just *wrong*. We should have the full thing internally as truename, and filter stuff the client doesn't want to see on output. Should we just store it into the truename right here? */ ＠＠ -1432,42 +1446,175 ＠＠ return result; } - DEBUG_XFT1 (0, "shit happens, try X11 charset match for %s\n", - XSTRING_DATA(font)); + return Qnil; #undef DECLARE_DEBUG_FONTNAME +} + #endif /* USE_XFT */ - LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding); +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 (DEVICE_X_DISPLAY (XDEVICE (device)), - patternext, MAX_FONT_COUNT, &count); - /* #### This code seems awfully bogus -- mrb */ - /* #### fontconfig does it better -- sjt */ - for (i = 0; i < count; i ++) - { - const Ibyte *intname; - Bytecount intlen; - - TO_INTERNAL_FORMAT (C_STRING, names[i], - ALLOCA, (intname, intlen), - Qx_font_name_encoding); + xlfd, MAX_FONT_COUNT, &count); + for (i = 0; i < count; ++i) + { + eireset(ei_single_result); + eicpy_ext(ei_single_result, names[i], Qx_font_name_encoding); + if (x_font_spec_matches_charset (XDEVICE (device), charset, - intname, Qnil, 0, -1, 0)) + eidata(ei_single_result), Qnil, 0, + -1, stage)) { - result = build_ext_string ((const Extbyte *) intname, - Qx_font_name_encoding); + result = eimake_string(ei_single_result); + DEBUG_OBJECTS ("in xlistfonts_checking_charset, returning %s\n", + eidata(ei_single_result)); break; } } if (names) - XFreeFontNames (names); + { + XFreeFontNames (names); + } + + return result; +} + +/* find a font spec that matches font spec FONT and also matches + (the registry of) CHARSET. */ +static Lisp_Object +x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset, + enum font_specifier_matchspec_stages stage) +{ + 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. */ - /* Check for a short font name. */ - if (NILP (result) - && x_font_spec_matches_charset (XDEVICE (device), charset, 0, - font, 0, -1, 0)) - return font; + 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; } ＠＠ -1512,6 +1659,13 ＠＠ void vars_of_objects_x (void) { +#ifdef DEBUG_XEMACS + DEFVAR_INT ("debug-x-objects", &debug_x_objects /* +If non-zero, display debug information about X objects +*/ ); + debug_x_objects = 0; +#endif + DEFVAR_BOOL ("x-handle-non-fully-specified-fonts", &x_handle_non_fully_specified_fonts /* If this is true then fonts which do not have all characters specified Index: src/objects.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.c,v retrieving revision 1.31 diff -u -u -r1.31 objects.c --- src/objects.c 2005/11/26 11:46:10 1.31 +++ src/objects.c 2006/10/31 22:07:14 ＠＠ -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; Index: src/objects.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.h,v retrieving revision 1.11 diff -u -u -r1.11 objects.h --- src/objects.h 2005/11/26 11:46:10 1.11 +++ src/objects.h 2006/10/31 22:07:14 ＠＠ -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_ */ Index: src/redisplay-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/redisplay-x.c,v retrieving revision 1.43 diff -u -u -r1.43 redisplay-x.c --- src/redisplay-x.c 2006/06/27 22:59:40 1.43 +++ src/redisplay-x.c 2006/10/31 22:07:14 ＠＠ -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,145 ＠＠ 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) - { - byte1 &= 0x7F; - byte2 &= 0x7F; - } - else if (graphic == 1) + runs_so_far++; + } + + if (translate_to_ucs_2) { - byte1 |= 0x80; - byte2 |= 0x80; + int ucs = ichar_to_unicode(ch); + + /* If UCS is less than zero or greater than 0xFFFF, set it to + REPLACMENT CHARACTER. */ + if (ucs & ~0xFFFF) + { + ucs = 0xFFFD; + } + + /* Ignoring the "graphic" handling. Also, X11 (XFT included) takes + its font indices with network byte order. */ + byte1 = ucs >> 8; + byte2 = ucs & 0xFF; } #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; +#ifdef MULE + if (2 == dimension) *text_storage++ = (unsigned char)byte2; +#endif /* MULE */ } 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 +367,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 +1021,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++) { Index: src/redisplay.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/redisplay.c,v retrieving revision 1.100 diff -u -u -r1.100 redisplay.c --- src/redisplay.c 2006/07/08 16:15:56 1.100 +++ src/redisplay.c 2006/10/31 22:07:18 ＠＠ -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 Index: src/specifier.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.c,v retrieving revision 1.44 diff -u -u -r1.44 specifier.c --- src/specifier.c 2006/02/27 16:29:28 1.44 +++ src/specifier.c 2006/10/31 22:07:19 ＠＠ -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 ＠＠ -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,13 +847,20 ＠＠ \(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. ＠＠ -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,61 ＠＠ 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; + Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags), + concons, devcons, charpres = Qnil; + int recompute_devices = 0, recompute_charsets = 0, i, max_args; - 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); if (NILP (assoc)) { - recompute = 1; - Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags); + recompute_devices = recompute_charsets = 1; + Vuser_defined_tags = Fcons (list3 (tag, device_predicate, + charset_predicate), + Vuser_defined_tags); DEVICE_LOOP_NO_BREAK (devcons, concons) { struct device *d = XDEVICE (XCAR (devcons)); /* Initially set the value to t in case of error - in predicate */ + in device_predicate */ DEVICE_USER_DEFINED_TAGS (d) = Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d)); } } - else if (!NILP (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); } + 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. However, in the special - case where both the old and new predicates are nil, we know that - we don't have to do this. (It's probably common for people to - call (define-specifier-tag) more than once on the same tag, - and the most common case is where PREDICATE is not specified.) */ + /* Recompute the tag values for all devices and charsets, 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) + if (recompute_devices) { DEVICE_LOOP_NO_BREAK (devcons, concons) { ＠＠ -1047,16 +1117,155 ＠＠ 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)) + { + 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 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) + { + 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 tag values for the newly-created device. */ ＠＠ -1065,6 +1274,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,15 +1286,83 ＠＠ 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, /* ＠＠ -1100,7 +1379,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 +1390,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 +1413,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)) { ＠＠ -1155,8 +1437,24 ＠＠ return list3 (Qlambda, list1 (Qdevice), list3 (Qeq, list2 (Qquote, tag), list2 (Qdevice_class, Qdevice))); + + 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 XCDR (assq_no_quit (tag, Vuser_defined_tags)); + 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. ＠＠ -2496,10 +2794,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); ＠＠ -2513,31 +2814,119 ＠＠ 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); + Lisp_Object val, the_instantiator; - if (device_matches_specifier_tag_set_p (device, tag_set)) + if (!device_matches_specifier_tag_set_p (device, tag_set)) { - Lisp_Object val = XCDR (tagged_inst); - Lisp_Object the_instantiator = val; + continue; + } + val = XCDR (tagged_inst); + the_instantiator = val; - if (HAS_SPECMETH_P (sp, instantiate)) - val = call_with_suspended_errors - ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), - Qunbound, Qspecifier, errb, 5, specifier, - matchspec, domain, val, depth); + if (HAS_SPECMETH_P (sp, instantiate)) + val = call_with_suspended_errors + ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), + Qunbound, Qspecifier, errb, 5, specifier, + matchspec, domain, val, depth); - if (!UNBOUNDP (val)) - { - unbind_to (count); - UNGCPRO; - if (instantiator) - *instantiator = the_instantiator; - return val; - } + if (!UNBOUNDP (val)) + { + unbind_to (count); + UNGCPRO; + if (instantiator) + *instantiator = the_instantiator; + return val; } } ＠＠ -3408,7 +3797,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 +3899,7 ＠＠ Vunlock_ghost_specifiers = Qnil; staticpro (&Vunlock_ghost_specifiers); + + Vcharset_tag_lists = make_vector(NUM_LEADING_BYTES, Qnil); + staticpro (&Vcharset_tag_lists); } Index: src/specifier.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.h,v retrieving revision 1.19 diff -u -u -r1.19 specifier.h --- src/specifier.h 2005/11/25 01:42:06 1.19 +++ src/specifier.h 2006/10/31 22:07:20 ＠＠ -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); ＠＠ -566,5 +567,19 ＠＠ #define DISPLAYTABLE_SPECIFIERP(x) SPECIFIER_TYPEP (x, display_table) #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_ */ Index: src/unicode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/unicode.c,v retrieving revision 1.34 diff -u -u -r1.34 unicode.c --- src/unicode.c 2006/06/14 06:10:10 1.34 +++ src/unicode.c 2006/10/31 22:07:21 ＠＠ -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 */ } -- Santa Maradona, priez pour moi! _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches