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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5