If FRAME is omitted or nil, use the selected frame."
(aref (internal-get-face face frame) 7))
+(defun face-bold-p (face &optional frame)
+ "Return non-nil if the font of FACE is bold.
+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).
+ The font default for a face is either nil, or a list
+ of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+ (let ((font (face-font face frame)))
+ (if (stringp font)
+ (not (eq font (x-make-font-unbold font)))
+ (memq 'bold font))))
+
+(defun face-italic-p (face &optional frame)
+ "Return non-nil if the font of FACE is italic.
+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).
+ The font default for a face is either nil, or a list
+ of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+ (let ((font (face-font face frame)))
+ (if (stringp font)
+ (not (eq font (x-make-font-unitalic font)))
+ (memq 'italic font))))
+
+(defun face-doc-string (face)
+ "Get the documentation string for FACE."
+ (get face 'face-documentation))
\f
;;; Mutators.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
(interactive (internal-face-interactive "font"))
- (if (stringp font) (setq font (x-resolve-font-name font 'default frame)))
+ (if (stringp font)
+ (setq font (or (query-fontset font)
+ (x-resolve-font-name font 'default frame))))
(internal-set-face-1 face 'font font 3 frame))
(defun set-face-foreground (face color &optional frame)
in that frame; otherwise change each frame."
(interactive (internal-face-interactive "underline-p" "underlined"))
(internal-set-face-1 face 'underline underline-p 7 frame))
+
+(defun set-face-bold-p (face bold-p &optional frame)
+ "Specify whether face FACE is bold. (Yes if BOLD-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (cond ((eq bold-p nil) (make-face-unbold face frame t))
+ (t (make-face-bold face frame t))))
+
+(defun set-face-italic-p (face italic-p &optional frame)
+ "Specify whether face FACE is italic. (Yes if ITALIC-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+ (t (make-face-italic face frame t))))
+
+(defun set-face-doc-string (face string)
+ "Set the documentation string for FACE to STRING."
+ (put face 'face-documentation string))
\f
(defun modify-face-read-string (face default name alist)
(let ((value
new-stipple-string)))
(list face (if (equal stipple "") nil stipple))))
-(defun make-face (name)
+(defun make-face (name &optional no-resources)
"Define a new FACE on all frames.
You can modify the font, color, etc of this face with the set-face- functions.
+If NO-RESOURCES is non-nil, then we ignore X resources
+and always make a face whose attributes are all nil.
+
If the face already exists, it is unmodified."
(interactive "SMake face: ")
(or (internal-find-face name)
(frame-face-alist (car frames))))
(setq frames (cdr frames)))
(setq global-face-data (cons (cons name face) global-face-data)))
- ;; when making a face after frames already exist
- (if (memq window-system '(x w32))
- (make-face-x-resource-internal face))
- ;; add to menu
+ ;; When making a face after frames already exist
+ (or no-resources
+ (if (memq window-system '(x w32))
+ (make-face-x-resource-internal face)))
+ ;; Add to menu of faces.
(if (fboundp 'facemenu-add-new-face)
(facemenu-add-new-face name))
face))
name)
+(defun make-empty-face (face)
+ "Define a new FACE on all frames, which initially reflects the defaults.
+You can modify the font, color, etc of this face with the set-face- functions.
+If the face already exists, it is unmodified."
+ (interactive "SMake empty face: ")
+ (make-face face t))
+
;; Fill in a face by default based on X resources, for all existing frames.
;; This has to be done when a new face is made.
(defun make-face-x-resource-internal (face &optional frame set-anyway)
(or (equal (face-background default frame)
(face-background face frame))
(null (face-background face frame)))
- (or (equal (face-font default frame) (face-font face frame))
- (null (face-font face frame)))
+ (or (null (face-font face frame))
+ (equal (face-font face frame)
+ (or (face-font default frame)
+ (downcase
+ (cdr (assq 'font (frame-parameters frame)))))))
(or (equal (face-stipple default frame)
(face-stipple face frame))
(null (face-stipple face frame)))
(progn
(set-face-foreground face bg frame)
(set-face-background face fg frame))
- (set-face-foreground face (or (face-background 'default frame)
- (cdr (assq 'background-color (frame-parameters frame))))
- frame)
- (set-face-background face (or (face-foreground 'default frame)
- (cdr (assq 'foreground-color (frame-parameters frame))))
- frame)))
+ (let* ((frame-bg (cdr (assq 'background-color (frame-parameters frame))))
+ (default-bg (or (face-background 'default frame)
+ frame-bg))
+ (frame-fg (cdr (assq 'foreground-color (frame-parameters frame))))
+ (default-fg (or (face-foreground 'default frame)
+ frame-fg)))
+ (set-face-foreground face default-bg frame)
+ (set-face-background face default-fg frame))))
face)
(face-fill-in face (cdr (car rest)) frame)))
(setq rest (cdr rest)))))
(setq frames (cdr frames)))))
-
+\f
+;;; Setting a face based on a SPEC.
+
+(defun face-spec-set (face spec &optional frame)
+ "Set FACE's face attributes according to the first matching entry in SPEC.
+If optional FRAME is non-nil, set it for that frame only.
+If it is nil, then apply SPEC to each frame individually.
+See `defface' for information about SPEC."
+ (let ((tail spec))
+ (while tail
+ (let* ((entry (car tail))
+ (display (nth 0 entry))
+ (attrs (nth 1 entry)))
+ (setq tail (cdr tail))
+ (modify-face face nil nil nil nil nil nil frame)
+ (when (face-spec-set-match-display display frame)
+ (face-spec-set-1 face frame attrs ':foreground 'set-face-foreground)
+ (face-spec-set-1 face frame attrs ':background 'set-face-background)
+ (face-spec-set-1 face frame attrs ':stipple 'set-face-stipple)
+ (face-spec-set-1 face frame attrs ':bold 'set-face-bold-p)
+ (face-spec-set-1 face frame attrs ':italic 'set-face-italic-p)
+ (face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
+ (setq tail nil)))))
+ (if (null frame)
+ (let ((frames (frame-list))
+ frame)
+ (while frames
+ (setq frame (car frames)
+ frames (cdr frames))
+ (face-spec-set face (or (get face 'saved-face)
+ (get face 'face-defface-spec))
+ frame)
+ (face-spec-set face spec frame)))))
+
+(defun face-spec-set-1 (face frame plist property function)
+ (while (and plist (not (eq (car plist) property)))
+ (setq plist (cdr (cdr plist))))
+ (if plist
+ (funcall function face (nth 1 plist) frame)))
+
+(defun face-spec-set-match-display (display frame)
+ "Non-nil iff DISPLAY matches FRAME.
+DISPLAY is part of a spec such as can be used in `defface'.
+If FRAME is nil, the current FRAME is used."
+ (let* ((conjuncts display)
+ conjunct req options
+ ;; t means we have succeeded against all
+ ;; the conjunts in DISPLAY that have been tested so far.
+ (match t))
+ (if (eq conjuncts t)
+ (setq conjuncts nil))
+ (while (and conjuncts match)
+ (setq conjunct (car conjuncts)
+ conjuncts (cdr conjuncts)
+ req (car conjunct)
+ options (cdr conjunct)
+ match (cond ((eq req 'type)
+ (memq window-system options))
+ ((eq req 'class)
+ (memq (frame-parameter frame 'display-type) options))
+ ((eq req 'background)
+ (memq (frame-parameter frame 'background-mode)
+ options))
+ (t
+ (error "Unknown req `%S' with options `%S'"
+ req options)))))
+ match))
\f
;; Like x-create-frame but also set up the faces.
(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")))
- parsed)
+ (res-geometry (if name (x-get-resource "geometry" "Geometry"))))
(if res-geometry
- (progn
- (setq parsed (x-parse-geometry res-geometry))
+ (let ((parsed (x-parse-geometry res-geometry)))
;; If the resource specifies a position,
;; call the position and size "user-specified".
(if (or (assq 'top parsed) (assq 'left parsed))
- (setq parsed (cons '(user-position . t)
- (cons '(user-size . t) 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)))))
+ (setq parameters (append parameters default-frame-alist parsed)))))
(let (frame)
(if (null global-face-data)
- (setq frame (x-create-frame parameters))
+ (progn
+ (setq frame (x-create-frame parameters))
+ (frame-set-background-mode frame))
(let* ((visibility-spec (assq 'visibility parameters))
- (faces (copy-alist global-face-data))
- success
- (rest faces))
+ success faces rest)
(setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+ (frame-set-background-mode frame)
(unwind-protect
(progn
+
+ ;; Copy the face alist, copying the face vectors
+ ;; and emptying out their attributes.
+ (setq faces
+ (mapcar '(lambda (elt)
+ (cons (car elt)
+ (vector 'face
+ (face-name (cdr elt))
+ (face-id (cdr elt))
+ nil nil nil nil nil)))
+ global-face-data))
(set-frame-face-alist frame faces)
+ ;; Handle the reverse-video frame parameter
+ ;; and X resource. x-create-frame does not handle this one.
(if (cdr (or (assq 'reverse parameters)
(assq 'reverse default-frame-alist)
(let ((resource (x-get-resource "reverseVideo"
(if (equal bg (cdr (assq 'cursor-color params)))
(modify-frame-parameters frame
(list (cons 'cursor-color fg))))))
- ;; Copy the vectors that represent the faces.
- ;; Also fill them in from X resources.
+
+ ;; Set up faces from the defface information
+ (mapcar (lambda (symbol)
+ (let ((spec (or (get symbol 'saved-face)
+ (get symbol 'face-defface-spec))))
+ (when spec
+ (face-spec-set symbol spec frame))))
+ (face-list))
+
+ ;; Set up faces from the global face data.
+ (setq rest faces)
+ (while rest
+ (let* ((face (car (car rest)))
+ (global (cdr (assq face global-face-data))))
+ (face-fill-in face global frame))
+ (setq rest (cdr rest)))
+
+ ;; Set up faces from the X resources.
+ (setq rest faces)
(while rest
- (let ((global (cdr (car rest))))
- (setcdr (car rest) (vector 'face
- (face-name (cdr (car rest)))
- (face-id (cdr (car rest)))
- nil nil nil nil nil))
- (face-fill-in (car (car rest)) global frame))
(make-face-x-resource-internal (cdr (car rest)) frame t)
(setq rest (cdr rest)))
+
+ ;; Make the frame visible, if desired.
(if (null visibility-spec)
(make-frame-visible frame)
(modify-frame-parameters frame (list visibility-spec)))
(setq success t))
(or success
(delete-frame frame)))))
- ;; Set up the background-mode frame parameter
- ;; so that programs can decide good ways of highlighting
- ;; on this frame.
- (let ((bg-resource (x-get-resource ".backgroundMode"
- "BackgroundMode"))
- (params (frame-parameters frame))
- (bg-mode))
- (setq bg-mode
- (cond (bg-resource (intern (downcase bg-resource)))
- ((< (apply '+ (x-color-values
- (cdr (assq 'background-color params))
- frame))
- ;; Just looking at the screen,
- ;; colors whose values add up to .6 of the white total
- ;; still look dark to me.
- (* (apply '+ (x-color-values "white" frame)) .6))
- 'dark)
- (t 'light)))
- (modify-frame-parameters frame
- (list (cons 'background-mode bg-mode)
- (cons 'display-type
- (cond ((x-display-color-p frame)
- 'color)
- ((x-display-grayscale-p frame)
- 'grayscale)
- (t 'mono))))))
frame))
+(defcustom frame-background-mode nil
+ "*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 (default) if you want Emacs to
+examine the brightness for you."
+ :group 'faces
+ :type '(choice (choice-item dark)
+ (choice-item light)
+ (choice-item :tag "default" nil)))
+
+(defun frame-set-background-mode (frame)
+ "Set up the `background-mode' and `display-type' frame parameters for FRAME."
+ (let ((bg-resource (x-get-resource ".backgroundMode"
+ "BackgroundMode"))
+ (params (frame-parameters frame))
+ (bg-mode))
+ (setq bg-mode
+ (cond (frame-background-mode)
+ (bg-resource (intern (downcase bg-resource)))
+ ((< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))
+ frame))
+ ;; Just looking at the screen,
+ ;; colors whose values add up to .6 of the white total
+ ;; still look dark to me.
+ (* (apply '+ (x-color-values "white" frame)) .6))
+ 'dark)
+ (t 'light)))
+ (modify-frame-parameters frame
+ (list (cons 'background-mode bg-mode)
+ (cons 'display-type
+ (cond ((x-display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono)))))))
+
;; Update a frame's faces when we change its default font.
(defun frame-update-faces (frame)
(let* ((faces global-face-data)