comparison lisp/faces.el @ 872:79c6ff3eef26

[xemacs-hg @ 2002-06-20 21:18:01 by ben] font changes etc.; some 21.4 changes mule/mule-msw-init-late.el: Specify charset->windows-registry conversion. mule/mule-x-init.el: Delete extra mule font additions here. Put them in faces.c. cl-macs.el: Document better. font-lock.el: Move Lisp function regexp to lisp-mode.el. lisp-mode.el: Various indentation fixes: Handle flet functions better. Handle argument lists in defuns and flets. Handle quoted lists, e.g. property lists -- don't indent like function calls. Distinguish between lambdas and other lists. lisp-mode.el: Handle this form. faces.el, font-menu.el, font.el, gtk-faces.el, msw-faces.el, msw-font-menu.el, x-faces.el, x-init.el: Major overhaul of face-handling code: -- Fix lots of bogus code in msw-faces.el, msw-font-menu.el, font-menu.el that was "truenaming" font specs -- i.e. in the process of frobbing a particular field in a general user-specified font spec with wildcarded fields, sticking in particular values for all the remaining wildcarded fields. This bug was rampant everywhere except in x-faces.el (the oldest and only correctly written code). This also means that we need to work with font names at all times and not font instances, because a font instance is essentially a truenamed font. -- Total rewrite of extremely junky code in msw-faces.el. Work with names as well as font instances, and return names; stop truenaming when canonicalizing and frobbing; fix handling of the combined style field, i.e. weight/slant (also fixed in font.el). -- Totally rewrite the frobbing functions in faces.el. This time, we frob all the instantiators rather than just computing a single instance value and working backwards. That way, e.g., `bold' will work for all charsets that have bold available, rather than only for whatever charset was part of the computed font instance (another example of the truename virus). Also fix up code to look at the fallbacks (all of them) when no global value present, so we don't need to put something in the global value. Intelligently handle a request to frob a buffer locale, rather than signalling an error. When frobbing instantiators, try hard to figure out what device type is associated with them, and frob each according to its own proper device type. Correctly handle inheritance vectors given as instantiators. Preserve existing tags when putting back frobbed instantiators. Extract out general specifier-frobbing code into specifier.el. Document everything cleanly. Do lots of other things better, etc. -- Don't duplicatively set a global specification for the default font -- it's already in the fallback and we no longer need a default global specification present. Delete various code in x-faces.el and msw-faces.el that duplicated the lists of fonts in faces.c. -- init-global-faces was not being called at all under MS Windows! Major bogosity. That caused device-specific values to get stuck into all the fonts, making it very hard to change them -- setting global specs caused nothing to happen. -- Correct weight names in font.el. -- Lots more font fixups in objects*.c. Printer.el: Warning fix. specifier.el: Add more args to map-specifier. Add various "heuristic" specifier functions to aid in creation of specifier-munging code such as in faces.el. subr.el: New functions. lwlib.c: Fix warning. config.inc.samp: Clean up, add args to control fastcall (not yet supported! the changes needed are in another ws of mine), profile support, vc6 support, union-type. xemacs.dsp, xemacs.mak: Semi-major overhaul. Fix bug where dump-id was always getting recomputed, forcing a redump even when nothing changed. Add support for fastcall. Support edit-and-continue (on by default) with vc6. Use incremental linking when doing a debug compilation. Add support for profiling. Consolidate the various debug flags. Partial support for "batch-compiling" -- compiling many files on a single invocation of the compiler. Doesn't seem to help that much for me, so it's not finished or enabled by default. Remove HAVE_MSW_C_DIRED, we always do. Correct some sloppy use of directories. s/cygwin32.h: Allow pdump to work under Cygwin (mmap is broken, so need to undefine HAVE_MMAP). s/win32-common.h, s/windowsnt.h: Support for fastcall. Add WIN32_ANY for identifying all Win32 variants (Cygwin, native, MinGW). Both of these are properly used in another ws. alloc.c, balloon-x.c, buffer.c, bytecode.c, callint.c, cm.c, cmdloop.c, cmds.c, console-gtk.c, console-gtk.h, console-msw.c, console-msw.h, console-stream.c, console-stream.h, console-tty.c, console-tty.h, console-x.c, console-x.h, console.c, console.h, device-gtk.c, device-msw.c, device-tty.c, device-x.c, device.c, device.h, devslots.h, dialog-gtk.c, dialog-msw.c, dialog-x.c, dialog.c, dired-msw.c, editfns.c, emacs.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, event-tty.c, event-unixoid.c, events.c, extents.c, extents.h, faces.c, fileio.c, fns.c, frame-gtk.c, frame-msw.c, frame-tty.c, frame-x.c, frame.c, frame.h, glyphs-eimage.c, glyphs-gtk.c, glyphs-msw.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, gui-gtk.c, gui-msw.c, gui-x.c, gui.c, gutter.c, input-method-xlib.c, intl-encap-win32.c, intl-win32.c, keymap.c, lisp.h, macros.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, menubar.h, minibuf.c, mule-charset.c, nt.c, objects-gtk.c, objects-gtk.h, objects-msw.c, objects-msw.h, objects-tty.c, objects-tty.h, objects-x.c, objects-x.h, objects.c, objects.h, postgresql.c, print.c, process.h, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-tty.c, redisplay-x.c, redisplay.c, redisplay.h, scrollbar-gtk.c, scrollbar-msw.c, scrollbar-x.c, scrollbar.c, select-gtk.c, select-msw.c, select-x.c, select.c, signal.c, sound.c, specifier.c, symbols.c, syntax.c, sysdep.c, syssignal.h, syswindows.h, toolbar-common.c, toolbar-gtk.c, toolbar-msw.c, toolbar-x.c, toolbar.c, unicode.c, window.c, window.h: The following are the major changes made: (1) Separation of various header files into an external and an internal version, similar to the existing separation of process.h and procimpl.h. Eventually this should be done for all Lisp objects. The external version has the same name as currently; the internal adds -impl. The external file has XFOO() macros for objects, but the structure is opaque and defined only in the internal file. It's now reasonable to move all prototypes in lisp.h into the appropriate external file, and this should be done. Currently, separation has been done on extents.h, objects*.h, console.h, device.h, frame.h, and window.h. For c/d/f/w, the most basic properties are available in the external header file, with the macros resolving to functions. In the internal header file, the macros are redefined to directly access the structure. Also, the global MARK_FOO_CHANGED macros have been made into functions so that they can be accessed without needing to include lots of -impl headers -- they are used in almost exclusively in non-time-critical functions, and take up enough time that the function overhead will be negligible. Similarly, the function overhead from making the basic properties mentioned above into functions is negligible, and code that does heavy accessing of c/d/f/w structures inevitably ends up needing the internal header files, anyway. (2) More face changes. -- Major rewrite of objects-msw.c. Now handles wildcard specs properly, rather than "truenaming" (or even worse, signalling an error, which previously happened with some of the fallbacks if you tried to use them in make-font-instance!). -- Split charset matching of fonts into two stages -- one to find a font specifically designed for a particular charset (by examining its registry), the second to find a Unicode font that can support the charset. This needs to proceed as two complete, separate instantiations in order to work properly (otherwise many of the fonts in the HELLO page look wrong). This should also make it easy to support iso10646 (Unicode) fonts under X. -- All default values for fonts are now completely specified in the fallbacks. Stuff from mule-x-init.el has all been moved here, merged with the existing specs, and totally rethought so you get sensible results. (HELLO now looks much better!). -- Generalize the "default X/GTK device" stuff into a per-device-type "default device". -- Add mswindows-{set-}charset-registry. In time, charset<->code-page conversion functions will be removed. -- Wrap protective code around calls to compute device specifier tags, and do this computation before calling the face initialization code because the latter may need these tags to be correctly updated. (3) Other changes. EmacsFrame.c, glyphs-msw.c, eval.c, gui-x.c, intl-encap-win32.c, search.c, signal.c, toolbar-msw.c, unicode.c: Warning fixes. config.h.in: #undefs meant to be frobbed by configure *MUST* go inside of #ifndef WIN32_NO_CONFIGURE, and everything else *MUST* go outside! eval.c: Let detailed backtraces be detailed. specifier.c: Don't override user's print-string-length/print-length settings. glyphs.c: New function image-instance-instantiator. config.h.in, sysdep.c: Changes for fastcall. sysdep.c, nt.c: Fix up a previous botched patch that tried to add support for both EEXIST and EACCES. IF THE BOTCHED PATCH WENT INTO 21.4, THIS FIXUP NEEDS TO GO IN, TOO. search.c: Fix *evil* crash due to incorrect synching of syntax-cache code with 21.1. THIS SHOULD GO INTO 21.4.
author ben
date Thu, 20 Jun 2002 21:19:10 +0000
parents 2b6fa2618f76
children c6facab13185
comparison
equal deleted inserted replaced
871:732270854293 872:79c6ff3eef26
1 ;;; faces.el --- Lisp interface to the C "face" structure 1 ;;; faces.el --- Lisp interface to the C "face" structure
2 2
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois 4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
5 ;; Copyright (C) 1995, 1996 Ben Wing 5 ;; Copyright (C) 1995, 1996, 2002 Ben Wing
6 6
7 ;; Author: Ben Wing <ben@xemacs.org> 7 ;; Author: Ben Wing <ben@xemacs.org>
8 ;; Keywords: faces, internal, dumped 8 ;; Keywords: faces, internal, dumped
9 9
10 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
164 (add-spec-to-specifier new-specifier specifier)) 164 (add-spec-to-specifier new-specifier specifier))
165 (setq specifier new-specifier) 165 (setq specifier new-specifier)
166 (put face property specifier))))) 166 (put face property specifier)))))
167 167
168 (defun face-property-instance (face property 168 (defun face-property-instance (face property
169 &optional domain default no-fallback) 169 &optional domain default no-fallback)
170 "Return the instance of FACE's PROPERTY in the specified DOMAIN. 170 "Return the instance of FACE's PROPERTY in the specified DOMAIN.
171 171
172 Under most circumstances, DOMAIN will be a particular window, 172 Under most circumstances, DOMAIN will be a particular window,
173 and the returned instance describes how the specified property 173 and the returned instance describes how the specified property
174 actually is displayed for that window and the particular buffer 174 actually is displayed for that window and the particular buffer
214 (if (specifierp value) 214 (if (specifierp value)
215 (setq value (specifier-instance value domain default no-fallback))) 215 (setq value (specifier-instance value domain default no-fallback)))
216 value)) 216 value))
217 217
218 (defun face-property-matching-instance (face property matchspec 218 (defun face-property-matching-instance (face property matchspec
219 &optional domain default 219 &optional domain default
220 no-fallback) 220 no-fallback)
221 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. 221 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN.
222 Currently the only useful value for MATCHSPEC is a charset, when used 222 Currently the only useful value for MATCHSPEC is a charset, when used
223 in conjunction with the face's font; this allows you to retrieve a 223 in conjunction with the face's font; this allows you to retrieve a
224 font that can be used to display a particular charset, rather than just 224 font that can be used to display a particular charset, rather than just
225 any font. 225 any font.
229 matching process." 229 matching process."
230 230
231 (setq face (get-face face)) 231 (setq face (get-face face))
232 (let ((value (get face property))) 232 (let ((value (get face property)))
233 (if (specifierp value) 233 (if (specifierp value)
234 (setq value (specifier-matching-instance value matchspec domain 234 (setq value (if (or (charsetp matchspec)
235 default no-fallback))) 235 (and (symbolp matchspec)
236 (find-charset matchspec)))
237 (or
238 (specifier-matching-instance
239 value (cons matchspec nil) domain default
240 no-fallback)
241 (specifier-matching-instance
242 value (cons matchspec t) domain default
243 no-fallback))
244 (specifier-matching-instance value matchspec domain
245 default no-fallback))))
236 value)) 246 value))
237 247
238 (defun set-face-property (face property value &optional locale tag-set 248 (defun set-face-property (face property value &optional locale tag-set
239 how-to-add) 249 how-to-add)
240 "Change a property of FACE. 250 "Change a property of FACE.
241 251
242 NOTE: If you want to remove a property from a face, use `remove-face-property' 252 NOTE: If you want to remove a property from a face, use `remove-face-property'
243 rather than attempting to set a value of nil for the property. 253 rather than attempting to set a value of nil for the property.
244 254
634 644
635 See `face-property-instance' for the semantics of the DOMAIN argument." 645 See `face-property-instance' for the semantics of the DOMAIN argument."
636 (face-property-instance face 'display-table domain default no-fallback)) 646 (face-property-instance face 'display-table domain default no-fallback))
637 647
638 (defun set-face-display-table (face display-table &optional locale tag-set 648 (defun set-face-display-table (face display-table &optional locale tag-set
639 how-to-add) 649 how-to-add)
640 "Change the display table of FACE to DISPLAY-TABLE in LOCALE. 650 "Change the display table of FACE to DISPLAY-TABLE in LOCALE.
641 DISPLAY-TABLE should be a vector as returned by `make-display-table'. 651 DISPLAY-TABLE should be a vector as returned by `make-display-table'.
642 652
643 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 653 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
644 HOW-TO-ADD arguments." 654 HOW-TO-ADD arguments."
653 "Return t if FACE is underlined in DOMAIN. 663 "Return t if FACE is underlined in DOMAIN.
654 See `face-property-instance' for the semantics of the DOMAIN argument." 664 See `face-property-instance' for the semantics of the DOMAIN argument."
655 (face-property-instance face 'underline domain default no-fallback)) 665 (face-property-instance face 'underline domain default no-fallback))
656 666
657 (defun set-face-underline-p (face underline-p &optional locale tag-set 667 (defun set-face-underline-p (face underline-p &optional locale tag-set
658 how-to-add) 668 how-to-add)
659 "Change the underline property of FACE to UNDERLINE-P. 669 "Change the underline property of FACE to UNDERLINE-P.
660 UNDERLINE-P is normally a face-boolean instantiator; see 670 UNDERLINE-P is normally a face-boolean instantiator; see
661 `make-face-boolean-specifier'. 671 `make-face-boolean-specifier'.
662 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 672 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
663 HOW-TO-ADD arguments." 673 HOW-TO-ADD arguments."
668 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN. 678 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN.
669 See `face-property-instance' for the semantics of the DOMAIN argument." 679 See `face-property-instance' for the semantics of the DOMAIN argument."
670 (face-property-instance face 'strikethru domain default no-fallback)) 680 (face-property-instance face 'strikethru domain default no-fallback))
671 681
672 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set 682 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set
673 how-to-add) 683 how-to-add)
674 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. 684 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE.
675 STRIKETHRU-P is normally a face-boolean instantiator; see 685 STRIKETHRU-P is normally a face-boolean instantiator; see
676 `make-face-boolean-specifier'. 686 `make-face-boolean-specifier'.
677 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 687 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
678 HOW-TO-ADD arguments." 688 HOW-TO-ADD arguments."
683 "Return t if FACE is highlighted in DOMAIN (TTY domains only). 693 "Return t if FACE is highlighted in DOMAIN (TTY domains only).
684 See `face-property-instance' for the semantics of the DOMAIN argument." 694 See `face-property-instance' for the semantics of the DOMAIN argument."
685 (face-property-instance face 'highlight domain default no-fallback)) 695 (face-property-instance face 'highlight domain default no-fallback))
686 696
687 (defun set-face-highlight-p (face highlight-p &optional locale tag-set 697 (defun set-face-highlight-p (face highlight-p &optional locale tag-set
688 how-to-add) 698 how-to-add)
689 "Change whether FACE is highlighted in LOCALE (TTY locales only). 699 "Change whether FACE is highlighted in LOCALE (TTY locales only).
690 HIGHLIGHT-P is normally a face-boolean instantiator; see 700 HIGHLIGHT-P is normally a face-boolean instantiator; see
691 `make-face-boolean-specifier'. 701 `make-face-boolean-specifier'.
692 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 702 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
693 HOW-TO-ADD arguments." 703 HOW-TO-ADD arguments."
712 "Return t if FACE is blinking in DOMAIN (TTY domains only). 722 "Return t if FACE is blinking in DOMAIN (TTY domains only).
713 See `face-property-instance' for the semantics of the DOMAIN argument." 723 See `face-property-instance' for the semantics of the DOMAIN argument."
714 (face-property-instance face 'blinking domain default no-fallback)) 724 (face-property-instance face 'blinking domain default no-fallback))
715 725
716 (defun set-face-blinking-p (face blinking-p &optional locale tag-set 726 (defun set-face-blinking-p (face blinking-p &optional locale tag-set
717 how-to-add) 727 how-to-add)
718 "Change whether FACE is blinking in LOCALE (TTY locales only). 728 "Change whether FACE is blinking in LOCALE (TTY locales only).
719 BLINKING-P is normally a face-boolean instantiator; see 729 BLINKING-P is normally a face-boolean instantiator; see
720 `make-face-boolean-specifier'. 730 `make-face-boolean-specifier'.
721 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and 731 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and
722 HOW-TO-ADD arguments." 732 HOW-TO-ADD arguments."
764 ;; x and tty devices. Then, check those properties specific to 774 ;; x and tty devices. Then, check those properties specific to
765 ;; the particular device type. 775 ;; the particular device type.
766 (and (face-equal-loop common-props face1 face2 domain) 776 (and (face-equal-loop common-props face1 face2 domain)
767 (cond ((eq 'tty (device-type device)) 777 (cond ((eq 'tty (device-type device))
768 (face-equal-loop tty-props face1 face2 domain)) 778 (face-equal-loop tty-props face1 face2 domain))
769 ;; #### Why isn't this (console-on-window-system-p (device-console device))? 779 ((console-on-window-system-p (device-console device))
770 ;; #### FIXME!
771 ((or (eq 'x (device-type device))
772 (eq 'gtk (device-type device))
773 (eq 'mswindows (device-type device)))
774 (face-equal-loop win-props face1 face2 domain)) 780 (face-equal-loop win-props face1 face2 domain))
775 (t t))))) 781 (t t)))))
776 782
777 (defun face-differs-from-default-p (face &optional domain) 783 (defun face-differs-from-default-p (face &optional domain)
778 "Return t if FACE will display differently from the default face in DOMAIN. 784 "Return t if FACE will display differently from the default face in DOMAIN.
779 See `face-property-instance' for the semantics of the DOMAIN argument." 785 See `face-property-instance' for the semantics of the DOMAIN argument."
780 (not (face-equal face 'default domain))) 786 (not (face-equal face 'default domain)))
781 787
782 ; moved from x-faces.el
783 (defun try-font-name (name &optional device) 788 (defun try-font-name (name &optional device)
789 "Return NAME if it's a valid font name on DEVICE, else nil."
784 ;; yes, name really should be here twice. 790 ;; yes, name really should be here twice.
785 (and name (make-font-instance name device t) name)) 791 (and name (make-font-instance name device t) name))
786 792
787 793
794
795 (defcustom face-frob-from-locale-first nil
796 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule
797 multi-charset environments."
798 :group 'faces
799 :type 'boolean)
800
788 ;; This function is a terrible, disgusting hack!!!! Need to 801 ;; This function is a terrible, disgusting hack!!!! Need to
789 ;; separate out the font elements as separate face properties! 802 ;; separate out the font elements as separate face properties!
790 803
791 ;; WE DEMAND LEXICAL SCOPING!!! 804 ;; WE DEMAND LEXICAL SCOPING!!!
792 ;; WE DEMAND LEXICAL SCOPING!!! 805 ;; WE DEMAND LEXICAL SCOPING!!!
801 ;; WE DEMAND LEXICAL SCOPING!!! 814 ;; WE DEMAND LEXICAL SCOPING!!!
802 ;; WE DEMAND LEXICAL SCOPING!!! 815 ;; WE DEMAND LEXICAL SCOPING!!!
803 ;; WE DEMAND LEXICAL SCOPING!!! 816 ;; WE DEMAND LEXICAL SCOPING!!!
804 ;; WE DEMAND LEXICAL SCOPING!!! 817 ;; WE DEMAND LEXICAL SCOPING!!!
805 ;; WE DEMAND LEXICAL SCOPING!!! 818 ;; WE DEMAND LEXICAL SCOPING!!!
806 (defun frob-face-property (face property func device-tags &optional 819
807 locale tags) 820 ;; When we are initializing a device, it won't be selected; we communicate
808 "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. 821 ;; the device to consider as selected using this variable.
809 This function is ugly and messy and is primarily used as an internal 822 (defvar Face-frob-property-device-considered-current nil)
810 helper function for `make-face-bold' et al., so you probably don't 823
811 want to use it or read the rest of the documentation. But if you do ... 824 (defun Face-frob-property (face locale tag-set exact-p
812 825 unfrobbed-face frobbed-face
813 FUNC should be a function of two arguments (an instance and a device) 826 win-prop tty-props
814 that returns a modified name that is valid for the given device. 827 frob-mapping standard-face-mapping)
815 If LOCALE specifies a valid domain (i.e. a window, frame, or device), 828 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET
816 this function instantiates the specifier over that domain, applies FUNC 829 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are
817 to the resulting instance, and adds the result back as an instantiator 830 ;; what we expect the original face and the result to look like,
818 for that locale. Otherwise, LOCALE should be a locale, locale type, or 831 ;; respectively. TTY-PROPS is a list of face properties to frob in place
819 'all (defaults to 'all if omitted). For each specification thusly 832 ;; of `font' for TTY's. FROB-MAPPING is either a plist mapping device
820 included: if the locale given is a valid domain, FUNC will be 833 ;; types to functions of two args (NAME DEVICE) that will frob the
821 iterated over all valid instantiators for the device of the domain 834 ;; instantiator as appropriate for the device type (this includes TTY's),
822 until a non-nil result is found (if there is no such result, the 835 ;; or a function to handle the mapping for all device types.
823 first valid instantiator is used), and that result substituted for 836 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance
824 the specification; otherwise, the process just outlined is 837 ;; instantiators to be replaced with other inheritance instantiators, meant
825 iterated over each existing device and the concatenated results 838 ;; for e.g. converting [bold] into [bold-italic].
826 substituted for the specification. 839
827 840 ;; #### it would be nice if this function could be generalized to be
828 DEVICE-TAGS is a list of tags that each device must match in order for 841 ;; a general specifier frobber. but so much of what it does is specific
829 the function to be called on it." 842 ;; to faces -- e.g. handling of inheritance, standard faces,
830 (let ((sp (face-property face property)) 843 ;; special-casing in various ways for tty's, etc. i've already extracted
831 temp-sp) 844 ;; as much of the functionality as i can into subfunctions in the
832 (if (valid-specifier-domain-p locale) 845 ;; heuristic section of specifier.el.
833 ;; this is easy. 846
834 (let* ((inst (face-property-instance face property locale)) 847 ;; #### Note: The old code was totally different (and there was much less
835 (name (and inst 848 ;; of it). It didn't bother with trying to frob all the instantiators,
836 (device-matches-specifier-tag-set-p 849 ;; or handle inheritance vectors as instantiators, or do something
837 (dfw-device locale) device-tags) 850 ;; sensible with buffer locales, or many other things. (It always, or
838 (funcall func inst (dfw-device locale))))) 851 ;; usually, did a specifier-instance and frobbed the result.) But it did
839 (when name 852 ;; do three things we don't:
840 (add-spec-to-specifier sp name locale tags))) 853 ;;
841 ;; otherwise, map over all specifications ... 854 ;; (1) Map over all devices when processing global or buffer locales.
842 ;; but first, some further kludging: 855 ;; Should we be doing this in stages 2 and/or 3? The fact that we
843 ;; (1) if we're frobbing the global property, make sure 856 ;; now process all fallback instantiators seems to make this less
844 ;; that something is there (copy from the default face, 857 ;; necessary, at least for global locales.
845 ;; if necessary). Otherwise, something like 858 ;;
846 ;; (make-face-larger 'modeline) 859 ;; (2) Remove all instantiators tagged with `default' when putting the
847 ;; won't do anything at all if the modeline simply 860 ;; instantiators back. I don't see why this is necessary, but maybe
848 ;; inherits its font from 'default. 861 ;; it is.
849 ;; (2) if we're frobbing a particular locale, nothing would 862 ;;
850 ;; happen if that locale has no instantiators. So signal 863 ;; (3) Pay attention to the face-frob-from-locale-first variable. ####
851 ;; an error to indicate this. 864 ;; I don't understand its purpose. Undocumented hacks like this,
852 865 ;; clearly added after-the-fact, don't deserve to live. DOCUMENT
853 866 ;; THIS SHIT!
854 (setq temp-sp (copy-specifier sp)) 867
855 (if (or (eq locale 'global) (eq locale 'all) (not locale)) 868 (flet
856 (when (not (specifier-specs temp-sp 'global)) 869 (
857 ;; Try fallback via the official ways and then do it "by hand" 870
858 (let* ((fallback (specifier-fallback sp)) 871 ;; non-nil if either instantiator non-nil, or nil instantiators allowed.
859 (fallback-sp 872 (nil-instantiator-ok (inst devtype-spec)
860 (cond ((specifierp fallback) fallback) 873 (or inst (eq devtype-spec 'tty)))
861 ;; just an inst list 874
862 (fallback 875 ;; if LOCALE is a global locale (all, nil, global), return 'global,
863 (make-specifier-and-init (specifier-type sp) 876 ;; else nil.
864 fallback)) 877 (global-locale (locale)
865 ((eq (get-face face) (get-face 'default)) 878 (and (memq locale '(all nil global)) 'global))
866 (error "Unable to find global specification")) 879
867 ;; If no fallback we snoop from default 880 ;; Given a locale and the inst-list from that locale, frob the
868 (t (face-property 'default property))))) 881 ;; instantiators according to FROB-MAPPING, a plist mapping device
869 (copy-specifier fallback-sp temp-sp 'global)))) 882 ;; types to functions that frob instantiators of that device type.
870 (if (and (valid-specifier-locale-p locale) 883 ;; NOTE: TAG-SET and FROB-MAPPING from environment.
871 (not (specifier-specs temp-sp locale))) 884 (frob-face-inst-list (locale inst-list prop devtype-spec)
872 (error "Property must have a specification in locale %S" locale)) 885 (let* ((ffpdev Face-frob-property-device-considered-current)
873 (map-specifier 886 (results
874 temp-sp 887 ;; for each inst-pair, frob it (the result will be 0 or
875 (lambda (sp-arg locale inst-list func) 888 ;; more inst-pairs; we may get more than one if, e.g. the
876 (let* ((device (dfw-device locale)) 889 ;; instantiator specifies inheritance and we expand the
877 ;; if a device can be derived from the locale, 890 ;; inheritance); then nconc the results together
878 ;; call frob-face-property-1 for that device. 891 (loop for (tag-set . x) in inst-list
879 ;; Otherwise map frob-face-property-1 over each device. 892 for devtype = (derive-device-type-from-locale-and-tag-set
880 (result 893 locale tag-set devtype-spec ffpdev)
881 (if device 894 ;; devtype may be nil if it fails to match DEVTYPE-SPEC
882 (list (and (device-matches-specifier-tag-set-p 895 if devtype
883 device device-tags) 896 if (let* ((mapper (if (functionp frob-mapping) frob-mapping
884 (frob-face-property-1 sp-arg device inst-list 897 (plist-get frob-mapping devtype)))
885 func))) 898 (result
886 (mapcar (lambda (device) 899 (cond
887 (and (device-matches-specifier-tag-set-p 900 ;; if a vector ...
888 device device-tags) 901 ((vectorp x)
889 (frob-face-property-1 sp-arg device 902 (let ((change-to
890 inst-list func))) 903 (cdr (assoc x standard-face-mapping))))
891 (device-list)))) 904 (cond
892 new-result) 905 ;; (1) handle standard mappings/null vectors
893 ;; remove duplicates and nils from the obtained list of 906 ((or change-to (null (length x)))
894 ;; instantiators. Also add tags amd remove 'defaults'. 907 (list (cons tag-set
895 (mapcar (lambda (arg) 908 (cond ((eq change-to t) x)
896 (when arg 909 (change-to)
897 (if (not (consp arg)) 910 (t x)))))
898 (setq arg (cons tags arg)) 911 ;; (2) inheritance vectors. retrieve the
899 (setcar arg (append tags (delete 'default 912 ;; inherited value and recursively frob.
900 (car arg)))))) 913 ;; stick the tag-set into the result.
901 (when (and arg (not (member arg new-result))) 914 (t (let*
902 (setq new-result (cons arg new-result)))) 915 ((subprop
903 result) 916 (if (> (length x) 1) (elt x 1)
904 ;; add back in. 917 prop))
905 (add-spec-list-to-specifier sp (list (cons locale new-result))) 918 (subinsts
906 ;; tell map-specifier to keep going. 919 (frob-face-inst-list
907 nil)) 920 locale
908 locale 921 (cdar
909 func)))) 922 (specifier-spec-list
910 923 (face-property (elt x 0)
911 (defun frob-face-property-1 (sp device inst-list func) 924 subprop)))
912 (let 925 subprop devtype-spec)))
913 (first-valid result) 926 ;; #### we don't currently handle
914 (while (and inst-list (not result)) 927 ;; the "reverse the sense" flag on
915 (let* ((inst-pair (car inst-list)) 928 ;; tty inheritance vectors.
916 (tag-set (car inst-pair)) 929 (add-tag-to-inst-list subinsts
917 (sp-inst (specifier-instance-from-inst-list 930 tag-set))))))
918 sp device (list inst-pair)))) 931 ;; (3) not a vector. just process it.
919 (if sp-inst 932 (t
920 (progn 933 (let ((value
921 (if (not first-valid) 934 (if (eq devtype-spec 'tty)
922 (setq first-valid inst-pair)) 935 (funcall mapper x)
923 (setq result (funcall func sp-inst device)) 936 (funcall mapper x
924 (if result 937 (derive-domain-from-locale
925 (setq result (cons tag-set result)))))) 938 locale devtype-spec
926 (setq inst-list (cdr inst-list))) 939 ffpdev)))))
927 (or result first-valid))) 940 (and (nil-instantiator-ok value devtype-spec)
928 941 (list (cons tag-set value))))))))
929 (defcustom face-frob-from-locale-first nil 942 ;; if we're adding to a tty, we need to tag our
930 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule 943 ;; additions with `tty'; see [note 1] below. we leave
931 multi-charset environments." 944 ;; the old spec in place, however -- if e.g. we're
932 :group 'faces 945 ;; italicizing a font that was always set to be
933 :type 'boolean) 946 ;; underlined, even on window systems, then we still
934 947 ;; want the underline there. unless we put the old
935 (defun frob-face-font-2 (face locale tags unfrobbed-face frobbed-face 948 ;; spec back, the underline will disappear, since
936 tty-thunk ws-thunk standard-face-mapping) 949 ;; the new specs are all tagged with `tty'. this
937 ;; another kludge to make things more intuitive. If we're 950 ;; doesn't apply to the [note 1] situations below
938 ;; inheriting from a standard face in this locale, frob the 951 ;; because there we're just adding, not substituting.
939 ;; inheritance as appropriate. Else, if, after the first 952 (if (and (eq 'tty devtype-spec)
940 ;; window-system frobbing pass, the face hasn't changed and still 953 (not (or (eq 'tty tag-set)
941 ;; looks like the standard unfrobbed face (e.g. 'default), make it 954 (memq 'tty tag-set))))
942 ;; inherit from the standard frobbed face (e.g. 'bold). Regardless 955 (nconc (add-tag-to-inst-list result 'tty)
943 ;; of things, do the TTY frobbing. 956 (list (cons tag-set x)))
944 957 result))
945 ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale, 958 nconc it)))
946 ;; but is a "locale, locale-type, or nil for all". So ... do our extra 959 (delete-duplicates results :test #'equal)))
947 ;; frobbing only if it's actually a locale; or for nil, do the frobbing 960
948 ;; on 'global. This specifier stuff needs some rethinking. 961 ;; Frob INST-LIST, which came from LOCALE, and put the new value back
949 (let* ((the-locale (cond ((null locale) 'global) 962 ;; into SP at LOCALE. THUNK is a cons of (PROP . DEVTYPE-SPEC), the
950 ((valid-specifier-locale-p locale) locale) 963 ;; property being processed and whether this is a TTY property or a
951 (t nil))) 964 ;; win property.
952 (spec-list 965 (frob-locale (sp locale inst-list thunk)
953 (and 966 (let ((newinst (frob-face-inst-list locale inst-list
954 the-locale 967 (car thunk) (cdr thunk))))
955 (specifier-spec-list (get (get-face face) 'font) the-locale tags t))) 968 (remove-specifier sp locale tag-set exact-p)
956 (change-it 969 (add-spec-list-to-specifier sp (list (cons locale newinst))))
957 (and 970 ;; map-specifier should keep going
958 spec-list 971 nil)
959 (cdr (assoc (cdadar spec-list) standard-face-mapping))))) 972
960 (if (and change-it 973 ;; map over all specified locales in LOCALE; for each locale,
961 (not (memq (face-name (find-face face)) 974 ;; frob the instantiators in that locale in the specifier in both
962 '(default bold italic bold-italic)))) 975 ;; WIN-PROP and TTY-PROPS in FACE. Takes values from environment.
963 (progn 976 (map-over-locales (locale)
964 (or (equal change-it t) 977 (map-specifier (get face win-prop) #'frob-locale locale
965 (set-face-property face 'font change-it the-locale tags)) 978 (cons win-prop 'window-system)
966 (funcall tty-thunk)) 979 tag-set exact-p)
967 (let* ((domain (cond ((null the-locale) nil) 980 (loop for prop in tty-props do
968 ((valid-specifier-domain-p the-locale) the-locale) 981 (map-specifier (get face prop) #'frob-locale locale
969 ;; OK, this next one is truly a kludge, but 982 (cons prop 'tty)
970 ;; it results in more intuitive behavior most 983 tag-set exact-p)))
971 ;; of the time. (really!) 984
972 ((or (eq the-locale 'global) (eq the-locale 'all)) 985 ;; end of flets
973 (selected-device)) 986 )
974 (t nil))) 987
975 (inst (and domain (face-property-instance face 'font domain)))) 988 ;; the function itself
976 ;; If it's reasonable to do the inherit-from-standard-face trick, 989
977 ;; and it's called for, then do it now. 990 (let* ((ffpdev Face-frob-property-device-considered-current)
978 (if (and 991 (do-later-stages
979 face-frob-from-locale-first 992 (or (global-locale locale)
980 (eq the-locale 'global) 993 (valid-specifier-domain-p locale)
981 domain 994 (bufferp locale)))
982 (equal inst (face-property-instance face 'font domain)) 995 (domain (and do-later-stages
983 ;; don't do it for standard faces, or you'll get inheritance loops. 996 (derive-domain-from-locale locale 'window-system
984 ;; #### This makes XEmacs seg fault! fix this bug. 997 ffpdev)))
985 (not (memq (face-name (find-face face)) 998 (check-differences
986 '(default bold italic bold-italic))) 999 (and unfrobbed-face frobbed-face domain
987 (equal (face-property-instance face 'font domain) 1000 (not (memq (face-name face)
988 (face-property-instance unfrobbed-face 'font domain))) 1001 '(default bold italic bold-italic)))))
989 (set-face-property face 'font (vector frobbed-face) 1002 (orig-instance
990 the-locale tags) 1003 (and check-differences
991 ;; and only otherwise try to build new property value artificially 1004 (face-property-instance face win-prop domain))))
992 (funcall tty-thunk) 1005
993 (funcall ws-thunk) 1006 ;; first do the frobbing
994 (and 1007 (setq face (get-face face))
995 domain 1008 (map-over-locales locale)
996 (equal inst (face-property-instance face 'font domain)) 1009
997 ;; don't do it for standard faces, or you'll get inheritance loops. 1010 (when do-later-stages
998 ;; #### This makes XEmacs seg fault! fix this bug. 1011
999 (not (memq (face-name (find-face face)) 1012 (if (global-locale locale) (setq locale 'global))
1000 '(default bold italic bold-italic))) 1013
1001 (equal (face-property-instance face 'font domain) 1014 ;; now do the second stage -- if there's nothing there, try
1002 (face-property-instance unfrobbed-face 'font domain)) 1015 ;; harder to find an instantiator, and frob it.
1003 (set-face-property face 'font (vector frobbed-face) the-locale tags))))))) 1016 (let (do-something)
1017 (loop for prop in (cons win-prop tty-props)
1018 for propspec = (get face prop)
1019 for devtype-spec = (if (eq prop win-prop) 'window-system 'tty)
1020 if propspec
1021 do
1022 (or (specifier-spec-list propspec locale)
1023 (let ((doit (derive-specifier-specs-from-locale
1024 propspec locale devtype-spec ffpdev
1025 ;; #### does this make sense? When no tags
1026 ;; given, frob the whole list of fallbacks when
1027 ;; global, else just retrieve a current-device
1028 ;; value. this tries to mirror normal practices,
1029 ;; where with no tags you want everything frobbed,
1030 ;; but with a tag you want only the tag frobbed
1031 ;; and hence you probably don't want lots and lots
1032 ;; of items there. (#### Perhaps the best way --
1033 ;; or at least a way with some theoretical
1034 ;; justifiability -- is to fetch the fallbacks
1035 ;; that match the TAG-SET/EXACT-P, and if none,
1036 ;; fall back onto doing the selected-device
1037 ;; trick.)
1038 (and (not tag-set) (not exact-p)))))
1039 (if (and (not doit) (eq locale 'global))
1040 (error
1041 "No fallback for specifier property %s in face %s???"
1042 prop face))
1043 ;; [note 1] whenever we add to a tty property,
1044 ;; make sure we tag our additions with `tty' to
1045 ;; avoid accidentally messing things up on window
1046 ;; systems (e.g. when making things italic we
1047 ;; don't want to set the underline property on
1048 ;; window systems)
1049 (when doit
1050 (add-spec-list-to-specifier
1051 propspec
1052 (list (cons locale
1053 (add-tag-to-inst-list
1054 doit
1055 (append (if (listp tag-set) tag-set
1056 (list tag-set))
1057 (if (eq devtype-spec 'tty) '(tty)))
1058 ))))
1059 (setq do-something t)))))
1060 (when do-something
1061 (map-over-locales (or (global-locale locale) locale))))
1062
1063 ;; then do the third stage -- check for whether we have to do
1064 ;; the inheritance trick.
1065
1066 (when (and check-differences
1067 (let ((new-instance
1068 (face-property-instance face win-prop domain)))
1069 (and
1070 (equal orig-instance new-instance)
1071 (equal orig-instance
1072 (face-property-instance unfrobbed-face win-prop
1073 domain)))))
1074 (set-face-property face win-prop (vector frobbed-face)
1075 (or (global-locale locale) locale) tag-set))))))
1004 1076
1005 ;; WE DEMAND FOUNDRY FROBBING! 1077 ;; WE DEMAND FOUNDRY FROBBING!
1006 1078
1007 ;; Family frobbing 1079 ;; Family frobbing
1008 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> 1080 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1009 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan. 1081 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan.
1010 ;; I'm long since flown to Rio, it does you little good to blame me, either. 1082 ;; I'm long since flown to Rio, it does you little good to blame me, either.
1011 (defun make-face-family (face family &optional locale tags) 1083 (defun make-face-family (face family &optional locale tags exact-p)
1012 "Set FACE's family to FAMILY in LOCALE, if possible. 1084 "Set FACE's family to FAMILY in LOCALE, if possible."
1013 1085 (interactive (list (read-face-name "Set family of which face: ")
1014 Add/replace settings specified by TAGS only." 1086 (read-string "Family to set: ")))
1015 (frob-face-property face 'font 1087
1016 ;; uses dynamic scope of family 1088 (Face-frob-property face locale tags exact-p
1017 #'(lambda (f d) 1089 nil nil 'font nil
1090 `(lambda (f d)
1018 ;; keep the dependency on font.el for now 1091 ;; keep the dependency on font.el for now
1019 (let ((fo (font-create-object (font-instance-name f) 1092 (let ((fo (font-create-object f d)))
1020 d))) 1093 (set-font-family fo ,family)
1021 (set-font-family fo family)
1022 (font-create-name fo d))) 1094 (font-create-name fo d)))
1023 nil locale tags)) 1095 nil))
1024 1096
1025 ;; Style (ie, typographical face) frobbing 1097 ;; Style (ie, typographical face) frobbing
1026 (defun make-face-bold (face &optional locale tags) 1098 (defun make-face-bold (face &optional locale tags exact-p)
1027 "Make FACE bold in LOCALE, if possible. 1099 "Make FACE bold in LOCALE, if possible.
1028 This will attempt to make the font bold for X/MSW locales and will set the 1100 This will attempt to make the font bold for window-system locales and will
1029 highlight flag for TTY locales. 1101 set the highlight flag for TTY locales.
1030 1102
1031 If LOCALE is nil, omitted, or `all', this will attempt to frob all 1103 The actual behavior of this function is somewhat messy, in an attempt to
1032 font specifications for FACE to make them appear bold. Similarly, if 1104 get more intuitive behavior in quite a lot of different circumstances. (You
1033 LOCALE is a locale type, this frobs all font specifications for locales 1105 might view this as indicative of design failures with specifiers, but in
1034 of that type. If LOCALE is a particular locale, what happens depends on 1106 fact almost all code that attempts to interface to humans and produce
1035 what sort of locale is given. If you gave a device, frame, or window, 1107 \"intuitive\" results gets messy, particularly with a system as complicated
1036 then it's always possible to determine what the font actually will be, 1108 as specifiers, whose complexity results from an attempt to work well in
1037 so this is determined and the resulting font is frobbed and added back as a 1109 many different circumstances.)
1038 specification for this locale. If LOCALE is a buffer, however, you can't 1110
1039 determine what the font will actually be unless there's actually a 1111 The meaning of LOCALE is the same as for `specifier-spec-list', i.e.:
1040 specification given for that particular buffer (otherwise, it depends 1112
1041 on what window and frame the buffer appears in, and might not even be 1113 -- If LOCALE is nil, omitted, or `all', this will attempt to \"frob\" all
1042 well-defined if the buffer appears multiple times in different places); 1114 font specifications for FACE to make them appear bold (i.e. the
1043 therefore you will get an error unless there's a specification for the 1115 specifications are replaced with equivalent specifications, where the
1044 buffer. 1116 font names have been changed to the closest bold font).
1045 1117
1046 Finally, in some cases (specifically, when LOCALE is not a locale type), 1118 -- If LOCALE is a locale type \(`buffer', `window', etc.), this frobs all
1047 if the frobbing didn't actually make the font look any different 1119 font specifications for locales of that type.
1048 \(this happens, for example, if your font specification is already bold 1120
1049 or has no bold equivalent), and currently looks like the font of the 1121 -- If LOCALE is a particular locale, this frobs all font specifications for
1050 'default face, it is set to inherit from the 'bold face. This is kludgy 1122 that locale.
1051 but it makes `make-face-bold' have more intuitive behavior in many 1123
1052 circumstances." 1124 If TAGS is given, this only processes instantiators whose tag set includes
1125 all tags mentioned in TAGS. In addition, if EXACT-P is non-nil, only
1126 instantiators whose tag set exactly matches TAGS are processed; otherwise,
1127 additional tags may be present in the instantiator's tag set.
1128
1129 This function proceeeds in three stages.
1130
1131 STAGE 1: Frob the settings that are already present.
1132 STAGE 2: (if called for) Ensure that *some* setting exists in the locale
1133 that was given, finding it in various ways and frobbing it as in
1134 stage 1. This ensures that there is an actual setting for
1135 the locale, so you will get the expected buffer-local/frame-local
1136 behavior -- changes to the global value, to other locales, won't
1137 affect this locale, (b) the face will actually look bold in
1138 the locale.
1139 STAGE 3: (if called for)
1140
1141 The way the frobbing works depends on the device type -- first on whether
1142 or not it's TTY, and second, if it's a window-system device type, on which
1143 particular window-system device type. For locales with a specific device
1144 type, we do the frobbing in the context of that device type -- this means
1145 that for TTY device types we set the highlight flag, and for window-system
1146 device types we modify the font spec according to the rules for font specs
1147 of that device type. For global locales, we may process both the highlight
1148 flag and the font specs (depending on the device types compiled into this
1149 XEmacs). When processing font specs, we check the tag set associated with
1150 each font spec to see if it's specific to a particular device type; if so,
1151 we frob it in the context of that type, else we use the type of the current
1152 device. (A hack, but works well in practice -- and if a new device is
1153 created, we will automatically frob all the standard fonts to make sure
1154 they display OK on that device.)
1155
1156 If LOCALE is not a locale type, and both TAGS and EXACT-P are omitted, we
1157 do further frobbing in an attempt to give more intuitive behavior.
1158
1159 First, if there are no specifications in LOCALE (if LOCALE is `all', we act
1160 as if it were `global' for this step), we do our utmost to put a
1161 specification there; otherwise, this function will have no effect. For
1162 device, frame, or window locales, the face's font is instantiated using the
1163 locale as a domain, and the resulting font is frobbed and added back as a
1164 specification for this locale. If LOCALE is `global', we retrieve the
1165 fallback specs and frob them. If LOCALE is a buffer, things get tricky
1166 since you can't instantiate a specifier in a buffer domain \(the buffer can
1167 appear in multiple places, or in different places over time, so this
1168 operation is not well-defined). We used to signal an error in this case,
1169 but now we instead try to do something logical so that we work somewhat
1170 similarly to buffer-local variables. Specifically, we use
1171 `get-buffer-window' to find a window viewing the buffer, and if there is
1172 one, use this as a domain to instantiate the font, and frob the resulting
1173 value. Otherwise, we use the selected window for the same purpose.
1174
1175 Finally, if the frobbing didn't actually make the font look any different
1176 in whatever domain we instantiated the font in (this happens, for example,
1177 if your font specification is already bold or has no bold equivalent; note
1178 that in this step, we use the selected device in place of `global' or `all'
1179 -- another hack, but works well in practice since there's usually only one
1180 device), and the font currently looks like the font of the `default' face,
1181 it is set to inherit from the `bold' face.
1182
1183 NOTE: For the other functions defined below, the identity of these two
1184 standard faces mentioned in the previous paragraph, and the TTY properties
1185 that are modified, may be different, and whether the TTY property or
1186 properties are set or unset may be different. For example, for
1187 `make-face-unitalic', the last sentence in the previous paragraph would
1188 read \"... and the font currently looks like the font of the `italic' face,
1189 it is set to inherit from the `default' face.\", and the second sentence in
1190 the first paragraph would read \"This will attempt to make the font
1191 non-italic for window-system locales and will unset the underline flag for
1192 TTY locales.\"
1193
1194 Here's a table indicating the behavior differences with the different
1195 functions:
1196
1197 function face1 face2 tty-props tty-val
1198 ----------------------------------------------------------------------------
1199 make-face-bold default bold highlight t
1200 make-face-italic default italic underline t
1201 make-face-bold-italic default bold-italic highlight,underline t
1202 make-face-unbold bold default highlight nil
1203 make-face-unitalic italic default underline nil
1204 "
1053 (interactive (list (read-face-name "Make which face bold: "))) 1205 (interactive (list (read-face-name "Make which face bold: ")))
1054 (frob-face-font-2 1206 (Face-frob-property face locale tags exact-p
1055 face locale tags 'default 'bold 1207 'default 'bold 'font '(highlight)
1056 (lambda () 1208 '(tty (lambda (x) t)
1057 ;; handle TTY specific entries 1209 x x-make-font-bold
1058 (when (featurep 'tty) 1210 gtk gtk-make-font-bold
1059 (set-face-highlight-p face t locale (cons 'tty tags)))) 1211 mswindows mswindows-make-font-bold
1060 (lambda () 1212 msprinter mswindows-make-font-bold)
1061 ;; handle window-system specific entries 1213 '(([default] . [bold])
1062 (when (featurep 'gtk) 1214 ([bold] . t)
1063 (frob-face-property face 'font 'gtk-make-font-bold 1215 ([italic] . [bold-italic])
1064 '(gtk) locale tags)) 1216 ([bold-italic] . t))))
1065 (when (featurep 'x) 1217
1066 (frob-face-property face 'font 'x-make-font-bold 1218 (defun make-face-italic (face &optional locale tags exact-p)
1067 '(x) locale tags))
1068 (when (featurep 'mswindows)
1069 (frob-face-property face 'font 'mswindows-make-font-bold
1070 '(mswindows) locale tags)
1071 (frob-face-property face 'font 'mswindows-make-font-bold
1072 '(msprinter) locale tags))
1073 )
1074 '(([default] . [bold])
1075 ([bold] . t)
1076 ([italic] . [bold-italic])
1077 ([bold-italic] . t))))
1078
1079 (defun make-face-italic (face &optional locale tags)
1080 "Make FACE italic in LOCALE, if possible. 1219 "Make FACE italic in LOCALE, if possible.
1081 This will attempt to make the font italic for X/MS Windows locales and 1220 This will attempt to make the font italic for X/MS Windows locales and
1082 will set the underline flag for TTY locales. See `make-face-bold' for 1221 will set the underline flag for TTY locales. See `make-face-bold' for
1083 the semantics of the LOCALE argument and for more specifics on exactly 1222 the semantics of the LOCALE argument and for more specifics on exactly
1084 how this function works." 1223 how this function works."
1085 (interactive (list (read-face-name "Make which face italic: "))) 1224 (interactive (list (read-face-name "Make which face italic: ")))
1086 (frob-face-font-2 1225 (Face-frob-property face locale tags exact-p
1087 face locale tags 'default 'italic 1226 'default 'italic 'font '(underline)
1088 (lambda () 1227 '(tty (lambda (x) t)
1089 ;; handle TTY specific entries 1228 x x-make-font-italic
1090 (when (featurep 'tty) 1229 gtk gtk-make-font-italic
1091 (set-face-underline-p face t locale (cons 'tty tags)))) 1230 mswindows mswindows-make-font-italic
1092 (lambda () 1231 msprinter mswindows-make-font-italic)
1093 ;; handle window-system specific entries 1232 '(([default] . [italic])
1094 (when (featurep 'gtk) 1233 ([bold] . [bold-italic])
1095 (frob-face-property face 'font 'gtk-make-font-italic 1234 ([italic] . t)
1096 '(gtk) locale tags)) 1235 ([bold-italic] . t))))
1097 (when (featurep 'x) 1236
1098 (frob-face-property face 'font 'x-make-font-italic 1237 (defun make-face-bold-italic (face &optional locale tags exact-p)
1099 '(x) locale tags))
1100 (when (featurep 'mswindows)
1101 (frob-face-property face 'font 'mswindows-make-font-italic
1102 '(mswindows) locale tags)
1103 (frob-face-property face 'font 'mswindows-make-font-italic
1104 '(msprinter) locale tags))
1105 )
1106 '(([default] . [italic])
1107 ([bold] . [bold-italic])
1108 ([italic] . t)
1109 ([bold-italic] . t))))
1110
1111 (defun make-face-bold-italic (face &optional locale tags)
1112 "Make FACE bold and italic in LOCALE, if possible. 1238 "Make FACE bold and italic in LOCALE, if possible.
1113 This will attempt to make the font bold-italic for X/MS Windows 1239 This will attempt to make the font bold-italic for X/MS Windows
1114 locales and will set the highlight and underline flags for TTY 1240 locales and will set the highlight and underline flags for TTY
1115 locales. See `make-face-bold' for the semantics of the LOCALE 1241 locales. See `make-face-bold' for the semantics of the LOCALE
1116 argument and for more specifics on exactly how this function works." 1242 argument and for more specifics on exactly how this function works."
1117 (interactive (list (read-face-name "Make which face bold-italic: "))) 1243 (interactive (list (read-face-name "Make which face bold-italic: ")))
1118 (frob-face-font-2 1244 (Face-frob-property face locale tags exact-p
1119 face locale tags 'default 'bold-italic 1245 'default 'bold-italic 'font '(underline highlight)
1120 (lambda () 1246 '(tty (lambda (x) t)
1121 ;; handle TTY specific entries 1247 x x-make-font-bold-italic
1122 (when (featurep 'tty) 1248 gtk gtk-make-font-bold-italic
1123 (set-face-highlight-p face t locale (cons 'tty tags)) 1249 mswindows mswindows-make-font-bold-italic
1124 (set-face-underline-p face t locale (cons 'tty tags)))) 1250 msprinter mswindows-make-font-bold-italic)
1125 (lambda () 1251 '(([default] . [italic])
1126 ;; handle window-system specific entries 1252 ([bold] . [bold-italic])
1127 (when (featurep 'gtk) 1253 ([italic] . [bold-italic])
1128 (frob-face-property face 'font 'gtk-make-font-bold-italic 1254 ([bold-italic] . t))))
1129 '(gtk) locale tags)) 1255
1130 (when (featurep 'x) 1256
1131 (frob-face-property face 'font 'x-make-font-bold-italic 1257 (defun make-face-unbold (face &optional locale tags exact-p)
1132 '(x) locale tags))
1133 (when (featurep 'mswindows)
1134 (frob-face-property face 'font 'mswindows-make-font-bold-italic
1135 '(mswindows) locale tags)
1136 (frob-face-property face 'font 'mswindows-make-font-bold-italic
1137 '(msprinter) locale tags))
1138 )
1139 '(([default] . [italic])
1140 ([bold] . [bold-italic])
1141 ([italic] . [bold-italic])
1142 ([bold-italic] . t))))
1143
1144 (defun make-face-unbold (face &optional locale tags)
1145 "Make FACE non-bold in LOCALE, if possible. 1258 "Make FACE non-bold in LOCALE, if possible.
1146 This will attempt to make the font non-bold for X/MS Windows locales 1259 This will attempt to make the font non-bold for X/MS Windows locales
1147 and will unset the highlight flag for TTY locales. See 1260 and will unset the highlight flag for TTY locales. See
1148 `make-face-bold' for the semantics of the LOCALE argument and for more 1261 `make-face-bold' for the semantics of the LOCALE argument and for more
1149 specifics on exactly how this function works." 1262 specifics on exactly how this function works."
1150 (interactive (list (read-face-name "Make which face non-bold: "))) 1263 (interactive (list (read-face-name "Make which face non-bold: ")))
1151 (frob-face-font-2 1264 (Face-frob-property face locale tags exact-p
1152 face locale tags 'bold 'default 1265 'bold 'default 'font '(highlight)
1153 (lambda () 1266 '(tty (lambda (x) nil)
1154 ;; handle TTY specific entries 1267 x x-make-font-unbold
1155 (when (featurep 'tty) 1268 gtk gtk-make-font-unbold
1156 (set-face-highlight-p face nil locale (cons 'tty tags)))) 1269 mswindows mswindows-make-font-unbold
1157 (lambda () 1270 msprinter mswindows-make-font-unbold)
1158 ;; handle window-system specific entries 1271 '(([default] . t)
1159 (when (featurep 'gtk) 1272 ([bold] . [default])
1160 (frob-face-property face 'font 'gtk-make-font-unbold 1273 ([italic] . t)
1161 '(gtk) locale tags)) 1274 ([bold-italic] . [italic]))))
1162 (when (featurep 'x) 1275
1163 (frob-face-property face 'font 'x-make-font-unbold 1276 (defun make-face-unitalic (face &optional locale tags exact-p)
1164 '(x) locale tags))
1165 (when (featurep 'mswindows)
1166 (frob-face-property face 'font 'mswindows-make-font-unbold
1167 '(mswindows) locale tags)
1168 (frob-face-property face 'font 'mswindows-make-font-unbold
1169 '(msprinter) locale tags))
1170 )
1171 '(([default] . t)
1172 ([bold] . [default])
1173 ([italic] . t)
1174 ([bold-italic] . [italic]))))
1175
1176 (defun make-face-unitalic (face &optional locale tags)
1177 "Make FACE non-italic in LOCALE, if possible. 1277 "Make FACE non-italic in LOCALE, if possible.
1178 This will attempt to make the font non-italic for X/MS Windows locales 1278 This will attempt to make the font non-italic for X/MS Windows locales
1179 and will unset the underline flag for TTY locales. See 1279 and will unset the underline flag for TTY locales. See
1180 `make-face-bold' for the semantics of the LOCALE argument and for more 1280 `make-face-bold' for the semantics of the LOCALE argument and for more
1181 specifics on exactly how this function works." 1281 specifics on exactly how this function works."
1182 (interactive (list (read-face-name "Make which face non-italic: "))) 1282 (interactive (list (read-face-name "Make which face non-italic: ")))
1183 (frob-face-font-2 1283 (Face-frob-property face locale tags exact-p
1184 face locale tags 'italic 'default 1284 'italic 'default 'font '(underline)
1185 (lambda () 1285 '(tty (lambda (x) nil)
1186 ;; handle TTY specific entries 1286 x x-make-font-unitalic
1187 (when (featurep 'tty) 1287 gtk gtk-make-font-unitalic
1188 (set-face-underline-p face nil locale (cons 'tty tags)))) 1288 mswindows mswindows-make-font-unitalic
1189 (lambda () 1289 msprinter mswindows-make-font-unitalic)
1190 ;; handle window-system specific entries 1290 '(([default] . t)
1191 (when (featurep 'gtk) 1291 ([bold] . t)
1192 (frob-face-property face 'font 'gtk-make-font-unitalic 1292 ([italic] . [default])
1193 '(gtk) locale tags)) 1293 ([bold-italic] . [bold]))))
1194 (when (featurep 'x)
1195 (frob-face-property face 'font 'x-make-font-unitalic
1196 '(x) locale tags))
1197 (when (featurep 'mswindows)
1198 (frob-face-property face 'font 'mswindows-make-font-unitalic
1199 '(mswindows) locale tags)
1200 (frob-face-property face 'font 'mswindows-make-font-unitalic
1201 '(msprinter) locale tags))
1202 )
1203 '(([default] . t)
1204 ([bold] . t)
1205 ([italic] . [default])
1206 ([bold-italic] . [bold]))))
1207 1294
1208 1295
1209 ;; Size frobbing 1296 ;; Size frobbing
1210 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> 1297 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
1211 ;; Jan had a separate helper function 1298 ;; Jan had a separate helper function
1212 (defun make-face-size (face size &optional locale tags) 1299 (defun make-face-size (face size &optional locale tags exact-p)
1213 "Adjust FACE to SIZE in LOCALE, if possible. 1300 "Adjust FACE to SIZE in LOCALE, if possible."
1214 1301 (interactive (list (read-face-name "Set size of which face: ")
1215 Add/replace settings specified by TAGS only." 1302 (read-number "Size to set: " t 10)))
1216 (frob-face-property face 'font 1303 (Face-frob-property face locale tags exact-p
1217 ;; uses dynamic scope of size 1304 nil nil 'font nil
1218 #'(lambda (f d) 1305 `(lambda (f d)
1219 ;; keep the dependency on font.el for now 1306 ;; keep the dependency on font.el for now
1220 (let ((fo (font-create-object (font-instance-name f) 1307 (let ((fo (font-create-object f d)))
1221 d))) 1308 (set-font-size fo ,size)
1222 (set-font-size fo size) 1309 (font-create-name fo d)))
1223 (font-create-name fo d))) 1310 nil))
1224 nil locale tags))
1225 1311
1226 ;; Why do the following two functions lose so badly in so many 1312 ;; Why do the following two functions lose so badly in so many
1227 ;; circumstances? 1313 ;; circumstances?
1228 1314
1229 (defun make-face-smaller (face &optional locale) 1315 (defun make-face-smaller (face &optional locale tags exact-p)
1230 "Make the font of FACE be smaller, if possible. 1316 "Make the font of FACE be smaller, if possible.
1231 LOCALE works as in `make-face-bold' et al., but the ``inheriting- 1317 LOCALE works as in `make-face-bold' et al., but the ``inheriting-
1232 from-the-bold-face'' operations described there are not done 1318 from-the-bold-face'' operations described there are not done
1233 because they don't make sense in this context." 1319 because they don't make sense in this context."
1234 (interactive (list (read-face-name "Shrink which face: "))) 1320 (interactive (list (read-face-name "Shrink which face: ")))
1235 ;; handle X specific entries 1321 (Face-frob-property face locale tags exact-p
1236 (when (featurep 'x) 1322 nil nil 'font nil
1237 (frob-face-property face 'font 'x-find-smaller-font 1323 '(x x-find-smaller-font
1238 '(x) locale)) 1324 gtk gtk-find-smaller-font
1239 (when (featurep 'mswindows) 1325 mswindows mswindows-find-smaller-font
1240 (frob-face-property face 'font 'mswindows-find-smaller-font 1326 msprinter mswindows-find-smaller-font)
1241 '(mswindows) locale) 1327 nil))
1242 (frob-face-property face 'font 'mswindows-find-smaller-font 1328
1243 '(msprinter) locale))) 1329 (defun make-face-larger (face &optional locale tags exact-p)
1244
1245 (defun make-face-larger (face &optional locale)
1246 "Make the font of FACE be larger, if possible. 1330 "Make the font of FACE be larger, if possible.
1247 See `make-face-smaller' for the semantics of the LOCALE argument." 1331 See `make-face-smaller' for the semantics of the LOCALE argument."
1248 (interactive (list (read-face-name "Enlarge which face: "))) 1332 (interactive (list (read-face-name "Enlarge which face: ")))
1249 ;; handle X specific entries 1333 (Face-frob-property face locale tags exact-p
1250 (when (featurep 'x) 1334 nil nil 'font nil
1251 (frob-face-property face 'font 'x-find-larger-font 1335 '(x x-find-larger-font
1252 '(x) locale)) 1336 gtk gtk-find-larger-font
1253 (when (featurep 'mswindows) 1337 mswindows mswindows-find-larger-font
1254 (frob-face-property face 'font 'mswindows-find-larger-font 1338 msprinter mswindows-find-larger-font)
1255 '(mswindows) locale) 1339 nil))
1256 (frob-face-property face 'font 'mswindows-find-larger-font
1257 '(msprinter) locale)))
1258 1340
1259 (defun invert-face (face &optional locale) 1341 (defun invert-face (face &optional locale)
1260 "Swap the foreground and background colors of the face." 1342 "Swap the foreground and background colors of the face."
1261 (interactive (list (read-face-name "Invert face: "))) 1343 (interactive (list (read-face-name "Invert face: ")))
1262 (if (valid-specifier-domain-p locale) 1344 (if (valid-specifier-domain-p locale)
1318 (let* ((color-instance (face-background-instance 'default frame)) 1400 (let* ((color-instance (face-background-instance 'default frame))
1319 (mode (condition-case nil 1401 (mode (condition-case nil
1320 (if (< (apply '+ (color-instance-rgb-components 1402 (if (< (apply '+ (color-instance-rgb-components
1321 color-instance)) 65536) 1403 color-instance)) 65536)
1322 'dark 'light) 1404 'dark 'light)
1323 ;; Here, we get an error on a TTY. As we don't have 1405 ;; Here, we get an error on a TTY (Return value from
1324 ;; a good way of detecting whether a TTY is light or 1406 ;; color-instance-rgb-components is nil), and on the
1325 ;; dark, we'll guess it's dark. 1407 ;; initial stream device (Return value from
1408 ;; face-background-instance is nil). As we don't have a
1409 ;; good way of detecting whether a TTY is light or dark,
1410 ;; we'll guess it's dark.
1326 (error 'dark)))) 1411 (error 'dark))))
1327 (set-frame-property frame 'background-mode mode) 1412 (set-frame-property frame 'background-mode mode)
1328 mode)) 1413 mode))
1329 1414
1330 (defun extract-custom-frame-properties (frame) 1415 (defun extract-custom-frame-properties (frame)
1585 ((eq 'mswindows (frame-type frame)) 1670 ((eq 'mswindows (frame-type frame))
1586 (declare-fboundp (mswindows-init-frame-faces frame))) 1671 (declare-fboundp (mswindows-init-frame-faces frame)))
1587 ;; Is there anything which should be done for TTY's? 1672 ;; Is there anything which should be done for TTY's?
1588 ))) 1673 )))
1589 1674
1590 ;; #### This is somewhat X-specific, and is called when the first 1675 ;; Called when the first device created.
1591 ;; X device is created (even if there were TTY devices created 1676
1592 ;; beforehand). The concept of resources has not been generalized 1677 (defun init-global-faces (device)
1593 ;; outside of X-specificness, so we have to live with this 1678 (let ((Face-frob-property-device-considered-current device))
1594 ;; breach of device-independence. 1679 ;; Look for global face resources.
1595 1680 (loop for face in (face-list) do
1596 (defun init-global-faces () 1681 (init-face-from-resources face 'global))
1597 ;; Look for global face resources. 1682 ;; Further frobbing.
1598 (loop for face in (face-list) do 1683 (and (featurep 'x) (declare-fboundp (x-init-global-faces)))
1599 (init-face-from-resources face 'global)) 1684 (and (featurep 'gtk) (declare-fboundp (gtk-init-global-faces)))
1600 ;; Further X frobbing. 1685 (and (featurep 'mswindows) (declare-fboundp (mswindows-init-global-faces)))
1601 (and (featurep 'x) (declare-fboundp (x-init-global-faces))) 1686
1602 (and (featurep 'gtk) (declare-fboundp (gtk-init-global-faces))) 1687 ;; for bold and the like, make the global specification be bold etc.
1603 (and (featurep 'mswindows) (declare-fboundp (mswindows-init-global-faces))) 1688 ;; if the user didn't already specify a value. These will also be
1604 1689 ;; frobbed further in init-other-random-faces.
1605 ;; for bold and the like, make the global specification be bold etc. 1690 (unless (face-font 'bold 'global)
1606 ;; if the user didn't already specify a value. These will also be 1691 (make-face-bold 'bold 'global))
1607 ;; frobbed further in init-other-random-faces. 1692 ;;
1608 (unless (face-font 'bold 'global) 1693 (unless (face-font 'italic 'global)
1609 (make-face-bold 'bold 'global)) 1694 (make-face-italic 'italic 'global))
1610 ;; 1695 ;;
1611 (unless (face-font 'italic 'global)
1612 (make-face-italic 'italic 'global))
1613 ;;
1614 (unless (face-font 'bold-italic 'global)
1615 (make-face-bold-italic 'bold-italic 'global)
1616 (unless (face-font 'bold-italic 'global) 1696 (unless (face-font 'bold-italic 'global)
1617 (copy-face 'bold 'bold-italic) 1697 (make-face-bold-italic 'bold-italic 'global)
1618 (make-face-italic 'bold-italic))) 1698 (unless (face-font 'bold-italic 'global)
1619 1699 (copy-face 'bold 'bold-italic)
1620 (when (face-equal 'bold 'bold-italic) 1700 (make-face-italic 'bold-italic)))
1621 (copy-face 'italic 'bold-italic) 1701
1622 (make-face-bold 'bold-italic)) 1702 (when (face-equal 'bold 'bold-italic device)
1623 ;; 1703 (copy-face 'italic 'bold-italic)
1624 ;; Nothing more to be done for X or TTY's? 1704 (make-face-bold 'bold-italic))))
1625 )
1626 1705
1627 1706
1628 ;; These warnings are there for a reason. Just specify your fonts 1707 ;; These warnings are there for a reason. Just specify your fonts
1629 ;; correctly. Deal with it. Additionally, one can use 1708 ;; correctly. Deal with it. Additionally, one can use
1630 ;; `log-warning-minimum-level' instead of this. 1709 ;; `log-warning-minimum-level' instead of this.