changeset 31190:85a616c90339

(set-face-attribute): Update doc string. (face-attribute-name-alist): Add :inherit. (face-valid-attribute-values): Handle :inherit. (face-read-string): Rephrase prompt to be less confusing. Assume that DEFAULT is a string, since we must return a string. (face-read-integer): Use `format' to turn DEFAULT into an acceptable default for face-read-string. Match NEW-VALUE against the string "unspecified", not the symbol `unspecified', since that's what face-read-string returns. (read-face-attribute): Lookup a name for old-value in valid, and use it as a default if we find one. Treat all values from face-read-string as strings. If the default is used, don't do any more processing on the value, just use the old value directly. (read-face-and-attribute, modify-face): Tweak prompt. (read-face-name): Don't assume prompt ends with a space.

--- a/lisp/faces.el	Sat Aug 26 06:10:30 2000 +0000
+++ b/lisp/faces.el	Sat Aug 26 10:58:32 2000 +0000
@@ -451,8 +451,10 @@
 
 `: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,7 +538,13 @@
 
 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."
+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."
   (setq args (purecopy args))
   (cond ((null frame)
 	 ;; Change face on all frames.
@@ -731,7 +739,7 @@
 	(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 +784,13 @@
 		  (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 +809,8 @@
     (: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 +824,22 @@
 
 (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 +851,15 @@
 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 +880,27 @@
 		   (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")))
@@ -920,7 +939,7 @@
 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))))
 
@@ -938,7 +957,7 @@
 	   (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)))))