9:49 a.m.
Emacs/W3 is the canonical source for font.el, at least until we do the new
font model in C and make it consistent across emacsen.
Please report any patches to me <wmperry(a)cs.indiana.edu>.
1998-12-31 William M. Perry <wmperry(a)aventail.com>
* font.el: Synch the diverging font.el stuff. Don't remove
compability stuff. Don't needlessly rewrite macros to the new
style, or old emacs breaks. Support for new Emacs redisplay.
-bp
Index: font.el
===================================================================
RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/font.el,v
retrieving revision 1.5.2.3
diff -c -w -c -w -r1.5.2.3 font.el
*** font.el 1998/12/31 14:46:11 1.5.2.3
--- font.el 1998/12/31 17:35:34
***************
*** 1,12 ****
;;; font.el --- New font model
! ;; Author: wmperry
! ;; Created: 1997/09/05 15:44:37
! ;; Version: 1.52
;; Keywords: faces
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry(a)cs.indiana.edu)
! ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Emacs.
;;;
--- 1,12 ----
;;; font.el --- New font model
! ;; Author: $Author: wmperry $
! ;; Created: $Date: 1998/12/18 02:19:25 $
! ;; Version: $Revision: 1.1.1.2 $
;; Keywords: faces
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;;; Copyright (c) 1995, 1996 by William M. Perry <wmperry(a)cs.indiana.edu>
! ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Emacs.
;;;
***************
*** 30,38 ****
;;; The emacsen compatibility package - load it up before anything else
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'cl)
(eval-and-compile
- (defvar device-fonts-cache)
(condition-case ()
(require 'custom)
(error nil))
--- 30,41 ----
;;; The emacsen compatibility package - load it up before anything else
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'cl)
+ (require 'devices)
+ ;; Needed for XEmacs 19.13, noop on all others, since it is always loaded.
+ (require 'disp-table)
+
(eval-and-compile
(condition-case ()
(require 'custom)
(error nil))
***************
*** 42,53 ****
(defmacro defgroup (&rest args)
nil)
(defmacro defcustom (var value doc &rest args)
! `(defvar ,var ,value ,doc))))
(if (not (fboundp 'try-font-name))
(defun try-font-name (fontname &rest args)
(case window-system
! ((x pm) (car-safe (x-list-fonts fontname)))
(mswindows (car-safe (mswindows-list-fonts fontname)))
(ns (car-safe (ns-list-fonts fontname)))
(otherwise nil))))
--- 45,56 ----
(defmacro defgroup (&rest args)
nil)
(defmacro defcustom (var value doc &rest args)
! (` (defvar (, var) (, value) (, doc))))))
(if (not (fboundp 'try-font-name))
(defun try-font-name (fontname &rest args)
(case window-system
! ((x win32 w32 pm) (car-safe (x-list-fonts fontname)))
(mswindows (car-safe (mswindows-list-fonts fontname)))
(ns (car-safe (ns-list-fonts fontname)))
(otherwise nil))))
***************
*** 89,106 ****
(defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
"Whether we are running in XEmacs or not.")
(defmacro define-font-keywords (&rest keys)
! `(eval-and-compile
! (let ((keywords (quote ,keys)))
(while keywords
(or (boundp (car keywords))
(set (car keywords) (car keywords)))
! (setq keywords (cdr keywords))))))
(defconst font-window-system-mappings
'((x . (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
--- 92,116 ----
(defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
"Whether we are running in XEmacs or not.")
+ (defconst font-running-emacs-new-redisplay (and (fboundp 'set-face-attribute)
+ (fboundp 'set-face-background-pixmap))
+ "Whether we are running in Emacs with the new redisplay engine.")
+
(defmacro define-font-keywords (&rest keys)
! (`
! (eval-and-compile
! (let ((keywords (quote (, keys))))
(while keywords
(or (boundp (car keywords))
(set (car keywords) (car keywords)))
! (setq keywords (cdr keywords)))))))
(defconst font-window-system-mappings
'((x . (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))
+ (win32 . (x-font-create-name x-font-create-object))
+ (w32 . (x-font-create-name x-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
***************
*** 132,137 ****
--- 142,161 ----
"An assoc list mapping keywords to actual Xwindow specific strings
for use in the 'weight' field of an X font string.")
+ (defconst font-new-redisplay-weight-mappings
+ '((:extra-light . extra-light)
+ (:light . light)
+ (:demi-light . semi-light)
+ (:demi . semi-light)
+ (:book . normal)
+ (:medium . normal)
+ (:normal . normal)
+ (:demi-bold . semi-bold)
+ (:bold . bold)
+ (:extra-bold . extra-bold))
+ "An assoc list mapping font weights to the actual symbols used by
+ the new redisplay engine.")
+
(defconst font-possible-weights
(mapcar 'car x-font-weight-mappings))
***************
*** 144,151 ****
(define-font-keywords :family :style :size :registry :encoding)
(define-font-keywords
! :weight :extra-light :light :demi-light :medium :normal :demi-bold
! :bold :extra-bold)
(defvar font-style-keywords nil)
--- 168,175 ----
(define-font-keywords :family :style :size :registry :encoding)
(define-font-keywords
! :weight :extra-light :light :demi-light :medium :normal :regular
! :demi-bold :bold :extra-bold)
(defvar font-style-keywords nil)
***************
*** 187,222 ****
(eval-when-compile
(defmacro define-new-mask (attr mask)
! `(progn
(setq font-style-keywords
! (cons (cons (quote ,attr)
(cons
! (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)
(if (/= 0 (& (font-style fontobj)
! ,(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)
(cond
(val
(set-font-style fontobj (| (font-style 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)))))))
! )))
(let ((mask 0))
(define-new-mask bold (setq mask (1+ mask)))
--- 211,247 ----
(eval-when-compile
(defmacro define-new-mask (attr mask)
! (`
! (progn
(setq font-style-keywords
! (cons (cons (quote (, attr))
(cons
! (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))
(if (/= 0 (& (font-style fontobj)
! (, (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))
(cond
(val
(set-font-style fontobj (| (font-style 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))))))))
! ))))
(let ((mask 0))
(define-new-mask bold (setq mask (1+ mask)))
***************
*** 472,478 ****
(concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
pixelsize - pointsize - resx - resy - spacing - avgwidth -
! registry - encoding "\\'"
))))
(defvar font-x-registry-and-encoding-regexp
--- 497,503 ----
(concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
pixelsize - pointsize - resx - resy - spacing - avgwidth -
! registry - encoding - "*" "\\'"
))))
(defvar font-x-registry-and-encoding-regexp
***************
*** 572,580 ****
(progn
(reset-device-font-menus device)
(x-font-families-for-device device t))
! (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
(aref menu 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,605 ----
(progn
(reset-device-font-menus device)
(x-font-families-for-device device t))
! (let ((scaled (mapcar (lambda (x) (if x (aref x 0)))
(aref menu 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))))
***************
*** 603,624 ****
;;;###autoload
(defun font-default-family-for-device (&optional device)
! (font-family (font-default-object-for-device (or device (selected-device)))))
;;;###autoload
(defun font-default-registry-for-device (&optional device)
! (font-registry (font-default-object-for-device (or device (selected-device)))))
;;;###autoload
(defun font-default-encoding-for-device (&optional device)
! (font-encoding (font-default-object-for-device (or device (selected-device)))))
;;;###autoload
(defun font-default-size-for-device (&optional 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 (or device (selected-device)))))
(defun x-font-create-name (fontobj &optional device)
(if (and (not (or (font-family fontobj)
--- 628,649 ----
;;;###autoload
(defun font-default-family-for-device (&optional device)
! (font-family (font-default-object-for-device device)))
;;;###autoload
(defun font-default-registry-for-device (&optional device)
! (font-registry (font-default-object-for-device device)))
;;;###autoload
(defun font-default-encoding-for-device (&optional device)
! (font-encoding (font-default-object-for-device device)))
;;;###autoload
(defun font-default-size-for-device (&optional 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)))
(defun x-font-create-name (fontobj &optional device)
(if (and (not (or (font-family fontobj)
***************
*** 706,714 ****
(progn
(reset-device-font-menus device)
(ns-font-families-for-device device t))
! (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
(aref menu 0)))
! (normal (mapcar #'(lambda (x) (if x (aref x 0)))
(aref menu 1))))
(sort (font-unique (nconc scaled normal)) 'string-lessp))))))
--- 731,739 ----
(progn
(reset-device-font-menus device)
(ns-font-families-for-device device t))
! (let ((scaled (mapcar (lambda (x) (if x (aref x 0)))
(aref menu 0)))
! (normal (mapcar (lambda (x) (if x (aref x 0)))
(aref menu 1))))
(sort (font-unique (nconc scaled normal)) 'string-lessp))))))
***************
*** 918,924 ****
(defun x-font-build-cache (&optional device)
(let ((hash-table (make-hash-table :test 'equal :size 15))
(fonts (mapcar 'x-font-create-object
! (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
(plist nil)
(cur nil))
(while fonts
--- 943,949 ----
(defun x-font-build-cache (&optional device)
(let ((hash-table (make-hash-table :test 'equal :size 15))
(fonts (mapcar 'x-font-create-object
! (list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
(plist nil)
(cur nil))
(while fonts
***************
*** 986,992 ****
--- 1011,1065 ----
(set-face-property face 'font-specification nil)
(apply 'set-face-font face font args))))
+ (defun font-find-available-family (fontobj &optional device)
+ (let* ((default (font-default-object-for-device device))
+ (family (or (font-family fontobj)
+ (font-family default)
+ (x-font-families-for-device device)))
+ (cur-family nil)
+ (done nil))
+ (if (stringp family)
+ (setq family (list family)))
+ (while (and family (not done))
+ (setq cur-family (pop family))
+ (if (assoc cur-family font-x-family-mappings)
+ ;; If the family name is an alias as defined by
+ ;; font-x-family-mappings, then append those families to the
+ ;; front fo 'family' and continue in the loop.
+ (setq family (append (cdr-safe
+ (assoc cur-family font-x-family-mappings))
+ family))
+ ;; Not an alias for a list of fonts, so we just check it.
+ ;; First, convert all '-' to spaces so that we don't screw up
+ ;; the oh-so wonderful X font model. Wheee.
+ (let ((x (length cur-family)))
+ (while (> x 0)
+ (if (= ?- (aref cur-family (1- x)))
+ (aset cur-family (1- x) ? ))
+ (setq x (1- x))))
+ (setq done (try-font-name (format "-*-%s-*-*-*-*-*-*-*-*-*-*-*-*" family)
device))))
+ (and done family)))
+
+ (defun font-set-face-font-new-redisplay (&optional face font &rest args)
+ (cond
+ ((and (vectorp font) (= (length font) 12))
+ (set-face-property face 'font-specification font)
+ (set-face-attribute face nil
+ :underline (font-underline-p font)
+ :weight (or (cdr-safe (assoc (font-weight font)
+ font-new-redisplay-weight-mappings))
+ 'normal)
+ :family (font-find-available-family font))
+ (if (font-size font)
+ (set-face-attribute face nil
+ :height (* 10 (font-spatial-to-canonical (font-size font))))))
+ (t
+ (set-face-property face 'font-specification nil)
+ (apply 'set-face-font face font args))))
+ (if font-running-emacs-new-redisplay
+ (fset 'font-set-face-font 'font-set-face-font-new-redisplay))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Now for emacsen specific stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
***************
*** 1218,1224 ****
((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 #'(lambda (x) (* x 65535)) color))
((and (listp color) (= 3 (length color)))
color)
((or (string-match "^#" color)
--- 1291,1297 ----
((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 (lambda (x) (* x 65535)) color))
((and (listp color) (= 3 (length color)))
color)
((or (string-match "^#" color)
***************
*** 1287,1292 ****
--- 1360,1375 ----
(case (device-type device)
((x pm)
(apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
+ (win32
+ (let* ((rgb (font-color-rgb-components color))
+ (color (apply 'format "#%02x%02x%02x" rgb)))
+ (win32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+ color))
+ (w32
+ (let* ((rgb (font-color-rgb-components color))
+ (color (apply 'format "#%02x%02x%02x" rgb)))
+ (w32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
+ color))
(mswindows
(let* ((rgb (font-color-rgb-components color))
(color (apply 'format "#%02x%02x%02x" rgb)))
***************
*** 1295,1301 ****
(tty
(apply 'font-tty-find-closest-color (font-color-rgb-components color)))
(ns
! (let ((vals (mapcar #'(lambda (x) (>> x 8))
(font-color-rgb-components color))))
(apply 'format "RGB%02x%02x%02xff" vals)))
(otherwise
--- 1378,1384 ----
(tty
(apply 'font-tty-find-closest-color (font-color-rgb-components color)))
(ns
! (let ((vals (mapcar (lambda (x) (>> x 8))
(font-color-rgb-components color))))
(apply 'format "RGB%02x%02x%02xff" vals)))
(otherwise