X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Ffaces.el;h=d14b45befa931cddc6c04d860484e60239d65d28;hp=09a3e79001d2acbe691221373555ac3179b8f86d;hb=82f6d62ee211b1d36e8f45fed3ee3edde82b6916;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910 diff --git a/lisp/faces.el b/lisp/faces.el index 09a3e79..d14b45b 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -31,7 +31,7 @@ ;; This file is dumped with XEmacs. ;; face implementation #1 (used Lisp vectors and parallel C vectors; -;; FSFmacs still uses this) authored by Jamie Zawinski +;; FSFmacs still uses this) authored by Jamie Zawinski ;; pre Lucid-Emacs 19.0. ;; face implementation #2 (used one face object per frame per face) @@ -117,19 +117,20 @@ The return value will be a list of instantiators (e.g. strings The specifications in a specifier determine what the value of PROPERTY will be in a particular \"domain\" or set of circumstances, which is typically a particular Emacs window along with the buffer - it contains and the frame and device it lies within. The value - is derived from the instantiator associated with the most specific + it contains and the frame and device it lies within. The value is + derived from the instantiator associated with the most specific locale (in the order buffer, window, frame, device, and 'global) that matches the domain in question. In other words, given a domain - (i.e. an Emacs window, usually), the specifier for PROPERTY will first - be searched for a specification whose locale is the buffer contained - within that window; then for a specification whose locale is the window - itself; then for a specification whose locale is the frame that the - window is contained within; etc. The first instantiator that is - valid for the domain (usually this means that the instantiator is - recognized by the device [i.e. the X server or TTY device] that the - domain is on. The function `face-property-instance' actually does - all this, and is used to determine how to display the face. + (i.e. an Emacs window, usually), the specifier for PROPERTY will + first be searched for a specification whose locale is the buffer + contained within that window; then for a specification whose locale + is the window itself; then for a specification whose locale is the + frame that the window is contained within; etc. The first + instantiator that is valid for the domain (usually this means that + the instantiator is recognized by the device [i.e. MS Windows, the X + server or TTY device] that the domain is on. The function + `face-property-instance' actually does all this, and is used to + determine how to display the face. See `set-face-property' for the built-in property-names." @@ -292,42 +293,41 @@ If PROPERTY is not a built-in property, then this function will The following symbols have predefined meanings: foreground The foreground color of the face. - For valid instantiators, see `color-specifier-p'. + For valid instantiators, see `make-color-specifier'. background The background color of the face. - For valid instantiators, see `color-specifier-p'. + For valid instantiators, see `make-color-specifier'. font The font used to display text covered by this face. - For valid instantiators, see `font-specifier-p'. + For valid instantiators, see `make-font-specifier'. display-table The display table of the face. This should be a vector of 256 elements. background-pixmap The pixmap displayed in the background of the face. - Only used by faces on X devices. - For valid instantiators, see `image-specifier-p'. + Only used by faces on X and MS Windows devices. + For valid instantiators, see `make-image-specifier'. underline Underline all text covered by this face. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. strikethru Draw a line through all text covered by this face. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. highlight Highlight all text covered by this face. Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. dim Dim all text covered by this face. - Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. blinking Blink all text covered by this face. Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. reverse Reverse the foreground and background colors. Only used by faces on TTY devices. - For valid instantiators, see `face-boolean-specifier-p'. + For valid instantiators, see `make-face-boolean-specifier'. doc-string Description of what the face's normal use is. NOTE: This is not a specifier, unlike all @@ -434,7 +434,7 @@ See `face-property-instance' for more information." FACE may be either a face object or a symbol representing a face. -FONT should be an instantiator (see `font-specifier-p'), a list of +FONT should be an instantiator (see `make-font-specifier'), a list of instantiators, an alist of specifications (each mapping a locale to an instantiator list), or a font specifier object. @@ -491,7 +491,7 @@ See `face-property-instance' for more information." FACE may be either a face object or a symbol representing a face. -COLOR should be an instantiator (see `color-specifier-p'), a list of +COLOR should be an instantiator (see `make-color-specifier'), a list of instantiators, an alist of specifications (each mapping a locale to an instantiator list), or a color specifier object. @@ -548,7 +548,7 @@ See `face-property-instance' for more information." FACE may be either a face object or a symbol representing a face. -COLOR should be an instantiator (see `color-specifier-p'), a list of +COLOR should be an instantiator (see `make-color-specifier'), a list of instantiators, an alist of specifications (each mapping a locale to an instantiator list), or a color specifier object. @@ -596,7 +596,7 @@ This property is only used on window system devices. FACE may be either a face object or a symbol representing a face. -PIXMAP should be an instantiator (see `image-specifier-p'), a list +PIXMAP should be an instantiator (see `make-image-specifier'), a list of instantiators, an alist of specifications (each mapping a locale to an instantiator list), or an image specifier object. @@ -653,7 +653,7 @@ See `face-property-instance' for the semantics of the DOMAIN argument." how-to-add) "Change the underline property of FACE to UNDERLINE-P. UNDERLINE-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "underline-p" "underlined")) @@ -668,7 +668,7 @@ See `face-property-instance' for the semantics of the DOMAIN argument." how-to-add) "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. STRIKETHRU-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "strikethru-p" "strikethru-d")) @@ -683,21 +683,21 @@ See `face-property-instance' for the semantics of the DOMAIN argument." how-to-add) "Change whether FACE is highlighted in LOCALE (TTY locales only). HIGHLIGHT-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "highlight-p" "highlighted")) (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'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "dim-p" "dimmed")) @@ -712,7 +712,7 @@ See `face-property-instance' for the semantics of the DOMAIN argument." how-to-add) "Change whether FACE is blinking in LOCALE (TTY locales only). BLINKING-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "blinking-p" "blinking")) @@ -726,7 +726,7 @@ See `face-property-instance' for the semantics of the DOMAIN argument." (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) "Change whether FACE is reversed in LOCALE (TTY locales only). REVERSE-P is normally a face-boolean instantiator; see - `face-boolean-specifier-p'. + `make-face-boolean-specifier'. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD arguments." (interactive (face-interactive "reverse-p" "reversed")) @@ -750,9 +750,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 +795,8 @@ 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 device-tags &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 @@ -813,14 +815,21 @@ until a non-nil result is found (if there is no such result, the 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))) +substituted for the specification. + +DEVICE-TAGS is a list of tags that each device must match in order for +the function to be called on it." + (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))))) + (name (and inst + (device-matches-specifier-tag-set-p + (dfw-device locale) device-tags) + (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,32 +841,44 @@ 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. + + + (setq temp-sp (copy-specifier sp)) (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)) + temp-sp 'global)) (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 (and (device-matches-specifier-tag-set-p + device device-tags) + (frob-face-property-1 sp-arg device inst-list + func))) (mapcar (lambda (device) - (frob-face-property-1 sp device - inst-list func)) + (and (device-matches-specifier-tag-set-p + device device-tags) + (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 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) @@ -886,15 +907,15 @@ 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 - tty-thunk x-thunk standard-face-mapping) +(defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face + tty-thunk ws-thunk standard-face-mapping) ;; another kludge to make things more intuitive. If we're ;; inheriting from a standard face in this locale, frob the - ;; inheritance as appropriate. Else, if, after the first X frobbing - ;; pass, the face hasn't changed and still looks like the standard - ;; unfrobbed face (e.g. 'default), make it inherit from the standard - ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY - ;; frobbing. + ;; inheritance as appropriate. Else, if, after the first + ;; window-system frobbing pass, the face hasn't changed and still + ;; looks like the standard unfrobbed face (e.g. 'default), make it + ;; inherit from the standard frobbed face (e.g. 'bold). Regardless + ;; of things, do the TTY frobbing. ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale, ;; but is a "locale, locale-type, or nil for all". So ... do our extra @@ -922,7 +943,7 @@ substituted for the specification." (t nil))) (inst (and domain (face-property-instance face 'font domain)))) (funcall tty-thunk) - (funcall x-thunk) + (funcall ws-thunk) ;; If it's reasonable to do the inherit-from-standard-face trick, ;; and it's called for, then do it now. (or (null domain) @@ -934,11 +955,11 @@ 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 +This will attempt to make the font bold for X/MSW locales and will set the highlight flag for TTY locales. If LOCALE is nil, omitted, or `all', this will attempt to frob all @@ -965,118 +986,128 @@ 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 + ;; handle X/MS Windows specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-make-font-bold locale)) + (frob-face-property face 'font 'x-make-font-bold + '(x) locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-bold locale)) + (frob-face-property face 'font 'mswindows-make-font-bold + '(mswindows) 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. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." +This will attempt to make the font italic for X/MS Windows locales and +will set the underline flag for TTY locales. 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 + '(x) locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-italic locale)) + (frob-face-property face 'font 'mswindows-make-font-italic + '(mswindows) 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. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." +This will attempt to make the font bold-italic for X/MS Windows +locales and will set the highlight and underline flags for TTY +locales. 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 + '(x) 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 + '(mswindows) 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. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." +This will attempt to make the font non-bold for X/MS Windows locales +and will unset the highlight flag for TTY locales. 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 + '(x) locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-unbold locale)) + (frob-face-property face 'font 'mswindows-make-font-unbold + '(mswindows) 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. -See `make-face-bold' for the semantics of the LOCALE argument and -for more specifics on exactly how this function works." +This will attempt to make the font non-italic for X/MS Windows locales +and will unset the underline flag for TTY locales. 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 + '(x) locale tags)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-make-font-unitalic locale)) + (frob-face-property face 'font 'mswindows-make-font-unitalic + '(mswindows) locale tags)) ) '(([default] . t) ([bold] . t) @@ -1095,9 +1126,11 @@ because they don't make sense in this context." (interactive (list (read-face-name "Shrink which face: "))) ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-find-smaller-font locale)) + (frob-face-property face 'font 'x-find-smaller-font + '(x) locale)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-find-smaller-font locale))) + (frob-face-property face 'font 'mswindows-find-smaller-font + '(mswindows) locale))) (defun make-face-larger (face &optional locale) "Make the font of FACE be larger, if possible. @@ -1105,9 +1138,11 @@ See `make-face-smaller' for the semantics of the LOCALE argument." (interactive (list (read-face-name "Enlarge which face: "))) ;; handle X specific entries (when (featurep 'x) - (frob-face-property face 'font 'x-find-larger-font locale)) + (frob-face-property face 'font 'x-find-larger-font + '(x) locale)) (when (featurep 'mswindows) - (frob-face-property face 'font 'mswindows-find-larger-font locale))) + (frob-face-property face 'font 'mswindows-find-larger-font + '(mswindows) locale))) (defun invert-face (face &optional locale) "Swap the foreground and background colors of the face." @@ -1197,25 +1232,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,14 +1268,14 @@ 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))))) (defvar default-custom-frame-properties nil "The frame properties used for the global faces. -Frames not matching these propertiess should have frame local faces. +Frames not matching these properties should have frame local faces. The value should be nil, if uninitialized, or a plist otherwise. See `defface' for a list of valid keys and values for the plist.") @@ -1249,13 +1291,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'. @@ -1314,6 +1387,24 @@ If FRAME is nil or omitted, initialize them for all frames." (get-custom-frame-properties frame)) (initialize-custom-faces frame))) +(defun startup-initialize-custom-faces () + "Reset faces created by defface. Only called at startup. +Don't use this function in your program." + (when default-custom-frame-properties + ;; Reset default value to the actual frame, not stream. + (setq default-custom-frame-properties + (extract-custom-frame-properties (selected-frame))) + ;; like initialize-custom-faces but removes property first. + (mapc (lambda (symbol) + (let ((spec (or (get symbol 'saved-face) + (get symbol 'face-defface-spec)))) + (when spec + ;; Reset faces created during auto-autoloads loading. + (reset-face symbol) + ;; And set it according to the spec. + (face-display-set symbol spec nil)))) + (face-list)))) + (defun make-empty-face (name &optional doc-string temporary) "Like `make-face', but doesn't query the resource database." @@ -1364,7 +1455,8 @@ and 'global)." (mswindows-init-device-faces device)) ;; Nothing to do for TTYs? ) - (init-other-random-faces device))) + (or (eq 'stream (device-type device)) + (init-other-random-faces device)))) (defun init-frame-faces (frame) (when init-face-from-resources @@ -1474,7 +1566,7 @@ you want to add code to do stuff like this, use the create-device-hook." ;; It's unreasonable to expect to be able to make a font italic all ;; the time. For many languages, italic is an alien concept. ;; Basically, because italic is not a globally meaningful concept, - ;; the use of the italic face should really be oboleted. + ;; the use of the italic face should really be obsoleted. ;; I disagree with above. In many languages, the concept of capital ;; letters is just as alien, and yet we use them. Italic is here to @@ -1524,14 +1616,17 @@ you want to add code to do stuff like this, use the create-device-hook." nil 'append)) ) -;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones. +;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle +;; Jones and Hrvoje Niksic. (defun set-face-stipple (face pixmap &optional frame) "Change the stipple pixmap of FACE to PIXMAP. This is an Emacs compatibility function; consider using set-face-background-pixmap instead. 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. +The directories listed in the variables `x-bitmap-file-path' and +`mswindows-bitmap-file-path' under X and MS Windows respectively +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 @@ -1541,21 +1636,33 @@ expected in this case, other types of image data will not work. 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) - (while (cond ((stringp pixmap) - (unless (file-readable-p pixmap) - (setq pixmap `[xbm :file ,pixmap])) - nil) - ((and (consp pixmap) (= (length pixmap) 3)) - (setq pixmap `[xbm :data ,pixmap]) - nil) - (t t)) - (setq pixmap (signal 'wrong-type-argument - (list 'stipple-pixmap-p pixmap)))) - (while (and frame (not (framep frame))) - (setq frame (signal 'wrong-type-argument (list 'framep frame)))) - (set-face-background-pixmap face pixmap frame)) + (setq face (wrong-type-argument 'facep face))) + (let ((bitmap-path (ecase (console-type) + (x x-bitmap-file-path) + (mswindows mswindows-bitmap-file-path))) + instantiator) + (while + (null + (setq instantiator + (cond ((stringp pixmap) + (let ((file (if (file-name-absolute-p pixmap) + pixmap + (locate-file pixmap bitmap-path + '(".xbm" ""))))) + (and file + `[xbm :file ,file]))) + ((and (listp pixmap) (= (length pixmap) 3)) + `[xbm :data ,pixmap]) + (t nil)))) + ;; We're signaling a continuable error; let's make sure the + ;; function `stipple-pixmap-p' at least exists. + (flet ((stipple-pixmap-p (pixmap) + (or (stringp pixmap) + (and (listp pixmap) (= (length pixmap) 3))))) + (setq pixmap (signal 'wrong-type-argument + (list 'stipple-pixmap-p pixmap))))) + (check-type frame (or null frame)) + (set-face-background-pixmap face instantiator frame))) ;; Create the remaining standard faces now. This way, packages that we dump @@ -1572,6 +1679,7 @@ in that frame; otherwise change each frame." (set-face-underline-p 'underline t 'global '(default))) (make-face 'zmacs-region "Used on highlightes region between point and mark.") (make-face 'isearch "Used on region matched by isearch.") +(make-face 'isearch-secondary "Face to use for highlighting all matches.") (make-face 'list-mode-item-selected "Face for the selected list item in list-mode.") (make-face 'highlight "Highlight face.") @@ -1661,27 +1769,36 @@ in that frame; otherwise change each frame." ((mswindows default color) . "green")) 'global) +;; #### This should really, I mean *really*, be converted to some form +;; of `defface' one day. +(set-face-foreground 'isearch-secondary + '(((x default color) . "red3") + ((mswindows default color) . "red3")) + 'global) + ;; Define some logical color names to be used when reading the pixmap files. (if (featurep 'xpm) (setq xpm-color-symbols (list - (purecopy '("foreground" (face-foreground 'default))) - (purecopy '("background" (face-background 'default))) - (purecopy '("backgroundToolBarColor" - (or - (and - (featurep 'x) - (x-get-resource "backgroundToolBarColor" - "BackgroundToolBarColor" 'string)) - - (face-background 'toolbar)))) - (purecopy '("foregroundToolBarColor" - (or - (and - (featurep 'x) - (x-get-resource "foregroundToolBarColor" - "ForegroundToolBarColor" 'string)) - (face-foreground 'toolbar)))) + '("foreground" (face-foreground 'default)) + '("background" (face-background 'default)) + '("backgroundToolBarColor" + (or + (and + (featurep 'x) + (x-get-resource "backgroundToolBarColor" + "BackgroundToolBarColor" 'string + nil nil 'warn)) + + (face-background 'toolbar))) + '("foregroundToolBarColor" + (or + (and + (featurep 'x) + (x-get-resource "foregroundToolBarColor" + "ForegroundToolBarColor" 'string + nil nil 'warn)) + (face-foreground 'toolbar))) ))) (when (featurep 'tty)