diff lisp/x-faces.el @ 263:727739f917cb r20-5b30

Import from CVS: tag r20-5b30
author cvs
date Mon, 13 Aug 2007 10:24:41 +0200
parents 0e522484dd2a
children 8efd647ea9ca
line wrap: on
line diff
--- a/lisp/x-faces.el	Mon Aug 13 10:23:52 2007 +0200
+++ b/lisp/x-faces.el	Mon Aug 13 10:24:41 2007 +0200
@@ -419,6 +419,20 @@
   ;; hysterical reasons. (jwz)
 
   (let* ((append (if set-anyway nil 'append))
+	 ;; Some faces are initialized before XEmacs is dumped.
+	 ;; In order for the X resources to be able to override
+	 ;; those settings, such initialization always uses the
+	 ;; `default' tag.  We remove all specifier specs
+	 ;; containing the `default' tag in the locale before
+	 ;; adding new specs.
+	 (tag-set '(default))
+	 ;; The tag order matters here.  The spec removal
+	 ;; function uses the list cdrs.  We want to remove (x
+	 ;; default) and (default) specs, not (default x) and (x)
+	 ;; specs.
+	 (x-tag-set '(x default))
+	 (tty-tag-set '(tty default))
+	 (device-class nil)
 	 (face-sym (face-name face))
 	 (name (symbol-name face-sym))
 	 (fn (x-get-resource-and-maybe-bogosity-check
@@ -467,6 +481,16 @@
 	      'boolean locale))
 	 )
 
+    (cond ((framep locale)
+	   (setq device-class (device-class (frame-device locale))))
+	  ((devicep locale)
+	   (setq device-class (device-class locale))))
+
+    (if device-class
+	(setq tag-set (cons device-class tag-set)
+	      x-tag-set (cons device-class x-tag-set)
+	      tty-tag-set (cons device-class tty-tag-set)))
+
     ;;
     ;; If this is the default face, then any unspecified properties should
     ;; be defaulted from the global properties.  Can't do this for
@@ -493,34 +517,73 @@
     ;; #### should issue warnings?  I think this should be
     ;; done when the instancing actually happens, but I'm not
     ;; sure how it should actually be dealt with.
-    (if fn
-	(set-face-font face fn locale nil append))
+    (when fn
+      ;; Always use the x-tag-set to remove specs, since we don't
+      ;; know whether the predumped face was initialized with an
+      ;; 'x tag or not.
+      (remove-specifier-specs-matching-tag-set-cdrs (face-font face)
+						    locale
+						    x-tag-set)
+      (set-face-font face fn locale nil append))
     ;; Kludge-o-rooni.  Set the foreground and background resources for
     ;; X devices only -- otherwise things tend to get all messed up
     ;; if you start up an X frame and then later create a TTY frame.
-    (if fg
-	(set-face-foreground face fg locale 'x append))
-    (if bg
-	(set-face-background face bg locale 'x append))
-    (if bgp
-	(set-face-background-pixmap face bgp locale nil append))
-    (if ulp
-	(set-face-underline-p face ulp locale nil append))
-    (if stp
-	(set-face-strikethru-p face stp locale nil append))
-    (if hp
-	(set-face-highlight-p face hp locale nil append))
-    (if dp
-	(set-face-dim-p face dp locale nil append))
-    (if bp
-	(set-face-blinking-p face bp locale nil append))
-    (if rp
-	(set-face-reverse-p face rp locale nil append))
+    (when fg
+      (remove-specifier-specs-matching-tag-set-cdrs (face-foreground face)
+						    locale
+						    x-tag-set)
+      (set-face-foreground face fg locale 'x append))
+    (when bg
+      (remove-specifier-specs-matching-tag-set-cdrs (face-background face)
+						    locale
+						    x-tag-set)
+      (set-face-background face bg locale 'x append))
+    (when bgp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
+						     face)
+						    locale
+						    x-tag-set)
+      (set-face-background-pixmap face bgp locale nil append))
+    (when ulp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-underline-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-underline-p face ulp locale nil append))
+    (when stp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-strikethru-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-strikethru-p face stp locale nil append))
+    (when hp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-highlight-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-highlight-p face hp locale nil append))
+    (when dp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-dim-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-dim-p face dp locale nil append))
+    (when bp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-blinking-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-blinking-p face bp locale nil append))
+    (when rp
+      (remove-specifier-specs-matching-tag-set-cdrs (face-reverse-p face)
+						    locale
+						    tty-tag-set)
+      (set-face-reverse-p face rp locale nil append))
     ))
 
 ;; GNU Emacs compatibility. (move to obsolete.el?)
 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
 
+(defun remove-specifier-specs-matching-tag-set-cdrs (specifier locale tag-set)
+  (while tag-set
+    (remove-specifier specifier locale tag-set)
+    (setq tag-set (cdr tag-set))))
+
 ;;; x-init-global-faces is responsible for ensuring that the
 ;;; default face has some reasonable fallbacks if nothing else is
 ;;; specified.