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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5