Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 6a22abad6937
children 1ce6082ce73f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/26 20:08:55 3 ;; Created: 1996/08/11 16:40:36
4 ;; Version: 1.40 4 ;; Version: 1.8
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 9 ;;;
11 ;;; This file is part of GNU Emacs. 10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;; 11 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by 13 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option) 14 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version. 15 ;;; any later version.
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details. 20 ;;; GNU General Public License for more details.
22 ;;; 21 ;;;
23 ;;; You should have received a copy of the GNU General Public License 22 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the 23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 26
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; The emacsen compatibility package - load it up before anything else 28 ;;; The emacsen compatibility package - load it up before anything else
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (eval-and-compile 30 (eval-and-compile
33 (unless (string-match "XEmacs" emacs-version) 31 (load-library "w3-sysdp")
34 (require 'w3-sysdp))
35 (require 'cl)) 32 (require 'cl))
36 33
37 (require 'disp-table) 34 (require 'disp-table)
38 (if (not (fboundp '<<)) (fset '<< 'lsh)) 35 (if (not (fboundp '<<)) (fset '<< 'lsh))
39 (if (not (fboundp '&)) (fset '& 'logand)) 36 (if (not (fboundp '&)) (fset '& 'logand))
47 ;;; Not much should need to be modified 44 ;;; Not much should need to be modified
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 46 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
50 "Whether we are running in XEmacs or not.") 47 "Whether we are running in XEmacs or not.")
51 48
52 (defmacro define-font-keywords (&rest keys) 49 (defmacro defkeyword (keyword &optional docstring)
53 (` 50 (list 'defconst keyword (list 'quote keyword)
54 (eval-and-compile 51 (or docstring "A keyword")))
55 (let ((keywords (quote (, keys))))
56 (while keywords
57 (or (boundp (car keywords))
58 (set (car keywords) (car keywords)))
59 (setq keywords (cdr keywords)))))))
60 52
61 (defconst font-window-system-mappings 53 (defconst font-window-system-mappings
62 '((x . (x-font-create-name x-font-create-object)) 54 '((x . (x-font-create-name x-font-create-object))
63 (ns . (ns-font-create-name ns-font-create-object)) 55 (ns . (ns-font-create-name ns-font-create-object))
64 (win32 . (x-font-create-name x-font-create-object))
65 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
66 (tty . (tty-font-create-plist tty-font-create-object))) 56 (tty . (tty-font-create-plist tty-font-create-object)))
67 "An assoc list mapping device types to the function used to create 57 "An assoc list mapping device types to the function used to create
68 a font name from a font structure.") 58 a font name from a font structure.")
69 59
70 (defconst ns-font-weight-mappings 60 (defconst ns-font-weight-mappings
133 ("cursive" . ("sirene" 123 ("cursive" . ("sirene"
134 "zapf chancery")) 124 "zapf chancery"))
135 ) 125 )
136 "A list of font family mappings.") 126 "A list of font family mappings.")
137 127
138 (define-font-keywords :family :style :size :registry :encoding) 128 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.")
139 129
140 (define-font-keywords 130 (defkeyword :weight "Keyword specifying the font weight of a FONTOBJ.")
141 :weight :extra-light :light :demi-light :medium :normal :demi-bold 131 (defkeyword :extra-light)
142 :bold :extra-bold) 132 (defkeyword :light)
143 133 (defkeyword :demi-light)
144 (defvar font-style-keywords nil) 134 (defkeyword :medium)
145 135 (defkeyword :normal)
146 (defsubst set-font-family (fontobj family) 136 (defkeyword :demi-bold)
147 (aset fontobj 1 family)) 137 (defkeyword :bold)
148 138 (defkeyword :extra-bold)
149 (defsubst set-font-weight (fontobj weight) 139
150 (aset fontobj 3 weight)) 140 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.")
151 141 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.")
152 (defsubst set-font-style (fontobj style) 142 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.")
153 (aset fontobj 5 style)) 143 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.")
154
155 (defsubst set-font-size (fontobj size)
156 (aset fontobj 7 size))
157
158 (defsubst set-font-registry (fontobj reg)
159 (aset fontobj 9 reg))
160
161 (defsubst set-font-encoding (fontobj enc)
162 (aset fontobj 11 enc))
163
164 (defsubst font-family (fontobj)
165 (aref fontobj 1))
166
167 (defsubst font-weight (fontobj)
168 (aref fontobj 3))
169
170 (defsubst font-style (fontobj)
171 (aref fontobj 5))
172
173 (defsubst font-size (fontobj)
174 (aref fontobj 7))
175
176 (defsubst font-registry (fontobj)
177 (aref fontobj 9))
178
179 (defsubst font-encoding (fontobj)
180 (aref fontobj 11))
181 144
182 (eval-when-compile 145 (eval-when-compile
183 (defmacro define-new-mask (attr mask) 146 (defmacro define-new-mask (attr mask)
184 (` 147 (`
185 (progn 148 (progn
186 (setq font-style-keywords
187 (cons (cons (quote (, attr))
188 (cons
189 (quote (, (intern (format "set-font-%s-p" attr))))
190 (quote (, (intern (format "font-%s-p" attr))))))
191 font-style-keywords))
192 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) 149 (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask))
193 (, (format 150 (, (format
194 "Bitmask for whether a font is to be rendered in %s or not." 151 "Bitmask for whether a font is to be rendered in %s or not."
195 attr))) 152 attr)))
196 (defun (, (intern (format "font-%s-p" attr))) (fontobj) 153 (defun (, (intern (format "font-%s-p" attr))) (fontobj)
197 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) 154 (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr))
198 (if (/= 0 (& (font-style fontobj) 155 (if (/= 0 (& (font-style fontobj)
199 (, (intern (format "font-%s-mask" attr))))) 156 (, (intern (format "font-%s-mask" attr)))))
200 t 157 t
201 nil)) 158 nil))
202 (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) 159 (defun (, (intern (format "font-set-%s-p" attr))) (fontobj val)
203 (, (format "Set whether FONTOBJ will be renderd in `%s' or not." 160 (, (format "Set whether FONTOBJ will be renderd in `%s' or not."
204 attr)) 161 attr))
205 (cond 162 (if val
206 (val 163 (set-font-style fontobj (| (font-style fontobj)
207 (set-font-style fontobj (| (font-style fontobj) 164 (, (intern
208 (, (intern 165 (format "font-%s-mask" attr)))))
209 (format "font-%s-mask" attr)))))) 166 (set-font-style fontobj (logxor (font-style fontobj)
210 (((, (intern (format "font-%s-p" attr))) fontobj) 167 (, (intern
211 (set-font-style fontobj (- (font-style fontobj) 168 (format "font-%s-mask"
212 (, (intern 169 attr)))))))
213 (format "font-%s-mask" attr))))))))
214 )))) 170 ))))
215 171
216 (let ((mask 0)) 172 (let ((mask 0))
217 (define-new-mask bold (setq mask (1+ mask))) 173 (define-new-mask bold (setq mask (1+ mask)))
218 (define-new-mask italic (setq mask (1+ mask))) 174 (define-new-mask italic (setq mask (1+ mask)))
247 table)) 203 table))
248 204
249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
250 ;;; Utility functions 206 ;;; Utility functions
251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 (defsubst set-font-style-by-keywords (fontobj styles)
253 (make-local-variable 'font-func)
254 (declare (special font-func))
255 (if (listp styles)
256 (while styles
257 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
258 styles (cdr styles))
259 (and (fboundp font-func) (funcall font-func fontobj t)))
260 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
261 (and (fboundp font-func) (funcall font-func fontobj t))))
262
263 (defsubst font-properties-from-style (fontobj)
264 (let ((style (font-style fontobj))
265 (todo font-style-keywords)
266 type func retval)
267 (while todo
268 (setq func (cdr (cdr (car todo)))
269 type (car (pop todo)))
270 (if (funcall func fontobj)
271 (setq retval (cons type retval))))
272 retval))
273
274 (defun unique (list) 208 (defun unique (list)
275 (let ((retval) 209 (let ((retval)
276 (cur)) 210 (cur))
277 (while list 211 (while list
278 (setq cur (car list) 212 (setq cur (car list)
292 w1) 226 w1)
293 (t 227 (t
294 w2)))) 228 w2))))
295 229
296 (defun font-spatial-to-canonical (spec &optional device) 230 (defun font-spatial-to-canonical (spec &optional device)
297 "Convert SPEC (in inches, millimeters, points, or picas) into points" 231 "Convert SPEC (in inches, millimeters, points, or picas) into pixels"
298 ;; 1 in = 6 pa = 25.4 mm = 72 pt 232 ;; 1 in = 25.4 mm = 72 pt = 6 pa
299 (cond 233 (if (numberp spec)
300 ((numberp spec) 234 spec
301 spec)
302 ((null spec)
303 nil)
304 (t
305 (let ((num nil) 235 (let ((num nil)
306 (type nil) 236 (type nil)
307 ;; If for any reason we get null for any of this, default 237 ;; If for any reason we get null for any of this, default
308 ;; to 1024x768 resolution on a 17" screen 238 ;; to 1024x768 resolution on a 17" screen
309 (pix-width (float (or (device-pixel-width device) 1024))) 239 (pix-width (float (or (device-pixel-width device) 1024)))
328 (setq type "px" 258 (setq type "px"
329 spec spec))) 259 spec spec)))
330 (setq num (string-to-number spec)) 260 (setq num (string-to-number spec))
331 (cond 261 (cond
332 ((member type '("pixel" "px" "pix")) 262 ((member type '("pixel" "px" "pix"))
333 (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0)))) 263 (setq retval num
264 num nil))
334 ((member type '("point" "pt")) 265 ((member type '("point" "pt"))
335 (setq retval num)) 266 (setq retval (+ (* (/ pix-width mm-width)
267 (/ 25.4 72.0)
268 num))))
336 ((member type '("pica" "pa")) 269 ((member type '("pica" "pa"))
337 (setq retval (* num 12.0))) 270 (setq retval (* (/ pix-width mm-width)
271 (/ 25.4 6.0)
272 num)))
338 ((member type '("inch" "in")) 273 ((member type '("inch" "in"))
339 (setq retval (* num 72.0))) 274 (setq retval (* (/ pix-width mm-width)
275 (/ 25.4 1.0)
276 num)))
340 ((string= type "mm") 277 ((string= type "mm")
341 (setq retval (* num (/ 72.0 25.4)))) 278 (setq retval (* (/ pix-width mm-width)
279 num)))
342 ((string= type "cm") 280 ((string= type "cm")
343 (setq retval (* num 10 (/ 72.0 25.4)))) 281 (setq retval (* (/ pix-width mm-width)
344 (t 282 10
345 (setq retval num)) 283 num)))
284 (t (setq retval num))
346 ) 285 )
347 retval)))) 286 retval)))
348 287
349 288
350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
351 ;;; The main interface routines - constructors and accessor functions 290 ;;; The main interface routines - constructors and accessor functions
352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
353 (defun make-font (&rest args) 292 (defun make-font (&rest args)
354 (vector :family 293 (vector :family
355 (if (stringp (plist-get args :family)) 294 (if (stringp (nth 1 (memq :family args)))
356 (list (plist-get args :family)) 295 (list (nth 1 (memq :family args)))
357 (plist-get args :family)) 296 (nth 1 (memq :family args)))
358 :weight 297 :weight
359 (plist-get args :weight) 298 (nth 1 (memq :weight args))
360 :style 299 :style
361 (if (numberp (plist-get args :style)) 300 (if (numberp (nth 1 (memq :style args)))
362 (plist-get args :style) 301 (nth 1 (memq :style args))
363 0) 302 0)
364 :size 303 :size
365 (plist-get args :size) 304 (nth 1 (memq :size args))
366 :registry 305 :registry
367 (plist-get args :registry) 306 (nth 1 (memq :registry args))
368 :encoding 307 :encoding
369 (plist-get args :encoding))) 308 (nth 1 (memq :encoding args))))
309
310 (defsubst set-font-family (fontobj family)
311 (aset fontobj 1 family))
312
313 (defsubst set-font-weight (fontobj weight)
314 (aset fontobj 3 weight))
315
316 (defsubst set-font-style (fontobj style)
317 (aset fontobj 5 style))
318
319 (defsubst set-font-size (fontobj size)
320 (aset fontobj 7 size))
321
322 (defsubst set-font-registry (fontobj reg)
323 (aset fontobj 9 reg))
324
325 (defsubst set-font-encoding (fontobj enc)
326 (aset fontobj 11 enc))
327
328 (defsubst font-family (fontobj)
329 (aref fontobj 1))
330
331 (defsubst font-weight (fontobj)
332 (aref fontobj 3))
333
334 (defsubst font-style (fontobj)
335 (aref fontobj 5))
336
337 (defsubst font-size (fontobj)
338 (aref fontobj 7))
339
340 (defsubst font-registry (fontobj)
341 (aref fontobj 9))
342
343 (defsubst font-encoding (fontobj)
344 (aref fontobj 11))
370 345
371 (defun font-create-name (fontobj &optional device) 346 (defun font-create-name (fontobj &optional device)
372 (let* ((type (device-type device)) 347 (let* ((type (device-type device))
373 (func (car (cdr-safe (assq type font-window-system-mappings))))) 348 (func (car (cdr-safe (assq type font-window-system-mappings)))))
374 (and func (fboundp func) (funcall func fontobj device)))) 349 (and func (fboundp func) (funcall func fontobj device))))
375 350
376 ;;;###autoload
377 (defun font-create-object (fontname &optional device) 351 (defun font-create-object (fontname &optional device)
378 (let* ((type (device-type device)) 352 (let* ((type (device-type device))
379 (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) 353 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
380 (and func (fboundp func) (funcall func fontname device)))) 354 (and func (fboundp func) (funcall func fontname device))))
381 355
424 398
425 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
426 ;;; The window-system dependent code (TTY-style) 400 ;;; The window-system dependent code (TTY-style)
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
428 (defun tty-font-create-object (fontname &optional device) 402 (defun tty-font-create-object (fontname &optional device)
429 (make-font :size "12pt")) 403 )
430 404
431 (defun tty-font-create-plist (fontobj &optional device) 405 (defun tty-font-create-plist (fontobj &optional device)
432 (let ((styles (font-style fontobj)) 406 (let ((styles (font-style fontobj))
433 (weight (font-weight fontobj))) 407 (weight (font-weight fontobj)))
434 (list 408 (list
470 pixelsize - pointsize - resx - resy - spacing - avgwidth - 444 pixelsize - pointsize - resx - resy - spacing - avgwidth -
471 registry - encoding "\\'" 445 registry - encoding "\\'"
472 )))) 446 ))))
473 447
474 (defun x-font-create-object (fontname &optional device) 448 (defun x-font-create-object (fontname &optional device)
475 (let ((case-fold-search t)) 449 (if (or (not (stringp fontname))
476 (if (or (not (stringp fontname)) 450 (not (string-match font-x-font-regexp fontname)))
477 (not (string-match font-x-font-regexp fontname))) 451 (make-font)
478 (make-font) 452 (let ((family nil)
479 (let ((family nil) 453 (style nil)
480 (style nil) 454 (size nil)
481 (size nil) 455 (weight (match-string 1 fontname))
482 (weight (match-string 1 fontname)) 456 (slant (match-string 2 fontname))
483 (slant (match-string 2 fontname)) 457 (swidth (match-string 3 fontname))
484 (swidth (match-string 3 fontname)) 458 (adstyle (match-string 4 fontname))
485 (adstyle (match-string 4 fontname)) 459 (pxsize (match-string 5 fontname))
486 (pxsize (match-string 5 fontname)) 460 (ptsize (match-string 6 fontname))
487 (ptsize (match-string 6 fontname)) 461 (retval nil)
488 (retval nil) 462 (case-fold-search t)
489 (case-fold-search t) 463 )
490 ) 464 (if (not (string-match x-font-regexp-foundry-and-family fontname))
491 (if (not (string-match x-font-regexp-foundry-and-family fontname)) 465 nil
492 nil 466 (setq family (list (match-string 1 fontname))))
493 (setq family (list (downcase (match-string 1 fontname))))) 467 (if (string= "*" weight) (setq weight nil))
494 (if (string= "*" weight) (setq weight nil)) 468 (if (string= "*" slant) (setq slant nil))
495 (if (string= "*" slant) (setq slant nil)) 469 (if (string= "*" swidth) (setq swidth nil))
496 (if (string= "*" swidth) (setq swidth nil)) 470 (if (string= "*" adstyle) (setq adstyle nil))
497 (if (string= "*" adstyle) (setq adstyle nil)) 471 (if (string= "*" pxsize) (setq pxsize nil))
498 (if (string= "*" pxsize) (setq pxsize nil)) 472 (if (string= "*" ptsize) (setq ptsize nil))
499 (if (string= "*" ptsize) (setq ptsize nil)) 473 (if ptsize (setq size (format "%dpt" (/ (string-to-int ptsize) 10))))
500 (if ptsize (setq size (/ (string-to-int ptsize) 10))) 474 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
501 (if (and (not size) pxsize) (setq size (concat pxsize "px"))) 475 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
502 (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) 476 (if (and adstyle (not (equal adstyle "")))
503 (if (and adstyle (not (equal adstyle ""))) 477 (setq family (append family (list adstyle))))
504 (setq family (append family (list (downcase adstyle))))) 478 (setq retval (make-font :family family
505 (setq retval (make-font :family family 479 :weight weight
506 :weight weight 480 :size size))
507 :size size)) 481 (font-set-bold-p retval (eq :bold weight))
508 (set-font-bold-p retval (eq :bold weight)) 482 (cond
509 (cond 483 ((null slant) nil)
510 ((null slant) nil) 484 ((member slant '("i" "I"))
511 ((member slant '("i" "I")) 485 (font-set-italic-p retval t))
512 (set-font-italic-p retval t)) 486 ((member slant '("o" "O"))
513 ((member slant '("o" "O")) 487 (font-set-oblique-p retval t)))
514 (set-font-oblique-p retval t))) 488 retval)))
515 retval))))
516 489
517 (defun x-font-families-for-device (&optional device no-resetp) 490 (defun x-font-families-for-device (&optional device no-resetp)
518 (condition-case () 491 (condition-case ()
519 (require 'x-font-menu) 492 (require 'x-font-menu)
520 (error nil)) 493 (error nil))
528 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 501 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
529 (aref menu 0))) 502 (aref menu 0)))
530 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 503 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
531 (aref menu 1)))) 504 (aref menu 1))))
532 (sort (unique (nconc scaled normal)) 'string-lessp)))) 505 (sort (unique (nconc scaled normal)) 'string-lessp))))
533 (cons "monospace" (mapcar 'car font-family-mappings)))) 506 (mapcar 'car font-family-mappings)))
534 507
535 (defvar font-default-cache nil) 508 (defvar font-default-cache nil)
536 509
537 ;;;###autoload
538 (defun font-default-font-for-device (&optional device) 510 (defun font-default-font-for-device (&optional device)
539 (or device (setq device (selected-device))) 511 (or device (setq device (selected-device)))
540 (if font-running-xemacs 512 (if font-running-xemacs
541 (font-truename 513 (font-truename
542 (make-font-specifier 514 (make-font-specifier
543 (face-font-name 'default device))) 515 (face-font-name 'default device)))
544 (let ((font (cdr-safe (assq 'font (frame-parameters device))))) 516 (cdr-safe (assq 'font (frame-parameters device)))))
545 (if (and (fboundp 'fontsetp) (fontsetp font)) 517
546 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
547 font))))
548
549 ;;;###autoload
550 (defun font-default-object-for-device (&optional device) 518 (defun font-default-object-for-device (&optional device)
551 (let ((font (font-default-font-for-device device))) 519 (let ((font (font-default-font-for-device device)))
552 (or (cdr-safe 520 (or (cdr-safe
553 (assoc font font-default-cache)) 521 (assoc font font-default-cache))
554 (progn 522 (progn
555 (setq font-default-cache (cons (cons font 523 (setq font-default-cache (cons (cons font
556 (font-create-object font)) 524 (font-create-object font))
557 font-default-cache)) 525 font-default-cache))
558 (cdr-safe (assoc font font-default-cache)))))) 526 (cdr-safe (assoc font font-default-cache))))))
559 527
560 ;;;###autoload
561 (defun font-default-family-for-device (&optional device) 528 (defun font-default-family-for-device (&optional device)
562 (or device (setq device (selected-device))) 529 (or device (setq device (selected-device)))
563 (font-family (font-default-object-for-device device))) 530 (font-family (font-default-object-for-device device)))
564 531
565 ;;;###autoload
566 (defun font-default-size-for-device (&optional device) 532 (defun font-default-size-for-device (&optional device)
567 (or device (setq device (selected-device))) 533 (or device (setq device (selected-device)))
568 ;; face-height isn't the right thing (always 1 pixel too high?) 534 ;; face-height isn't the right thing (always 1 pixel too high?)
569 ;; (if font-running-xemacs 535 ;; (if font-running-xemacs
570 ;; (format "%dpx" (face-height 'default device)) 536 ;; (format "%dpx" (face-height 'default device))
571 (font-size (font-default-object-for-device device))) 537 (font-size (font-default-object-for-device device)))
572 538
573 (defun x-font-create-name (fontobj &optional device) 539 (defun x-font-create-name (fontobj &optional device)
574 (if (and (not (or (font-family fontobj) 540 (if (and (not (or (font-family fontobj)
575 (font-weight fontobj) 541 (font-weight fontobj)
576 (font-size fontobj) 542 (font-size fontobj)
577 (font-registry fontobj) 543 (font-registry fontobj)
578 (font-encoding fontobj))) 544 (font-encoding fontobj)))
579 (= (font-style fontobj) 0)) 545 (not (font-bold-p fontobj))
546 (not (font-italic-p fontobj)))
580 (face-font 'default) 547 (face-font 'default)
581 (or device (setq device (selected-device))) 548 (or device (setq device (selected-device)))
582 (let ((family (or (font-family fontobj) 549 (let ((family (or (font-family fontobj)
583 (font-default-family-for-device device) 550 (font-default-family-for-device device)
584 (x-font-families-for-device device))) 551 (x-font-families-for-device device)))
585 (weight (or (font-weight fontobj) :medium)) 552 (weight (or (font-weight fontobj) :medium))
586 (style (font-style fontobj)) 553 (style (font-style fontobj))
587 (size (or (if font-running-xemacs 554 (size (or (font-size fontobj) (font-default-size-for-device device)))
588 (font-size fontobj))
589 (font-default-size-for-device device)))
590 (registry (or (font-registry fontobj) "*")) 555 (registry (or (font-registry fontobj) "*"))
591 (encoding (or (font-encoding fontobj) "*"))) 556 (encoding (or (font-encoding fontobj) "*")))
592 (if (stringp family) 557 (if (stringp family)
593 (setq family (list family))) 558 (setq family (list family)))
594 (setq weight (font-higher-weight weight 559 (setq weight (font-higher-weight weight
617 (let ((x (length cur-family))) 582 (let ((x (length cur-family)))
618 (while (> x 0) 583 (while (> x 0)
619 (if (= ?- (aref cur-family (1- x))) 584 (if (= ?- (aref cur-family (1- x)))
620 (aset cur-family (1- x) ? )) 585 (aset cur-family (1- x) ? ))
621 (setq x (1- x)))) 586 (setq x (1- x))))
622 ;; We treat oblique and italic as equivalent. Don't ask. 587 (setq font-name (format "-*-%s-%s-%s-*-*-%s-*-*-*-*-*-%s-%s"
623 (let ((slants '("o" "i"))) 588 cur-family weight
624 (while (and slants (not done)) 589 (if (font-italic-p fontobj)
625 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s" 590 "i"
626 cur-family weight 591 "r")
627 (if (or (font-italic-p fontobj) 592 (if size (int-to-string size) "*")
628 (font-oblique-p fontobj)) 593 registry
629 (car slants) 594 encoding
630 "r") 595 )
631 (if size 596 done (try-font-name font-name device))))
632 (int-to-string (* 10 size)) "*")
633 registry
634 encoding
635 )
636 slants (cdr slants)
637 done (try-font-name font-name device))))))
638 (if done font-name))))) 597 (if done font-name)))))
639 598
640 599
641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
642 ;;; The window-system dependent code (NS-style) 601 ;;; The window-system dependent code (NS-style)
643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
644 (defun ns-font-families-for-device (&optional device no-resetp) 603 (defun ns-font-families-for-device (&optional device no-resetp)
645 ;; For right now, assume we are going to have the same storage for 604 ;; For right now, assume we are going to have the same storage for
646 ;; device fonts for NS as we do for X. Is this a valid assumption? 605 ;; device fonts for NS as we do for X. Is this a valid assumption?
647 (or device (setq device (selected-device))) 606 (or device (setq device (selected-device)))
648 (if (boundp 'device-fonts-cache) 607 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
649 (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) 608 (if (and (not menu) (not no-resetp))
650 (if (and (not menu) (not no-resetp)) 609 (progn
651 (progn 610 (reset-device-font-menus device)
652 (reset-device-font-menus device) 611 (ns-font-families-for-device device t))
653 (ns-font-families-for-device device t)) 612 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
654 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 613 (aref menu 0)))
655 (aref menu 0))) 614 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
656 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 615 (aref menu 1))))
657 (aref menu 1)))) 616 (sort (unique (nconc scaled normal)) 'string-lessp)))))
658 (sort (unique (nconc scaled normal)) 'string-lessp))))))
659 617
660 (defun ns-font-create-name (fontobj &optional device) 618 (defun ns-font-create-name (fontobj &optional device)
661 (let ((family (or (font-family fontobj) 619 (let ((family (or (font-family fontobj)
662 (ns-font-families-for-device device))) 620 (ns-font-families-for-device device)))
663 (weight (or (font-weight fontobj) :medium)) 621 (weight (or (font-weight fontobj) :medium))
666 (registry (or (font-registry fontobj) "*")) 624 (registry (or (font-registry fontobj) "*"))
667 (encoding (or (font-encoding fontobj) "*"))) 625 (encoding (or (font-encoding fontobj) "*")))
668 ;; Create a font, wow! 626 ;; Create a font, wow!
669 (if (stringp family) 627 (if (stringp family)
670 (setq family (list family))) 628 (setq family (list family)))
671 (if (or (symbolp style) (numberp style)) 629 (if (symbolp style)
672 (setq style (list style))) 630 (setq style (list style)))
673 (setq weight (font-higher-weight weight (car-safe (memq :bold style)))) 631 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
674 (if (stringp size) 632 (if (stringp size)
675 (setq size (font-spatial-to-canonical size device))) 633 (setq size (font-spatial-to-canonical size device)))
676 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings)) 634 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
695 (setq font-name "UNKNOWN FORMULA GOES HERE" 653 (setq font-name "UNKNOWN FORMULA GOES HERE"
696 done (try-font-name font-name device)))) 654 done (try-font-name font-name device))))
697 (if done font-name)))) 655 (if done font-name))))
698 656
699 657
700 ;;; Cache building code
701 ;;;###autoload
702 (defun x-font-build-cache (&optional device)
703 (let ((hashtable (make-hash-table :test 'equal :size 15))
704 (fonts (mapcar 'x-font-create-object
705 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
706 (plist nil)
707 (cur nil))
708 (while fonts
709 (setq cur (car fonts)
710 fonts (cdr fonts)
711 plist (cl-gethash (car (font-family cur)) hashtable))
712 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
713 (setq plist (plist-put plist 'weights (cons (font-weight cur)
714 (plist-get plist 'weights)))))
715 (if (not (member (font-size cur) (plist-get plist 'sizes)))
716 (setq plist (plist-put plist 'sizes (cons (font-size cur)
717 (plist-get plist 'sizes)))))
718 (if (and (font-oblique-p cur)
719 (not (memq 'oblique (plist-get plist 'styles))))
720 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
721 (if (and (font-italic-p cur)
722 (not (memq 'italic (plist-get plist 'styles))))
723 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
724 (cl-puthash (car (font-family cur)) plist hashtable))
725 hashtable))
726
727
728 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
729 ;;; Now overwrite the original copy of set-face-font with our own copy that 659 ;;; Now overwrite the original copy of set-face-font with our own copy that
730 ;;; can deal with either syntax. 660 ;;; can deal with either syntax.
731 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 661 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
732 ;;; ###autoload
733 (defun font-set-face-font (&optional face font &rest args) 662 (defun font-set-face-font (&optional face font &rest args)
734 (cond 663 (if (interactive-p)
735 ((and (vectorp font) (= (length font) 12)) 664 (call-interactively 'font-original-set-face-font)
736 (let ((font-name (font-create-name font))) 665 (cond
737 (set-face-property face 'font-specification font) 666 ((and (vectorp font) (= (length font) 12))
738 (cond 667 (let ((font-name (font-create-name font)))
739 ((null font-name) ; No matching font! 668 (set-face-property face 'font-specification font)
740 nil) 669 (cond
741 ((listp font-name) ; For TTYs 670 ((null font-name) ; No matching font!
742 (let (cur) 671 nil)
743 (while font-name 672 ((listp font-name) ; For TTYs
744 (setq cur (car font-name) 673 (let (cur)
745 font-name (cdr font-name)) 674 (while font-name
746 (apply 'set-face-property face (car cur) (cdr cur) args)))) 675 (setq cur (car font-name)
747 (font-running-xemacs 676 font-name (cdr font-name))
748 (apply 'set-face-font face font-name args) 677 (apply 'set-face-property face (car cur) (cdr cur) args))))
749 (apply 'set-face-underline-p face (font-underline-p font) args) 678 (font-running-xemacs
750 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) 679 (apply 'font-original-set-face-font face font-name args)
751 (fboundp 'set-face-display-table)) 680 (apply 'set-face-underline-p face (font-underline-p font) args)
752 (apply 'set-face-display-table 681 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
753 face font-caps-display-table args)) 682 (fboundp 'set-face-display-table))
754 (apply 'set-face-property face 'strikethru (or 683 (apply 'set-face-display-table
755 (font-linethrough-p font) 684 face font-caps-display-table args))
756 (font-strikethru-p font)) 685 (apply 'set-face-property face 'strikethru (or
757 args)) 686 (font-linethrough-p font)
758 (t 687 (font-strikethru-p font))
759 (condition-case nil 688 args))
760 (apply 'set-face-font face font-name args) 689 (t
761 (error 690 (condition-case nil
762 (let ((args (car-safe args))) 691 (apply 'font-original-set-face-font face font-name args)
763 (and (or (font-bold-p font) 692 (error
764 (memq (font-weight font) '(:bold :demi-bold))) 693 (let ((args (car-safe args)))
765 (make-face-bold face args t)) 694 (and (or (font-bold-p font)
766 (and (font-italic-p font) (make-face-italic face args t))))) 695 (memq (font-weight font) '(:bold :demi-bold)))
767 (apply 'set-face-underline-p face (font-underline-p font) args))))) 696 (make-face-bold face args t))
768 (t 697 (and (font-italic-p font) (make-face-italic face args t)))))
769 ;; Let the original set-face-font signal any errors 698 (apply 'set-face-underline-p face (font-underline-p font) args)))))
770 (set-face-property face 'font-specification nil) 699 (t
771 (apply 'set-face-font face font args)))) 700 ;; Let the original set-face-font signal any errors
701 (set-face-property face 'font-specification nil)
702 (apply 'font-original-set-face-font face font args)))))
772 703
773 704
774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 705 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
775 ;;; Now for emacsen specific stuff 706 ;;; Now for emacsen specific stuff
776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 707 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 g 0 903 g 0
973 b 0))) 904 b 0)))
974 (list r g b) )) 905 (list r g b) ))
975 906
976 (defsubst font-rgb-color-p (obj) 907 (defsubst font-rgb-color-p (obj)
977 (or (and (vectorp obj) 908 (and (vectorp obj)
978 (= (length obj) 4) 909 (= (length obj) 4)
979 (eq (aref obj 0) 'rgb)))) 910 (eq (aref obj 0) 'rgb)))
980 911
981 (defsubst font-rgb-color-red (obj) (aref obj 1)) 912 (defsubst font-rgb-color-red (obj) (aref obj 1))
982 (defsubst font-rgb-color-green (obj) (aref obj 2)) 913 (defsubst font-rgb-color-green (obj) (aref obj 2))
983 (defsubst font-rgb-color-blue (obj) (aref obj 3)) 914 (defsubst font-rgb-color-blue (obj) (aref obj 3))
984 915
989 into their components. 920 into their components.
990 RGB values for color names are looked up in the rgb.txt file. 921 RGB values for color names are looked up in the rgb.txt file.
991 The variable x-library-search-path is use to locate the rgb.txt file." 922 The variable x-library-search-path is use to locate the rgb.txt file."
992 (let ((case-fold-search t)) 923 (let ((case-fold-search t))
993 (cond 924 (cond
994 ((and (font-rgb-color-p color) (floatp (aref color 1))) 925 ((font-rgb-color-p color)
926 (list (* 65535 (font-rgb-color-red color))
927 (* 65535 (font-rgb-color-green color))
928 (* 65535 (font-rgb-color-blue color))))
929 ((and (vectorp color) (= 3 (length color)) (floatp (aref color 0)))
995 (list (* 65535 (aref color 0)) 930 (list (* 65535 (aref color 0))
996 (* 65535 (aref color 1)) 931 (* 65535 (aref color 1))
997 (* 65535 (aref color 2)))) 932 (* 65535 (aref color 2))))
998 ((font-rgb-color-p color)
999 (list (font-rgb-color-red color)
1000 (font-rgb-color-green color)
1001 (font-rgb-color-blue color)))
1002 ((and (vectorp color) (= 3 (length color))) 933 ((and (vectorp color) (= 3 (length color)))
1003 (list (aref color 0) (aref color 1) (aref color 2))) 934 (list (aref color 0) (aref color 1) (aref color 2)))
1004 ((and (listp color) (= 3 (length color)) (floatp (car color))) 935 ((and (listp color) (= 3 (length color)) (floatp (car color)))
1005 (mapcar (function (lambda (x) (* x 65535))) color)) 936 (mapcar (function (lambda (x) (* x 65535))) color))
1006 ((and (listp color) (= 3 (length color))) 937 ((and (listp color) (= 3 (length color)))
1066 (cdr-safe (aref colors nearest)))) 997 (cdr-safe (aref colors nearest))))
1067 998
1068 (defun font-normalize-color (color &optional device) 999 (defun font-normalize-color (color &optional device)
1069 "Return an RGB tuple, given any form of input. If an error occurs, black 1000 "Return an RGB tuple, given any form of input. If an error occurs, black
1070 is returned." 1001 is returned."
1071 (case (device-type device) 1002 (cond
1072 ((x pm) 1003 ((eq (device-type device) 'x)
1073 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color))) 1004 (apply 'format "#%04x%04x%04x" (font-color-rgb-components color)))
1074 (win32 1005 ((eq (device-type device) 'tty)
1075 (let* ((rgb (font-color-rgb-components color))
1076 (color (apply 'format "#%02x%02x%02x" rgb)))
1077 (win32-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
1078 color))
1079 (tty
1080 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1006 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1081 (ns 1007 ((eq (device-type device) 'ns)
1082 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1008 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
1083 (font-color-rgb-components color)))) 1009 (font-color-rgb-components color))))
1084 (apply 'format "RGB%02x%02x%02xff" vals))) 1010 (apply 'format "RGB%02x%02x%02ff" vals)))
1085 (otherwise 1011 (t "black")))
1086 color)))
1087 1012
1088 (defun font-set-face-background (&optional face color &rest args) 1013 (defun font-set-face-background (&optional face color &rest args)
1089 (interactive) 1014 (interactive)
1090 (condition-case nil 1015 (if (interactive-p)
1091 (cond 1016 (call-interactively 'font-original-set-face-background)
1092 ((or (font-rgb-color-p color) 1017 (cond
1093 (string-match "^#[0-9a-fA-F]+$" color)) 1018 ((font-rgb-color-p color)
1094 (apply 'set-face-background face 1019 (apply 'font-original-set-face-background face
1095 (font-normalize-color color) args)) 1020 (font-normalize-color color) args))
1096 (t 1021 (t
1097 (apply 'set-face-background face color args))) 1022 (apply 'font-original-set-face-background face color args)))))
1098 (error nil)))
1099 1023
1100 (defun font-set-face-foreground (&optional face color &rest args) 1024 (defun font-set-face-foreground (&optional face color &rest args)
1101 (interactive) 1025 (interactive)
1102 (condition-case nil 1026 (if (interactive-p)
1103 (cond 1027 (call-interactively 'font-original-set-face-foreground)
1104 ((or (font-rgb-color-p color) 1028 (cond
1105 (string-match "^#[0-9a-fA-F]+$" color)) 1029 ((font-rgb-color-p color)
1106 (apply 'set-face-foreground face (font-normalize-color color) args)) 1030 (apply 'font-original-set-face-foreground face
1107 (t 1031 (font-normalize-color color) args))
1108 (apply 'set-face-foreground face color args))) 1032 (t
1109 (error nil))) 1033 (apply 'font-original-set-face-foreground face color args)))))
1034
1035 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1036 ;;; Do the actual overwriting of some functions
1037 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1038 (defmacro font-overwrite-fn (func)
1039 (` (let ((our-func (intern (format "font-%s" (, func))))
1040 (new-func (intern (format "font-original-%s" (, func))))
1041 (old-func (and (fboundp (, func)) (symbol-function (, func)))))
1042 (if (not (fboundp new-func))
1043 (progn
1044 (if old-func
1045 (fset new-func old-func)
1046 (fset new-func 'ignore))
1047 (fset (, func) our-func))))))
1048
1049 (font-overwrite-fn 'set-face-foreground)
1050 (font-overwrite-fn 'set-face-background)
1051 (font-overwrite-fn 'set-face-font)
1110 1052
1111 (provide 'font) 1053 (provide 'font)