X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7e09ef09a479731d01b1ca46e94ddadd73ac98e3..73d213f2816876fe9c6c429e75a3be5454a42b34:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index 22bf262672..612bd1677b 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1,6 +1,6 @@ ;;; faces.el --- Lisp faces -;; Copyright (C) 1992-1996, 1998-2015 Free Software Foundation, Inc. +;; Copyright (C) 1992-1996, 1998-2016 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal @@ -273,6 +273,17 @@ If FRAME is omitted or nil, use the selected frame." (not (internal-lisp-face-empty-p face frame))) +(defun face-list-p (face-or-list) + "True if FACE-OR-LIST is a list of faces. +Return nil if FACE-OR-LIST is a non-nil atom, or a cons cell whose car +is either `foreground-color', `background-color', or a keyword." + ;; The logic of merge_face_ref (xfaces.c) is recreated here. + (and (listp face-or-list) + (not (memq (car face-or-list) + '(foreground-color background-color))) + (not (keywordp (car face-or-list))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Setting face attributes from X resources. @@ -422,7 +433,7 @@ completely specified)." (defun face-attribute-merged-with (attribute value faces &optional frame) "Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute. FACES may be either a single face or a list of faces. -\[This is an internal function.]" +[This is an internal function.]" (cond ((not (face-attribute-relative-p attribute value)) value) ((null faces) @@ -608,7 +619,7 @@ VALUE must be a string specifying the font family `:foundry' VALUE must be a string specifying the font foundry, -e.g. ``adobe''. If a font foundry is specified, wild-cards `*' +e.g., \"adobe\". If a font foundry is specified, wild-cards `*' and `?' are allowed. `:width' @@ -742,7 +753,7 @@ is specified, `:italic' is ignored." (setq args (purecopy args)) (let ((where (if (null frame) 0 frame)) (spec args) - family foundry) + family foundry orig-family orig-foundry) ;; If we set the new-frame defaults, this face is modified outside Custom. (if (memq where '(0 t)) (put (or (get face 'face-alias) face) 'face-modified t)) @@ -758,9 +769,16 @@ is specified, `:italic' is ignored." (when (or family foundry) (when (and (stringp family) (string-match "\\([^-]*\\)-\\([^-]*\\)" family)) + (setq orig-foundry foundry + orig-family family) (unless foundry (setq foundry (match-string 1 family))) - (setq family (match-string 2 family))) + (setq family (match-string 2 family)) + ;; Reject bogus "families" that are all-digits -- those are some + ;; weird font names, like Foobar-12, that end in a number. + (when (string-match "\\`[0-9]*\\'" family) + (setq family orig-family) + (setq foundry orig-foundry))) (when (or (stringp family) (eq family 'unspecified)) (internal-set-lisp-face-attribute face :family (purecopy family) where)) @@ -881,7 +899,7 @@ where COLOR is a string or `foreground-color', and STYLE is either foreground color. :style may be omitted, which means to use a line. FRAME nil or not specified means change face on all frames. -Use `set-face-attribute' to ``unspecify'' underlining." +Use `set-face-attribute' to \"unspecify\" underlining." (interactive (read-face-and-attribute :underline)) (set-face-attribute face frame :underline underline)) @@ -894,7 +912,7 @@ Use `set-face-attribute' to ``unspecify'' underlining." INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video. FRAME nil or not specified means change face on all frames. -Use `set-face-attribute' to ``unspecify'' the inverse video attribute." +Use `set-face-attribute' to \"unspecify\" the inverse video attribute." (interactive (let ((list (read-face-and-attribute :inverse-video))) (list (car list) (if (cadr list) t)))) @@ -987,7 +1005,7 @@ a single face name." (setq default (car (split-string default crm-separator t)))) (let ((prompt (if default - (format "%s (default `%s'): " prompt default) + (format-message "%s (default `%s'): " prompt default) (format "%s: " prompt))) aliasfaces nonaliasfaces faces) ;; Build up the completion tables. @@ -1118,10 +1136,10 @@ Value is the new attribute value." (setq name (concat (upcase (substring name 0 1)) (substring name 1))) (let* ((completion-ignore-case t) (value (completing-read - (if default - (format "%s for face `%s' (default %s): " - name face default) - (format "%s for face `%s': " name face)) + (format-message (if default + "%s for face `%s' (default %s): " + "%s for face `%s': ") + name face default) completion-alist nil nil nil nil default))) (if (equal value "") default value))) @@ -1206,7 +1224,8 @@ 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-message + "Set font attributes of face `%s' from font: " face) (append (fontset-list) (x-list-fonts "*" nil frame))))) @@ -1417,18 +1436,21 @@ If FRAME is omitted or nil, use the selected frame." (when alias (setq face alias) (insert - (format "\n %s is an alias for the face `%s'.\n%s" - f alias - (if (setq obsolete (get f 'obsolete-face)) - (format " This face is obsolete%s; use `%s' instead.\n" - (if (stringp obsolete) - (format " since %s" obsolete) - "") - alias) - "")))) + (format-message + "\n %s is an alias for the face `%s'.\n%s" + f alias + (if (setq obsolete (get f 'obsolete-face)) + (format-message + " This face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) (insert "\nDocumentation:\n" - (or (face-documentation face) - "Not documented as a face.") + (substitute-command-keys + (or (face-documentation face) + "Not documented as a face.")) "\n\n")) (with-current-buffer standard-output (save-excursion @@ -1437,12 +1459,13 @@ If FRAME is omitted or nil, use the selected frame." (help-xref-button 1 'help-customize-face f))) (setq file-name (find-lisp-object-file-name f 'defface)) (when file-name - (princ "Defined in `") + (princ (substitute-command-keys "Defined in `")) (princ (file-name-nondirectory file-name)) - (princ "'") + (princ (substitute-command-keys "'")) ;; Make a hyperlink to the library. (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) + (re-search-backward + (substitute-command-keys "`\\([^`']+\\)'") nil t) (help-xref-button 1 'help-face-def f file-name)) (princ ".") (terpri) @@ -1575,6 +1598,13 @@ is given, in which case return its value instead." result no-match-retval)))) +;; When over 80 faces get processed at frame creation time, all but +;; one specifying all attributes as "unspecified", generating this +;; list every time means a lot of consing. +(defconst face--attributes-unspecified + (apply 'append + (mapcar (lambda (x) (list (car x) 'unspecified)) + face-attribute-name-alist))) (defun face-spec-reset-face (face &optional frame) "Reset all attributes of FACE on FRAME to unspecified." @@ -1599,9 +1629,7 @@ is given, in which case return its value instead." "unspecified-fg" "unspecified-bg"))))) ;; For all other faces, unspecify all attributes. - (apply 'append - (mapcar (lambda (x) (list (car x) 'unspecified)) - face-attribute-name-alist))))) + face--attributes-unspecified))) (defun face-spec-set (face spec &optional spec-type) "Set the face spec SPEC for FACE. @@ -1922,50 +1950,52 @@ Return nil if there is no face." (get-char-property (point) 'face)))) (cond ((facep faceprop) (push faceprop faces)) - ((and (listp faceprop) - ;; Don't treat an attribute spec as a list of faces. - (not (keywordp (car faceprop))) - (not (memq (car faceprop) - '(foreground-color background-color)))) + ((face-list-p faceprop) (dolist (face faceprop) (if (facep face) (push face faces)))))) - (setq faces (delete-dups (nreverse faces))) - (if multiple faces (car faces)))) + (if multiple + (delete-dups (nreverse faces)) + (car (last faces))))) + +(defun faces--attribute-at-point (attribute &optional attribute-unnamed) + "Return the face ATTRIBUTE at point. +ATTRIBUTE is a keyword. +If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in +unnamed faces (e.g, `foreground-color')." + ;; `face-at-point' alone is not sufficient. It only gets named faces. + ;; Need also pick up any face properties that are not associated with named faces. + (let ((faces (or (get-char-property (point) 'read-face-name) + ;; If `font-lock-mode' is on, `font-lock-face' takes precedence. + (and font-lock-mode + (get-char-property (point) 'font-lock-face)) + (get-char-property (point) 'face))) + (found nil)) + (dolist (face (if (face-list-p faces) + faces + (list faces))) + (cond (found) + ((and face (symbolp face)) + (let ((value (face-attribute-specified-or + (face-attribute face attribute nil t) + nil))) + (unless (member value '(nil "unspecified-fg" "unspecified-bg")) + (setq found value)))) + ((consp face) + (setq found (cond ((and attribute-unnamed + (memq attribute-unnamed face)) + (cdr (memq attribute-unnamed face))) + ((memq attribute face) (cadr (memq attribute face)))))))) + (or found + (face-attribute 'default attribute)))) (defun foreground-color-at-point () "Return the foreground color of the character after point." - ;; `face-at-point' alone is not sufficient. It only gets named faces. - ;; Need also pick up any face properties that are not associated with named faces. - (let ((face (or (face-at-point) - (get-char-property (point) 'read-face-name) - (get-char-property (point) 'face)))) - (cond ((and face (symbolp face)) - (let ((value (face-foreground face nil 'default))) - (if (member value '("unspecified-fg" "unspecified-bg")) - nil - value))) - ((consp face) - (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face))) - ((memq ':foreground face) (cadr (memq ':foreground face))))) - (t nil)))) ; Invalid face value. + (faces--attribute-at-point :foreground 'foreground-color)) (defun background-color-at-point () "Return the background color of the character after point." - ;; `face-at-point' alone is not sufficient. It only gets named faces. - ;; Need also pick up any face properties that are not associated with named faces. - (let ((face (or (face-at-point) - (get-char-property (point) 'read-face-name) - (get-char-property (point) 'face)))) - (cond ((and face (symbolp face)) - (let ((value (face-background face nil 'default))) - (if (member value '("unspecified-fg" "unspecified-bg")) - nil - value))) - ((consp face) - (cond ((memq 'background-color face) (cdr (memq 'background-color face))) - ((memq ':background face) (cadr (memq ':background face))))) - (t nil)))) ; Invalid face value. + (faces--attribute-at-point :background 'background-color)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2035,7 +2065,7 @@ Value is the new parameter list." "Create and return a frame with frame parameters PARAMETERS. If PARAMETERS specify a frame name, handle X geometry resources for that name. If PARAMETERS includes a `reverse' parameter, or -the X resource ``reverseVideo'' is present, handle that." +the X resource \"reverseVideo\" is present, handle that." (setq parameters (x-handle-named-frame-geometry parameters)) (let* ((params (copy-tree parameters)) (visibility-spec (assq 'visibility parameters)) @@ -2092,8 +2122,7 @@ frame parameters in PARAMETERS." (value (cdr (assq param-name parameters)))) (if value (set-face-attribute (nth 1 param) frame - (nth 2 param) value)))) - (frame-can-run-window-configuration-change-hook frame t))) + (nth 2 param) value)))))) (defun tty-handle-reverse-video (frame parameters) "Handle the reverse-video frame parameter for terminal frames." @@ -2488,7 +2517,7 @@ is used for the inner part while the first pixel line/column is drawn with the `window-divider-first-pixel' face and the last pixel line/column with the `window-divider-last-pixel' face." :version "24.4" - :group 'frames + :group 'window-divider :group 'basic-faces) (defface window-divider-first-pixel @@ -2499,7 +2528,7 @@ line/column is drawn with the foreground of this face. If you do not want to accentuate the first pixel line/column, set this to the same as `window-divider' face." :version "24.4" - :group 'frames + :group 'window-divider :group 'basic-faces) (defface window-divider-last-pixel @@ -2510,7 +2539,7 @@ line/column is drawn with the foreground of this face. If you do not want to accentuate the last pixel line/column, set this to the same as `window-divider' face." :version "24.4" - :group 'frames + :group 'window-divider :group 'basic-faces) (defface minibuffer-prompt @@ -2672,10 +2701,12 @@ It is used for characters of no fonts too." :background "turquoise") ; looks OK on tty (becomes cyan) (((class color) (background dark)) :background "steelblue3") ; looks OK on tty (becomes blue) - (((background dark)) + (((background dark) (min-colors 4)) :background "grey50") + (((background light) (min-colors 4)) + :background "gray") (t - :background "gray")) + :inherit underline)) "Face used for a matching paren." :group 'paren-showing-faces)