(put 'face-name 'byte-optimizer nil)
(put 'face-id 'byte-optimizer nil)
(put 'face-font 'byte-optimizer nil)
+ (put 'face-font-explicit 'byte-optimizer nil)
(put 'face-foreground 'byte-optimizer nil)
(put 'face-background 'byte-optimizer nil)
(put 'face-stipple 'byte-optimizer nil)
(put 'face-underline-p 'byte-optimizer nil)
(put 'set-face-font 'byte-optimizer nil)
+ (put 'set-face-font-auto 'byte-optimizer nil)
(put 'set-face-foreground 'byte-optimizer nil)
(put 'set-face-background 'byte-optimizer nil)
(put 'set-face-stipple 'byte-optimizer nil)
;;;; Functions for manipulating face vectors.
;;; A face vector is a vector of the form:
-;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE UNDERLINE INVERSE]
+;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE
+;;; UNDERLINE-P INVERSE-VIDEO-P FONT-EXPLICIT-P BOLD-P ITALIC-P]
;;; Type checkers.
(defsubst internal-facep (x)
- (and (vectorp x) (= (length x) 9) (eq (aref x 0) 'face)))
+ (and (vectorp x) (= (length x) 12) (eq (aref x 0) 'face)))
(defun facep (x)
"Return t if X is a face name or an internal face vector."
If FRAME is omitted or nil, use the selected frame."
(aref (internal-get-face face frame) 8))
+(defun face-font-explicit (face &optional frame)
+ "Return non-nil if this face's font was explicitly specified."
+ (aref (internal-get-face face frame) 9))
+
(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))))
+ (aref (internal-get-face face frame) 10))
(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))))
+ (aref (internal-get-face face frame) 11))
-(defun face-doc-string (face)
+(defalias 'face-doc-string 'face-documentation)
+(defun face-documentation (face)
"Get the documentation string for FACE."
(get face 'face-documentation))
\f
(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)
+ ;; Record that this face's font was set explicitly, not automatically,
+ ;; unless we are setting it to nil.
+ (internal-set-face-1 face nil (not (null font)) 9 frame))
+
+(defun set-face-font-auto (face font &optional frame)
+ "Change the font of face FACE to FONT (a string), for an automatic change.
+An automatic change means that we don't change the \"explicit\" flag;
+if the font was derived from the frame font before, it is now.
+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 (or (and (fontset-name-p font)
+ (or (query-fontset font)
+ (instantiate-fontset font)))
+ (x-resolve-font-name font 'default frame))))
(internal-set-face-1 face 'font font 3 frame))
+(defun set-face-font-explicit (face flag &optional frame)
+ "Set the explicit-font flag of face FACE to FLAG.
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (internal-set-face-1 face nil flag 9 frame))
+
(defun set-face-foreground (face color &optional frame)
"Change the foreground color of face FACE to COLOR (a string).
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
- (interactive (internal-face-interactive "foreground"))
+ (interactive (internal-face-interactive "foreground" 'color))
(internal-set-face-1 face 'foreground color 4 frame))
(defvar face-default-stipple "gray3"
"Change the background color of face FACE to COLOR (a string).
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
- (interactive (internal-face-interactive "background"))
+ (interactive (internal-face-interactive "background" 'color))
;; For a specific frame, use gray stipple instead of gray color
;; if the display does not support a gray color.
(if (and frame (not (eq frame t)) color
(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)
+(defalias 'set-face-doc-string 'set-face-documentation)
+(defun set-face-documentation (face string)
"Set the documentation string for FACE to STRING."
(put face 'face-documentation string))
\f
(t value))))
(defun modify-face (face foreground background stipple
- bold-p italic-p underline-p &optional frame)
+ bold-p italic-p underline-p &optional inverse-p frame)
"Change the display attributes for face FACE.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame.
try) or nil. STIPPLE should be a stipple pattern name string or nil.
If nil, means do not change the display attribute corresponding to that arg.
-BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
-in italic, and underlined, respectively. If neither nil or t, means do not
-change the display attribute corresponding to that arg.
+BOLD-P, ITALIC-P, UNDERLINE-P, and INVERSE-P specify whether
+the face should be set bold, italic, underlined or in inverse-video,
+respectively. If one of these arguments is neither nil or t, it means do not
+change the display attribute corresponding to that argument.
If called interactively, prompts for a face name and face attributes."
(interactive
(bold-p (y-or-n-p (concat "Should face " face " be bold ")))
(italic-p (y-or-n-p (concat "Should face " face " be italic ")))
(underline-p (y-or-n-p (concat "Should face " face " be underlined ")))
+ (inverse-p (y-or-n-p (concat "Should face " face " be inverse-video ")))
(all-frames-p (y-or-n-p (concat "Modify face " face " in all frames "))))
(message "Face %s: %s" face
(mapconcat 'identity
(and background (concat (downcase background) " background"))
(and stipple (concat (downcase new-stipple-string) " stipple"))
(and bold-p "bold") (and italic-p "italic")
+ (and inverse-p "inverse")
(and underline-p "underline"))) ", "))
(list (intern face) foreground background stipple
- bold-p italic-p underline-p
+ bold-p italic-p underline-p inverse-p
(if all-frames-p nil (selected-frame)))))
+ ;; Clear this before we install the new foreground and background;
+ ;; otherwise, clearing it after would swap them!
+ (when (and (or foreground background) (face-inverse-video-p face))
+ (set-face-inverse-video-p face nil frame)
+ ;; Arrange to restore it after, if we are not setting it now.
+ (or (memq inverse-p '(t nil))
+ (setq inverse-p t)))
(condition-case nil
(face-try-color-list 'set-face-foreground face foreground frame)
(error nil))
(condition-case nil
(set-face-stipple face stipple frame)
(error nil))
+ ;; Now that we have the new colors,
+ (if (memq inverse-p '(nil t))
+ (set-face-inverse-video-p face inverse-p frame))
(cond ((eq bold-p nil)
(if (face-font face frame)
(make-face-unbold face frame t)))
(if (eq name 'inverse-video)
(or (eq value (aref internal-face index))
(invert-face face frame))
- (set-face-attribute-internal (face-id face) name value frame)))
+ (and name (fboundp 'set-face-attribute-internal)
+ (set-face-attribute-internal (face-id face)
+ name value frame))))
(aset internal-face index value)))))
(default (if (fboundp fn)
(or (funcall fn face (selected-frame))
(funcall fn 'default (selected-frame)))))
- (value (if bool
- (y-or-n-p (concat "Should face " (symbol-name face)
- " be " bool "? "))
- (read-string (concat prompt " " (symbol-name face) " to: ")
- default))))
+ value)
+ (setq value
+ (cond ((eq bool 'color)
+ (completing-read (concat prompt " " (symbol-name face) " to: ")
+ (mapcar (function (lambda (color)
+ (cons color color)))
+ x-colors)
+ nil nil nil nil default))
+ (bool
+ (y-or-n-p (concat "Should face " (symbol-name face)
+ " be " bool "? ")))
+ (t
+ (read-string (concat prompt " " (symbol-name face) " to: ")
+ nil nil default))))
(list face (if (equal value "") nil value))))
(defun internal-face-interactive-stipple (what)
If the face already exists, it is unmodified."
(interactive "SMake face: ")
(or (internal-find-face name)
- (let ((face (make-vector 9 nil)))
+ (let ((face (make-vector 12 nil)))
(aset face 0 'face)
(aset face 1 name)
(let* ((frames (frame-list))
(inhibit-quit t)
(id (internal-next-face-id)))
- (make-face-internal id)
+ (if (fboundp 'make-face-internal)
+ (make-face-internal id))
(aset face 2 id)
(while frames
(set-frame-face-alist (car frames)
(set-face-font new-face (face-font old-face frame) new-frame)
(error
(set-face-font new-face nil new-frame)))
+ (set-face-font-explicit new-face (face-font-explicit old-face frame)
+ new-frame)
(set-face-foreground new-face (face-foreground old-face frame) new-frame)
(set-face-background new-face (face-background old-face frame) new-frame)
(set-face-stipple new-face
(defun internal-try-face-font (face font &optional frame)
"Like set-face-font, but returns nil on failure instead of an error."
(condition-case ()
- (set-face-font face font frame)
+ (set-face-font-auto face font frame)
(error nil)))
\f
;; Manipulating font names.
"Make the font of the given face be bold, if possible.
If NOERROR is non-nil, return nil on failure."
(interactive (list (read-face-name "Make which face bold: ")))
+ ;; Set the bold-p flag, first of all.
+ (internal-set-face-1 face nil t 10 frame)
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face (if (memq 'italic (face-font face t))
'(bold italic) '(bold))
"Make the font of the given face be italic, if possible.
If NOERROR is non-nil, return nil on failure."
(interactive (list (read-face-name "Make which face italic: ")))
+ ;; Set the italic-p flag, first of all.
+ (internal-set-face-1 face nil t 11 frame)
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face (if (memq 'bold (face-font face t))
'(bold italic) '(italic))
"Make the font of the given face be bold and italic, if possible.
If NOERROR is non-nil, return nil on failure."
(interactive (list (read-face-name "Make which face bold-italic: ")))
+ ;; Set the bold-p and italic-p flags, first of all.
+ (internal-set-face-1 face nil t 10 frame)
+ (internal-set-face-1 face nil t 11 frame)
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face '(bold italic) t)
(let (font)
"Make the font of the given face be non-bold, if possible.
If NOERROR is non-nil, return nil on failure."
(interactive (list (read-face-name "Make which face non-bold: ")))
+ ;; Clear the bold-p flag, first of all.
+ (internal-set-face-1 face nil nil 10 frame)
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face (if (memq 'italic (face-font face t))
'(italic) nil)
"Make the font of the given face be non-italic, if possible.
If NOERROR is non-nil, return nil on failure."
(interactive (list (read-face-name "Make which face non-italic: ")))
+ ;; Clear the italic-p flag, first of all.
+ (internal-set-face-1 face nil nil 11 frame)
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face (if (memq 'bold (face-font face t))
'(bold) nil)
(princ " Stipple: ") (princ (or (face-stipple face) "none")) (terpri)
(terpri)
(princ "Documentation:") (terpri)
- (let ((doc (face-doc-string face)))
+ (let ((doc (face-documentation face)))
(if doc
(princ doc)
(princ "not documented as a face.")))))
\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
+(defun face-attr-match-p (face attrs &optional frame)
+ (or frame (setq frame (selected-frame)))
+ (and (face-attr-match-1 face frame attrs ':inverse-video
+ 'face-inverse-video-p)
+ (if (face-inverse-video-p face frame)
+ (and
+ (face-attr-match-1 face frame attrs
+ ':foreground 'face-background
+ (cdr (assq 'foreground-color
+ (frame-parameters frame))))
+ (face-attr-match-1 face frame attrs
+ ':background 'face-foreground
+ (cdr (assq 'background-color
+ (frame-parameters frame)))))
+ (and
+ (face-attr-match-1 face frame attrs ':foreground 'face-foreground)
+ (face-attr-match-1 face frame attrs ':background 'face-background)))
+ (face-attr-match-1 face frame attrs ':stipple 'face-stipple)
+ (face-attr-match-1 face frame attrs ':bold 'face-bold-p)
+ (face-attr-match-1 face frame attrs ':italic 'face-italic-p)
+ (face-attr-match-1 face frame attrs ':underline 'face-underline-p)
+))
+
+(defun face-attr-match-1 (face frame plist property function
+ &optional defaultval)
+ (while (and plist (not (eq (car plist) property)))
+ (setq plist (cdr (cdr plist))))
+ (eq (funcall function face frame)
+ (if plist
+ (nth 1 plist)
+ (or defaultval
+ (funcall function 'default frame)))))
+
+(defun face-spec-match-p (face spec &optional frame)
+ "Return t if FACE, on FRAME, matches what SPEC says it should look like."
+ (face-attr-match-p face (face-spec-choose spec frame) frame))
+
+(defun face-attr-construct (face &optional frame)
+ "Return a defface-style attribute list for FACE, as it exists on FRAME."
+ (let (result)
+ (if (face-inverse-video-p face frame)
+ (progn
+ (setq result (cons ':inverse-video (cons t result)))
+ (or (face-attr-match-1 face frame nil
+ ':foreground 'face-background
+ (cdr (assq 'foreground-color
+ (frame-parameters frame))))
+ (setq result (cons ':foreground
+ (cons (face-foreground face frame) result))))
+ (or (face-attr-match-1 face frame nil
+ ':background 'face-foreground
+ (cdr (assq 'background-color
+ (frame-parameters frame))))
+ (setq result (cons ':background
+ (cons (face-background face frame) result)))))
+ (if (face-foreground face frame)
+ (setq result (cons ':foreground
+ (cons (face-foreground face frame) result))))
+ (if (face-background face frame)
+ (setq result (cons ':background
+ (cons (face-background face frame) result)))))
+ (if (face-stipple face frame)
+ (setq result (cons ':stipple
+ (cons (face-stipple face frame) result))))
+ (if (face-bold-p face frame)
+ (setq result (cons ':bold
+ (cons (face-bold-p face frame) result))))
+ (if (face-italic-p face frame)
+ (setq result (cons ':italic
+ (cons (face-italic-p face frame) result))))
+ (if (face-underline-p face frame)
+ (setq result (cons ':underline
+ (cons (face-underline-p face frame) result))))
+ result))
+
+;; Choose the proper attributes for FRAME, out of SPEC.
+(defun face-spec-choose (spec &optional frame)
+ (or frame (setq frame (selected-frame)))
+ (let ((tail spec)
+ result)
+ (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)
+ (setq result attrs tail nil))))
+ result))
+
+(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."
+ (if frame
+ (let ((attrs (face-spec-choose spec frame)))
+ (when attrs
+ ;; If the font was set automatically, clear it out
+ ;; to allow it to be set it again.
+ (unless (face-font-explicit face frame)
+ (set-face-font face nil frame))
+ (modify-face face '(nil) '(nil) nil nil nil nil nil 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 ':italic 'set-face-italic-p)
(face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
(face-spec-set-1 face frame attrs ':inverse-video
- 'set-face-inverse-video-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)))))
+ 'set-face-inverse-video-p)))
+ (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 frame (x-create-frame (cons '(visibility . nil) parameters)))
(unwind-protect
(progn
-
;; Copy the face alist, copying the face vectors
;; and emptying out their attributes.
(setq faces
(vector 'face
(face-name (cdr elt))
(face-id (cdr elt))
- nil nil nil nil nil nil)))
+ nil
+ nil nil nil nil
+ nil nil nil nil)))
global-face-data))
(set-frame-face-alist frame faces)
(frame-set-background-mode frame)
- ;; 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
- (make-face-x-resource-internal (cdr (car rest)) frame)
- (setq rest (cdr rest)))
+ (face-set-after-frame-default frame)
;; Make the frame visible, if desired.
(if (null visibility-spec)
(delete-frame frame)))))
frame))
+;; Update a frame's faces after the frame font changes.
+;; This is called from modify-frame-parameters
+;; as well as from elsewhere in this file.
+(defun face-set-after-frame-default (frame)
+ (let ((rest (frame-face-alist frame)))
+ (while rest
+ ;; Set up each face, first from the defface information,
+ ;; then the global face data, and then the X resources.
+ (let* ((face (car (car rest)))
+ (spec (or (get face 'saved-face)
+ (get face 'face-defface-spec)))
+ (global (cdr (assq face global-face-data)))
+ (local (cdr (car rest))))
+ (when spec
+ (face-spec-set face spec frame))
+ (face-fill-in face global frame)
+ (make-face-x-resource-internal local frame))
+ (setq rest (cdr rest)))))
+
(defcustom frame-background-mode nil
"*The brightness of the background.
Set this to the symbol dark if your background color is dark, light if
(t 'mono)))))))
;; Update a frame's faces when we change its default font.
-(defun frame-update-faces (frame)
- (let* ((faces global-face-data)
- (rest faces))
- (while rest
- (let* ((face (car (car rest)))
- (font (face-font face t)))
- (if (listp font)
- (let ((bold (memq 'bold font))
- (italic (memq 'italic font)))
- ;; Ignore any previous (string-valued) font, it might not even
- ;; be the right size anymore.
- (set-face-font face nil frame)
- (cond ((and bold italic)
- (make-face-bold-italic face frame t))
- (bold
- (make-face-bold face frame t))
- (italic
- (make-face-italic face frame t)))))
- (setq rest (cdr rest)))
- frame)))
+(defun frame-update-faces (frame) nil)
;; Update the colors of FACE, after FRAME's own colors have been changed.
;; This applies only to faces with global color specifications
(setq region-face (face-id 'region))
+(defgroup basic-faces nil
+ "The standard faces of Emacs."
+ :prefix "huh"
+ :group 'faces)
+
;; Specify how these faces look, and their documentation.
(let ((all '((bold "Use bold font." ((t (:bold t))))
(bold-italic "Use bold italic font." ((t (:bold t :italic t))))
(underline "Underline text." ((t (:underline t))))
(default "Used for text not covered by other faces." ((t nil)))
(highlight "Highlight text in some way."
- ((((class color)) (:background "darkseagreen2"))
+ ((((class color) (background light))
+ (:background "darkseagreen2"))
+ (((class color) (background dark))
+ (:background "darkolivegreen"))
(t (:inverse-video t))))
(modeline "Used for displaying the modeline."
((t (:inverse-video t))))
(region "Used for displaying the region."
- ((t (:background "gray"))))
+ ((((class color) (background dark))
+ (:background "blue"))
+ (t (:background "gray"))))
(secondary-selection
"Used for displaying the secondary selection."
- ((((class color)) (:background "paleturquoise"))
+ ((((class color) (background light))
+ (:background "paleturquoise"))
+ (((class color) (background dark))
+ (:background "darkslateblue"))
(t (:inverse-video t))))))
entry symbol doc spec)
(while all
symbol (nth 0 entry)
doc (nth 1 entry)
spec (nth 2 entry))
+ (custom-add-to-group 'basic-faces symbol 'custom-face)
(put symbol 'face-documentation doc)
(put symbol 'face-defface-spec spec)))
HCoop / bpt / emacs.git / blobdiff