Mercurial > emacs
changeset 19098:51fdd58dc112
(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.
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Sun, 03 Aug 1997 04:10:36 +0000 |
| parents | 200ff7e7d620 |
| children | 5221c4793bb8 |
| files | lisp/faces.el |
| diffstat | 1 files changed, 107 insertions(+), 24 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/faces.el Sun Aug 03 04:10:08 1997 +0000 +++ b/lisp/faces.el Sun Aug 03 04:10:36 1997 +0000 @@ -1147,23 +1147,108 @@ ;;; 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." - (let ((tail spec)) - (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) + (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 @@ (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)))