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