;;; 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
(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."
+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)
(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)
(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.
(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)))
"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)))))
(when alias
(setq face alias)
(insert
- (format (substitute-command-keys
- "\n %s is an alias for the face ‘%s’.\n%s")
- f alias
- (if (setq obsolete (get f 'obsolete-face))
- (format (substitute-command-keys
- " 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"
(substitute-command-keys
(or (face-documentation face)
(help-xref-button 1 'help-customize-face f)))
(setq file-name (find-lisp-object-file-name f 'defface))
(when file-name
- (princ (substitute-command-keys "Defined in ‘"))
+ (princ (substitute-command-keys "Defined in `"))
(princ (file-name-nondirectory file-name))
- (princ (substitute-command-keys "’"))
+ (princ (substitute-command-keys "'"))
;; Make a hyperlink to the library.
(save-excursion
(re-search-backward
- (substitute-command-keys "‘\\([^‘’]+\\)’") nil t)
+ (substitute-command-keys "`\\([^`']+\\)'") nil t)
(help-xref-button 1 'help-face-def f file-name))
(princ ".")
(terpri)
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."
"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.
(delete-dups (nreverse faces))
(car (last faces)))))
-(defun foreground-color-at-point ()
- "Return the foreground color of the character after point."
+(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 ((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.
+ (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."
+ (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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
:group 'basic-faces)
(defface variable-pitch
- '((t :family "Sans Serif"))
+ '((((type w32))
+ ;; This is a kludgy workaround for an issue discussed in
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2016-04/msg00746.html.
+ :font "-outline-Arial-normal-normal-normal-sans-*-*-*-*-p-*-iso8859-1")
+ (t :family "Sans Serif"))
"The basic variable-pitch face."
:group 'basic-faces)
: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)