;; 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.
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.
(setq file-name (find-lisp-object-file-name f 'defface))
(when file-name
(princ "Defined in `")
- (princ file-name)
+ (princ (file-name-nondirectory file-name))
(princ "'")
;; Make a hyperlink to the library.
(save-excursion
;; 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.
(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))
+ (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)
+ ;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)))
HCoop / bpt / emacs.git / blobdiff