;;; Code:
(eval-when-compile
- (require 'cl))
+ (require 'cl)
+ ;; Warning suppression -- can't require x-win in batch:
+ (autoload 'xw-defined-colors "x-win"))
(require 'cus-face)
(".attributeBackgroundPixmap" . "Face.AttributeBackgroundPixmap"))
(:bold (".attributeBold" . "Face.AttributeBold"))
(:italic (".attributeItalic" . "Face.AttributeItalic"))
- (:font (".attributeFont" . "Face.AttributeFont")))
+ (:font (".attributeFont" . "Face.AttributeFont"))
+ (:inherit (".attributeInherit" . "Face.AttributeInherit")))
"*List of X resources and classes for face attributes.
Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
the name of a face attribute, and each ENTRY is a cons of the form
(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
X resource class for the attribute."
- :type 'sexp
+ :type '(repeat (cons symbol (repeat (cons string string))))
:group 'faces)
`:height'
-VALUE must be an integer specifying the height of the font to use in
-1/10 pt.
+VALUE must be either an integer specifying the height of the font to use
+in 1/10 pt, a floating point number specifying the amount by which to
+scale any underlying face, or a function, which is called with the old
+height (from the underlying face), and should return the new height.
`:weight'
For compatibility with Emacs 20, keywords `:bold' and `:italic' can
be used to specify that a bold or italic font should be used. VALUE
-must be t or nil in that case. A value of `unspecified' is not allowed."
- (setq args (purecopy args))
- (cond ((null frame)
- ;; Change face on all frames.
- (dolist (frame (frame-list))
- (apply #'set-face-attribute face frame args))
- ;; Record that as a default for new frames.
- (apply #'set-face-attribute face t args))
- (t
- (while args
- (internal-set-lisp-face-attribute face (car args)
- (purecopy (cadr args))
- frame)
- (setq args (cdr (cdr args)))))))
+must be t or nil in that case. A value of `unspecified' is not allowed.
+
+`:inherit'
+
+VALUE is the name of a face from which to inherit attributes, or a list
+of face names. Attributes from inherited faces are merged into the face
+like an underlying face would be, with higher priority than underlying faces."
+ (let ((where (if (null frame) 0 frame)))
+ (setq args (purecopy args))
+ (while args
+ (internal-set-lisp-face-attribute face (car args)
+ (purecopy (cadr args))
+ where)
+ (setq args (cdr (cdr args))))))
(defun make-face-bold (face &optional frame noerror)
(def (thing-at-point 'symbol))
face)
(cond ((assoc def face-list)
- (setq prompt (concat prompt "(default " def "): ")))
+ (setq prompt (concat prompt " (default " def "): ")))
(t (setq def nil)
(setq prompt (concat prompt ": "))))
(while (equal "" (setq face (completing-read
(mapcar #'list
(apply #'nconc (mapcar #'directory-files
x-bitmap-file-path)))))
+ (:inherit
+ (cons '("none" . nil)
+ (mapcar #'(lambda (c) (cons (symbol-name c) c))
+ (face-list))))
(t
(error "Internal error"))))
- (if (listp valid)
+ (if (and (listp valid) (not (memq attribute '(:inherit))))
(nconc (list (cons "unspecified" 'unspecified)) valid)
valid)))
(:inverse-video . "inverse-video display")
(:foreground . "foreground color")
(:background . "background color")
- (:stipple . "background stipple"))
+ (:stipple . "background stipple")
+ (:inherit . "inheritance"))
"An alist of descriptive names for face attributes.
Each element has the form (ATTRIBUTE-NAME . DESCRIPTION) where
ATTRIBUTE-NAME is a face attribute name (a keyword symbol), and
(defun face-read-string (face default name &optional completion-alist)
"Interactively read a face attribute string value.
-FACE is the face whose attribute is read. DEFAULT is the default
-value to return if no new value is entered. NAME is a descriptive
-name of the attribute for prompting. COMPLETION-ALIST is an alist
-of valid values, if non-nil.
+FACE is the face whose attribute is read. If non-nil, DEFAULT is the
+default string to return if no new value is entered. NAME is a
+descriptive name of the attribute for prompting. COMPLETION-ALIST is an
+alist of valid values, if non-nil.
-Entering nothing accepts the default value DEFAULT.
+Entering nothing accepts the default string DEFAULT.
Value is the new attribute value."
+ ;; Capitalize NAME (we don't use `capitalize' because that capitalizes
+ ;; each word in a string separately).
+ (setq name (concat (upcase (substring name 0 1)) (substring name 1)))
(let* ((completion-ignore-case t)
(value (completing-read
(if default
- (format "Set face %s %s (default %s): "
- face name (downcase (if (symbolp default)
- (symbol-name default)
- default)))
- (format "Set face %s %s: " face name))
+ (format "%s for face `%s' (default %s): "
+ name face default)
+ (format "%s for face `%s': " name face))
completion-alist)))
(if (equal value "") default value)))
name of the attribute for prompting. Value is the new attribute value."
(let ((new-value
(face-read-string face
- (if (memq default
- '(unspecified
- "unspecified-fg"
- "unspecified-bg"))
- default
- (int-to-string default))
+ (format "%s" default)
name
(list (cons "unspecified" 'unspecified)))))
- (if (memq new-value '(unspecified "unspecified-fg" "unspecified-bg"))
- new-value
- (string-to-int new-value))))
+ (cond ((equal new-value "unspecified")
+ 'unspecified)
+ ((member new-value '("unspecified-fg" "unspecified-bg"))
+ new-value)
+ (t
+ (string-to-int new-value)))))
(defun read-face-attribute (face attribute &optional frame)
(vectorp old-value)))
(setq old-value (prin1-to-string old-value)))
(cond ((listp valid)
- (setq new-value
- (face-read-string face old-value attribute-name valid))
- ;; Terminal frames can support colors that don't appear
- ;; explicitly in VALID, using color approximation code
- ;; in tty-colors.el.
- (if (and (memq attribute '(:foreground :background))
- (not (memq window-system '(x w32 mac)))
- (not (memq new-value
- '(unspecified
- "unspecified-fg"
- "unspecified-bg"))))
- (setq new-value (car (tty-color-desc new-value frame))))
- (unless (eq new-value 'unspecified)
- (setq new-value (cdr (assoc new-value valid)))))
+ (let ((default
+ (or (car (rassoc old-value valid))
+ (format "%s" old-value))))
+ (setq new-value
+ (face-read-string face default attribute-name valid))
+ (if (equal new-value default)
+ ;; Nothing changed, so don't bother with all the stuff
+ ;; below. In particular, this avoids a non-tty color
+ ;; from being canonicalized for a tty when the user
+ ;; just uses the default.
+ (setq new-value old-value)
+ ;; Terminal frames can support colors that don't appear
+ ;; explicitly in VALID, using color approximation code
+ ;; in tty-colors.el.
+ (if (and (memq attribute '(:foreground :background))
+ (not (memq window-system '(x w32 mac)))
+ (not (member new-value
+ '("unspecified"
+ "unspecified-fg" "unspecified-bg"))))
+ (setq new-value (car (tty-color-desc new-value frame))))
+ (setq new-value (cdr (assoc new-value valid))))))
((eq valid 'integerp)
(setq new-value (face-read-integer face old-value attribute-name)))
(t (error "Internal error")))
"Read the name of a font for FACE on FRAME.
If optional argument FRAME Is nil or omitted, use the selected frame."
(let ((completion-ignore-case t))
- (completing-read (format "Set font attributes of face %s from font: " face)
+ (completing-read (format "Set font attributes of face `%s' from font: " face)
(mapcar 'list (x-list-fonts "*" nil frame)))))
If optional argument FRAME is nil or omitted, modify the face used
for newly created frame, i.e. the global face."
(interactive)
- (let ((face (read-face-name "Modify face ")))
+ (let ((face (read-face-name "Modify face")))
(apply #'set-face-attribute face frame
(read-all-face-attributes face frame))))
Value is a list (FACE NEW-VALUE) where FACE is the face read
(a symbol), and NEW-VALUE is value read."
(cond ((eq attribute :font)
- (let* ((prompt (format "Set font-related attributes of face "))
+ (let* ((prompt "Set font-related attributes of face")
(face (read-face-name prompt))
(font (read-face-font face frame)))
(list face font)))
(t
(let* ((attribute-name (face-descriptive-attribute-name attribute))
- (prompt (format "Set %s of face " attribute-name))
+ (prompt (format "Set %s of face" attribute-name))
(face (read-face-name prompt))
(new-value (read-face-attribute face attribute frame)))
(list face new-value)))))
(:box . "Box")
(:inverse-video . "Inverse")
(:stipple . "Stipple")
- (:font . "Font or fontset")))
+ (:font . "Font or fontset")
+ (:inherit . "Inherit")))
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
attrs))))
(with-output-to-temp-buffer "*Help*"
(defun face-spec-reset-face (face &optional frame)
"Reset all attributes of FACE on FRAME to unspecified."
- (let ((attrs face-attribute-name-alist)
- params)
+ (let ((attrs face-attribute-name-alist))
(while attrs
(let ((attr-and-name (car attrs)))
- (setq params (cons (car attr-and-name) (cons 'unspecified params))))
- (setq attrs (cdr attrs)))
- (apply #'set-face-attribute face frame params)))
+ (set-face-attribute face frame (car attr-and-name) 'unspecified))
+ (setq attrs (cdr attrs)))))
(defun face-spec-set (face spec &optional frame)
"Set FACE's attributes according to the first matching entry in SPEC.
FRAME is the frame whose frame-local face is set. FRAME nil means
do it on all frames. See `defface' for information about SPEC."
- (let ((attrs (face-spec-choose spec frame))
- params)
+ (let ((attrs (face-spec-choose spec frame)))
+ (when attrs
+ (face-spec-reset-face face frame))
(while attrs
(let ((attribute (car attrs))
(value (car (cdr attrs))))
(t (unless (assq attribute face-x-resources)
(setq attribute nil))))
(when attribute
- (setq params (cons attribute (cons value params)))))
- (setq attrs (cdr (cdr attrs))))
- (face-spec-reset-face face frame)
- (apply #'set-face-attribute face frame params)))
+ (set-face-attribute face frame attribute value)))
+ (setq attrs (cdr (cdr attrs))))))
(defun face-attr-match-p (face attrs &optional frame)
(defun color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.
The value is a list of integer RGB values--\(RED GREEN BLUE\).
-These values appear to range from 0 to 65280 or 65535, depending
-on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
+These values appear to range from 0 65535; white is \(65535 65535 65535\).
If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, the value is nil.
If COLOR is the symbol `unspecified' or one of the strings
:group 'faces
:set #'(lambda (var value)
(set-default var value)
- (mapcar 'frame-set-background-mode (frame-list)))
+ (mapc 'frame-set-background-mode (frame-list)))
:initialize 'custom-initialize-changed
:type '(choice (choice-item dark)
(choice-item light)
(let* ((bg-resource
(and window-system
(x-get-resource ".backgroundMode" "BackgroundMode")))
- (params (frame-parameters frame))
(bg-mode (cond (frame-background-mode)
((null window-system)
;; No way to determine this automatically (?).
(bg-resource
(intern (downcase bg-resource)))
((< (apply '+ (x-color-values
- (cdr (assq 'background-color
- params))
+ (frame-parameter frame 'background-color)
frame))
;; Just looking at the screen, colors whose
;; values add up to .6 of the white total
(put 'modeline 'face-alias 'mode-line)
(defface header-line
- '((((type x) (class color))
- (:box (:line-width 2 :style released-button)
- :background "grey75" :foreground "black"))
- (((type w32) (class color))
- (:box (:line-width 2 :style released-button)
- :background "grey75" :foreground "black"))
+ '((((type tty))
+ (:inverse-video t))
+ (((class color) (background light))
+ (:box (:line-width 1 :style released-button)
+ :background "grey90"
+ :inherit mode-line))
+ (((class color) (background dark))
+ (:box (:line-width 1 :style released-button)
+ :background "grey20"
+ :inherit mode-line))
+ (((class mono))
+ (:box (:line-width 1 :style released-button)
+ :background "grey"
+ :inherit mode-line))
(t
(:inverse-video t)))
"Basic header-line face."
(:background "light goldenrod yellow"))
(t (:background "gray")))
"Basic face for highlighting the region."
+ :version "21.1"
:group 'basic-faces)