;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;;; Code:
(eval-when-compile
- (require 'custom)
(require 'cl))
(require 'cus-face)
(defcustom face-font-family-alternatives
'(("courier" "fixed")
- ("helv" "helvetica" "fixed"))
+ ("helv" "helvetica" "arial" "fixed"))
"*Alist of alternative font family names.
Each element has the the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
(defun set-face-documentation (face string)
"Set the documentation string for FACE to STRING."
- (put face 'face-documentation string))
+ ;; Perhaps the text should go in DOC.
+ (put face 'face-documentation (purecopy string)))
(defalias 'face-doc-string 'face-documentation)
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."
+ (setq args (purecopy args))
(cond ((null frame)
;; Change face on all frames.
(dolist (frame (frame-list))
(t
(while args
(internal-set-lisp-face-attribute face (car args)
- (car (cdr args)) frame)
+ (purecopy (cadr args))
+ frame)
(setq args (cdr (cdr args)))))))
-(defun make-face-bold (face &optional frame)
+(defun make-face-bold (face &optional frame noerror)
"Make the font of FACE be bold, if possible.
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 ")))
(set-face-attribute face frame :weight 'bold))
-(defun make-face-unbold (face &optional frame)
+(defun make-face-unbold (face &optional frame noerror)
"Make the font of FACE be non-bold, if possible.
-FRAME nil or not specified means change face on all frames."
- (interactive (list (read-face-name "Make which face non-bold: ")))
+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 ")))
(set-face-attribute face frame :weight 'normal))
-(defun make-face-italic (face &optional frame)
+(defun make-face-italic (face &optional frame noerror)
"Make the font of FACE be italic, if possible.
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 ")))
(set-face-attribute face frame :slant 'italic))
-(defun make-face-unitalic (face &optional frame)
+(defun make-face-unitalic (face &optional frame noerror)
"Make the font of FACE be non-italic, if possible.
FRAME nil or not specified means change face on all frames."
- (interactive (list (read-face-name "Make which face non-italic: ")))
+ (interactive (list (read-face-name "Make which face non-italic ")))
(set-face-attribute face frame :slant 'normal))
-(defun make-face-bold-italic (face &optional frame)
+(defun make-face-bold-italic (face &optional frame noerror)
"Make the font of FACE be bold and italic, if possible.
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: ")))
(set-face-attribute face frame :weight 'bold :slant 'italic))
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 ")))
(let ((fg (face-attribute face :foreground frame))
(bg (face-attribute face :background frame)))
(if (or fg bg)
Value is a symbol naming a known face."
(let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x))
(face-list)))
+ (def (thing-at-point 'symbol))
face)
- (while (equal "" (setq face (completing-read prompt face-list nil t))))
+ (cond ((assoc def face-list)
+ (setq prompt (concat prompt "(default " def "): ")))
+ (t (setq def nil)
+ (setq prompt (concat prompt ": "))))
+ (while (equal "" (setq face (completing-read
+ prompt face-list nil t nil nil def))))
(intern face)))
(internal-lisp-face-attribute-values attribute))))
((:foreground :background)
(mapcar #'(lambda (c) (cons c c))
- (or (and window-system (x-defined-colors frame))
- (tty-defined-colors))))
+ (defined-colors frame)))
((:height)
'integerp)
(:stipple
name of the attribute for prompting. Value is the new attribute value."
(let ((new-value
(face-read-string face
- (if (eq default 'unspecified)
- 'unspecified
+ (if (memq default
+ '(unspecified
+ "unspecified-fg"
+ "unspecified-bg"))
+ default
(int-to-string default))
name
(list (cons "unspecified" 'unspecified)))))
- (if (eq new-value 'unspecified)
+ (if (memq new-value '(unspecified "unspecified-fg" "unspecified-bg"))
new-value
(string-to-int new-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)))))
((eq valid 'integerp)
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))))
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 (format "Set font-related attributes of face: "))
+ (let* ((prompt (format "Set font-related attributes of face "))
(face (read-face-name prompt))
(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))
+ (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)))))
(let ((faces (sort (face-list) #'string-lessp))
(face nil)
(frame (selected-frame))
- disp-frame window)
+ disp-frame window face-name)
(with-output-to-temp-buffer "*Faces*"
(save-excursion
(set-buffer standard-output)
(setq truncate-lines t)
+ (insert
+ (substitute-command-keys
+ (concat
+ "Use "
+ (if (display-mouse-p) "\\[help-follow-mouse] or ")
+ "\\[help-follow] on a face name to customize it\n"
+ "or on its sample text for a decription of the face.\n\n")))
+ (setq help-xref-stack nil)
(while faces
(setq face (car faces))
(setq faces (cdr faces))
- (insert (format "%25s " (face-name face)))
+ (setq face-name (symbol-name face))
+ (insert (format "%25s " face-name))
+ ;; Hyperlink to a customization buffer for the face. Using
+ ;; the help xref mechanism may not be the best way.
+ (save-excursion
+ (save-match-data
+ (search-backward face-name)
+ (help-xref-button 0 #'customize-face face-name
+ "mouse-2: customize this face")))
(let ((beg (point)))
(insert list-faces-sample-text)
+ ;; Hyperlink to a help buffer for the face.
+ (save-excursion
+ (save-match-data
+ (search-backward list-faces-sample-text)
+ (help-xref-button 0 #'describe-face face
+ "mouse-2: describe this face")))
(insert "\n")
(put-text-property beg (1- (point)) 'face face)
;; If the sample text has multiple lines, line up all of them.
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: ")))
+ (interactive (list (read-face-name "Describe face ")))
(let* ((attrs '((:family . "Family")
(:width . "Width")
(:height . "Height")
(face-attr-match-p face (face-spec-choose spec frame) frame))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Frame-type independent color support.
+;;; We keep the old x-* names as aliases for back-compatibility.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun defined-colors (&optional frame)
+ "Return a list of colors supported for a particular frame.
+The argument FRAME specifies which frame to try.
+The value may be different for frames on different display types.
+If FRAME doesn't support colors, the value is nil."
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-defined-colors frame)
+ (mapcar 'car (tty-color-alist frame))))
+(defalias 'x-defined-colors 'defined-colors)
+
+(defun color-defined-p (color &optional frame)
+ "Return non-nil if color COLOR is supported on frame FRAME.
+If FRAME is omitted or nil, use the selected frame.
+If COLOR is the symbol `unspecified' or one of the strings
+\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
+ (if (memq color '(unspecified "unspecified-bg" "unspecified-fg"))
+ nil
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-color-defined-p color frame)
+ (numberp (tty-color-translate color frame)))))
+(defalias 'x-color-defined-p 'color-defined-p)
+
+(defun color-values (color &optional frame)
+ "Return a description of the color named COLOR on frame FRAME.
+The value is a list of integer RGB values--\(RED GREEN BLUE\).
+These values appear to range from 0 to 65280 or 65535, depending
+on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
+If FRAME is omitted or nil, use the selected frame.
+If FRAME cannot display COLOR, the value is nil.
+If COLOR is the symbol `unspecified' or one of the strings
+\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
+ (if (memq color '(unspecified "unspecified-fg" "unspecified-bg"))
+ nil
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-color-values color frame)
+ (tty-color-values color frame))))
+(defalias 'x-color-values 'color-values)
+
+(defun display-color-p (&optional display)
+ "Return t if DISPLAY supports color.
+The optional argument DISPLAY specifies which display to ask about.
+DISPLAY should be either a frame or a display name (a string).
+If omitted or nil, that stands for the selected frame's display."
+ (if (memq (framep-on-display display) '(x w32))
+ (xw-display-color-p display)
+ (tty-display-color-p display)))
+(defalias 'x-display-color-p 'display-color-p)
+
+(defun display-grayscale-p (&optional display)
+ "Return non-nil if frames on DISPLAY can display shades of gray."
+ (let ((frame-type (framep-on-display display)))
+ (cond
+ ((memq frame-type '(x w32 mac))
+ (x-display-grayscale-p display))
+ (t
+ (> (tty-color-gray-shades display) 2)))))
+
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Background mode.
'dark)
(t 'light)))
(display-type (cond ((null window-system)
- (if (tty-display-color-p) 'color 'mono))
+ (if (tty-display-color-p frame) 'color 'mono))
((x-display-color-p frame)
'color)
((x-display-grayscale-p frame)
(defface mode-line
'((((type x) (class color))
(:box (:line-width 2 :style released-button) :background "grey75"))
+ (((type w32) (class color))
+ (:box (:line-width 2 :style released-button) :background "grey75"))
(t
(:inverse-video t)))
"Basic mode line face."
:version "21.1"
+ :group 'modeline
:group 'basic-faces)
;; Make `modeline' an alias for `mode-line', for compatibility.
(defface header-line
'((((type x) (class color))
(:box (:line-width 2 :style released-button) :background "grey75"))
+ (((type w32) (class color))
+ (:box (:line-width 2 :style released-button) :background "grey75"))
(t
(:inverse-video t)))
"Basic header-line face."
(:box (:line-width 1 :style released-button) :background "grey75"))
(((type x) (class mono))
(:box (:line-width 1 :style released-button) :background "grey"))
+ (((type w32) (class color))
+ (:box (:line-width 1 :style released-button) :background "grey75"))
(t
()))
"Basic tool-bar face."
(:background "gray")))
"Basic face for the fringes to the left and right of windows under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(defface scroll-bar '()
"Basic face for the scroll bar colors under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(t (:inverse-video t)))
"Basic menu face."
:version "21.1"
+ :group 'menu
:group 'basic-faces)
(defface border '()
"Basic face for the frame border under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(defface cursor '()
"Basic face for the cursor color under X."
:version "21.1"
+ :group 'cursor
:group 'basic-faces)
(defface mouse '()
"Basic face for the mouse color under X."
:version "21.1"
+ :group 'mouse
:group 'basic-faces)
'((((type tty) (class color))
(:background "cyan"))
(((class color) (background light))
- (:background "paleturquoise"))
+ (:background "yellow"))
(((class color) (background dark))
- (:background "darkslateblue"))
+ (:background "yellow"))
(t (:inverse-video t)))
"Basic face for displaying the secondary selection."
:group 'basic-faces)
-(defface fixed-pitch '((t (:family "courier*")))
+(defface fixed-pitch '((t (:family "courier")))
"The basic fixed-pitch face."
:group 'basic-faces)
-(defface variable-pitch '((t (:family "helv*")))
+(defface variable-pitch '((t (:family "helv")))
"The basic variable-pitch face."
:group 'basic-faces)
(t (:inverse-video t)))
"Basic face for highlighting trailing whitespace."
:version "21.1"
+ :group 'font-lock ; like `show-trailing-whitespace'
:group 'basic-faces)