(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)))))
;; 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))
(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 ws-thunk standard-face-mapping)
;; another kludge to make things more intuitive. If we're
(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 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)
- (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/MSW locales and will set the
(when (featurep 'tty)
(set-face-highlight-p face t locale (cons 'tty tags))))
(lambda ()
- ;; handle X/MS Windows 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
'(x) locale tags))
(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
'(x) locale tags))
(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
'(x) locale tags))
(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
'(x) locale tags))
(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
'(x) locale tags))
([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?
(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
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))))
+ (setq face (wrong-type-argument 'facep face)))
(let ((bitmap-path (ecase (console-type)
(x x-bitmap-file-path)
(mswindows mswindows-bitmap-file-path)))
(and (listp pixmap) (= (length pixmap) 3)))))
(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))))
+ (check-type frame (or null frame))
(set-face-background-pixmap face instantiator frame)))
\f
(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
- nil nil 'warn))
-
- (face-background 'toolbar))))
- (purecopy '("foregroundToolBarColor"
- (or
- (and
- (featurep 'x)
- (x-get-resource "foregroundToolBarColor"
- "ForegroundToolBarColor" 'string
- nil nil 'warn))
- (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