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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5