X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Ffont.el;h=b0e002fa308d96f4a9d1ec5fd7a4b7cba0732135;hb=0d9955fa18f502aa3b2169315dc364771154e921;hp=ecaf1c90450e71c31d42b2598983ac439621467f;hpb=72a705551741d6f85a40eea486c222bac482d8dc;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/font.el b/lisp/font.el index ecaf1c9..b0e002f 100644 --- a/lisp/font.el +++ b/lisp/font.el @@ -32,6 +32,7 @@ (require 'cl) (eval-and-compile + (defvar device-fonts-cache) (condition-case () (require 'custom) (error nil)) @@ -40,8 +41,8 @@ ;; We have the old custom-library, hack around it! (defmacro defgroup (&rest args) nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) + (defmacro defcustom (var value doc &rest args) + `(defvar ,var ,value ,doc)))) (if (not (fboundp 'try-font-name)) (defun try-font-name (fontname &rest args) @@ -89,22 +90,24 @@ "Whether we are running in XEmacs or not.") (defmacro define-font-keywords (&rest keys) - (` - (eval-and-compile - (let ((keywords (quote (, keys)))) + `(eval-and-compile + (let ((keywords (quote ,keys))) (while keywords (or (boundp (car keywords)) (set (car keywords) (car keywords))) - (setq keywords (cdr keywords))))))) + (setq keywords (cdr keywords)))))) (defconst font-window-system-mappings '((x . (x-font-create-name x-font-create-object)) + (gtk . (x-font-create-name x-font-create-object)) (ns . (ns-font-create-name ns-font-create-object)) (mswindows . (mswindows-font-create-name mswindows-font-create-object)) (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME (tty . (tty-font-create-plist tty-font-create-object))) - "An assoc list mapping device types to the function used to create -a font name from a font structure.") + "An assoc list mapping device types to a list of translations. + +The first function creates a font name from a font descriptor object. +The second performs the reverse translation.") (defconst ns-font-weight-mappings '((:extra-light . "extralight") @@ -141,6 +144,8 @@ for use in the 'weight' field of an X font string.") (defvar font-maximum-slippage "1pt" "How much a font is allowed to vary from the desired size.") +;; Canonical (internal) sizes are in points. +;; Registry (define-font-keywords :family :style :size :registry :encoding) (define-font-keywords @@ -187,37 +192,36 @@ for use in the 'weight' field of an X font string.") (eval-when-compile (defmacro define-new-mask (attr mask) - (` - (progn + `(progn (setq font-style-keywords - (cons (cons (quote (, attr)) + (cons (cons (quote ,attr) (cons - (quote (, (intern (format "set-font-%s-p" attr)))) - (quote (, (intern (format "font-%s-p" attr)))))) + (quote ,(intern (format "set-font-%s-p" attr))) + (quote ,(intern (format "font-%s-p" attr))))) font-style-keywords)) - (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) - (, (format - "Bitmask for whether a font is to be rendered in %s or not." - attr))) - (defun (, (intern (format "font-%s-p" attr))) (fontobj) - (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) + (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask) + ,(format + "Bitmask for whether a font is to be rendered in %s or not." + attr)) + (defun ,(intern (format "font-%s-p" attr)) (fontobj) + ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr) (if (/= 0 (& (font-style fontobj) - (, (intern (format "font-%s-mask" attr))))) + ,(intern (format "font-%s-mask" attr)))) t nil)) - (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) - (, (format "Set whether FONTOBJ will be renderd in `%s' or not." - attr)) + (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val) + ,(format "Set whether FONTOBJ will be renderd in `%s' or not." + attr) (cond (val (set-font-style fontobj (| (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))) - (((, (intern (format "font-%s-p" attr))) fontobj) + ,(intern + (format "font-%s-mask" attr))))) + ((,(intern (format "font-%s-p" attr)) fontobj) (set-font-style fontobj (- (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))))) - )))) + ,(intern + (format "font-%s-mask" attr))))))) + ))) (let ((mask 0)) (define-new-mask bold (setq mask (1+ mask))) @@ -250,7 +254,7 @@ for use in the 'weight' field of an X font string.") (while (< i 255) ;; Oslash - Thorn (aset table i (- i 32)) (setq i (1+ i))) - table)) + table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utility functions @@ -300,8 +304,16 @@ for use in the 'weight' field of an X font string.") w2)))) (defun font-spatial-to-canonical (spec &optional device) - "Convert SPEC (in inches, millimeters, points, or picas) into points" - ;; 1 in = 6 pa = 25.4 mm = 72 pt + "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points. + +Canonical sizes are in points. If SPEC is null, nil is returned. If SPEC is +a number, it is interpreted as the desired point size and returned unchanged. +Otherwise SPEC must be a string consisting of a number and an optional type. +The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or +\"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), +\"cm\" (centimeters), or \"mm\" (millimeters). + +1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent." (cond ((numberp spec) spec) @@ -316,6 +328,8 @@ for use in the 'weight' field of an X font string.") (mm-width (float (or (device-mm-width device) 293))) (retval nil)) (cond + ;; the following string-match is broken, there will never be a + ;; left operand detected ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee! (let ((math-func (intern (match-string 1 spec))) (other (font-spatial-to-canonical @@ -336,7 +350,7 @@ for use in the 'weight' field of an X font string.") (setq num (string-to-number spec)) (cond ((member type '("pixel" "px" "pix")) - (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0)))) + (setq retval (* num (/ mm-width pix-width) (/ 72.0 25.4)))) ((member type '("point" "pt")) (setq retval num)) ((member type '("pica" "pa")) @@ -375,12 +389,14 @@ for use in the 'weight' field of an X font string.") (plist-get args :encoding))) (defun font-create-name (fontobj &optional device) + "Return a font name constructed from FONTOBJ, appropriate for DEVICE." (let* ((type (device-type device)) (func (car (cdr-safe (assq type font-window-system-mappings))))) (and func (fboundp func) (funcall func fontobj device)))) ;;;###autoload (defun font-create-object (fontname &optional device) + "Return a font descriptor object for FONTNAME, appropriate for DEVICE." (let* ((type (device-type device)) (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) (and func (fboundp func) (funcall func fontname device)))) @@ -432,18 +448,19 @@ for use in the 'weight' field of an X font string.") ;;; The window-system dependent code (TTY-style) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun tty-font-create-object (fontname &optional device) + "Return a font descriptor object for FONTNAME, appropriate for TTY devices." (make-font :size "12pt")) (defun tty-font-create-plist (fontobj &optional device) - (let ((styles (font-style fontobj)) - (weight (font-weight fontobj))) - (list - (cons 'underline (font-underline-p fontobj)) - (cons 'highlight (if (or (font-bold-p fontobj) - (memq weight '(:bold :demi-bold))) t)) - (cons 'dim (font-dim-p fontobj)) - (cons 'blinking (font-blink-p fontobj)) - (cons 'reverse (font-reverse-p fontobj))))) + "Return a font name constructed from FONTOBJ, appropriate for TTY devices." + (list + (cons 'underline (font-underline-p fontobj)) + (cons 'highlight (if (or (font-bold-p fontobj) + (memq (font-weight fontobj) '(:bold :demi-bold))) + t)) + (cons 'dim (font-dim-p fontobj)) + (cons 'blinking (font-blink-p fontobj)) + (cons 'reverse (font-reverse-p fontobj)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -520,6 +537,7 @@ for use in the 'weight' field of an X font string.") "A list of font family mappings on X devices.") (defun x-font-create-object (fontname &optional device) + "Return a font descriptor object for FONTNAME, appropriate for X devices." (let ((case-fold-search t)) (if (or (not (stringp fontname)) (not (string-match font-x-font-regexp fontname))) @@ -560,16 +578,13 @@ for use in the 'weight' field of an X font string.") (set-font-italic-p retval t)) ((member slant '("o" "O")) (set-font-oblique-p retval t))) - (if (string-match font-x-registry-and-encoding-regexp fontname) - (progn - (set-font-registry retval (match-string 1 fontname)) - (set-font-encoding retval (match-string 2 fontname)))) + (when (string-match font-x-registry-and-encoding-regexp fontname) + (set-font-registry retval (match-string 1 fontname)) + (set-font-encoding retval (match-string 2 fontname))) retval)))) (defun x-font-families-for-device (&optional device no-resetp) - (condition-case () - (require 'x-font-menu) - (error nil)) + (ignore-errors (require 'x-font-menu)) (or device (setq device (selected-device))) (if (boundp 'device-fonts-cache) (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) @@ -577,9 +592,9 @@ for use in the 'weight' field of an X font string.") (progn (reset-device-font-menus device) (x-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))) (cons "monospace" (mapcar 'car font-x-family-mappings)))) @@ -597,42 +612,36 @@ for use in the 'weight' field of an X font string.") (if (and (fboundp 'fontsetp) (fontsetp font)) (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) font)))) - + ;;;###autoload (defun font-default-object-for-device (&optional device) (let ((font (font-default-font-for-device device))) - (or (cdr-safe - (assoc font font-default-cache)) - (progn - (setq font-default-cache (cons (cons font - (font-create-object font)) - font-default-cache)) - (cdr-safe (assoc font font-default-cache)))))) + (or (cdr-safe (assoc font font-default-cache)) + (let ((object (font-create-object font))) + (push (cons font object) font-default-cache) + object)))) ;;;###autoload (defun font-default-family-for-device (&optional device) - (or device (setq device (selected-device))) - (font-family (font-default-object-for-device device))) + (font-family (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-registry-for-device (&optional device) - (or device (setq device (selected-device))) - (font-registry (font-default-object-for-device device))) + (font-registry (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-encoding-for-device (&optional device) - (or device (setq device (selected-device))) - (font-encoding (font-default-object-for-device device))) + (font-encoding (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-size-for-device (&optional device) - (or device (setq device (selected-device))) ;; face-height isn't the right thing (always 1 pixel too high?) ;; (if font-running-xemacs ;; (format "%dpx" (face-height 'default device)) - (font-size (font-default-object-for-device device))) + (font-size (font-default-object-for-device (or device (selected-device))))) (defun x-font-create-name (fontobj &optional device) + "Return a font name constructed from FONTOBJ, appropriate for X devices." (if (and (not (or (font-family fontobj) (font-weight fontobj) (font-size fontobj) @@ -718,13 +727,14 @@ for use in the 'weight' field of an X font string.") (progn (reset-device-font-menus device) (ns-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) (defun ns-font-create-name (fontobj &optional device) + "Return a font name constructed from FONTOBJ, appropriate for NextSTEP devices." (let ((family (or (font-family fontobj) (ns-font-families-for-device device))) (weight (or (font-weight fontobj) :medium)) @@ -778,14 +788,14 @@ for use in the 'weight' field of an X font string.") ;;; Missing parts of the font spec should be filled in with these values: ;;; Courier New:Regular:10::western ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" -(defvar font-mswindows-font-regexp +(defvar font-mswindows-font-regexp (let ((- ":") (fontname "\\([a-zA-Z ]+\\)") (weight "\\([a-zA-Z]*\\)") (style "\\( [a-zA-Z]*\\)?") (pointsize "\\([0-9]+\\)") - (effects "\\([a-zA-Z ]*\\)")q + (effects "\\([a-zA-Z ]*\\)") (charset "\\([a-zA-Z 0-9]*\\)") ) (concat "^" @@ -825,6 +835,7 @@ for use in the 'weight' field of an mswindows font string.") "A list of font family mappings on mswindows devices.") (defun mswindows-font-create-object (fontname &optional device) + "Return a font descriptor object for FONTNAME, appropriate for MS Windows devices." (let ((case-fold-search t) (font (mswindows-font-canonicalize-name fontname))) (if (or (not (stringp font)) @@ -863,6 +874,7 @@ for use in the 'weight' field of an mswindows font string.") retval)))) (defun mswindows-font-create-name (fontobj &optional device) + "Return a font name constructed from FONTOBJ, appropriate for MS Windows devices." (if (and (not (or (font-family fontobj) (font-weight fontobj) (font-size fontobj) @@ -889,7 +901,7 @@ for use in the 'weight' field of an mswindows font string.") (and (font-bold-p fontobj) :bold))) (if (stringp size) (setq size (truncate (font-spatial-to-canonical size device)))) - (setq weight (or (cdr-safe + (setq weight (or (cdr-safe (assq weight mswindows-font-weight-mappings)) "")) (let ((done nil) ; Did we find a good font yet? (font-name nil) ; font name we are currently checking @@ -928,7 +940,7 @@ for use in the 'weight' field of an mswindows font string.") ;;; Cache building code ;;;###autoload (defun x-font-build-cache (&optional device) - (let ((hashtable (make-hash-table :test 'equal :size 15)) + (let ((hash-table (make-hash-table :test 'equal :size 15)) (fonts (mapcar 'x-font-create-object (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) (plist nil) @@ -936,7 +948,7 @@ for use in the 'weight' field of an mswindows font string.") (while fonts (setq cur (car fonts) fonts (cdr fonts) - plist (cl-gethash (car (font-family cur)) hashtable)) + plist (cl-gethash (car (font-family cur)) hash-table)) (if (not (memq (font-weight cur) (plist-get plist 'weights))) (setq plist (plist-put plist 'weights (cons (font-weight cur) (plist-get plist 'weights))))) @@ -949,8 +961,8 @@ for use in the 'weight' field of an mswindows font string.") (if (and (font-italic-p cur) (not (memq 'italic (plist-get plist 'styles)))) (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles))))) - (cl-puthash (car (font-family cur)) plist hashtable)) - hashtable)) + (cl-puthash (car (font-family cur)) plist hash-table)) + hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1066,8 +1078,6 @@ for use in the 'weight' field of an mswindows font string.") The list (R G B) is returned, or an error is signaled if the lookup fails." (let ((lib-list (if (boundp 'x-library-search-path) x-library-search-path - ;; This default is from XEmacs 19.13 - hope it covers - ;; everyone. (list "/usr/X11R6/lib/X11/" "/usr/X11R5/lib/X11/" "/usr/lib/X11R6/X11/" @@ -1078,7 +1088,9 @@ The list (R G B) is returned, or an error is signaled if the lookup fails." "/usr/local/lib/X11R5/X11/" "/usr/X11/lib/X11/" "/usr/lib/X11/" + "/usr/share/X11/" "/usr/local/lib/X11/" + "/usr/local/share/X11/" "/usr/X386/lib/X11/" "/usr/x386/lib/X11/" "/usr/XFree86/lib/X11/" @@ -1128,7 +1140,7 @@ The list (R G B) is returned, or an error is signaled if the lookup fails." (?3 . 3) (?d . 13) (?D . 13) (?4 . 4) (?e . 14) (?E . 14) (?5 . 5) (?f . 15) (?F . 15) - (?6 . 6) + (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9))) @@ -1230,7 +1242,7 @@ The variable x-library-search-path is use to locate the rgb.txt file." ((and (vectorp color) (= 3 (length color))) (list (aref color 0) (aref color 1) (aref color 2))) ((and (listp color) (= 3 (length color)) (floatp (car color))) - (mapcar (function (lambda (x) (* x 65535))) color)) + (mapcar #'(lambda (x) (* x 65535)) color)) ((and (listp color) (= 3 (length color))) color) ((or (string-match "^#" color) @@ -1250,7 +1262,7 @@ The variable x-library-search-path is use to locate the rgb.txt file." (font-lookup-rgb-components color))))) (defsubst font-tty-compute-color-delta (col1 col2) - (+ + (+ (* (- (aref col1 0) (aref col2 0)) (- (aref col1 0) (aref col2 0))) (* (- (aref col1 1) (aref col2 1)) @@ -1307,7 +1319,7 @@ is returned." (tty (apply 'font-tty-find-closest-color (font-color-rgb-components color))) (ns - (let ((vals (mapcar (function (lambda (x) (>> x 8))) + (let ((vals (mapcar #'(lambda (x) (>> x 8)) (font-color-rgb-components color)))) (apply 'format "RGB%02x%02x%02xff" vals))) (otherwise @@ -1365,7 +1377,7 @@ is returned." (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) (setq found t))) found)) - + (defun font-blink-callback () ;; Optimized to never invert the face unless one of the visible windows ;; is showing it. @@ -1383,7 +1395,7 @@ is returned." "How often to blink faces" :type 'number :group 'faces) - + (defun font-blink-initialize () (cond ((featurep 'itimer) @@ -1393,10 +1405,10 @@ is returned." font-blink-interval font-blink-interval)) ((fboundp 'run-at-time) - (cancel-function-timers 'font-blink-callback) + (cancel-function-timers 'font-blink-callback) (run-at-time font-blink-interval font-blink-interval 'font-blink-callback)) (t nil))) - + (provide 'font)