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

Contents of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5