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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5