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

  ViewVC Help
Powered by ViewVC 1.1.5