(require 'cl)
(eval-and-compile
+ (defvar device-fonts-cache)
(condition-case ()
(require 'custom)
(error nil))
;; 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)
"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")
(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
(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)))
(while (< i 255) ;; Oslash - Thorn
(aset table i (- i 32))
(setq i (1+ i)))
- table))
+ table))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utility functions
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)
(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
(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"))
(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))))
;;; 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))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"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)))
(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)))))
(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))))
(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)
(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))
;;; 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 "^"
"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))
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)
(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
;;; 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)
(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)))))
(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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(?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)))
((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)
(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))
(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
(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.
"How often to blink faces"
:type 'number
:group 'faces)
-
+
(defun font-blink-initialize ()
(cond
((featurep 'itimer)
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)
projects / chise / xemacs-chise.git.1 / blobdiff