;; This file is dumped with XEmacs.
;; face implementation #1 (used Lisp vectors and parallel C vectors;
-;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com>
+;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org>
;; pre Lucid-Emacs 19.0.
;; face implementation #2 (used one face object per frame per face)
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."
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.
- 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
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.
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.
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.
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.
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"))
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"))
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"))
(defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
"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"))
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"))
(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"))
(and (face-equal-loop common-props face1 face2 domain)
(cond ((eq 'tty (device-type device))
(face-equal-loop tty-props face1 face2 domain))
+ ;; #### Why isn't this (console-on-window-system-p (device-console device))?
+ ;; #### FIXME!
((or (eq 'x (device-type device))
+ (eq 'gtk (device-type device))
(eq 'mswindows (device-type device)))
(face-equal-loop win-props face1 face2 domain))
(t t)))))
;; 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
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
;; (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 (copy-specifier sp))
+ (if (or (eq locale 'global) (eq locale 'all) (not locale))
+ (when (not (specifier-specs temp-sp 'global))
+ ;; Try fallback via the official ways and then do it "by hand"
+ (let* ((fallback (specifier-fallback sp))
+ (fallback-sp
+ (cond ((specifierp fallback) fallback)
+ ;; just an inst list
+ (fallback
+ (make-specifier-and-init (specifier-type sp)
+ fallback))
+ ((eq (get-face face) (get-face 'default))
+ (error "Unable to find global specification"))
+ ;; If no fallback we snoop from default
+ (t (face-property 'default property)))))
+ (copy-specifier fallback-sp 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)
(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)
+(defcustom face-frob-from-locale-first nil
+ "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
+multi-charset environments."
+ :group 'faces
+ :type 'boolean)
+
+(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
(let* ((the-locale (cond ((null locale) 'global)
((valid-specifier-locale-p locale) locale)
(t nil)))
- (specs (and the-locale (face-font face the-locale nil t)))
- (change-it (and specs (cdr (assoc specs standard-face-mapping)))))
+ (spec-list
+ (and
+ the-locale
+ (specifier-spec-list (get (get-face face) 'font) the-locale tags t)))
+ (change-it
+ (and
+ spec-list
+ (cdr (assoc (cdadar spec-list) standard-face-mapping)))))
(if (and change-it
(not (memq (face-name (find-face face))
'(default bold italic bold-italic))))
(progn
(or (equal change-it t)
- (set-face-property face 'font change-it the-locale))
+ (set-face-property face 'font change-it the-locale tags))
(funcall tty-thunk))
(let* ((domain (cond ((null the-locale) nil)
((valid-specifier-domain-p the-locale) the-locale)
(selected-device))
(t nil)))
(inst (and domain (face-property-instance face 'font domain))))
- (funcall tty-thunk)
- (funcall x-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)
- (not (equal inst (face-property-instance face 'font domain)))
- ;; don't do it for standard faces, or you'll get inheritance loops.
- ;; #### This makes XEmacs seg fault! fix this bug.
- (memq (face-name (find-face face))
- '(default bold italic bold-italic))
- (not (equal (face-property-instance face 'font domain)
- (face-property-instance unfrobbed-face 'font domain)))
+ (if (and
+ face-frob-from-locale-first
+ (eq the-locale 'global)
+ domain
+ (equal inst (face-property-instance face 'font domain))
+ ;; don't do it for standard faces, or you'll get inheritance loops.
+ ;; #### This makes XEmacs seg fault! fix this bug.
+ (not (memq (face-name (find-face face))
+ '(default bold italic bold-italic)))
+ (equal (face-property-instance face 'font domain)
+ (face-property-instance unfrobbed-face 'font domain)))
(set-face-property face 'font (vector frobbed-face)
- the-locale))))))
-
-(defun make-face-bold (face &optional locale)
+ the-locale tags)
+ ;; and only otherwise try to build new property value artificially
+ (funcall tty-thunk)
+ (funcall ws-thunk)
+ (and
+ domain
+ (equal inst (face-property-instance face 'font domain))
+ ;; don't do it for standard faces, or you'll get inheritance loops.
+ ;; #### This makes XEmacs seg fault! fix this bug.
+ (not (memq (face-name (find-face face))
+ '(default bold italic bold-italic)))
+ (equal (face-property-instance face 'font domain)
+ (face-property-instance unfrobbed-face 'font domain))
+ (set-face-property face 'font (vector frobbed-face) the-locale tags)))))))
+
+;; WE DEMAND FOUNDRY FROBBING!
+
+;; Family frobbing
+;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
+;; Brainlessly derived from make-face-size by Stephen; don't blame Jan.
+;; I'm long since flown to Rio, it does you little good to blame me, either.
+(defun make-face-family (face family &optional locale tags)
+ "Set FACE's family to FAMILY in LOCALE, if possible.
+
+Add/replace settings specified by TAGS only."
+ (frob-face-property face 'font
+ ;; uses dynamic scope of family
+ #'(lambda (f d)
+ ;; keep the dependency on font.el for now
+ (let ((fo (font-create-object (font-instance-name f)
+ d)))
+ (set-font-family fo family)
+ (font-create-name fo d)))
+ nil locale tags))
+
+;; Style (ie, typographical face) frobbing
+(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
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 window-system specific entries
+ (when (featurep 'gtk)
+ (frob-face-property face 'font 'gtk-make-font-bold
+ '(gtk) locale tags))
(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
+ ;; handle window-system specific entries
+ (when (featurep 'gtk)
+ (frob-face-property face 'font 'gtk-make-font-italic
+ '(gtk) locale tags))
(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
+ ;; handle window-system specific entries
+ (when (featurep 'gtk)
+ (frob-face-property face 'font 'gtk-make-font-bold-italic
+ '(gtk) locale tags))
(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
+ ;; handle window-system specific entries
+ (when (featurep 'gtk)
+ (frob-face-property face 'font 'gtk-make-font-unbold
+ '(gtk) locale tags))
(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
+ ;; handle window-system specific entries
+ (when (featurep 'gtk)
+ (frob-face-property face 'font 'gtk-make-font-unitalic
+ '(gtk) locale tags))
(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)
([bold-italic] . [bold]))))
+;; Size frobbing
+;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
+;; Jan had a separate helper function
+(defun make-face-size (face size &optional locale tags)
+ "Adjust FACE to SIZE in LOCALE, if possible.
+
+Add/replace settings specified by TAGS only."
+ (frob-face-property face 'font
+ ;; uses dynamic scope of size
+ #'(lambda (f d)
+ ;; keep the dependency on font.el for now
+ (let ((fo (font-create-object (font-instance-name f)
+ d)))
+ (set-font-size fo size)
+ (font-create-name fo d)))
+ nil locale tags))
+
;; Why do the following two functions lose so badly in so many
;; circumstances?
(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.
(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."
;; 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."
(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.")
(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"
+have the entries from the new plist and return the new spec."
(mapcar
(lambda (e)
(let ((entries (car e))
(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.
(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))))
+
\f
(defun make-empty-face (name &optional doc-string temporary)
"Like `make-face', but doesn't query the resource database."
;; Then do any device-specific initialization.
(cond ((eq 'x (device-type device))
(x-init-device-faces device))
+ ((eq 'gtk (device-type device))
+ (gtk-init-device-faces device))
((eq 'mswindows (device-type device))
(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
;; Then do any frame-specific initialization.
(cond ((eq 'x (frame-type frame))
(x-init-frame-faces frame))
+ ((eq 'gtk (frame-type frame))
+ (gtk-init-frame-faces frame))
((eq 'mswindows (frame-type frame))
(mswindows-init-frame-faces frame))
;; Is there anything which should be done for TTY's?
(loop for face in (face-list) do
(init-face-from-resources face 'global))
;; Further X frobbing.
- (x-init-global-faces)
+ (and (featurep 'x) (x-init-global-faces))
+ (and (featurep 'gtk) (gtk-init-global-faces))
+
;; for bold and the like, make the global specification be bold etc.
;; if the user didn't already specify a value. These will also be
;; frobbed further in init-other-random-faces.
(defun face-complain-about-font (face device)
(if (symbolp face) (setq face (symbol-name face)))
;; (if (not inhibit-font-complaints)
- (display-warning
- 'font
- (let ((default-name (face-font-name 'default device)))
- (format "%s: couldn't deduce %s %s version of the font
+ ;; complaining for printers is generally annoying.
+ (unless (device-printer-p device)
+ (display-warning
+ 'font
+ (let ((default-name (face-font-name 'default device)))
+ (format "%s: couldn't deduce %s %s version of the font
%S.
Please specify X resources to make the %s face
Emacs.%s.attributeFont: -dt-*-medium-i-*
or
Emacs.%s.attributeForeground: hotpink\n"
- invocation-name
- (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
- face
- default-name
- face
- face
- face
- ))))
+ invocation-name
+ (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
+ face
+ default-name
+ face
+ face
+ face
+ )))))
;; #### This is quite a mess. We should use the custom mechanism for
;; 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
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
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)))
\f
;; Create the remaining standard faces now. This way, packages that we dump
(make-face 'underline "Underlined text.")
(or (face-differs-from-default-p 'underline)
(set-face-underline-p 'underline t 'global '(default)))
-(make-face 'zmacs-region "Used on highlightes region between point and mark.")
+(make-face 'zmacs-region "Used on highlighted 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.")
'global)
(set-face-background-pixmap 'highlight
'(((x default mono) . "gray1")
+ ((gtk default mono) . "gray1")
((mswindows default mono) . "gray1"))
'global)
'global)
(set-face-background-pixmap 'zmacs-region
'(((x default mono) . "gray3")
+ ((gtk default mono) . "gray3")
((mswindows default mono) . "gray3"))
'global)
'(((x default color) . "gray68")
((x default grayscale) . "gray68")
((x default mono) . [default foreground])
+ ((gtk default color) . "gray68")
+ ((gtk default grayscale) . "gray68")
+ ((gtk default mono) . [default foreground])
((mswindows default color) . "gray68")
((mswindows default grayscale) . "gray68")
((mswindows default mono) . [default foreground]))
'global)
(set-face-background-pixmap 'primary-selection
'(((x default mono) . "gray3")
+ ((gtk default mono) . "gray3")
((mswindows default mono) . "gray3"))
'global)
'(((x default color) . "paleturquoise")
((x default color) . "green")
((x default grayscale) . "gray53")
+ ((gtk default color) . "paleturquoise")
+ ((gtk default color) . "green")
+ ((gtk default grayscale) . "gray53")
((mswindows default color) . "paleturquoise")
((mswindows default color) . "green")
((mswindows default grayscale) . "gray53"))
'global)
(set-face-background-pixmap 'secondary-selection
'(((x default mono) . "gray1")
+ ((gtk default mono) . "gray1")
((mswindows default mono) . "gray1"))
'global)
(set-face-background 'isearch
'(((x default color) . "paleturquoise")
((x default color) . "green")
+ ((gtk default color) . "paleturquoise")
+ ((gtk default color) . "green")
((mswindows default color) . "paleturquoise")
((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)
projects / chise / xemacs-chise.git.1 / blobdiff