Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 1ce6082ce73f
children 821dec489c24
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/03 16:43:49 3 ;; Created: 1997/01/22 19:31:17
4 ;; Version: 1.22 4 ;; Version: 1.26
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 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 10 ;;;
11 ;;; This file is part of GNU Emacs. 11 ;;; This file is part of GNU Emacs.
12 ;;; 12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;;; 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 14 ;;; it under the terms of the GNU General Public License as published by
46 ;;; Not much should need to be modified 46 ;;; Not much should need to be modified
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 48 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
49 "Whether we are running in XEmacs or not.") 49 "Whether we are running in XEmacs or not.")
50 50
51 (defmacro defkeyword (keyword &optional docstring) 51 (defmacro define-font-keywords (&rest keys)
52 (list 'defconst keyword (list 'quote keyword) 52 (`
53 (or docstring "A keyword"))) 53 (eval-and-compile
54 (let ((keywords (quote (, keys))))
55 (while keywords
56 (or (boundp (car keywords))
57 (set (car keywords) (car keywords)))
58 (setq keywords (cdr keywords)))))))
54 59
55 (defconst font-window-system-mappings 60 (defconst font-window-system-mappings
56 '((x . (x-font-create-name x-font-create-object)) 61 '((x . (x-font-create-name x-font-create-object))
57 (ns . (ns-font-create-name ns-font-create-object)) 62 (ns . (ns-font-create-name ns-font-create-object))
63 (win32 . (x-font-create-name x-font-create-object)) ; Change? FIXME
64 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
58 (tty . (tty-font-create-plist tty-font-create-object))) 65 (tty . (tty-font-create-plist tty-font-create-object)))
59 "An assoc list mapping device types to the function used to create 66 "An assoc list mapping device types to the function used to create
60 a font name from a font structure.") 67 a font name from a font structure.")
61 68
62 (defconst ns-font-weight-mappings 69 (defconst ns-font-weight-mappings
125 ("cursive" . ("sirene" 132 ("cursive" . ("sirene"
126 "zapf chancery")) 133 "zapf chancery"))
127 ) 134 )
128 "A list of font family mappings.") 135 "A list of font family mappings.")
129 136
130 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.") 137 (define-font-keywords :family :style :size :registry :encoding)
131 138
132 (defkeyword :weight "Keyword specifying the font weight of a FONTOBJ.") 139 (define-font-keywords
133 (defkeyword :extra-light) 140 :weight :extra-light :light :demi-light :medium :normal :demi-bold
134 (defkeyword :light) 141 :bold :extra-bold)
135 (defkeyword :demi-light)
136 (defkeyword :medium)
137 (defkeyword :normal)
138 (defkeyword :demi-bold)
139 (defkeyword :bold)
140 (defkeyword :extra-bold)
141
142 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.")
143 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.")
144 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.")
145 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.")
146 142
147 (defvar font-style-keywords nil) 143 (defvar font-style-keywords nil)
148 144
149 (defsubst set-font-family (fontobj family) 145 (defsubst set-font-family (fontobj family)
150 (aset fontobj 1 family)) 146 (aset fontobj 1 family))
1056 (cdr-safe (aref colors nearest)))) 1052 (cdr-safe (aref colors nearest))))
1057 1053
1058 (defun font-normalize-color (color &optional device) 1054 (defun font-normalize-color (color &optional device)
1059 "Return an RGB tuple, given any form of input. If an error occurs, black 1055 "Return an RGB tuple, given any form of input. If an error occurs, black
1060 is returned." 1056 is returned."
1061 (cond 1057 (case (device-type device)
1062 ((eq (device-type device) 'x) 1058 ((x pm win32)
1063 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color))) 1059 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
1064 ((eq (device-type device) 'tty) 1060 (tty
1065 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1061 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1066 ((eq (device-type device) 'ns) 1062 (ns
1067 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1063 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
1068 (font-color-rgb-components color)))) 1064 (font-color-rgb-components color))))
1069 (apply 'format "RGB%02x%02x%02xff" vals))) 1065 (apply 'format "RGB%02x%02x%02xff" vals)))
1070 (t "black"))) 1066 (otherwise "black")))
1071 1067
1072 (defun font-set-face-background (&optional face color &rest args) 1068 (defun font-set-face-background (&optional face color &rest args)
1073 (interactive) 1069 (interactive)
1074 (if (interactive-p) 1070 (if (interactive-p)
1075 (call-interactively 'font-original-set-face-background) 1071 (call-interactively 'font-original-set-face-background)