diff options
| -rw-r--r-- | lisp/faces.el | 97 |
1 files changed, 52 insertions, 45 deletions
diff --git a/lisp/faces.el b/lisp/faces.el index 003d732f141..8ed46f6e876 100644 --- a/lisp/faces.el +++ b/lisp/faces.el | |||
| @@ -720,37 +720,43 @@ and colors. If it is nil or not specified, the selected frame is | |||
| 720 | used. Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value | 720 | used. Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value |
| 721 | out of a set of discrete values. Value is `integerp' if ATTRIBUTE expects | 721 | out of a set of discrete values. Value is `integerp' if ATTRIBUTE expects |
| 722 | an integer value." | 722 | an integer value." |
| 723 | (case attribute | 723 | (let (valid) |
| 724 | (:family | 724 | (setq valid |
| 725 | (if window-system | 725 | (case attribute |
| 726 | (mapcar #'(lambda (x) (cons (car x) (car x))) | 726 | (:family |
| 727 | (x-font-family-list)) | 727 | (if window-system |
| 728 | ;; Only one font on TTYs. | 728 | (mapcar #'(lambda (x) (cons (car x) (car x))) |
| 729 | (cons "default" "default"))) | 729 | (x-font-family-list)) |
| 730 | ((:width :weight :slant :inverse-video) | 730 | ;; Only one font on TTYs. |
| 731 | (mapcar #'(lambda (x) (cons (symbol-name x) x)) | 731 | (list (cons "default" "default")))) |
| 732 | (internal-lisp-face-attribute-values attribute))) | 732 | ((:width :weight :slant :inverse-video) |
| 733 | ((:underline :overline :strike-through :box) | 733 | (mapcar #'(lambda (x) (cons (symbol-name x) x)) |
| 734 | (if window-system | 734 | (internal-lisp-face-attribute-values attribute))) |
| 735 | (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) | 735 | ((:underline :overline :strike-through :box) |
| 736 | (internal-lisp-face-attribute-values attribute)) | 736 | (if window-system |
| 737 | (mapcar #'(lambda (c) (cons c c)) | 737 | (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) |
| 738 | (x-defined-colors frame))) | 738 | (internal-lisp-face-attribute-values attribute)) |
| 739 | (mapcar #'(lambda (x) (cons (symbol-name x) x)) | 739 | (mapcar #'(lambda (c) (cons c c)) |
| 740 | (internal-lisp-face-attribute-values attribute)))) | 740 | (x-defined-colors frame))) |
| 741 | ((:foreground :background) | 741 | (mapcar #'(lambda (x) (cons (symbol-name x) x)) |
| 742 | (mapcar #'(lambda (c) (cons c c)) | 742 | (internal-lisp-face-attribute-values attribute)))) |
| 743 | (or (and window-system (x-defined-colors frame)) | 743 | ((:foreground :background) |
| 744 | (tty-defined-colors)))) | 744 | (mapcar #'(lambda (c) (cons c c)) |
| 745 | ((:height) | 745 | (or (and window-system (x-defined-colors frame)) |
| 746 | 'integerp) | 746 | (tty-defined-colors)))) |
| 747 | (:stipple | 747 | ((:height) |
| 748 | (and window-system | 748 | 'integerp) |
| 749 | (mapcar #'list | 749 | (:stipple |
| 750 | (apply #'nconc (mapcar #'directory-files | 750 | (and window-system |
| 751 | x-bitmap-file-path))))) | 751 | (mapcar #'list |
| 752 | (t | 752 | (apply #'nconc (mapcar #'directory-files |
| 753 | (error "Internal error")))) | 753 | x-bitmap-file-path))))) |
| 754 | (t | ||
| 755 | (error "Internal error")))) | ||
| 756 | (if (listp valid) | ||
| 757 | (nconc (list (cons "unspecified" 'unspecified)) valid) | ||
| 758 | valid))) | ||
| 759 | |||
| 754 | 760 | ||
| 755 | 761 | ||
| 756 | (defvar face-attribute-name-alist | 762 | (defvar face-attribute-name-alist |
| @@ -785,9 +791,7 @@ value to return if no new value is entered. NAME is a descriptive | |||
| 785 | name of the attribute for prompting. COMPLETION-ALIST is an alist | 791 | name of the attribute for prompting. COMPLETION-ALIST is an alist |
| 786 | of valid values, if non-nil. | 792 | of valid values, if non-nil. |
| 787 | 793 | ||
| 788 | Entering ``none'' as attribute value means an unspecified attribute | 794 | Entering nothing accepts the default value DEFAULT. |
| 789 | value. Entering nothing accepts the default value DEFAULT. | ||
| 790 | |||
| 791 | Value is the new attribute value." | 795 | Value is the new attribute value." |
| 792 | (let* ((completion-ignore-case t) | 796 | (let* ((completion-ignore-case t) |
| 793 | (value (completing-read | 797 | (value (completing-read |
| @@ -798,9 +802,7 @@ Value is the new attribute value." | |||
| 798 | default))) | 802 | default))) |
| 799 | (format "Set face %s %s: " face name)) | 803 | (format "Set face %s %s: " face name)) |
| 800 | completion-alist))) | 804 | completion-alist))) |
| 801 | (if (equal value "none") | 805 | (if (equal value "") default value))) |
| 802 | nil | ||
| 803 | (if (equal value "") default value)))) | ||
| 804 | 806 | ||
| 805 | 807 | ||
| 806 | (defun face-read-integer (face default name) | 808 | (defun face-read-integer (face default name) |
| @@ -808,11 +810,16 @@ Value is the new attribute value." | |||
| 808 | FACE is the face whose attribute is read. DEFAULT is the default | 810 | FACE is the face whose attribute is read. DEFAULT is the default |
| 809 | value to return if no new value is entered. NAME is a descriptive | 811 | value to return if no new value is entered. NAME is a descriptive |
| 810 | name of the attribute for prompting. Value is the new attribute value." | 812 | name of the attribute for prompting. Value is the new attribute value." |
| 811 | (let ((new-value (face-read-string face | 813 | (let ((new-value |
| 812 | (and default (int-to-string default)) | 814 | (face-read-string face |
| 813 | name))) | 815 | (if (eq default 'unspecified) |
| 814 | (and new-value | 816 | 'unspecified |
| 815 | (string-to-int new-value)))) | 817 | (int-to-string default)) |
| 818 | name | ||
| 819 | (list (cons "unspecified" 'unspecified))))) | ||
| 820 | (if (eq new-value 'unspecified) | ||
| 821 | new-value | ||
| 822 | (string-to-int new-value)))) | ||
| 816 | 823 | ||
| 817 | 824 | ||
| 818 | (defun read-face-attribute (face attribute &optional frame) | 825 | (defun read-face-attribute (face attribute &optional frame) |
| @@ -834,9 +841,9 @@ of a global face. Value is the new attribute value." | |||
| 834 | (setq old-value (prin1-to-string old-value))) | 841 | (setq old-value (prin1-to-string old-value))) |
| 835 | (cond ((listp valid) | 842 | (cond ((listp valid) |
| 836 | (setq new-value | 843 | (setq new-value |
| 837 | (cdr (assoc (face-read-string face old-value | 844 | (face-read-string face old-value attribute-name valid)) |
| 838 | attribute-name valid) | 845 | (unless (eq new-value 'unspecified) |
| 839 | valid)))) | 846 | (setq new-value (cdr (assoc new-value valid))))) |
| 840 | ((eq valid 'integerp) | 847 | ((eq valid 'integerp) |
| 841 | (setq new-value (face-read-integer face old-value attribute-name))) | 848 | (setq new-value (face-read-integer face old-value attribute-name))) |
| 842 | (t (error "Internal error"))) | 849 | (t (error "Internal error"))) |