Mercurial > hg > xemacs-beta

comparison lisp/specifier.el @ 872:79c6ff3eef26

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[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 943eaba38521
children ec2d1e636272
comparison
equal deleted inserted replaced
871:732270854293 872:79c6ff3eef26
1 ;;; specifier.el --- Lisp interface to specifiers 1 ;;; specifier.el --- Lisp interface to specifiers
2 2
3 ;; Copyright (C) 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996, 2000 Ben Wing. 4 ;; Copyright (C) 1995, 1996, 2000, 2002 Ben Wing.
5 5
6 ;; Author: Ben Wing <ben@xemacs.org> 6 ;; Author: Ben Wing <ben@xemacs.org>
7 ;; Keywords: internal, dumped 7 ;; Keywords: internal, dumped
8 8
9 ;;; Synched up with: Not in FSF. 9 ;;; Synched up with: Not in FSF.
48 (add-spec-list-to-specifier sp spec-list) 48 (add-spec-list-to-specifier sp spec-list)
49 sp)) 49 sp))
50 50
51 ;; God damn, do I hate dynamic scoping. 51 ;; God damn, do I hate dynamic scoping.
52 52
53 (defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg) 53 (defun map-specifier (ms-specifier ms-func &optional ms-locale ms-maparg
54 ms-tag-set ms-exact-p)
54 "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER. 55 "Apply MS-FUNC to the specification(s) for MS-LOCALE in MS-SPECIFIER.
55 56
56 If MS-LOCALE is a locale, MS-FUNC will be called for that locale. 57 If MS-LOCALE is a locale, MS-FUNC will be called for that locale.
57 If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales 58 If MS-LOCALE is a locale type, MS-FUNC will be mapped over all locales
58 of that type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped 59 of that type. If MS-LOCALE is 'all or nil, MS-FUNC will be mapped
59 over all locales in MS-SPECIFIER. 60 over all locales in MS-SPECIFIER.
61
62 MS-TAG-SET and MS-EXACT-P are as in `specifier-spec-list'.
60 63
61 MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale 64 MS-FUNC is called with four arguments: the MS-SPECIFIER, the locale
62 being mapped over, the inst-list for that locale, and the 65 being mapped over, the inst-list for that locale, and the
63 optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil, 66 optional MS-MAPARG. If any invocation of MS-FUNC returns non-nil,
64 the mapping will stop and the returned value becomes the 67 the mapping will stop and the returned value becomes the
65 value returned from `map-specifier'. Otherwise, `map-specifier' 68 value returned from `map-specifier'. Otherwise, `map-specifier'
66 returns nil." 69 returns nil."
67 (let ((ms-specs (specifier-spec-list ms-specifier ms-locale)) 70 (let ((ms-specs (specifier-spec-list ms-specifier ms-locale ms-tag-set
71 ms-exact-p))
68 ms-result) 72 ms-result)
69 (while (and ms-specs (not ms-result)) 73 (while (and ms-specs (not ms-result))
70 (let ((ms-this-spec (car ms-specs))) 74 (let ((ms-this-spec (car ms-specs)))
71 (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec) 75 (setq ms-result (funcall ms-func ms-specifier (car ms-this-spec)
72 (cdr ms-this-spec) ms-maparg)) 76 (cdr ms-this-spec) ms-maparg))
406 (canonicalize-spec-list nval (specifier-type specifier)) 410 (canonicalize-spec-list nval (specifier-type specifier))
407 how-to-add)))) 411 how-to-add))))
408 value) 412 value)
409 413
410 (defun modify-specifier-instances (specifier func &optional args force default 414 (defun modify-specifier-instances (specifier func &optional args force default
411 locale tag-set) 415 locale tag-set)
412 "Modify all specifications that match LOCALE and TAG-SET by FUNC. 416 "Modify all specifications that match LOCALE and TAG-SET by FUNC.
413 417
414 For each specification that exists for SPECIFIER, in locale LOCALE 418 For each specification that exists for SPECIFIER, in locale LOCALE
415 that matches TAG-SET, call the function FUNC with the instance as its 419 that matches TAG-SET, call the function FUNC with the instance as its
416 first argument and with optional arguments ARGS. The result is then 420 first argument and with optional arguments ARGS. The result is then
611 ;; code) can safely clear specs with this tag without worrying 615 ;; code) can safely clear specs with this tag without worrying
612 ;; about clobbering user settings. 616 ;; about clobbering user settings.
613 617
614 (define-specifier-tag 'default) 618 (define-specifier-tag 'default)
615 619
620 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
621 ;;; "Heuristic" specifier functions ;;;
622 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
623
624 ;;; "Heuristic" is a euphemism for kludge. This stuff works well in
625 ;;; practice, though.
626
627 ;;; You might view all the contortions we do here and in Face-frob-property
628 ;;; as indicative of design failures with specifiers, and perhaps you're
629 ;;; right. But in fact almost all code that attempts to interface to
630 ;;; humans and produce "intuitive" results gets messy, particularly with a
631 ;;; system as complicated as specifiers, whose complexity results from an
632 ;;; attempt to work well in many different circumstances. We could create
633 ;;; a much simpler system, but the tradeoff would be that you'd have to
634 ;;; programmatically control all the stuff that gets handled automatically
635 ;;; by setting the right specifiers -- and then things wouldn't "just work"
636 ;;; if the user simultaneously creates a TTY and X device, or X devices on
637 ;;; different types of machines, or wants some buffers to display
638 ;;; differently from others, etc. without a lot of hook functions and other
639 ;;; glue machinery to set everything up. The result would be just as much
640 ;;; complexity, but worse, and much harder to control, since there wouldn't
641 ;;; be any standard framework for managing all these hook functions and the
642 ;;; user would have to be able to write lots of Lisp code to get things
643 ;;; working.
644
645 ;;; The problem is that we have no high-level code, e.g. custom, to make it
646 ;;; easy for the user to control specifiers nicely. The following
647 ;;; lower-level code, though, should make it easier to implement the
648 ;;; high-level code.
649
650 ;;; #### Something like Face-frob-property, but more general, should be
651 ;;; created for general specifier frobbing.
652
653 ;;; #### Other possible extensions to specifiers would be
654 ;;;
655 ;;; (a) the ability to create specifications for particular types of
656 ;;; buffers, e.g. all C-mode buffers one way, all text-mode buffers
657 ;;; another way, etc. Perhaps this should be implemented through hook
658 ;;; functions; but that wouldn't easily allow you to `make-face-bold'
659 ;;; and have it work on these other kinds of specifications. Probably
660 ;;; a better way is to extend the tag mechanism so that it can specify
661 ;;; things other than device types. One way would be to simply allow
662 ;;; tags to have arbitrary elisp attached to them -- a function that
663 ;;; takes a domain and returns whether the attached instantiator
664 ;;; applies. This should be doable given (a) that we now have code to
665 ;;; allow elisp to be run inside a "sandbox", sufficiently protected
666 ;;; that it can even be called from redisplay, and (b) the large amount
667 ;;; of caching we already have, which would minimize the speed hit.
668 ;;; However, this still runs into problems -- (a) it requires
669 ;;; programming to get anything at all done, and (b) you'll get
670 ;;; horrible namespace clashes very quickly. Another possibility to be
671 ;;; used in conjunction with this would be vector tags, with an
672 ;;; extendable mechanism to control their syntax. For example,
673 ;;;
674 ;;; [tag :mode 'c] (buffer in c-mode)
675 ;;; [tag :buffer-name "\\*Help: function"] (help-on-function buffers)
676 ;;; [tag :buffer-coding-system 'japanese-euc] (buffer's coding system is
677 ;;; EUC-JP)
678 ;;; [tag :buffer-file-name "^#.*#$"] (autosave files)
679 ;;; [tag :language-environment "French"] (whenever the global language
680 ;;; environment is French)
681 ;;; [tag :font-height-minimum '(default 12)] (if the height of the default
682 ;;; font is at least 12 pixels
683 ;;; in this domain)
684 ;;;
685 ;;; The general idea is that the properties allowable in a tag vector
686 ;;; are extendable, just by specifying the property name and a function
687 ;;; of two arguments, the property value and the domain, which should
688 ;;; return whether the tag applies. You could imagine very complex
689 ;;; behavior (e.g. combining two tags in a single tag set makes an
690 ;;; `and', and putting the two tags separately with separate (perhaps
691 ;;; identical) instantiators makes an `or'. You could effectively do a
692 ;;; lot of what you might want to do with hooks, but in a much more
693 ;;; controllable fashion. Obviously, much of this complexity wouldn't
694 ;;; necessarily be directly set by the user -- they wouldn't probably
695 ;;; do more than simple tags based on mode, buffer or file name, etc.
696 ;;; But a higher-level interface could easily have various possible
697 ;;; "behaviors" to choose from, implemented using this mechanism.
698 ;;;
699 ;;; #### WE NEED CUSTOM SUPPORT!
700 ;;;
701 ;;; (b) Another possibility is "partial" inheritance. For example --
702 ;;; toolbars and menubars are complex specifications. Currently the
703 ;;; only way to make a change is to copy the entire value and make the
704 ;;; necessary modifications. What we would like instead is to be able
705 ;;; to construct a mini-menubar that says something like "add this menu
706 ;;; here" and combine with everything else. That would require a
707 ;;; slightly different approach to instantiation. Currently it just
708 ;;; searches up the tree from specific to general, looking for a match;
709 ;;; from this match, it generates the instance. Instead, it would
710 ;;; potentially have to record all the matches it found and pass a list
711 ;;; of them to the instantiation function. To implement this, we would
712 ;;; create another specifier method "instantiator_inherits_up", which
713 ;;; looks at the instantiator to determine if it calls for combining
714 ;;; itself with the value higher up. this tells the specifier code
715 ;;; whether to stop now or keep going. It would then pass a Dynarr of
716 ;;; the instantiators to the instantiate method, which might be a
717 ;;; special version, e.g. "instantiate_multi".
718
719 (defun instance-to-instantiator (inst)
720 "Convert an instance to an instantiator.
721 If we have an instance object, we fetch the instantiator that generated the object. Otherwise, we just return the instance."
722 (cond ((font-instance-p inst)
723 (setq inst (font-instance-name inst)))
724 ((color-instance-p inst)
725 (setq inst (color-instance-name inst)))
726 ((image-instance-p inst)
727 (setq inst (image-instance-instantiator inst)))
728 (t inst)))
729
730 (defun device-type-matches-spec (devtype devtype-spec)
731 ;; Return DEVTYPE (a devtype) if it matches DEVTYPE-SPEC, else nil.
732 ;; DEVTYPE-SPEC can be nil (all types OK), a device type (only that type
733 ;; OK), or `window-system' -- window system device types OK.
734 (cond ((not devtype-spec) devtype)
735 ((eq devtype-spec 'window-system)
736 (and (not (memq devtype '(tty stream))) devtype))
737 (t (and (eq devtype devtype-spec) devtype))))
738
739 (defun add-tag-to-inst-list (inst-list tag-set)
740 "Add TAG-SET (tag or tag-set) to all tags in INST-LIST."
741 ;; Ah, all is sweetness and light with `loop'
742 (if (null tag-set) inst-list
743 (loop for (t2 . x2) in inst-list
744 for newt2 = (delete-duplicates
745 (append (if (listp tag-set) tag-set (list tag-set))
746 (if (listp t2) t2 (list t2))))
747 collect (cons newt2 x2))))
748
749 (defun derive-domain-from-locale (locale &optional devtype-spec current-device)
750 "Given a locale, try to derive the \"most reasonable\" domain.
751
752 This is a heuristic \(\"works most of the time\") algorithm.
753
754 \[Remember that, in specifiers, locales are what you attach specifications or
755 \"instantiators\" to, and domains are the contexts in which you can
756 retrieve the value or \"instance\" of the specifier. Not all locales are
757 domains. In particular, buffers are locales but not domains because
758 buffers may be displayed in different windows on different frames, and thus
759 end up with different values if the frames each have a frame-local
760 instantiator and the instantiators are different. However, we may well
761 find ourselves in a situation where we want to figure out the most likely
762 value of a specifier in a buffer -- for example we might conceptually want
763 to make a buffer's modeline face be bold, so we need to figure out what the
764 current face is. If the buffer already has an instantiator, it's easy; but
765 if it doesn't, we want to do something reasonable rather than just issue an
766 error, even though technically the value is not well-defined. We want
767 something that gives the right answer most of the time.]
768
769 LOCALE is a specifier locale -- i.e. a buffer, window, frame, device, the
770 symbol `global', or nil, meaning the same as `global'.
771
772 DEVTYPE-SPEC, if given, can restrict the possible return values to domains
773 on devices of that device type; or if it's `window-system', to domains on
774 window-system devices.
775
776 CURRENT-DEVICE is what should be considered as the \"selected device\" when
777 this value is needed. It defaults to the currently selected device.
778
779 -- If LOCALE is a domain, it's simply returned.
780 -- If LOCALE is `all', `global', or nil, we return CURRENT-DEVICE.
781 -- If LOCALE is a buffer, we use `get-buffer-window' to find a window viewing
782 the buffer, and return it if there is one; otherwise we return the selected
783 window on CURRENT-DEVICE.
784
785 The return value may be nil if the only possible values don't agree with
786 DEVTYPE-SPEC."
787 ;; DEVICE aims to be the selected device, but picks some other
788 ;; device if that won't work. may be nil.
789 (let* ((device (or current-device (selected-device)))
790 (device (if (device-type-matches-spec (device-type device)
791 devtype-spec)
792 device
793 (first
794 (delete-if-not
795 #'(lambda (x)
796 (device-type-matches-spec (device-type x)
797 devtype-spec))
798 (device-list))))))
799 (cond ((memq locale '(all nil global)) device)
800 ((valid-specifier-domain-p locale)
801 (and (device-type-matches-spec (device-type (dfw-device locale))
802 devtype-spec)
803 locale))
804 ((bufferp locale)
805 (let ((win (get-buffer-window locale t devtype-spec)))
806 (or win (and device (selected-window device))))))))
807
808 (defun derive-device-type-from-tag-set (tag-set &optional try-stages
809 devtype-spec current-device)
810 "Given a tag set, try (heuristically) to get a device type from it.
811
812 There are three stages that this function proceeds through, each one trying
813 harder than the previous to get a value. TRY-STAGES controls how many
814 stages to try. If nil or 1, only stage 1 is done; if 2; stages 1 and 2 are
815 done; if 3, stages 1-3 are done; if t, all stages are done (currently 1-3).
816
817 Stage 1 looks at the tags themselves to see if any of them are device-type
818 tags. If so, it returns the device type. If there is more than one device
819 type, this tag can never match anything, but we go ahead and return one of
820 them. If no device types in the tags, we fail.
821
822 Stage 2 runs all devices through the tag set to see if any match, and
823 accumulate a list of device types of all matching devices. If there is
824 exactly one device type in the list, we return it, else fail.
825
826 Stage 3 picks up from where stage 2 left off, and tries hard to return
827 *SOME* device type in all possible situations, modulo the DEVTYPE-SPEC
828 flag. \(DEVTYPE-SPEC and CURRENT-DEVICE are the same as in
829 `derive-domain-from-locale'.)
830
831 Specifically:
832
833 \(a) if no matching devices, return the selected device's type.
834 \(b) if more than device type and the selected device's type is
835 listed, use it.
836 \(c) else, pick one of the device types (currently the first).
837
838 This will never return a device type that's incompatible with the
839 DEVTYPE-SPEC flag; thus, it may return nil."
840 (or try-stages (setq try-stages 1))
841 (if (eq try-stages t) (setq try-stages 3))
842 (check-argument-range try-stages 1 3)
843 (flet ((delete-wrong-type (x)
844 (delete-if-not
845 #'(lambda (y)
846 (device-type-matches-spec y devtype-spec))
847 x)))
848 (let ((both (intersection (device-type-list)
849 (canonicalize-tag-set tag-set))))
850 ;; shouldn't be more than one (will fail), but whatever
851 (if both (first (delete-wrong-type both))
852 (and (>= try-stages 2)
853 ;; no device types mentioned. try the hard way,
854 ;; i.e. check each existing device to see if it will
855 ;; pass muster.
856 (let ((okdevs
857 (delete-wrong-type
858 (delete-duplicates
859 (mapcan
860 #'(lambda (dev)
861 (and (device-matches-specifier-tag-set-p
862 dev tag-set)
863 (list (device-type dev))))
864 (device-list)))))
865 (devtype (cond ((or (null devtype-spec)
866 (eq devtype-spec 'window-system))
867 (let ((dev (derive-domain-from-locale
868 'global devtype-spec
869 current-device)))
870 (and dev (device-type dev))))
871 (t devtype-spec))))
872 (cond ((= 1 (length okdevs)) (car okdevs))
873 ((< try-stages 3) nil)
874 ((null okdevs) devtype)
875 ((memq devtype okdevs) devtype)
876 (t (car okdevs)))))))))
877
878 ;; Sheesh, the things you do to get "intuitive" behavior.
879 (defun derive-device-type-from-locale-and-tag-set (locale tag-set
880 &optional devtype-spec
881 current-device)
882 "Try to derive a device type from a locale and tag set.
883
884 If the locale is a domain, use the domain's device type. Else, if the tag
885 set uniquely specifies a device type, use it. Else, if a buffer is given,
886 find a window visiting the buffer, and if any, use its device type.
887 Finally, go back to the tag set and \"try harder\" -- if the selected
888 device matches the tag set, use its device type, else use some valid device
889 type from the tag set.
890
891 DEVTYPE-SPEC and CURRENT-DEVICE as in `derive-domain-from-locale'."
892
893 (cond ((valid-specifier-domain-p locale)
894 ;; if locale is a domain, then it must match DEVTYPE-SPEC,
895 ;; or we exit immediately with nil.
896 (device-type-matches-spec (device-type (dfw-device locale))
897 devtype-spec))
898 ((derive-device-type-from-tag-set tag-set 2 devtype-spec
899 current-device))
900 ((and (bufferp locale)
901 (let ((win (get-buffer-window locale t devtype-spec)))
902 (and win (device-type (dfw-device win))))))
903 ((derive-device-type-from-tag-set tag-set t devtype-spec
904 current-device))))
905
906 (defun derive-specifier-specs-from-locale (specifier locale
907 &optional devtype-spec
908 current-device
909 global-use-fallback)
910 "Heuristically find the specs of a specifier in a locale.
911
912 This tries to find some reasonable instantiators that are most likely to
913 correspond to the specifier's \"value\" (i.e. instance) in a particular
914 locale, even when the user has not specifically set any such instantiators.
915 This is useful for functions that want to modify the instance of a
916 specifier in a particular locale, and only in that locale.
917
918 Keep in mind that this is a heuristic (i.e. kludge) function, and that it
919 may not always give the right results, since the operation is not
920 technically well-defined in many cases! (See `derive-domain-from-locale'.)
921
922 DEVTYPE-SPEC and CURRENT-DEVICE are as in `derive-domain-from-locale'.
923
924 The return value is an inst-list, i.e.
925
926 ((TAG-SET . INSTANTIATOR) ...)
927
928 More specifically, if there is already a spec in the locale, it's just
929 returned. Otherwise, if LOCALE is `global', `all', or nil: If
930 GLOBAL-USE-FALLBACK is non-nil, the fallback is fetched, and returned, with
931 `default' added to the tag set; else, we use CURRENT-DEVICE (defaulting to
932 the selected device) as a domain and proceed as in the following. If
933 LOCALE is a domain (window, frame, device), the specifier's instance in
934 that domain is computed, and converted back to an instantiator
935 \(`instance-to-instantiator'). Else, if LOCALE is a buffer, we use
936 `derive-domain-from-locale' to heuristically get a likely domain, and
937 proceed as if LOCALE were a domain."
938 (if (memq locale '(all nil)) (setq locale 'global))
939 (let ((current (specifier-spec-list specifier locale)))
940 (if current (cdar current)
941 ;; case 1: a global locale, fallbacks
942 (cond ((and (eq locale 'global) global-use-fallback)
943 ;; if nothing there globally, retrieve the fallback.
944 ;; this is either an inst-list or a specifier. in the
945 ;; latter case, we need to recursively retrieve its
946 ;; fallback.
947 (let (sofar
948 (fallback (specifier-fallback specifier)))
949 (while (specifierp fallback)
950 (setq sofar (nconc sofar
951 (cdar (specifier-spec-list fallback
952 'global))))
953 (setq fallback (specifier-fallback fallback)))
954 (add-tag-to-inst-list (nconc sofar fallback) 'default)))
955 (t
956 (let (domain)
957 ;; case 2: window, frame, device locale
958 (cond ((eq locale 'global)
959 (setq domain (or current-device (selected-device))))
960 ((valid-specifier-domain-p locale)
961 (setq domain locale))
962 ;; case 3: buffer locale
963 ((bufferp locale)
964 (setq domain (derive-domain-from-locale
965 locale devtype-spec current-device)))
966 (t nil))
967 ;; retrieve an instance, convert back to instantiator
968 (when domain
969 (let ((inst
970 (instance-to-instantiator
971 (specifier-instance specifier domain))))
972 (list (cons nil inst))))))))))
973
616 ;;; specifier.el ends here 974 ;;; specifier.el ends here