(fontset-name-p): New function.

(uninstanciated-fontset-alist): New variable.
(create-fontset-from-fontset-spec): Delete arg STYLE.  Register
style-variants of FONTSET in uninstanciated-fontset-alist.
(create-fontset-from-x-resource): Call
create-fontset-from-fontset-spec correctly.

1 files changed, 99 insertions, 15 deletions

diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 49604f9ab55..2aede0e2410 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -280,6 +280,14 @@ automatically."
       (setcdr (assq 'latin-iso8859-1 fontlist) (cdr (assq 'ascii fontlist))))
   fontlist)
 
+(defun fontset-name-p (fontset)
+  "Return non-nil if FONTSET is valid as fontset name.
+A valid fontset name should conform to XLFD (X Logical Font Description)
+with \"fontset\" in `<CHARSET_REGISTRY> field."
+  (and (string-match xlfd-tight-regexp fontset)
+       (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
+		"fontset")))
+
 ;; Return a list to be appended to `x-fixed-font-alist' when
 ;; `mouse-set-font' is called.
 (defun generate-fontset-menu ()
@@ -324,6 +332,15 @@ automatically."
 	    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)
   "Create a fontset from fontset specification string FONTSET-SPEC.
 FONTSET-SPEC is a string of the format:
@@ -347,21 +364,6 @@ signaled unless the optional 3rd argument NOERROR is non-nil."
 	  (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
 			       fontlist))))
 
-    ;; If STYLE is specified, modify fontset name (NAME) and FONTLIST.
-    (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))))))
-
     ;; If NAME conforms to XLFD, complement FONTLIST for charsets not
     ;; specified in FONTSET-SPEC.
     (let ((xlfd-fields (x-decompose-font-name name)))
@@ -369,6 +371,43 @@ signaled unless the optional 3rd argument NOERROR is non-nil."
 	  (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
@@ -382,6 +421,51 @@ signaled unless the optional 3rd argument NOERROR is non-nil."
 		(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 (setq font (funcall (car funcs) (cdr (car l))))
+		      (setcdr (car l) font))
+		  (setq l (cdr l))))
+	      (setq funcs (cdr funcs)))
+	    (new-fontset (car new-fontset-data) (cdr new-fontset-data))
+	    (car new-fontset-data)))))))
 
 ;; Create standard fontset from 16 dots fonts which are the most widely
 ;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are