(face-attr-match-p): New function.

(face-attr-match-1, face-spec-match-p, face-attr-construct): Likewise.
(face-spec-choose): New function.
(face-spec-set): Use face-spec-choose.

1 files changed, 107 insertions, 24 deletions

diff --git a/lisp/faces.el b/lisp/faces.el
index f925daa6e70..0ff08e2efe7 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1147,23 +1147,108 @@ selected frame."
 
 ;;; Setting a face based on a SPEC.
 
-(defun face-spec-set (face spec &optional frame)
-  "Set FACE's face attributes according to the first matching entry in SPEC.
-If optional FRAME is non-nil, set it for that frame only.
-If it is nil, then apply SPEC to each frame individually.
-See `defface' for information about SPEC."
-  (let ((tail spec))
-    (while tail 
+(defun face-attr-match-p (face attrs &optional frame)
+  (or frame (setq frame (selected-frame)))
+  (and (face-attr-match-1 face frame attrs ':inverse-video
+                          'face-inverse-video-p)
+       (if (face-inverse-video-p face frame)
+           (and
+            (face-attr-match-1 face frame attrs
+                               ':foreground 'face-background
+                               (cdr (assq 'foreground-color
+                                          (frame-parameters frame))))
+            (face-attr-match-1 face frame attrs
+                               ':background 'face-foreground 
+                               (cdr (assq 'background-color
+                                          (frame-parameters frame)))))
+         (and
+          (face-attr-match-1 face frame attrs ':foreground 'face-foreground)
+          (face-attr-match-1 face frame attrs ':background 'face-background)))
+       (face-attr-match-1 face frame attrs ':stipple 'face-stipple)
+       (face-attr-match-1 face frame attrs ':bold 'face-bold-p)
+       (face-attr-match-1 face frame attrs ':italic 'face-italic-p)
+       (face-attr-match-1 face frame attrs ':underline 'face-underline-p)
+))
+
+(defun face-attr-match-1 (face frame plist property function
+                               &optional defaultval)
+  (while (and plist (not (eq (car plist) property)))
+    (setq plist (cdr (cdr plist))))
+  (eq (funcall function face frame)
+      (if plist
+          (nth 1 plist)
+        (or defaultval
+            (funcall function 'default frame)))))
+
+(defun face-spec-match-p (face spec &optional frame)
+  "Return t if FACE, on FRAME, matches what SPEC says it should look like."
+  (face-attr-match-p face (face-spec-choose spec frame) frame))
+
+(defun face-attr-construct (face &optional frame)
+  "Return a defface-style attribute list for FACE, as it exists on FRAME." 
+  (let (result)
+    (if (face-inverse-video-p face frame)
+        (progn
+          (setq result (cons ':inverse-video (cons t result)))
+          (or (face-attr-match-1 face frame nil
+                                 ':foreground 'face-background
+                                 (cdr (assq 'foreground-color
+                                            (frame-parameters frame))))
+              (setq result (cons ':foreground
+                                 (cons (face-foreground face frame) result))))
+          (or (face-attr-match-1 face frame nil
+                                 ':background 'face-foreground 
+                                 (cdr (assq 'background-color
+                                            (frame-parameters frame))))
+              (setq result (cons ':background
+                                 (cons (face-background face frame) result)))))
+      (if (face-foreground face frame)
+          (setq result (cons ':foreground
+                             (cons (face-foreground face frame) result))))
+      (if (face-background face frame)
+          (setq result (cons ':background
+                             (cons (face-background face frame) result)))))
+    (if (face-stipple face frame)
+        (setq result (cons ':stipple
+                           (cons (face-stipple face frame) result))))
+    (if (face-bold-p face frame)
+        (setq result (cons ':bold
+                           (cons (face-bold-p face frame) result))))
+    (if (face-italic-p face frame)
+        (setq result (cons ':italic
+                           (cons (face-italic-p face frame) result))))
+    (if (face-underline-p face frame)
+        (setq result (cons ':underline
+                           (cons (face-underline-p face frame) result))))
+    result))
+    
+;; Choose the proper attributes for FRAME, out of SPEC.
+(defun face-spec-choose (spec &optional frame)
+  (or frame (setq frame (selected-frame)))
+  (let ((tail spec)
+        result)
+    (while tail
       (let* ((entry (car tail))
              (display (nth 0 entry))
              (attrs (nth 1 entry)))
         (setq tail (cdr tail))
-        ;; If the font was set automatically, clear it out
-        ;; to allow it to be set it again.
-        (unless (face-font-explicit face frame)
-          (set-face-font face nil frame))
-        (modify-face face nil nil nil nil nil nil frame)
         (when (face-spec-set-match-display display frame)
+          (setq result attrs tail nil))))
+    result))
+
+(defun face-spec-set (face spec &optional frame)
+  "Set FACE's face attributes according to the first matching entry in SPEC.
+If optional FRAME is non-nil, set it for that frame only.
+If it is nil, then apply SPEC to each frame individually.
+See `defface' for information about SPEC."
+  (if frame
+      (let ((attrs (face-spec-choose spec frame)))
+        (when attrs
+          ;; If the font was set automatically, clear it out
+          ;; to allow it to be set it again.
+          (unless (face-font-explicit face frame)
+            (set-face-font face nil frame))
+          (modify-face face nil nil nil nil nil nil frame)
           (face-spec-set-1 face frame attrs ':foreground 'set-face-foreground)
           (face-spec-set-1 face frame attrs ':background 'set-face-background)
           (face-spec-set-1 face frame attrs ':stipple 'set-face-stipple)
@@ -1171,18 +1256,16 @@ See `defface' for information about SPEC."
           (face-spec-set-1 face frame attrs ':italic 'set-face-italic-p)
           (face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
           (face-spec-set-1 face frame attrs ':inverse-video
-                           'set-face-inverse-video-p)
-          (setq tail nil)))))
-  (if (null frame)
-      (let ((frames (frame-list))
-            frame)
-        (while frames
-          (setq frame (car frames)
-                frames (cdr frames))
-          (face-spec-set face (or (get face 'saved-face)
-                                  (get face 'face-defface-spec))
-                         frame)
-          (face-spec-set face spec frame)))))
+                           'set-face-inverse-video-p)))
+    (let ((frames (frame-list))
+          frame)
+      (while frames
+        (setq frame (car frames)
+              frames (cdr frames))
+        (face-spec-set face (or (get face 'saved-face)
+                                (get face 'face-defface-spec))
+                       frame)
+        (face-spec-set face spec frame)))))
 
 (defun face-spec-set-1 (face frame plist property function)
   (while (and plist (not (eq (car plist) property)))