1 ;;; fontset.el --- Commands for handling fontset.
3 ;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation.
6 ;; Keywords: mule, multilingual, fontset
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; Set standard REGISTRY property of charset to find an appropriate
28 ;; font for each charset. This is used to generate a font name in a
29 ;; fontset. If the value contains a character `-', the string before
30 ;; that is embedded in `CHARSET_REGISTRY' field, and the string after
31 ;; that is embedded in `CHARSET_ENCODING' field. If the value does not
32 ;; contain `-', the whole string is embedded in `CHARSET_REGISTRY'
33 ;; field, and a wild card character `*' is embedded in
34 ;; `CHARSET_ENCODING' field.
36 (defvar x-charset-registries
37 '((ascii . "ISO8859-1")
38 (latin-iso8859-1 . "ISO8859-1")
39 (latin-iso8859-2 . "ISO8859-2")
40 (latin-iso8859-3 . "ISO8859-3")
41 (latin-iso8859-4 . "ISO8859-4")
42 (thai-tis620 . "TIS620")
43 (greek-iso8859-7 . "ISO8859-7")
44 (arabic-iso8859-6 . "ISO8859-6")
45 (hebrew-iso8859-8 . "ISO8859-8")
46 (katakana-jisx0201 . "JISX0201")
47 (latin-jisx0201 . "JISX0201")
48 (cyrillic-iso8859-5 . "ISO8859-5")
49 (latin-iso8859-9 . "ISO8859-9")
50 (japanese-jisx0208-1978 . "JISX0208.1978")
51 (chinese-gb2312 . "GB2312")
52 (japanese-jisx0208 . "JISX0208.1983")
53 (korean-ksc5601 . "KSC5601")
54 (japanese-jisx0212 . "JISX0212")
55 (chinese-cns11643-1 . "CNS11643.1992-1")
56 (chinese-cns11643-2 . "CNS11643.1992-2")
57 (chinese-cns11643-3 . "CNS11643.1992-3")
58 (chinese-cns11643-4 . "CNS11643.1992-4")
59 (chinese-cns11643-5 . "CNS11643.1992-5")
60 (chinese-cns11643-6 . "CNS11643.1992-6")
61 (chinese-cns11643-7 . "CNS11643.1992-7")
62 (chinese-big5-1 . "Big5")
63 (chinese-big5-2 . "Big5")
64 (chinese-sisheng . "sisheng_cwnn")
65 (vietnamese-viscii-lower . "VISCII1.1")
66 (vietnamese-viscii-upper . "VISCII1.1")
67 (arabic-digit . "MuleArabic-0")
68 (arabic-1-column . "MuleArabic-1")
69 (arabic-2-column . "MuleArabic-2")
71 (ethiopic . "Ethiopic-Unicode")
72 (ascii-right-to-left . "ISO8859-1")
73 (indian-is13194 . "IS13194-Devanagari")
74 (indian-2-column . "MuleIndian-2")
75 (indian-1-column . "MuleIndian-1")
77 (tibetan . "MuleTibetan-0")
78 (tibetan-1-column . "MuleTibetan-1")
81 (let ((l x-charset-registries))
84 (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
88 ;; Set arguments in `font-encoding-alist' (which see).
89 (defun set-font-encoding (pattern charset encoding)
90 (let ((slot (assoc pattern font-encoding-alist)))
92 (let ((place (assq charset (cdr slot))))
94 (setcdr place encoding)
95 (setcdr slot (cons (cons charset encoding) (cdr slot)))))
96 (setq font-encoding-alist
97 (cons (list pattern (cons charset encoding)) font-encoding-alist)))
100 (set-font-encoding "ISO8859-1" 'ascii 0)
101 (set-font-encoding "JISX0201" 'latin-jisx0201 0)
103 ;; Setting for suppressing XLoadQueryFont on big fonts.
104 (setq x-pixel-size-width-font-regexp
105 "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
107 (defvar x-font-name-charset-alist
108 '(("iso8859-1" ascii latin-iso8859-1)
109 ("iso8859-2" ascii latin-iso8859-2)
110 ("iso8859-3" ascii latin-iso8859-3)
111 ("iso8859-4" ascii latin-iso8859-4)
112 ("iso8859-5" ascii cyrillic-iso8859-5)
113 ("iso8859-6" ascii arabic-iso8859-6)
114 ("iso8859-7" ascii greek-iso8859-7)
115 ("iso8859-8" ascii hebrew-iso8859-8)
116 ("tis620" ascii thai-tis620)
117 ("koi8" ascii cyrillic-iso8859-5)
118 ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
119 ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
120 ("mulelao-1" ascii lao))
121 "Alist of font names vs list of charsets the font can display.
123 When a font name which matches some element of this alist is given as
124 `-fn' command line argument or is specified by X resource, a fontset
125 which uses the specified font for the corresponding charsets are
126 created and used for the initial frame.")
128 ;;; XLFD (X Logical Font Description) format handler.
130 ;; Define XLFD's field index numbers. ; field name
131 (defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY
132 (defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME
133 (defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME
134 (defconst xlfd-regexp-slant-subnum 3) ; SLANT
135 (defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME
136 (defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME
137 (defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE
138 (defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE
139 (defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X
140 (defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y
141 (defconst xlfd-regexp-spacing-subnum 10) ; SPACING
142 (defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH
143 (defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY
144 (defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING
146 ;; Regular expression matching against a fontname which conforms to
147 ;; XLFD (X Logical Font Description). All fields in XLFD should be
148 ;; not be omitted (but can be a wild card) to be matched.
149 (defconst xlfd-tight-regexp
151 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
152 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
153 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")
155 ;; List of field numbers of XLFD whose values are numeric.
156 (defconst xlfd-regexp-numeric-subnums
157 (list xlfd-regexp-pixelsize-subnum ;6
158 xlfd-regexp-pointsize-subnum ;7
159 xlfd-regexp-resx-subnum ;8
160 xlfd-regexp-resy-subnum ;9
161 xlfd-regexp-avgwidth-subnum ;11
164 (defun x-decompose-font-name (pattern)
165 "Decompose PATTERN into XLFD's fields and return vector of the fields.
166 The length of the vector is 14.
168 If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
169 X server and use the information of the full name to decompose
170 PATTERN. If no full XLFD name is gotten, return nil."
171 (let (xlfd-fields fontname)
172 (if (string-match xlfd-tight-regexp pattern)
174 (setq xlfd-fields (make-vector 14 nil))
176 (aset xlfd-fields i (match-string (1+ i) pattern))
179 (setq fontname (condition-case nil
180 (x-resolve-font-name pattern)
183 (string-match xlfd-tight-regexp fontname))
184 ;; We get a full XLFD name.
185 (let ((len (length pattern))
188 ;; Setup xlfd-fields by the full XLFD name. Each element
189 ;; should be a cons of matched index and matched string.
190 (setq xlfd-fields (make-vector 14 nil))
193 (cons (match-beginning (1+ i))
194 (match-string (1+ i) fontname)))
197 ;; Replace wild cards in PATTERN by regexp codes.
200 (let ((ch (aref pattern i)))
202 (setq pattern (concat (substring pattern 0 i)
204 (substring pattern (1+ i)))
208 (setq pattern (concat (substring pattern 0 i)
210 (substring pattern (1+ i)))
215 ;; Set each element of xlfd-fields to proper strings.
216 (if (string-match pattern fontname)
217 ;; The regular expression PATTERN matchs the full XLFD
218 ;; name. Set elements that correspond to a wild card
219 ;; in PATTERN to "*", set the other elements to the
220 ;; exact strings in PATTERN.
221 (let ((l (cdr (cdr (match-data)))))
224 (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
226 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
228 (if (< (car (aref xlfd-fields i)) (car (cdr l)))
230 (aset xlfd-fields i "*")
232 (setq l (cdr (cdr l)))))))
233 ;; Set each element of xlfd-fields to the exact string
234 ;; in the corresonding fields in full XLFD name.
237 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
241 ;; Replace consecutive wild-cards (`*') in NAME to one.
242 ;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1"
243 (defsubst x-reduce-font-name (name)
244 (while (string-match "-\\*-\\(\\*-\\)+" name)
245 (setq name (replace-match "-*-" t t name)))
248 (defun x-compose-font-name (fields &optional reduce)
249 "Compose X's fontname from FIELDS.
250 FIELDS is a vector of XLFD fields, the length 14.
251 If a field is nil, wild-card letter `*' is embedded.
252 Optional argument REDUCE non-nil means consecutive wild-cards are
255 (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-"))))
257 (x-reduce-font-name name)
260 (defun register-alternate-fontnames (fontname)
261 "Register alternate fontnames for FONTNAME in `alternate-fontname-alist'.
262 When Emacs fails to open FONTNAME, it tries to open an alternate font
263 registered in the variable `alternate-fontname-alist' (which see).
265 For FONTNAME, the following three alternate fontnames are registered:
266 fontname which ignores style specification of FONTNAME,
267 fontname which ignores size specification of FONTNAME,
268 fontname which ignores both style and size specification of FONTNAME.
269 Emacs tries to open fonts in this order."
270 (unless (assoc fontname alternate-fontname-alist)
271 (let ((xlfd-fields (x-decompose-font-name fontname))
272 style-ignored size-ignored both-ignored)
274 (aset xlfd-fields xlfd-regexp-foundry-subnum nil)
275 (aset xlfd-fields xlfd-regexp-family-subnum nil)
277 (let ((temp (copy-sequence xlfd-fields)))
278 (aset temp xlfd-regexp-weight-subnum nil)
279 (aset temp xlfd-regexp-slant-subnum nil)
280 (aset temp xlfd-regexp-swidth-subnum nil)
281 (aset temp xlfd-regexp-adstyle-subnum nil)
282 (setq style-ignored (x-compose-font-name temp t)))
284 (aset xlfd-fields xlfd-regexp-pixelsize-subnum nil)
285 (aset xlfd-fields xlfd-regexp-pointsize-subnum nil)
286 (aset xlfd-fields xlfd-regexp-resx-subnum nil)
287 (aset xlfd-fields xlfd-regexp-resy-subnum nil)
288 (aset xlfd-fields xlfd-regexp-spacing-subnum nil)
289 (aset xlfd-fields xlfd-regexp-avgwidth-subnum nil)
290 (setq size-ignored (x-compose-font-name xlfd-fields t))
292 (aset xlfd-fields xlfd-regexp-weight-subnum nil)
293 (aset xlfd-fields xlfd-regexp-slant-subnum nil)
294 (aset xlfd-fields xlfd-regexp-swidth-subnum nil)
295 (aset xlfd-fields xlfd-regexp-adstyle-subnum nil)
296 (setq both-ignored (x-compose-font-name xlfd-fields t))
298 (setq alternate-fontname-alist
299 (cons (list fontname style-ignored size-ignored both-ignored)
300 alternate-fontname-alist))))))
302 ;; Just to avoid compiler waring. The gloval value is never used.
303 (defvar resolved-ascii-font nil)
305 (defun x-complement-fontset-spec (xlfd-fields fontlist)
306 "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it.
307 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
308 FONTLIST is an alist of charsets vs the corresponding font names.
310 Font names for charsets not listed in FONTLIST are generated from
311 XLFD-FIELDS and a property of x-charset-registry of each charset
314 By side effect, this sets `resolved-ascii-font' to the resolved name
316 (let ((charsets charset-list)
317 (xlfd-fields-non-ascii (copy-sequence xlfd-fields))
319 (aset xlfd-fields-non-ascii xlfd-regexp-foundry-subnum nil)
320 (aset xlfd-fields-non-ascii xlfd-regexp-family-subnum nil)
321 (aset xlfd-fields-non-ascii xlfd-regexp-adstyle-subnum nil)
322 (aset xlfd-fields-non-ascii xlfd-regexp-avgwidth-subnum nil)
324 (let ((charset (car charsets)))
325 (unless (assq charset fontlist)
326 (let ((registry (get-charset-property charset 'x-charset-registry))
327 registry-val encoding-val fontname)
328 (if (string-match "-" registry)
329 ;; REGISTRY contains `CHARSET_ENCODING' field.
330 (setq registry-val (substring registry 0 (match-beginning 0))
331 encoding-val (substring registry (match-end 0)))
332 (setq registry-val (concat registry "*")
334 (let ((xlfd (if (eq charset 'ascii) xlfd-fields
335 xlfd-fields-non-ascii)))
336 (aset xlfd xlfd-regexp-registry-subnum registry-val)
337 (aset xlfd xlfd-regexp-encoding-subnum encoding-val)
338 (setq fontname (downcase (x-compose-font-name xlfd))))
339 (setq new-fontlist (cons (cons charset fontname) new-fontlist))
340 (register-alternate-fontnames fontname))))
341 (setq charsets (cdr charsets)))
343 ;; Be sure that ASCII font is available.
344 (let ((slot (or (assq 'ascii fontlist) (assq 'ascii new-fontlist)))
346 (setq ascii-font (condition-case nil
347 (x-resolve-font-name (cdr slot))
350 (let ((l x-font-name-charset-alist))
351 ;; If the ASCII font can also be used for another
352 ;; charsets, use that font instead of what generated based
353 ;; on x-charset-registry in the previous code.
355 (if (string-match (car (car l)) ascii-font)
356 (let ((charsets (cdr (car l)))
359 (if (and (not (eq (car charsets) 'ascii))
360 (setq slot2 (assq (car charsets) new-fontlist)))
361 (setcdr slot2 (cdr slot)))
362 (setq charsets (cdr charsets)))
365 (setq resolved-ascii-font ascii-font)
366 (append fontlist new-fontlist))))))
368 (defun fontset-name-p (fontset)
369 "Return non-nil if FONTSET is valid as fontset name.
370 A valid fontset name should conform to XLFD (X Logical Font Description)
371 with \"fontset\" in `<CHARSET_REGISTRY> field."
372 (and (string-match xlfd-tight-regexp fontset)
373 (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
376 ;; Return a list to be appended to `x-fixed-font-alist' when
377 ;; `mouse-set-font' is called.
378 (defun generate-fontset-menu ()
379 (let ((fontsets global-fontset-alist)
383 (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets))
384 (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
386 (sort l (function (lambda (x y) (string< (car x) (car y))))))))
388 (defun fontset-plain-name (fontset)
389 "Return a plain and descriptive name of FONTSET."
390 (if (not (setq fontset (query-fontset fontset)))
391 (error "Invalid fontset: %s" fontset))
392 (let ((xlfd-fields (x-decompose-font-name fontset)))
394 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
395 (slant (aref xlfd-fields xlfd-regexp-slant-subnum))
396 (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
397 (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
398 (charset (aref xlfd-fields xlfd-regexp-registry-subnum))
399 (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum))
401 (if (not (string= "fontset" charset))
403 (if (> (string-to-int size) 0)
404 (setq name (format "%s: %s-dot" nickname size))
405 (setq name nickname))
406 (cond ((string-match "^medium$" weight)
407 (setq name (concat name " " "medium")))
408 ((string-match "^bold$\\|^demibold$" weight)
409 (setq name (concat name " " weight))))
410 (cond ((string-match "^i$" slant)
411 (setq name (concat name " " "italic")))
412 ((string-match "^o$" slant)
413 (setq name (concat name " " "slant")))
414 ((string-match "^ri$" slant)
415 (setq name (concat name " " "reverse italic")))
416 ((string-match "^ro$" slant)
417 (setq name (concat name " " "reverse slant"))))
421 (defvar uninstantiated-fontset-alist nil
422 "Alist of fontset names vs. information for instantiating them.
423 Each element has the form (FONTSET STYLE FONTLIST), where
424 FONTSET is a name of fontset not yet instantiated.
425 STYLE is a style of FONTSET, one of the followings:
426 bold, demobold, italic, oblique,
427 bold-italic, demibold-italic, bold-oblique, demibold-oblique.
428 FONTLIST is an alist of charsets vs font names to be used in FONSET.")
430 (defconst x-style-funcs-alist
431 `((bold . x-make-font-bold)
432 (demibold . x-make-font-demibold)
433 (italic . x-make-font-italic)
434 (oblique . x-make-font-oblique)
435 (bold-italic . x-make-font-bold-italic)
437 . ,(function (lambda (x)
438 (let ((y (x-make-font-demibold x)))
439 (and y (x-make-font-italic y))))))
441 . ,(function (lambda (x)
442 (let ((y (x-make-font-demibold x)))
443 (and y (x-make-font-oblique y))))))
445 . ,(function (lambda (x)
446 (let ((y (x-make-font-bold x)))
447 (and y (x-make-font-oblique y)))))))
448 "Alist of font style vs function to generate a X font name of the style.
449 The function is called with one argument, a font name.")
451 (defcustom fontset-default-styles '(bold italic bold-italic)
452 "List of alternative styles to create for a fontset.
453 Valid elements include `bold', `demibold'; `italic', `oblique';
454 and combinations of one from each group,
455 such as `bold-italic' and `demibold-oblique'."
457 :type '(set (const bold) (const demibold) (const italic) (const oblique)
458 (const bold-italic) (const bold-oblique) (const demibold-italic)
459 (const demibold-oblique)))
461 (defun x-modify-font-name (fontname style)
462 "Substitute style specification part of FONTNAME for STYLE.
463 STYLE should be listed in the variable `x-style-funcs-alist'."
464 (let ((func (cdr (assq style x-style-funcs-alist))))
466 (funcall func fontname))))
469 (defun create-fontset-from-fontset-spec (fontset-spec
470 &optional style-variant noerror)
471 "Create a fontset from fontset specification string FONTSET-SPEC.
472 FONTSET-SPEC is a string of the format:
473 FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
474 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
476 Optional 2nd argument STYLE-VARIANT is a list of font styles
477 \(e.g. bold, italic) or the symbol t to specify all available styles.
478 If this argument is specified, fontsets which differs from
479 FONTSET-NAME in styles are also created. An element of STYLE-VARIANT
480 may be cons of style and a font name. In this case, the style variant
481 fontset uses the font for ASCII character set.
483 If this function attempts to create already existing fontset, error is
484 signaled unless the optional 3rd argument NOERROR is non-nil.
486 It returns a name of the created fontset."
487 (if (not (string-match "^[^,]+" fontset-spec))
488 (error "Invalid fontset spec: %s" fontset-spec))
489 (let ((idx (match-end 0))
490 (name (match-string 0 fontset-spec))
491 fontlist full-fontlist ascii-font resolved-ascii-font charset)
492 (if (query-fontset name)
494 (error "Fontset \"%s\" already exists" name))
495 ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
496 (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
497 (setq idx (match-end 0))
498 (setq charset (intern (match-string 1 fontset-spec)))
499 (if (charsetp charset)
500 (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
502 ;; Remember the specified ASCII font name now because it will be
503 ;; replaced by resolved font name by x-complement-fontset-spec.
504 (setq ascii-font (cdr (assq 'ascii fontlist)))
506 ;; If NAME conforms to XLFD, complement FONTLIST for charsets
507 ;; which are not specified in FONTSET-SPEC.
508 (let ((fields (x-decompose-font-name name)))
510 (setq full-fontlist (x-complement-fontset-spec fields fontlist))))
513 ;; Create the fontset.
514 (new-fontset name full-fontlist)
516 ;; Define aliases: short name (if appropriate) and ASCII font name.
517 (if (and (string-match "fontset-.*$" name)
518 (not (assoc name fontset-alias-alist)))
519 (let ((alias (match-string 0 name)))
520 (or (rassoc alias fontset-alias-alist)
521 (setq fontset-alias-alist
522 (cons (cons name alias) fontset-alias-alist)))))
523 (or (rassoc resolved-ascii-font fontset-alias-alist)
524 (setq fontset-alias-alist
525 (cons (cons name resolved-ascii-font)
526 fontset-alias-alist)))
527 (or (equal ascii-font resolved-ascii-font)
528 (rassoc ascii-font fontset-alias-alist)
529 (setq fontset-alias-alist
530 (cons (cons name ascii-font)
531 fontset-alias-alist)))
533 ;; At last, handle style variants.
534 (if (eq style-variant t)
535 (setq style-variant fontset-default-styles))
538 ;; Generate fontset names of style variants and set them
539 ;; in uninstantiated-fontset-alist.
540 (let* (nonascii-fontlist
541 new-name new-ascii-font style font)
543 (setq nonascii-fontlist (delete (cons 'ascii ascii-font)
544 (copy-sequence fontlist)))
545 (setq ascii-font (cdr (assq 'ascii full-fontlist))
546 nonascii-fontlist fontlist))
548 (setq style (car style-variant))
551 (setq font (cdr style)
553 (setq new-name (x-modify-font-name name style))
555 ;; Modify ASCII font name for the style...
558 (x-modify-font-name resolved-ascii-font style)))
559 ;; but leave fonts for the other charsets unmodified
560 ;; for the moment. They are modified for the style
561 ;; in instantiate-fontset.
562 (setq uninstantiated-fontset-alist
565 (cons (cons 'ascii new-ascii-font)
567 uninstantiated-fontset-alist))
568 (or (rassoc new-ascii-font fontset-alias-alist)
569 (setq fontset-alias-alist
570 (cons (cons new-name new-ascii-font)
571 fontset-alias-alist))))
572 (setq style-variant (cdr style-variant)))))))
575 (defun create-fontset-from-ascii-font (font &optional resolved-font
577 "Create a fontset from an ASCII font FONT.
579 Optional 1st arg RESOLVED-FONT is a resolved name of FONT. If
580 omitted, x-resolve-font-name is called to get the resolved name. At
581 this time, if FONT is not available, error is signaled.
583 Optional 2nd arg FONTSET-NAME is a string to be used in
584 `<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted,
585 an appropriate name is generated automatically.
587 Style variants of the fontset is created too. Font names in the
588 variants are generated automatically from FONT unless X resources
589 XXX.attributeFont explicitly specify them.
591 It returns a name of the created fontset."
593 (setq resolved-font (x-resolve-font-name font)))
594 (let* ((faces (copy-sequence fontset-default-styles))
596 (xlfd (x-decompose-font-name font))
597 (resolved-xlfd (x-decompose-font-name resolved-font))
598 face face-font fontset fontset-spec)
600 (setq face (car faces))
601 (setq face-font (x-get-resource (concat (symbol-name face)
603 "Face.AttributeFont"))
605 (setcar faces (cons face face-font)))
606 (setq faces (cdr faces)))
607 (aset xlfd xlfd-regexp-foundry-subnum nil)
608 (aset xlfd xlfd-regexp-family-subnum nil)
609 (aset xlfd xlfd-regexp-registry-subnum "fontset")
613 (aref resolved-xlfd xlfd-regexp-registry-subnum)
614 (aref resolved-xlfd xlfd-regexp-encoding-subnum)
615 (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
616 (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
617 ;; The fontset name should have concrete values in weight and
619 (let ((weight (aref xlfd xlfd-regexp-weight-subnum))
620 (slant (aref xlfd xlfd-regexp-slant-subnum)))
621 (if (or (not weight) (string-match "[*?]*" weight))
622 (aset xlfd xlfd-regexp-weight-subnum
623 (aref resolved-xlfd xlfd-regexp-weight-subnum)))
624 (if (or (not slant) (string-match "[*?]*" slant))
625 (aset xlfd xlfd-regexp-slant-subnum
626 (aref resolved-xlfd xlfd-regexp-slant-subnum))))
627 (setq fontset (x-compose-font-name xlfd))
628 (or (query-fontset fontset)
629 (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)
632 (defun instantiate-fontset (fontset)
633 "Make FONTSET be ready to use.
634 FONTSET should be in the variable `uninstantiated-fontset-alist' in advance.
635 Return FONTSET if it is created successfully, else return nil."
636 (let ((fontset-data (assoc fontset uninstantiated-fontset-alist)))
638 (setq uninstantiated-fontset-alist
639 (delete fontset-data uninstantiated-fontset-alist))
641 (let* ((fields (x-decompose-font-name fontset))
642 (style (nth 1 fontset-data))
643 (fontlist (x-complement-fontset-spec fields (nth 2 fontset-data)))
644 (font (cdr (assq 'ascii fontlist))))
645 ;; If ASCII font is available, instantiate this fontset.
647 (let ((new-fontlist (list (cons 'ascii font))))
648 ;; Fonts for non-ascii charsets should be modified for
651 (setq font (cdr (car fontlist)))
652 (or (eq (car (car fontlist)) 'ascii)
654 (cons (cons (car (car fontlist))
655 (x-modify-font-name font style))
657 (setq fontlist (cdr fontlist)))
658 (new-fontset fontset new-fontlist)
661 (defun resolve-fontset-name (pattern)
662 "Return a fontset name matching PATTERN."
663 (let ((fontset (car (rassoc pattern fontset-alias-alist))))
664 (or fontset (setq fontset pattern))
665 (if (assoc fontset uninstantiated-fontset-alist)
666 (instantiate-fontset fontset)
667 (query-fontset fontset))))
669 ;; Create standard fontset from 16 dots fonts which are the most widely
670 ;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are
671 ;; specified here because FAMILY of those fonts are not "fixed" in
673 (defvar standard-fontset-spec
674 "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
675 chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
676 korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
677 chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
678 chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
679 chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
680 chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
681 chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
682 chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
683 chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
684 "String of fontset spec of the standard fontset.
685 You have the biggest chance to display international characters
686 with correct glyphs by using the standard fontset.
687 See the documentation of `create-fontset-from-fontset-spec' for the format.")
689 ;; Create fontsets from X resources of the name `fontset-N (class
690 ;; Fontset-N)' where N is integer 0, 1, ...
691 ;; The values of the resources the string of the same format as
692 ;; `standard-fontset-spec'.
694 (defun create-fontset-from-x-resource ()
697 (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
698 (concat "Fontset-" idx)))
699 (create-fontset-from-fontset-spec fontset-spec t 'noerror)
700 (setq idx (1+ idx)))))
702 (defsubst fontset-list ()
703 "Returns a list of all defined fontset names."
704 (mapcar 'car global-fontset-alist))
709 ;;; fontset.el ends here