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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Feb 10 00:30:47 1991 UTC (23 years, 2 months ago) by wlott
Changes since 1.1: +8 -5 lines
Removed some bogus type declarations from a DEFSETF.
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)
549 (type array-index start)
550 (type (or array-index null) end)
551 (type sequence sequence)
552 (type (or int32 null) width))
553 (declare (values (or null array-index) (or null int32)))
554 (declare (type translation-function translate)
555 (downward-funarg translate))
556 (let* ((src-start start)
557 (src-end (or end (length sequence)))
558 (next-start nil)
559 (length (index- src-end src-start))
560 (request-length (* length 2)) ; Leave lots of room for font shifts.
561 (display (gcontext-display gcontext))
562 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
563 (font (gcontext-font gcontext t)))
564 (declare (type array-index src-start src-end length)
565 (type (or null array-index) next-start)
566 (type display display))
567 (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)
568 (drawable drawable)
569 (gcontext gcontext)
570 (int16 x y)
571 (progn
572 ;; Don't let any flushes happen since we manually set the request
573 ;; length when we're done.
574 (with-buffer-flush-inhibited (display)
575 (do* ((boffset (index+ buffer-boffset 16))
576 (src-chunk 0)
577 (dst-chunk 0)
578 (offset 0)
579 (overall-width 0)
580 (stop-p nil))
581 ((or stop-p (zerop length))
582 ;; Ensure terminated with zero bytes
583 (do ((end (the array-index (lround boffset))))
584 ((index>= boffset end))
585 (setf (aref buffer-bbuf boffset) 0)
586 (index-incf boffset))
587 (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
588 (setf (buffer-boffset display) boffset)
589 (unless (index-zerop length) (setq next-start src-start))
590 (when overall-width (setq width overall-width)))
591
592 (declare (type array-index src-chunk dst-chunk offset)
593 (type (or null int32) overall-width)
594 (type boolean stop-p))
595 (setq src-chunk (index-min length *max-string-size*))
596 (multiple-value-bind (new-start new-font translated-width)
597 (funcall translate
598 sequence src-start (index+ src-start src-chunk)
599 font buffer-bbuf (index+ boffset 2))
600 (setq dst-chunk (index- new-start src-start)
601 length (index- length dst-chunk)
602 src-start new-start)
603 (if translated-width
604 (when overall-width (incf overall-width translated-width))
605 (setq overall-width nil))
606 (when (index-plusp dst-chunk)
607 (setf (aref buffer-bbuf boffset) dst-chunk)
608 (setf (aref buffer-bbuf (index+ boffset 1)) offset)
609 (incf boffset (index+ dst-chunk 2)))
610 (setq offset 0)
611 (cond ((null new-font)
612 ;; Don't stop if translate copied whole chunk
613 (unless (index= src-chunk dst-chunk)
614 (setq stop-p t)))
615 ((integerp new-font) (setq offset new-font))
616 ((type? new-font 'font)
617 (setq font new-font)
618 (let ((font-id (font-id font))
619 (buffer-boffset boffset))
620 (declare (type resource-id font-id)
621 (type array-index buffer-boffset))
622 ;; This changes the gcontext font in the server
623 ;; Update the gcontext cache (both local and server state)
624 (let ((local-state (gcontext-local-state gcontext))
625 (server-state (gcontext-server-state gcontext)))
626 (declare (type gcontext-state local-state server-state))
627 (setf (gcontext-internal-font-obj server-state) font
628 (gcontext-internal-font server-state) font-id)
629 (without-interrupts
630 (setf (gcontext-internal-font-obj local-state) font
631 (gcontext-internal-font local-state) font-id)))
632 (card8-put 0 #xff)
633 (card8-put 1 (ldb (byte 8 24) font-id))
634 (card8-put 2 (ldb (byte 8 16) font-id))
635 (card8-put 3 (ldb (byte 8 8) font-id))
636 (card8-put 4 (ldb (byte 8 0) font-id)))
637 (index-incf boffset 5)))
638 )))))
639 (values next-start width)))
640
641 ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
642 ;; on 16bit boundaries and this function garbles the bytes.
643 (defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
644 ;; First result is new start, if end was not reached. Second result is
645 ;; overall width, if known.
646 (declare (type drawable drawable)
647 (type gcontext gcontext)
648 (type int16 x y)
649 (type array-index start)
650 (type (or array-index null) end)
651 (type (or null int32) width)
652 (type sequence sequence))
653 (declare (values (or null array-index) (or null int32)))
654 (declare (type translation-function translate)
655 (downward-funarg translate))
656 (let* ((src-start start)
657 (src-end (or end (length sequence)))
658 (next-start nil)
659 (length (index- src-end src-start))
660 (request-length (* length 3)) ; Leave lots of room for font shifts.
661 (display (gcontext-display gcontext))
662 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
663 (font (gcontext-font gcontext t))
664 (buffer (display-tbuf16 display)))
665 (declare (type array-index src-start src-end length)
666 (type (or null array-index) next-start)
667 (type display display)
668 (type buffer-text16 buffer))
669 (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)
670 (drawable drawable)
671 (gcontext gcontext)
672 (int16 x y)
673 (progn
674 ;; Don't let any flushes happen since we manually set the request
675 ;; length when we're done.
676 (with-buffer-flush-inhibited (display)
677 (do* ((boffset (index+ buffer-boffset 16))
678 (src-chunk 0)
679 (dst-chunk 0)
680 (offset 0)
681 (overall-width 0)
682 (stop-p nil))
683 ((or stop-p (zerop length))
684 ;; Ensure terminated with zero bytes
685 (do ((end (lround boffset)))
686 ((index>= boffset end))
687 (setf (aref buffer-bbuf boffset) 0)
688 (index-incf boffset))
689 (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
690 (setf (buffer-boffset display) boffset)
691 (unless (zerop length) (setq next-start src-start))
692 (when overall-width (setq width overall-width)))
693
694 (declare (type array-index boffset src-chunk dst-chunk offset)
695 (type (or null int32) overall-width)
696 (type boolean stop-p))
697 (setq src-chunk (index-min length *max-string-size*))
698 (multiple-value-bind (new-start new-font translated-width)
699 (funcall translate
700 sequence src-start (index+ src-start src-chunk)
701 font buffer 0)
702 (setq dst-chunk (index- new-start src-start)
703 length (index- length dst-chunk)
704 src-start new-start)
705 (write-sequence-card16 display (index+ boffset 2) buffer 0 dst-chunk
706 #+clx-little-endian ;; Byte swap for little-endian
707 #'byte-swap-card16)
708 (if translated-width
709 (when overall-width (incf overall-width translated-width))
710 (setq overall-width nil))
711 (when (index-plusp dst-chunk)
712 (setf (aref buffer-bbuf boffset) dst-chunk)
713 (setf (aref buffer-bbuf (index+ boffset 1)) offset)
714 (index-incf boffset (index+ dst-chunk dst-chunk 2)))
715 (setq offset 0)
716 (cond ((null new-font)
717 ;; Don't stop if translate copied whole chunk
718 (unless (index= src-chunk dst-chunk)
719 (setq stop-p t)))
720 ((integerp new-font) (setq offset new-font))
721 ((type? new-font 'font)
722 (setq font new-font)
723 (let ((font-id (font-id font))
724 (buffer-boffset boffset))
725 (declare (type resource-id font-id)
726 (type array-index buffer-boffset))
727 ;; This changes the gcontext font in the SERVER
728 ;; Update the gcontext cache (both local and server state)
729 (let ((local-state (gcontext-local-state gcontext))
730 (server-state (gcontext-server-state gcontext)))
731 (declare (type gcontext-state local-state server-state))
732 (setf (gcontext-internal-font-obj server-state) font
733 (gcontext-internal-font server-state) font-id)
734 (without-interrupts
735 (setf (gcontext-internal-font-obj local-state) font
736 (gcontext-internal-font local-state) font-id)))
737 (card8-put 0 #xff)
738 (card8-put 1 (ldb (byte 8 24) font-id))
739 (card8-put 2 (ldb (byte 8 16) font-id))
740 (card8-put 3 (ldb (byte 8 8) font-id))
741 (card8-put 4 (ldb (byte 8 0) font-id)))
742 (index-incf boffset 5)))
743 )))))
744 (values next-start width)))
745
746 (defun draw-image-glyph (drawable gcontext x y elt
747 &key translate width (size :default))
748 ;; Returns true if elt is output, nil if translate refuses to output it.
749 ;; Second result is overall width, if known. An initial font change is
750 ;; allowed from translate.
751 (declare (type drawable drawable)
752 (type gcontext gcontext)
753 (type int16 x y)
754 (type (or null int32) width)
755 (type index-size size))
756 (declare (type (or null translation-function) translate)
757 (downward-funarg #+Genera * #-Genera translate))
758 (declare (values boolean (or null int32)))
759 (let* ((display (gcontext-display gcontext))
760 (result t)
761 (opcode *x-imagetext8*))
762 (declare (type display display))
763 (let ((vector (allocate-gcontext-state)))
764 (declare (type gcontext-state vector))
765 (setf (aref vector 0) elt)
766 (multiple-value-bind (new-start new-font translate-width)
767 (funcall (or translate #'translate-default)
768 vector 0 1 (gcontext-font gcontext t) vector 1)
769 ;; Allow translate to set a new font
770 (when (type? new-font 'font)
771 (setf (gcontext-font gcontext) new-font)
772 (multiple-value-setq (new-start new-font translate-width)
773 (funcall translate vector 0 1 new-font vector 1)))
774 ;; If new-start is zero, translate refuses to output it
775 (setq result (index-plusp new-start)
776 elt (aref vector 1))
777 (deallocate-gcontext-state vector)
778 (when translate-width (setq width translate-width))))
779 (when result
780 (when (eql size 16)
781 (setq opcode *x-imagetext16*)
782 (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
783 (with-buffer-request (display opcode :gc-force gcontext)
784 (drawable drawable)
785 (gcontext gcontext)
786 (data 1) ;; 1 character
787 (int16 x y)
788 (card8 (ldb (byte 8 0) elt))
789 (card8 (ldb (byte 8 8) elt)))
790 (values t width))))
791
792 (defun draw-image-glyphs (drawable gcontext x y sequence
793 &key (start 0) end width translate (size :default))
794 ;; An initial font change is allowed from translate, but any subsequent font
795 ;; change or horizontal motion will cause termination (because the protocol
796 ;; doesn't support chaining). [Alternatively, font changes could be accepted
797 ;; as long as they are accompanied with a width return value, or always
798 ;; accept font changes and call text-width as required. However, horizontal
799 ;; motion can't really be accepted, due to semantics.] First result is new
800 ;; start, if end was not reached. Second result is overall width, if known.
801 (declare (type drawable drawable)
802 (type gcontext gcontext)
803 (type int16 x y)
804 (type array-index start)
805 (type (or null array-index) end)
806 (type sequence sequence)
807 (type (or null int32) width)
808 (type index-size size))
809 (declare (type (or null translation-function) translate)
810 (downward-funarg #+Genera * #-Genera translate))
811 (declare (values (or null array-index) (or null int32)))
812 (unless end (setq end (length sequence)))
813 (ecase size
814 ((:default 8)
815 (draw-image-glyphs8 drawable gcontext x y sequence start end width translate))
816 (16
817 (draw-image-glyphs16 drawable gcontext x y sequence start end width translate))))
818
819 (defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate)
820 ;; An initial font change is allowed from translate, but any subsequent font
821 ;; change or horizontal motion will cause termination (because the protocol
822 ;; doesn't support chaining). [Alternatively, font changes could be accepted
823 ;; as long as they are accompanied with a width return value, or always
824 ;; accept font changes and call text-width as required. However, horizontal
825 ;; motion can't really be accepted, due to semantics.] First result is new
826 ;; start, if end was not reached. Second result is overall width, if known.
827 (declare (type drawable drawable)
828 (type gcontext gcontext)
829 (type int16 x y)
830 (type array-index start)
831 (type sequence sequence)
832 (type (or null array-index) end)
833 (type (or null int32) width))
834 (declare (type (or null translation-function) translate)
835 (downward-funarg translate))
836 (declare (values (or null array-index) (or null int32)))
837 (do* ((display (gcontext-display gcontext))
838 (length (index- end start))
839 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
840 (font (gcontext-font gcontext t))
841 (font-change nil)
842 (new-start) (translated-width) (chunk))
843 (nil) ;; forever
844 (declare (type display display)
845 (type array-index length)
846 (type (or null array-index) new-start chunk))
847
848 (when font-change
849 (setf (gcontext-font gcontext) font))
850 (block change-font
851 (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
852 (drawable drawable)
853 (gcontext gcontext)
854 (int16 x y)
855 (progn
856 ;; Don't let any flushes happen since we manually set the request
857 ;; length when we're done.
858 (with-buffer-flush-inhibited (display)
859 ;; Translate the sequence into the buffer
860 (multiple-value-setq (new-start font translated-width)
861 (funcall (or translate #'translate-default) sequence start end
862 font buffer-bbuf (index+ buffer-boffset 16)))
863 ;; Number of glyphs translated
864 (setq chunk (index- new-start start))
865 ;; Check for initial font change
866 (when (and (index-zerop chunk) (type? font 'font))
867 (setq font-change t) ;; Loop around changing font
868 (return-from change-font))
869 ;; Quit when nothing translated
870 (when (index-zerop chunk)
871 (return-from draw-image-glyphs8 new-start))
872 ;; Update buffer pointers
873 (data-put 1 chunk)
874 (let ((blen (lround (index+ 16 chunk))))
875 (length-put 2 (index-ash blen -2))
876 (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
877 ;; Normal exit
878 (return-from draw-image-glyphs8
879 (values (if (index= chunk length) nil new-start)
880 (or translated-width width))))))
881
882 (defun draw-image-glyphs16 (drawable gcontext x y sequence start end width translate)
883 ;; An initial font change is allowed from translate, but any subsequent font
884 ;; change or horizontal motion will cause termination (because the protocol
885 ;; doesn't support chaining). [Alternatively, font changes could be accepted
886 ;; as long as they are accompanied with a width return value, or always
887 ;; accept font changes and call text-width as required. However, horizontal
888 ;; motion can't really be accepted, due to semantics.] First result is new
889 ;; start, if end was not reached. Second result is overall width, if known.
890 (declare (type drawable drawable)
891 (type gcontext gcontext)
892 (type int16 x y)
893 (type array-index start)
894 (type sequence sequence)
895 (type (or null array-index) end)
896 (type (or null int32) width))
897 (declare (type (or null translation-function) translate)
898 (downward-funarg translate))
899 (declare (values (or null array-index) (or null int32)))
900 (do* ((display (gcontext-display gcontext))
901 (length (index- end start))
902 ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
903 (font (gcontext-font gcontext t))
904 (font-change nil)
905 (new-start) (translated-width) (chunk)
906 (buffer (buffer-tbuf16 display)))
907 (nil) ;; forever
908
909 (declare (type display display)
910 (type array-index length)
911 (type (or null array-index) new-start chunk)
912 (type buffer-text16 buffer))
913 (when font-change
914 (setf (gcontext-font gcontext) font))
915
916 (block change-font
917 (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
918 (drawable drawable)
919 (gcontext gcontext)
920 (int16 x y)
921 (progn
922 ;; Don't let any flushes happen since we manually set the request
923 ;; length when we're done.
924 (with-buffer-flush-inhibited (display)
925 ;; Translate the sequence into the buffer
926 (multiple-value-setq (new-start font translated-width)
927 (funcall (or translate #'translate-default) sequence start end
928 font buffer 0))
929 ;; Number of glyphs translated
930 (setq chunk (index- new-start start))
931 ;; Check for initial font change
932 (when (and (index-zerop chunk) (type? font 'font))
933 (setq font-change t) ;; Loop around changing font
934 (return-from change-font))
935 ;; Quit when nothing translated
936 (when (index-zerop chunk)
937 (return-from draw-image-glyphs16 new-start))
938 (write-sequence-card16 display (index+ buffer-boffset 16) buffer 0 chunk
939 #+clx-little-endian ;; Byte swap for little-endian
940 #'byte-swap-card16)
941 ;; Update buffer pointers
942 (data-put 1 chunk)
943 (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
944 (length-put 2 (index-ash blen -2))
945 (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
946 ;; Normal exit
947 (return-from draw-image-glyphs16
948 (values (if (index= chunk length) nil new-start)
949 (or translated-width width))))))
950
951
952 ;;-----------------------------------------------------------------------------
953
954 (defun display-keycode-range (display)
955 (declare (type display display))
956 (declare (values min max))
957 (values (display-min-keycode display)
958 (display-max-keycode display)))
959
960 ;; Should this signal device-busy like the pointer-mapping setf, and return a
961 ;; boolean instead (true for success)? Alternatively, should the
962 ;; pointer-mapping setf be changed to set-pointer-mapping with a (member
963 ;; :success :busy) result?
964
965 (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
966 ;; Setf ought to allow multiple values.
967 (declare (type display display)
968 (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
969 (declare (values (member :success :busy :failed)))
970 (let* ((keycodes-per-modifier (index-max (length shift)
971 (length lock)
972 (length control)
973 (length mod1)
974 (length mod2)
975 (length mod3)
976 (length mod4)
977 (length mod5)))
978 (data (make-array (index* 8 keycodes-per-modifier)
979 :element-type 'card8
980 :initial-element 0)))
981 (replace data shift)
982 (replace data lock :start1 keycodes-per-modifier)
983 (replace data control :start1 (index* 2 keycodes-per-modifier))
984 (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
985 (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
986 (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
987 (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
988 (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
989 (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)
990 ((data keycodes-per-modifier)
991 ((sequence :format card8) data))
992 (values (member8-get 1 :success :busy :failed)))))
993
994 (defun modifier-mapping (display)
995 ;; each value is a list of integers
996 (declare (type display display))
997 (declare (values shift lock control mod1 mod2 mod3 mod4 mod5))
998 (let ((lists nil))
999 (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
1000 ()
1001 (do* ((keycodes-per-modifier (card8-get 1))
1002 (advance-by *replysize* keycodes-per-modifier)
1003 (keys nil nil)
1004 (i 0 (index+ i 1)))
1005 ((index= i 8))
1006 (advance-buffer-offset advance-by)
1007 (dotimes (j keycodes-per-modifier)
1008 (let ((key (read-card8 j)))
1009 (unless (zerop key)
1010 (push key keys))))
1011 (push (nreverse keys) lists)))
1012 (values-list (nreverse lists))))
1013
1014 ;; Either we will want lots of defconstants for well-known values, or perhaps
1015 ;; an integer-to-keyword translation function for well-known values.
1016
1017 (defun change-keyboard-mapping
1018 (display keysyms &key (start 0) end (first-keycode start))
1019 ;; start/end give subrange of keysyms
1020 ;; first-keycode is the first-keycode to store at
1021 (declare (type display display)
1022 (type array-index start)
1023 (type card8 first-keycode)
1024 (type (or null array-index) end)
1025 (type (array * (* *)) keysyms))
1026 (let* ((keycode-end (or end (array-dimension keysyms 0)))
1027 (keysyms-per-keycode (array-dimension keysyms 1))
1028 (length (index- keycode-end start))
1029 (size (index* length keysyms-per-keycode))
1030 (request-length (index+ size 2)))
1031 (declare (type array-index keycode-end keysyms-per-keycode length request-length))
1032 (with-buffer-request (display *x-setkeyboardmapping*
1033 :length (index-ash request-length 2)
1034 :sizes (32))
1035 (data length)
1036 (length request-length)
1037 (card8 first-keycode keysyms-per-keycode)
1038 (progn
1039 (do ((limit (index-ash (buffer-size display) -2))
1040 (w (index+ 2 (index-ash buffer-boffset -2)))
1041 (i start (index+ i 1)))
1042 ((index>= i keycode-end)
1043 (setf (buffer-boffset display) (index-ash w 2)))
1044 (declare (type array-index limit w i))
1045 (when (index> w limit)
1046 (buffer-flush display)
1047 (setq w (index-ash (buffer-boffset display) -2)))
1048 (do ((j 0 (index+ j 1)))
1049 ((index>= j keysyms-per-keycode))
1050 (declare (type array-index j))
1051 (card29-put (index* w 4) (aref keysyms i j))
1052 (index-incf w)))))))
1053
1054 (defun keyboard-mapping (display &key first-keycode start end data)
1055 ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
1056 ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
1057 ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
1058 ;; If DATA is specified, the results are put there.
1059 (declare (type display display)
1060 (type (or null card8) first-keycode)
1061 (type (or null array-index) start end)
1062 (type (or null (array * (* *))) data))
1063 (declare (values (array * (* *))))
1064 (unless first-keycode (setq first-keycode (display-min-keycode display)))
1065 (unless start (setq start first-keycode))
1066 (unless end (setq end (1+ (display-max-keycode display))))
1067 (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))
1068 ((card8 first-keycode (index- end start)))
1069 (do* ((keysyms-per-keycode (card8-get 1))
1070 (bytes-per-keycode (* keysyms-per-keycode 4))
1071 (advance-by *replysize* bytes-per-keycode)
1072 (keycode-count (floor (card32-get 4) keysyms-per-keycode)
1073 (index- keycode-count 1))
1074 (result (if (and (arrayp data)
1075 (= (array-rank data) 2)
1076 (>= (array-dimension data 0) (index+ start keycode-count))
1077 (>= (array-dimension data 1) keysyms-per-keycode))
1078 data
1079 (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
1080 :element-type 'keysym :initial-element 0)))
1081 (i start (1+ i)))
1082 ((zerop keycode-count) (setq data result))
1083 (advance-buffer-offset advance-by)
1084 (dotimes (j keysyms-per-keycode)
1085 (setf (aref result i j) (card29-get (* j 4))))))
1086 data)

  ViewVC Help
Powered by ViewVC 1.1.5