-;;; fontset.el --- Commands for handling fontset.
+;;; fontset.el --- commands for handling fontset
;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.
+;; Copyright (C) 2001 Free Software Foundation, Inc.
;; Keywords: mule, multilingual, fontset
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-;;; Code:
+;;; Commentary:
-;; Set standard REGISTRY property of charset to find an appropriate
-;; font for each charset. This is used to generate a font name in a
-;; fontset. If the value contains a character `-', the string before
-;; that is embeded in `CHARSET_REGISTRY' field, and the string after
-;; that is embeded in `CHARSET_ENCODING' field. If the value does not
-;; contain `-', the whole string is embeded in `CHARSET_REGISTRY'
-;; field, and a wild card character `*' is embeded in
-;; `CHARSET_ENCODING' field.
-
-(defvar x-charset-registries
- '((ascii . "ISO8859-1")
- (latin-iso8859-1 . "ISO8859-1")
- (latin-iso8859-2 . "ISO8859-2")
- (latin-iso8859-3 . "ISO8859-3")
- (latin-iso8859-4 . "ISO8859-4")
- (thai-tis620 . "TIS620")
- (greek-iso8859-7 . "ISO8859-7")
- (arabic-iso8859-6 . "ISO8859-6")
- (hebrew-iso8859-8 . "ISO8859-8")
- (katakana-jisx0201 . "JISX0201")
- (latin-jisx0201 . "JISX0201")
- (cyrillic-iso8859-5 . "ISO8859-5")
- (latin-iso8859-9 . "ISO8859-9")
- (japanese-jisx0208-1978 . "JISX0208.1978")
- (chinese-gb2312 . "GB2312")
- (japanese-jisx0208 . "JISX0208.1983")
- (korean-ksc5601 . "KSC5601")
- (japanese-jisx0212 . "JISX0212")
- (chinese-cns11643-1 . "CNS11643.1992-1")
- (chinese-cns11643-2 . "CNS11643.1992-2")
- (chinese-cns11643-3 . "CNS11643.1992-3")
- (chinese-cns11643-4 . "CNS11643.1992-4")
- (chinese-cns11643-5 . "CNS11643.1992-5")
- (chinese-cns11643-6 . "CNS11643.1992-6")
- (chinese-cns11643-7 . "CNS11643.1992-7")
- (chinese-big5-1 . "Big5")
- (chinese-big5-2 . "Big5")
- (chinese-sisheng . "sisheng_cwnn")
- (vietnamese-viscii-lower . "VISCII1.1")
- (vietnamese-viscii-upper . "VISCII1.1")
- (arabic-digit . "MuleArabic-0")
- (arabic-1-column . "MuleArabic-1")
- (arabic-2-column . "MuleArabic-2")
- (ipa . "MuleIPA")
- (ethiopic . "Ethiopic-Unicode")
- (ascii-right-to-left . "ISO8859-1")
- (indian-is13194 . "IS13194-Devanagari")
- (indian-2-column . "MuleIndian-2")
- (indian-1-column . "MuleIndian-1")
- (lao . "MuleLao-1")
- (tibetan . "MuleTibetan-0")
- (tibetan-1-column . "MuleTibetan-1")
- ))
+;;; Code:
-(let ((l x-charset-registries))
+;; Set standard fontname specification of characters in the default
+;; fontset to find an appropriate font for each charset. This is used
+;; to generate a font name for a fontset if the fontset doesn't
+;; specify a font name for a specific character. The specification
+;; has the form (FAMILY . REGISTRY). FAMILY may be nil, in which
+;; case, the family name of default face is used. If REGISTRY
+;; contains a character `-', the string before that is embedded in
+;; `CHARSET_REGISTRY' field, and the string after that is embedded in
+;; `CHARSET_ENCODING' field. If it does not contain `-', the whole
+;; string is embedded in `CHARSET_REGISTRY' field, and a wild card
+;; character `*' is embedded in `CHARSET_ENCODING' field. The
+;; REGISTRY for ASCII characters are predefined as "ISO8859-1".
+
+(let ((l `((latin-iso8859-1 . (nil . "ISO8859-1"))
+ (latin-iso8859-2 . (nil . "ISO8859-2"))
+ (latin-iso8859-3 . (nil . "ISO8859-3"))
+ (latin-iso8859-4 . (nil . "ISO8859-4"))
+ (thai-tis620 . ("*" . "TIS620"))
+ (greek-iso8859-7 . ("*" . "ISO8859-7"))
+ (arabic-iso8859-6 . ("*" . "ISO8859-6"))
+ (hebrew-iso8859-8 . ("*" . "ISO8859-8"))
+ (katakana-jisx0201 . ("*" . "JISX0201"))
+ (latin-jisx0201 . (nil . "JISX0201"))
+ (cyrillic-iso8859-5 . ("*" . "ISO8859-5"))
+ (latin-iso8859-9 . (nil . "ISO8859-9"))
+ (japanese-jisx0208-1978 . ("*" . "JISX0208.1978"))
+ (chinese-gb2312 . ("*" . "GB2312.1980"))
+ (japanese-jisx0208 . ("*" . "JISX0208.1990"))
+ (korean-ksc5601 . ("*" . "KSC5601.1989"))
+ (japanese-jisx0212 . ("*" . "JISX0212"))
+ (chinese-cns11643-1 . ("*" . "CNS11643.1992-1"))
+ (chinese-cns11643-2 . ("*" . "CNS11643.1992-2"))
+ (chinese-cns11643-3 . ("*" . "CNS11643.1992-3"))
+ (chinese-cns11643-4 . ("*" . "CNS11643.1992-4"))
+ (chinese-cns11643-5 . ("*" . "CNS11643.1992-5"))
+ (chinese-cns11643-6 . ("*" . "CNS11643.1992-6"))
+ (chinese-cns11643-7 . ("*" . "CNS11643.1992-7"))
+ (chinese-big5-1 . ("*" . "Big5"))
+ (chinese-big5-2 . ("*" . "Big5"))
+ (chinese-sisheng . (nil . "sisheng_cwnn"))
+ (vietnamese-viscii-lower . (nil . "VISCII1.1"))
+ (vietnamese-viscii-upper . (nil . "VISCII1.1"))
+ (arabic-digit . ("*" . "MuleArabic-0"))
+ (arabic-1-column . ("*" . "MuleArabic-1"))
+ (arabic-2-column . ("*" . "MuleArabic-2"))
+ (ipa . (nil . "MuleIPA"))
+ (ethiopic . ("*" . "Ethiopic-Unicode"))
+ (ascii-right-to-left . (nil . "ISO8859-1"))
+ (indian-is13194 . ("*" . "IS13194-Devanagari"))
+ (indian-2-column . ("*" . "MuleIndian-2"))
+ (indian-1-column . ("*" . "MuleIndian-1"))
+ (lao . ("*" . "MuleLao-1"))
+ (tibetan . ("proportional" . "MuleTibetan-2"))
+ (tibetan-1-column . ("*" . "MuleTibetan-1"))
+ (latin-iso8859-14 . (nil . "ISO8859-14"))
+ (latin-iso8859-15 . (nil . "ISO8859-15"))
+ (mule-unicode-0100-24ff . (nil . "ISO10646-1"))
+ (mule-unicode-2500-33ff . (nil . "ISO10646-1"))
+ (mule-unicode-e000-ffff . (nil . "ISO10646-1"))
+ (japanese-jisx0213-1 . ("*" . "JISX0213.2000-1"))
+ (japanese-jisx0213-2 . ("*" . "JISX0213.2000-2"))
+ ))
+ charset font-spec arg)
(while l
- (condition-case nil
- (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
- (error nil))
- (setq l (cdr l))))
+ (setq charset (car (car l)) font-spec (cdr (car l)) l (cdr l))
+ (if (symbolp charset)
+ (setq arg (make-char charset))
+ (setq arg charset))
+ (set-fontset-font "fontset-default" arg font-spec)))
;; Set arguments in `font-encoding-alist' (which see).
(defun set-font-encoding (pattern charset encoding)
(set-font-encoding "ISO8859-1" 'ascii 0)
(set-font-encoding "JISX0201" 'latin-jisx0201 0)
+(define-ccl-program ccl-encode-unicode-font
+ `(0
+ (if (r0 == ,(charset-id 'ascii))
+ ((r2 = r1)
+ (r1 = 0))
+ (if (r0 == ,(charset-id 'latin-iso8859-1))
+ ((r2 = (r1 + 128))
+ (r1 = 0))
+ (if (r0 == ,(charset-id 'mule-unicode-0100-24ff))
+ ((r1 *= 96)
+ (r1 += r2)
+ (r1 += ,(- #x100 (* 32 96) 32))
+ (r1 >8= 0)
+ (r2 = r7))
+ (if (r0 == ,(charset-id 'mule-unicode-2500-33ff))
+ ((r1 *= 96)
+ (r1 += r2)
+ (r1 += ,(- #x2500 (* 32 96) 32))
+ (r1 >8= 0)
+ (r2 = r7))
+ (if (r0 == ,(charset-id 'mule-unicode-e000-ffff))
+ ((r1 *= 96)
+ (r1 += r2)
+ (r1 += ,(- #xe000 (* 32 96) 32))
+ (r1 >8= 0)
+ (r2 = r7)))))))))
+
+(setq font-ccl-encoder-alist
+ (cons '("ISO10646-1" . ccl-encode-unicode-font)
+ font-ccl-encoder-alist))
+
;; Setting for suppressing XLoadQueryFont on big fonts.
(setq x-pixel-size-width-font-regexp
"gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
+;; These fonts require vertical centering.
+(setq vertical-centering-font-regexp
+ "gb2312\\|jisx0208\\|jisx0212\\|ksc5601\\|cns11643\\|big5")
+
+(defvar x-font-name-charset-alist
+ '(("iso8859-1" ascii latin-iso8859-1)
+ ("iso8859-2" ascii latin-iso8859-2)
+ ("iso8859-3" ascii latin-iso8859-3)
+ ("iso8859-4" ascii latin-iso8859-4)
+ ("iso8859-5" ascii cyrillic-iso8859-5)
+ ("iso8859-6" ascii arabic-iso8859-6)
+ ("iso8859-7" ascii greek-iso8859-7)
+ ("iso8859-8" ascii hebrew-iso8859-8)
+ ("iso8859-14" ascii latin-iso8859-14)
+ ("iso8859-15" ascii latin-iso8859-15)
+ ("tis620" ascii thai-tis620)
+ ("koi8" ascii cyrillic-iso8859-5)
+ ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
+ ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
+ ("mulelao-1" ascii lao)
+ ("iso10646-1" ascii latin-iso8859-1 mule-unicode-0100-24ff
+ mule-unicode-2500-33ff mule-unicode-e000-ffff))
+ "Alist of font names vs list of charsets the font can display.
+
+When a font name which matches some element of this alist is given as
+`-fn' command line argument or is specified by X resource, a fontset
+which uses the specified font for the corresponding charsets are
+created and used for the initial frame.")
+
;;; XLFD (X Logical Font Description) format handler.
;; Define XLFD's field index numbers. ; field name
(error)))
(if (and fontname
(string-match xlfd-tight-regexp fontname))
+ ;; We get a full XLFD name.
(let ((len (length pattern))
(i 0)
l)
+ ;; Setup xlfd-fields by the full XLFD name. Each element
+ ;; should be a cons of matched index and matched string.
(setq xlfd-fields (make-vector 14 nil))
(while (< i 14)
(aset xlfd-fields i
(cons (match-beginning (1+ i))
(match-string (1+ i) fontname)))
(setq i (1+ i)))
+
+ ;; Replace wild cards in PATTERN by regexp codes.
(setq i 0)
(while (< i len)
(let ((ch (aref pattern i)))
len (+ len 5)
i (+ i 5))
(setq i (1+ i))))))
- (string-match pattern fontname)
- (setq l (cdr (cdr (match-data))))
- (setq i 0)
- (while (< i 14)
- (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
- (progn
- (aset xlfd-fields i (cdr (aref xlfd-fields i)))
- (setq i (1+ i)))
- (if (< (car (aref xlfd-fields i)) (car (cdr l)))
- (progn
- (aset xlfd-fields i "*")
- (setq i (1+ i)))
- (setq l (cdr (cdr l))))))
+
+ ;; Set each element of xlfd-fields to proper strings.
+ (if (string-match pattern fontname)
+ ;; The regular expression PATTERN matchs the full XLFD
+ ;; name. Set elements that correspond to a wild card
+ ;; in PATTERN to "*", set the other elements to the
+ ;; exact strings in PATTERN.
+ (let ((l (cdr (cdr (match-data)))))
+ (setq i 0)
+ (while (< i 14)
+ (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
+ (progn
+ (aset xlfd-fields i (cdr (aref xlfd-fields i)))
+ (setq i (1+ i)))
+ (if (< (car (aref xlfd-fields i)) (car (cdr l)))
+ (progn
+ (aset xlfd-fields i "*")
+ (setq i (1+ i)))
+ (setq l (cdr (cdr l)))))))
+ ;; Set each element of xlfd-fields to the exact string
+ ;; in the corresonding fields in full XLFD name.
+ (setq i 0)
+ (while (< i 14)
+ (aset xlfd-fields i (cdr (aref xlfd-fields i)))
+ (setq i (1+ i))))
xlfd-fields)))))
;; Replace consecutive wild-cards (`*') in NAME to one.
(setq name (replace-match "-*-" t t name)))
name)
-(defun x-compose-font-name (xlfd-fields &optional reduce)
+(defun x-compose-font-name (fields &optional reduce)
"Compose X's fontname from FIELDS.
-FIELDS is a vector of XLFD fields.
+FIELDS is a vector of XLFD fields, the length 14.
If a field is nil, wild-card letter `*' is embedded.
-Optional argument REDUCE non-nil means consecutive wild-cards are
-reduced to be one."
- (let ((name
- (concat "-" (mapconcat (lambda (x) (or x "*")) xlfd-fields "-"))))
- (if reduce
- (x-reduce-font-name name)
- name)))
-
-(defun register-alternate-fontnames (fontname)
- "Register alternate fontnames for FONTNAME in `alternate-fontname-alist'.
-When Emacs fails to open FONTNAME, it tries to open alternate font
-registered in the variable `alternate-fontname-alist' (which see).
-
-For FONTNAME, the following three alternate fontnames are registered:
- fontname which ignores style specification of FONTNAME,
- fontname which ignores size specification of FONTNAME,
- fontname which ignores both style and size specification of FONTNAME."
- (unless (assoc fontname alternate-fontname-alist)
- (let ((xlfd-fields (x-decompose-font-name fontname))
- style-ignored size-ignored both-ignored)
- (when xlfd-fields
- (aset xlfd-fields xlfd-regexp-foundry-subnum nil)
- (aset xlfd-fields xlfd-regexp-family-subnum nil)
-
- (let ((temp (copy-sequence xlfd-fields)))
- (aset temp xlfd-regexp-weight-subnum nil)
- (aset temp xlfd-regexp-slant-subnum nil)
- (aset temp xlfd-regexp-swidth-subnum nil)
- (aset temp xlfd-regexp-adstyle-subnum nil)
- (setq style-ignored (x-compose-font-name temp t)))
-
- (aset xlfd-fields xlfd-regexp-pixelsize-subnum nil)
- (aset xlfd-fields xlfd-regexp-pointsize-subnum nil)
- (aset xlfd-fields xlfd-regexp-resx-subnum nil)
- (aset xlfd-fields xlfd-regexp-resy-subnum nil)
- (aset xlfd-fields xlfd-regexp-spacing-subnum nil)
- (aset xlfd-fields xlfd-regexp-avgwidth-subnum nil)
- (setq size-ignored (x-compose-font-name xlfd-fields t))
-
- (aset xlfd-fields xlfd-regexp-weight-subnum nil)
- (aset xlfd-fields xlfd-regexp-slant-subnum nil)
- (aset xlfd-fields xlfd-regexp-swidth-subnum nil)
- (aset xlfd-fields xlfd-regexp-adstyle-subnum nil)
- (setq both-ignored (x-compose-font-name xlfd-fields t))
-
- (setq alternate-fontname-alist
- (cons (list fontname style-ignored size-ignored both-ignored)
- alternate-fontname-alist))))))
+Optional argument REDUCE is always ignored. It exists just for
+backward compatibility."
+ (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-")))
+
+
+(defun x-must-resolve-font-name (xlfd-fields)
+ "Like `x-resolve-font-name', but always return a font name.
+XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
+If no font matching XLFD-FIELDS is available, successively replace
+parts of the font name pattern with \"*\" until some font is found.
+Value is name of that font."
+ (let ((ascii-font nil) (index 0))
+ (while (and (null ascii-font) (<= index xlfd-regexp-encoding-subnum))
+ (let ((pattern (x-compose-font-name xlfd-fields)))
+ (condition-case nil
+ (setq ascii-font (x-resolve-font-name pattern))
+ (error
+ (message "Warning: no fonts matching `%s' available" pattern)
+ (aset xlfd-fields index "*")
+ (setq index (1+ index))))))
+ (unless ascii-font
+ (error "No fonts founds"))
+ ascii-font))
+
(defun x-complement-fontset-spec (xlfd-fields fontlist)
- "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it.
+ "Complement FONTLIST for charsets based on XLFD-FIELDS and return it.
XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
-FONTLIST is an alist of cons of charset and fontname.
-
-Fontnames for charsets not listed in FONTLIST are generated from
-XLFD-FIELDS and a property of x-charset-registry of each charset
-automatically."
- (let ((charsets charset-list))
- (while charsets
- (let ((charset (car charsets)))
- (unless (assq charset fontlist)
- (let ((registry (get-charset-property charset
- 'x-charset-registry))
- registry-val encoding-val fontname loose-fontname)
- (if (string-match "-" registry)
- ;; REGISTRY contains `CHARSET_ENCODING' field.
- (setq registry-val (substring registry 0 (match-beginning 0))
- encoding-val (substring registry (match-end 0)))
- (setq registry-val (concat registry "*")
- encoding-val "*"))
- (aset xlfd-fields xlfd-regexp-registry-subnum registry-val)
- (aset xlfd-fields xlfd-regexp-encoding-subnum encoding-val)
- (setq fontname (downcase (x-compose-font-name xlfd-fields)))
- (setq fontlist (cons (cons charset fontname) fontlist))
- (register-alternate-fontnames fontname))))
- (setq charsets (cdr charsets))))
-
- ;; Here's a trick for the charset latin-iso8859-1. If font for
- ;; ascii also contains Latin-1 characters, use it also for
- ;; latin-iso8859-1. This prevent loading a font for latin-iso8859-1
- ;; by a different name.
- (if (string-match (cdr (assq 'latin-iso8859-1 x-charset-registries))
- (cdr (assq 'ascii fontlist)))
- (setcdr (assq 'latin-iso8859-1 fontlist) (cdr (assq 'ascii fontlist))))
- fontlist)
+FONTLIST is an alist of charsets vs the corresponding font names.
+
+The fonts are complemented as below.
+
+If FONTLIST doesn't specify a font for ASCII charset, generate a font
+name for the charset from XLFD-FIELDS, and add that information to
+FONTLIST.
+
+If a font specifid for ASCII supports the other charsets (see the
+variable `x-font-name-charset-alist'), add that information to FONTLIST."
+ (let* ((slot (assq 'ascii fontlist))
+ (ascii-font (cdr slot))
+ ascii-font-spec)
+ (if ascii-font
+ (setcdr slot (setq ascii-font (x-resolve-font-name ascii-font)))
+ ;; If font for ASCII is not specified, add it.
+ (aset xlfd-fields xlfd-regexp-registry-subnum "iso8859")
+ (aset xlfd-fields xlfd-regexp-encoding-subnum "1")
+ (setq ascii-font (x-must-resolve-font-name xlfd-fields))
+ (setq fontlist (cons (cons 'ascii ascii-font) fontlist)))
+
+ ;; If the font for ASCII also supports the other charsets, and
+ ;; they are not specified in FONTLIST, add them.
+ (setq xlfd-fields (x-decompose-font-name ascii-font))
+ (if (not xlfd-fields)
+ (setq ascii-font-spec ascii-font)
+ (setq ascii-font-spec
+ (cons (format "%s-%s"
+ (aref xlfd-fields xlfd-regexp-foundry-subnum)
+ (aref xlfd-fields xlfd-regexp-family-subnum))
+ (format "%s-%s"
+ (aref xlfd-fields xlfd-regexp-registry-subnum)
+ (aref xlfd-fields xlfd-regexp-encoding-subnum)))))
+ (let ((tail x-font-name-charset-alist)
+ elt)
+ (while tail
+ (setq elt (car tail) tail (cdr tail))
+ (if (string-match (car elt) ascii-font)
+ (let ((charsets (cdr elt))
+ charset)
+ (while charsets
+ (setq charset (car charsets) charsets (cdr charsets))
+ (or (assq charset fontlist)
+ (setq fontlist
+ (cons (cons charset ascii-font-spec) fontlist))))))))
+
+ fontlist))
(defun fontset-name-p (fontset)
"Return non-nil if FONTSET is valid as fontset name.
;; Return a list to be appended to `x-fixed-font-alist' when
;; `mouse-set-font' is called.
(defun generate-fontset-menu ()
- (let ((fontsets global-fontset-alist)
+ (let ((fontsets (fontset-list))
fontset-name
l)
(while fontsets
- (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets))
+ (setq fontset-name (car fontsets) fontsets (cdr fontsets))
(setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
- (cons "Fontset" l)))
+ (cons "Fontset"
+ (sort l (function (lambda (x y) (string< (car x) (car y))))))))
(defun fontset-plain-name (fontset)
"Return a plain and descriptive name of FONTSET."
name))
fontset)))
-(defvar uninstanciated-fontset-alist nil
- "Alist of fontset names vs. information for instanciating them.
-Each element has the form (FONTSET STYLE BASE-FONTSET), where
-FONTSET is a name of fontset not yet instanciated.
-STYLE is a style of FONTSET, one of the followings:
- bold, demobold, italic, oblique,
- bold-italic, demibold-italic, bold-oblique, demibold-oblique.
-BASE-FONTSET is a name of fontset base from which FONSET is instanciated.")
-
-(defun create-fontset-from-fontset-spec (fontset-spec &optional style noerror)
+;;;###autoload
+(defun create-fontset-from-fontset-spec (fontset-spec
+ &optional style-variant noerror)
"Create a fontset from fontset specification string FONTSET-SPEC.
FONTSET-SPEC is a string of the format:
FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
-If optional argument STYLE is specified, create a fontset of STYLE
-by modifying FONTSET-SPEC appropriately. STYLE can be one of `bold',
-`italic', and `bold-italic'.
+
+Optional 2nd argument is ignored. It exists just for backward
+compatibility.
+
If this function attempts to create already existing fontset, error is
-signaled unless the optional 3rd argument NOERROR is non-nil."
+signaled unless the optional 3rd argument NOERROR is non-nil.
+
+It returns a name of the created fontset."
(if (not (string-match "^[^,]+" fontset-spec))
(error "Invalid fontset spec: %s" fontset-spec))
+ (setq fontset-spec (downcase fontset-spec))
(let ((idx (match-end 0))
(name (match-string 0 fontset-spec))
- fontlist charset)
- ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
- (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
- (setq idx (match-end 0))
- (setq charset (intern (match-string 1 fontset-spec)))
- (if (charsetp charset)
- (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
- fontlist))))
-
- ;; If NAME conforms to XLFD, complement FONTLIST for charsets not
- ;; specified in FONTSET-SPEC.
- (let ((xlfd-fields (x-decompose-font-name name)))
- (if xlfd-fields
- (setq fontlist
- (x-complement-fontset-spec xlfd-fields fontlist))))
-
- ;; If STYLE is specified, modify fontset name (NAME) and FONTLIST.
- (if nil
- (let ((func (cdr (assq style '((bold . x-make-font-bold)
- (italic . x-make-font-italic)
- (bold-italic . x-make-font-bold-italic)))))
- (l fontlist)
- new-name)
- (if (and func
- (setq new-name (funcall func name)))
- (progn
- (setq name new-name)
- (while l
- (if (setq new-name (funcall func (cdr (car l))))
- (setcdr (car l) new-name))
- (setq l (cdr l))))))
- (let ((funcs-alist
- '((bold x-make-font-bold)
- (demibold x-make-font-demibold)
- (italic x-make-font-italic)
- (oblique x-make-font-oblique)
- (bold-italic x-make-font-bold x-make-font-italic)
- (demibold-italic x-make-font-demibold x-make-font-italic)
- (bold-oblique x-make-font-bold x-make-font-oblique)
- (demibold-oblique x-make-font-demibold x-make-font-oblique)))
- new-name style funcs)
- (while funcs-alist
- (setq funcs (car funcs-alist))
- (setq style (car funcs))
- (setq funcs (cdr funcs))
- (setq new-name name)
- (while funcs
- (setq new-name (funcall (car funcs) new-name))
- (setq funcs (cdr funcs)))
- (setq uninstanciated-fontset-alist
- (cons (list new-name style name) uninstanciated-fontset-alist))
- (setq funcs-alist (cdr funcs-alist)))))
-
- (if (and noerror (query-fontset name))
- ;; Don't try to create an already existing fontset.
- nil
- ;; Create the fontset, and define the alias if appropriate.
+ xlfd-fields charset fontlist ascii-font)
+ (if (query-fontset name)
+ (or noerror
+ (error "Fontset \"%s\" already exists" name))
+ (setq xlfd-fields (x-decompose-font-name name))
+ (or xlfd-fields
+ (error "Fontset \"%s\" not conforming to XLFD" name))
+
+ ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
+ (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
+ (setq idx (match-end 0))
+ (setq charset (intern (match-string 1 fontset-spec)))
+ (if (charsetp charset)
+ (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
+ fontlist))))
+ (setq ascii-font (cdr (assq 'ascii fontlist)))
+
+ ;; Complement FONTLIST.
+ (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))
+
(new-fontset name fontlist)
- (if (and (not style)
- (not (assoc name fontset-alias-alist))
- (string-match "fontset-.*$" name))
+
+ ;; Define the short name alias.
+ (if (and (string-match "fontset-.*$" name)
+ (not (assoc name fontset-alias-alist)))
(let ((alias (match-string 0 name)))
(or (rassoc alias fontset-alias-alist)
(setq fontset-alias-alist
- (cons (cons name alias) fontset-alias-alist))))))))
-
-(defun instanciate-fontset (fontset)
- "Create a new fontset FONTSET if it is not yet instanciated.
-Return FONTSET if it is created successfully, else return nil."
- (let ((fontset-data (assoc fontset uninstanciated-fontset-alist)))
- (if (null fontset-data)
- nil
- (let ((style (nth 1 fontset-data))
- (base-fontset (nth 2 fontset-data))
- (funcs-alist
- '((bold x-make-font-bold)
- (demibold x-make-font-demibold)
- (italic x-make-font-italic)
- (oblique x-make-font-oblique)
- (bold-italic x-make-font-bold x-make-font-italic)
- (demibold-italic x-make-font-demibold x-make-font-italic)
- (bold-oblique x-make-font-bold x-make-font-oblique)
- (demibold-oblique x-make-font-demibold x-make-font-oblique)))
- ascii-font font font2 funcs)
- (setq uninstanciated-fontset-alist
- (delete fontset-data uninstanciated-fontset-alist))
- (setq fontset-data (assoc base-fontset global-fontset-alist))
- (setq ascii-font (cdr (assq 'ascii (cdr fontset-data))))
- (setq funcs (cdr (assq style funcs-alist)))
- (if (= (length funcs) 1)
- (and (setq font (funcall (car funcs) ascii-font))
- (setq font (x-resolve-font-name font 'default)))
- (and (setq font (funcall (car funcs) ascii-font))
- (not (equal font ascii-font))
- (setq font2 (funcall (nth 1 funcs) font))
- (not (equal font2 font))
- (setq font (x-resolve-font-name font2 'default))))
- (when font
- (let ((new-fontset-data (copy-alist fontset-data)))
- (setq funcs (cdr (assq style funcs-alist)))
- (while funcs
- (setcar new-fontset-data
- (funcall (car funcs) (car new-fontset-data)))
- (let ((l (cdr new-fontset-data)))
- (while l
- (if (= (length funcs) 1)
- (setq font (funcall (car funcs) (cdr (car l))))
- (and (setq font (funcall (car funcs) (cdr (car l))))
- (not (equal font (cdr (car l))))
- (setq font2 (funcall (nth 1 funcs) font))
- (not (equal font2 font))
- (setq font font2)))
- (when font
- (setcdr (car l) font)
- (register-alternate-fontnames font))
- (setq l (cdr l))))
- (setq funcs (cdr funcs)))
- (new-fontset (car new-fontset-data) (cdr new-fontset-data))
- (car new-fontset-data)))))))
+ (cons (cons name alias) fontset-alias-alist)))))
+
+ ;; Define the ASCII font name alias.
+ (or ascii-font
+ (setq ascii-font (cdr (assq 'ascii fontlist))))
+ (or (rassoc ascii-font fontset-alias-alist)
+ (setq fontset-alias-alist
+ (cons (cons name ascii-font)
+ fontset-alias-alist))))
+
+ name))
+
+(defun create-fontset-from-ascii-font (font &optional resolved-font
+ fontset-name)
+ "Create a fontset from an ASCII font FONT.
+
+Optional 1st arg RESOLVED-FONT is a resolved name of FONT. If
+omitted, x-resolve-font-name is called to get the resolved name. At
+this time, if FONT is not available, error is signaled.
+
+Optional 2nd arg FONTSET-NAME is a string to be used in
+`<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted,
+an appropriate name is generated automatically.
+
+It returns a name of the created fontset."
+ (setq font (downcase font))
+ (if resolved-font
+ (setq resolved-font (downcase resolved-font))
+ (setq resolved-font (downcase (x-resolve-font-name font))))
+ (let ((xlfd (x-decompose-font-name font))
+ (resolved-xlfd (x-decompose-font-name resolved-font))
+ fontset fontset-spec)
+ (aset xlfd xlfd-regexp-foundry-subnum nil)
+ (aset xlfd xlfd-regexp-family-subnum nil)
+ (aset xlfd xlfd-regexp-registry-subnum "fontset")
+ (if fontset-name
+ (setq fontset-name (downcase fontset-name))
+ (setq fontset-name
+ (format "%s_%s_%s"
+ (aref resolved-xlfd xlfd-regexp-registry-subnum)
+ (aref resolved-xlfd xlfd-regexp-encoding-subnum)
+ (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
+ (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
+ (setq fontset (x-compose-font-name xlfd))
+ (or (query-fontset fontset)
+ (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)))))
+
\f
;; Create standard fontset from 16 dots fonts which are the most widely
;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are
;; specified here because FAMILY of those fonts are not "fixed" in
;; many cases.
(defvar standard-fontset-spec
- "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
+ (purecopy "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
- chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
+ chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7")
"String of fontset spec of the standard fontset.
You have the biggest chance to display international characters
with correct glyphs by using the standard fontset.
(defun create-fontset-from-x-resource ()
(let ((idx 0)
fontset-spec)
- (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
- (concat "Fontset-" idx)))
- (create-fontset-from-fontset-spec fontset-spec nil 'noerror)
+ (while (setq fontset-spec (x-get-resource (format "fontset-%d" idx)
+ (format "Fontset-%d" idx)))
+ (create-fontset-from-fontset-spec fontset-spec t 'noerror)
(setq idx (1+ idx)))))
-(defsubst fontset-list ()
- "Returns a list of all defined fontset names."
- (mapcar 'car global-fontset-alist))
-
;;
(provide 'fontset)