X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffaces.el;h=568c7ae458cc4584855f54a35c25060c8ef7c06e;hb=7a33575176f7e0b9ca40c60815621792b45f31c9;hp=d14b45befa931cddc6c04d860484e60239d65d28;hpb=b10ee70be2e0ce31599b05e9d58f83fc92141de0;p=chise%2Fxemacs-chise.git

diff --git a/lisp/faces.el b/lisp/faces.el
index d14b45b..568c7ae 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -907,6 +907,12 @@ the function to be called on it."
       (setq inst-list (cdr inst-list)))
     (or result first-valid)))
 
+(defcustom face-frob-from-locale-first nil
+  "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
+multi-charset environments."
+  :group 'faces
+  :type 'boolean)
+
 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face
 			      tty-thunk ws-thunk standard-face-mapping)
   ;; another kludge to make things more intuitive.  If we're
@@ -924,14 +930,20 @@ the function to be called on it."
   (let* ((the-locale (cond ((null locale) 'global)
 			   ((valid-specifier-locale-p locale) locale)
 			   (t nil)))
-	 (specs (and the-locale (face-font face the-locale nil t)))
-	 (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
+	 (spec-list
+	  (and
+	   the-locale
+	   (specifier-spec-list (get (get-face face) 'font) the-locale tags t)))
+	 (change-it
+	  (and
+	   spec-list
+	   (cdr (assoc (cdadar spec-list) standard-face-mapping)))))
     (if (and change-it
 	     (not (memq (face-name (find-face face))
 			'(default bold italic bold-italic))))
 	(progn
 	  (or (equal change-it t)
-	      (set-face-property face 'font change-it the-locale))
+	      (set-face-property face 'font change-it the-locale tags))
 	  (funcall tty-thunk))
       (let* ((domain (cond ((null the-locale) nil)
 			   ((valid-specifier-domain-p the-locale) the-locale)
@@ -942,20 +954,34 @@ the function to be called on it."
 			    (selected-device))
 			   (t nil)))
 	     (inst (and domain (face-property-instance face 'font domain))))
-	(funcall tty-thunk)
-	(funcall ws-thunk)
 	;; If it's reasonable to do the inherit-from-standard-face trick,
 	;; and it's called for, then do it now.
-	(or (null domain)
-	    (not (equal inst (face-property-instance face 'font domain)))
-	    ;; don't do it for standard faces, or you'll get inheritance loops.
-	    ;; #### This makes XEmacs seg fault! fix this bug.
-	    (memq (face-name (find-face face))
-		  '(default bold italic bold-italic))
-	    (not (equal (face-property-instance face 'font domain)
-			(face-property-instance unfrobbed-face 'font domain)))
+	(if (and
+	     face-frob-from-locale-first
+	     (eq the-locale 'global)
+	     domain
+	     (equal inst (face-property-instance face 'font domain))
+	     ;; don't do it for standard faces, or you'll get inheritance loops.
+	     ;; #### This makes XEmacs seg fault! fix this bug.
+	     (not (memq (face-name (find-face face))
+			'(default bold italic bold-italic)))
+	     (equal (face-property-instance face 'font domain)
+		    (face-property-instance unfrobbed-face 'font domain)))
 	    (set-face-property face 'font (vector frobbed-face)
-			       the-locale tags))))))
+			       the-locale tags)
+	  ;; and only otherwise try to build new property value artificially
+	  (funcall tty-thunk)
+	  (funcall ws-thunk)
+	  (and
+	   domain
+	   (equal inst (face-property-instance face 'font domain))
+	   ;; don't do it for standard faces, or you'll get inheritance loops.
+	   ;; #### This makes XEmacs seg fault! fix this bug.
+	   (not (memq (face-name (find-face face))
+		      '(default bold italic bold-italic)))
+	   (equal (face-property-instance face 'font domain)
+		  (face-property-instance unfrobbed-face 'font domain))
+	   (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
 
 (defun make-face-bold (face &optional locale tags)
   "Make FACE bold in LOCALE, if possible.