;;; 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, 2010, 2011
+;; 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
;; 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" "fixed")
+ ("courier" "CMU Typewriter Text" "fixed")
("Sans Serif" "helv" "helvetica" "arial" "fixed")
- ("helv" "helvetica" "arial" "fixed"))
- "*Alist of alternative font family names.
+ ("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
ALTERNATIVE2 etc."
;; 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")))
- "*Alist of alternative font registry names.
+ ("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
tries to find a best matching font among all fonts of registry
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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")))
- "*List of X resources and classes for face attributes.
+ (: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
\(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
(defun set-face-attributes-from-resources (face frame)
"Set attributes of FACE from X resources for FRAME."
- (when (memq (framep frame) '(x w32 mac ns))
+ (when (memq (framep frame) '(x w32))
(dolist (definition face-x-resources)
(let ((attribute (car definition)))
(dolist (entry (cdr definition))
(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:
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 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 (or (stringp foundry) (eq foundry 'unspecified))
+ (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.
(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
(:family
(if (window-system frame)
- (mapcar #'(lambda (x) (cons (car x) (car x)))
+ (mapcar (lambda (x) (cons x x))
(font-family-list))
;; Only one font on TTYs.
(list (cons "default" "default"))))
(:foundry
(list nil))
(:width
- (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-width-table))
(:weight
- (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-weight-table))
(:slant
- (mapcar #'(lambda (x) (cons (symbol-name (car x)) (car x)))
+ (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1)))
font-slant-table))
(:inverse-video
(mapcar #'(lambda (x) (cons (symbol-name x) x))
((:height)
'integerp)
(:stipple
- (and (memq (window-system frame) '(x w32 mac ns))
+ (and (memq (window-system frame) '(x ns)) ; No stipple on w32
(mapcar #'list
(apply #'nconc
(mapcar (lambda (dir)
valid)))
-(defvar face-attribute-name-alist
+(defconst face-attribute-name-alist
'((:family . "font family")
(:foundry . "font foundry")
(:width . "character set width")
;; explicitly in VALID, using color approximation code
;; in tty-colors.el.
(when (and (memq attribute '(:foreground :background))
- (not (memq (window-system frame) '(x w32 mac ns)))
+ (not (memq (window-system frame) '(x w32 ns)))
(not (member new-value
'("unspecified"
"unspecified-fg" "unspecified-bg"))))
;;; 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
(: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)))
- (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)))
- ;; The next 4 sexps are copied from describe-function-1
- ;; and simplified.
- (setq file-name (symbol-file f 'defface))
- (setq file-name (describe-simplify-lib-file-name file-name))
- (when file-name
- (princ "Defined in `")
- (princ 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"))
+ ;; 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
+ (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.
The value may be different for frames on different display types.
If FRAME doesn't support colors, the value is nil.
If FRAME is nil, that stands for the selected frame."
- (if (memq (framep (or frame (selected-frame))) '(x w32 mac ns))
+ (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
(xw-defined-colors frame)
(mapcar 'car (tty-color-alist frame))))
(defalias 'x-defined-colors 'defined-colors)
\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
(if (member color '(unspecified "unspecified-bg" "unspecified-fg"))
nil
- (if (member (framep (or frame (selected-frame))) '(x w32 mac ns))
+ (if (member (framep (or frame (selected-frame))) '(x w32 ns))
(xw-color-defined-p color frame)
(numberp (tty-color-translate color frame)))))
(defalias 'x-color-defined-p 'color-defined-p)
\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
(if (member color '(unspecified "unspecified-fg" "unspecified-bg"))
nil
- (if (memq (framep (or frame (selected-frame))) '(x w32 mac ns))
+ (if (memq (framep (or frame (selected-frame))) '(x w32 ns))
(xw-color-values color frame)
(tty-color-values color frame))))
(defalias 'x-color-values 'color-values)
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 mac ns))
+ (if (memq (framep-on-display display) '(x w32 ns))
(xw-display-color-p display)
(tty-display-color-p display)))
(defalias 'x-display-color-p 'display-color-p)
"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 ns))
+ ((memq frame-type '(x w32 ns))
(x-display-grayscale-p display))
(t
(> (tty-color-gray-shades display) 2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
(declare-function x-get-resource "frame.c"
(attribute class &optional component subclass))
+(defvar inhibit-frame-set-background-mode nil)
+
(defun frame-set-background-mode (frame)
"Set up display-dependent faces on FRAME.
Display-dependent faces are those which have different definitions
according to the `background-mode' and `display-type' frame parameters."
- (let* ((bg-resource
- (and (window-system frame)
- (x-get-resource "backgroundMode" "BackgroundMode")))
- (bg-color (frame-parameter frame 'background-color))
- (terminal-bg-mode (terminal-parameter frame 'background-mode))
- (tty-type (tty-type frame))
- (bg-mode
- (cond (frame-background-mode)
- (bg-resource
- (intern (downcase bg-resource)))
- (terminal-bg-mode)
- ((and (null (window-system frame))
- ;; Unspecified frame background color can only
- ;; happen on tty's.
- (member bg-color '(nil unspecified "unspecified-bg")))
- ;; There is no way to determine the background mode
- ;; automatically, so we make a guess based on the
- ;; terminal type.
- (if (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type))
- 'light
- 'dark))
- ((equal bg-color "unspecified-fg") ; inverted colors
- (if (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type))
- 'dark
- 'light))
- ((>= (apply '+ (color-values bg-color frame))
- ;; Just looking at the screen, colors whose
- ;; values add up to .6 of the white total
- ;; still look dark to me.
- (* (apply '+ (color-values "white" frame)) .6))
- 'light)
- (t 'dark)))
- (display-type
- (cond ((null (window-system frame))
- (if (tty-display-color-p frame) 'color 'mono))
- ((display-color-p frame)
- 'color)
- ((x-display-grayscale-p frame)
- 'grayscale)
- (t 'mono)))
- (old-bg-mode
- (frame-parameter frame 'background-mode))
- (old-display-type
- (frame-parameter frame 'display-type)))
-
- (unless (and (eq bg-mode old-bg-mode) (eq display-type old-display-type))
- (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.
- ;; 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))
- (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)
- (cons 'display-type display-type)))
- ;; For all named faces, choose face specs matching the new frame
- ;; parameters, unless they have been locally modified.
- (dolist (face (face-list))
- (unless (memq face locally-modified-faces)
- (face-spec-recalc face frame)))))))
+ (unless inhibit-frame-set-background-mode
+ (let* ((bg-resource
+ (and (window-system frame)
+ (x-get-resource "backgroundMode" "BackgroundMode")))
+ (bg-color (frame-parameter frame 'background-color))
+ (terminal-bg-mode (terminal-parameter frame 'background-mode))
+ (tty-type (tty-type frame))
+ (default-bg-mode
+ (if (or (window-system frame)
+ (and tty-type
+ (string-match "^\\(xterm\\|\\rxvt\\|dtterm\\|eterm\\)"
+ tty-type)))
+ 'light
+ 'dark))
+ (non-default-bg-mode (if (eq default-bg-mode 'light) 'dark 'light))
+ (bg-mode
+ (cond (frame-background-mode)
+ (bg-resource (intern (downcase bg-resource)))
+ (terminal-bg-mode)
+ ((equal bg-color "unspecified-fg") ; inverted colors
+ non-default-bg-mode)
+ ((not (color-values bg-color frame))
+ default-bg-mode)
+ ((>= (apply '+ (color-values bg-color frame))
+ ;; Just looking at the screen, colors whose
+ ;; values add up to .6 of the white total
+ ;; still look dark to me.
+ (* (apply '+ (color-values "white" frame)) .6))
+ 'light)
+ (t 'dark)))
+ (display-type
+ (cond ((null (window-system frame))
+ (if (tty-display-color-p frame) 'color 'mono))
+ ((display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono)))
+ (old-bg-mode
+ (frame-parameter frame 'background-mode))
+ (old-display-type
+ (frame-parameter frame 'display-type)))
+
+ (unless (and (eq bg-mode old-bg-mode) (eq display-type old-display-type))
+ (let ((locally-modified-faces nil)
+ ;; Prevent face-spec-recalc from calling this function
+ ;; again, resulting in a loop (bug#911).
+ (inhibit-frame-set-background-mode t))
+ ;; Before modifying the frame parameters, 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. 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))
+ (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)
+ (cons 'display-type display-type)))
+ ;; For all named faces, choose face specs matching the new frame
+ ;; parameters, unless they have been locally modified.
+ (dolist (face (face-list))
+ (unless (memq face locally-modified-faces)
+ (face-spec-recalc face frame))))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 (or (cdr (assq 'name parameters))
+ (cdr (assq 'name default-frame-alist)))))
+ (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 default-frame-alist 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)
(declare-function x-create-frame "xfns.c" (parms))
(declare-function x-setup-function-keys "term/x-win" (frame))
-(declare-function tool-bar-setup "tool-bar" (&optional frame))
(defun x-create-frame-with-faces (&optional parameters)
"Create a frame from optional frame parameters PARAMETERS.
(x-handle-reverse-video frame parameters)
(frame-set-background-mode frame)
(face-set-after-frame-default frame parameters)
- ;; Make sure the tool-bar is ready to be enabled. The
- ;; `tool-bar-lines' frame parameter will not take effect
- ;; without this call.
- (tool-bar-setup frame)
(if (null visibility-spec)
(make-frame-visible frame)
(modify-frame-parameters frame (list visibility-spec)))
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)))
+ (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
(condition-case ()
(progn
;; Initialize faces from face spec and custom theme.
;; X resouces for the default face are applied during
;; x-create-frame.
(and (not (eq face 'default))
- (memq (window-system frame) '(x w32 mac))
+ (memq (window-system frame) '(x w32))
(make-face-x-resource-internal face frame))
;; Apply attributes specified by face-new-frame-defaults
(internal-merge-in-global-face face frame))
\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 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
'((default
:box (:line-width 1 :style released-button)
:foreground "black")
- (((type x w32 mac ns) (class color))
+ (((type x w32 ns) (class color))
:background "grey75")
(((type x) (class mono))
:background "grey"))
: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