faces.el (read-face-name): Do not override value of arg default, call instead face...

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6054ed3c213ed41a244f73f81d2871dadf434192..37e8028c941016435e8746fa472089ceb476e5b5 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,21 @@
+2013-04-12  Roland Winkler  <winkler@gnu.org>
+
+       * faces.el (read-face-name): Do not override value of arg default.
+       Allow single faces and strings as default values.  Remove those
+       elements from return value that are not faces.
+       (describe-face): Simplify.
+       (face-at-point): New optional args thing and multiple so that this
+       function can provide the same functionality previously provided by
+       read-face-name.
+       (make-face-bold, make-face-unbold, make-face-italic)
+       (make-face-unitalic, make-face-bold-italic, invert-face)
+       (modify-face, read-face-and-attribute): Use face-at-point.
+
+       * cus-edit.el (customize-face, customize-face-other-window)
+       * cus-theme.el (custom-theme-add-face)
+       * face-remap.el (buffer-face-set)
+       * facemenu.el (facemenu-set-face): Use face-at-point.
+
 2013-04-12  Michael Albinus  <michael.albinus@gmx.de>
 
        * info.el (Info-file-list-for-emacs): Add "tramp" and "dbus".

diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index d19e2ded00cf45bc928f872d2479b37f580fdebd..ac9408b1081343386f1fe58104b9bbf5a13e8fc1 100644 (file)
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -1319,7 +1319,8 @@ If OTHER-WINDOW is non-nil, display in another window.
 
 Interactively, when point is on text which has a face specified,
 suggest to customize that face, if it's customizable."
-  (interactive (list (read-face-name "Customize face" "all faces" t)))
+  (interactive (list (read-face-name "Customize face"
+                                     (or (face-at-point t t) "all faces") t)))
   (if (member face '(nil ""))
       (setq face (face-list)))
   (if (and (listp face) (null (cdr face)))
@@ -1350,7 +1351,8 @@ If FACE is actually a face-alias, customize the face it is aliased to.
 
 Interactively, when point is on text which has a face specified,
 suggest to customize that face, if it's customizable."
-  (interactive (list (read-face-name "Customize face" "all faces" t)))
+  (interactive (list (read-face-name "Customize face"
+                                     (or (face-at-point t t) "all faces") t)))
   (customize-face face t))
 
 (defalias 'customize-customized 'customize-unsaved)

diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index cc1046eddc57235c82c8442c0fdbd7ca09f022a0..dbe4fa42d8ef8793f8b6a10b31be250a2e8a91a3 100644 (file)
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -263,7 +263,7 @@ interactively, this defaults to the current value of VAR."
 (defun custom-theme-add-face (face &optional spec)
   "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
 SPEC, if non-nil, should be a face spec to which to set the widget."
-  (interactive (list (read-face-name "Face name" nil nil) nil))
+  (interactive (list (read-face-name "Face name" (face-at-point t))))
   (unless (or (facep face) spec)
     (error "`%s' has no face definition" face))
   (let ((entry (assq face custom-theme-faces)))

diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index f1efc3727f5d50b8f1da8507741238359e3c60ec..b620d01d83e94805770620b83ad6ae468747c332 100644 (file)
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -378,7 +378,7 @@ one face is listed, that specifies an aggregate face, like in a
 
 This function makes the variable `buffer-face-mode-face' buffer
 local, and sets it to FACE."
-  (interactive (list (read-face-name "Set buffer face")))
+  (interactive (list (read-face-name "Set buffer face" (face-at-point t))))
   (while (and (consp specs) (null (cdr specs)))
     (setq specs (car specs)))
   (if (null specs)

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 9a66edd28fc04571e75ecae08c231feeabb41078..eb4554585a8c1271f949c8babf778602328eda6c 100644 (file)
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -329,7 +329,7 @@ This command can also add FACE to the menu of faces,
 if `facemenu-listed-faces' says to do that."
   (interactive (list (progn
                       (barf-if-buffer-read-only)
-                      (read-face-name "Use face"))
+                      (read-face-name "Use face" (face-at-point t)))
                     (if (and mark-active (not current-prefix-arg))
                         (region-beginning))
                     (if (and mark-active (not current-prefix-arg))

diff --git a/lisp/faces.el b/lisp/faces.el
index 400b475429fd9e0155b72ec8ed98bf04a72b3583..de6d36c7ae8ea1a9e05127d9478dad0cd86a748d 100644 (file)
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -757,7 +757,8 @@ is specified, `:italic' is ignored."
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of the font weight."
-  (interactive (list (read-face-name "Make which face bold")))
+  (interactive (list (read-face-name "Make which face bold"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'bold))
 
 
@@ -765,7 +766,8 @@ Use `set-face-attribute' for finer control of the font weight."
   "Make the font of FACE be non-bold, if possible.
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility."
-  (interactive (list (read-face-name "Make which face non-bold")))
+  (interactive (list (read-face-name "Make which face non-bold"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'normal))
 
 
@@ -774,7 +776,8 @@ Argument NOERROR is ignored and retained for compatibility."
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of the font slant."
-  (interactive (list (read-face-name "Make which face italic")))
+  (interactive (list (read-face-name "Make which face italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :slant 'italic))
 
 
@@ -782,7 +785,8 @@ Use `set-face-attribute' for finer control of the font slant."
   "Make the font of FACE be non-italic, if possible.
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility."
-  (interactive (list (read-face-name "Make which face non-italic")))
+  (interactive (list (read-face-name "Make which face non-italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :slant 'normal))
 
 
@@ -791,7 +795,8 @@ Argument NOERROR is ignored and retained for compatibility."
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of font weight and slant."
-  (interactive (list (read-face-name "Make which face bold-italic")))
+  (interactive (list (read-face-name "Make which face bold-italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'bold :slant 'italic))
 
 
@@ -911,7 +916,7 @@ If FRAME is omitted or nil, it means change face on all frames.
 If FACE specifies neither foreground nor background color,
 set its foreground and background to the background and foreground
 of the default face.  Value is FACE."
-  (interactive (list (read-face-name "Invert face")))
+  (interactive (list (read-face-name "Invert face" (face-at-point t))))
   (let ((fg (face-attribute face :foreground frame))
        (bg (face-attribute face :background frame)))
     (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
@@ -929,85 +934,54 @@ of the default face.  Value is FACE."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun read-face-name (prompt &optional default multiple)
-  "Read one or more face names, defaulting to the face(s) at point.
-PROMPT should be a prompt string; it should not end in a space or
-a colon.
+  "Read one or more face names, prompting with PROMPT.
+PROMPT should not end in a space or a colon.
 
-The optional argument DEFAULT specifies the default face name(s)
-to return if the user just types RET.  If its value is non-nil,
-it should be a list of face names (symbols or strings); in that case,
-the default return value is the `car' of DEFAULT (if the argument
-MULTIPLE is non-nil), or DEFAULT (if MULTIPLE is nil).  See below
-for the meaning of MULTIPLE.
-
-If DEFAULT is nil, the list of default face names is taken from
-the symbol at point and the `read-face-name' property of the text at point,
-or, if that is nil, from the `face' property of the text at point.
+Return DEFAULT if the user enters the empty string.
+If DEFAULT is non-nil, it should be a list of face names (symbols or strings).
+In that case, return the `car' of DEFAULT (if MULTIPLE is non-nil),
+or DEFAULT (if MULTIPLE is nil).  See below for the meaning of MULTIPLE.
+DEFAULT can also be a single face.
 
 This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\"
-as the separator regexp.  Thus, the user may enter multiple face
-names, separated by commas.  The optional argument MULTIPLE
-specifies the form of the return value.  If MULTIPLE is non-nil,
-return a list of face names; if the user entered just one face
-name, the return value would be a list of one face name.
-Otherwise, return a single face name; if the user entered more
-than one face name, return only the first one."
-  ;; Should we better not generate automagically a value for DEFAULT
-  ;; when `read-face-name' was called with DEFAULT being nil?
-  ;; Such magic is somewhat unusual for a function  `read-...'.
-  ;; Also, one cannot skip this magic by means of a suitable
-  ;; value of DEFAULT.  It would be cleaner to use
-  ;; (read-face-name prompt (face-at-point)).
-  (unless default
-    ;; Try to get a default face name from the buffer.
-    (let ((thing (intern-soft (thing-at-point 'symbol))))
-      (if (memq thing (face-list))
-          (setq default (list thing))))
-    ;; Add the named faces that the `read-face-name' or `face' property uses.
-    (let ((faceprop (or (get-char-property (point) 'read-face-name)
-                        (get-char-property (point) 'face))))
-      (if (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))))
-          (dolist (face faceprop)
-            (if (symbolp face)
-                (push face default)))
-        (if (symbolp faceprop)
-            (push faceprop default)))
-      (delete-dups default)))
-
-  ;; If we only want one, and the default is more than one,
-  ;; discard the unwanted ones now.
-  (if (and default (not multiple))
-      (setq default (list (car default))))
-
-  (if default
-      (setq default (mapconcat (lambda (f)
-                                 (if (symbolp f) (symbol-name f) f))
-                               default ", ")))
-
-  ;; Build up the completion tables.
-  (let (aliasfaces nonaliasfaces)
+as the separator regexp.  Thus, the user may enter multiple face names,
+separated by commas.
+
+MULTIPLE specifies the form of the return value.  If MULTIPLE is non-nil,
+return a list of face names; if the user entered just one face name,
+return a list of one face name.  Otherwise, return a single face name;
+if the user entered more than one face name, return only the first one."
+  (if (and default (not (stringp default)))
+      (setq default
+            (cond ((symbolp default)
+                   (symbol-name default))
+                  (multiple
+                   (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
+                              default ", "))
+                  ;; If we only want one, and the default is more than one,
+                  ;; discard the unwanted ones.
+                  (t (symbol-name (car default))))))
+
+  (let (aliasfaces nonaliasfaces faces)
+    ;; Build up the completion tables.
     (mapatoms (lambda (s)
-                (if (custom-facep s)
+                (if (facep s)
                     (if (get s 'face-alias)
                         (push (symbol-name s) aliasfaces)
                       (push (symbol-name s) nonaliasfaces)))))
-
-    (let ((faces
-           ;; Read the faces.
-           (mapcar 'intern
-                   (completing-read-multiple
-                    (if default
-                        (format "%s (default `%s'): " prompt default)
-                      (format "%s: " prompt))
-                    (completion-table-in-turn nonaliasfaces aliasfaces)
-                    nil t nil 'face-name-history default))))
-      ;; Return either a list of faces or just one face.
-      (if multiple
-         faces
-       (car faces)))))
+    (dolist (face (completing-read-multiple
+                   (if default
+                       (format "%s (default `%s'): " prompt default)
+                     (format "%s: " prompt))
+                   (completion-table-in-turn nonaliasfaces aliasfaces)
+                   nil t nil 'face-name-history default))
+      ;; Ignore elements that are not faces
+      ;; (for example, because DEFAULT was "all faces")
+      (if (facep face) (push (intern face) faces)))
+    ;; Return either a list of faces or just one face.
+    (if multiple
+        (nreverse faces)
+      (last faces))))
 
 ;; Not defined without X, but behind window-system test.
 (defvar x-bitmap-file-path)
@@ -1235,7 +1209,7 @@ and the face and its settings are obtained by querying the user."
                          :slant (if italic-p 'italic 'normal)
                          :underline underline
                          :inverse-video inverse-p)
-    (setq face (read-face-name "Modify face"))
+    (setq face (read-face-name "Modify face" (face-at-point t)))
     (apply #'set-face-attribute face frame
           (read-all-face-attributes face frame))))
 
@@ -1247,13 +1221,13 @@ 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 "Set font-related attributes of face")
-               (face (read-face-name prompt))
+               (face (read-face-name prompt (face-at-point t)))
                (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))
-               (face (read-face-name prompt))
+               (face (read-face-name prompt (face-at-point t)))
                (new-value (read-face-attribute face attribute frame)))
           (list face new-value)))))
 
@@ -1363,8 +1337,7 @@ If the optional argument FRAME is given, report on face FACE in that frame.
 If FRAME is t, report on the defaults for face FACE (for new frames).
 If FRAME is omitted or nil, use the selected frame."
   (interactive (list (read-face-name "Describe face"
-                                     (if (eq 'default (face-at-point))
-                                         '(default))
+                                     (or (face-at-point t) 'default)
                                      t)))
   (let* ((attrs '((:family . "Family")
                  (:foundry . "Foundry")
@@ -1879,23 +1852,33 @@ resulting color name in the echo area."
     (when msg (message "Color: `%s'" color))
     color))
 
-
-(defun face-at-point ()
+(defun face-at-point (&optional thing multiple)
   "Return the face of the character after point.
 If it has more than one face, return the first one.
-Return nil if it has no specified face."
-  (let* ((faceprop (or (get-char-property (point) 'read-face-name)
-                       (get-char-property (point) 'face)
-                       'default))
-         (face (cond ((symbolp faceprop) faceprop)
-                     ;; List of faces (don't treat an attribute spec).
-                     ;; Just use the first face.
-                     ((and (consp faceprop) (not (keywordp (car faceprop)))
-                           (not (memq (car faceprop)
-                                     '(foreground-color background-color))))
-                      (car faceprop))
-                     (t nil))))         ; Invalid face value.
-    (if (facep face) face nil)))
+If THING is non-nil try first to get a face name from the buffer.
+IF MULTIPLE is non-nil, return a list of all faces.
+Return nil if there is no face."
+  (let (faces)
+    (if thing
+        ;; Try to get a face name from the buffer.
+        (let ((face (intern-soft (thing-at-point 'symbol))))
+          (if (facep face)
+              (push face faces))))
+    ;; Add the named faces that the `read-face-name' or `face' property uses.
+    (let ((faceprop (or (get-char-property (point) 'read-face-name)
+                        (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))))
+             (dolist (face faceprop)
+               (if (facep face)
+                   (push face faces))))))
+    (setq faces (delete-dups (nreverse faces)))
+    (if multiple faces (car faces))))
 
 (defun foreground-color-at-point ()
   "Return the foreground color of the character after point."