;;; faces.el --- Lisp faces
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; unavailable, and we fall back on the courier and helv families,
;; which are generally available.
(defcustom face-font-family-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
'(("Monospace" "courier" "fixed")
("courier" "CMU Typewriter Text" "fixed")
("Sans Serif" "helv" "helvetica" "arial" "fixed")
- ("helv" "helvetica" "arial" "fixed"))
+ ("helv" "helvetica" "arial" "fixed")))
"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
;; This is defined originally in xfaces.c.
(defcustom face-font-registry-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
(if (eq system-type 'windows-nt)
'(("iso8859-1" "ms-oemlatin")
("gb2312.1980" "gb2312" "gbk" "gb18030")
'(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
- ("muletibetan-2" "muletibetan-0")))
+ ("muletibetan-2" "muletibetan-0"))))
"Alist of alternative font registry names.
Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of registry REGISTRY can be loaded, font selection
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom face-x-resources
+ (mapcar
+ (lambda (arg)
+ ;; FIXME; can we purecopy some of the conses too?
+ (cons (car arg)
+ (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg))))))
'((:family (".attributeFamily" . "Face.AttributeFamily"))
(:foundry (".attributeFoundry" . "Face.AttributeFoundry"))
(:width (".attributeWidth" . "Face.AttributeWidth"))
(:bold (".attributeBold" . "Face.AttributeBold"))
(:italic (".attributeItalic" . "Face.AttributeItalic"))
(:font (".attributeFont" . "Face.AttributeFont"))
- (:inherit (".attributeInherit" . "Face.AttributeInherit")))
+ (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
"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
(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,
+If FRAME is omitted or nil the value describes the default attributes,
but if you specify FRAME, the value describes the attributes
of FACE on FRAME."
(mapcar (lambda (pair)
(if alias
(progn
(setq doc (get alias 'face-documentation))
- (format "%s is an alias for the face `%s'.%s" face alias
+ (format "%s is an alias for the face `%s'.%s" face alias
(if doc (format "\n%s" doc)
"")))
(get face 'face-documentation))))
attribute is changed on all frames).
ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a valid
-face attribute name. All attributes can be set to `unspecified';
+face attribute name. All attributes can be set to `unspecified';
this fact is not further mentioned below.
The following attributes are recognized:
(when (and (stringp family)
(string-match "\\([^-]*\\)-\\([^-]*\\)" family))
(unless foundry
- (setq foundry (match-string 2 family)))
- (setq family (match-string 1 family)))
- (when (stringp family)
+ (setq foundry (match-string 1 family)))
+ (setq family (match-string 2 family)))
+ (when (or (stringp family) (eq family 'unspecified))
(internal-set-lisp-face-attribute face :family (purecopy family)
where))
- (when (stringp foundry)
+ (when (or (stringp foundry) (eq foundry 'unspecified))
(internal-set-lisp-face-attribute face :foundry (purecopy foundry)
where)))
(while args
;;; Interactively modifying faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun read-face-name (prompt &optional string-describing-default multiple)
+(defun read-face-name (prompt &optional default multiple)
"Read a face, defaulting to the face or faces on the char after point.
If it has the property `read-face-name', that overrides the `face' property.
PROMPT should be a string that describes what the caller will do with the face;
it should not end in a space.
-STRING-DESCRIBING-DEFAULT should describe what default the caller will use if
-the user just types RET; you can omit it.
+The optional argument DEFAULT provides the value to display in the
+minibuffer prompt that is returned if the user just types RET
+unless DEFAULT is a string (in which case nil is returned).
If MULTIPLE is non-nil, return a list of faces (possibly only one).
Otherwise, return a single face."
(let ((faceprop (or (get-char-property (point) 'read-face-name)
(let* ((input
;; Read the input.
(completing-read-multiple
- (if (or faces string-describing-default)
- (format "%s (default %s): " prompt
+ (if (or faces default)
+ (format "%s (default `%s'): " prompt
(if faces (mapconcat 'symbol-name faces ",")
- string-describing-default))
+ default))
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history
;; Canonicalize the output.
(output
(cond ((or (equal input "") (equal input '("")))
- faces)
+ (or faces (unless (stringp default) default)))
((stringp input)
(mapcar 'intern (split-string input ", *" t)))
((listp input)
(defun face-valid-attribute-values (attribute &optional frame)
"Return valid values for face attribute ATTRIBUTE.
The optional argument FRAME is used to determine available fonts
-and colors. If it is nil or not specified, the selected frame is
-used. Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value
-out of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
+and colors. If it is nil or not specified, the selected frame is used.
+Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out
+of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
an integer value."
(let ((valid
(case attribute
valid)))
-(defvar face-attribute-name-alist
+(defconst face-attribute-name-alist
'((:family . "font family")
(:foundry . "font foundry")
(:width . "character set width")
;;; Listing faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar list-faces-sample-text
+(defconst list-faces-sample-text
"abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"*Text string to display as the sample text for `list-faces-display'.")
(setq max-length (1+ max-length)
line-format (format "%%-%ds" max-length))
(with-help-window "*Faces*"
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
(setq truncate-lines t)
(insert
(substitute-command-keys
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" "= `default' face" t)))
+ (interactive (list (read-face-name "Describe face" 'default t)))
(let* ((attrs '((:family . "Family")
(:foundry . "Foundry")
(:width . "Width")
(:inherit . "Inherit")))
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
attrs))))
- (help-setup-xref (list #'describe-face face) (interactive-p))
+ (help-setup-xref (list #'describe-face face)
+ (called-interactively-p 'interactive))
(unless face
(setq face 'default))
(if (not (listp face))
(setq face (list face)))
(with-help-window (help-buffer)
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
(dolist (f face)
(if (stringp f) (setq f (intern f)))
;; We may get called for anonymous faces (i.e., faces
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")
+ ;; FIXME not sure how much of this belongs here, and
+ ;; how much in `face-documentation'. The latter is
+ ;; not used much, but needs to return nil for
+ ;; undocumented faces.
+ (let ((alias (get f 'face-alias))
+ (face f)
+ obsolete)
+ (when alias
+ (setq face alias)
+ (insert
+ (format "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+ (insert "\nDocumentation:\n"
+ (or (face-documentation face)
+ "Not documented as a face.")
+ "\n\n"))
(with-current-buffer standard-output
(save-excursion
(re-search-backward
(defun x-handle-named-frame-geometry (parameters)
"Add geometry parameters for a named frame to parameter list PARAMETERS.
Value is the new parameter list."
- (let* ((name (or (cdr (assq 'name parameters))
- (cdr (assq 'name default-frame-alist))))
- (x-resource-name name)
- (res-geometry (if name (x-get-resource "geometry" "Geometry"))))
- (when res-geometry
- (let ((parsed (x-parse-geometry res-geometry)))
- ;; If the resource specifies a position, call the position
- ;; and size "user-specified".
- (when (or (assq 'top parsed)
- (assq 'left parsed))
- (setq parsed (append '((user-position . t) (user-size . t)) parsed)))
- ;; Put the geometry parameters at the end. Copy
- ;; default-frame-alist so that they go after it.
- (setq parameters (append parameters default-frame-alist parsed))))
- parameters))
+ ;; Note that `x-resource-name' has a global meaning.
+ (let ((x-resource-name (cdr (assq 'name parameters))))
+ (when x-resource-name
+ ;; Before checking X resources, we must have an X connection.
+ (or (window-system)
+ (x-display-list)
+ (x-open-connection (or (cdr (assq 'display parameters))
+ x-display-name)))
+ (let (res-geometry parsed)
+ (and (setq res-geometry (x-get-resource "geometry" "Geometry"))
+ (setq parsed (x-parse-geometry res-geometry))
+ (setq parameters
+ (append parameters parsed
+ ;; If the resource specifies a position,
+ ;; take note of that.
+ (if (or (assq 'top parsed) (assq 'left parsed))
+ '((user-position . t) (user-size . t)))))))))
+ parameters)
(defun x-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter and X resource.
`x-create-frame' does not handle this one."
(when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
(let ((resource (x-get-resource "reverseVideo"
"ReverseVideo")))
(if resource
(declare-function x-setup-function-keys "term/x-win" (frame))
(defun x-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If PARAMETERS specify a frame name,
-handle X geometry resources for that name. If either PARAMETERS
-or `default-frame-alist' contains a `reverse' parameter, or
-the X resource ``reverseVideo'' is present, handle that.
-Value is the new frame created."
+ "Create and return a frame with frame parameters PARAMETERS.
+If PARAMETERS specify a frame name, handle X geometry resources
+for that name. If PARAMETERS includes a `reverse' parameter, or
+the X resource ``reverseVideo'' is present, handle that."
(setq parameters (x-handle-named-frame-geometry parameters))
(let* ((params (copy-tree parameters))
(visibility-spec (assq 'visibility parameters))
Calculate the face definitions using the face specs, custom theme
settings, X resources, and `face-new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
-frame parameters in PARAMETERS and `default-frame-alist'."
- (dolist (face (nreverse (face-list)))
+frame parameters in PARAMETERS."
+ (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
(condition-case ()
(progn
;; Initialize faces from face spec and custom theme.
(mouse-color mouse :background))))
(dolist (param face-params)
(let* ((param-name (nth 0 param))
- (value (cdr (or (assq param-name parameters)
- (assq param-name default-frame-alist)))))
+ (value (cdr (assq param-name parameters))))
(if value
(set-face-attribute (nth 1 param) frame
(nth 2 param) value))))))
(defun tty-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter for terminal frames."
- (when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)))
+ (when (cdr (assq 'reverse parameters))
(let* ((params (frame-parameters frame))
(bg (cdr (assq 'foreground-color params)))
(fg (cdr (assq 'background-color params))))
(defun tty-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If either PARAMETERS or `default-frame-alist'
-contains a `reverse' parameter, handle that. Value is the new frame
-created."
+ "Create and return a frame from optional frame parameters PARAMETERS.
+If PARAMETERS contains a `reverse' parameter, handle that."
(let ((frame (make-terminal-frame parameters))
success)
(unwind-protect
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Compatiblity with 20.2
+;;; Compatibility with 20.2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Update a frame's faces when we change its default font.
"Basic face for highlighting."
:group 'basic-faces)
+;; Region face: under NS, default to the system-defined selection
+;; color (optimized for the fixed white background of other apps),
+;; if background is light.
(defface region
'((((class color) (min-colors 88) (background dark))
:background "blue3")
+ (((class color) (min-colors 88) (background light) (type gtk))
+ :foreground "gtk_selection_fg_color"
+ :background "gtk_selection_bg_color")
+ (((class color) (min-colors 88) (background light) (type ns))
+ :background "ns_selection_color")
(((class color) (min-colors 88) (background light))
:background "lightgoldenrod2")
(((class color) (min-colors 16) (background dark))
:version "21.1"
:group 'mode-line-faces
:group 'basic-faces)
+;; No need to define aliases of this form for new faces.
+(define-obsolete-face-alias 'modeline 'mode-line "21.1")
(defface mode-line-inactive
'((default
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
+(define-obsolete-face-alias 'modeline-inactive 'mode-line-inactive "22.1")
(defface mode-line-highlight
'((((class color) (min-colors 88))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
+(define-obsolete-face-alias 'modeline-highlight 'mode-line-highlight "22.1")
(defface mode-line-emphasis
'((t (:weight bold)))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
-
-;; Make `modeline' an alias for `mode-line', for compatibility.
-(put 'modeline 'face-alias 'mode-line)
-(put 'modeline-inactive 'face-alias 'mode-line-inactive)
-(put 'modeline-highlight 'face-alias 'mode-line-highlight)
-(put 'modeline-buffer-id 'face-alias 'mode-line-buffer-id)
+(define-obsolete-face-alias 'modeline-buffer-id 'mode-line-buffer-id "22.1")
(defface header-line
'((default
:group 'menu
:group 'basic-faces)
+(defface help-argument-name '((((supports :slant italic)) :inherit italic))
+ "Face to highlight argument names in *Help* buffers."
+ :group 'help)
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulating font names.
(encoding "[^-]+")
)
(setq x-font-regexp
- (concat "\\`\\*?[-?*]"
+ (purecopy (concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
pixelsize - pointsize - resx - resy - spacing - avgwidth -
registry - encoding "\\*?\\'"
- ))
+ )))
(setq x-font-regexp-head
- (concat "\\`[-?*]" foundry - family - weight\? - slant\?
- "\\([-*?]\\|\\'\\)"))
- (setq x-font-regexp-slant (concat - slant -))
- (setq x-font-regexp-weight (concat - weight -))
+ (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\?
+ "\\([-*?]\\|\\'\\)")))
+ (setq x-font-regexp-slant (purecopy (concat - slant -)))
+ (setq x-font-regexp-weight (purecopy (concat - weight -)))
nil)
HCoop / bpt / emacs.git / blobdiff