;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998
+;; 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
actually specified in the same way (equal attributes) or if it is
fully-unspecified, and thus inherits the attributes of any face it
is displayed on top of."
- (or (internal-lisp-face-empty-p face frame)
- (not (internal-lisp-face-equal-p face 'default frame))))
+ (cond ((eq frame t) (setq frame nil))
+ ((null frame) (setq frame (selected-frame))))
+ (let* ((v1 (internal-lisp-face-p face frame))
+ (n (if v1 (length v1) 0))
+ (v2 (internal-lisp-face-p 'default frame))
+ (i 1))
+ (unless v1
+ (error "Not a face: %S" face))
+ (while (and (< i n)
+ (or (eq 'unspecified (aref v1 i))
+ (equal (aref v1 i) (aref v2 i))))
+ (setq i (1+ i)))
+ (< i n)))
(defun face-nontrivial-p (face &optional frame)
If FRAME is omitted or nil, use the selected frame.
Use `face-attribute' for finer control."
(let ((bold (face-attribute face :weight frame)))
- (not (memq bold '(normal unspecified)))))
+ (memq bold '(semi-bold bold extra-bold ultra-bold))))
(defun face-italic-p (face &optional frame)
If FRAME is omitted or nil, use the selected frame.
Use `face-attribute' for finer control."
(let ((italic (face-attribute face :slant frame)))
- (not (memq italic '(normal unspecified)))))
+ (memq italic '(italic oblique))))
(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")
match (cond ((eq req 'type)
(or (memq window-system options)
(and (null window-system)
- (memq 'tty options))))
+ (memq 'tty options))
+ (and (memq 'motif options)
+ (featurep 'motif))
+ (and (memq 'lucid options)
+ (featurep 'x-toolkit)
+ (not (featurep 'motif)))
+ (and (memq 'x-toolkit options)
+ (featurep 'x-toolkit))))
((eq req 'class)
(memq (frame-parameter frame 'display-type) options))
((eq req 'background)
(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)
(defun face-set-after-frame-default (frame)
- "Set frame-local faces of FRAME from face specs and resources."
+ "Set frame-local faces of FRAME from face specs and resources.
+Initialize colors of certain faces from frame parameters."
(dolist (face (face-list))
(let ((spec (or (get face 'saved-face)
(get face 'face-defface-spec))))
(face-spec-set face spec frame))
(internal-merge-in-global-face face frame)
(when (memq window-system '(x w32))
- (make-face-x-resource-internal face frame)))))
+ (make-face-x-resource-internal face frame))))
+
+ ;; Initialize attributes from frame parameters.
+ (let ((params '((foreground-color default :foreground)
+ (background-color default :background)
+ (border-color border :background)
+ (cursor-color cursor :background)
+ (scroll-bar-foreground scroll-bar :foreground)
+ (scroll-bar-background scroll-bar :background)
+ (mouse-color mouse :background))))
+ (while params
+ (let ((param-name (nth 0 (car params)))
+ (face (nth 1 (car params)))
+ (attr (nth 2 (car params)))
+ value)
+ (when (setq value (frame-parameter frame param-name))
+ (set-face-attribute face frame attr value)))
+ (setq params (cdr params)))))
(defun tty-create-frame-with-faces (&optional parameters)
;;; Standard faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Make the standard faces. The C code knows faces `default',
-;; `modeline', `tool-bar' and `region', so they must be the first faces
-;; made. Unspecified attributes of these three faces are filled-in
-;; from frame parameters in the C code.
-
(defgroup basic-faces nil
"The standard faces of Emacs."
:group 'faces)
:group 'basic-faces)
-(defface modeline
+(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.
+(put 'modeline 'face-alias 'mode-line)
(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."
+ :version "21.1"
:group 'basic-faces)
(: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."
+ :version "21.1"
:group 'basic-faces)
(((class color) (background light))
(:background "lightblue"))
(t (:background "gray")))
- "Basic face for highlight the region."
+ "Basic face for highlighting the region."
:group 'basic-faces)
-(defface margin
+(defface fringe
'((((class color))
(:background "grey95"))
(t
(:background "gray")))
- "Basic face for the margins to the left and right of windows under X."
+ "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)
+
+
+(defface menu
+ '((((type x-toolkit)) ())
+ (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)
(((class color) (background dark))
(:background "darkolivegreen"))
(t (:inverse-video t)))
- "Basic face for highlighting.")
+ "Basic face for highlighting."
+ :group 'basic-faces)
(defface secondary-selection
'((((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.")
+ "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)
(((class color) (background dark))
(:background "red"))
(t (:inverse-video t)))
- "Basic face for highlighting trailing whitespace.")
+ "Basic face for highlighting trailing whitespace."
+ :version "21.1"
+ :group 'font-lock ; like `show-trailing-whitespace'
+ :group 'basic-faces)
\f