lisp/international/fontset.el

   1 ;;; fontset.el --- commands for handling fontset
   2
   3 ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007  Free Software Foundation, Inc.
   5 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   6 ;;   2005, 2006, 2007
   7 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   8 ;;   Registration Number H14PRO021
   9
  10 ;; Keywords: mule, multilingual, fontset
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32
  33 ;; Set standard fontname specification of characters in the default
  34 ;; fontset to find an appropriate font for each charset.  This is used
  35 ;; to generate a font name for a fontset if the fontset doesn't
  36 ;; specify a font name for a specific character.  The specification
  37 ;; has the form (FAMILY . REGISTRY).  FAMILY may be nil, in which
  38 ;; case, the family name of default face is used.  If REGISTRY
  39 ;; contains a character `-', the string before that is embedded in
  40 ;; `CHARSET_REGISTRY' field, and the string after that is embedded in
  41 ;; `CHARSET_ENCODING' field.  If it does not contain `-', the whole
  42 ;; string is embedded in `CHARSET_REGISTRY' field, and a wild card
  43 ;; character `*' is embedded in `CHARSET_ENCODING' field.  The
  44 ;; REGISTRY for ASCII characters are predefined as "ISO8859-1".
  45
  46 (defun setup-default-fontset ()
  47   "Setup the default fontset."
  48   (dolist (elt
  49            `((latin-iso8859-1 . (nil . "ISO8859-1"))
  50              (latin-iso8859-2 . (nil . "ISO8859-2"))
  51              (latin-iso8859-3 . (nil . "ISO8859-3"))
  52              (latin-iso8859-4 . (nil . "ISO8859-4"))
  53              ;; Setting "*" family is for a workaround of the problem
  54              ;; that a font of wrong size is preferred if the font
  55              ;; family matches with a requested one.
  56              (thai-tis620 . ("*" . "TIS620"))
  57              (greek-iso8859-7 . (nil . "ISO8859-7"))
  58              (arabic-iso8859-6 . (nil . "ISO8859-6"))
  59              (hebrew-iso8859-8 . (nil . "ISO8859-8"))
  60              (katakana-jisx0201 . (nil . "JISX0201"))
  61              (latin-jisx0201 . (nil . "JISX0201"))
  62              (cyrillic-iso8859-5 . (nil . "ISO8859-5"))
  63              (latin-iso8859-9 . (nil . "ISO8859-9"))
  64              (japanese-jisx0208-1978 . (nil . "JISX0208.1978"))
  65              (chinese-gb2312 . (nil . "GB2312.1980"))
  66              (japanese-jisx0208 . (nil . "JISX0208.1990"))
  67              (korean-ksc5601 . (nil . "KSC5601.1989"))
  68              (japanese-jisx0212 . (nil . "JISX0212"))
  69              (chinese-cns11643-1 . (nil . "CNS11643.1992-1"))
  70              (chinese-cns11643-2 . (nil . "CNS11643.1992-2"))
  71              (chinese-cns11643-3 . (nil . "CNS11643.1992-3"))
  72              (chinese-cns11643-4 . (nil . "CNS11643.1992-4"))
  73              (chinese-cns11643-5 . (nil . "CNS11643.1992-5"))
  74              (chinese-cns11643-6 . (nil . "CNS11643.1992-6"))
  75              (chinese-cns11643-7 . (nil . "CNS11643.1992-7"))
  76              (chinese-big5-1 . (nil . "Big5"))
  77              (chinese-big5-2 . (nil . "Big5"))
  78              (chinese-sisheng . (nil . "sisheng_cwnn"))
  79              (vietnamese-viscii-lower . (nil . "VISCII1.1"))
  80              (vietnamese-viscii-upper . (nil . "VISCII1.1"))
  81              (arabic-digit . (nil . "MuleArabic-0"))
  82              (arabic-1-column . (nil . "MuleArabic-1"))
  83              (arabic-2-column . (nil . "MuleArabic-2"))
  84              (ipa . (nil . "MuleIPA"))
  85              (ethiopic . (nil . "Ethiopic-Unicode"))
  86              (ascii-right-to-left . (nil . "ISO8859-1"))
  87              (indian-is13194 . (nil . "IS13194-Devanagari"))
  88              (indian-2-column . (nil . "MuleIndian-2"))
  89              (lao . (nil . "MuleLao-1"))
  90              (tibetan . ("proportional" . "MuleTibetan-2"))
  91              (tibetan-1-column . (nil . "MuleTibetan-1"))
  92              (latin-iso8859-14 . (nil . "ISO8859-14"))
  93              (latin-iso8859-15 . (nil . "ISO8859-15"))
  94              (mule-unicode-0100-24ff . (nil . "ISO10646-1"))
  95              (mule-unicode-2500-33ff . (nil . "ISO10646-1"))
  96              (mule-unicode-e000-ffff . (nil . "ISO10646-1"))
  97              (japanese-jisx0213-1 . (nil . "JISX0213.2000-1"))
  98              (japanese-jisx0213-2 . (nil . "JISX0213.2000-2"))
  99              ;; unicode
 100              ((,(decode-char 'ucs #x0900) . ,(decode-char 'ucs #x097F))
 101               . (nil . "ISO10646.indian-1"))
 102              ;; Indian CDAC
 103              (,(indian-font-char-range 'cdac:dv-ttsurekh)
 104               . (nil . "Devanagari-CDAC"))
 105              (,(indian-font-char-range 'cdac:sd-ttsurekh)
 106               . (nil . "Sanskrit-CDAC"))
 107              (,(indian-font-char-range 'cdac:bn-ttdurga)
 108               . (nil . "Bengali-CDAC"))
 109              (,(indian-font-char-range 'cdac:as-ttdurga)
 110               . (nil . "Assamese-CDAC"))
 111              (,(indian-font-char-range 'cdac:pn-ttamar)
 112               . (nil . "Punjabi-CDAC"))
 113              (,(indian-font-char-range 'cdac:gj-ttavantika)
 114               . (nil . "Gujarati-CDAC"))
 115              (,(indian-font-char-range 'cdac:or-ttsarala)
 116               . (nil . "Oriya-CDAC"))
 117              (,(indian-font-char-range 'cdac:tm-ttvalluvar)
 118               . (nil . "Tamil-CDAC"))
 119              (,(indian-font-char-range 'cdac:tl-tthemalatha)
 120               . (nil . "Telugu-CDAC"))
 121              (,(indian-font-char-range 'cdac:kn-ttuma)
 122               . (nil . "Kannada-CDAC"))
 123              (,(indian-font-char-range 'cdac:ml-ttkarthika)
 124               . (nil . "Malayalam-CDAC"))
 125              ;; Indian AKRUTI
 126              (,(indian-font-char-range 'akruti:dev)
 127               . (nil . "Devanagari-Akruti"))
 128              (,(indian-font-char-range 'akruti:bng)
 129               . (nil . "Bengali-Akruti"))
 130              (,(indian-font-char-range 'akruti:pnj)
 131               . (nil . "Punjabi-Akruti"))
 132              (,(indian-font-char-range 'akruti:guj)
 133               . (nil . "Gujarati-Akruti"))
 134              (,(indian-font-char-range 'akruti:ori)
 135               . (nil . "Oriya-Akruti"))
 136              (,(indian-font-char-range 'akruti:tml)
 137               . (nil . "Tamil-Akruti"))
 138              (,(indian-font-char-range 'akruti:tlg)
 139               . (nil . "Telugu-Akruti"))
 140              (,(indian-font-char-range 'akruti:knd)
 141               . (nil . "Kannada-Akruti"))
 142              (,(indian-font-char-range 'akruti:mal)
 143               . (nil . "Malayalam-Akruti"))
 144              ))
 145     (set-fontset-font "fontset-default" (car elt) (cdr elt))))
 146
 147 ;; Set arguments in `font-encoding-alist' (which see).
 148 (defun set-font-encoding (pattern charset encoding)
 149   (let ((slot (assoc pattern font-encoding-alist)))
 150     (if slot
 151         (let ((place (assq charset (cdr slot))))
 152           (if place
 153               (setcdr place encoding)
 154             (setcdr slot (cons (cons charset encoding) (cdr slot)))))
 155       (setq font-encoding-alist
 156             (cons (list pattern (cons charset encoding)) font-encoding-alist)))
 157     ))
 158
 159 ;; Allow display of arbitrary characters with an iso-10646-encoded
 160 ;; (`Unicode') font.
 161 (define-translation-table 'ucs-mule-to-mule-unicode
 162   ucs-mule-to-mule-unicode)
 163 (define-translation-hash-table 'ucs-mule-cjk-to-unicode
 164   ucs-mule-cjk-to-unicode)
 165
 166 (define-ccl-program ccl-encode-unicode-font
 167   `(0
 168     ;; r0: charset-id
 169     ;; r1: 1st position code
 170     ;; r2: 2nd position code (if r0 is 2D charset)
 171     ((if (r0 == ,(charset-id 'ascii))
 172          ((r2 = r1)
 173           (r1 = 0))
 174        ;; At first, try to get a Unicode code point directly.
 175        ((if (r2 >= 0)
 176             ;; This is a 2D charset.
 177             (r1 = ((r1 << 7) | r2)))
 178         (lookup-character utf-subst-table-for-encode r0 r1)
 179         (if r7
 180             ;; We got it!
 181             ((r1 = (r0 >> 8))
 182              (r2 = (r0 & #xFF)))
 183           ;; Look for a translation for non-ASCII chars.
 184           ((translate-character ucs-mule-to-mule-unicode r0 r1)
 185            (if (r0 == ,(charset-id 'ascii))
 186                ((r2 = r1)
 187                 (r1 = 0))
 188              ((if (r0 == ,(charset-id 'latin-iso8859-1))
 189                   ((r2 = (r1 + 128))
 190                    (r1 = 0))
 191                 ((r2 = (r1 & #x7F))
 192                  (r1 >>= 7)
 193                  (if (r0 == ,(charset-id 'mule-unicode-0100-24ff))
 194                      ((r1 *= 96)
 195                       (r1 += r2)
 196                       (r1 += ,(- #x100 (* 32 96) 32))
 197                       (r1 >8= 0)
 198                       (r2 = r7))
 199                    (if (r0 == ,(charset-id 'mule-unicode-2500-33ff))
 200                        ((r1 *= 96)
 201                         (r1 += r2)
 202                         (r1 += ,(- #x2500 (* 32 96) 32))
 203                         (r1 >8= 0)
 204                         (r2 = r7))
 205                      (if (r0 == ,(charset-id 'mule-unicode-e000-ffff))
 206                          ((r1 *= 96)
 207                           (r1 += r2)
 208                           (r1 += ,(- #xe000 (* 32 96) 32))
 209                           (r1 >8= 0)
 210                           (r2 = r7))
 211                        ;; No way, use the glyph for U+FFFD.
 212                        ((r1 = #xFF)
 213                         (r2 = #xFD)))))))))))))))
 214   "Encode characters for display with iso10646 font.
 215 Translate through the translation-hash-table named
 216 `ucs-mule-cjk-to-unicode' and the translation-table named
 217 `ucs-mule-to-mule-unicode' initially.")
 218
 219 ;; Use the above CCL encoder for Unicode fonts.  Please note that the
 220 ;; regexp is not simply "ISO10646-1" because there exists, for
 221 ;; instance, the following Devanagari Unicode fonts:
 222 ;;      -misc-fixed-medium-r-normal--24-240-72-72-c-120-iso10646.indian-1
 223 ;;      -sibal-devanagari-medium-r-normal--24-240-75-75-P--iso10646-dev
 224 (setq font-ccl-encoder-alist
 225       (cons '("ISO10646.*-*" . ccl-encode-unicode-font)
 226             font-ccl-encoder-alist))
 227
 228 ;; Setting for suppressing XLoadQueryFont on big fonts.
 229 (setq x-pixel-size-width-font-regexp
 230       "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
 231
 232 ;; These fonts require vertical centering.
 233 (setq vertical-centering-font-regexp
 234       "gb2312\\|jisx0208\\|jisx0212\\|ksc5601\\|cns11643\\|big5")
 235
 236 ;; CDAC fonts are actually smaller than their design sizes.
 237 (setq face-font-rescale-alist
 238       '(("-cdac$" . 1.3)))
 239
 240 (defvar x-font-name-charset-alist
 241   '(("iso8859-1" ascii latin-iso8859-1)
 242     ("iso8859-2" ascii latin-iso8859-2)
 243     ("iso8859-3" ascii latin-iso8859-3)
 244     ("iso8859-4" ascii latin-iso8859-4)
 245     ("iso8859-5" ascii cyrillic-iso8859-5)
 246     ("iso8859-6" ascii arabic-iso8859-6)
 247     ("iso8859-7" ascii greek-iso8859-7)
 248     ("iso8859-8" ascii hebrew-iso8859-8)
 249     ("iso8859-14" ascii latin-iso8859-14)
 250     ("iso8859-15" ascii latin-iso8859-15)
 251     ("tis620" ascii thai-tis620)
 252     ("koi8" ascii cyrillic-iso8859-5)
 253     ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
 254     ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
 255     ("mulelao-1" ascii lao)
 256     ("iso10646-1" ascii latin-iso8859-1 mule-unicode-0100-24ff
 257      mule-unicode-2500-33ff mule-unicode-e000-ffff))
 258   "Alist of font names vs list of charsets the font can display.
 259
 260 When a font name which matches some element of this alist is given as
 261 `-fn' command line argument or is specified by X resource, a fontset
 262 which uses the specified font for the corresponding charsets are
 263 created and used for the initial frame.")
 264
 265 ;;; XLFD (X Logical Font Description) format handler.
 266
 267 ;; Define XLFD's field index numbers.           ; field name
 268 (defconst xlfd-regexp-foundry-subnum 0)         ; FOUNDRY
 269 (defconst xlfd-regexp-family-subnum 1)          ; FAMILY_NAME
 270 (defconst xlfd-regexp-weight-subnum 2)          ; WEIGHT_NAME
 271 (defconst xlfd-regexp-slant-subnum 3)           ; SLANT
 272 (defconst xlfd-regexp-swidth-subnum 4)          ; SETWIDTH_NAME
 273 (defconst xlfd-regexp-adstyle-subnum 5)         ; ADD_STYLE_NAME
 274 (defconst xlfd-regexp-pixelsize-subnum 6)       ; PIXEL_SIZE
 275 (defconst xlfd-regexp-pointsize-subnum 7)       ; POINT_SIZE
 276 (defconst xlfd-regexp-resx-subnum 8)            ; RESOLUTION_X
 277 (defconst xlfd-regexp-resy-subnum 9)            ; RESOLUTION_Y
 278 (defconst xlfd-regexp-spacing-subnum 10)        ; SPACING
 279 (defconst xlfd-regexp-avgwidth-subnum 11)       ; AVERAGE_WIDTH
 280 (defconst xlfd-regexp-registry-subnum 12)       ; CHARSET_REGISTRY
 281 (defconst xlfd-regexp-encoding-subnum 13)       ; CHARSET_ENCODING
 282
 283 ;; Regular expression matching against a fontname which conforms to
 284 ;; XLFD (X Logical Font Description).  All fields in XLFD should be
 285 ;; not be omitted (but can be a wild card) to be matched.
 286 (defconst xlfd-tight-regexp
 287   "^\
 288 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
 289 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
 290 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")
 291
 292 ;; List of field numbers of XLFD whose values are numeric.
 293 (defconst xlfd-regexp-numeric-subnums
 294   (list xlfd-regexp-pixelsize-subnum    ;6
 295         xlfd-regexp-pointsize-subnum    ;7
 296         xlfd-regexp-resx-subnum         ;8
 297         xlfd-regexp-resy-subnum         ;9
 298         xlfd-regexp-avgwidth-subnum     ;11
 299         ))
 300
 301 (defun x-decompose-font-name (pattern)
 302   "Decompose PATTERN into XLFD's fields and return vector of the fields.
 303 The length of the vector is 14.
 304
 305 If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
 306 X server and use the information of the full name to decompose
 307 PATTERN.  If no full XLFD name is gotten, return nil."
 308   (let (xlfd-fields fontname)
 309     (if (string-match xlfd-tight-regexp pattern)
 310         (let ((i 0))
 311           (setq xlfd-fields (make-vector 14 nil))
 312           (while (< i 14)
 313             (aset xlfd-fields i (match-string (1+ i) pattern))
 314             (setq i (1+ i)))
 315           xlfd-fields)
 316       (setq fontname (condition-case nil
 317                          (x-resolve-font-name pattern)
 318                        (error)))
 319       (if (and fontname
 320                (string-match xlfd-tight-regexp fontname))
 321           ;; We get a full XLFD name.
 322           (let ((len (length pattern))
 323                 (i 0)
 324                 l)
 325             ;; Setup xlfd-fields by the full XLFD name.  Each element
 326             ;; should be a cons of matched index and matched string.
 327             (setq xlfd-fields (make-vector 14 nil))
 328             (while (< i 14)
 329               (aset xlfd-fields i
 330                     (cons (match-beginning (1+ i))
 331                           (match-string (1+ i) fontname)))
 332               (setq i (1+ i)))
 333
 334             ;; Replace wild cards in PATTERN by regexp codes.
 335             (setq i 0)
 336             (while (< i len)
 337               (let ((ch (aref pattern i)))
 338                 (if (= ch ??)
 339                     (setq pattern (concat (substring pattern 0 i)
 340                                           "\\(.\\)"
 341                                           (substring pattern (1+ i)))
 342                           len (+ len 4)
 343                           i (+ i 4))
 344                   (if (= ch ?*)
 345                       (setq pattern (concat (substring pattern 0 i)
 346                                             "\\(.*\\)"
 347                                             (substring pattern (1+ i)))
 348                             len (+ len 5)
 349                             i (+ i 5))
 350                     (setq i (1+ i))))))
 351
 352             ;; Set each element of xlfd-fields to proper strings.
 353             (if (string-match pattern fontname)
 354                 ;; The regular expression PATTERN matchs the full XLFD
 355                 ;; name.  Set elements that correspond to a wild card
 356                 ;; in PATTERN to "*", set the other elements to the
 357                 ;; exact strings in PATTERN.
 358                 (let ((l (cdr (cdr (match-data)))))
 359                   (setq i 0)
 360                   (while (< i 14)
 361                     (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
 362                         (progn
 363                           (aset xlfd-fields i (cdr (aref xlfd-fields i)))
 364                           (setq i (1+ i)))
 365                       (if (< (car (aref xlfd-fields i)) (car (cdr l)))
 366                           (progn
 367                             (aset xlfd-fields i "*")
 368                             (setq i (1+ i)))
 369                         (setq l (cdr (cdr l)))))))
 370               ;; Set each element of xlfd-fields to the exact string
 371               ;; in the corresonding fields in full XLFD name.
 372               (setq i 0)
 373               (while (< i 14)
 374                 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
 375                 (setq i (1+ i))))
 376             xlfd-fields)))))
 377
 378 ;; Replace consecutive wild-cards (`*') in NAME to one.
 379 ;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1"
 380 (defsubst x-reduce-font-name (name)
 381   (while (string-match "-\\*-\\(\\*-\\)+" name)
 382     (setq name (replace-match "-*-" t t name)))
 383   name)
 384
 385 (defun x-compose-font-name (fields &optional reduce)
 386   "Compose X's fontname from FIELDS.
 387 FIELDS is a vector of XLFD fields, of length 14.
 388 If a field is nil, wild-card letter `*' is embedded.
 389 Optional argument REDUCE exists just for backward compatibility,
 390 and is always ignored."
 391   (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-")))
 392
 393
 394 (defun x-must-resolve-font-name (xlfd-fields)
 395   "Like `x-resolve-font-name', but always return a font name.
 396 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
 397 If no font matching XLFD-FIELDS is available, successively replace
 398 parts of the font name pattern with \"*\" until some font is found.
 399 Value is name of that font."
 400   (let ((ascii-font nil) (index 0))
 401     (while (and (null ascii-font) (<= index xlfd-regexp-encoding-subnum))
 402       (let ((pattern (x-compose-font-name xlfd-fields)))
 403         (condition-case nil
 404             (setq ascii-font (x-resolve-font-name pattern))
 405           (error
 406            (message "Warning: no fonts matching `%s' available" pattern)
 407            (aset xlfd-fields index "*")
 408            (setq index (1+ index))))))
 409     (unless ascii-font
 410       (error "No fonts found"))
 411     ascii-font))
 412
 413
 414 (defun x-complement-fontset-spec (xlfd-fields fontlist)
 415   "Complement FONTLIST for charsets based on XLFD-FIELDS and return it.
 416 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
 417 FONTLIST is an alist of charsets vs the corresponding font names.
 418
 419 The fonts are complemented as below.
 420
 421 If FONTLIST doesn't specify a font for ASCII charset, generate a font
 422 name for the charset from XLFD-FIELDS, and add that information to
 423 FONTLIST.
 424
 425 If a font specifid for ASCII supports the other charsets (see the
 426 variable `x-font-name-charset-alist'), add that information to FONTLIST."
 427   (let* ((slot (assq 'ascii fontlist))
 428          (ascii-font (cdr slot))
 429          ascii-font-spec)
 430     (if ascii-font
 431         (setcdr slot (setq ascii-font (x-resolve-font-name ascii-font)))
 432       ;; If font for ASCII is not specified, add it.
 433       (aset xlfd-fields xlfd-regexp-registry-subnum "iso8859")
 434       (aset xlfd-fields xlfd-regexp-encoding-subnum "1")
 435       (setq ascii-font (x-must-resolve-font-name xlfd-fields))
 436       (setq fontlist (cons (cons 'ascii ascii-font) fontlist)))
 437
 438     ;; If the font for ASCII also supports the other charsets, and
 439     ;; they are not specified in FONTLIST, add them.
 440     (setq xlfd-fields (x-decompose-font-name ascii-font))
 441     (if (not xlfd-fields)
 442         (setq ascii-font-spec ascii-font)
 443       (setq ascii-font-spec
 444             (cons (format "%s-%s"
 445                           (aref xlfd-fields xlfd-regexp-foundry-subnum)
 446                           (aref xlfd-fields xlfd-regexp-family-subnum))
 447                   (format "%s-%s"
 448                           (aref xlfd-fields xlfd-regexp-registry-subnum)
 449                           (aref xlfd-fields xlfd-regexp-encoding-subnum)))))
 450     (let ((tail x-font-name-charset-alist)
 451           elt)
 452       (while tail
 453         (setq elt (car tail) tail (cdr tail))
 454         (if (string-match (car elt) ascii-font)
 455             (let ((charsets (cdr elt))
 456                   charset)
 457               (while charsets
 458                 (setq charset (car charsets) charsets (cdr charsets))
 459                 (or (assq charset fontlist)
 460                     (setq fontlist
 461                           (cons (cons charset ascii-font-spec) fontlist))))))))
 462
 463     fontlist))
 464
 465 (defun fontset-name-p (fontset)
 466   "Return non-nil if FONTSET is valid as fontset name.
 467 A valid fontset name should conform to XLFD (X Logical Font Description)
 468 with \"fontset\" in `<CHARSET_REGISTRY>' field."
 469   (and (string-match xlfd-tight-regexp fontset)
 470        (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
 471                 "fontset")))
 472
 473 ;; Return a list to be appended to `x-fixed-font-alist' when
 474 ;; `mouse-set-font' is called.
 475 (defun generate-fontset-menu ()
 476   (let ((fontsets (fontset-list))
 477         fontset-name
 478         l)
 479     (while fontsets
 480       (setq fontset-name (car fontsets) fontsets (cdr fontsets))
 481       (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
 482     (cons "Fontset"
 483           (sort l (function (lambda (x y) (string< (car x) (car y))))))))
 484
 485 (defun fontset-plain-name (fontset)
 486   "Return a plain and descriptive name of FONTSET."
 487   (if (not (setq fontset (query-fontset fontset)))
 488       (error "Invalid fontset: %s" fontset))
 489   (let ((xlfd-fields (x-decompose-font-name fontset)))
 490     (if xlfd-fields
 491         (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
 492               (slant  (aref xlfd-fields xlfd-regexp-slant-subnum))
 493               (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
 494               (size   (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
 495               (charset (aref xlfd-fields xlfd-regexp-registry-subnum))
 496               (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum))
 497               name)
 498           (if (not (string= "fontset" charset))
 499               fontset
 500             (if (> (string-to-number size) 0)
 501                 (setq name (format "%s: %s-dot" nickname size))
 502               (setq name nickname))
 503             (cond ((string-match "^medium$" weight)
 504                    (setq name (concat name " " "medium")))
 505                   ((string-match "^bold$\\|^demibold$" weight)
 506                    (setq name (concat name " " weight))))
 507             (cond ((string-match "^i$" slant)
 508                    (setq name (concat name " " "italic")))
 509                   ((string-match "^o$" slant)
 510                    (setq name (concat name " " "slant")))
 511                   ((string-match "^ri$" slant)
 512                    (setq name (concat name " " "reverse italic")))
 513                   ((string-match "^ro$" slant)
 514                    (setq name (concat name " " "reverse slant"))))
 515             name))
 516       fontset)))
 517
 518
 519 (defun create-fontset-from-fontset-spec (fontset-spec
 520                                          &optional style-variant noerror)
 521   "Create a fontset from fontset specification string FONTSET-SPEC.
 522 FONTSET-SPEC is a string of the format:
 523         FONTSET-NAME,CHARSET0:FONT0,CHARSET1:FONT1, ...
 524 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
 525
 526 Optional 2nd arg exists just for backward compatibility, and is ignored.
 527
 528 If this function attempts to create already existing fontset, an error is
 529 signaled unless the optional 3rd argument NOERROR is non-nil.
 530
 531 It returns a name of the created fontset."
 532   (if (not (string-match "^[^,]+" fontset-spec))
 533       (error "Invalid fontset spec: %s" fontset-spec))
 534   (setq fontset-spec (downcase fontset-spec))
 535   (let ((idx (match-end 0))
 536         (name (match-string 0 fontset-spec))
 537         xlfd-fields charset fontlist ascii-font)
 538     (if (query-fontset name)
 539         (or noerror
 540             (error "Fontset \"%s\" already exists" name))
 541       (setq xlfd-fields (x-decompose-font-name name))
 542       (or xlfd-fields
 543           (error "Fontset \"%s\" not conforming to XLFD" name))
 544
 545       ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
 546       (while (string-match "[, \t\n]*\\([^:]+\\):[ \t]*\\([^,]+\\)"
 547                            fontset-spec idx)
 548         (setq idx (match-end 0))
 549         (setq charset (intern (match-string 1 fontset-spec)))
 550         (if (charsetp charset)
 551             (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
 552                                  fontlist))))
 553       (setq ascii-font (cdr (assq 'ascii fontlist)))
 554
 555       ;; Complement FONTLIST.
 556       (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))
 557
 558       (new-fontset name fontlist)
 559
 560       ;; Define the short name alias.
 561       (if (and (string-match "fontset-.*$" name)
 562                (not (assoc name fontset-alias-alist)))
 563           (let ((alias (match-string 0 name)))
 564             (or (rassoc alias fontset-alias-alist)
 565                 (setq fontset-alias-alist
 566                       (cons (cons name alias) fontset-alias-alist)))))
 567
 568       ;; Define the ASCII font name alias.
 569       (or ascii-font
 570           (setq ascii-font (cdr (assq 'ascii fontlist))))
 571       (or (rassoc ascii-font fontset-alias-alist)
 572           (setq fontset-alias-alist
 573                 (cons (cons name ascii-font)
 574                       fontset-alias-alist))))
 575
 576     name))
 577
 578 (defun create-fontset-from-ascii-font (font &optional resolved-font
 579                                             fontset-name)
 580   "Create a fontset from an ASCII font FONT.
 581
 582 Optional 2nd arg RESOLVED-FONT is a resolved name of FONT.
 583 If omitted, `x-resolve-font-name' is called to get the resolved name.
 584 At this time, if FONT is not available, an error is signaled.
 585
 586 Optional 3rd arg FONTSET-NAME is a string to be used in
 587 `<CHARSET_ENCODING>' fields of a new fontset name.  If it is omitted,
 588 an appropriate name is generated automatically.
 589
 590 It returns a name of the created fontset."
 591   (setq font (downcase font))
 592   (if resolved-font
 593       (setq resolved-font (downcase resolved-font))
 594     (setq resolved-font (downcase (x-resolve-font-name font))))
 595   (let ((xlfd (x-decompose-font-name font))
 596         (resolved-xlfd (x-decompose-font-name resolved-font))
 597         fontset fontset-spec)
 598     (aset xlfd xlfd-regexp-foundry-subnum nil)
 599     (aset xlfd xlfd-regexp-family-subnum nil)
 600     (aset xlfd xlfd-regexp-registry-subnum "fontset")
 601     (if fontset-name
 602         (setq fontset-name (downcase fontset-name))
 603       (setq fontset-name
 604             (format "%s_%s_%s"
 605                     (aref resolved-xlfd xlfd-regexp-registry-subnum)
 606                     (aref resolved-xlfd xlfd-regexp-encoding-subnum)
 607                     (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
 608     (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
 609     (setq fontset (x-compose-font-name xlfd))
 610     (or (query-fontset fontset)
 611         (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)))))
 612
 613 \f
 614 ;; Create standard fontset from 16 dots fonts which are the most widely
 615 ;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are
 616 ;; specified here because FAMILY of those fonts are not "fixed" in
 617 ;; many cases.
 618 (defvar standard-fontset-spec
 619   (purecopy "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
 620         chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
 621         korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
 622         chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
 623         chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
 624         chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
 625         chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
 626         chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
 627         chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
 628         chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7")
 629   "String of fontset spec of the standard fontset.
 630 You have the biggest chance to display international characters
 631 with correct glyphs by using the standard fontset.
 632 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 633
 634 ;; Create fontsets from X resources of the name `fontset-N (class
 635 ;; Fontset-N)' where N is integer 0, 1, ...
 636 ;; The values of the resources the string of the same format as
 637 ;; `standard-fontset-spec'.
 638
 639 (defun create-fontset-from-x-resource ()
 640   (let ((idx 0)
 641         fontset-spec)
 642     (while (setq fontset-spec (x-get-resource (format "fontset-%d" idx)
 643                                               (format "Fontset-%d" idx)))
 644       (create-fontset-from-fontset-spec fontset-spec t 'noerror)
 645       (setq idx (1+ idx)))))
 646
 647 ;;
 648 (provide 'fontset)
 649
 650 ;;; arch-tag: bb53e629-0234-403c-950e-551e61554849
 651 ;;; fontset.el ends here