;; 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
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
;; (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.
(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
(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.
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.
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.
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.
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.
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)
;; 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)
- (if (and (eq 'default face) (featurep 'x))
- (x-init-global-faces))
- (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."
(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)))))
projects / chise / xemacs-chise.git.1 / blobdiff