X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffaces.el;h=b9dc478b5aacda5fcbf70a356793f751ba68795c;hb=fb429e0e5132c44445e4bf2dc7af356e00ade2e5;hp=09a3e79001d2acbe691221373555ac3179b8f86d;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git diff --git a/lisp/faces.el b/lisp/faces.el index 09a3e79..b9dc478 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -318,7 +318,6 @@ The following symbols have predefined meanings: For valid instantiators, see `face-boolean-specifier-p'. dim Dim all text covered by this face. - Only used by faces on TTY devices. For valid instantiators, see `face-boolean-specifier-p'. blinking Blink all text covered by this face. @@ -690,12 +689,12 @@ See `set-face-property' for the semantics of the LOCALE, TAG-SET, and (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) (defun face-dim-p (face &optional domain default no-fallback) - "Return t if FACE is dimmed in DOMAIN (TTY domains only). + "Return t if FACE is dimmed in DOMAIN. See `face-property-instance' for the semantics of the DOMAIN argument." (face-property-instance face 'dim domain default no-fallback)) (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) - "Change whether FACE is dimmed in LOCALE (TTY locales only). + "Change whether FACE is dimmed in LOCALE. DIM-P is normally a face-boolean instantiator; see `face-boolean-specifier-p'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and @@ -750,9 +749,10 @@ See `face-property-instance' for the semantics of the DOMAIN argument." (if (not (valid-specifier-domain-p domain)) (error "Invalid specifier domain")) (let ((device (dfw-device domain)) - (common-props '(foreground background font display-table underline)) + (common-props '(foreground background font display-table underline + dim)) (win-props '(background-pixmap strikethru)) - (tty-props '(highlight dim blinking reverse))) + (tty-props '(highlight blinking reverse))) ;; First check the properties which are used in common between the ;; x and tty devices. Then, check those properties specific to @@ -794,7 +794,7 @@ See `face-property-instance' for the semantics of the DOMAIN argument." ;; WE DEMAND LEXICAL SCOPING!!! ;; WE DEMAND LEXICAL SCOPING!!! ;; WE DEMAND LEXICAL SCOPING!!! -(defun frob-face-property (face property func &optional locale) +(defun frob-face-property (face property func &optional locale tags) "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. This function is ugly and messy and is primarily used as an internal helper function for `make-face-bold' et al., so you probably don't @@ -814,13 +814,14 @@ first valid instantiator is used), and that result substituted for the specification; otherwise, the process just outlined is iterated over each existing device and the concatenated results substituted for the specification." - (let ((sp (face-property face property))) + (let ((sp (face-property face property)) + temp-sp) (if (valid-specifier-domain-p locale) ;; this is easy. (let* ((inst (face-property-instance face property locale)) (name (and inst (funcall func inst (dfw-device locale))))) (when name - (add-spec-to-specifier sp name locale))) + (add-spec-to-specifier sp name locale tags))) ;; otherwise, map over all specifications ... ;; but first, some further kludging: ;; (1) if we're frobbing the global property, make sure @@ -832,33 +833,40 @@ substituted for the specification." ;; (2) if we're frobbing a particular locale, nothing would ;; happen if that locale has no instantiators. So signal ;; an error to indicate this. - (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) - (not (face-property face property 'global))) - (copy-specifier (face-property 'default property) - (face-property face property) - 'global)) + + (setq temp-sp + (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) + (not (face-property face property 'global))) + (copy-specifier (face-property 'default property) + nil 'global) + sp)) (if (and (valid-specifier-locale-p locale) - (not (face-property face property locale))) + (not (specifier-specs temp-sp locale))) (error "Property must have a specification in locale %S" locale)) (map-specifier - sp - (lambda (sp locale inst-list func) + temp-sp + (lambda (sp-arg locale inst-list func) (let* ((device (dfw-device locale)) ;; if a device can be derived from the locale, ;; call frob-face-property-1 for that device. ;; Otherwise map frob-face-property-1 over each device. (result (if device - (list (frob-face-property-1 sp device inst-list func)) + (list (frob-face-property-1 sp-arg device inst-list func)) (mapcar (lambda (device) - (frob-face-property-1 sp device + (frob-face-property-1 sp-arg device inst-list func)) (device-list)))) new-result) ;; remove duplicates and nils from the obtained list of - ;; instantiators. + ;; instantiators. Also add tags amd remove 'defaults'. (mapcar (lambda (arg) - (when (and arg (not (member arg new-result))) + (when arg + (if (not (consp arg)) + (setq arg (cons tags arg)) + (setcar arg (append tags (delete 'default + (car arg)))))) + (when (and arg (not (member arg new-result))) (setq new-result (cons arg new-result)))) result) ;; add back in. @@ -886,7 +894,7 @@ substituted for the specification." (setq inst-list (cdr inst-list))) (or result first-valid))) -(defun frob-face-font-2 (face locale unfrobbed-face frobbed-face +(defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face tty-thunk x-thunk standard-face-mapping) ;; another kludge to make things more intuitive. If we're ;; inheriting from a standard face in this locale, frob the @@ -934,9 +942,9 @@ substituted for the specification." (not (equal (face-property-instance face 'font domain) (face-property-instance unfrobbed-face 'font domain))) (set-face-property face 'font (vector frobbed-face) - the-locale)))))) + the-locale tags)))))) -(defun make-face-bold (face &optional locale) +(defun make-face-bold (face &optional locale tags) "Make FACE bold in LOCALE, if possible. This will attempt to make the font bold for X locales and will set the highlight flag for TTY locales. @@ -965,24 +973,24 @@ but it makes `make-face-bold' have more intuitive behavior in many circumstances." (interactive (list (read-face-name "Make which face bold: "))) (frob-face-font-2 - face locale 'default 'bold + face locale tags 'default 'bold (lambda () ;; handle TTY specific entries (when (featurep 'tty) - (set-face-highlight-p face t locale 'tty))) + (set-face-highlight-p face t locale (cons 'tty tags)))) (lambda () ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-bold locale)) + (frob-face-property face 'font 'x-make-font-bold locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-bold locale)) + (frob-face-property face 'font 'mswindows-make-font-bold locale tags)) ) '(([default] . [bold]) ([bold] . t) ([italic] . [bold-italic]) ([bold-italic] . t)))) -(defun make-face-italic (face &optional locale) +(defun make-face-italic (face &optional locale tags) "Make FACE italic in LOCALE, if possible. This will attempt to make the font italic for X locales and will set the underline flag for TTY locales. @@ -990,24 +998,24 @@ See `make-face-bold' for the semantics of the LOCALE argument and for more specifics on exactly how this function works." (interactive (list (read-face-name "Make which face italic: "))) (frob-face-font-2 - face locale 'default 'italic + face locale tags 'default 'italic (lambda () ;; handle TTY specific entries (when (featurep 'tty) - (set-face-underline-p face t locale 'tty))) + (set-face-underline-p face t locale (cons 'tty tags)))) (lambda () ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-italic locale)) + (frob-face-property face 'font 'x-make-font-italic locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-italic locale)) + (frob-face-property face 'font 'mswindows-make-font-italic locale tags)) ) '(([default] . [italic]) ([bold] . [bold-italic]) ([italic] . t) ([bold-italic] . t)))) -(defun make-face-bold-italic (face &optional locale) +(defun make-face-bold-italic (face &optional locale tags) "Make FACE bold and italic in LOCALE, if possible. This will attempt to make the font bold-italic for X locales and will set the highlight and underline flags for TTY locales. @@ -1015,25 +1023,25 @@ See `make-face-bold' for the semantics of the LOCALE argument and for more specifics on exactly how this function works." (interactive (list (read-face-name "Make which face bold-italic: "))) (frob-face-font-2 - face locale 'default 'bold-italic + face locale tags 'default 'bold-italic (lambda () ;; handle TTY specific entries (when (featurep 'tty) - (set-face-highlight-p face t locale 'tty) - (set-face-underline-p face t locale 'tty))) + (set-face-highlight-p face t locale (cons 'tty tags)) + (set-face-underline-p face t locale (cons 'tty tags)))) (lambda () ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-bold-italic locale)) + (frob-face-property face 'font 'x-make-font-bold-italic locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-bold-italic locale)) + (frob-face-property face 'font 'mswindows-make-font-bold-italic locale tags)) ) '(([default] . [italic]) ([bold] . [bold-italic]) ([italic] . [bold-italic]) ([bold-italic] . t)))) -(defun make-face-unbold (face &optional locale) +(defun make-face-unbold (face &optional locale tags) "Make FACE non-bold in LOCALE, if possible. This will attempt to make the font non-bold for X locales and will unset the highlight flag for TTY locales. @@ -1041,24 +1049,24 @@ See `make-face-bold' for the semantics of the LOCALE argument and for more specifics on exactly how this function works." (interactive (list (read-face-name "Make which face non-bold: "))) (frob-face-font-2 - face locale 'bold 'default + face locale tags 'bold 'default (lambda () ;; handle TTY specific entries (when (featurep 'tty) - (set-face-highlight-p face nil locale 'tty))) + (set-face-highlight-p face nil locale (cons 'tty tags)))) (lambda () ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-unbold locale)) + (frob-face-property face 'font 'x-make-font-unbold locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-unbold locale)) + (frob-face-property face 'font 'mswindows-make-font-unbold locale tags)) ) '(([default] . t) ([bold] . [default]) ([italic] . t) ([bold-italic] . [italic])))) -(defun make-face-unitalic (face &optional locale) +(defun make-face-unitalic (face &optional locale tags) "Make FACE non-italic in LOCALE, if possible. This will attempt to make the font non-italic for X locales and will unset the underline flag for TTY locales. @@ -1066,17 +1074,17 @@ See `make-face-bold' for the semantics of the LOCALE argument and for more specifics on exactly how this function works." (interactive (list (read-face-name "Make which face non-italic: "))) (frob-face-font-2 - face locale 'italic 'default + face locale tags 'italic 'default (lambda () ;; handle TTY specific entries (when (featurep 'tty) - (set-face-underline-p face nil locale 'tty))) + (set-face-underline-p face nil locale (cons 'tty tags)))) (lambda () ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-unitalic locale)) + (frob-face-property face 'font 'x-make-font-unitalic locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-unitalic locale)) + (frob-face-property face 'font 'mswindows-make-font-unitalic locale tags)) ) '(([default] . t) ([bold] . t) @@ -1197,25 +1205,32 @@ examine the brightness for you." ;; Old name, used by custom. Also, FSFmacs name. (defvaralias 'initialize-face-resources 'init-face-from-resources) -(defun face-spec-set (face spec &optional frame) +;; Make sure all custom setting are added with this tag so we can +;; identify-them +(define-specifier-tag 'custom) + +(defun face-spec-set (face spec &optional frame tags) "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 (progn - (reset-face face frame) - (face-display-set face spec frame) + (reset-face face frame tags) + (face-display-set face spec frame tags) (init-face-from-resources face frame)) (let ((frames (relevant-custom-frames))) - (reset-face face) - (face-display-set face spec) + (reset-face face nil tags) + ;; This should not be needed. We only remove our own specifiers + ;; (if (and (eq 'default face) (featurep 'x)) + ;; (x-init-global-faces)) + (face-display-set face spec nil tags) (while frames - (face-display-set face spec (car frames)) + (face-display-set face spec (car frames) tags) (pop frames)) (init-face-from-resources face)))) -(defun face-display-set (face spec &optional frame) +(defun face-display-set (face spec &optional frame tags) "Set FACE to the attributes to the first matching entry in SPEC. Iff optional FRAME is non-nil, set it for that frame only. See `defface' for information about SPEC." @@ -1226,7 +1241,7 @@ See `defface' for information about SPEC." (when (face-spec-set-match-display display frame) ;; Avoid creating frame local duplicates of the global face. (unless (and frame (eq display (get face 'custom-face-display))) - (apply 'face-custom-attributes-set face frame atts)) + (apply 'face-custom-attributes-set face frame tags atts)) (unless frame (put face 'custom-face-display display)) (setq spec nil))))) @@ -1249,13 +1264,44 @@ If FRAME is nil, return the default frame properties." ;; and cache it... (set-frame-property frame 'custom-properties cache)) cache)) - ;; We avoid this cache, because various frame and device - ;; properties can change. - ;;(default-custom-frame-properties) + (default-custom-frame-properties) (t (setq default-custom-frame-properties (extract-custom-frame-properties (selected-frame)))))) +(defun face-spec-update-all-matching (spec display plist) + "Update all entries in the face spec that could match display to +have the entries from the new plist and return the new spec" + (mapcar + (lambda (e) + (let ((entries (car e)) + (options (cadr e)) + (match t) + dplist + (new-options plist) + ) + (unless (eq display t) + (mapc (lambda (arg) + (setq dplist (plist-put dplist (car arg) (cadr arg)))) + display)) + (unless (eq entries t) + (mapc (lambda (arg) + (setq match (and match (eq (cadr arg) + (plist-get + dplist (car arg) + (cadr arg)))))) + entries)) + (if (not match) + e + (while new-options + (setq options + (plist-put options (car new-options) (cadr new-options))) + (setq new-options (cddr new-options))) + (list entries options)))) + (copy-sequence spec))) + + + (defun face-spec-set-match-display (display &optional frame) "Return non-nil if DISPLAY matches FRAME. DISPLAY is part of a spec such as can be used in `defface'. @@ -1542,7 +1588,7 @@ If the optional FRAME argument is provided, change only in that frame; otherwise change each frame." (while (not (find-face face)) (setq face (signal 'wrong-type-argument (list 'facep face)))) - (locate-file pixmap x-bitmap-file-path ".xbm:" 4) + (locate-file pixmap x-bitmap-file-path '(".xbm" "")) (while (cond ((stringp pixmap) (unless (file-readable-p pixmap) (setq pixmap `[xbm :file ,pixmap]))