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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Aug 21 15:49:28 2007 UTC (6 years, 7 months ago) by fgilham
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, release-19e-pre1, release-19e-pre2, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-extfmt-2009-06-11, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, portable-clx-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.7: +97 -62 lines
Telent CLX import
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; CLX text keyboard and pointer requests
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20
21 #+cmu
22 (ext:file-comment "$Id: text.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
23
24 (in-package :xlib)
25
26 ;; Strings are broken up into chunks of this size
27 (defparameter *max-string-size* 254)
28
29 ;; In the functions below, the transform is used to convert an element of the
30 ;; sequence into a font index. The transform is applied to each element of the
31 ;; (sub)sequence, until either the transform returns nil or the end of the
32 ;; (sub)sequence is reached. If transform returns nil for an element, the
33 ;; index of that element in the sequence is returned, otherwise nil is
34 ;; returned.
35
36 (deftype translation-function ()
37 #+explorer t
38 #-explorer
39 '(function (sequence array-index array-index (or null font) vector array-index)
40 (values array-index (or null int16 font) (or null int32))))
41
42 ;; In the functions below, if width is specified, it is assumed to be the pixel
43 ;; width of whatever string of glyphs is actually drawn. Specifying width will
44 ;; allow for appending the output of subsequent calls to the same protocol
45 ;; request, provided gcontext has not been modified in the interim. If width
46 ;; is not specified, appending of subsequent output might not occur.
47 ;; Specifying width is simply a hint, for performance. Note that specifying
48 ;; width may be difficult if transform can return nil.
49
50 (defun translate-default (src src-start src-end font dst dst-start)
51 ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
52 ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
53 ;; on context. font is the current font, if known. The function should
54 ;; translate as many elements of src as possible into indexes in the current
55 ;; font, and store them into dst.
56 ;;
57 ;; The first return value should be the src index of the first untranslated
58 ;; element. If no further elements need to be translated, the second return
59 ;; value should be nil. If a horizontal motion is required before further
60 ;; translation, the second return value should be the delta in x coordinate.
61 ;; If a font change is required for further translation, the second return
62 ;; value should be the new font. If known, the pixel width of the translated
63 ;; text can be returned as the third value; this can allow for appending of
64 ;; subsequent output to the same protocol request, if no overall width has
65 ;; been specified at the higher level.
66 ;; (returns values: ending-index
67 ;; (OR null horizontal-motion font)
68 ;; (OR null translated-width))
69 (declare (type sequence src)
70 (type array-index src-start src-end dst-start)
71 (type (or null font) font)
72 (type vector dst)
73 (inline graphic-char-p))
74 (declare (clx-values integer (or null integer font) (or null integer)))
75
76 (let ((min-char-index (xlib:font-min-char font))
77 (max-char-index (xlib:font-max-char font)))
78 (if (stringp src)
79 (do ((i src-start (index+ i 1))
80 (j dst-start (index+ j 1))
81 (char))
82 ((index>= i src-end)
83 i)
84 (declare (type array-index i j))
85 (setf char (char->card8 (char src i)))
86 (if (or (< char min-char-index) (> char max-char-index))
87 (return i)
88 (setf (aref dst j) char)))
89 (do ((i src-start (index+ i 1))
90 (j dst-start (index+ j 1))
91 (elt))
92 ((index>= i src-end)
93 i)
94 (declare (type array-index i j))
95 (setq elt (elt src i))
96 (when (characterp elt) (setq elt (char->card8 elt)))
97 (if (or (not (integerp elt))
98 (< elt min-char-index)
99 (> elt max-char-index))
100 (return i)
101 (setf (aref dst j) elt))))))
102
103 ;; There is a question below of whether translate should always be required, or
104 ;; if not, what the default should be or where it should come from. For
105 ;; example, the default could be something that expected a string as src and
106 ;; translated the CL standard character set to ASCII indexes, and ignored fonts
107 ;; and bits. Or the default could expect a string but otherwise be "system
108 ;; dependent". Or the default could be something that expected a vector of
109 ;; integers and did no translation. Or the default could come from the
110 ;; gcontext (but what about text-extents and text-width?).
111
112 (defun text-extents (font sequence &key (start 0) end translate)
113 ;; If multiple fonts are involved, font-ascent and font-descent will be the
114 ;; maximums. If multiple directions are involved, the direction will be nil.
115 ;; Translate will always be called with a 16-bit dst buffer.
116 (declare (type sequence sequence)
117 (type (or font gcontext) font))
118 (declare (type (or null translation-function) translate)
119 #+clx-ansi-common-lisp
120 (dynamic-extent translate)
121 #+(and lispm (not clx-ansi-common-lisp))
122 (sys:downward-funarg #+Genera * #-Genera translate))
123 (declare (clx-values width ascent descent left right
124 font-ascent font-descent direction
125 (or null array-index)))
126 (when (type? font 'gcontext)
127 (force-gcontext-changes font)
128 (setq font (gcontext-font font t)))
129 (check-type font font)
130 (let* ((left-bearing 0)
131 (right-bearing 0)
132 ;; Sum of widths
133 (width 0)
134 (ascent 0)
135 (descent 0)
136 (overall-ascent (font-ascent font))
137 (overall-descent (font-descent font))
138 (overall-direction (font-direction font))
139 (next-start nil)
140 (display (font-display font)))
141 (declare (type int16 ascent descent overall-ascent overall-descent)
142 (type int32 left-bearing right-bearing width)
143 (type (or null array-index) next-start)
144 (type display display))
145 (with-display (display)
146 (do* ((wbuf (display-tbuf16 display))
147 (src-end (or end (length sequence)))
148 (src-start start (index+ src-start buf-end))
149 (end (index-min src-end (index+ src-start +buffer-text16-size+))
150 (index-min src-end (index+ src-start +buffer-text16-size+)))
151 (buf-end 0)
152 (new-font)
153 (font-ascent 0)
154 (font-descent 0)
155 (font-direction)
156 (stop-p nil))
157 ((or stop-p (index>= src-start src-end))
158 (when (index< src-start src-end)
159 (setq next-start src-start)))
160 (declare (type buffer-text16 wbuf)
161 (type array-index src-start src-end end buf-end)
162 (type int16 font-ascent font-descent)
163 (type generalized-boolean stop-p))
164 ;; Translate the text
165 (multiple-value-setq (buf-end new-font)
166 (funcall (or translate #'translate-default)
167 sequence src-start end font wbuf 0))
168 (setq buf-end (- buf-end src-start))
169 (cond ((null new-font) (setq stop-p t))
170 ((integerp new-font) (incf width (the int32 new-font))))
171
172 (let (w a d l r)
173 (if (or (font-char-infos-internal font) (font-local-only-p font))
174 ;; Calculate text extents locally
175 (progn
176 (multiple-value-setq (w a d l r)
177 (text-extents-local font wbuf 0 buf-end nil))
178 (setq font-ascent (the int16 (font-ascent font))
179 font-descent (the int16 (font-descent font))
180 font-direction (font-direction font)))
181 ;; Let the server calculate text extents
182 (multiple-value-setq
183 (w a d l r font-ascent font-descent font-direction)
184 (text-extents-server font wbuf 0 buf-end)))
185 (incf width (the int32 w))
186 (cond ((index= src-start start)
187 (setq left-bearing (the int32 l))
188 (setq right-bearing (the int32 r))
189 (setq ascent (the int16 a))
190 (setq descent (the int16 d)))
191 (t
192 (setq left-bearing (the int32 (min left-bearing (the int32 l))))
193 (setq right-bearing (the int32 (max right-bearing (the int32 r))))
194 (setq ascent (the int16 (max ascent (the int16 a))))
195 (setq descent (the int16 (max descent (the int16 d)))))))
196
197 (when (type? new-font 'font)
198 (setq font new-font))
199
200 (setq overall-ascent (the int16 (max overall-ascent font-ascent)))
201 (setq overall-descent (the int16 (max overall-descent font-descent)))
202 (case overall-direction
203 (:unknown (setq overall-direction font-direction))
204 (:left-to-right (unless (eq font-direction :left-to-right)
205 (setq overall-direction nil)))
206 (:right-to-left (unless (eq font-direction :right-to-left)
207 (setq overall-direction nil))))))
208
209 (values width
210 ascent
211 descent
212 left-bearing
213 right-bearing
214 overall-ascent
215 overall-descent
216 overall-direction
217 next-start)))
218
219 (defun text-width (font sequence &key (start 0) end translate)
220 ;; Translate will always be called with a 16-bit dst buffer.
221 (declare (type sequence sequence)
222 (type (or font gcontext) font)
223 (type array-index start)
224 (type (or null array-index) end))
225 (declare (type (or null translation-function) translate)
226 #+clx-ansi-common-lisp
227 (dynamic-extent translate)
228 #+(and lispm (not clx-ansi-common-lisp))
229 (sys:downward-funarg #+Genera * #-Genera translate))
230 (declare (clx-values integer (or null integer)))
231 (when (type? font 'gcontext)
232 (force-gcontext-changes font)
233 (setq font (gcontext-font font t)))
234 (check-type font font)
235 (let* ((width 0)
236 (next-start nil)
237 (display (font-display font)))
238 (declare (type int32 width)
239 (type (or null array-index) next-start)
240 (type display display))
241 (with-display (display)
242 (do* ((wbuf (display-tbuf16 display))
243 (src-end (or end (length sequence)))
244 (src-start start (index+ src-start buf-end))
245 (end (index-min src-end (index+ src-start +buffer-text16-size+))
246 (index-min src-end (index+ src-start +buffer-text16-size+)))
247 (buf-end 0)
248 (new-font)
249 (stop-p nil))
250 ((or stop-p (index>= src-start src-end))
251 (when (index< src-start src-end)
252 (setq next-start src-start)))
253 (declare (type buffer-text16 wbuf)
254 (type array-index src-start src-end end buf-end)
255 (type generalized-boolean stop-p))
256 ;; Translate the text
257 (multiple-value-setq (buf-end new-font)
258 (funcall (or translate #'translate-default)
259 sequence src-start end font wbuf 0))
260 (setq buf-end (- buf-end src-start))
261 (cond ((null new-font) (setq stop-p t))
262 ((integerp new-font) (incf width (the int32 new-font))))
263
264 (incf width
265 (if (or (font-char-infos-internal font) (font-local-only-p font))
266 (text-extents-local font wbuf 0 buf-end :width-only)
267 (text-width-server font wbuf 0 buf-end)))
268 (when (type? new-font 'font)
269 (setq font new-font))))
270 (values width next-start)))
271
272 (defun text-extents-server (font sequence start end)
273 (declare (type font font)
274 (type sequence sequence)
275 (type array-index start end))
276 (declare (clx-values width ascent descent left right font-ascent font-descent direction))
277 (let ((display (font-display font))
278 (length (index- end start))
279 (font-id (font-id font)))
280 (declare (type display display)
281 (type array-index length)
282 (type resource-id font-id))
283 (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes (8 16 32))
284 (((data boolean) (oddp length))
285 (length (index+ (index-ceiling length 2) 2))
286 (resource-id font-id)
287 ((sequence :format char2b :start start :end end :appending t)
288 sequence))
289 (values
290 (integer-get 16)
291 (int16-get 12)
292 (int16-get 14)
293 (integer-get 20)
294 (integer-get 24)
295 (int16-get 8)
296 (int16-get 10)
297 (member8-get 1 :left-to-right :right-to-left)))))
298
299 (defun text-width-server (font sequence start end)
300 (declare (type (or font gcontext) font)
301 (type sequence sequence)
302 (type array-index start end))
303 (declare (clx-values integer))
304 (let ((display (font-display font))
305 (length (index- end start))
306 (font-id (font-id font)))
307 (declare (type display display)
308 (type array-index length)
309 (type resource-id font-id))
310 (with-buffer-request-and-reply (display +x-querytextextents+ 28 :sizes 32)
311 (((data boolean) (oddp length))
312 (length (index+ (index-ceiling length 2) 2))
313 (resource-id font-id)
314 ((sequence :format char2b :start start :end end :appending t)
315 sequence))
316 (values (integer-get 16)))))
317
318 (defun text-extents-local (font sequence start end width-only-p)
319 (declare (type font font)
320 (type sequence sequence)
321 (type integer start end)
322 (type generalized-boolean width-only-p))
323 (declare (clx-values width ascent descent overall-left overall-right))
324 (let* ((char-infos (font-char-infos font))
325 (font-info (font-font-info font)))
326 (declare (type font-info font-info))
327 (declare (type (simple-array int16 (*)) char-infos))
328 (if (zerop (length char-infos))
329 ;; Fixed width font
330 (let* ((font-width (max-char-width font))
331 (font-ascent (max-char-ascent font))
332 (font-descent (max-char-descent font))
333 (width (* (index- end start) font-width)))
334 (declare (type int16 font-width font-ascent font-descent)
335 (type int32 width))
336 (if width-only-p
337 width
338 (values width
339 font-ascent
340 font-descent
341 (max-char-left-bearing font)
342 (+ width (- font-width) (max-char-right-bearing font)))))
343
344 ;; Variable-width font
345 (let* ((first-col (font-info-min-byte2 font-info))
346 (num-cols (1+ (- (font-info-max-byte2 font-info) first-col)))
347 (first-row (font-info-min-byte1 font-info))
348 (last-row (font-info-max-byte1 font-info))
349 (num-rows (1+ (- last-row first-row))))
350 (declare (type card8 first-col first-row last-row)
351 (type card16 num-cols num-rows))
352 (if (or (plusp first-row) (plusp last-row))
353
354 ;; Matrix (16 bit) font
355 (macrolet ((char-info-elt (sequence elt)
356 `(let* ((char (the card16 (elt ,sequence ,elt)))
357 (row (- (ash char -8) first-row))
358 (col (- (logand char #xff) first-col)))
359 (declare (type card16 char)
360 (type int16 row col))
361 (if (and (< -1 row num-rows) (< -1 col num-cols))
362 (index* 6 (index+ (index* row num-cols) col))
363 -1))))
364 (if width-only-p
365 (do ((i start (index1+ i))
366 (width 0))
367 ((index>= i end) width)
368 (declare (type array-index i)
369 (type int32 width))
370 (let ((n (char-info-elt sequence i)))
371 (declare (type fixnum n))
372 (unless (minusp n) ;; Ignore characters not in the font
373 (incf width (the int16 (aref char-infos (index+ 2 n)))))))
374 ;; extents
375 (do ((i start (index1+ i))
376 (width 0)
377 (ascent #x-7fff)
378 (descent #x-7fff)
379 (left #x7fff)
380 (right #x-7fff))
381 ((index>= i end)
382 (values width ascent descent left right))
383 (declare (type array-index i)
384 (type int16 ascent descent)
385 (type int32 width left right))
386 (let ((n (char-info-elt sequence i)))
387 (declare (type fixnum n))
388 (unless (minusp n) ;; Ignore characters not in the font
389 (setq left (min left (+ width (aref char-infos n))))
390 (setq right (max right (+ width (aref char-infos (index1+ n)))))
391 (incf width (aref char-infos (index+ 2 n)))
392 (setq ascent (max ascent (aref char-infos (index+ 3 n))))
393 (setq descent (max descent (aref char-infos (index+ 4 n)))))))))
394
395 ;; Non-matrix (8 bit) font
396 ;; The code here is identical to the above, except for the following macro:
397 (macrolet ((char-info-elt (sequence elt)
398 `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col)))
399 (declare (type int16 col))
400 (if (< -1 col num-cols)
401 (index* 6 col)
402 -1))))
403 (if width-only-p
404 (do ((i start (index1+ i))
405 (width 0))
406 ((index>= i end) width)
407 (declare (type array-index i)
408 (type int32 width))
409 (let ((n (char-info-elt sequence i)))
410 (declare (type fixnum n))
411 (unless (minusp n) ;; Ignore characters not in the font
412 (incf width (the int16 (aref char-infos (index+ 2 n)))))))
413 ;; extents
414 (do ((i start (index1+ i))
415 (width 0)
416 (ascent #x-7fff)
417 (descent #x-7fff)
418 (left #x7fff)
419 (right #x-7fff))
420 ((index>= i end)
421 (values width ascent descent left right))
422 (declare (type array-index i)
423 (type int16 ascent descent)
424 (type int32 width left right))
425 (let ((n (char-info-elt sequence i)))
426 (declare (type fixnum n))
427 (unless (minusp n) ;; Ignore characters not in the font
428 (setq left (min left (+ width (aref char-infos n))))
429 (setq right (max right (+ width (aref char-infos (index1+ n)))))
430 (incf width (aref char-infos (index+ 2 n)))
431 (setq ascent (max ascent (aref char-infos (index+ 3 n))))
432 (setq descent (max descent (aref char-infos (index+ 4 n)))))
433 ))))
434 )))))
435
436 ;;-----------------------------------------------------------------------------
437
438 ;; This controls the element size of the dst buffer given to translate. If
439 ;; :default is specified, the size will be based on the current font, if known,
440 ;; and otherwise 16 will be used. [An alternative would be to pass the buffer
441 ;; size to translate, and allow it to return the desired size if it doesn't
442 ;; like the current size. The problem is that the protocol doesn't allow
443 ;; switching within a single request, so to allow switching would require
444 ;; knowing the width of text, which isn't necessarily known. We could call
445 ;; text-width to compute it, but perhaps that is doing too many favors?] [An
446 ;; additional possibility is to allow an index-size of :two-byte, in which case
447 ;; translate would be given a double-length 8-bit array, and translate would be
448 ;; expected to store first-byte/second-byte instead of 16-bit integers.]
449
450 (deftype index-size () '(member :default 8 16))
451
452 ;; In the functions below, if width is specified, it is assumed to be the total
453 ;; pixel width of whatever string of glyphs is actually drawn. Specifying
454 ;; width will allow for appending the output of subsequent calls to the same
455 ;; protocol request, provided gcontext has not been modified in the interim.
456 ;; If width is not specified, appending of subsequent output might not occur
457 ;; (unless translate returns the width). Specifying width is simply a hint,
458 ;; for performance.
459
460 (defun draw-glyph (drawable gcontext x y elt
461 &key translate width (size :default))
462 ;; Returns true if elt is output, nil if translate refuses to output it.
463 ;; Second result is width, if known.
464 (declare (type drawable drawable)
465 (type gcontext gcontext)
466 (type int16 x y)
467 (type (or null int32) width)
468 (type index-size size))
469 (declare (type (or null translation-function) translate)
470 #+clx-ansi-common-lisp
471 (dynamic-extent translate)
472 #+(and lispm (not clx-ansi-common-lisp))
473 (sys:downward-funarg #+Genera * #-Genera translate))
474 (declare (clx-values generalized-boolean (or null int32)))
475 (let* ((display (gcontext-display gcontext))
476 (result t)
477 (opcode +x-polytext8+))
478 (declare (type display display))
479 (let ((vector (allocate-gcontext-state)))
480 (declare (type gcontext-state vector))
481 (setf (aref vector 0) elt)
482 (multiple-value-bind (new-start new-font translate-width)
483 (funcall (or translate #'translate-default)
484 vector 0 1 (gcontext-font gcontext t) vector 1)
485 ;; Allow translate to set a new font
486 (when (type? new-font 'font)
487 (setf (gcontext-font gcontext) new-font)
488 (multiple-value-setq (new-start new-font translate-width)
489 (funcall translate vector 0 1 new-font vector 1)))
490 ;; If new-start is zero, translate refuses to output it
491 (setq result (index-plusp new-start)
492 elt (aref vector 1))
493 (deallocate-gcontext-state vector)
494 (when translate-width (setq width translate-width))))
495 (when result
496 (when (eql size 16)
497 (setq opcode +x-polytext16+)
498 (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
499 (with-buffer-request (display opcode :gc-force gcontext)
500 (drawable drawable)
501 (gcontext gcontext)
502 (int16 x y)
503 (card8 1 0)
504 (card8 (ldb (byte 8 0) elt))
505 (card8 (ldb (byte 8 8) elt)))
506 (values t width))))
507
508 (defun draw-glyphs (drawable gcontext x y sequence
509 &key (start 0) end translate width (size :default))
510 ;; First result is new start, if end was not reached. Second result is
511 ;; overall width, if known.
512 (declare (type drawable drawable)
513 (type gcontext gcontext)
514 (type int16 x y)
515 (type array-index start)
516 (type sequence sequence)
517 (type (or null array-index) end)
518 (type (or null int32) width)
519 (type index-size size))
520 (declare (type (or null translation-function) translate)
521 #+clx-ansi-common-lisp
522 (dynamic-extent translate)
523 #+(and lispm (not clx-ansi-common-lisp))
524 (sys:downward-funarg #+Genera * #-Genera translate))
525 (declare (clx-values (or null array-index) (or null int32)))
526 (unless end (setq end (length sequence)))
527 (ecase size
528 ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end
529 (or translate #'translate-default) width))
530 (16 (draw-glyphs16 drawable gcontext x y sequence start end
531 (or translate #'translate-default) width))))
532
533 (defun draw-glyphs8 (drawable gcontext x y sequence start end translate width)
534 ;; First result is new start, if end was not reached. Second result is
535 ;; overall width, if known.
536 (declare (type drawable drawable)
537 (type gcontext gcontext)
538 (type int16 x y)
539 (type array-index start)
540 (type sequence sequence)
541 (type (or null array-index) end)
542 (type (or null int32) width))
543 (declare (clx-values (or null array-index) (or null int32)))
544 (declare (type translation-function translate)
545 #+clx-ansi-common-lisp
546 (dynamic-extent translate)
547 #+(and lispm (not clx-ansi-common-lisp))
548 (sys:downward-funarg translate))
549 (let* ((src-start start)
550 (src-end (or end (length sequence)))
551 (next-start nil)
552 (length (index- src-end src-start))
553 (request-length (* length 2)) ; Leave lots of room for font shifts.
554 (display (gcontext-display gcontext))
555 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
556 (font (gcontext-font gcontext t)))
557 (declare (type array-index src-start src-end length)
558 (type (or null array-index) next-start)
559 (type display display))
560 (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length)
561 (drawable drawable)
562 (gcontext gcontext)
563 (int16 x y)
564 (progn
565 ;; Don't let any flushes happen since we manually set the request
566 ;; length when we're done.
567 (with-buffer-flush-inhibited (display)
568 (do* ((boffset (index+ buffer-boffset 16))
569 (src-chunk 0)
570 (dst-chunk 0)
571 (offset 0)
572 (overall-width 0)
573 (stop-p nil))
574 ((or stop-p (zerop length))
575 ;; Ensure terminated with zero bytes
576 (do ((end (the array-index (lround boffset))))
577 ((index>= boffset end))
578 (setf (aref buffer-bbuf boffset) 0)
579 (index-incf boffset))
580 (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
581 (setf (buffer-boffset display) boffset)
582 (unless (index-zerop length) (setq next-start src-start))
583 (when overall-width (setq width overall-width)))
584
585 (declare (type array-index src-chunk dst-chunk offset)
586 (type (or null int32) overall-width)
587 (type generalized-boolean stop-p))
588 (setq src-chunk (index-min length *max-string-size*))
589 (multiple-value-bind (new-start new-font translated-width)
590 (funcall translate
591 sequence src-start (index+ src-start src-chunk)
592 font buffer-bbuf (index+ boffset 2))
593 (setq dst-chunk (index- new-start src-start)
594 length (index- length dst-chunk)
595 src-start new-start)
596 (if translated-width
597 (when overall-width (incf overall-width translated-width))
598 (setq overall-width nil))
599 (when (index-plusp dst-chunk)
600 (setf (aref buffer-bbuf boffset) dst-chunk)
601 (setf (aref buffer-bbuf (index+ boffset 1)) offset)
602 (incf boffset (index+ dst-chunk 2)))
603 (setq offset 0)
604 (cond ((null new-font)
605 ;; Don't stop if translate copied whole chunk
606 (unless (index= src-chunk dst-chunk)
607 (setq stop-p t)))
608 ((integerp new-font) (setq offset new-font))
609 ((type? new-font 'font)
610 (setq font new-font)
611 (let ((font-id (font-id font))
612 (buffer-boffset boffset))
613 (declare (type resource-id font-id)
614 (type array-index buffer-boffset))
615 ;; This changes the gcontext font in the server
616 ;; Update the gcontext cache (both local and server state)
617 (let ((local-state (gcontext-local-state gcontext))
618 (server-state (gcontext-server-state gcontext)))
619 (declare (type gcontext-state local-state server-state))
620 (setf (gcontext-internal-font-obj server-state) font
621 (gcontext-internal-font server-state) font-id)
622 (without-interrupts
623 (setf (gcontext-internal-font-obj local-state) font
624 (gcontext-internal-font local-state) font-id)))
625 (card8-put 0 #xff)
626 (card8-put 1 (ldb (byte 8 24) font-id))
627 (card8-put 2 (ldb (byte 8 16) font-id))
628 (card8-put 3 (ldb (byte 8 8) font-id))
629 (card8-put 4 (ldb (byte 8 0) font-id)))
630 (index-incf boffset 5)))
631 )))))
632 (values next-start width)))
633
634 ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
635 ;; on 16bit boundaries and this function garbles the bytes.
636 (defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
637 ;; First result is new start, if end was not reached. Second result is
638 ;; overall width, if known.
639 (declare (type drawable drawable)
640 (type gcontext gcontext)
641 (type int16 x y)
642 (type array-index start)
643 (type sequence sequence)
644 (type (or null array-index) end)
645 (type (or null int32) width))
646 (declare (clx-values (or null array-index) (or null int32)))
647 (declare (type translation-function translate)
648 #+clx-ansi-common-lisp
649 (dynamic-extent translate)
650 #+(and lispm (not clx-ansi-common-lisp))
651 (sys:downward-funarg translate))
652 (let* ((src-start start)
653 (src-end (or end (length sequence)))
654 (next-start nil)
655 (length (index- src-end src-start))
656 (request-length (* length 3)) ; Leave lots of room for font shifts.
657 (display (gcontext-display gcontext))
658 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
659 (font (gcontext-font gcontext t))
660 (buffer (display-tbuf16 display)))
661 (declare (type array-index src-start src-end length)
662 (type (or null array-index) next-start)
663 (type display display)
664 (type buffer-text16 buffer))
665 (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length)
666 (drawable drawable)
667 (gcontext gcontext)
668 (int16 x y)
669 (progn
670 ;; Don't let any flushes happen since we manually set the request
671 ;; length when we're done.
672 (with-buffer-flush-inhibited (display)
673 (do* ((boffset (index+ buffer-boffset 16))
674 (src-chunk 0)
675 (dst-chunk 0)
676 (offset 0)
677 (overall-width 0)
678 (stop-p nil))
679 ((or stop-p (zerop length))
680 ;; Ensure terminated with zero bytes
681 (do ((end (lround boffset)))
682 ((index>= boffset end))
683 (setf (aref buffer-bbuf boffset) 0)
684 (index-incf boffset))
685 (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
686 (setf (buffer-boffset display) boffset)
687 (unless (zerop length) (setq next-start src-start))
688 (when overall-width (setq width overall-width)))
689
690 (declare (type array-index boffset src-chunk dst-chunk offset)
691 (type (or null int32) overall-width)
692 (type generalized-boolean stop-p))
693 (setq src-chunk (index-min length *max-string-size*))
694 (multiple-value-bind (new-start new-font translated-width)
695 (funcall translate
696 sequence src-start (index+ src-start src-chunk)
697 font buffer 0)
698 (setq dst-chunk (index- new-start src-start)
699 length (index- length dst-chunk)
700 src-start new-start)
701 (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk)
702 (if translated-width
703 (when overall-width (incf overall-width translated-width))
704 (setq overall-width nil))
705 (when (index-plusp dst-chunk)
706 (setf (aref buffer-bbuf boffset) dst-chunk)
707 (setf (aref buffer-bbuf (index+ boffset 1)) offset)
708 (index-incf boffset (index+ dst-chunk dst-chunk 2)))
709 (setq offset 0)
710 (cond ((null new-font)
711 ;; Don't stop if translate copied whole chunk
712 (unless (index= src-chunk dst-chunk)
713 (setq stop-p t)))
714 ((integerp new-font) (setq offset new-font))
715 ((type? new-font 'font)
716 (setq font new-font)
717 (let ((font-id (font-id font))
718 (buffer-boffset boffset))
719 (declare (type resource-id font-id)
720 (type array-index buffer-boffset))
721 ;; This changes the gcontext font in the SERVER
722 ;; Update the gcontext cache (both local and server state)
723 (let ((local-state (gcontext-local-state gcontext))
724 (server-state (gcontext-server-state gcontext)))
725 (declare (type gcontext-state local-state server-state))
726 (setf (gcontext-internal-font-obj server-state) font
727 (gcontext-internal-font server-state) font-id)
728 (without-interrupts
729 (setf (gcontext-internal-font-obj local-state) font
730 (gcontext-internal-font local-state) font-id)))
731 (card8-put 0 #xff)
732 (card8-put 1 (ldb (byte 8 24) font-id))
733 (card8-put 2 (ldb (byte 8 16) font-id))
734 (card8-put 3 (ldb (byte 8 8) font-id))
735 (card8-put 4 (ldb (byte 8 0) font-id)))
736 (index-incf boffset 5)))
737 )))))
738 (values next-start width)))
739
740 (defun draw-image-glyph (drawable gcontext x y elt
741 &key translate width (size :default))
742 ;; Returns true if elt is output, nil if translate refuses to output it.
743 ;; Second result is overall width, if known. An initial font change is
744 ;; allowed from translate.
745 (declare (type drawable drawable)
746 (type gcontext gcontext)
747 (type int16 x y)
748 (type (or null int32) width)
749 (type index-size size))
750 (declare (type (or null translation-function) translate)
751 #+clx-ansi-common-lisp
752 (dynamic-extent translate)
753 #+(and lispm (not clx-ansi-common-lisp))
754 (sys:downward-funarg #+Genera * #-Genera translate))
755 (declare (clx-values generalized-boolean (or null int32)))
756 (let* ((display (gcontext-display gcontext))
757 (result t)
758 (opcode +x-imagetext8+))
759 (declare (type display display))
760 (let ((vector (allocate-gcontext-state)))
761 (declare (type gcontext-state vector))
762 (setf (aref vector 0) elt)
763 (multiple-value-bind (new-start new-font translate-width)
764 (funcall (or translate #'translate-default)
765 vector 0 1 (gcontext-font gcontext t) vector 1)
766 ;; Allow translate to set a new font
767 (when (type? new-font 'font)
768 (setf (gcontext-font gcontext) new-font)
769 (multiple-value-setq (new-start new-font translate-width)
770 (funcall translate vector 0 1 new-font vector 1)))
771 ;; If new-start is zero, translate refuses to output it
772 (setq result (index-plusp new-start)
773 elt (aref vector 1))
774 (deallocate-gcontext-state vector)
775 (when translate-width (setq width translate-width))))
776 (when result
777 (when (eql size 16)
778 (setq opcode +x-imagetext16+)
779 (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
780 (with-buffer-request (display opcode :gc-force gcontext)
781 (drawable drawable)
782 (gcontext gcontext)
783 (data 1) ;; 1 character
784 (int16 x y)
785 (card8 (ldb (byte 8 0) elt))
786 (card8 (ldb (byte 8 8) elt)))
787 (values t width))))
788
789 (defun draw-image-glyphs (drawable gcontext x y sequence
790 &key (start 0) end translate width (size :default))
791 ;; An initial font change is allowed from translate, but any subsequent font
792 ;; change or horizontal motion will cause termination (because the protocol
793 ;; doesn't support chaining). [Alternatively, font changes could be accepted
794 ;; as long as they are accompanied with a width return value, or always
795 ;; accept font changes and call text-width as required. However, horizontal
796 ;; motion can't really be accepted, due to semantics.] First result is new
797 ;; start, if end was not reached. Second result is overall width, if known.
798 (declare (type drawable drawable)
799 (type gcontext gcontext)
800 (type int16 x y)
801 (type array-index start)
802 (type (or null array-index) end)
803 (type sequence sequence)
804 (type (or null int32) width)
805 (type index-size size))
806 (declare (type (or null translation-function) translate)
807 #+clx-ansi-common-lisp
808 (dynamic-extent translate)
809 #+(and lispm (not clx-ansi-common-lisp))
810 (sys:downward-funarg #+Genera * #-Genera translate))
811 (declare (clx-values (or null array-index) (or null int32)))
812 (setf end (index-min (index+ start 255) (or end (length sequence))))
813 (ecase size
814 ((:default 8)
815 (draw-image-glyphs8 drawable gcontext x y sequence start end translate width))
816 (16
817 (draw-image-glyphs16 drawable gcontext x y sequence start end translate width))))
818
819 (defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width)
820 ;; An initial font change is allowed from translate, but any subsequent font
821 ;; change or horizontal motion will cause termination (because the protocol
822 ;; doesn't support chaining). [Alternatively, font changes could be accepted
823 ;; as long as they are accompanied with a width return value, or always
824 ;; accept font changes and call text-width as required. However, horizontal
825 ;; motion can't really be accepted, due to semantics.] First result is new
826 ;; start, if end was not reached. Second result is overall width, if known.
827 (declare (type drawable drawable)
828 (type gcontext gcontext)
829 (type int16 x y)
830 (type array-index start)
831 (type sequence sequence)
832 (type (or null array-index) end)
833 (type (or null int32) width))
834 (declare (type (or null translation-function) translate)
835 #+clx-ansi-common-lisp
836 (dynamic-extent translate)
837 #+(and lispm (not clx-ansi-common-lisp))
838 (sys:downward-funarg translate))
839 (declare (clx-values (or null array-index) (or null int32)))
840 (do* ((display (gcontext-display gcontext))
841 (length (index- end start))
842 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
843 (font (gcontext-font gcontext t))
844 (font-change nil)
845 (new-start) (translated-width) (chunk))
846 (nil) ;; forever
847 (declare (type display display)
848 (type array-index length)
849 (type (or null array-index) new-start chunk))
850
851 (when font-change
852 (setf (gcontext-font gcontext) font))
853 (block change-font
854 (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length)
855 (drawable drawable)
856 (gcontext gcontext)
857 (int16 x y)
858 (progn
859 ;; Don't let any flushes happen since we manually set the request
860 ;; length when we're done.
861 (with-buffer-flush-inhibited (display)
862 ;; Translate the sequence into the buffer
863 (multiple-value-setq (new-start font translated-width)
864 (funcall (or translate #'translate-default) sequence start end
865 font buffer-bbuf (index+ buffer-boffset 16)))
866 ;; Number of glyphs translated
867 (setq chunk (index- new-start start))
868 ;; Check for initial font change
869 (when (and (index-zerop chunk) (type? font 'font))
870 (setq font-change t) ;; Loop around changing font
871 (return-from change-font))
872 ;; Quit when nothing translated
873 (when (index-zerop chunk)
874 (return-from draw-image-glyphs8 new-start))
875 ;; Update buffer pointers
876 (data-put 1 chunk)
877 (let ((blen (lround (index+ 16 chunk))))
878 (length-put 2 (index-ash blen -2))
879 (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
880 ;; Normal exit
881 (return-from draw-image-glyphs8
882 (values (if (index= chunk length) nil new-start)
883 (or translated-width width))))))
884
885 (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width)
886 ;; An initial font change is allowed from translate, but any subsequent font
887 ;; change or horizontal motion will cause termination (because the protocol
888 ;; doesn't support chaining). [Alternatively, font changes could be accepted
889 ;; as long as they are accompanied with a width return value, or always
890 ;; accept font changes and call text-width as required. However, horizontal
891 ;; motion can't really be accepted, due to semantics.] First result is new
892 ;; start, if end was not reached. Second result is overall width, if known.
893 (declare (type drawable drawable)
894 (type gcontext gcontext)
895 (type int16 x y)
896 (type array-index start)
897 (type sequence sequence)
898 (type (or null array-index) end)
899 (type (or null int32) width))
900 (declare (type (or null translation-function) translate)
901 #+clx-ansi-common-lisp
902 (dynamic-extent translate)
903 #+(and lispm (not clx-ansi-common-lisp))
904 (sys:downward-funarg translate))
905 (declare (clx-values (or null array-index) (or null int32)))
906 (do* ((display (gcontext-display gcontext))
907 (length (index- end start))
908 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
909 (font (gcontext-font gcontext t))
910 (font-change nil)
911 (new-start) (translated-width) (chunk)
912 (buffer (buffer-tbuf16 display)))
913 (nil) ;; forever
914
915 (declare (type display display)
916 (type array-index length)
917 (type (or null array-index) new-start chunk)
918 (type buffer-text16 buffer))
919 (when font-change
920 (setf (gcontext-font gcontext) font))
921
922 (block change-font
923 (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length)
924 (drawable drawable)
925 (gcontext gcontext)
926 (int16 x y)
927 (progn
928 ;; Don't let any flushes happen since we manually set the request
929 ;; length when we're done.
930 (with-buffer-flush-inhibited (display)
931 ;; Translate the sequence into the buffer
932 (multiple-value-setq (new-start font translated-width)
933 (funcall (or translate #'translate-default) sequence start end
934 font buffer 0))
935 ;; Number of glyphs translated
936 (setq chunk (index- new-start start))
937 ;; Check for initial font change
938 (when (and (index-zerop chunk) (type? font 'font))
939 (setq font-change t) ;; Loop around changing font
940 (return-from change-font))
941 ;; Quit when nothing translated
942 (when (index-zerop chunk)
943 (return-from draw-image-glyphs16 new-start))
944 (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk)
945 ;; Update buffer pointers
946 (data-put 1 chunk)
947 (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
948 (length-put 2 (index-ash blen -2))
949 (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
950 ;; Normal exit
951 (return-from draw-image-glyphs16
952 (values (if (index= chunk length) nil new-start)
953 (or translated-width width))))))
954
955
956 ;;-----------------------------------------------------------------------------
957
958 (defun display-keycode-range (display)
959 (declare (type display display))
960 (declare (clx-values min max))
961 (values (display-min-keycode display)
962 (display-max-keycode display)))
963
964 ;; Should this signal device-busy like the pointer-mapping setf, and return a
965 ;; generalized-boolean instead (true for success)? Alternatively, should the
966 ;; pointer-mapping setf be changed to set-pointer-mapping with a (member
967 ;; :success :busy) result?
968
969 (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
970 ;; Setf ought to allow multiple values.
971 (declare (type display display)
972 (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
973 (declare (clx-values (member :success :busy :failed)))
974 (let* ((keycodes-per-modifier (index-max (length shift)
975 (length lock)
976 (length control)
977 (length mod1)
978 (length mod2)
979 (length mod3)
980 (length mod4)
981 (length mod5)))
982 (data (make-array (index* 8 keycodes-per-modifier)
983 :element-type 'card8
984 :initial-element 0)))
985 (replace data shift)
986 (replace data lock :start1 keycodes-per-modifier)
987 (replace data control :start1 (index* 2 keycodes-per-modifier))
988 (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
989 (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
990 (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
991 (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
992 (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
993 (with-buffer-request-and-reply (display +x-setmodifiermapping+ 4 :sizes 8)
994 ((data keycodes-per-modifier)
995 ((sequence :format card8) data))
996 (values (member8-get 1 :success :busy :failed)))))
997
998 (defun modifier-mapping (display)
999 ;; each value is a list of integers
1000 (declare (type display display))
1001 (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))
1002 (let ((lists nil))
1003 (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8)
1004 ()
1005 (do* ((keycodes-per-modifier (card8-get 1))
1006 (advance-by +replysize+ keycodes-per-modifier)
1007 (keys nil nil)
1008 (i 0 (index+ i 1)))
1009 ((index= i 8))
1010 (advance-buffer-offset advance-by)
1011 (dotimes (j keycodes-per-modifier)
1012 (let ((key (read-card8 j)))
1013 (unless (zerop key)
1014 (push key keys))))
1015 (push (nreverse keys) lists)))
1016 (values-list (nreverse lists))))
1017
1018 ;; Either we will want lots of defconstants for well-known values, or perhaps
1019 ;; an integer-to-keyword translation function for well-known values.
1020
1021 (defun change-keyboard-mapping
1022 (display keysyms &key (start 0) end (first-keycode start))
1023 ;; start/end give subrange of keysyms
1024 ;; first-keycode is the first-keycode to store at
1025 (declare (type display display)
1026 (type array-index start)
1027 (type card8 first-keycode)
1028 (type (or null array-index) end)
1029 (type (array * (* *)) keysyms))
1030 (let* ((keycode-end (or end (array-dimension keysyms 0)))
1031 (keysyms-per-keycode (array-dimension keysyms 1))
1032 (length (index- keycode-end start))
1033 (size (index* length keysyms-per-keycode))
1034 (request-length (index+ size 2)))
1035 (declare (type array-index keycode-end keysyms-per-keycode length request-length))
1036 (with-buffer-request (display +x-setkeyboardmapping+
1037 :length (index-ash request-length 2)
1038 :sizes (32))
1039 (data length)
1040 (length request-length)
1041 (card8 first-keycode keysyms-per-keycode)
1042 (progn
1043 (do ((limit (index-ash (buffer-size display) -2))
1044 (w (index+ 2 (index-ash buffer-boffset -2)))
1045 (i start (index+ i 1)))
1046 ((index>= i keycode-end)
1047 (setf (buffer-boffset display) (index-ash w 2)))
1048 (declare (type array-index limit w i))
1049 (when (index> w limit)
1050 (buffer-flush display)
1051 (setq w (index-ash (buffer-boffset display) -2)))
1052 (do ((j 0 (index+ j 1)))
1053 ((index>= j keysyms-per-keycode))
1054 (declare (type array-index j))
1055 (card29-put (index* w 4) (aref keysyms i j))
1056 (index-incf w)))))))
1057
1058 (defun keyboard-mapping (display &key first-keycode start end data)
1059 ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
1060 ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
1061 ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
1062 ;; If DATA is specified, the results are put there.
1063 (declare (type display display)
1064 (type (or null card8) first-keycode)
1065 (type (or null array-index) start end)
1066 (type (or null (array * (* *))) data))
1067 (declare (clx-values (array * (* *))))
1068 (unless first-keycode (setq first-keycode (display-min-keycode display)))
1069 (unless start (setq start first-keycode))
1070 (unless end (setq end (1+ (display-max-keycode display))))
1071 (with-buffer-request-and-reply (display +x-getkeyboardmapping+ nil :sizes (8 32))
1072 ((card8 first-keycode (index- end start)))
1073 (do* ((keysyms-per-keycode (card8-get 1))
1074 (bytes-per-keycode (* keysyms-per-keycode 4))
1075 (advance-by +replysize+ bytes-per-keycode)
1076 (keycode-count (floor (card32-get 4) keysyms-per-keycode)
1077 (index- keycode-count 1))
1078 (result (if (and (arrayp data)
1079 (= (array-rank data) 2)
1080 (>= (array-dimension data 0) (index+ start keycode-count))
1081 (>= (array-dimension data 1) keysyms-per-keycode))
1082 data
1083 (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
1084 :element-type 'keysym :initial-element 0)))
1085 (i start (1+ i)))
1086 ((zerop keycode-count) (setq data result))
1087 (advance-buffer-offset advance-by)
1088 (dotimes (j keysyms-per-keycode)
1089 (setf (aref result i j) (card29-get (* j 4))))))
1090 data)

  ViewVC Help
Powered by ViewVC 1.1.5