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

Contents of /src/clx/fonts.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6.14.1 - (hide annotations)
Wed Jun 17 15:46:26 2009 UTC (4 years, 10 months ago) by rtoy
Branch: portable-clx-branch
CVS Tags: portable-clx-import-2009-06-16
Changes since 1.6: +0 -3 lines
Import portable clx version from Christophe Rhodes darcs repository as
of 2009-06-16.

This is an exact copy of the code.  It is intended updates of
portable-clx go on the portable-clx-branch and should be merged to the
main branch as needed.  This should make it easier to do any
CMUCL-specific changes that aren't in portable-clx.

I chose not to import the files in the clx/manual directory.
Everything else is imported.  (Should the manual be imported too?)
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 fgilham 1.6
19 ram 1.1 (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 ram 1.3 ; (clx-values (or null integer))))
35 ram 1.1
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 ram 1.3 ; (clx-values integer)))
41 ram 1.1
42     ;(defun min-char-<metric> (font)
43     ; (declare (type font font)
44 ram 1.3 ; (clx-values integer)))
45 ram 1.1
46     ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
47    
48 pw 1.4 (deftype char-info-vec () '(simple-array int16 (*)))
49 ram 1.1
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 ram 1.3 (declare (clx-values (or null ,type)))
68 ram 1.1 (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 ram 1.3 (declare (clx-values (or null ,type)))
95 ram 1.1 (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 ram 1.3 (declare (clx-values (or null ,type)))
107 ram 1.1 (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 ram 1.3 (declare (type char-info-vec result))
123 ram 1.1 ,@(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 ram 1.3 (declare (clx-values font))
150 ram 1.1 (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 fgilham 1.6 (with-buffer-request (display +x-openfont+)
160 ram 1.1 (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 fgilham 1.6 (unless (font-font-info-internal font)
167     (query-font font))
168 ram 1.1 font))
169    
170     (defun open-font-internal (font)
171     ;; Called "under the covers" to open a font object
172     (declare (type font font))
173 ram 1.3 (declare (clx-values resource-id))
174 ram 1.1 (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 fgilham 1.6 (with-buffer-request (display +x-openfont+)
179 ram 1.1 (resource-id id)
180     (card16 (length name-string))
181     (pad16 nil)
182     (string name-string))
183     (push font (display-font-cache display))
184     (incf (font-reference-count font))
185     id))
186    
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))
193    
194     (defun query-font (font)
195     ;; Internal function called by font and char info accessors
196     (declare (type font font))
197 ram 1.3 (declare (clx-values font-info))
198 ram 1.1 (let ((display (font-display font))
199     font-id
200     font-info
201     props)
202     (setq font-id (font-id font)) ;; May issue an open-font request
203 fgilham 1.6 (with-buffer-request-and-reply (display +x-queryfont+ 60)
204 ram 1.1 ((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))
209     (min-char min-byte2)
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)))
214     (setq font-info
215     (make-font-info
216     :direction (member8-get 48 :left-to-right :right-to-left)
217     :min-char min-char
218     :max-char max-char
219     :min-byte1 min-byte1
220     :max-byte1 max-byte1
221     :min-byte2 min-byte2
222     :max-byte2 max-byte2
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)))
237     ((endp p))
238     (setf (car p) (atom-name display (car p))))
239     (setf (font-info-properties font-info) props)
240     font-info))
241    
242     (defun close-font (font)
243     ;; This might not generate a protocol request if the font is reference
244     ;; counted locally.
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)))
253     ;; Close the font
254 fgilham 1.6 (with-buffer-request (display +x-closefont+)
255 ram 1.1 (resource-id id)))))
256    
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 ram 1.3 (declare (clx-values (clx-sequence string)))
263 ram 1.1 (let ((string (string pattern)))
264 fgilham 1.6 (with-buffer-request-and-reply (display +x-listfonts+ size :sizes (8 16))
265 ram 1.1 ((card16 max-fonts (length string))
266     (string string))
267     (values
268     (read-sequence-string
269 fgilham 1.6 buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+)))))
270 ram 1.1
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 ram 1.3 (declare (clx-values (clx-sequence font)))
283 ram 1.1 (let ((string (string pattern))
284     (result nil))
285 fgilham 1.6 (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
286 ram 1.1 :sizes (8 16) :multiple-reply t)
287     ((card16 max-fonts (length string))
288     (string string))
289     (cond ((zerop (card8-get 1)) t)
290     (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))
296     (min-char min-byte2)
297     (max-char (index+ (index-ash max-byte1 8) max-byte2))
298     (nfont-props (card16-get 46))
299     (font
300     (make-font
301     :display display
302     :name nil
303     :font-info-internal
304     (make-font-info
305     :direction (member8-get 48 :left-to-right :right-to-left)
306     :min-char min-char
307     :max-char max-char
308     :min-byte1 min-byte1
309     :max-byte1 max-byte1
310     :min-byte2 min-byte2
311     :max-byte2 max-byte2
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)
319     :format int32
320     :result-type 'list
321     :index 60)))))
322     (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
323     (push font result))
324     nil)))
325     ;; Replace atom id's with keywords in the plist
326     (dolist (font result)
327     (do ((p (font-properties font) (cddr p)))
328     ((endp p))
329     (setf (car p) (atom-name display (car p)))))
330     (coerce (nreverse result) result-type)))
331    
332     (defun font-path (display &key (result-type 'list))
333     (declare (type display display)
334     (type t result-type)) ;; CL type
335 ram 1.3 (declare (clx-values (clx-sequence (or string pathname))))
336 fgilham 1.6 (with-buffer-request-and-reply (display +x-getfontpath+ size :sizes (8 16))
337 ram 1.1 ()
338     (values
339     (read-sequence-string
340 fgilham 1.6 buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
341 ram 1.1
342     (defun set-font-path (display paths)
343     (declare (type display display)
344 ram 1.3 (type (clx-sequence (or string pathname)) paths))
345 ram 1.1 (let ((path-length (length paths))
346     (request-length 8))
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 fgilham 1.6 (with-buffer-request (display +x-setfontpath+ :length request-length)
353 ram 1.1 (length (ceiling request-length 4))
354     (card16 path-length)
355     (pad16 nil)
356     (progn
357     (incf buffer-boffset 8)
358     (dotimes (i path-length)
359     (let* ((string (string (elt paths i)))
360     (len (length string)))
361     (card8-put 0 len)
362     (string-put 1 string :appending t :header-length 1)
363     (incf buffer-boffset (1+ len))))
364 ram 1.2 (setf (buffer-boffset display) (lround buffer-boffset)))))
365     paths)
366 ram 1.1
367     (defsetf font-path set-font-path)

  ViewVC Help
Powered by ViewVC 1.1.5