Mercurial > hg > xemacs-beta

comparison lisp/specifier.el @ 3926:74b10360eef9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2007-04-29 11:15:01 by aidan] Don't try to manipulate XFT fonts on a mswindows device.
author aidan
date Sun, 29 Apr 2007 11:15:04 +0000
parents fd1acd2f457a
children 4f2243a0dc04
comparison
equal deleted inserted replaced
3925:1cc024bd0b7b 3926:74b10360eef9
737 ;; Return DEVTYPE (a devtype) if it matches DEVTYPE-SPEC, else nil. 737 ;; Return DEVTYPE (a devtype) if it matches DEVTYPE-SPEC, else nil.
738 ;; DEVTYPE-SPEC can be nil (all types OK), a device type (only that type 738 ;; DEVTYPE-SPEC can be nil (all types OK), a device type (only that type
739 ;; OK), or `window-system' -- window system device types OK. 739 ;; OK), or `window-system' -- window system device types OK.
740 (cond ((not devtype-spec) devtype) 740 (cond ((not devtype-spec) devtype)
741 ((eq devtype-spec 'window-system) 741 ((eq devtype-spec 'window-system)
742 (and (not (memq devtype '(tty stream))) devtype)) 742 (and (not (memq devtype '(msprinter tty stream))) devtype))
743 (t (and (eq devtype devtype-spec) devtype)))) 743 (t (and (eq devtype devtype-spec) devtype))))
744 744
745 (defun add-tag-to-inst-list (inst-list tag-set) 745 (defun add-tag-to-inst-list (inst-list tag-set)
746 "Add TAG-SET (tag or tag-set) to all tags in INST-LIST." 746 "Add TAG-SET (tag or tag-set) to all tags in INST-LIST."
747 ;; Ah, all is sweetness and light with `loop' 747 ;; Ah, all is sweetness and light with `loop'
813 813
814 (defun derive-device-type-from-tag-set (tag-set &optional try-stages 814 (defun derive-device-type-from-tag-set (tag-set &optional try-stages
815 devtype-spec current-device) 815 devtype-spec current-device)
816 "Given a tag set, try (heuristically) to get a device type from it. 816 "Given a tag set, try (heuristically) to get a device type from it.
817 817
818 There are three stages that this function proceeds through, each one trying 818 If CURRENT-DEVICE is supplied, then this function either returns its type,
819 in the event that it matches TAG-SET, or nil.
820
821 Otherwise, there are three stages that it proceeds through, each one trying
819 harder than the previous to get a value. TRY-STAGES controls how many 822 harder than the previous to get a value. TRY-STAGES controls how many
820 stages to try. If nil or 1, only stage 1 is done; if 2; stages 1 and 2 are 823 stages to try. If nil or 1, only stage 1 is done; if 2; stages 1 and 2 are
821 done; if 3, stages 1-3 are done; if t, all stages are done (currently 1-3). 824 done; if 3, stages 1-3 are done; if t, all stages are done (currently 1-3).
822 825
823 Stage 1 looks at the tags themselves to see if any of them are device-type 826 Stage 1 looks at the tags themselves to see if any of them are device-type
845 DEVTYPE-SPEC flag; thus, it may return nil." 848 DEVTYPE-SPEC flag; thus, it may return nil."
846 (or try-stages (setq try-stages 1)) 849 (or try-stages (setq try-stages 1))
847 (if (eq try-stages t) (setq try-stages 3)) 850 (if (eq try-stages t) (setq try-stages 3))
848 (check-argument-range try-stages 1 3) 851 (check-argument-range try-stages 1 3)
849 (flet ((delete-wrong-type (x) 852 (flet ((delete-wrong-type (x)
850 (delete-if-not 853 (delete-if-not
851 #'(lambda (y) 854 #'(lambda (y)
852 (device-type-matches-spec y devtype-spec)) 855 (device-type-matches-spec y devtype-spec))
853 x))) 856 x)))
854 (let ((both (intersection (device-type-list) 857 (let ((both (intersection
855 (canonicalize-tag-set tag-set)))) 858 (if current-device
859 (list (device-type current-device))
860 (device-type-list))
861 (canonicalize-tag-set tag-set))))
856 ;; shouldn't be more than one (will fail), but whatever 862 ;; shouldn't be more than one (will fail), but whatever
857 (if both (first (delete-wrong-type both)) 863 (if both (first (delete-wrong-type both))
858 (and (>= try-stages 2) 864 (and (>= try-stages 2)
859 ;; no device types mentioned. try the hard way, 865 ;; no device types mentioned. try the hard way,
860 ;; i.e. check each existing device to see if it will 866 ;; i.e. check each existing device (or the
861 ;; pass muster. 867 ;; supplied device) to see if it will pass muster.
862 (let ((okdevs 868 ;;
863 (delete-wrong-type 869 ;; Further checking is not relevant if current-device was
864 (delete-duplicates 870 ;; supplied.
865 (mapcan 871 (not current-device)
866 #'(lambda (dev) 872 (let ((okdevs
867 (and (device-matches-specifier-tag-set-p 873 (delete-wrong-type
868 dev tag-set) 874 (delete-duplicates
869 (list (device-type dev)))) 875 (mapcan
870 (device-list))))) 876 #'(lambda (dev)
871 (devtype (cond ((or (null devtype-spec) 877 (and (device-matches-specifier-tag-set-p
872 (eq devtype-spec 'window-system)) 878 dev tag-set)
873 (let ((dev (derive-domain-from-locale 879 (list (device-type dev))))
874 'global devtype-spec 880 (if current-device
875 current-device))) 881 (list current-device)
876 (and dev (device-type dev)))) 882 (device-list))))))
877 (t devtype-spec)))) 883 (devtype (cond ((or (null devtype-spec)
878 (cond ((= 1 (length okdevs)) (car okdevs)) 884 (eq devtype-spec 'window-system))
879 ((< try-stages 3) nil) 885 (let ((dev (derive-domain-from-locale
880 ((null okdevs) devtype) 886 'global devtype-spec
881 ((memq devtype okdevs) devtype) 887 current-device)))
882 (t (car okdevs))))))))) 888 (and dev (device-type dev))))
889 (t devtype-spec))))
890 (cond ((= 1 (length okdevs)) (car okdevs))
891 ((< try-stages 3) nil)
892 ((null okdevs) devtype)
893 ((memq devtype okdevs) devtype)
894 (t (car okdevs)))))))))
883 895
884 ;; Sheesh, the things you do to get "intuitive" behavior. 896 ;; Sheesh, the things you do to get "intuitive" behavior.
885 (defun derive-device-type-from-locale-and-tag-set (locale tag-set 897 (defun derive-device-type-from-locale-and-tag-set (locale tag-set
886 &optional devtype-spec 898 &optional devtype-spec
887 current-device) 899 current-device)
893 Finally, go back to the tag set and \"try harder\" -- if the selected 905 Finally, go back to the tag set and \"try harder\" -- if the selected
894 device matches the tag set, use its device type, else use some valid device 906 device matches the tag set, use its device type, else use some valid device
895 type from the tag set. 907 type from the tag set.
896 908
897 DEVTYPE-SPEC and CURRENT-DEVICE as in `derive-domain-from-locale'." 909 DEVTYPE-SPEC and CURRENT-DEVICE as in `derive-domain-from-locale'."
898
899 (cond ((valid-specifier-domain-p locale) 910 (cond ((valid-specifier-domain-p locale)
900 ;; if locale is a domain, then it must match DEVTYPE-SPEC, 911 ;; if locale is a domain, then it must match DEVTYPE-SPEC,
901 ;; or we exit immediately with nil. 912 ;; or we exit immediately with nil.
902 (device-type-matches-spec (device-type (dfw-device locale)) 913 (device-type-matches-spec (device-type (dfw-device locale))
903 devtype-spec)) 914 devtype-spec))