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 tags)
+(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."
+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 tags)))
;; otherwise, map over all specifications ...
;; 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)
- temp-sp 'global))
+ (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 (specifier-specs temp-sp locale)))
(error "Property must have a specification in locale %S" locale))
;; Otherwise map frob-face-property-1 over each device.
(result
(if device
- (list (frob-face-property-1 sp-arg 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-arg 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
(setq arg (cons tags arg))
(setcar arg (append tags (delete 'default
(car arg))))))
- (when (and arg (not (member arg new-result)))
+ (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)))
+(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 x-thunk standard-face-mapping)
+ 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 tags))))))
-
+ 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
(when (featurep '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 tags))
+ (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 tags))
+ (frob-face-property face 'font 'mswindows-make-font-bold
+ '(mswindows) locale tags))
)
'(([default] . [bold])
([bold] . t)
(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 tags 'default 'italic
(when (featurep '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 tags))
+ (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 tags))
+ (frob-face-property face 'font 'mswindows-make-font-italic
+ '(mswindows) locale tags))
)
'(([default] . [italic])
([bold] . [bold-italic])
(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 tags 'default 'bold-italic
(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 tags))
+ (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 tags))
+ (frob-face-property face 'font 'mswindows-make-font-bold-italic
+ '(mswindows) locale tags))
)
'(([default] . [italic])
([bold] . [bold-italic])
(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 tags 'bold 'default
(when (featurep '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 tags))
+ (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 tags))
+ (frob-face-property face 'font 'mswindows-make-font-unbold
+ '(mswindows) locale tags))
)
'(([default] . t)
([bold] . [default])
(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 tags 'italic 'default
(when (featurep '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 tags))
+ (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 tags))
+ (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."
(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.
;; 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?
;; 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
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" ""))
- (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
'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)
(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)