Mercurial > hg > xemacs-beta

comparison lisp/specifier.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents b75b075a9041
children 18c0b5909d16
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
603 ;; 603 ;;
604 ;; (set-face-foreground 'default "black" nil '(x color)) 604 ;; (set-face-foreground 'default "black" nil '(x color))
605 ;; 605 ;;
606 ;; from producing an error if no X support was compiled in. 606 ;; from producing an error if no X support was compiled in.
607 607
608 (or (valid-specifier-tag-p 'x) 608 (loop
609 (define-specifier-tag 'x (lambda (dev) (eq (device-type dev) 'x)))) 609 for tag in '(x tty mswindows msprinter gtk carbon)
610 (or (valid-specifier-tag-p 'tty) 610 do (unless (valid-specifier-tag-p tag)
611 (define-specifier-tag 'tty (lambda (dev) (eq (device-type dev) 'tty)))) 611 (define-specifier-tag tag #'ignore)))
612 (or (valid-specifier-tag-p 'mswindows)
613 (define-specifier-tag 'mswindows (lambda (dev)
614 (eq (device-type dev) 'mswindows))))
615 (or (valid-specifier-tag-p 'gtk)
616 (define-specifier-tag 'gtk (lambda (dev) (eq (device-type dev) 'gtk))))
617 612
618 ;; Add special tag for use by initialization code. Code that 613 ;; Add special tag for use by initialization code. Code that
619 ;; sets up default specs should use this tag. Code that needs to 614 ;; sets up default specs should use this tag. Code that needs to
620 ;; override default specs (e.g. the X resource initialization 615 ;; override default specs (e.g. the X resource initialization
621 ;; code) can safely clear specs with this tag without worrying 616 ;; code) can safely clear specs with this tag without worrying
622 ;; about clobbering user settings. 617 ;; about clobbering user settings.
623 618
624 (define-specifier-tag 'default) 619 (define-specifier-tag 'default)
620
621 ;; The x-resource specifier tag is provide so the X resource initialization
622 ;; code can be overridden by custom without trouble.
623
624 (define-specifier-tag 'x-resource)
625 625
626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
627 ;;; "Heuristic" specifier functions ;;; 627 ;;; "Heuristic" specifier functions ;;;
628 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 628 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
629 629
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))
975 (let ((inst 986 (let ((inst
976 (instance-to-instantiator 987 (instance-to-instantiator
977 (specifier-instance specifier domain)))) 988 (specifier-instance specifier domain))))
978 (list (cons nil inst)))))))))) 989 (list (cons nil inst))))))))))
979 990
991 ;; Character 160 (octal 0240) displays incorrectly under some X
992 ;; installations apparently due to a universally crocked font width
993 ;; specification. Display it as a space since that's what's expected.
994 ;;
995 ;; (make-char-table 'generic) instead of (make-display-table) because
996 ;; make-display-table isn't dumped, and this file is.
997 ;;
998 ;; We also want the global display table to be actually globally
999 ;; initialised; that's why this is here, and not in x-init.el, these days.
1000
1001 (set-specifier current-display-table
1002 #s(char-table type generic data (?\xA0 ?\x20))
1003 'global)
1004
980 ;;; specifier.el ends here 1005 ;;; specifier.el ends here