xemacs-beta: lisp/x-faces.el comparison

comparison 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

comparison

equal deleted inserted replaced

-:9d8607af9e13
+:727739f917cb
 ;; I think these should be called "face.faceForeground" instead of
 ;; "face.attributeForeground", but they're the way they are for
 ;; 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
 	      (concat name ".attributeFont")
 	      "Face.AttributeFont"
 	      (concat name ".attributeReverse")
 	      "Face.AttributeReverse"
 	      '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
 ;; frames or devices because then, common resource specs like
 ;; "*Foreground: black" will have unwanted effects.
 	(setq bg (or (x-get-resource
 		      "cursorColor" "CursorColor" 'string locale) bg)))
 ;; #### 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
+(when fn
-	(set-face-font face fn locale nil append))
+;; 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
+(when fg
-	(set-face-foreground face fg locale 'x append))
+(remove-specifier-specs-matching-tag-set-cdrs (face-foreground face)
-(if bg
+						    locale
-	(set-face-background face bg locale 'x append))
+						    x-tag-set)
-(if bgp
+(set-face-foreground face fg locale 'x append))
-	(set-face-background-pixmap face bgp locale nil append))
+(when bg
-(if ulp
+(remove-specifier-specs-matching-tag-set-cdrs (face-background face)
-	(set-face-underline-p face ulp locale nil append))
+						    locale
-(if stp
+						    x-tag-set)
-	(set-face-strikethru-p face stp locale nil append))
+(set-face-background face bg locale 'x append))
-(if hp
+(when bgp
-	(set-face-highlight-p face hp locale nil append))
+(remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
-(if dp
+						     face)
-	(set-face-dim-p face dp locale nil append))
+						    locale
-(if bp
+						    x-tag-set)
-	(set-face-blinking-p face bp locale nil append))
+(set-face-background-pixmap face bgp locale nil append))
-(if rp
+(when ulp
-	(set-face-reverse-p face rp locale nil append))
+(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.
 ;;;

Mercurial > hg > xemacs-beta

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