From d11fba257e256277003baa8860edfbf767895376 Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Mon, 21 Apr 1997 03:56:57 +0000 Subject: [PATCH] (frame-set-background-mode): New function. (frame-background-mode): New variable. (x-create-frame-with-faces): Rearrangement of order of font processing. Handle custom-faces here. (face-doc-string, set-face-doc-string): New functions. (set-face-bold-p, set-face-italic-p): New functions. (face-bold-p, face-italic-p): New function. (face-spec-set, face-spec-set-1, face-spec-set-match-display): New functions. --- lisp/faces.el | 227 +++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 188 insertions(+), 39 deletions(-) diff --git a/lisp/faces.el b/lisp/faces.el index bb36630f87c..d65bc1b019e 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -108,6 +108,33 @@ 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) 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)) ;;; Mutators. @@ -191,6 +218,24 @@ 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 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)) (defun modify-face-read-string (face default name alist) (let ((value @@ -1075,7 +1120,73 @@ selected frame." (face-fill-in face (cdr (car rest)) frame))) (setq rest (cdr rest))))) (setq frames (cdr frames))))) - + +;;; 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)) ;; Like x-create-frame but also set up the faces. @@ -1098,16 +1209,30 @@ selected frame." (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" @@ -1130,51 +1255,75 @@ selected frame." (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) -- 2.39.2