/[cmucl]/src/clx/fonts.lisp
ViewVC logotype

Contents of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.6: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;;
4 ;;; TEXAS INSTRUMENTS INCORPORATED
5 ;;; P.O. BOX 2909
6 ;;; AUSTIN, TEXAS 78769
7 ;;;
8 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9 ;;;
10 ;;; Permission is granted to any individual or institution to use, copy, modify,
11 ;;; and distribute this software, provided that this complete copyright and
12 ;;; permission notice is maintained, intact, in all copies and supporting
13 ;;; documentation.
14 ;;;
15 ;;; Texas Instruments Incorporated provides this software "as is" without
16 ;;; express or implied warranty.
17 ;;;
18
19 #+cmu
20 (ext:file-comment "$Id: fonts.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $")
21
22 (in-package :xlib)
23
24 ;; The char-info stuff is here instead of CLX because of uses of int16->card16.
25
26 ; To allow efficient storage representations, the type char-info is not
27 ; required to be a structure.
28
29 ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
30
31 ;(defun char-<metric> (font index)
32 ; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
33 ; ;; (or an in-bounds index on a pseudo font), although returning zero or
34 ; ;; signalling might be better.
35 ; (declare (type font font)
36 ; (type integer index)
37 ; (clx-values (or null integer))))
38
39 ;(defun max-char-<metric> (font)
40 ; ;; Note: I have tentatively chosen separate accessors over allowing :min and
41 ; ;; :max as an index above.
42 ; (declare (type font font)
43 ; (clx-values integer)))
44
45 ;(defun min-char-<metric> (font)
46 ; (declare (type font font)
47 ; (clx-values integer)))
48
49 ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
50
51 (deftype char-info-vec () '(simple-array int16 (*)))
52
53 (macrolet ((def-char-info-accessors (useless-name &body fields)
54 `(within-definition (,useless-name def-char-info-accessors)
55 ,@(do ((field fields (cdr field))
56 (n 0 (1+ n))
57 (name) (type)
58 (result nil))
59 ((endp field) result)
60 (setq name (xintern 'char- (caar field)))
61 (setq type (cadar field))
62 (flet ((from (form)
63 (if (eq type 'int16)
64 form
65 `(,(xintern 'int16-> type) ,form))))
66 (push
67 `(defun ,name (font index)
68 (declare (type font font)
69 (type array-index index))
70 (declare (clx-values (or null ,type)))
71 (when (and (font-name font)
72 (index>= (font-max-char font) index (font-min-char font)))
73 (the ,type
74 ,(from
75 `(the int16
76 (let ((char-info-vector (font-char-infos font)))
77 (declare (type char-info-vec char-info-vector))
78 (if (index-zerop (length char-info-vector))
79 ;; Fixed width font
80 (aref (the char-info-vec
81 (font-max-bounds font))
82 ,n)
83 ;; Variable width font
84 (aref char-info-vector
85 (index+
86 (index*
87 6
88 (index-
89 index
90 (font-min-char font)))
91 ,n)))))))))
92 result)
93 (setq name (xintern 'min-char- (caar field)))
94 (push
95 `(defun ,name (font)
96 (declare (type font font))
97 (declare (clx-values (or null ,type)))
98 (when (font-name font)
99 (the ,type
100 ,(from
101 `(the int16
102 (aref (the char-info-vec (font-min-bounds font))
103 ,n))))))
104 result)
105 (setq name (xintern 'max-char- (caar field)))
106 (push
107 `(defun ,name (font)
108 (declare (type font font))
109 (declare (clx-values (or null ,type)))
110 (when (font-name font)
111 (the ,type
112 ,(from
113 `(the int16
114 (aref (the char-info-vec (font-max-bounds font))
115 ,n))))))
116 result)))
117
118 (defun make-char-info
119 (&key ,@(mapcar
120 #'(lambda (field)
121 `(,(car field) (required-arg ,(car field))))
122 fields))
123 (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
124 (let ((result (make-array ,(length fields) :element-type 'int16)))
125 (declare (type char-info-vec result))
126 ,@(do* ((field fields (cdr field))
127 (var (caar field) (caar field))
128 (type (cadar field) (cadar field))
129 (n 0 (1+ n))
130 (result nil))
131 ((endp field) (nreverse result))
132 (push `(setf (aref result ,n)
133 ,(if (eq type 'int16)
134 var
135 `(,(xintern type '->int16) ,var)))
136 result))
137 result)))))
138 (def-char-info-accessors ignore
139 (left-bearing int16)
140 (right-bearing int16)
141 (width int16)
142 (ascent int16)
143 (descent int16)
144 (attributes card16)))
145
146 (defun open-font (display name)
147 ;; Font objects may be cached and reference counted locally within the display
148 ;; object. This function might not execute a with-display if the font is cached.
149 ;; The protocol QueryFont request happens on-demand under the covers.
150 (declare (type display display)
151 (type stringable name))
152 (declare (clx-values font))
153 (let* ((name-string (string-downcase (string name)))
154 (font (car (member name-string (display-font-cache display)
155 :key 'font-name
156 :test 'equal)))
157 font-id)
158 (unless font
159 (setq font (make-font :display display :name name-string))
160 (setq font-id (allocate-resource-id display font 'font))
161 (setf (font-id-internal font) font-id)
162 (with-buffer-request (display +x-openfont+)
163 (resource-id font-id)
164 (card16 (length name-string))
165 (pad16 nil)
166 (string name-string))
167 (push font (display-font-cache display)))
168 (incf (font-reference-count font))
169 (unless (font-font-info-internal font)
170 (query-font font))
171 font))
172
173 (defun open-font-internal (font)
174 ;; Called "under the covers" to open a font object
175 (declare (type font font))
176 (declare (clx-values resource-id))
177 (let* ((name-string (font-name font))
178 (display (font-display font))
179 (id (allocate-resource-id display font 'font)))
180 (setf (font-id-internal font) id)
181 (with-buffer-request (display +x-openfont+)
182 (resource-id id)
183 (card16 (length name-string))
184 (pad16 nil)
185 (string name-string))
186 (push font (display-font-cache display))
187 (incf (font-reference-count font))
188 id))
189
190 (defun discard-font-info (font)
191 ;; Discards any state that can be re-obtained with QueryFont. This is
192 ;; simply a performance hint for memory-limited systems.
193 (declare (type font font))
194 (setf (font-font-info-internal font) nil
195 (font-char-infos-internal font) nil))
196
197 (defun query-font (font)
198 ;; Internal function called by font and char info accessors
199 (declare (type font font))
200 (declare (clx-values font-info))
201 (let ((display (font-display font))
202 font-id
203 font-info
204 props)
205 (setq font-id (font-id font)) ;; May issue an open-font request
206 (with-buffer-request-and-reply (display +x-queryfont+ 60)
207 ((resource-id font-id))
208 (let* ((min-byte2 (card16-get 40))
209 (max-byte2 (card16-get 42))
210 (min-byte1 (card8-get 49))
211 (max-byte1 (card8-get 50))
212 (min-char min-byte2)
213 (max-char (index+ (index-ash max-byte1 8) max-byte2))
214 (nfont-props (card16-get 46))
215 (nchar-infos (index* (card32-get 56) 6))
216 (char-info (make-array nchar-infos :element-type 'int16)))
217 (setq font-info
218 (make-font-info
219 :direction (member8-get 48 :left-to-right :right-to-left)
220 :min-char min-char
221 :max-char max-char
222 :min-byte1 min-byte1
223 :max-byte1 max-byte1
224 :min-byte2 min-byte2
225 :max-byte2 max-byte2
226 :all-chars-exist-p (boolean-get 51)
227 :default-char (card16-get 44)
228 :ascent (int16-get 52)
229 :descent (int16-get 54)
230 :min-bounds (char-info-get 8)
231 :max-bounds (char-info-get 24)))
232 (setq props (sequence-get :length (index* 2 nfont-props) :format int32
233 :result-type 'list :index 60))
234 (sequence-get :length nchar-infos :format int16 :data char-info
235 :index (index+ 60 (index* 2 nfont-props 4)))
236 (setf (font-char-infos-internal font) char-info)
237 (setf (font-font-info-internal font) font-info)))
238 ;; Replace atom id's with keywords in the plist
239 (do ((p props (cddr p)))
240 ((endp p))
241 (setf (car p) (atom-name display (car p))))
242 (setf (font-info-properties font-info) props)
243 font-info))
244
245 (defun close-font (font)
246 ;; This might not generate a protocol request if the font is reference
247 ;; counted locally.
248 (declare (type font font))
249 (when (and (not (plusp (decf (font-reference-count font))))
250 (font-id-internal font))
251 (let ((display (font-display font))
252 (id (font-id-internal font)))
253 (declare (type display display))
254 ;; Remove font from cache
255 (setf (display-font-cache display) (delete font (display-font-cache display)))
256 ;; Close the font
257 (with-buffer-request (display +x-closefont+)
258 (resource-id id)))))
259
260 (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
261 (declare (type display display)
262 (type string pattern)
263 (type card16 max-fonts)
264 (type t result-type)) ;; CL type
265 (declare (clx-values (clx-sequence string)))
266 (let ((string (string pattern)))
267 (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
268 ((card16 max-fonts (length string))
269 (string string))
270 (values
271 (read-sequence-string
272 buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
273
274 (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
275 ;; Note: Was called list-fonts-with-info.
276 ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
277 ;; no per-character metrics and no resource-ids. These pseudo fonts will be
278 ;; converted (internally) to real fonts dynamically as needed, by issuing an
279 ;; OpenFont request. However, the OpenFont might fail, in which case the
280 ;; invalid-font error can arise.
281 (declare (type display display)
282 (type string pattern)
283 (type card16 max-fonts)
284 (type t result-type)) ;; CL type
285 (declare (clx-values (clx-sequence font)))
286 (let ((string (string pattern))
287 (result nil))
288 (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
289 :sizes (8 16) :multiple-reply t)
290 ((card16 max-fonts (length string))
291 (string string))
292 (cond ((zerop (card8-get 1)) t)
293 (t
294 (let* ((name-len (card8-get 1))
295 (min-byte2 (card16-get 40))
296 (max-byte2 (card16-get 42))
297 (min-byte1 (card8-get 49))
298 (max-byte1 (card8-get 50))
299 (min-char min-byte2)
300 (max-char (index+ (index-ash max-byte1 8) max-byte2))
301 (nfont-props (card16-get 46))
302 (font
303 (make-font
304 :display display
305 :name nil
306 :font-info-internal
307 (make-font-info
308 :direction (member8-get 48 :left-to-right :right-to-left)
309 :min-char min-char
310 :max-char max-char
311 :min-byte1 min-byte1
312 :max-byte1 max-byte1
313 :min-byte2 min-byte2
314 :max-byte2 max-byte2
315 :all-chars-exist-p (boolean-get 51)
316 :default-char (card16-get 44)
317 :ascent (int16-get 52)
318 :descent (int16-get 54)
319 :min-bounds (char-info-get 8)
320 :max-bounds (char-info-get 24)
321 :properties (sequence-get :length (index* 2 nfont-props)
322 :format int32
323 :result-type 'list
324 :index 60)))))
325 (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
326 (push font result))
327 nil)))
328 ;; Replace atom id's with keywords in the plist
329 (dolist (font result)
330 (do ((p (font-properties font) (cddr p)))
331 ((endp p))
332 (setf (car p) (atom-name display (car p)))))
333 (coerce (nreverse result) result-type)))
334
335 (defun font-path (display &key (result-type 'list))
336 (declare (type display display)
337 (type t result-type)) ;; CL type
338 (declare (clx-values (clx-sequence (or string pathname))))
339 (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
340 ()
341 (values
342 (read-sequence-string
343 buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
344
345 (defun set-font-path (display paths)
346 (declare (type display display)
347 (type (clx-sequence (or string pathname)) paths))
348 (let ((path-length (length paths))
349 (request-length 8))
350 ;; Find the request length
351 (dotimes (i path-length)
352 (let* ((string (string (elt paths i)))
353 (len (length string)))
354 (incf request-length (1+ len))))
355 (with-buffer-request (display +x-setfontpath+ :length request-length)
356 (length (ceiling request-length 4))
357 (card16 path-length)
358 (pad16 nil)
359 (progn
360 (incf buffer-boffset 8)
361 (dotimes (i path-length)
362 (let* ((string (string (elt paths i)))
363 (len (length string)))
364 (card8-put 0 len)
365 (string-put 1 string :appending t :header-length 1)
366 (incf buffer-boffset (1+ len))))
367 (setf (buffer-boffset display) (lround buffer-boffset)))))
368 paths)
369
370 (defsetf font-path set-font-path)

  ViewVC Help
Powered by ViewVC 1.1.5