1
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
4
;;; TEXAS INSTRUMENTS INCORPORATED
6
;;; AUSTIN, TEXAS 78769
8
;;; Copyright (C) 1987 Texas Instruments Incorporated.
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
15
;;; Texas Instruments Incorporated provides this software "as is" without
16
;;; express or implied warranty.
21
;; The char-info stuff is here instead of CLX because of uses of int16->card16.
23
; To allow efficient storage representations, the type char-info is not
24
; required to be a structure.
26
;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
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))))
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)))
42
;(defun min-char-<metric> (font)
43
; (declare (type font font)
44
; (clx-values integer)))
46
;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
48
(deftype char-info-vec () '(simple-array int16 (*)))
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))
57
(setq name (xintern 'char- (caar field)))
58
(setq type (cadar field))
62
`(,(xintern 'int16-> type) ,form))))
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)))
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))
77
(aref (the char-info-vec
78
(font-max-bounds font))
80
;; Variable width font
81
(aref char-info-vector
87
(font-min-char font)))
90
(setq name (xintern 'min-char- (caar field)))
93
(declare (type font font))
94
(declare (clx-values (or null ,type)))
95
(when (font-name font)
99
(aref (the char-info-vec (font-min-bounds font))
102
(setq name (xintern 'max-char- (caar field)))
105
(declare (type font font))
106
(declare (clx-values (or null ,type)))
107
(when (font-name font)
111
(aref (the char-info-vec (font-max-bounds font))
115
(defun make-char-info
118
`(,(car field) (required-arg ,(car field))))
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))
128
((endp field) (nreverse result))
129
(push `(setf (aref result ,n)
130
,(if (eq type 'int16)
132
`(,(xintern type '->int16) ,var)))
135
(def-char-info-accessors ignore
137
(right-bearing int16)
141
(attributes card16)))
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)
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))
163
(string name-string))
164
(push font (display-font-cache display)))
165
(incf (font-reference-count font))
166
(unless (font-font-info-internal font)
170
(defun open-font-internal (font)
171
;; Called "under the covers" to open a font object
172
(declare (type font font))
173
(declare (clx-values resource-id))
174
(let* ((name-string (font-name font))
175
(display (font-display font))
176
(id (allocate-resource-id display font 'font)))
177
(setf (font-id-internal font) id)
178
(with-buffer-request (display +x-openfont+)
180
(card16 (length name-string))
182
(string name-string))
183
(push font (display-font-cache display))
184
(incf (font-reference-count font))
187
(defun discard-font-info (font)
188
;; Discards any state that can be re-obtained with QueryFont. This is
189
;; simply a performance hint for memory-limited systems.
190
(declare (type font font))
191
(setf (font-font-info-internal font) nil
192
(font-char-infos-internal font) nil))
194
(defun query-font (font)
195
;; Internal function called by font and char info accessors
196
(declare (type font font))
197
(declare (clx-values font-info))
198
(let ((display (font-display font))
202
(setq font-id (font-id font)) ;; May issue an open-font request
203
(with-buffer-request-and-reply (display +x-queryfont+ 60)
204
((resource-id font-id))
205
(let* ((min-byte2 (card16-get 40))
206
(max-byte2 (card16-get 42))
207
(min-byte1 (card8-get 49))
208
(max-byte1 (card8-get 50))
210
(max-char (index+ (index-ash max-byte1 8) max-byte2))
211
(nfont-props (card16-get 46))
212
(nchar-infos (index* (card32-get 56) 6))
213
(char-info (make-array nchar-infos :element-type 'int16)))
216
:direction (member8-get 48 :left-to-right :right-to-left)
223
:all-chars-exist-p (boolean-get 51)
224
:default-char (card16-get 44)
225
:ascent (int16-get 52)
226
:descent (int16-get 54)
227
:min-bounds (char-info-get 8)
228
:max-bounds (char-info-get 24)))
229
(setq props (sequence-get :length (index* 2 nfont-props) :format int32
230
:result-type 'list :index 60))
231
(sequence-get :length nchar-infos :format int16 :data char-info
232
:index (index+ 60 (index* 2 nfont-props 4)))
233
(setf (font-char-infos-internal font) char-info)
234
(setf (font-font-info-internal font) font-info)))
235
;; Replace atom id's with keywords in the plist
236
(do ((p props (cddr p)))
238
(setf (car p) (atom-name display (car p))))
239
(setf (font-info-properties font-info) props)
242
(defun close-font (font)
243
;; This might not generate a protocol request if the font is reference
245
(declare (type font font))
246
(when (and (not (plusp (decf (font-reference-count font))))
247
(font-id-internal font))
248
(let ((display (font-display font))
249
(id (font-id-internal font)))
250
(declare (type display display))
251
;; Remove font from cache
252
(setf (display-font-cache display) (delete font (display-font-cache display)))
254
(with-buffer-request (display +x-closefont+)
257
(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
258
(declare (type display display)
259
(type string pattern)
260
(type card16 max-fonts)
261
(type t result-type)) ;; CL type
262
(declare (clx-values (clx-sequence string)))
263
(let ((string (string pattern)))
264
(with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
265
((card16 max-fonts (length string))
268
(read-sequence-string
269
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
271
(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
272
;; Note: Was called list-fonts-with-info.
273
;; Returns "pseudo" fonts that contain basic font metrics and properties, but
274
;; no per-character metrics and no resource-ids. These pseudo fonts will be
275
;; converted (internally) to real fonts dynamically as needed, by issuing an
276
;; OpenFont request. However, the OpenFont might fail, in which case the
277
;; invalid-font error can arise.
278
(declare (type display display)
279
(type string pattern)
280
(type card16 max-fonts)
281
(type t result-type)) ;; CL type
282
(declare (clx-values (clx-sequence font)))
283
(let ((string (string pattern))
285
(with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
286
:sizes (8 16) :multiple-reply t)
287
((card16 max-fonts (length string))
289
(cond ((zerop (card8-get 1)) t)
291
(let* ((name-len (card8-get 1))
292
(min-byte2 (card16-get 40))
293
(max-byte2 (card16-get 42))
294
(min-byte1 (card8-get 49))
295
(max-byte1 (card8-get 50))
297
(max-char (index+ (index-ash max-byte1 8) max-byte2))
298
(nfont-props (card16-get 46))
305
:direction (member8-get 48 :left-to-right :right-to-left)
312
:all-chars-exist-p (boolean-get 51)
313
:default-char (card16-get 44)
314
:ascent (int16-get 52)
315
:descent (int16-get 54)
316
:min-bounds (char-info-get 8)
317
:max-bounds (char-info-get 24)
318
:properties (sequence-get :length (index* 2 nfont-props)
322
(setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
325
;; Replace atom id's with keywords in the plist
326
(dolist (font result)
327
(do ((p (font-properties font) (cddr p)))
329
(setf (car p) (atom-name display (car p)))))
330
(coerce (nreverse result) result-type)))
332
(defun font-path (display &key (result-type 'list))
333
(declare (type display display)
334
(type t result-type)) ;; CL type
335
(declare (clx-values (clx-sequence (or string pathname))))
336
(with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
339
(read-sequence-string
340
buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
342
(defun set-font-path (display paths)
343
(declare (type display display)
344
(type (clx-sequence (or string pathname)) paths))
345
(let ((path-length (length paths))
347
;; Find the request length
348
(dotimes (i path-length)
349
(let* ((string (string (elt paths i)))
350
(len (length string)))
351
(incf request-length (1+ len))))
352
(with-buffer-request (display +x-setfontpath+ :length request-length)
353
(length (ceiling request-length 4))
357
(incf buffer-boffset 8)
358
(dotimes (i path-length)
359
(let* ((string (string (elt paths i)))
360
(len (length string)))
362
(string-put 1 string :appending t :header-length 1)
363
(incf buffer-boffset (1+ len))))
364
(setf (buffer-boffset display) (lround buffer-boffset)))))
367
(defsetf font-path set-font-path)
added
removed
src/clx/fonts.lisp
