;;; Code:
+\f
+;;;; Functions for manipulating face vectors.
+
+;;; A face vector is a vector of the form:
+;;; [face ID FONT FOREGROUND BACKGROUND BACKGROUND-PIXMAP UNDERLINE]
+
+;;; Type checkers.
(defsubst internal-facep (x)
(and (vectorp x) (= (length x) 8) (eq (aref x 0) 'face)))
(` (while (not (internal-facep (, face)))
(setq (, face) (signal 'wrong-type-argument (list 'internal-facep (, face)))))))
-
-(defvar global-face-data nil "do not use this")
-
-(defun face-list ()
- "Returns a list of all defined face names."
- (mapcar 'car global-face-data))
-
-(defun internal-find-face (name &optional frame)
- "Retrieve the face named NAME. Return nil if there is no such face.
-If the optional argument FRAME is given, this gets the face NAME for
-that frame; otherwise, it uses the selected frame.
-If FRAME is the symbol t, then the global, non-frame face is returned.
-If NAME is already a face, it is simply returned."
- (if (and (eq frame t) (not (symbolp name)))
- (setq name (face-name name)))
- (if (symbolp name)
- (cdr (assq name
- (if (eq frame t)
- global-face-data
- (frame-face-alist (or frame (selected-frame))))))
- (internal-check-face name)
- name))
-
-(defun internal-get-face (name &optional frame)
- "Retrieve the face named NAME; error if there is none.
-If the optional argument FRAME is given, this gets the face NAME for
-that frame; otherwise, it uses the selected frame.
-If FRAME is the symbol t, then the global, non-frame face is returned.
-If NAME is already a face, it is simply returned."
- (or (internal-find-face name frame)
- (internal-check-face name)))
-
+;;; Accessors.
(defsubst face-name (face)
"Return the name of face FACE."
(aref (internal-get-face face) 1))
Otherwise report on the defaults for face FACE (for new frames)."
(aref (internal-get-face face frame) 5))
-(defsubst face-background-pixmap (face &optional frame)
- "Return the background pixmap name of face FACE, or nil if unspecified.
-If the optional argument FRAME is given, report on face FACE in that frame.
-Otherwise report on the defaults for face FACE (for new frames)."
- (aref (internal-get-face face frame) 6))
+;;(defsubst face-background-pixmap (face &optional frame)
+;; "Return the background pixmap name of face FACE, or nil if unspecified.
+;;If the optional argument FRAME is given, report on face FACE in that frame.
+;;Otherwise report on the defaults for face FACE (for new frames)."
+;; (aref (internal-get-face face frame) 6))
(defsubst face-underline-p (face &optional frame)
"Return t if face FACE is underlined.
Otherwise report on the defaults for face FACE (for new frames)."
(aref (internal-get-face face frame) 7))
+\f
+;;; Mutators.
+
+(defsubst 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 (x-resolve-font-name font face frame)))
+ (internal-set-face-1 face 'font font 3 frame))
+
+(defsubst 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"))
+ (internal-set-face-1 face 'foreground color 4 frame))
+
+(defsubst set-face-background (face color &optional frame)
+ "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"))
+ (internal-set-face-1 face 'background color 5 frame))
+
+;;(defsubst set-face-background-pixmap (face name &optional frame)
+;; "Change the background pixmap of face FACE to PIXMAP.
+;;PIXMAP should be a string, the name of a file of pixmap data.
+;;The directories listed in the `x-bitmap-file-path' variable are searched.
+
+;;Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA)
+;;where WIDTH and HEIGHT are the size in pixels,
+;;and DATA is a string, containing the raw bits of the bitmap.
+
+;;If the optional FRAME argument is provided, change only
+;;in that frame; otherwise change each frame."
+;; (interactive (internal-face-interactive "background-pixmap"))
+;; (internal-set-face-1 face 'background-pixmap name 6 frame))
+
+(defsubst set-face-underline-p (face underline-p &optional frame)
+ "Specify whether face FACE is underlined. (Yes if UNDERLINE-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (interactive (internal-face-interactive "underline-p" "underlined"))
+ (internal-set-face-1 face 'underline underline-p 7 frame))
+
+\f
+;;;; Associating face names (symbols) with their face vectors.
+
+(defvar global-face-data nil "do not use this")
+
+(defun face-list ()
+ "Returns a list of all defined face names."
+ (mapcar 'car global-face-data))
+
+(defun internal-find-face (name &optional frame)
+ "Retrieve the face named NAME. Return nil if there is no such face.
+If the optional argument FRAME is given, this gets the face NAME for
+that frame; otherwise, it uses the selected frame.
+If FRAME is the symbol t, then the global, non-frame face is returned.
+If NAME is already a face, it is simply returned."
+ (if (and (eq frame t) (not (symbolp name)))
+ (setq name (face-name name)))
+ (if (symbolp name)
+ (cdr (assq name
+ (if (eq frame t)
+ global-face-data
+ (frame-face-alist (or frame (selected-frame))))))
+ (internal-check-face name)
+ name))
+
+(defun internal-get-face (name &optional frame)
+ "Retrieve the face named NAME; error if there is none.
+If the optional argument FRAME is given, this gets the face NAME for
+that frame; otherwise, it uses the selected frame.
+If FRAME is the symbol t, then the global, non-frame face is returned.
+If NAME is already a face, it is simply returned."
+ (or (internal-find-face name frame)
+ (internal-check-face name)))
+
(defun internal-set-face-1 (face name value index frame)
(let ((inhibit-quit t))
(list face (if (equal value "") nil value))))
-(defsubst 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"))
- (internal-set-face-1 face 'font font 3 frame))
-
-(defsubst 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"))
- (internal-set-face-1 face 'foreground color 4 frame))
-
-(defsubst set-face-background (face color &optional frame)
- "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"))
- (internal-set-face-1 face 'background color 5 frame))
-
-(defsubst set-face-background-pixmap (face name &optional frame)
- "Change the background pixmap of face FACE to PIXMAP.
-PIXMAP should be a string, the name of a file of pixmap data.
-The directories listed in the `x-bitmap-file-path' variable are searched.
-
-Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA)
-where WIDTH and HEIGHT are the size in pixels,
-and DATA is a string, containing the raw bits of the bitmap.
-
-If the optional FRAME argument is provided, change only
-in that frame; otherwise change each frame."
- (interactive (internal-face-interactive "background-pixmap"))
- (internal-set-face-1 face 'background-pixmap name 6 frame))
-
-(defsubst set-face-underline-p (face underline-p &optional frame)
- "Specify whether face FACE is underlined. (Yes if UNDERLINE-P is non-nil.)
-If the optional FRAME argument is provided, change only
-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 make-face (name)
"Define a new FACE on all frames.
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 face: ")
(or (internal-find-face name)
(let ((face (make-vector 8 nil)))
(aset face 0 'face)
(set-face-font new-face (face-font old-face frame) frame)
(set-face-foreground new-face (face-foreground old-face frame) frame)
(set-face-background new-face (face-background old-face frame) frame)
- (set-face-background-pixmap
- new-face (face-background-pixmap old-face frame) frame)
+;;; (set-face-background-pixmap
+;;; new-face (face-background-pixmap old-face frame) frame)
(set-face-underline-p new-face (face-underline-p old-face frame)
frame))
new-face))
(defun face-equal (face1 face2 &optional frame)
- "True if the faces FACE1 and FACE2 display in the the same way."
+ "True if the faces FACE1 and FACE2 display in the same way."
(setq face1 (internal-get-face face1 frame)
face2 (internal-get-face face2 frame))
(and (equal (face-foreground face1 frame) (face-foreground face2 frame))
(null (face-background face frame)))
(or (equal (face-font default frame) (face-font face frame))
(null (face-font face frame)))
- (or (equal (face-background-pixmap default frame)
- (face-background-pixmap face frame))
- (null (face-background-pixmap face frame)))
+;;; (or (equal (face-background-pixmap default frame)
+;;; (face-background-pixmap face frame))
+;;; (null (face-background-pixmap face frame)))
(equal (face-underline-p default frame)
(face-underline-p face frame))
))))
(defun invert-face (face &optional frame)
"Swap the foreground and background colors of face FACE.
If the face doesn't specify both foreground and background, then
-its foreground and background are set to the background and
-foreground of the default face."
+set its foreground and background to the default background and foreground."
(interactive (list (read-face-name "Invert face: ")))
(setq face (internal-get-face face frame))
(let ((fg (face-foreground face frame))
(progn
(set-face-foreground face bg frame)
(set-face-background face fg frame))
- (set-face-foreground face (face-background 'default frame) frame)
- (set-face-background face (face-foreground 'default frame) 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)))
face)
(condition-case ()
(set-face-font face font frame)
(error nil)))
-
-
-(defun set-default-font (font)
- "Sets the font used for normal text and the modeline to FONT in all frames.
-For finer-grained control, use set-face-font."
- (interactive (list (read-string "Set default font: "
- (face-font 'default (selected-frame)))))
- (set-face-font 'default font)
- (set-face-font 'modeline font))
\f
;; Manipulating font names.
(setq x-font-regexp-weight (concat - weight -))
nil)
+(defun x-resolve-font-name (pattern &optional face frame)
+ "Return a font name matching PATTERN.
+All wildcards in PATTERN become substantiated.
+If PATTERN is nil, return the name of the frame's base font, which never
+contains wildcards.
+Given optional arguments FACE and FRAME, try to return a font which is
+also the same size as FACE on FRAME."
+ (or (symbolp face)
+ (setq face (face-name face)))
+ (and (eq frame t)
+ (setq frame nil))
+ (if pattern
+ (let ((fonts (x-list-fonts pattern face frame)))
+ (or fonts
+ (if face
+ (error "No fonts matching pattern are the same size as `%s'"
+ face)
+ (error "No fonts match `%s'" pattern)))
+ (car fonts))
+ (cdr (assq 'font (frame-parameters (selected-frame))))))
+
(defun x-frob-font-weight (font which)
(if (or (string-match x-font-regexp font)
(string-match x-font-regexp-head font)
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(or (and (setq f2 (x-make-font-bold font))
- (internal-try-face-font face f2))
+ (internal-try-face-font face f2 frame))
(and (setq f2 (x-make-font-demibold font))
- (internal-try-face-font face f2))))
+ (internal-try-face-font face f2 frame))))
(or (not (equal ofont (face-font face)))
(and (not noerror)
- (error "No %s version of %S" face ofont)))))
+ (error "No bold version of %S" font)))))
(defun make-face-italic (face &optional frame noerror)
"Make the font of the given face be italic, if possible.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(or (and (setq f2 (x-make-font-italic font))
- (internal-try-face-font face f2))
+ (internal-try-face-font face f2 frame))
(and (setq f2 (x-make-font-oblique font))
- (internal-try-face-font face f2))))
+ (internal-try-face-font face f2 frame))))
(or (not (equal ofont (face-font face)))
(and (not noerror)
- (error "No %s version of %S" face ofont)))))
+ (error "No italic version of %S" font)))))
(defun make-face-bold-italic (face &optional frame noerror)
"Make the font of the given face be bold and italic, if possible.
(not (equal font f2))
(setq f3 (x-make-font-bold f2))
(not (equal f2 f3))
- (internal-try-face-font face f3))
+ (internal-try-face-font face f3 frame))
(and (setq f2 (x-make-font-oblique font))
(not (equal font f2))
(setq f3 (x-make-font-bold f2))
(not (equal f2 f3))
- (internal-try-face-font face f3))
+ (internal-try-face-font face f3 frame))
(and (setq f2 (x-make-font-italic font))
(not (equal font f2))
(setq f3 (x-make-font-demibold f2))
(not (equal f2 f3))
- (internal-try-face-font face f3))
+ (internal-try-face-font face f3 frame))
(and (setq f2 (x-make-font-oblique font))
(not (equal font f2))
(setq f3 (x-make-font-demibold f2))
(not (equal f2 f3))
- (internal-try-face-font face f3))))
+ (internal-try-face-font face f3 frame))))
(or (not (equal ofont (face-font face)))
(and (not noerror)
- (error "No %s version of %S" face ofont)))))
+ (error "No bold italic version of %S" font)))))
(defun make-face-unbold (face &optional frame noerror)
"Make the font of the given face be non-bold, if possible.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (x-make-font-unbold font1))
- (if font (internal-try-face-font face font)))
+ (if font (internal-try-face-font face font frame)))
(or (not (equal ofont (face-font face)))
(and (not noerror)
- (error "No %s version of %S" face ofont)))))
+ (error "No unbold version of %S" font1)))))
(defun make-face-unitalic (face &optional frame noerror)
"Make the font of the given face be non-italic, if possible.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (x-make-font-unitalic font1))
- (if font (internal-try-face-font face font)))
+ (if font (internal-try-face-font face font frame)))
(or (not (equal ofont (face-font face)))
(and (not noerror)
- (error "No %s version of %S" face ofont)))))
+ (error "No unitalic version of %S" font1)))))
\f
-;;; Make the builtin faces; the C code knows these as faces 0, 1, and 2,
-;;; respectively, so they must be the first three faces made.
-
-(if (internal-find-face 'default)
- nil
+;;; Make the default and modeline faces; the C code knows these as
+;;; faces 0 and 1, respectively, so they must be the first two faces
+;;; made.
+(defun face-initialize ()
(make-face 'default)
(make-face 'modeline)
(make-face 'highlight)
(make-face 'bold)
(make-face 'italic)
(make-face 'bold-italic)
- (make-face 'primary-selection)
- (make-face 'secondary-selection))
+ (make-face 'region)
+ (make-face 'secondary-selection)
+
+ (setq region-face (face-id 'region))
+
+ ;; Set up the faces of all existing X Window frames.
+ (let ((frames (frame-list)))
+ (while frames
+ (if (eq (framep (car frames)) 'x)
+ (x-initialize-frame-faces (car frames)))
+ (setq frames (cdr frames)))))
+
\f
;;; This really belongs in setting a frame's own font.
;;; ;;
(or (face-differs-from-default-p 'highlight frame)
(condition-case ()
- (if (x-display-color-p)
- (condition-case ()
- (set-face-background 'highlight "darkseagreen2" frame)
- (error (set-face-background 'highlight "green" frame)))
- (set-face-background-pixmap 'highlight "gray1" frame)
- )
+ (condition-case ()
+ (set-face-background 'highlight "darkseagreen2" frame)
+ (error (set-face-background 'highlight "green" frame)))
+;;; (set-face-background-pixmap 'highlight "gray1" frame)
(error (invert-face 'highlight frame))))
- (or (face-differs-from-default-p 'primary-selection frame)
+ (or (face-differs-from-default-p 'region frame)
(condition-case ()
- (if (x-display-color-p)
- (set-face-background 'primary-selection "gray" frame)
- (set-face-background-pixmap 'primary-selection "gray3" frame)
- )
- (error (invert-face 'primary-selection frame))))
+ (set-face-background 'region "gray" frame)
+ (error (invert-face 'region frame))))
+
+ (or (face-differs-from-default-p 'modeline frame)
+ (invert-face 'modeline frame))
(or (face-differs-from-default-p 'secondary-selection frame)
(condition-case ()
- (if (x-display-color-p)
- (condition-case ()
- ;; some older X servers don't have this one.
- (set-face-background 'secondary-selection "paleturquoise"
- frame)
- (error
- (set-face-background 'secondary-selection "green" frame)))
- (set-face-background-pixmap 'secondary-selection "gray1" frame)
- )
+ (condition-case ()
+ ;; some older X servers don't have this one.
+ (set-face-background 'secondary-selection "paleturquoise"
+ frame)
+ (error
+ (set-face-background 'secondary-selection "green" frame)))
+;;; (set-face-background-pixmap 'secondary-selection "gray1" frame)
(error (invert-face 'secondary-selection frame))))
)
(defun internal-x-complain-about-font (face frame)
- (message "No %s version of %S"
- face
- (or (face-font face frame)
- (face-font face t)
- (face-font 'default frame)
- (cdr (assq 'font (frame-parameters frame)))))
- (sit-for 1))
+;;; It's annoying to bother the user about this,
+;;; since it happens under normal circumstances.
+;;; (message "No %s version of %S"
+;;; face
+;;; (or (face-font face frame)
+;;; (face-font face t)
+;;; (face-font 'default frame)
+;;; (cdr (assq 'font (frame-parameters frame)))))
+;;; (sit-for 1)
+ )
\f
;; Like x-create-frame but also set up the faces.
(defun x-create-frame-with-faces (&optional parameters)
- (let* ((frame (x-create-frame parameters))
- (faces (copy-alist global-face-data))
- (rest faces)
- default modeline)
- (set-frame-face-alist frame faces)
-
- ;; Copy the vectors that represent the faces.
- ;; Also fill them in from X resources.
- (while rest
- (setcdr (car rest) (copy-sequence (cdr (car rest))))
- (make-face-x-resource-internal (cdr (car rest)) frame t)
- (setq rest (cdr rest)))
-
- (setq default (internal-get-face 'default frame)
- modeline (internal-get-face 'modeline frame))
-
- (x-initialize-frame-faces frame)
-
-;;; ;; Make sure the modeline face is fully qualified.
-;;; (if (and (not (face-font modeline frame)) (face-font default frame))
-;;; (set-face-font modeline (face-font default frame) frame))
-;;; (if (and (not (face-background modeline frame))
-;;; (face-background default frame))
-;;; (set-face-background modeline (face-background default frame) frame))
-;;; (if (and (not (face-foreground modeline frame))
-;;; (face-foreground default frame))
-;;; (set-face-foreground modeline (face-foreground default frame) frame))
- frame))
-
-;; Set up the faces of all existing frames.
-(let ((frames (frame-list)))
- (while frames
- (if (eq (framep (car frames)) 'x)
- (x-initialize-frame-faces (car frames)))
- (setq frames (cdr frames))))
+ (if (null global-face-data)
+ (x-create-frame parameters)
+ (let* ((frame (x-create-frame parameters))
+ (faces (copy-alist global-face-data))
+ (rest faces))
+ (set-frame-face-alist frame faces)
+
+ (if (cdr (or (assq 'reverse parameters)
+ (assq 'reverse default-frame-alist)
+ (cons nil
+ (x-get-resource "reverseVideo" "ReverseVideo"))))
+ (let ((params (frame-parameters frame)))
+ (modify-frame-parameters
+ frame
+ (list (cons 'foreground-color (cdr (assq 'background-color params)))
+ (cons 'background-color (cdr (assq 'foreground-color params)))
+ (cons 'mouse-color (cdr (assq 'background-color params)))
+ (cons 'cursor-color (cdr (assq 'background-color params)))
+ (cons 'border-color (cdr (assq 'background-color params)))))))
+
+ ;; Copy the vectors that represent the faces.
+ ;; Also fill them in from X resources.
+ (while rest
+ (setcdr (car rest) (copy-sequence (cdr (car rest))))
+ (make-face-x-resource-internal (cdr (car rest)) frame t)
+ (setq rest (cdr rest)))
+
+ (x-initialize-frame-faces frame)
+
+ frame)))
+
+;; If we are already using x-window frames, initialize faces for them.
+(if (eq (framep (selected-frame)) 'x)
+ (face-initialize))
(provide 'faces)