(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]
+;;; [face NAME ID FONT FOREGROUND BACKGROUND STIPPLE UNDERLINE INVERSE]
;;; Type checkers.
(defsubst internal-facep (x)
- (and (vectorp x) (= (length x) 8) (eq (aref x 0) 'face)))
+ (and (vectorp x) (= (length x) 10) (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) 3))
+(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-foreground (face &optional frame)
"Return the foreground color name of face FACE, or nil if unspecified.
If the optional argument FRAME is given, report on face FACE in that frame.
If FRAME is omitted or nil, use the selected frame."
(aref (internal-get-face face frame) 7))
+(defun face-inverse-video-p (face &optional frame)
+ "Return t if face FACE is in inverse video.
+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).
+If FRAME is omitted or nil, use the selected frame."
+ (aref (internal-get-face face frame) 8))
+
(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 omitted or nil, use the selected frame."
(let ((font (face-font face frame)))
(if (stringp font)
- (not (eq font (x-make-font-unbold font)))
+ (not (equal font (x-make-font-unbold font)))
(memq 'bold font))))
(defun face-italic-p (face &optional frame)
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)))
+ (not (equal font (x-make-font-unitalic font)))
(memq 'italic font))))
(defun face-doc-string (face)
(defun set-face-font (face font &optional frame)
"Change the font of face FACE to FONT (a string).
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 (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)
(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
(interactive (internal-face-interactive "underline-p" "underlined"))
(internal-set-face-1 face 'underline underline-p 7 frame))
+(defun set-face-inverse-video-p (face inverse-video-p &optional frame)
+ "Specify whether face FACE is in inverse video.
+\(Yes if INVERSE-VIDEO-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (interactive (internal-face-interactive "inverse-video-p" "inverse-video"))
+ (internal-set-face-1 face 'inverse-video inverse-video-p 8 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
(condition-case nil
(set-face-stipple face stipple frame)
(error nil))
- (cond ((eq bold-p nil) (make-face-unbold face frame t))
- ((eq bold-p t) (make-face-bold face frame t)))
- (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+ (cond ((eq bold-p nil)
+ (if (face-font face frame)
+ (make-face-unbold face frame t)))
+ ((eq bold-p t)
+ (make-face-bold face frame t)))
+ (cond ((eq italic-p nil)
+ (if (face-font face frame)
+ (make-face-unitalic face frame t)))
((eq italic-p t) (make-face-italic face frame t)))
(if (memq underline-p '(nil t))
(set-face-underline-p face underline-p frame))
(aset (internal-get-face (if (symbolp face) face (face-name face)) t)
index value)
value)
- (or (eq frame t)
- (set-face-attribute-internal (face-id face) name value frame))
- (aset (internal-get-face face frame) index value))))
+ (let ((internal-face (internal-get-face face frame)))
+ (or (eq frame t)
+ (if (eq name 'inverse-video)
+ (or (eq value (aref internal-face index))
+ (invert-face face frame))
+ (and name (fboundp 'set-face-attribute-internal)
+ (set-face-attribute-internal (face-id face)
+ name value frame))))
+ (aset internal-face index value)))))
(defun read-face-name (prompt)
If the face already exists, it is unmodified."
(interactive "SMake face: ")
(or (internal-find-face name)
- (let ((face (make-vector 8 nil)))
+ (let ((face (make-vector 10 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.
"Given an X font specification, make a non-italic version of it.
If that can't be done, return nil."
(x-frob-font-slant font "r"))
+
+(defun x-make-font-bold-italic (font)
+ "Given an X font specification, make a bold and italic version of it.
+If that can't be done, return nil."
+ (and (setq font (x-make-font-bold font))
+ (x-make-font-italic font)))
\f
;;; non-X-specific interface
(princ doc)
(princ "not documented as a face.")))))
\f
-;;; Make the standard faces.
-;;; The C code knows the default and modeline faces as faces 0 and 1,
-;;; so they must be the first two faces made.
-(defun face-initialize ()
- (make-face 'default)
- (make-face 'modeline)
- (make-face 'highlight)
-
- ;; These aren't really special in any way, but they're nice to have around.
-
- (make-face 'bold)
- (make-face 'italic)
- (make-face 'bold-italic)
- (make-face 'region)
- (make-face 'secondary-selection)
- (make-face 'underline)
-
- (setq region-face (face-id 'region))
-
- ;; Specify the global properties of these faces
- ;; so they will come out right on new frames.
-
- (make-face-bold 'bold t)
- (make-face-italic 'italic t)
- (make-face-bold-italic 'bold-italic t)
-
- (set-face-background 'highlight '("darkseagreen2" "green" t) t)
- (set-face-background 'region '("gray" underline) t)
- (set-face-background 'secondary-selection '("paleturquoise" "green" t) t)
- (set-face-background 'modeline '(t) t)
- (set-face-underline-p 'underline t t)
-
- ;; Set up the faces of all existing X Window frames
- ;; from those global properties, unless already set in a given frame.
-
- (let ((frames (frame-list)))
- (while frames
- (if (not (memq (framep (car frames)) '(t nil)))
- (let ((frame (car frames))
- (rest global-face-data))
- (while rest
- (let ((face (car (car rest))))
- (or (face-differs-from-default-p 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)
(display (nth 0 entry))
(attrs (nth 1 entry)))
(setq tail (cdr tail))
+ ;; 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 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 ':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)
+ (face-spec-set-1 face frame attrs ':inverse-video
+ 'set-face-inverse-video-p)
(setq tail nil)))))
(if (null frame)
(let ((frames (frame-list))
(let* ((visibility-spec (assq 'visibility parameters))
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
(vector 'face
(face-name (cdr elt))
(face-id (cdr elt))
- nil nil nil nil nil)))
+ nil nil nil nil nil nil nil)))
global-face-data))
(set-frame-face-alist frame faces)
(modify-frame-parameters frame
(list (cons 'cursor-color fg))))))
- ;; 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 t)
- (setq rest (cdr rest)))
+ (frame-set-background-mode frame)
+
+ (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
(background (face-background data))
(font (face-font data))
(stipple (face-stipple data)))
- (set-face-underline-p face (face-underline-p data) frame)
+ (if (face-underline-p data)
+ (set-face-underline-p face (face-underline-p data) frame))
(if foreground
(face-try-color-list 'set-face-foreground
face foreground frame))
(eq function 'set-face-background))
(funcall function face colors frame))
(if (eq colors t)
- (invert-face face frame)
+ (set-face-inverse-video-p face t frame)
(let (done)
(while (and colors (not done))
(if (or (memq (car colors) '(t underline))
(condition-case nil
(progn
(cond ((eq (car colors) t)
- (invert-face face frame))
+ (set-face-inverse-video-p face t frame))
((eq (car colors) 'underline)
(set-face-underline-p face t frame))
(t
;; If this is the last color, let the error get out if it fails.
;; If it succeeds, we will exit anyway after this iteration.
(cond ((eq (car colors) t)
- (invert-face face frame))
+ (set-face-inverse-video-p face t frame))
((eq (car colors) 'underline)
(set-face-underline-p face t frame))
(t
(funcall function face (car colors) frame)))))
(setq colors (cdr colors)))))))
-;; If we are already using x-window frames, initialize faces for them.
-(if (memq (framep (selected-frame)) '(x w32))
- (face-initialize))
+;;; Make the standard faces.
+;;; The C code knows the default and modeline faces as faces 0 and 1,
+;;; so they must be the first two faces made.
+(make-face 'default)
+(make-face 'modeline)
+(make-face 'highlight)
+
+;; These aren't really special in any way, but they're nice to have around.
+
+(make-face 'bold)
+(make-face 'italic)
+(make-face 'bold-italic)
+(make-face 'region)
+(make-face 'secondary-selection)
+(make-face 'underline)
+
+(setq region-face (face-id 'region))
+
+;; 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))))
+ (italic "Use italic font." ((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"))
+ (t (:inverse-video t))))
+ (modeline "Used for displaying the modeline."
+ ((t (:inverse-video t))))
+ (region "Used for displaying the region."
+ ((t (:background "gray"))))
+ (secondary-selection
+ "Used for displaying the secondary selection."
+ ((((class color)) (:background "paleturquoise"))
+ (t (:inverse-video t))))))
+ entry symbol doc spec)
+ (while all
+ (setq entry (car all)
+ all (cdr all)
+ symbol (nth 0 entry)
+ doc (nth 1 entry)
+ spec (nth 2 entry))
+ (put symbol 'face-documentation doc)
+ (put symbol 'face-defface-spec spec)))
(provide 'faces)