Download
(and (< emacs-major-version 20)(eval-when-compile (require 'cl)))
(defmacro define-face-const (foreground background)
"Define a constant variable (via `defconst') naming a new face.
FOREGROUND is either nil or a string naming the new face's foreground color.
BACKGROUND is either nil or a string naming the new face's background color.
FOREGROUND (or BACKGROUND) nil means do not set the foreground (or the
BACKGROUND). If both are nil, the new variable's value is nil.
The value of the new variable (new face or nil) is returned.
Only colors (strings) satisfying `x-color-defined-p' are accepted.
\"Black\" is used in place of any unacceptable foreground color name.
\"White\" is used in place of any unacceptable background color name.
The name of the new constant variable is as follows:
If both FOREGROUND and BACKGROUND are strings: FOREGROUND-on-BACKGROUND-face
If only FOREGROUND is a string: FOREGROUND-foreground-face
If only BACKGROUND is a string: BACKGROUND-background-face
Examples of use:
(define-face-const \"Blue\" \"Thistle\") => (defconst 'blue-on-thistle-face)
where (face-foreground 'blue-on-thistle-face) = \"Blue\"
(face-background 'blue-on-thistle-face) = \"Thistle\"
(define-face-const \"Blue\" nil) => (defconst 'blue-foreground-face)
where (face-foreground 'blue-foreground-face) = \"Blue\"
(define-face-const nil \"Thistle\") => (defconst 'thistle-background-face)
where (face-background 'thistle-background-face) = \"Thistle\"
If color ZZZZZZ is undefined:
(define-face-const \"Blue\" \"ZZZZZZ\") => (defconst 'blue-on-white-face)
where (face-foreground 'blue-on-white-face) = \"Blue\"
(face-background 'blue-on-white-face) = \"White\"
(define-face-const \"ZZZZZZ\" \"Pink\") => (defconst 'black-on-pink-face)
where (face-foreground 'black-on-pink-face) = \"Black\"
(face-background 'black-on-pink-face) = \"Pink\""
(when (fboundp 'x-color-defined-p)
(when (and (stringp foreground)
(not (x-color-defined-p foreground))
(not (x-color-defined-p (setq foreground (downcase foreground)))))
(setq foreground "Black"))
(when (and (stringp background)
(not (x-color-defined-p background))
(not (x-color-defined-p (setq background (downcase background)))))
(setq background "White")))
(let ((face-name (cond ((and (stringp foreground) (stringp background))
(downcase
(concat foreground "-on-" background "-face")))
(foreground
(downcase (concat foreground "-foreground-face")))
(background
(downcase (concat background "-background-face")))
(t nil))))
(if (and (fboundp 'make-face)
(setq face-name (and face-name (intern face-name))))
(` (progn
(let ((new-face
(defconst (, face-name) (make-face '(, face-name)))))
(when (, foreground)
(set-face-foreground (, face-name) (, foreground)))
(when (, background)
(set-face-background (, face-name) (, background)))
new-face)))
(` (defconst (, face-name) nil)))))
(provide 'def-face-const)