;;; faces.el --- Lisp faces
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
(defcustom face-font-selection-order
'(:width :height :weight :slant)
- "*A list specifying how face font selection chooses fonts.
+ "A list specifying how face font selection chooses fonts.
Each of the four symbols `:width', `:height', `:weight', and `:slant'
must appear once in the list, and the list must not contain any other
elements. Font selection first tries to find a best matching font
;; which are generally available.
(defcustom face-font-family-alternatives
'(("Monospace" "courier" "fixed")
- ("courier" "fixed")
+ ("courier" "CMU Typewriter Text" "fixed")
("Sans Serif" "helv" "helvetica" "arial" "fixed")
("helv" "helvetica" "arial" "fixed"))
- "*Alist of alternative font family names.
+ "Alist of alternative font family names.
Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
ALTERNATIVE2 etc."
("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
("muletibetan-2" "muletibetan-0")))
- "*Alist of alternative font registry names.
+ "Alist of alternative font registry names.
Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of registry REGISTRY can be loaded, font selection
tries to find a best matching font among all fonts of registry
(:italic (".attributeItalic" . "Face.AttributeItalic"))
(:font (".attributeFont" . "Face.AttributeFont"))
(:inherit (".attributeInherit" . "Face.AttributeInherit")))
- "*List of X resources and classes for face attributes.
+ "List of X resources and classes for face attributes.
Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
the name of a face attribute, and each ENTRY is a cons of the form
\(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
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."
- (let ((where (if (null frame) 0 frame)))
- (setq args (purecopy args))
+ (setq args (purecopy args))
+ (let ((where (if (null frame) 0 frame))
+ (spec args)
+ family foundry)
;; If we set the new-frame defaults, this face is modified outside Custom.
(if (memq where '(0 t))
(put (or (get face 'face-alias) face) 'face-modified t))
+ ;; If family and/or foundry are specified, set it first. Certain
+ ;; face attributes, e.g. :weight semi-condensed, are not supported
+ ;; in every font. See bug#1127.
+ (while spec
+ (cond ((eq (car spec) :family)
+ (setq family (cadr spec)))
+ ((eq (car spec) :foundry)
+ (setq foundry (cadr spec))))
+ (setq spec (cddr spec)))
+ (when (or family foundry)
+ (when (and (stringp family)
+ (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+ (unless foundry
+ (setq foundry (match-string 2 family)))
+ (setq family (match-string 1 family)))
+ (when (stringp family)
+ (internal-set-lisp-face-attribute face :family (purecopy family)
+ where))
+ (when (stringp foundry)
+ (internal-set-lisp-face-attribute face :foundry (purecopy foundry)
+ where)))
(while args
- ;; Don't recursively set the attributes from the frame's font param
- ;; when we update the frame's font param from the attributes.
- (if (and (eq (car args) :family)
- (stringp (cadr args))
- (string-match "\\([^-]*\\)-\\([^-]*\\)" (cadr args)))
- (let ((foundry (match-string 1 (cadr args)))
- (family (match-string 2 (cadr args))))
- (internal-set-lisp-face-attribute face :foundry
- (purecopy foundry)
- where)
- (internal-set-lisp-face-attribute face :family
- (purecopy family)
- where))
+ (unless (memq (car args) '(:family :foundry))
(internal-set-lisp-face-attribute face (car args)
(purecopy (cadr args))
where))
- (setq args (cdr (cdr args))))))
-
+ (setq args (cddr args)))))
(defun make-face-bold (face &optional frame noerror)
"Make the font of FACE be bold, if possible.
(case attribute
(:family
(if (window-system frame)
- (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (mapcar (lambda (x) (cons x x))
(font-family-list))
;; Only one font on TTYs.
(list (cons "default" "default"))))
((:height)
'integerp)
(:stipple
- (and (memq (window-system frame) '(x w32 ns))
+ (and (memq (window-system frame) '(x ns)) ; No stipple on w32
(mapcar #'list
(apply #'nconc
(mapcar (lambda (dir)
(set-buffer standard-output)
(dolist (f face)
(if (stringp f) (setq f (intern f)))
- (insert "Face: " (symbol-name f))
- (if (not (facep f))
- (insert " undefined face.\n")
- (let ((customize-label "customize this face")
- file-name)
- (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
- (princ (concat " (" customize-label ")\n"))
- (insert "Documentation: "
- (or (face-documentation f)
- "Not documented as a face.")
- "\n")
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward
- (concat "\\(" customize-label "\\)") nil t)
- (help-xref-button 1 'help-customize-face f)))
- (setq file-name (find-lisp-object-file-name f 'defface))
- (when file-name
- (princ "Defined in `")
- (princ (file-name-nondirectory file-name))
- (princ "'")
- ;; Make a hyperlink to the library.
- (save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-face-def f file-name))
- (princ ".")
- (terpri)
- (terpri))
- (dolist (a attrs)
- (let ((attr (face-attribute f (car a) frame)))
- (insert (make-string (- max-width (length (cdr a))) ?\s)
- (cdr a) ": " (format "%s" attr))
- (if (and (eq (car a) :inherit)
- (not (eq attr 'unspecified)))
- ;; Make a hyperlink to the parent face.
- (save-excursion
- (re-search-backward ": \\([^:]+\\)" nil t)
- (help-xref-button 1 'help-face attr)))
- (insert "\n")))))
- (terpri))))))
+ ;; We may get called for anonymous faces (i.e., faces
+ ;; expressed using prop-value plists). Those can't be
+ ;; usefully customized, so ignore them.
+ (when (symbolp f)
+ (insert "Face: " (symbol-name f))
+ (if (not (facep f))
+ (insert " undefined face.\n")
+ (let ((customize-label "customize this face")
+ file-name)
+ (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
+ (princ (concat " (" customize-label ")\n"))
+ (insert "Documentation: "
+ (or (face-documentation f)
+ "Not documented as a face.")
+ "\n")
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 'help-customize-face f)))
+ (setq file-name (find-lisp-object-file-name f 'defface))
+ (when file-name
+ (princ "Defined in `")
+ (princ (file-name-nondirectory file-name))
+ (princ "'")
+ ;; Make a hyperlink to the library.
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-face-def f file-name))
+ (princ ".")
+ (terpri)
+ (terpri))
+ (dolist (a attrs)
+ (let ((attr (face-attribute f (car a) frame)))
+ (insert (make-string (- max-width (length (cdr a))) ?\s)
+ (cdr a) ": " (format "%s" attr))
+ (if (and (eq (car a) :inherit)
+ (not (eq attr 'unspecified)))
+ ;; Make a hyperlink to the parent face.
+ (save-excursion
+ (re-search-backward ": \\([^:]+\\)" nil t)
+ (help-xref-button 1 'help-face attr)))
+ (insert "\n")))))
+ (terpri)))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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))))
;; Reset each frame according to the rules implied by all its specs.
(dolist (frame (frame-list))
(face-spec-recalc face frame))))
(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))))))
+ (let* ((spec (face-spec-choose spec frame))
+ attrs)
+ (while spec
+ (when (assq (car spec) face-x-resources)
+ (push (car spec) attrs)
+ (push (cadr spec) attrs))
+ (setq spec (cddr spec)))
+ (apply 'set-face-attribute face frame (nreverse attrs))))
(defun face-attr-match-p (face attrs &optional frame)
"Return t if attributes of FACE match values in plist ATTRS.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom frame-background-mode nil
- "*The brightness of the background.
+ "The brightness of the background.
Set this to the symbol `dark' if your background color is dark,
`light' if your background is light, or nil (automatic by default)
if you want Emacs to examine the brightness for you. Don't set this
;; X resouces for the default face are applied during
;; x-create-frame.
(and (not (eq face 'default))
- (memq (window-system frame) '(x w32 ns))
+ (memq (window-system frame) '(x w32 ns))
(make-face-x-resource-internal face frame))
;; Apply attributes specified by face-new-frame-defaults
(internal-merge-in-global-face face frame))