code.delx.au - gnu-emacs/blob - lisp/international/fontset.el

   1 ;;; fontset.el --- commands for handling fontset
   2
   3 ;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   5 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   6
   7 ;; Keywords: mule, i18n, fontset
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 ;; Setup font-encoding-alist for all known encodings.
  31
  32 (setq font-encoding-alist
  33       '(("iso8859-1$" . iso-8859-1)
  34         ("iso8859-2$" . iso-8859-2)
  35         ("iso8859-3$" . iso-8859-3)
  36         ("iso8859-4$" . iso-8859-4)
  37         ("iso8859-5$" . iso-8859-5)
  38         ("iso8859-6$" . iso-8859-6)
  39         ("iso8859-7$" . iso-8859-7)
  40         ("iso8859-8$" . iso-8859-8)
  41         ("iso8859-9$" . iso-8859-9)
  42         ("iso8859-10$" . iso-8859-10)
  43         ("iso8859-11$" . iso-8859-11)
  44         ("iso8859-13$" . iso-8859-13)
  45         ("iso8859-14$" . iso-8859-14)
  46         ("iso8859-15$" . iso-8859-15)
  47         ("gb2312.1980" . chinese-gb2312)
  48         ("jisx0208.1978" . japanese-jisx0208-1978)
  49         ("jisx0208" . japanese-jisx0208)
  50         ("jisx0201" . jisx0201)
  51         ("jisx0212" . japanese-jisx0212)
  52         ("ksc5601.1987" . korean-ksc5601)
  53         ("cns11643.1992.*1" . chinese-cns11643-1)
  54         ("cns11643.1992.*2" . chinese-cns11643-2)
  55         ("cns11643.1992.*3" . chinese-cns11643-3)
  56         ("cns11643.1992.*4" . chinese-cns11643-4)
  57         ("cns11643.1992.*5" . chinese-cns11643-5)
  58         ("cns11643.1992.*6" . chinese-cns11643-6)
  59         ("cns11643.1992.*7" . chinese-cns11643-7)
  60         ("big5" . big5)
  61         ("sisheng_cwnn" . chinese-sisheng)
  62         ("viscii" . viscii)
  63         ("tis620" . tis620-2533)
  64         ("mulearabic-0" . arabic-digit)
  65         ("mulearabic-1" . arabic-1-column)
  66         ("mulearabic-2" . arabic-2-column)
  67         ("muleipa" . ipa)
  68         ("ethiopic-unicode" . ethiopic)
  69         ("is13194-devanagari" . indian-is13194)
  70         ("devanagari-cdac" . devanagari-glyph)
  71 ;; These would be necessary for supporting the complete set of Indian
  72 ;; scripts.  See also mule-conf.el.
  73 ;;      ("sanskrit-cdac" . sanskrit-glyph)
  74 ;;      ("bengali-cdac" . bengali-glyph)
  75 ;;      ("assamese-cdac" . assamese-glyph)
  76 ;;      ("punjabi-cdac" . punjabi-glyph)
  77 ;;      ("gujarati-cdac" . gujarati-glyph)
  78 ;;      ("oriya-cdac" . oriya-glyph)
  79 ;;      ("tamil-cdac" . tamil-glyph)
  80 ;;      ("telugu-cdac" . telugu-glyph)
  81 ;;      ("kannada-cdac" . kannada-glyph)
  82 ;;      ("malayalam-cdac" . malayalam-glyph)
  83         ("muleindian-2" . indian-2-column)
  84         ("muleindian-1" . indian-1-column)
  85         ("mulelao-1" . mule-lao)
  86         ("muletibetan-2" . tibetan)
  87         ("muletibetan-1" . tibetan-1-column)
  88         ("jisx0213.2000-1" . japanese-jisx0213-1)
  89         ("jisx0213.2000-2" . japanese-jisx0213-2)
  90         ("abobe-symbol" . symbol)
  91         ("iso10646-1" . (unicode . nil))
  92         ("iso10646.indian-1" . (unicode . nil))))
  93
  94
  95 ;; Set standard fontname specification of characters in the default
  96 ;; fontset to find an appropriate font for each script/charset.  The
  97 ;; specification has the form ((SCRIPT FONT-SPEC ...) ...), where
  98 ;; FONT-SPEC is:
  99 ;;      a vector [ FAMILY WEIGHT SLANT ADSTYLE REGISTRY ],
 100 ;;      or a cons (FAMILY . REGISTRY),
 101 ;;      or a string FONT-NAME.
 102 ;;
 103 ;; FAMILY, WEIGHT, SLANT, and ADSTYLE may be nil, in which case, the
 104 ;; the corresponding name of default face is used.  If REGISTRY
 105 ;; contains a character `-', the string before that is embedded in
 106 ;; `CHARSET_REGISTRY' field, and the string after that is embedded in
 107 ;; `CHARSET_ENCODING' field.  If it does not contain `-', the whole
 108 ;; string is embedded in `CHARSET_REGISTRY' field, and a wild card
 109 ;; character `*' is embedded in `CHARSET_ENCODING' field.
 110 ;;
 111 ;; SCRIPT is a symbol that appears as an element of the char table
 112 ;; `char-script-table'.  SCRIPT may be a charset specifying the range
 113 ;; of characters.
 114
 115 (new-fontset
 116  "fontset-default"
 117  '( ;; for each script
 118    (latin (nil . "ISO8859-1")
 119           (nil . "ISO8859-2")
 120           (nil . "ISO8859-3")
 121           (nil . "ISO8859-4")
 122           (nil . "ISO8859-9")
 123           (nil . "ISO8859-10")
 124           (nil . "ISO8859-13")
 125           (nil . "ISO8859-14")
 126           (nil . "ISO8859-15")
 127           (nil . "VISCII1.1-1"))
 128
 129    (thai (nil . "TIS620*")
 130          (nil . "ISO8859-11"))
 131
 132    (devanagari (nil . "iso10646.indian-1"))
 133
 134    (lao  (nil . "MuleLao-1"))
 135
 136    ;; both for script and charset.
 137    (tibetan (nil . "muletibetan-2"))
 138
 139    ;; both for script and charset.
 140    (ethiopic (nil . "ethiopic-unicode"))
 141
 142    (greek (nil . "ISO8859-7"))
 143
 144    (cyrillic (nil . "ISO8859-5"))
 145
 146    (arabic (nil . "MuleArabic-0")
 147            (nil . "MuleArabic-1")
 148            (nil . "MuleArabic-2")
 149            (nil . "ISO8859-6"))
 150
 151    (hebrew (nil . "ISO8859-8"))
 152
 153    (kana (nil . "JISX0208*")
 154          (nil . "GB2312.1980-0")
 155          (nil . "KSC5601.1987*")
 156          (nil . "JISX0201*"))
 157
 158    (bopomofo (nil . "sisheng_cwnn-0"))
 159
 160    (han (nil . "GB2312.1980-0")
 161         (nil . "JISX0208*")
 162         (nil . "JISX0212*")
 163         (nil . "big5*")
 164         (nil . "KSC5601.1987*")
 165         (nil . "CNS11643.1992-1")
 166         (nil . "CNS11643.1992-2")
 167         (nil . "CNS11643.1992-3")
 168         (nil . "CNS11643.1992-4")
 169         (nil . "CNS11643.1992-5")
 170         (nil . "CNS11643.1992-6")
 171         (nil . "CNS11643.1992-7")
 172         (nil . "gbk-0")
 173         (nil . "JISX0213.2000-1")
 174         (nil . "JISX0213.2000-2"))
 175
 176    (cjk-misc (nil . "GB2312.1980-0")
 177              (nil . "JISX0208*")
 178              (nil . "JISX0212*")
 179              (nil . "big5*")
 180              (nil . "KSC5601.1987*")
 181              (nil . "CNS11643.1992-1")
 182              (nil . "CNS11643.1992-2")
 183              (nil . "CNS11643.1992-3")
 184              (nil . "CNS11643.1992-4")
 185              (nil . "CNS11643.1992-5")
 186              (nil . "CNS11643.1992-6")
 187              (nil . "CNS11643.1992-7")
 188              (nil . "gbk-0")
 189              (nil . "JISX0213.2000-1")
 190              (nil . "JISX0213.2000-2"))
 191
 192    (hangul (nil . "KSC5601.1987-0"))
 193
 194    ;; for each charset
 195    (ascii (nil . "ISO8859-1"))
 196    (arabic-digit ("*" . "MuleArabic-0"))
 197    (arabic-1-column ("*" . "MuleArabic-1"))
 198    (arabic-2-column ("*" . "MuleArabic-2"))
 199    (indian-is13194 (nil . "is13194-devanagari"))
 200    (indian-1-column ("*" . "muleindian-2"))
 201    (devanagari-glyph ("altsys-dv_ttsurekh" . "devanagari-cdac"))
 202 ;; These would be necessary for supporting the complete set of Indian
 203 ;; scripts.
 204    ;; fixme: family name
 205 ;;    (sanskrit-glyph ("*" . "sanskrit-cdac"))
 206 ;;    (bengali-glyph ("*" . "bengali-cdac"))
 207 ;;    (assamese-glyph ("*" . "assamese-cdac"))
 208 ;;    (punjabi-glyph ("*" . "punjabi-cdac"))
 209 ;;    (gujarati-glyph ("*" . "gujarati-cdac"))
 210 ;;    (oriya-glyph ("*" . "oriya-cdac"))
 211 ;;    (tamil-glyph ("*" . "tamil-cdac"))
 212 ;;    (telugu-glyph ("*" . "telugu-cdac"))
 213 ;;    (kannada-glyph ("*" . "kannada-cdac"))
 214    (malayalam-glyph ("altsys-ml_ttkarthika" . "malayalam-cdac"))
 215    (ipa (nil . "MuleIPA-1"))
 216    ))
 217
 218 ;; Append Unicode fonts.
 219 ;; This may find fonts with more variants (bold, italic) but which don't cover
 220 ;; many characters.
 221 (set-fontset-font "fontset-default" '(0 . #xFFFF)
 222                   '(nil . "iso10646-1") nil 'append)
 223 ;; These may find fonts that cover many characters but with fewer variants.
 224 (set-fontset-font "fontset-default" '(0 . #xFFFF)
 225                   '("gnu-unifont" . "iso10646-1") nil 'append)
 226 (set-fontset-font "fontset-default" '(0 . #xFFFF)
 227                   '("mutt-clearlyu" . "iso10646-1") nil 'append)
 228
 229 ;; These are the registered registries/encodings from
 230 ;; ftp://ftp.x.org/pub/DOCS/registry 2001/06/01
 231
 232 ;; Name                                            Reference
 233 ;; ----                                            ---------
 234 ;; "DEC"                                           [27]
 235 ;;         registry prefix
 236 ;; "DEC.CNS11643.1986-2"                           [53]
 237 ;;         CNS11643 2-plane using the encoding
 238 ;;         suggested in that standard
 239 ;; "DEC.DTSCS.1990-2"                              [54]
 240 ;;         DEC Taiwan Supplemental Character Set
 241 ;; "fujitsu.u90x01.1991-0"                         [87]
 242 ;; "fujitsu.u90x03.1991-0"                         [87]
 243 ;; "GB2312.1980-0"                                 [39],[12]
 244 ;;         China (PRC) Hanzi, GL encoding
 245 ;; "GB2312.1980-1"                                 [39]
 246 ;;         (deprecated)
 247 ;;         China (PRC) Hanzi, GR encoding
 248 ;; "HP-Arabic8"                                    [36]
 249 ;;         HPARABIC8 8-bit character set
 250 ;; "HP-East8"                                      [36]
 251 ;;         HPEAST8 8-bit character set
 252 ;; "HP-Greek8"                                     [36]
 253 ;;         HPGREEK8 8-bit character set
 254 ;; "HP-Hebrew8"                                    [36]
 255 ;;         HPHEBREW8 8-bit character set
 256 ;; "HP-Japanese15"                                 [36]
 257 ;;         HPJAPAN15 15-bit characer set,
 258 ;;         modified from industry defacto
 259 ;;         standard Shift-JIS
 260 ;; "HP-Kana8"                                      [36]
 261 ;;         HPKANA8 8-bit character set
 262 ;; "HP-Korean15"                                   [36]
 263 ;;         HPKOREAN15 15-bit character set
 264 ;; "HP-Roman8"                                     [36]
 265 ;;         HPROMAN8 8-bit character set
 266 ;; "HP-SChinese15"                                 [36]
 267 ;;         HPSCHINA15 15-bit character set for
 268 ;;         support of Simplified Chinese
 269 ;; "HP-TChinese15"                                 [36]
 270 ;;         HPTCHINA15 15-bit character set for
 271 ;;         support of Traditional Chinese
 272 ;; "HP-Turkish8"                                   [36]
 273 ;;         HPTURKISH8 8-bit character set
 274 ;; "IPSYS"                                         [59]
 275 ;;         registry prefix
 276 ;; "IPSYS.IE-1"                                    [59]
 277 ;; "ISO2022"<REG>"-"<ENC>                          [44]
 278 ;; "ISO646.1991-IRV"                               [107]
 279 ;;         ISO 646 International Reference Version
 280 ;; "ISO8859-1"                                     [15],[12]
 281 ;;         ISO Latin alphabet No. 1
 282 ;; "ISO8859-2"                                     [15],[12]
 283 ;;         ISO Latin alphabet No. 2
 284 ;; "ISO8859-3"                                     [15],[12]
 285 ;;         ISO Latin alphabet No. 3
 286 ;; "ISO8859-4"                                     [15],[12]
 287 ;;         ISO Latin alphabet No. 4
 288 ;; "ISO8859-5"                                     [15],[12]
 289 ;;         ISO Latin/Cyrillic alphabet
 290 ;; "ISO8859-6"                                     [15],[12]
 291 ;;         ISO Latin/Arabic alphabet
 292 ;; "ISO8859-7"                                     [15],[12]
 293 ;;         ISO Latin/Greek alphabet
 294 ;; "ISO8859-8"                                     [15],[12]
 295 ;;         ISO Latin/Hebrew alphabet
 296 ;; "ISO8859-9"                                     [15],[12]
 297 ;;         ISO Latin alphabet No. 5
 298 ;; "ISO8859-10"                                    [15],[12]
 299 ;;         ISO Latin alphabet No. 6
 300 ;; "ISO8859-13"                                    [15],[12]
 301 ;;         ISO Latin alphabet No. 7
 302 ;; "ISO8859-14"                                    [15],[12]
 303 ;;         ISO Latin alphabet No. 8
 304 ;; "ISO8859-15"                                    [15],[12]
 305 ;;         ISO Latin alphabet No. 9
 306 ;; "FCD8859-15"                                    [7]
 307 ;;         (deprecated)
 308 ;;         ISO Latin alphabet No. 9, Final Committee Draft
 309 ;; "ISO10646-1"                                    [133]
 310 ;;         Unicode Universal Multiple-Octet Coded Character Set
 311 ;; "ISO10646-MES"                                  [133]
 312 ;;         (deprecated)
 313 ;;         Unicode Minimum European Subset
 314 ;; "JISX0201.1976-0"                               [38],[12]
 315 ;;         8-Bit Alphanumeric-Katakana Code
 316 ;; "JISX0208.1983-0"                               [40],[12]
 317 ;;         Japanese Graphic Character Set,
 318 ;;         GL encoding
 319 ;; "JISX0208.1990-0"                               [71]
 320 ;;         Japanese Graphic Character Set,
 321 ;;         GL encoding
 322 ;; "JISX0208.1983-1"                               [40]
 323 ;;         (deprecated)
 324 ;;         Japanese Graphic Character Set,
 325 ;;         GR encoding
 326 ;; "JISX0212.1990-0"                               [72]
 327 ;;         Supplementary Japanese Graphic Character Set,
 328 ;;         GL encoding
 329 ;; "KOI8-R"                                        [119]
 330 ;;         Cyrillic alphabet
 331 ;; "KSC5601.1987-0"                                [41],[12]
 332 ;;         Korean Graphic Character Set,
 333 ;;         GL encoding
 334 ;; "KSC5601.1987-1"                                [41]
 335 ;;         (deprecated)
 336 ;;         Korean Graphic Character Set,
 337 ;;         GR encoding
 338 ;; "omron_CNS11643-0"                              [45]
 339 ;; "omron_CNS11643-1"                              [45]
 340 ;; "omron_BIG5-0"                                  [45]
 341 ;; "omron_BIG5-1"                                  [45]
 342 ;; "wn.tamil.1993"                                 [103]
 343
 344 (defun set-font-encoding (pattern charset)
 345   "Set arguments in `font-encoding-alist' (which see)."
 346   (let ((slot (assoc pattern font-encoding-alist)))
 347     (if slot
 348         (setcdr slot charset)
 349       (setq font-encoding-alist
 350             (cons (cons pattern charset) font-encoding-alist)))))
 351
 352 ;; Setting for suppressing XLoadQueryFont on big fonts.
 353 (setq x-pixel-size-width-font-regexp
 354       "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
 355
 356 ;; These fonts require vertical centering.
 357 (setq vertical-centering-font-regexp
 358       "gb2312\\|jisx0208\\|jisx0212\\|ksc5601\\|cns11643\\|big5")
 359
 360 ;; CDAC fonts are actually smaller than their design sizes.
 361 (setq face-font-rescale-alist
 362       '(("-cdac$" . 1.3)))
 363
 364 (defvar x-font-name-charset-alist nil
 365   "This variable has no meaning now.  Just kept for backward compatibility.")
 366
 367 ;;; XLFD (X Logical Font Description) format handler.
 368
 369 ;; Define XLFD's field index numbers.           ; field name
 370 (defconst xlfd-regexp-family-subnum 0)          ; FOUNDRY and FAMILY
 371 (defconst xlfd-regexp-weight-subnum 1)          ; WEIGHT_NAME
 372 (defconst xlfd-regexp-slant-subnum 2)           ; SLANT
 373 (defconst xlfd-regexp-swidth-subnum 3)          ; SETWIDTH_NAME
 374 (defconst xlfd-regexp-adstyle-subnum 4)         ; ADD_STYLE_NAME
 375 (defconst xlfd-regexp-pixelsize-subnum 5)       ; PIXEL_SIZE
 376 (defconst xlfd-regexp-pointsize-subnum 6)       ; POINT_SIZE
 377 (defconst xlfd-regexp-resx-subnum 7)            ; RESOLUTION_X
 378 (defconst xlfd-regexp-resy-subnum 8)            ; RESOLUTION_Y
 379 (defconst xlfd-regexp-spacing-subnum 8)         ; SPACING
 380 (defconst xlfd-regexp-avgwidth-subnum 10)       ; AVERAGE_WIDTH
 381 (defconst xlfd-regexp-registry-subnum 11)       ; REGISTRY and ENCODING
 382
 383 ;; Regular expression matching against a fontname which conforms to
 384 ;; XLFD (X Logical Font Description).  All fields in XLFD should be
 385 ;; not be omitted (but can be a wild card) to be matched.
 386 (defconst xlfd-tight-regexp
 387   "^\
 388 -\\([^-]*-[^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
 389 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
 390 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*-[^-]*\\)$")
 391
 392 ;; Regular expression matching against a fontname which conforms to
 393 ;; XLFD (X Logical Font Description).  All fields in XLFD from FOUNDRY
 394 ;; to ADSTYLE, REGISTRY, and ENCODING should be not be omitted (but
 395 ;; can be a wild card) to be matched.
 396 (defconst xlfd-style-regexp
 397   "^\
 398 -\\([^-]*-[^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-.*\
 399 -\\([^-]*-[^-]*\\)$")
 400
 401 ;; List of field numbers of XLFD whose values are numeric.
 402 (defconst xlfd-regexp-numeric-subnums
 403   (list xlfd-regexp-pixelsize-subnum    ;5
 404         xlfd-regexp-pointsize-subnum    ;6
 405         xlfd-regexp-resx-subnum         ;7
 406         xlfd-regexp-resy-subnum         ;8
 407         xlfd-regexp-avgwidth-subnum     ;10
 408         ))
 409
 410 (defun x-decompose-font-name (pattern)
 411   "Decompose PATTERN into XLFD fields and return a vector of the fields.
 412 The length of the vector is 12.
 413 The FOUNDRY and FAMILY fields are concatinated and stored in the first
 414 element of the vector.
 415 The REGISTRY and ENCODING fields are concatinated and stored in the last
 416 element of the vector.
 417
 418 Return nil if PATTERN doesn't conform to XLFD."
 419   (if (string-match xlfd-tight-regexp pattern)
 420       (let ((xlfd-fields (make-vector 12 nil)))
 421         (dotimes (i 12)
 422           (aset xlfd-fields i (match-string (1+ i) pattern)))
 423         (dotimes (i 12)
 424           (if (string-match "^[*-]+$" (aref xlfd-fields i))
 425               (aset xlfd-fields i nil)))
 426         xlfd-fields)))
 427
 428 (defun x-compose-font-name (fields &optional reduce)
 429   "Compose X fontname from FIELDS.
 430 FIELDS is a vector of XLFD fields, the length 12.
 431 If a field is nil, wild-card letter `*' is embedded.
 432 Optional argument REDUCE is always ignored.  It exists just for
 433 backward compatibility."
 434   (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-")))
 435
 436 (defun x-must-resolve-font-name (xlfd-fields)
 437   "Like `x-resolve-font-name', but always return a font name.
 438 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
 439 If no font matching XLFD-FIELDS is available, successively replace
 440 parts of the font name pattern with \"*\" until some font is found.
 441 Value is name of that font."
 442   (let ((ascii-font nil) (index 0))
 443     (while (and (null ascii-font) (<= index xlfd-regexp-registry-subnum))
 444       (let ((pattern (x-compose-font-name xlfd-fields)))
 445         (condition-case nil
 446             (setq ascii-font (x-resolve-font-name pattern))
 447           (error
 448            (message "Warning: no fonts matching `%s' available" pattern)
 449            (aset xlfd-fields index "*")
 450            (setq index (1+ index))))))
 451     (unless ascii-font
 452       (error "No fonts founds"))
 453     ascii-font))
 454
 455
 456 (defun x-complement-fontset-spec (xlfd-fields fontlist)
 457   "Complement elements of FONTLIST based on XLFD-FIELDS.
 458 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
 459 FONTLIST is an alist of script names vs the corresponding font names.
 460
 461 The font names are complemented as below.
 462
 463 If a font name matches `xlfd-style-regexp', each field of wild card is
 464 replaced by the corresponding fields in XLFD-FIELDS."
 465   (let ((default-spec (vector (aref xlfd-fields xlfd-regexp-family-subnum)
 466                               (aref xlfd-fields xlfd-regexp-weight-subnum)
 467                               (aref xlfd-fields xlfd-regexp-slant-subnum)
 468                               (aref xlfd-fields xlfd-regexp-swidth-subnum)
 469                               (aref xlfd-fields xlfd-regexp-adstyle-subnum)
 470                               (aref xlfd-fields xlfd-regexp-registry-subnum))))
 471     (dolist (elt fontlist)
 472       (let ((name (cadr elt))
 473             font-spec)
 474         (when (or (string-match xlfd-style-regexp name)
 475                   (and (setq name (car (x-list-fonts name nil nil 1)))
 476                        (string-match xlfd-style-regexp name)))
 477           (setq font-spec (make-vector 6 nil))
 478           (dotimes (i 6)
 479             (aset font-spec i (match-string (1+ i) name)))
 480           (dotimes (i 6)
 481             (if (string-match "^[*-]+$" (aref font-spec i))
 482                 (aset font-spec i (aref default-spec i))))
 483           (setcar (cdr elt) font-spec))))
 484
 485     fontlist))
 486
 487 (defun fontset-name-p (fontset)
 488   "Return non-nil if FONTSET is valid as fontset name.
 489 A valid fontset name should conform to XLFD (X Logical Font Description)
 490 with \"fontset\" in `<CHARSET_REGISTRY> field."
 491   (and (string-match xlfd-tight-regexp fontset)
 492        (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
 493                 "fontset")))
 494
 495 (defun generate-fontset-menu ()
 496   "Return list to be appended to `x-fixed-font-alist'.
 497 Done when `mouse-set-font' is called."
 498   (let (l)
 499     (dolist (fontset (fontset-list))
 500       (or (string-match "fontset-default$" fontset)
 501           (push (list (fontset-plain-name fontset) fontset) l)))
 502     (cons "Fontset"
 503           (sort l #'(lambda (x y) (string< (car x) (car y)))))))
 504
 505 (defun fontset-plain-name (fontset)
 506   "Return a plain and descriptive name of FONTSET."
 507   (if (not (setq fontset (query-fontset fontset)))
 508       (error "Invalid fontset: %s" fontset))
 509   (let ((xlfd-fields (x-decompose-font-name fontset)))
 510     (if xlfd-fields
 511         (let ((family (aref xlfd-fields xlfd-regexp-family-subnum))
 512               (weight (aref xlfd-fields xlfd-regexp-weight-subnum))
 513               (slant  (aref xlfd-fields xlfd-regexp-slant-subnum))
 514               (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
 515               (size   (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
 516               (nickname (aref xlfd-fields xlfd-regexp-registry-subnum))
 517               name)
 518           (if (not (string-match "^fontset-\\(.*\\)$" nickname))
 519               (setq nickname family)
 520             (setq nickname (match-string 1 nickname)))
 521           (if (and size (> (string-to-int size) 0))
 522               (setq name (format "%s: %s-dot" nickname size))
 523             (setq name nickname))
 524           (and weight
 525                (cond ((string-match "^medium$" weight)
 526                       (setq name (concat name " " "medium")))
 527                      ((string-match "^bold$\\|^demibold$" weight)
 528                       (setq name (concat name " " weight)))))
 529           (and slant
 530                (cond ((string-match "^i$" slant)
 531                       (setq name (concat name " " "italic")))
 532                      ((string-match "^o$" slant)
 533                       (setq name (concat name " " "slant")))
 534                      ((string-match "^ri$" slant)
 535                       (setq name (concat name " " "reverse italic")))
 536                      ((string-match "^ro$" slant)
 537                       (setq name (concat name " " "reverse slant")))))
 538           name)
 539       fontset)))
 540
 541 (defvar charset-script-alist
 542   '((ascii . latin)
 543     (latin-iso8859-1 . latin)
 544     (latin-iso8859-2 . latin)
 545     (latin-iso8859-3 . latin)
 546     (latin-iso8859-4 . latin)
 547     (latin-iso8859-9 . latin)
 548     (latin-iso8859-10 . latin)
 549     (latin-iso8859-13 . latin)
 550     (latin-iso8859-14 . latin)
 551     (latin-iso8859-15 . latin)
 552     (latin-iso8859-16 . latin)
 553     (latin-jisx0201 . latin)
 554     (thai-tis620 . thai)
 555     (cyrillic-iso8859-5 . cyrillic)
 556     (arabic-iso8859-6 . arabic)
 557     (greek-iso8859-7 . latin)
 558     (hebrew-iso8859-8 . latin)
 559     (katakana-jisx0201 . kana)
 560     (chinese-gb2312 . han)
 561     (chinese-big5-1 . han)
 562     (chinese-big5-2 . han)
 563     (chinese-cns11643-1 . han)
 564     (chinese-cns11643-2 . han)
 565     (chinese-cns11643-3 . han)
 566     (chinese-cns11643-4 . han)
 567     (chinese-cns11643-5 . han)
 568     (chinese-cns11643-6 . han)
 569     (chinese-cns11643-7 . han)
 570     (japanese-jisx0208 . han)
 571     (japanese-jisx0208-1978 . han)
 572     (japanese-jisx0212 . han)
 573     (japanese-jisx0213-1 . han)
 574     (japanese-jisx0213-2 . han)
 575     (korean-ksc5601 . hangul)
 576     (chinese-sisheng . bopomofo)
 577     (vietnamese-viscii-lower . latin)
 578     (vietnamese-viscii-upper . latin)
 579     (arabic-digit . arabic)
 580     (arabic-1-column . arabic)
 581     (arabic-2-column . arabic)
 582     (indian-is13194 . devanagari)
 583     (indian-glyph . devanagari)
 584     (indian-1-column . devanagari)
 585     (indian-2-column . devanagari)
 586     (tibetan-1-column . tibetan))
 587   "Alist of charsets vs the corresponding most appropriate scripts.
 588
 589 This alist is used by the function `create-fontset-from-fontset-spec'
 590 to map charsets to scripts.")
 591
 592 ;;;###autoload
 593 (defun create-fontset-from-fontset-spec (fontset-spec
 594                                          &optional style-variant noerror)
 595   "Create a fontset from fontset specification string FONTSET-SPEC.
 596 FONTSET-SPEC is a string of the format:
 597         FONTSET-NAME,SCRIPT-NAME0:FONT-NAME0,SCRIPT-NAME1:FONT-NAME1, ...
 598 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
 599
 600 When a frame uses the fontset as the `font' parameter, the frame's
 601 default font name is derived from FONTSET-NAME by substituting
 602 \"iso8859-1\" for the tail part \"fontset-XXX\".  But, if SCRIPT-NAMEn
 603 is \"ascii\", use the corresponding FONT-NAMEn as the default font
 604 name.
 605
 606 Optional 2nd and 3rd arguments are ignored.  They exist just for
 607 backward compatibility.
 608
 609 It returns a name of the created fontset.
 610
 611 For backward compatibility, SCRIPT-NAME may be a charset name, in
 612 which case, the corresponding script is decided by the variable
 613 `charset-script-alist' (which see)."
 614   (or (string-match "^[^,]+" fontset-spec)
 615       (error "Invalid fontset spec: %s" fontset-spec))
 616   (let ((idx (match-end 0))
 617         (name (match-string 0 fontset-spec))
 618         xlfd-fields script fontlist)
 619     (setq xlfd-fields (x-decompose-font-name name))
 620     (or xlfd-fields
 621         (error "Fontset name \"%s\" not conforming to XLFD" name))
 622
 623     ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
 624     (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
 625       (setq idx (match-end 0))
 626       (setq script (intern (match-string 1 fontset-spec)))
 627       (if (or (eq script 'ascii)
 628               (memq script (char-table-extra-slot char-script-table 0))
 629               (setq script (cdr (assq script charset-script-alist))))
 630           (setq fontlist (cons (list script (match-string 2 fontset-spec))
 631                                fontlist))))
 632
 633     ;; Complement FONTLIST.
 634     (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))
 635
 636     ;; Create a fontset.
 637     (new-fontset name fontlist)))
 638
 639 (defun create-fontset-from-ascii-font (font &optional resolved-font
 640                                             fontset-name)
 641   "Create a fontset from an ASCII font FONT.
 642
 643 Optional 1st arg RESOLVED-FONT is a resolved name of FONT.  If
 644 omitted, `x-resolve-font-name' is called to get the resolved name.  At
 645 this time, if FONT is not available, an error is signaled.
 646
 647 Optional 2nd arg FONTSET-NAME is a string to be used in
 648 `<CHARSET_ENCODING>' fields of a new fontset name.  If it is omitted,
 649 an appropriate name is generated automatically.
 650
 651 It returns a name of the created fontset."
 652   (setq font (downcase font))
 653   (setq resolved-font
 654         (downcase (or resolved-font (x-resolve-font-name font))))
 655   (let ((xlfd (x-decompose-font-name resolved-font))
 656         fontset)
 657     (if fontset-name
 658         (setq fontset-name (downcase fontset-name))
 659       (if (query-fontset "fontset-startup")
 660           (setq fontset-name
 661                 (subst-char-in-string
 662                  ?- ?_ (aref xlfd xlfd-regexp-registry-subnum) t))
 663         (setq fontset-name "startup")))
 664     (aset xlfd xlfd-regexp-registry-subnum
 665           (format "fontset-%s" fontset-name))
 666     (setq fontset (x-compose-font-name xlfd))
 667     (or (query-fontset fontset)
 668         (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)))))
 669
 670 \f
 671 ;; Create standard fontset from 16 dots fonts which are the most widely
 672 ;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are
 673 ;; specified here because FAMILY of those fonts are not "fixed" in
 674 ;; many cases.
 675 (defvar standard-fontset-spec
 676   (purecopy "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard")
 677   "String of fontset spec of the standard fontset.
 678 You have the biggest chance to display international characters
 679 with correct glyphs by using the standard fontset.
 680 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 681
 682
 683 ;; Create fontsets from X resources of the name `fontset-N (class
 684 ;; Fontset-N)' where N is integer 0, 1, ...
 685 ;; The values of the resources the string of the same format as
 686 ;; `standard-fontset-spec'.
 687
 688 (defun create-fontset-from-x-resource ()
 689   (let ((idx 0)
 690         fontset-spec)
 691     (while (setq fontset-spec (x-get-resource (format "fontset-%d" idx)
 692                                               (format "Fontset-%d" idx)))
 693       (create-fontset-from-fontset-spec fontset-spec t 'noerror)
 694       (setq idx (1+ idx)))))
 695
 696 ;;
 697 (provide 'fontset)
 698
 699 ;;; fontset.el ends here