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

Contents of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5