X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/25ac7b52b010137bcabe0d168bc119db41772a0b..a114b1ca6e39479bce038fe2f78ed07e3ef0b5bc:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index cff3810219..d50600c4a6 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -25,7 +25,9 @@ ;;; 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) @@ -267,13 +269,14 @@ If FRAME is omitted or nil, use the selected frame." (".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) @@ -451,8 +454,10 @@ It must be one of the symbols `ultra-condensed', `extra-condensed', `: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,20 +541,20 @@ will be used. 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) @@ -731,7 +736,7 @@ Value is a symbol naming a known face." (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 +781,13 @@ an integer value." (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 +806,8 @@ an integer value." (: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 +821,22 @@ DESCRIPTION is a descriptive name for ATTRIBUTE-NAME.") (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 +848,15 @@ value to return if no new value is entered. NAME is a descriptive 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 +877,27 @@ of a global face. Value is the new attribute value." (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"))) @@ -900,7 +916,7 @@ of a global face. Value is the new attribute value." "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))))) @@ -920,7 +936,7 @@ Value is a property list of attribute names and new values." 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)))) @@ -932,13 +948,13 @@ FRAME nil or unspecified means read attribute value of global face. 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))))) @@ -1148,21 +1164,20 @@ If FRAME is nil, the current FRAME is used." (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)))) @@ -1173,10 +1188,8 @@ do it on all frames. See `defface' for information about SPEC." (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) @@ -1234,8 +1247,7 @@ If COLOR is the symbol `unspecified' or one of the strings (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 @@ -1280,7 +1292,7 @@ this won't have the expected effect." :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) @@ -1292,7 +1304,6 @@ this won't have the expected effect." (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 (?). @@ -1300,8 +1311,7 @@ this won't have the expected effect." (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 @@ -1519,12 +1529,20 @@ created." (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." @@ -1560,6 +1578,7 @@ created." (:background "light goldenrod yellow")) (t (:background "gray"))) "Basic face for highlighting the region." + :version "21.1" :group 'basic-faces)