;;; faces.el --- Lisp faces
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
- (require 'cl)
- ;; Warning suppression -- can't require x-win in batch:
- (autoload 'xw-defined-colors "x-win"))
+ (require 'cl))
+
+(declare-function xw-defined-colors "term/x-win" (&optional frame))
(defvar help-xref-stack-item)
\f
(defcustom face-font-registry-alternatives
(if (eq system-type 'windows-nt)
'(("iso8859-1" "ms-oemlatin")
- ("gb2312.1980" "gb2312")
+ ("gb2312.1980" "gb2312" "gbk" "gb18030")
("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
("muletibetan-2" "muletibetan-0"))
- '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk*")
+ '(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
("muletibetan-2" "muletibetan-0")))
(internal-set-alternative-font-registry-alist value)))
+(defconst font-weight-table
+ '((thin 0)
+ (ultra-light 20 ultralight)
+ (extra-light 40 extralight)
+ (light 50)
+ (semi-light 75 semilight demilight book)
+ (normal 100 medium regular)
+ (semi-bold 180 semibold demibold demi)
+ (bold 200)
+ (extra-bold 205 extrabold)
+ (ultra-bold 210 ultrabold black))
+ "Alist of font weight symbols vs the corresponding numeric values.
+Each element has the form:
+ \(SYMBOLIC-VALUE NUMERIC-VALUE ALIAS-SYMBOL ...)
+")
+
+(defconst font-slant-table
+ '((reverse-oblique 0 ro)
+ (reverse-italic 10 ri)
+ (normal 100 r)
+ (italic 200 i ot)
+ (oblique 210 o))
+ "Alist of font slant symbols vs the corresponding numeric values.
+See `font-weight-table' for the detailed format.")
+
+(defconst font-width-table
+ '((ultra-condensed 50 ultracondensed)
+ (extra-condensed 63 extracondensed)
+ (condensed 75 compressed narrow)
+ (semi-condensed 87 semicondensed semicondensed)
+ (normal 100 medium regular)
+ (semi-expanded 113 semiexpanded demiexpanded)
+ (expanded 125)
+ (extra-expanded 150 extraexpanded)
+ (ultra-expanded 200 ultraexpanded wide))
+ "Alist of font width symbols vs the corresponding numeric values.
+See `font-weight-table' for the detailed format.")
+
+(internal-set-font-style-table
+ font-weight-table font-slant-table font-width-table)
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creation, copying.
If the optional fourth argument NEW-FRAME is given,
copy the information from face OLD-FACE on frame FRAME
-to NEW-FACE on frame NEW-FRAME."
+to NEW-FACE on frame NEW-FRAME. In this case, FRAME may not be nil."
(let ((inhibit-quit t))
(if (null frame)
(progn
+ (when new-frame
+ (error "Copying face %s from all frames to one frame"
+ old-face))
+ (make-empty-face new-face)
(dolist (frame (frame-list))
(copy-face old-face new-face frame))
(copy-face old-face new-face t))
+ (make-empty-face new-face)
(internal-copy-lisp-face old-face new-face frame new-frame))
new-face))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun facep (face)
- "Return non-nil if FACE is a face name or internal face object.
-Return nil otherwise. A face name can be a string or a symbol.
-An internal face object is a vector of the kind used internally
-to record face data."
+ "Return non-nil if FACE is a face name; nil otherwise.
+A face name can be a string or a symbol."
(internal-lisp-face-p face))
If FRAME is t, report on the defaults for face FACE (for new frames).
If FRAME is omitted or nil, use the selected frame."
(let ((attrs
- '(:family :width :height :weight :slant :foreground
- :background :underline :overline :strike-through
- :box :inverse-video))
+ (delq :inherit (mapcar 'car face-attribute-name-alist)))
(differs nil))
(while (and attrs (not differs))
(let* ((attr (pop attrs))
(symbol-name (check-face face)))
+(defun face-all-attributes (face &optional frame)
+ "Return an alist stating the attributes of FACE.
+Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
+Normally the value describes the default attributes,
+but if you specify FRAME, the value describes the attributes
+of FACE on FRAME."
+ (mapcar (lambda (pair)
+ (let ((attr (car pair)))
+ (cons attr (face-attribute face attr (or frame t)))))
+ face-attribute-name-alist))
+
(defun face-attribute (face attribute &optional frame inherit)
"Return the value of FACE's ATTRIBUTE on FRAME.
If the optional argument FRAME is given, report on face FACE in that frame.
(if faces (mapconcat 'symbol-name faces ",")
string-describing-default))
(format "%s: " prompt))
- (complete-in-turn nonaliasfaces aliasfaces)
+ (completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil nil
(if faces (mapconcat 'symbol-name faces ","))))
;; Canonicalize the output.
(:family
(if (window-system frame)
(mapcar #'(lambda (x) (cons (car x) (car x)))
- (x-font-family-list))
+ (font-family-list))
;; Only one font on TTYs.
(list (cons "default" "default"))))
- ((:width :weight :slant :inverse-video)
- (mapcar #'(lambda (x) (cons (symbol-name x) x))
- (internal-lisp-face-attribute-values attribute)))
+ (:width
+ (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ font-width-table))
+ (:weight
+ (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ font-weight-table))
+ (:slant
+ (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ font-slant-table))
+ (:inverse-video
+ (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (internal-lisp-face-attribute-values attribute)))
((:underline :overline :strike-through :box)
(if (window-system frame)
(nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
If optional argument FRAME is nil or omitted, use the selected frame."
(let ((completion-ignore-case t))
(completing-read (format "Set font attributes of face `%s' from font: " face)
- (x-list-fonts "*" nil frame))))
+ (append (fontset-list) (x-list-fonts "*" nil frame)))))
(defun read-all-face-attributes (face &optional frame)
(:box . "Box")
(:inverse-video . "Inverse")
(:stipple . "Stipple")
- (:font . "Font or fontset")
+ (:font . "Font")
+ (:fontset . "Fontset")
(:inherit . "Inherit")))
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
attrs))))
(setq attrs (cdr attrs)))))
-(defun face-spec-set (face spec &optional frame)
- "Set FACE's attributes according to the first matching entry in SPEC.
-FRAME is the frame whose frame-local face is set. FRAME nil means
-do it on all frames (and change the default for new frames).
-See `defface' for information about SPEC. If SPEC is nil, do nothing."
- (let ((attrs (face-spec-choose spec frame)))
- (when spec
- (face-spec-reset-face face (or frame t)))
- (while attrs
- (let ((attribute (car attrs))
- (value (car (cdr attrs))))
- ;; Support some old-style attribute names and values.
- (case attribute
- (:bold (setq attribute :weight value (if value 'bold 'normal)))
- (:italic (setq attribute :slant value (if value 'italic 'normal)))
- ((:foreground :background)
- ;; Compatibility with 20.x. Some bogus face specs seem to
- ;; exist containing things like `:foreground nil'.
- (if (null value) (setq value 'unspecified)))
- (t (unless (assq attribute face-x-resources)
- (setq attribute nil))))
- (when attribute
- ;; If frame is nil, set the default for new frames.
- ;; Existing frames are handled below.
- (set-face-attribute face (or frame t) attribute value)))
- (setq attrs (cdr (cdr attrs)))))
- (unless frame
- ;; When we reset the face based on its spec, then it is unmodified
- ;; as far as Custom is concerned.
- (put (or (get face 'face-alias) face) 'face-modified nil)
-;;; ;; Clear all the new-frame defaults for this face.
+(defun face-spec-set (face spec &optional for-defface)
+ "Set FACE's face spec, which controls its appearance, to SPEC.
+If FOR-DEFFACE is t, set the base spec, the one that `defface'
+ and Custom set. (In that case, the caller must put it in the
+ appropriate property, because that depends on the caller.)
+If FOR-DEFFACE is nil, set the overriding spec (and store it
+ in the `face-override-spec' property of FACE).
+
+The appearance of FACE is controlled by the base spec,
+by any custom theme specs on top of that, and by the
+overriding spec on top of all the rest.
+
+FOR-DEFFACE can also be a frame, in which case we set the
+frame-specific attributes of FACE for that frame based on SPEC.
+That usage is deprecated.
+
+See `defface' for information about the format and meaning of SPEC."
+ (if (framep for-defface)
+ ;; Handle the deprecated case where third arg is a frame.
+ (face-spec-set-2 face for-defface spec)
+ (if for-defface
+ ;; When we reset the face based on its custom spec, then it is
+ ;; unmodified as far as Custom is concerned.
+ (put (or (get face 'face-alias) face) 'face-modified nil)
+ ;; When we change a face based on a spec from outside custom,
+ ;; record it for future frames.
+ (put (or (get face 'face-alias) face) 'face-override-spec spec))
+;;; RMS 29 dec 2007: Perhaps this code should be reinstated.
+;;; That depends on whether the overriding spec
+;;; or the default face attributes
+;;; should take priority.
+;;; ;; Clear all the new-frame default attributes for this face.
;;; ;; face-spec-reset-face won't do it right.
;;; (let ((facevec (cdr (assq face face-new-frame-defaults))))
;;; (dotimes (i (length facevec))
;;; (unless (= i 0)
;;; (aset facevec i 'unspecified))))
- ;; Set each frame according to the rules implied by SPEC.
+ ;; Reset each frame according to the rules implied by all its specs.
(dolist (frame (frame-list))
- (face-spec-set face spec frame))))
-
+ (face-spec-recalc face frame))))
+
+(defun face-spec-recalc (face frame)
+ "Reset the face attributes of FACE on FRAME according to its specs.
+This applies the defface/custom spec first, then the custom theme specs,
+then the override spec."
+ (face-spec-reset-face face frame)
+ (let ((face-sym (or (get face 'face-alias) face)))
+ (face-spec-set-2 face frame
+ (face-user-default-spec face))
+ (let ((theme-faces (reverse (get face-sym 'theme-face))))
+ (dolist (spec theme-faces)
+ (face-spec-set-2 face frame (cadr spec))))
+ (face-spec-set-2 face frame (get face-sym 'face-override-spec))))
+
+(defun face-spec-set-2 (face frame spec)
+ "Set the face attributes of FACE on FRAME according to SPEC."
+ (let* ((attrs (face-spec-choose spec frame)))
+ (while attrs
+ (let ((attribute (car attrs))
+ (value (car (cdr attrs))))
+ ;; Support some old-style attribute names and values.
+ (case attribute
+ (:bold (setq attribute :weight value (if value 'bold 'normal)))
+ (:italic (setq attribute :slant value (if value 'italic 'normal)))
+ ((:foreground :background)
+ ;; Compatibility with 20.x. Some bogus face specs seem to
+ ;; exist containing things like `:foreground nil'.
+ (if (null value) (setq value 'unspecified)))
+ (t (unless (assq attribute face-x-resources)
+ (setq attribute nil))))
+ (when attribute
+ (set-face-attribute face frame attribute value)))
+ (setq attrs (cdr (cdr attrs))))))
(defun face-attr-match-p (face attrs &optional frame)
"Return t if attributes of FACE match values in plist ATTRS.
;; (save-match-data
;; (dolist (this result)
;; (if (string-match " " this)
-;; (push (replace-regexp-in-string " " ""
+;; (push (replace-regexp-in-string " " ""
;; this)
;; to-be-rejected)))
;; (dolist (elt to-be-rejected)
(let ((locally-modified-faces nil))
;; Before modifying the frame parameters, we collect a list of
;; faces that don't match what their face-spec says they should
- ;; look like; we then avoid changing these faces below. A
- ;; negative list is used on the assumption that most faces will
+ ;; look like; we then avoid changing these faces below.
+ ;; These are the faces whose attributes were modified on FRAME.
+ ;; We use a negative list on the assumption that most faces will
;; be unmodified, so we can avoid consing in the common case.
(dolist (face (face-list))
- (when (not (face-spec-match-p face
- (face-user-default-spec face)
- (selected-frame)))
- (push face locally-modified-faces)))
+ (and (not (get face 'face-override-spec))
+ (not (face-spec-match-p face
+ (face-user-default-spec face)
+ (selected-frame)))
+ (push face locally-modified-faces)))
;; Now change to the new frame parameters
(modify-frame-parameters frame
(list (cons 'background-mode bg-mode)
;; parameters, unless they have been locally modified.
(dolist (face (face-list))
(unless (memq face locally-modified-faces)
- (face-spec-set face (face-user-default-spec face) frame)))))))
+ (face-spec-recalc face frame)))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(dolist (face (delq 'default (face-list)))
(condition-case ()
(progn
- (face-spec-set face (face-user-default-spec face) frame)
+ (face-spec-recalc face frame)
(if (memq (window-system frame) '(x w32 mac))
(make-face-x-resource-internal face frame))
(internal-merge-in-global-face face frame))
:group 'faces)
(defface default
- '((t nil))
+ '((t nil)) ; If this were nil, face-defface-spec would not be set.
"Basic default face."
:group 'basic-faces)
:group 'mode-line-faces
:group 'basic-faces)
+(defface mode-line-emphasis
+ '((t (:weight bold)))
+ "Face used to emphasize certain mode line features.
+Use the face `mode-line-highlight' for features that can be selected."
+ :version "23.1"
+ :group 'mode-line-faces
+ :group 'basic-faces)
+
(defface mode-line-buffer-id
'((t (:weight bold)))
"Face used for buffer identification parts of the mode line."