Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents 6240c7796c7a
children aabb7f5b1c81
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
30 ;;; The emacsen compatibility package - load it up before anything else 30 ;;; The emacsen compatibility package - load it up before anything else
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (require 'cl) 32 (require 'cl)
33 33
34 (eval-and-compile 34 (eval-and-compile
35 (defvar device-fonts-cache)
35 (condition-case () 36 (condition-case ()
36 (require 'custom) 37 (require 'custom)
37 (error nil)) 38 (error nil))
38 (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) 39 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
39 nil ;; We've got what we needed 40 nil ;; We've got what we needed
40 ;; We have the old custom-library, hack around it! 41 ;; We have the old custom-library, hack around it!
41 (defmacro defgroup (&rest args) 42 (defmacro defgroup (&rest args)
42 nil) 43 nil)
43 (defmacro defcustom (var value doc &rest args) 44 (defmacro defcustom (var value doc &rest args)
44 (` (defvar (, var) (, value) (, doc)))))) 45 `(defvar ,var ,value ,doc))))
45 46
46 (if (not (fboundp 'try-font-name)) 47 (if (not (fboundp 'try-font-name))
47 (defun try-font-name (fontname &rest args) 48 (defun try-font-name (fontname &rest args)
48 (case window-system 49 (case window-system
49 ((x pm) (car-safe (x-list-fonts fontname))) 50 ((x pm) (car-safe (x-list-fonts fontname)))
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 89 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
89 "Whether we are running in XEmacs or not.") 90 "Whether we are running in XEmacs or not.")
90 91
91 (defmacro define-font-keywords (&rest keys) 92 (defmacro define-font-keywords (&rest keys)
92 (` 93 `(eval-and-compile
93 (eval-and-compile 94 (let ((keywords (quote ,keys)))
94 (let ((keywords (quote (, keys))))
95 (while keywords 95 (while keywords
96 (or (boundp (car keywords)) 96 (or (boundp (car keywords))
97 (set (car keywords) (car keywords))) 97 (set (car keywords) (car keywords)))
98 (setq keywords (cdr keywords))))))) 98 (setq keywords (cdr keywords))))))
99 99
100 (defconst font-window-system-mappings 100 (defconst font-window-system-mappings
101 '((x . (x-font-create-name x-font-create-object)) 101 '((x . (x-font-create-name x-font-create-object))
102 (ns . (ns-font-create-name ns-font-create-object)) 102 (ns . (ns-font-create-name ns-font-create-object))
103 (mswindows . (mswindows-font-create-name mswindows-font-create-object)) 103 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
185 (defsubst font-encoding (fontobj) 185 (defsubst font-encoding (fontobj)
186 (aref fontobj 11)) 186 (aref fontobj 11))
187 187
188 (eval-when-compile 188 (eval-when-compile
189 (defmacro define-new-mask (attr mask) 189 (defmacro define-new-mask (attr mask)
190 (` 190 `(progn
191 (progn
192 (setq font-style-keywords 191 (setq font-style-keywords
193 (cons (cons (quote (, attr)) 192 (cons (cons (quote ,attr)
194 (cons 193 (cons
195 (quote (, (intern (format "set-font-%s-p" attr)))) 194 (quote ,(intern (format "set-font-%s-p" attr)))
196 (quote (, (intern (format "font-%s-p" attr)))))) 195 (quote ,(intern (format "font-%s-p" attr)))))
197 font-style-keywords)) 196 font-style-keywords))
198 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) 197 (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask)
199 (, (format 198 ,(format
200 "Bitmask for whether a font is to be rendered in %s or not." 199 "Bitmask for whether a font is to be rendered in %s or not."
201 attr))) 200 attr))
202 (defun (, (intern (format "font-%s-p" attr))) (fontobj) 201 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
203 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) 202 ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr)
204 (if (/= 0 (& (font-style fontobj) 203 (if (/= 0 (& (font-style fontobj)
205 (, (intern (format "font-%s-mask" attr))))) 204 ,(intern (format "font-%s-mask" attr))))
206 t 205 t
207 nil)) 206 nil))
208 (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) 207 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
209 (, (format "Set whether FONTOBJ will be renderd in `%s' or not." 208 ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
210 attr)) 209 attr)
211 (cond 210 (cond
212 (val 211 (val
213 (set-font-style fontobj (| (font-style fontobj) 212 (set-font-style fontobj (| (font-style fontobj)
214 (, (intern 213 ,(intern
215 (format "font-%s-mask" attr)))))) 214 (format "font-%s-mask" attr)))))
216 (((, (intern (format "font-%s-p" attr))) fontobj) 215 ((,(intern (format "font-%s-p" attr)) fontobj)
217 (set-font-style fontobj (- (font-style fontobj) 216 (set-font-style fontobj (- (font-style fontobj)
218 (, (intern 217 ,(intern
219 (format "font-%s-mask" attr)))))))) 218 (format "font-%s-mask" attr)))))))
220 )))) 219 )))
221 220
222 (let ((mask 0)) 221 (let ((mask 0))
223 (define-new-mask bold (setq mask (1+ mask))) 222 (define-new-mask bold (setq mask (1+ mask)))
224 (define-new-mask italic (setq mask (1+ mask))) 223 (define-new-mask italic (setq mask (1+ mask)))
225 (define-new-mask oblique (setq mask (1+ mask))) 224 (define-new-mask oblique (setq mask (1+ mask)))
248 (setq i (1+ i))) 247 (setq i (1+ i)))
249 (setq i 248) 248 (setq i 248)
250 (while (< i 255) ;; Oslash - Thorn 249 (while (< i 255) ;; Oslash - Thorn
251 (aset table i (- i 32)) 250 (aset table i (- i 32))
252 (setq i (1+ i))) 251 (setq i (1+ i)))
253 table)) 252 table))
254 253
255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
256 ;;; Utility functions 255 ;;; Utility functions
257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
258 (defsubst set-font-style-by-keywords (fontobj styles) 257 (defsubst set-font-style-by-keywords (fontobj styles)
433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
434 (defun tty-font-create-object (fontname &optional device) 433 (defun tty-font-create-object (fontname &optional device)
435 (make-font :size "12pt")) 434 (make-font :size "12pt"))
436 435
437 (defun tty-font-create-plist (fontobj &optional device) 436 (defun tty-font-create-plist (fontobj &optional device)
438 (let ((styles (font-style fontobj)) 437 (list
439 (weight (font-weight fontobj))) 438 (cons 'underline (font-underline-p fontobj))
440 (list 439 (cons 'highlight (if (or (font-bold-p fontobj)
441 (cons 'underline (font-underline-p fontobj)) 440 (memq (font-weight fontobj) '(:bold :demi-bold)))
442 (cons 'highlight (if (or (font-bold-p fontobj) 441 t))
443 (memq weight '(:bold :demi-bold))) t)) 442 (cons 'dim (font-dim-p fontobj))
444 (cons 'dim (font-dim-p fontobj)) 443 (cons 'blinking (font-blink-p fontobj))
445 (cons 'blinking (font-blink-p fontobj)) 444 (cons 'reverse (font-reverse-p fontobj))))
446 (cons 'reverse (font-reverse-p fontobj)))))
447 445
448 446
449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 447 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
450 ;;; The window-system dependent code (X-style) 448 ;;; The window-system dependent code (X-style)
451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
558 ((null slant) nil) 556 ((null slant) nil)
559 ((member slant '("i" "I")) 557 ((member slant '("i" "I"))
560 (set-font-italic-p retval t)) 558 (set-font-italic-p retval t))
561 ((member slant '("o" "O")) 559 ((member slant '("o" "O"))
562 (set-font-oblique-p retval t))) 560 (set-font-oblique-p retval t)))
563 (if (string-match font-x-registry-and-encoding-regexp fontname) 561 (when (string-match font-x-registry-and-encoding-regexp fontname)
564 (progn 562 (set-font-registry retval (match-string 1 fontname))
565 (set-font-registry retval (match-string 1 fontname)) 563 (set-font-encoding retval (match-string 2 fontname)))
566 (set-font-encoding retval (match-string 2 fontname))))
567 retval)))) 564 retval))))
568 565
569 (defun x-font-families-for-device (&optional device no-resetp) 566 (defun x-font-families-for-device (&optional device no-resetp)
570 (condition-case () 567 (ignore-errors (require 'x-font-menu))
571 (require 'x-font-menu)
572 (error nil))
573 (or device (setq device (selected-device))) 568 (or device (setq device (selected-device)))
574 (if (boundp 'device-fonts-cache) 569 (if (boundp 'device-fonts-cache)
575 (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) 570 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
576 (if (and (not menu) (not no-resetp)) 571 (if (and (not menu) (not no-resetp))
577 (progn 572 (progn
578 (reset-device-font-menus device) 573 (reset-device-font-menus device)
579 (x-font-families-for-device device t)) 574 (x-font-families-for-device device t))
580 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 575 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
581 (aref menu 0))) 576 (aref menu 0)))
582 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 577 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
583 (aref menu 1)))) 578 (aref menu 1))))
584 (sort (font-unique (nconc scaled normal)) 'string-lessp)))) 579 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
585 (cons "monospace" (mapcar 'car font-x-family-mappings)))) 580 (cons "monospace" (mapcar 'car font-x-family-mappings))))
586 581
587 (defvar font-default-cache nil) 582 (defvar font-default-cache nil)
595 (face-font-name 'default device))) 590 (face-font-name 'default device)))
596 (let ((font (cdr-safe (assq 'font (frame-parameters device))))) 591 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
597 (if (and (fboundp 'fontsetp) (fontsetp font)) 592 (if (and (fboundp 'fontsetp) (fontsetp font))
598 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) 593 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
599 font)))) 594 font))))
600 595
601 ;;;###autoload 596 ;;;###autoload
602 (defun font-default-object-for-device (&optional device) 597 (defun font-default-object-for-device (&optional device)
603 (let ((font (font-default-font-for-device device))) 598 (let ((font (font-default-font-for-device device)))
604 (or (cdr-safe 599 (unless (cdr-safe (assoc font font-default-cache))
605 (assoc font font-default-cache)) 600 (push (cons font (font-create-object font)) font-default-cache)
606 (progn 601 (cdr-safe (assoc font font-default-cache)))))
607 (setq font-default-cache (cons (cons font
608 (font-create-object font))
609 font-default-cache))
610 (cdr-safe (assoc font font-default-cache))))))
611 602
612 ;;;###autoload 603 ;;;###autoload
613 (defun font-default-family-for-device (&optional device) 604 (defun font-default-family-for-device (&optional device)
614 (or device (setq device (selected-device))) 605 (font-family (font-default-object-for-device (or device (selected-device)))))
615 (font-family (font-default-object-for-device device)))
616 606
617 ;;;###autoload 607 ;;;###autoload
618 (defun font-default-registry-for-device (&optional device) 608 (defun font-default-registry-for-device (&optional device)
619 (or device (setq device (selected-device))) 609 (font-registry (font-default-object-for-device (or device (selected-device)))))
620 (font-registry (font-default-object-for-device device)))
621 610
622 ;;;###autoload 611 ;;;###autoload
623 (defun font-default-encoding-for-device (&optional device) 612 (defun font-default-encoding-for-device (&optional device)
624 (or device (setq device (selected-device))) 613 (font-encoding (font-default-object-for-device (or device (selected-device)))))
625 (font-encoding (font-default-object-for-device device)))
626 614
627 ;;;###autoload 615 ;;;###autoload
628 (defun font-default-size-for-device (&optional device) 616 (defun font-default-size-for-device (&optional device)
629 (or device (setq device (selected-device)))
630 ;; face-height isn't the right thing (always 1 pixel too high?) 617 ;; face-height isn't the right thing (always 1 pixel too high?)
631 ;; (if font-running-xemacs 618 ;; (if font-running-xemacs
632 ;; (format "%dpx" (face-height 'default device)) 619 ;; (format "%dpx" (face-height 'default device))
633 (font-size (font-default-object-for-device device))) 620 (font-size (font-default-object-for-device (or device (selected-device)))))
634 621
635 (defun x-font-create-name (fontobj &optional device) 622 (defun x-font-create-name (fontobj &optional device)
636 (if (and (not (or (font-family fontobj) 623 (if (and (not (or (font-family fontobj)
637 (font-weight fontobj) 624 (font-weight fontobj)
638 (font-size fontobj) 625 (font-size fontobj)
716 (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) 703 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
717 (if (and (not menu) (not no-resetp)) 704 (if (and (not menu) (not no-resetp))
718 (progn 705 (progn
719 (reset-device-font-menus device) 706 (reset-device-font-menus device)
720 (ns-font-families-for-device device t)) 707 (ns-font-families-for-device device t))
721 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 708 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
722 (aref menu 0))) 709 (aref menu 0)))
723 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 710 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
724 (aref menu 1)))) 711 (aref menu 1))))
725 (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) 712 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
726 713
727 (defun ns-font-create-name (fontobj &optional device) 714 (defun ns-font-create-name (fontobj &optional device)
728 (let ((family (or (font-family fontobj) 715 (let ((family (or (font-family fontobj)
776 ;;; A maximal mswindows font spec looks like: 763 ;;; A maximal mswindows font spec looks like:
777 ;;; Courier New:Bold Italic:10:underline strikeout:western 764 ;;; Courier New:Bold Italic:10:underline strikeout:western
778 ;;; Missing parts of the font spec should be filled in with these values: 765 ;;; Missing parts of the font spec should be filled in with these values:
779 ;;; Courier New:Regular:10::western 766 ;;; Courier New:Regular:10::western
780 ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" 767 ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$"
781 (defvar font-mswindows-font-regexp 768 (defvar font-mswindows-font-regexp
782 (let 769 (let
783 ((- ":") 770 ((- ":")
784 (fontname "\\([a-zA-Z ]+\\)") 771 (fontname "\\([a-zA-Z ]+\\)")
785 (weight "\\([a-zA-Z]*\\)") 772 (weight "\\([a-zA-Z]*\\)")
786 (style "\\( [a-zA-Z]*\\)?") 773 (style "\\( [a-zA-Z]*\\)?")
787 (pointsize "\\([0-9]+\\)") 774 (pointsize "\\([0-9]+\\)")
788 (effects "\\([a-zA-Z ]*\\)")q 775 (effects "\\([a-zA-Z ]*\\)")
789 (charset "\\([a-zA-Z 0-9]*\\)") 776 (charset "\\([a-zA-Z 0-9]*\\)")
790 ) 777 )
791 (concat "^" 778 (concat "^"
792 fontname - weight style - pointsize - effects - charset "$"))) 779 fontname - weight style - pointsize - effects - charset "$")))
793 780
887 (setq family (list family))) 874 (setq family (list family)))
888 (setq weight (font-higher-weight weight 875 (setq weight (font-higher-weight weight
889 (and (font-bold-p fontobj) :bold))) 876 (and (font-bold-p fontobj) :bold)))
890 (if (stringp size) 877 (if (stringp size)
891 (setq size (truncate (font-spatial-to-canonical size device)))) 878 (setq size (truncate (font-spatial-to-canonical size device))))
892 (setq weight (or (cdr-safe 879 (setq weight (or (cdr-safe
893 (assq weight mswindows-font-weight-mappings)) "")) 880 (assq weight mswindows-font-weight-mappings)) ""))
894 (let ((done nil) ; Did we find a good font yet? 881 (let ((done nil) ; Did we find a good font yet?
895 (font-name nil) ; font name we are currently checking 882 (font-name nil) ; font name we are currently checking
896 (cur-family nil) ; current family we are checking 883 (cur-family nil) ; current family we are checking
897 ) 884 )
926 913
927 914
928 ;;; Cache building code 915 ;;; Cache building code
929 ;;;###autoload 916 ;;;###autoload
930 (defun x-font-build-cache (&optional device) 917 (defun x-font-build-cache (&optional device)
931 (let ((hashtable (make-hash-table :test 'equal :size 15)) 918 (let ((hash-table (make-hash-table :test 'equal :size 15))
932 (fonts (mapcar 'x-font-create-object 919 (fonts (mapcar 'x-font-create-object
933 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) 920 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
934 (plist nil) 921 (plist nil)
935 (cur nil)) 922 (cur nil))
936 (while fonts 923 (while fonts
937 (setq cur (car fonts) 924 (setq cur (car fonts)
938 fonts (cdr fonts) 925 fonts (cdr fonts)
939 plist (cl-gethash (car (font-family cur)) hashtable)) 926 plist (cl-gethash (car (font-family cur)) hash-table))
940 (if (not (memq (font-weight cur) (plist-get plist 'weights))) 927 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
941 (setq plist (plist-put plist 'weights (cons (font-weight cur) 928 (setq plist (plist-put plist 'weights (cons (font-weight cur)
942 (plist-get plist 'weights))))) 929 (plist-get plist 'weights)))))
943 (if (not (member (font-size cur) (plist-get plist 'sizes))) 930 (if (not (member (font-size cur) (plist-get plist 'sizes)))
944 (setq plist (plist-put plist 'sizes (cons (font-size cur) 931 (setq plist (plist-put plist 'sizes (cons (font-size cur)
947 (not (memq 'oblique (plist-get plist 'styles)))) 934 (not (memq 'oblique (plist-get plist 'styles))))
948 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles))))) 935 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
949 (if (and (font-italic-p cur) 936 (if (and (font-italic-p cur)
950 (not (memq 'italic (plist-get plist 'styles)))) 937 (not (memq 'italic (plist-get plist 'styles))))
951 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles))))) 938 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
952 (cl-puthash (car (font-family cur)) plist hashtable)) 939 (cl-puthash (car (font-family cur)) plist hash-table))
953 hashtable)) 940 hash-table))
954 941
955 942
956 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 943 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
957 ;;; Now overwrite the original copy of set-face-font with our own copy that 944 ;;; Now overwrite the original copy of set-face-font with our own copy that
958 ;;; can deal with either syntax. 945 ;;; can deal with either syntax.
1126 (?1 . 1) (?b . 11) (?B . 11) 1113 (?1 . 1) (?b . 11) (?B . 11)
1127 (?2 . 2) (?c . 12) (?C . 12) 1114 (?2 . 2) (?c . 12) (?C . 12)
1128 (?3 . 3) (?d . 13) (?D . 13) 1115 (?3 . 3) (?d . 13) (?D . 13)
1129 (?4 . 4) (?e . 14) (?E . 14) 1116 (?4 . 4) (?e . 14) (?E . 14)
1130 (?5 . 5) (?f . 15) (?F . 15) 1117 (?5 . 5) (?f . 15) (?F . 15)
1131 (?6 . 6) 1118 (?6 . 6)
1132 (?7 . 7) 1119 (?7 . 7)
1133 (?8 . 8) 1120 (?8 . 8)
1134 (?9 . 9))) 1121 (?9 . 9)))
1135 (n 0) 1122 (n 0)
1136 (i 0) 1123 (i 0)
1228 (font-rgb-color-green color) 1215 (font-rgb-color-green color)
1229 (font-rgb-color-blue color))) 1216 (font-rgb-color-blue color)))
1230 ((and (vectorp color) (= 3 (length color))) 1217 ((and (vectorp color) (= 3 (length color)))
1231 (list (aref color 0) (aref color 1) (aref color 2))) 1218 (list (aref color 0) (aref color 1) (aref color 2)))
1232 ((and (listp color) (= 3 (length color)) (floatp (car color))) 1219 ((and (listp color) (= 3 (length color)) (floatp (car color)))
1233 (mapcar (function (lambda (x) (* x 65535))) color)) 1220 (mapcar #'(lambda (x) (* x 65535)) color))
1234 ((and (listp color) (= 3 (length color))) 1221 ((and (listp color) (= 3 (length color)))
1235 color) 1222 color)
1236 ((or (string-match "^#" color) 1223 ((or (string-match "^#" color)
1237 (string-match "^rgb:" color)) 1224 (string-match "^rgb:" color))
1238 (font-parse-rgb-components color)) 1225 (font-parse-rgb-components color))
1248 (font-parse-rgb-components (format "#%02x%02x%02x" r g b)))) 1235 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
1249 (t 1236 (t
1250 (font-lookup-rgb-components color))))) 1237 (font-lookup-rgb-components color)))))
1251 1238
1252 (defsubst font-tty-compute-color-delta (col1 col2) 1239 (defsubst font-tty-compute-color-delta (col1 col2)
1253 (+ 1240 (+
1254 (* (- (aref col1 0) (aref col2 0)) 1241 (* (- (aref col1 0) (aref col2 0))
1255 (- (aref col1 0) (aref col2 0))) 1242 (- (aref col1 0) (aref col2 0)))
1256 (* (- (aref col1 1) (aref col2 1)) 1243 (* (- (aref col1 1) (aref col2 1))
1257 (- (aref col1 1) (aref col2 1))) 1244 (- (aref col1 1) (aref col2 1)))
1258 (* (- (aref col1 2) (aref col2 2)) 1245 (* (- (aref col1 2) (aref col2 2))
1305 (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color) 1292 (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
1306 color)) 1293 color))
1307 (tty 1294 (tty
1308 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1295 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1309 (ns 1296 (ns
1310 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1297 (let ((vals (mapcar #'(lambda (x) (>> x 8))
1311 (font-color-rgb-components color)))) 1298 (font-color-rgb-components color))))
1312 (apply 'format "RGB%02x%02x%02xff" vals))) 1299 (apply 'format "RGB%02x%02x%02xff" vals)))
1313 (otherwise 1300 (otherwise
1314 color))) 1301 color)))
1315 1302
1363 (window-buffer window) nd)))) 1350 (window-buffer window) nd))))
1364 (setq face-at (get-text-property st 'face (window-buffer window))) 1351 (setq face-at (get-text-property st 'face (window-buffer window)))
1365 (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) 1352 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
1366 (setq found t))) 1353 (setq found t)))
1367 found)) 1354 found))
1368 1355
1369 (defun font-blink-callback () 1356 (defun font-blink-callback ()
1370 ;; Optimized to never invert the face unless one of the visible windows 1357 ;; Optimized to never invert the face unless one of the visible windows
1371 ;; is showing it. 1358 ;; is showing it.
1372 (let ((faces (if font-running-xemacs (face-list t) (face-list))) 1359 (let ((faces (if font-running-xemacs (face-list t) (face-list)))
1373 (obj nil)) 1360 (obj nil))
1381 1368
1382 (defcustom font-blink-interval 0.5 1369 (defcustom font-blink-interval 0.5
1383 "How often to blink faces" 1370 "How often to blink faces"
1384 :type 'number 1371 :type 'number
1385 :group 'faces) 1372 :group 'faces)
1386 1373
1387 (defun font-blink-initialize () 1374 (defun font-blink-initialize ()
1388 (cond 1375 (cond
1389 ((featurep 'itimer) 1376 ((featurep 'itimer)
1390 (if (get-itimer "font-blinker") 1377 (if (get-itimer "font-blinker")
1391 (delete-itimer (get-itimer "font-blinker"))) 1378 (delete-itimer (get-itimer "font-blinker")))
1392 (start-itimer "font-blinker" 'font-blink-callback 1379 (start-itimer "font-blinker" 'font-blink-callback
1393 font-blink-interval 1380 font-blink-interval
1394 font-blink-interval)) 1381 font-blink-interval))
1395 ((fboundp 'run-at-time) 1382 ((fboundp 'run-at-time)
1396 (cancel-function-timers 'font-blink-callback) 1383 (cancel-function-timers 'font-blink-callback)
1397 (run-at-time font-blink-interval 1384 (run-at-time font-blink-interval
1398 font-blink-interval 1385 font-blink-interval
1399 'font-blink-callback)) 1386 'font-blink-callback))
1400 (t nil))) 1387 (t nil)))
1401 1388
1402 (provide 'font) 1389 (provide 'font)