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

Contents of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Nov 7 16:57:53 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
Changes since 1.1: +2 -9 lines
CLX R5 changes.
1 ram 1.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     ; (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     ; (values integer)))
41    
42     ;(defun min-char-<metric> (font)
43     ; (declare (type font font)
44     ; (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 (6)))
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 (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 (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 (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     (array-register result))
124     ,@(do* ((field fields (cdr field))
125     (var (caar field) (caar field))
126     (type (cadar field) (cadar field))
127     (n 0 (1+ n))
128     (result nil))
129     ((endp field) (nreverse result))
130     (push `(setf (aref result ,n)
131     ,(if (eq type 'int16)
132     var
133     `(,(xintern type '->int16) ,var)))
134     result))
135     result)))))
136     (def-char-info-accessors ignore
137     (left-bearing int16)
138     (right-bearing int16)
139     (width int16)
140     (ascent int16)
141     (descent int16)
142     (attributes card16)))
143    
144     (defun open-font (display name)
145     ;; Font objects may be cached and reference counted locally within the display
146     ;; object. This function might not execute a with-display if the font is cached.
147     ;; The protocol QueryFont request happens on-demand under the covers.
148     (declare (type display display)
149     (type stringable name))
150     (declare (values font))
151     (let* ((name-string (string-downcase (string name)))
152     (font (car (member name-string (display-font-cache display)
153     :key 'font-name
154     :test 'equal)))
155     font-id)
156     (unless font
157     (setq font (make-font :display display :name name-string))
158     (setq font-id (allocate-resource-id display font 'font))
159     (setf (font-id-internal font) font-id)
160     (with-buffer-request (display *x-openfont*)
161     (resource-id font-id)
162     (card16 (length name-string))
163     (pad16 nil)
164     (string name-string))
165     (push font (display-font-cache display)))
166     (incf (font-reference-count font))
167     font))
168    
169     (defun open-font-internal (font)
170     ;; Called "under the covers" to open a font object
171     (declare (type font font))
172     (declare (values resource-id))
173     (let* ((name-string (font-name font))
174     (display (font-display font))
175     (id (allocate-resource-id display font 'font)))
176     (setf (font-id-internal font) id)
177     (with-buffer-request (display *x-openfont*)
178     (resource-id id)
179     (card16 (length name-string))
180     (pad16 nil)
181     (string name-string))
182     (push font (display-font-cache display))
183     (incf (font-reference-count font))
184     id))
185    
186     (defun discard-font-info (font)
187     ;; Discards any state that can be re-obtained with QueryFont. This is
188     ;; simply a performance hint for memory-limited systems.
189     (declare (type font font))
190     (setf (font-font-info-internal font) nil
191     (font-char-infos-internal font) nil))
192    
193     (defun query-font (font)
194     ;; Internal function called by font and char info accessors
195     (declare (type font font))
196     (declare (values font-info))
197     (let ((display (font-display font))
198     font-id
199     font-info
200     props)
201     (setq font-id (font-id font)) ;; May issue an open-font request
202     (with-buffer-request-and-reply (display *x-queryfont* 60)
203     ((resource-id font-id))
204     (let* ((min-byte2 (card16-get 40))
205     (max-byte2 (card16-get 42))
206     (min-byte1 (card8-get 49))
207     (max-byte1 (card8-get 50))
208     (min-char min-byte2)
209     (max-char (index+ (index-ash max-byte1 8) max-byte2))
210     (nfont-props (card16-get 46))
211     (nchar-infos (index* (card32-get 56) 6))
212     (char-info (make-array nchar-infos :element-type 'int16)))
213     (setq font-info
214     (make-font-info
215     :direction (member8-get 48 :left-to-right :right-to-left)
216     :min-char min-char
217     :max-char max-char
218     :min-byte1 min-byte1
219     :max-byte1 max-byte1
220     :min-byte2 min-byte2
221     :max-byte2 max-byte2
222     :all-chars-exist-p (boolean-get 51)
223     :default-char (card16-get 44)
224     :ascent (int16-get 52)
225     :descent (int16-get 54)
226     :min-bounds (char-info-get 8)
227     :max-bounds (char-info-get 24)))
228     (setq props (sequence-get :length (index* 2 nfont-props) :format int32
229     :result-type 'list :index 60))
230     (sequence-get :length nchar-infos :format int16 :data char-info
231     :index (index+ 60 (index* 2 nfont-props 4)))
232     (setf (font-char-infos-internal font) char-info)
233     (setf (font-font-info-internal font) font-info)))
234     ;; Replace atom id's with keywords in the plist
235     (do ((p props (cddr p)))
236     ((endp p))
237     (setf (car p) (atom-name display (car p))))
238     (setf (font-info-properties font-info) props)
239     font-info))
240    
241     (defun close-font (font)
242     ;; This might not generate a protocol request if the font is reference
243     ;; counted locally.
244     (declare (type font font))
245     (when (and (not (plusp (decf (font-reference-count font))))
246     (font-id-internal font))
247     (let ((display (font-display font))
248     (id (font-id-internal font)))
249     (declare (type display display))
250     ;; Remove font from cache
251     (setf (display-font-cache display) (delete font (display-font-cache display)))
252     ;; Close the font
253     (with-buffer-request (display *x-closefont*)
254     (resource-id id)))))
255    
256     (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
257     (declare (type display display)
258     (type string pattern)
259     (type card16 max-fonts)
260     (type t result-type)) ;; CL type
261     (declare (values (sequence string)))
262     (let ((string (string pattern)))
263     (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
264     ((card16 max-fonts (length string))
265     (string string))
266     (values
267     (read-sequence-string
268     buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))))
269    
270     (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
271     ;; Note: Was called list-fonts-with-info.
272     ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
273     ;; no per-character metrics and no resource-ids. These pseudo fonts will be
274     ;; converted (internally) to real fonts dynamically as needed, by issuing an
275     ;; OpenFont request. However, the OpenFont might fail, in which case the
276     ;; invalid-font error can arise.
277     (declare (type display display)
278     (type string pattern)
279     (type card16 max-fonts)
280     (type t result-type)) ;; CL type
281     (declare (values (sequence font)))
282     (let ((string (string pattern))
283     (result nil))
284     (with-buffer-request-and-reply (display *x-listfontswithinfo* 60
285     :sizes (8 16) :multiple-reply t)
286     ((card16 max-fonts (length string))
287     (string string))
288     (cond ((zerop (card8-get 1)) t)
289     (t
290     (let* ((name-len (card8-get 1))
291     (min-byte2 (card16-get 40))
292     (max-byte2 (card16-get 42))
293     (min-byte1 (card8-get 49))
294     (max-byte1 (card8-get 50))
295     (min-char min-byte2)
296     (max-char (index+ (index-ash max-byte1 8) max-byte2))
297     (nfont-props (card16-get 46))
298     (font
299     (make-font
300     :display display
301     :name nil
302     :font-info-internal
303     (make-font-info
304     :direction (member8-get 48 :left-to-right :right-to-left)
305     :min-char min-char
306     :max-char max-char
307     :min-byte1 min-byte1
308     :max-byte1 max-byte1
309     :min-byte2 min-byte2
310     :max-byte2 max-byte2
311     :all-chars-exist-p (boolean-get 51)
312     :default-char (card16-get 44)
313     :ascent (int16-get 52)
314     :descent (int16-get 54)
315     :min-bounds (char-info-get 8)
316     :max-bounds (char-info-get 24)
317     :properties (sequence-get :length (index* 2 nfont-props)
318     :format int32
319     :result-type 'list
320     :index 60)))))
321     (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
322     (push font result))
323     nil)))
324     ;; Replace atom id's with keywords in the plist
325     (dolist (font result)
326     (do ((p (font-properties font) (cddr p)))
327     ((endp p))
328     (setf (car p) (atom-name display (car p)))))
329     (coerce (nreverse result) result-type)))
330    
331     (defun font-path (display &key (result-type 'list))
332     (declare (type display display)
333     (type t result-type)) ;; CL type
334     (declare (values (sequence (or string pathname))))
335     (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))
336     ()
337     (values
338     (read-sequence-string
339     buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))
340    
341     (defun set-font-path (display paths)
342     (declare (type display display)
343     (type sequence paths)) ;; (sequence (or string pathname))
344     (let ((path-length (length paths))
345     (request-length 8))
346     ;; Find the request length
347     (dotimes (i path-length)
348     (let* ((string (string (elt paths i)))
349     (len (length string)))
350     (incf request-length (1+ len))))
351     (with-buffer-request (display *x-setfontpath* :length request-length)
352     (length (ceiling request-length 4))
353     (card16 path-length)
354     (pad16 nil)
355     (progn
356     (incf buffer-boffset 8)
357     (dotimes (i path-length)
358     (let* ((string (string (elt paths i)))
359     (len (length string)))
360     (card8-put 0 len)
361     (string-put 1 string :appending t :header-length 1)
362     (incf buffer-boffset (1+ len))))
363 ram 1.2 (setf (buffer-boffset display) (lround buffer-boffset)))))
364     paths)
365 ram 1.1
366     (defsetf font-path set-font-path)

  ViewVC Help
Powered by ViewVC 1.1.5