(declare-function xw-defined-colors "term/x-win" (&optional frame))
(defvar help-xref-stack-item)
+
+(defvar face-name-history nil
+ "History list for some commands that read face names.
+Maximum length of the history list is determined by the value
+of `history-length', which see.")
+
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Font selection.
(internal-set-font-selection-order value)))
-;; This is defined originally in xfaces.c.
+;; In the absence of Fontconfig support, Monospace and Sans Serif are
+;; unavailable, and we fall back on the courier and helv families,
+;; which are generally available.
(defcustom face-font-family-alternatives
- '(("courier" "fixed")
+ '(("Monospace" "courier" "fixed")
+ ("courier" "CMU Typewriter Text" "fixed")
+ ("Sans Serif" "helv" "helvetica" "arial" "fixed")
("helv" "helvetica" "arial" "fixed"))
"*Alist of alternative font family names.
Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
variants of FACE from X resources. (X resources recognized are found
in the global variable `face-x-resources'.) If FACE is already known
as a face, leave it unmodified. Value is FACE."
- (interactive "SMake face: ")
+ (interactive (list (read-from-minibuffer
+ "Make face: " nil nil t 'face-name-history)))
(unless (facep face)
;; Make frame-local faces (this also makes the global one).
(dolist (frame (frame-list))
(defun make-empty-face (face)
"Define a new, empty face with name FACE.
If the face already exists, it is left unmodified. Value is FACE."
- (interactive "SMake empty face: ")
+ (interactive (list (read-from-minibuffer
+ "Make empty face: " nil nil t 'face-name-history)))
(make-face face 'no-init-from-resources))
(defun set-face-attributes-from-resources (face frame)
"Set attributes of FACE from X resources for FRAME."
- (when (memq (framep frame) '(x w32 mac))
+ (when (memq (framep frame) '(x w32 ns))
(dolist (definition face-x-resources)
(let ((attribute (car definition)))
(dolist (entry (cdr definition))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar inhibit-face-set-after-frame-default nil
- "If non-nil, that tells `face-set-after-frame-default' to do nothing.")
-
(defun set-face-attribute (face frame &rest args)
"Set attributes of FACE on FRAME from ARGS.
`:family'
-VALUE must be a string specifying the font family, e.g. ``courier'',
+VALUE must be a string specifying the font family, e.g. ``monospace'',
or a fontset alias name. If a font family is specified, wild-cards `*'
and `?' are allowed.
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 fro the attributes.
- (let ((inhibit-face-set-after-frame-default t))
- (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))
- (internal-set-lisp-face-attribute face (car args)
- (purecopy (cadr args))
- where)))
- (setq args (cdr (cdr args))))))
-
+ (unless (memq (car args) '(:family :foundry))
+ (internal-set-lisp-face-attribute face (car args)
+ (purecopy (cadr args))
+ where))
+ (setq args (cddr args)))))
(defun make-face-bold (face &optional frame noerror)
"Make the font of FACE be bold, if possible.
string-describing-default))
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
- nil t nil nil
+ nil t nil 'face-name-history
(if faces (mapconcat 'symbol-name faces ","))))
;; Canonicalize the output.
(output
(case attribute
(:family
(if (window-system frame)
- (mapcar #'(lambda (x) (cons (car x) (car x)))
+ (mapcar #'(lambda (x) (cons (symbol-name 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))
+ (and (memq (window-system frame) '(x w32 ns))
(mapcar #'list
(apply #'nconc
(mapcar (lambda (dir)
;; 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)))
+ (not (memq (window-system frame) '(x w32 ns)))
(not (member new-value
'("unspecified"
"unspecified-fg" "unspecified-bg"))))
this regular expression. When called interactively with a prefix
arg, prompt for a regular expression."
(interactive (list (and current-prefix-arg
- (read-string "List faces matching regexp: "))))
+ (read-regexp "List faces matching regexp"))))
(let ((all-faces (zerop (length regexp)))
(frame (selected-frame))
(max-length 0)
(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))
+ (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.
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))
+ (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))
+ (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))
+ (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))
+ (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))
+ ((memq frame-type '(x w32 ns))
(x-display-grayscale-p display))
(t
(> (tty-color-gray-shades display) 2)))))
(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.
the X resource ``reverseVideo'' is present, handle that.
Value is the new frame created."
(setq parameters (x-handle-named-frame-geometry parameters))
- (let ((visibility-spec (assq 'visibility parameters))
- (frame (x-create-frame `((visibility . nil) . ,parameters)))
- success)
+ (let* ((params (copy-tree parameters))
+ (visibility-spec (assq 'visibility parameters))
+ (delayed-params '(foreground-color background-color font
+ border-color cursor-color mouse-color
+ visibility scroll-bar-foreground
+ scroll-bar-background))
+ frame success)
+ (dolist (param delayed-params)
+ (setq params (assq-delete-all param params)))
+ (setq frame (x-create-frame `((visibility . nil) . ,params)))
(unwind-protect
(progn
(x-setup-function-keys frame)
(x-handle-reverse-video frame parameters)
(frame-set-background-mode frame)
- (face-set-after-frame-default frame)
- ;; 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)
+ (face-set-after-frame-default frame parameters)
(if (null visibility-spec)
(make-frame-visible frame)
(modify-frame-parameters frame (list visibility-spec)))
(delete-frame frame)))
frame))
-(defun face-set-after-frame-default (frame)
- "Set frame-local faces of FRAME from face specs and resources.
-Initialize colors of certain faces from frame parameters."
- (unless inhibit-face-set-after-frame-default
- (if (face-attribute 'default :font t)
- (set-face-attribute 'default frame :font
- (face-attribute 'default :font t))
- (set-face-attribute 'default frame :family
- (face-attribute 'default :family t))
- (set-face-attribute 'default frame :height
- (face-attribute 'default :height t))
- (set-face-attribute 'default frame :slant
- (face-attribute 'default :slant t))
- (set-face-attribute 'default frame :weight
- (face-attribute 'default :weight t))
- (set-face-attribute 'default frame :width
- (face-attribute 'default :width t))))
- ;; Find attributes that should be initialized from frame parameters.
+(defun face-set-after-frame-default (frame &optional parameters)
+ "Initialize the frame-local faces of FRAME.
+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)))
+ (condition-case ()
+ (progn
+ ;; Initialize faces from face spec and custom theme.
+ (face-spec-recalc face frame)
+ ;; X resouces for the default face are applied during
+ ;; x-create-frame.
+ (and (not (eq face 'default))
+ (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))
+ ;; Don't let invalid specs prevent frame creation.
+ (error nil)))
+ ;; Apply attributes specified by frame parameters.
(let ((face-params '((foreground-color default :foreground)
- (background-color default :background)
- (border-color border :background)
- (cursor-color cursor :background)
- (scroll-bar-foreground scroll-bar :foreground)
- (scroll-bar-background scroll-bar :background)
- (mouse-color mouse :background)))
- apply-params)
+ (background-color default :background)
+ (font default :font)
+ (border-color border :background)
+ (cursor-color cursor :background)
+ (scroll-bar-foreground scroll-bar :foreground)
+ (scroll-bar-background scroll-bar :background)
+ (mouse-color mouse :background))))
(dolist (param face-params)
- (let* ((value (frame-parameter frame (nth 0 param)))
- (face (nth 1 param))
- (attr (nth 2 param))
- (default-value (face-attribute face attr t)))
- ;; Compile a list of face attributes to set, but don't set
- ;; them yet. The call to make-face-x-resource-internal,
- ;; below, can change frame parameters, and the final set of
- ;; frame parameters should be the ones acquired at this step.
- (if (eq default-value 'unspecified)
- ;; The face spec does not specify a new-frame value for
- ;; this attribute. Check if the existing frame parameter
- ;; specifies it.
- (if value
- (push (list face frame attr value) apply-params))
- ;; The face spec specifies a value for this attribute, to be
- ;; applied to the face on all new frames.
- (push (list face frame attr default-value) apply-params))))
- ;; Initialize faces from face specs and X resources. The
- ;; condition-case prevents invalid specs from causing frame
- ;; creation to fail.
- (dolist (face (delq 'default (face-list)))
- (condition-case ()
- (progn
- (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))
- (error nil)))
- ;; Apply the attributes specified by frame parameters. This
- ;; rewrites parameters changed by make-face-x-resource-internal
- (dolist (param apply-params)
- (apply 'set-face-attribute param))))
+ (let* ((param-name (nth 0 param))
+ (value (cdr (or (assq param-name parameters)
+ (assq param-name default-frame-alist)))))
+ (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."
(set-locale-environment nil frame)
(tty-run-terminal-initialization frame))
(frame-set-background-mode frame)
- (face-set-after-frame-default frame)
+ (face-set-after-frame-default frame parameters)
(setq success t))
(unless success
(delete-frame frame)))
:group 'basic-faces)
(defface fixed-pitch
- '((t :family "courier"))
+ '((t :family "Monospace"))
"The basic fixed-pitch face."
:group 'basic-faces)
(defface variable-pitch
- '((t :family "helv"))
+ '((t :family "Sans Serif"))
"The basic variable-pitch face."
:group 'basic-faces)
'((default
:box (:line-width 1 :style released-button)
:foreground "black")
- (((type x w32 mac) (class color))
+ (((type x w32 ns) (class color))
:background "grey75")
(((type x) (class mono))
:background "grey"))
HCoop / bpt / emacs.git / blobdiff