(instantiate-fontset): Delete

duplicated call of x-complement-fontset-spec.  Call new-fontset
with a correct argument.
(x-compose-font-name): Argument name adjusted for the doc-string.
(x-complement-fontset-spec): Don't alter the contents of the
arguments XLFD-FIELDS and FONTLIST.
(x-style-funcs-alist): The format changed.
(x-modify-font-name): New function.
(create-fontset-from-fontset-spec): The arg STYLE-VARIANT-P is
changed to STYLE-VARIANT, the format also changed.  Use
x-modify-font-name instead of calling functions in
x-style-funcs-alist directly.
(instantiate-fontset): Use x-modify-font-name instead of calling
functions in x-style-funcs-alist directly.
(resolve-fontset-name): New function.

1 files changed, 160 insertions, 106 deletions

diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 8074a942a54..3944e481d94 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -228,14 +228,14 @@ PATTERN.  If no full XLFD name is gotten, return nil."
     (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 "-"))))
+         (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-"))))
     (if reduce
         (x-reduce-font-name name)
       name)))
@@ -290,12 +290,17 @@ FONTLIST is an alist of charsets vs the corresponding font names.
 Font names 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))
+  (let ((charsets charset-list)
+        (xlfd-fields-non-ascii (copy-sequence xlfd-fields))
+        (new-fontlist nil))
+    (aset xlfd-fields-non-ascii xlfd-regexp-foundry-subnum nil)
+    (aset xlfd-fields-non-ascii xlfd-regexp-family-subnum nil)
+    (aset xlfd-fields-non-ascii xlfd-regexp-adstyle-subnum nil)
+    (aset xlfd-fields-non-ascii xlfd-regexp-avgwidth-subnum nil)
     (while charsets
       (let ((charset (car charsets)))
         (unless (assq charset fontlist)
-          (let ((registry (get-charset-property charset
-                                                'x-charset-registry))
+          (let ((registry (get-charset-property charset 'x-charset-registry))
                 registry-val encoding-val fontname)
             (if (string-match "-" registry)
                 ;; REGISTRY contains `CHARSET_ENCODING' field.
@@ -303,29 +308,38 @@ automatically."
                       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))
+            (let ((xlfd (if (eq charset 'ascii) xlfd-fields
+                          xlfd-fields-non-ascii)))
+              (aset xlfd xlfd-regexp-registry-subnum registry-val)
+              (aset xlfd xlfd-regexp-encoding-subnum encoding-val)
+              (setq fontname (downcase (x-compose-font-name xlfd))))
+            (setq new-fontlist (cons (cons charset fontname) new-fontlist))
             (register-alternate-fontnames fontname))))
-      (setq charsets (cdr charsets))))
-
-  ;; If the font for ASCII can also be used for another charsets, use
-  ;; that font instead of what generated based on x-charset-registery
-  ;; in the previous code.
-  (let ((ascii-font (cdr (assq 'ascii fontlist)))
-        (l x-font-name-charset-alist))
-    (while l
-      (if (string-match (car (car l)) ascii-font)
-          (let ((charsets (cdr (car l))))
-            (while charsets
-              (if (not (eq (car charsets) 'ascii))
-                  (setcdr (assq (car charsets) fontlist) ascii-font))
-              (setq charsets (cdr charsets)))
-            (setq l nil))
-        (setq l (cdr l)))))
-
-  fontlist)
+      (setq charsets (cdr charsets)))
+
+    ;; Be sure that ASCII font is avairable.
+    (let ((slot (or (assq 'ascii fontlist) (assq 'ascii new-fontlist)))
+          ascii-font)
+      (if (setq ascii-font (condition-case nil
+                               (x-resolve-font-name (cdr slot))
+                             (error nil)))
+          (setcdr slot ascii-font))
+      (if ascii-font
+          (let ((l x-font-name-charset-alist))
+            ;; If the ASCII font can also be used for another
+            ;; charsets, use that font instead of what generated based
+            ;; on x-charset-registery in the previous code.
+            (while l
+              (if (string-match (car (car l)) ascii-font)
+                  (let ((charsets (cdr (car l))))
+                    (while charsets
+                      (if (and (not (eq (car charsets) 'ascii))
+                               (setq slot (assq (car charsets) new-fontlist)))
+                          (setcdr slot ascii-font))
+                      (setq charsets (cdr charsets)))
+                    (setq l nil))
+                (setq l (cdr l))))
+            (append fontlist new-fontlist))))))
 
 (defun fontset-name-p (fontset)
   "Return non-nil if FONTSET is valid as fontset name.
@@ -389,32 +403,49 @@ STYLE is a style of FONTSET, one of the followings:
 FONTLIST is an alist of charsets vs font names to be used in FONSET.")
 
 (defconst x-style-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)
-    (demibold-oblique x-make-font-demibold x-make-font-oblique)
-    (bold-oblique x-make-font-bold x-make-font-oblique))
-  "Alist of font style vs functions to generate a X font name of the style.")
+  `((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-italic)
+    (demibold-italic
+     . ,(function (lambda (x) (x-make-font-italic (x-make-font-demibold x)))))
+    (demibold-oblique
+     . ,(function (lambda (x) (x-make-font-oblique (x-make-font-demibold x)))))
+    (bold-oblique
+     . ,(function (lambda (x) (x-make-font-oblique (x-make-font-bold x))))))
+  "Alist of font style vs function to generate a X font name of the style.
+The function is called with one argument, a font name.")
+
+(defun x-modify-font-name (fontname style)
+  "Substitute style specification part of FONTNAME for STYLE.
+STYLE should be listed in the variable `x-style-funcs-alist'."
+  (let ((func (cdr (assq style x-style-funcs-alist))))
+    (if func
+        (funcall func fontname))))
 
 ;;;###autoload
 (defun create-fontset-from-fontset-spec (fontset-spec
-                                         &optional style-variant-p noerror)
+                                         &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-VARIANT-P is specified, it also creates
-fontsets which differs from FONTSET-NAME in styles (e.g. bold, italic).
+
+Optional 2nd argument STYLE-VARIANT is a list of font styles
+\(e.g. bold, italic) or the symbol t to specify all available styles.
+If this argument is specified, fontsets which differs from
+FONTSET-NAME in styles are also created.  An element of STYLE-VARIANT
+may be cons of style and a font name.  In this case, the style variant
+fontset uses the font for ASCII character set.
+
 If this function attempts to create already existing fontset, error is
 signaled unless the optional 3rd argument NOERROR is non-nil."
   (if (not (string-match "^[^,]+" fontset-spec))
       (error "Invalid fontset spec: %s" fontset-spec))
   (let ((idx (match-end 0))
         (name (match-string 0 fontset-spec))
-        fontlist charset)
+        fontlist full-fontlist ascii-font charset)
     (if (query-fontset name)
         (or noerror 
             (error "Fontset \"%s\" already exists"))
@@ -425,88 +456,111 @@ signaled unless the optional 3rd argument NOERROR is non-nil."
         (if (charsetp charset)
             (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
                                  fontlist))))
-
-      (if style-variant-p
-          ;; Generate fontset names of style variants and set them in
-          ;; uninstantiated-fontset-alist.
-          (let ((style-funcs-alist x-style-funcs-alist)
-                new-name style funcs)
-            (while style-funcs-alist
-              (setq style (car (car style-funcs-alist))
-                    funcs (cdr (car style-funcs-alist)))
-              (setq new-name name)
-              (while funcs
-                (setq new-name (funcall (car funcs) new-name))
-                (setq funcs (cdr funcs)))
-              (setq uninstantiated-fontset-alist
-                    (cons (list new-name style fontlist)
-                          uninstantiated-fontset-alist))
-              (setq style-funcs-alist (cdr style-funcs-alist)))))
+      ;; Remember the specified ASCII font name now because it will be
+      ;; replaced by resolved font name by x-complement-fontset-spec.
+      (setq ascii-font (cdr (assq 'ascii fontlist)))
 
       ;; If NAME conforms to XLFD, complement FONTLIST for charsets
       ;; which are 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))))
+      (let ((fields (x-decompose-font-name name)))
+        (if fields
+            (setq full-fontlist (x-complement-fontset-spec fields fontlist))))
       
-      ;; Create the fontset.
-      (new-fontset name fontlist)
-
-      ;; Define the alias (short name) if appropriate.
-      (if (and (not (assoc name fontset-alias-alist))
-               (string-match "fontset-.*$" name))
-          (let ((alias (match-string 0 name)))
-            (or (rassoc alias fontset-alias-alist)
-                (setq fontset-alias-alist
-                      (cons (cons name alias) fontset-alias-alist))))))))
+      (when full-fontlist
+        ;; Create the fontset.
+        (new-fontset name full-fontlist)
+
+        ;; Define aliases: short name (if appropriate) and ASCII font name.
+        (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)))))
+        (let ((resolved-ascii-font (cdr (assq 'ascii full-fontlist))))
+          (setq fontset-alias-alist
+                (cons (cons name resolved-ascii-font)
+                      fontset-alias-alist))
+          (or (equal ascii-font resolved-ascii-font)
+              (setq fontset-alias-alist
+                    (cons (cons name ascii-font)
+                          fontset-alias-alist))))
+
+        ;; At last, handle style variants.
+        (if (eq style-variant t)
+            (setq style-variant (mapcar 'car x-style-funcs-alist)))
+
+        (if style-variant
+            ;; Generate fontset names of style variants and set them
+            ;; in uninstantiated-fontset-alist.
+            (let* (nonascii-fontlist
+                   new-name new-ascii-font style font)
+              (if ascii-font
+                  (setq nonascii-fontlist (delete (cons 'ascii ascii-font)
+                                                  (copy-sequence fontlist)))
+                (setq ascii-font (cdr (assq 'ascii full-fontlist))
+                      nonascii-fontlist fontlist))
+              (while style-variant
+                (setq style (car style-variant))
+                (if (symbolp style)
+                    (setq font nil)
+                  (setq font (cdr style)
+                        style (car style)))
+                (setq new-name (x-modify-font-name name style))
+                (when new-name
+                  ;; Modify ASCII font name for the style...
+                  (setq new-ascii-font
+                        (or font (x-modify-font-name ascii-font style)))
+                  ;; but leave fonts for the other charsets unmodified
+                  ;; for the momemnt.  They are modified for the style
+                  ;; in instantiate-fontset.
+                  (setq uninstantiated-fontset-alist
+                        (cons (list new-name
+                                    style
+                                    (cons (cons 'ascii new-ascii-font)
+                                          nonascii-fontlist))
+                              uninstantiated-fontset-alist))
+                  (setq fontset-alias-alist
+                        (cons (cons new-name new-ascii-font)
+                              fontset-alias-alist)))
+                (setq style-variant (cdr style-variant)))))))))
 
 (defun instantiate-fontset (fontset)
   "Make FONTSET be readly to use.
 FONTSET should be in the variable `uninstantiated-fontset-alist' in advance.
 Return FONTSET if it is created successfully, else return nil."
   (let ((fontset-data (assoc fontset uninstantiated-fontset-alist)))
-    (if (null fontset-data)
-        nil
-      (let* ((xlfd-fields (x-decompose-font-name fontset))
-             (fontlist (x-complement-fontset-spec xlfd-fields
-                                                  (nth 2 fontset-data)))
-             (funcs (cdr (assq (nth 1 fontset-data) x-style-funcs-alist)))
-             ascii-font font font2)
-        (setq uninstantiated-fontset-alist
-              (delete fontset-data uninstantiated-fontset-alist))
-        (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))
-
-        ;; At first, check if ASCII font of this style is surely available.
-        (setq ascii-font (cdr (assq 'ascii fontlist)))
-        (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))))
-
-        ;; If ASCII font is available, instantiate the fontset.
+    (when fontset-data
+      (setq uninstantiated-fontset-alist
+            (delete fontset-data uninstantiated-fontset-alist))
+
+      (let* ((fields (x-decompose-font-name fontset))
+             (style (nth 1 fontset-data))
+             (fontlist (x-complement-fontset-spec fields (nth 2 fontset-data)))
+             (font (cdr (assq 'ascii fontlist))))
+        ;; If ASCII font is available, instantiate this fontset.
         (when font
           (let ((new-fontlist (list (cons 'ascii font))))
+            ;; Fonts for non-ascii charsets should be modified for
+            ;; this style now.
             (while fontlist
               (setq font (cdr (car fontlist)))
               (or (eq (car (car fontlist)) 'ascii)
-                  (if (if (= (length funcs) 1)
-                          (setq font (funcall (car funcs) font))
-                        (and (setq font (funcall (car funcs) font))
-                             (not (equal font (cdr (car fontlist))))
-                             (setq font2 (funcall (nth 1 funcs) font))
-                             (not (equal font2 font))
-                             (setq font font2)))
-                      (setq new-fontlist
-                            (cons (cons (car fontlist) font) new-fontlist))))
+                  (setq new-fontlist
+                        (cons (cons (car (car fontlist))
+                                    (x-modify-font-name font style))
+                              new-fontlist)))
               (setq fontlist (cdr fontlist)))
-            (new-fontset fontset (x-complement-fontset-spec xlfd-fields
-                                                            fontlist))
+            (new-fontset fontset new-fontlist)
             fontset))))))
+
+(defun resolve-fontset-name (pattern)
+  "Return a fontset name matching PATTERN."
+  (let ((fontset (car (rassoc pattern fontset-alias-alist))))
+    (or fontset (setq fontset pattern))
+    (if (assoc fontset uninstantiated-fontset-alist)
+        (instantiate-fontset fontset)
+      (query-fontset fontset))))
 
 ;; Create standard fontset from 16 dots fonts which are the most widely
 ;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are