+(defun describe-face (face)
+ "Display the properties of face FACE."
+ (interactive (list (read-face-name "Describe face: ")))
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Properties of face `")
+ (princ (face-name face))
+ (princ "':") (terpri)
+ (princ "Foreground: ") (princ (face-foreground face)) (terpri)
+ (princ "Background: ") (princ (face-background face)) (terpri)
+ (princ " Font: ") (princ (face-font face)) (terpri)
+ (princ "Underlined: ") (princ (if (face-underline-p face) "yes" "no")) (terpri)
+ (princ " Stipple: ") (princ (or (face-stipple face) "none")) (terpri)
+ (terpri)
+ (princ "Documentation:") (terpri)
+ (let ((doc (face-documentation face)))
+ (if doc
+ (princ doc)
+ (princ "not documented as a face.")))
+ (print-help-return-message)))
+\f
+;;; Setting a face based on a SPEC.
+
+(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))
+ (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 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)
+ (face-spec-set-1 face frame attrs ':bold 'set-face-bold-p)
+ (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)))
+ (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)))
+ (setq plist (cdr (cdr plist))))
+ (if plist
+ (funcall function face (nth 1 plist) frame)))
+
+(defun face-spec-set-match-display (display frame)
+ "Non-nil iff DISPLAY matches FRAME.
+DISPLAY is part of a spec such as can be used in `defface'.
+If FRAME is nil, the current FRAME is used."
+ (let* ((conjuncts display)
+ conjunct req options
+ ;; t means we have succeeded against all
+ ;; the conjunts in DISPLAY that have been tested so far.
+ (match t))
+ (if (eq conjuncts t)
+ (setq conjuncts nil))
+ (while (and conjuncts match)
+ (setq conjunct (car conjuncts)
+ conjuncts (cdr conjuncts)
+ req (car conjunct)
+ options (cdr conjunct)
+ match (cond ((eq req 'type)
+ (memq window-system options))
+ ((eq req 'class)
+ (memq (frame-parameter frame 'display-type) options))
+ ((eq req 'background)
+ (memq (frame-parameter frame 'background-mode)
+ options))
+ (t
+ (error "Unknown req `%S' with options `%S'"
+ req options)))))
+ match))