Publicize cl--generic-all-functions

[gnu-emacs] / lisp / faces.el

diff --git a/lisp/faces.el b/lisp/faces.el
index 4e7f1a42bff6a4719ef328937b1d330cb07bfa7a..fddc036c13e4a4a0ab445cf8d8022a82c6ce24fc 100644 (file)
--- 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
@@ -276,7 +276,7 @@ If FRAME is omitted or nil, use the selected 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."
+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)
@@ -1598,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."
@@ -1622,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.
@@ -1953,39 +1958,44 @@ Return nil if there is no 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
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2271,7 +2281,11 @@ If you set `term-file-prefix' to nil, this function does nothing."
   :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)