# HG changeset patch # User Miles Bader # Date 967287512 0 # Node ID 85a616c90339d180a761d46b410c11da775d821f # Parent b1854258a0dbde0ae1f295ef5f003c9df5e0b5e0 (set-face-attribute): Update doc string. (face-attribute-name-alist): Add :inherit. (face-valid-attribute-values): Handle :inherit. (face-read-string): Rephrase prompt to be less confusing. Assume that DEFAULT is a string, since we must return a string. (face-read-integer): Use `format' to turn DEFAULT into an acceptable default for face-read-string. Match NEW-VALUE against the string "unspecified", not the symbol `unspecified', since that's what face-read-string returns. (read-face-attribute): Lookup a name for old-value in valid, and use it as a default if we find one. Treat all values from face-read-string as strings. If the default is used, don't do any more processing on the value, just use the old value directly. (read-face-and-attribute, modify-face): Tweak prompt. (read-face-name): Don't assume prompt ends with a space. diff -r b1854258a0db -r 85a616c90339 lisp/faces.el --- a/lisp/faces.el Sat Aug 26 06:10:30 2000 +0000 +++ b/lisp/faces.el Sat Aug 26 10:58:32 2000 +0000 @@ -451,8 +451,10 @@ `: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' @@ -536,7 +538,13 @@ 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." +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." (setq args (purecopy args)) (cond ((null frame) ;; Change face on all frames. @@ -731,7 +739,7 @@ (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 @@ -776,9 +784,13 @@ (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))) @@ -797,7 +809,8 @@ (: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 @@ -811,21 +824,22 @@ (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))) @@ -837,17 +851,15 @@ 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) @@ -868,20 +880,27 @@ (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"))) @@ -920,7 +939,7 @@ 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)))) @@ -938,7 +957,7 @@ (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)))))