X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffaces.el;h=a4f56eadda4bff5ac38cdaf92dcc3939e6398754;hb=8ccf542c980645ba3c02074a8bc67cd4fc8e7a1f;hp=953025b35c1ade4d484a66fcd80725ea771d34de;hpb=98a6e4055a1fa624c592ac06f79287d55196ca37;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/faces.el b/lisp/faces.el index 953025b..a4f56ea 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -761,7 +761,10 @@ See `face-property-instance' for the semantics of the DOMAIN argument." (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))))) @@ -844,10 +847,21 @@ the function to be called on it." (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)) @@ -907,6 +921,12 @@ the function to be called on it." (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 @@ -924,14 +944,20 @@ the function to be called on it." (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) @@ -942,21 +968,56 @@ the function to be called on it." (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 @@ -992,7 +1053,10 @@ circumstances." (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)) @@ -1019,7 +1083,10 @@ how this function works." (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)) @@ -1047,7 +1114,10 @@ argument and for more specifics on exactly how this function works." (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)) @@ -1074,7 +1144,10 @@ specifics on exactly how this function works." (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)) @@ -1101,7 +1174,10 @@ specifics on exactly how this function works." (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)) @@ -1115,6 +1191,23 @@ specifics on exactly how this function works." ([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? @@ -1451,6 +1544,8 @@ and 'global)." ;; 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? @@ -1466,6 +1561,8 @@ and 'global)." ;; 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? @@ -1482,7 +1579,9 @@ and 'global)." (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. @@ -1515,10 +1614,12 @@ and 'global)." (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 @@ -1528,14 +1629,14 @@ For example, you could add one of the following to $HOME/Emacs: 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 @@ -1636,7 +1737,7 @@ expected in this case, other types of image data will not work. If the optional FRAME argument is provided, change only in that frame; otherwise change each frame." (while (not (find-face face)) - (setq face (signal 'wrong-type-argument (list 'facep face)))) + (setq face (wrong-type-argument 'facep face))) (let ((bitmap-path (ecase (console-type) (x x-bitmap-file-path) (mswindows mswindows-bitmap-file-path))) @@ -1661,8 +1762,7 @@ in that frame; otherwise change each frame." (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))) @@ -1678,7 +1778,7 @@ in that frame; otherwise change each frame." (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 @@ -1712,6 +1812,7 @@ in that frame; otherwise change each frame." 'global) (set-face-background-pixmap 'highlight '(((x default mono) . "gray1") + ((gtk default mono) . "gray1") ((mswindows default mono) . "gray1")) 'global) @@ -1723,6 +1824,7 @@ in that frame; otherwise change each frame." 'global) (set-face-background-pixmap 'zmacs-region '(((x default mono) . "gray3") + ((gtk default mono) . "gray3") ((mswindows default mono) . "gray3")) 'global) @@ -1730,6 +1832,9 @@ in that frame; otherwise change each frame." '(((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])) @@ -1747,6 +1852,7 @@ in that frame; otherwise change each frame." 'global) (set-face-background-pixmap 'primary-selection '(((x default mono) . "gray3") + ((gtk default mono) . "gray3") ((mswindows default mono) . "gray3")) 'global) @@ -1754,18 +1860,24 @@ in that frame; otherwise change each frame." '(((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)