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

Contents of /src/clx/text.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Nov 7 16:58:45 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
Changes since 1.1: +76 -74 lines
CLX R5 changes.
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    
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 (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 ram 1.2 #+clx-ansi-common-lisp
114     (dynamic-extent translate)
115     #+(and lispm (not clx-ansi-common-lisp))
116     (sys:downward-funarg #+Genera * #-Genera translate))
117 ram 1.1 (declare (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 ram 1.2 (src-start start (index+ src-start buf-end))
143 ram 1.1 (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 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 ram 1.2 ((integerp new-font) (incf width (the int32 new-font))))
165 ram 1.1
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 ram 1.2
191     (when (type? new-font 'font)
192     (setq font new-font))
193    
194 ram 1.1 (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 ram 1.2 #+clx-ansi-common-lisp
221     (dynamic-extent translate)
222     #+(and lispm (not clx-ansi-common-lisp))
223     (sys:downward-funarg #+Genera * #-Genera translate))
224 ram 1.1 (declare (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 ram 1.2 (src-start start (index+ src-start buf-end))
239 ram 1.1 (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 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 ram 1.2 ((integerp new-font) (incf width (the int32 new-font))))
257 ram 1.1
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 ram 1.2 (text-width-server font wbuf 0 buf-end)))
262     (when (type? new-font 'font)
263     (setq font new-font))))
264 ram 1.1 (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 (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 ram 1.2 ((sequence :format char2b :start start :end end :appending t)
282 ram 1.1 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 (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 ram 1.2 ((sequence :format char2b :start start :end end :appending t)
309 ram 1.1 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 boolean width-only-p))
317     (declare (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     (array-register char-infos))
323     (if (zerop (length char-infos))
324     ;; Fixed width font
325     (let* ((font-width (max-char-width font))
326     (font-ascent (max-char-ascent font))
327     (font-descent (max-char-descent font))
328     (width (* (index- end start) font-width)))
329     (declare (type int16 font-width font-ascent font-descent)
330     (type int32 width))
331     (if width-only-p
332     width
333     (values width
334     font-ascent
335     font-descent
336     (max-char-left-bearing font)
337     (+ width (- font-width) (max-char-right-bearing font)))))
338    
339     ;; Variable-width font
340     (let* ((first-col (font-info-min-byte2 font-info))
341     (num-cols (1+ (- (font-info-max-byte2 font-info) first-col)))
342     (first-row (font-info-min-byte1 font-info))
343     (last-row (font-info-max-byte1 font-info))
344     (num-rows (1+ (- last-row first-row))))
345     (declare (type card8 first-col first-row last-row)
346     (type card16 num-cols num-rows))
347     (if (or (plusp first-row) (plusp last-row))
348    
349     ;; Matrix (16 bit) font
350     (macrolet ((char-info-elt (sequence elt)
351     `(let* ((char (the card16 (elt ,sequence ,elt)))
352     (row (- (ash char -8) first-row))
353     (col (- (logand char #xff) first-col)))
354     (declare (type card16 char)
355     (type int16 row col))
356     (if (and (< -1 row num-rows) (< -1 col num-cols))
357     (index* 6 (index+ (index* row num-cols) col))
358     -1))))
359     (if width-only-p
360     (do ((i start (index1+ i))
361     (width 0))
362     ((index>= i end) width)
363     (declare (type array-index i)
364     (type int32 width))
365     (let ((n (char-info-elt sequence i)))
366     (declare (type fixnum n))
367     (unless (minusp n) ;; Ignore characters not in the font
368     (incf width (the int16 (aref char-infos (index+ 2 n)))))))
369     ;; extents
370     (do ((i start (index1+ i))
371     (width 0)
372 ram 1.2 (ascent #x-7fff)
373     (descent #x-7fff)
374 ram 1.1 (left #x7fff)
375 ram 1.2 (right #x-7fff))
376 ram 1.1 ((index>= i end)
377     (values width ascent descent left right))
378     (declare (type array-index i)
379     (type int16 ascent descent)
380     (type int32 width left right))
381     (let ((n (char-info-elt sequence i)))
382     (declare (type fixnum n))
383     (unless (minusp n) ;; Ignore characters not in the font
384     (setq left (min left (+ width (aref char-infos n))))
385     (setq right (max right (+ width (aref char-infos (index1+ n)))))
386     (incf width (aref char-infos (index+ 2 n)))
387     (setq ascent (max ascent (aref char-infos (index+ 3 n))))
388     (setq descent (max descent (aref char-infos (index+ 4 n)))))))))
389    
390     ;; Non-matrix (8 bit) font
391     ;; The code here is identical to the above, except for the following macro:
392     (macrolet ((char-info-elt (sequence elt)
393     `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col)))
394     (declare (type int16 col))
395     (if (< -1 col num-cols)
396     (index* 6 col)
397     -1))))
398     (if width-only-p
399     (do ((i start (index1+ i))
400     (width 0))
401     ((index>= i end) width)
402     (declare (type array-index i)
403     (type int32 width))
404     (let ((n (char-info-elt sequence i)))
405     (declare (type fixnum n))
406     (unless (minusp n) ;; Ignore characters not in the font
407     (incf width (the int16 (aref char-infos (index+ 2 n)))))))
408     ;; extents
409     (do ((i start (index1+ i))
410     (width 0)
411 ram 1.2 (ascent #x-7fff)
412     (descent #x-7fff)
413 ram 1.1 (left #x7fff)
414 ram 1.2 (right #x-7fff))
415 ram 1.1 ((index>= i end)
416     (values width ascent descent left right))
417     (declare (type array-index i)
418     (type int16 ascent descent)
419     (type int32 width left right))
420     (let ((n (char-info-elt sequence i)))
421     (declare (type fixnum n))
422     (unless (minusp n) ;; Ignore characters not in the font
423     (setq left (min left (+ width (aref char-infos n))))
424     (setq right (max right (+ width (aref char-infos (index1+ n)))))
425     (incf width (aref char-infos (index+ 2 n)))
426     (setq ascent (max ascent (aref char-infos (index+ 3 n))))
427     (setq descent (max descent (aref char-infos (index+ 4 n)))))
428     ))))
429     )))))
430    
431     ;;-----------------------------------------------------------------------------
432    
433     ;; This controls the element size of the dst buffer given to translate. If
434     ;; :default is specified, the size will be based on the current font, if known,
435     ;; and otherwise 16 will be used. [An alternative would be to pass the buffer
436     ;; size to translate, and allow it to return the desired size if it doesn't
437     ;; like the current size. The problem is that the protocol doesn't allow
438     ;; switching within a single request, so to allow switching would require
439     ;; knowing the width of text, which isn't necessarily known. We could call
440     ;; text-width to compute it, but perhaps that is doing too many favors?] [An
441     ;; additional possibility is to allow an index-size of :two-byte, in which case
442     ;; translate would be given a double-length 8-bit array, and translate would be
443     ;; expected to store first-byte/second-byte instead of 16-bit integers.]
444    
445     (deftype index-size () '(member :default 8 16))
446    
447     ;; In the functions below, if width is specified, it is assumed to be the total
448     ;; pixel width of whatever string of glyphs is actually drawn. Specifying
449     ;; width will allow for appending the output of subsequent calls to the same
450     ;; protocol request, provided gcontext has not been modified in the interim.
451     ;; If width is not specified, appending of subsequent output might not occur
452     ;; (unless translate returns the width). Specifying width is simply a hint,
453     ;; for performance.
454    
455     (defun draw-glyph (drawable gcontext x y elt
456     &key translate width (size :default))
457     ;; Returns true if elt is output, nil if translate refuses to output it.
458     ;; Second result is width, if known.
459     (declare (type drawable drawable)
460     (type gcontext gcontext)
461     (type int16 x y)
462     (type (or null int32) width)
463     (type index-size size))
464     (declare (type (or null translation-function) translate)
465 ram 1.2 #+clx-ansi-common-lisp
466     (dynamic-extent translate)
467     #+(and lispm (not clx-ansi-common-lisp))
468     (sys:downward-funarg #+Genera * #-Genera translate))
469 ram 1.1 (declare (values boolean (or null int32)))
470     (let* ((display (gcontext-display gcontext))
471     (result t)
472     (opcode *x-polytext8*))
473     (declare (type display display))
474     (let ((vector (allocate-gcontext-state)))
475     (declare (type gcontext-state vector))
476     (setf (aref vector 0) elt)
477     (multiple-value-bind (new-start new-font translate-width)
478     (funcall (or translate #'translate-default)
479     vector 0 1 (gcontext-font gcontext t) vector 1)
480     ;; Allow translate to set a new font
481     (when (type? new-font 'font)
482     (setf (gcontext-font gcontext) new-font)
483     (multiple-value-setq (new-start new-font translate-width)
484     (funcall translate vector 0 1 new-font vector 1)))
485     ;; If new-start is zero, translate refuses to output it
486     (setq result (index-plusp new-start)
487     elt (aref vector 1))
488     (deallocate-gcontext-state vector)
489     (when translate-width (setq width translate-width))))
490     (when result
491     (when (eql size 16)
492     (setq opcode *x-polytext16*)
493     (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
494     (with-buffer-request (display opcode :gc-force gcontext)
495     (drawable drawable)
496     (gcontext gcontext)
497     (int16 x y)
498     (card8 1 0)
499     (card8 (ldb (byte 8 0) elt))
500     (card8 (ldb (byte 8 8) elt)))
501     (values t width))))
502    
503     (defun draw-glyphs (drawable gcontext x y sequence
504     &key (start 0) end translate width (size :default))
505     ;; First result is new start, if end was not reached. Second result is
506     ;; overall width, if known.
507     (declare (type drawable drawable)
508     (type gcontext gcontext)
509     (type int16 x y)
510     (type array-index start)
511     (type sequence sequence)
512     (type (or null array-index) end)
513     (type (or null int32) width)
514     (type index-size size))
515     (declare (type (or null translation-function) translate)
516 ram 1.2 #+clx-ansi-common-lisp
517     (dynamic-extent translate)
518     #+(and lispm (not clx-ansi-common-lisp))
519     (sys:downward-funarg #+Genera * #-Genera translate))
520 ram 1.1 (declare (values (or null array-index) (or null int32)))
521     (unless end (setq end (length sequence)))
522     (ecase size
523     ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end
524     (or translate #'translate-default) width))
525     (16 (draw-glyphs16 drawable gcontext x y sequence start end
526     (or translate #'translate-default) width))))
527    
528     (defun draw-glyphs8 (drawable gcontext x y sequence start end translate width)
529     ;; First result is new start, if end was not reached. Second result is
530     ;; overall width, if known.
531     (declare (type drawable drawable)
532     (type gcontext gcontext)
533 ram 1.2 (type int16 x y)
534     (type array-index start)
535     (type sequence sequence)
536     (type (or null array-index) end)
537     (type (or null int32) width))
538 ram 1.1 (declare (values (or null array-index) (or null int32)))
539     (declare (type translation-function translate)
540 ram 1.2 #+clx-ansi-common-lisp
541     (dynamic-extent translate)
542     #+(and lispm (not clx-ansi-common-lisp))
543     (sys:downward-funarg translate))
544 ram 1.1 (let* ((src-start start)
545     (src-end (or end (length sequence)))
546     (next-start nil)
547     (length (index- src-end src-start))
548     (request-length (* length 2)) ; Leave lots of room for font shifts.
549     (display (gcontext-display gcontext))
550     ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
551     (font (gcontext-font gcontext t)))
552     (declare (type array-index src-start src-end length)
553     (type (or null array-index) next-start)
554     (type display display))
555     (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)
556     (drawable drawable)
557     (gcontext gcontext)
558     (int16 x y)
559     (progn
560     ;; Don't let any flushes happen since we manually set the request
561     ;; length when we're done.
562     (with-buffer-flush-inhibited (display)
563     (do* ((boffset (index+ buffer-boffset 16))
564     (src-chunk 0)
565     (dst-chunk 0)
566     (offset 0)
567     (overall-width 0)
568     (stop-p nil))
569     ((or stop-p (zerop length))
570     ;; Ensure terminated with zero bytes
571     (do ((end (the array-index (lround boffset))))
572     ((index>= boffset end))
573     (setf (aref buffer-bbuf boffset) 0)
574     (index-incf boffset))
575     (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
576     (setf (buffer-boffset display) boffset)
577     (unless (index-zerop length) (setq next-start src-start))
578     (when overall-width (setq width overall-width)))
579    
580     (declare (type array-index src-chunk dst-chunk offset)
581     (type (or null int32) overall-width)
582     (type boolean stop-p))
583     (setq src-chunk (index-min length *max-string-size*))
584     (multiple-value-bind (new-start new-font translated-width)
585     (funcall translate
586     sequence src-start (index+ src-start src-chunk)
587     font buffer-bbuf (index+ boffset 2))
588     (setq dst-chunk (index- new-start src-start)
589     length (index- length dst-chunk)
590     src-start new-start)
591     (if translated-width
592     (when overall-width (incf overall-width translated-width))
593     (setq overall-width nil))
594     (when (index-plusp dst-chunk)
595     (setf (aref buffer-bbuf boffset) dst-chunk)
596     (setf (aref buffer-bbuf (index+ boffset 1)) offset)
597     (incf boffset (index+ dst-chunk 2)))
598     (setq offset 0)
599     (cond ((null new-font)
600     ;; Don't stop if translate copied whole chunk
601     (unless (index= src-chunk dst-chunk)
602     (setq stop-p t)))
603     ((integerp new-font) (setq offset new-font))
604     ((type? new-font 'font)
605     (setq font new-font)
606     (let ((font-id (font-id font))
607     (buffer-boffset boffset))
608     (declare (type resource-id font-id)
609     (type array-index buffer-boffset))
610     ;; This changes the gcontext font in the server
611     ;; Update the gcontext cache (both local and server state)
612     (let ((local-state (gcontext-local-state gcontext))
613     (server-state (gcontext-server-state gcontext)))
614     (declare (type gcontext-state local-state server-state))
615     (setf (gcontext-internal-font-obj server-state) font
616     (gcontext-internal-font server-state) font-id)
617     (without-interrupts
618     (setf (gcontext-internal-font-obj local-state) font
619     (gcontext-internal-font local-state) font-id)))
620     (card8-put 0 #xff)
621     (card8-put 1 (ldb (byte 8 24) font-id))
622     (card8-put 2 (ldb (byte 8 16) font-id))
623     (card8-put 3 (ldb (byte 8 8) font-id))
624     (card8-put 4 (ldb (byte 8 0) font-id)))
625     (index-incf boffset 5)))
626     )))))
627     (values next-start width)))
628    
629     ;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
630     ;; on 16bit boundaries and this function garbles the bytes.
631     (defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
632     ;; First result is new start, if end was not reached. Second result is
633     ;; overall width, if known.
634     (declare (type drawable drawable)
635     (type gcontext gcontext)
636     (type int16 x y)
637 ram 1.2 (type array-index start)
638     (type sequence sequence)
639     (type (or null array-index) end)
640     (type (or null int32) width))
641 ram 1.1 (declare (values (or null array-index) (or null int32)))
642     (declare (type translation-function translate)
643 ram 1.2 #+clx-ansi-common-lisp
644     (dynamic-extent translate)
645     #+(and lispm (not clx-ansi-common-lisp))
646     (sys:downward-funarg translate))
647 ram 1.1 (let* ((src-start start)
648     (src-end (or end (length sequence)))
649     (next-start nil)
650     (length (index- src-end src-start))
651     (request-length (* length 3)) ; Leave lots of room for font shifts.
652     (display (gcontext-display gcontext))
653     ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
654     (font (gcontext-font gcontext t))
655     (buffer (display-tbuf16 display)))
656     (declare (type array-index src-start src-end length)
657     (type (or null array-index) next-start)
658     (type display display)
659     (type buffer-text16 buffer))
660     (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)
661     (drawable drawable)
662     (gcontext gcontext)
663     (int16 x y)
664     (progn
665     ;; Don't let any flushes happen since we manually set the request
666     ;; length when we're done.
667     (with-buffer-flush-inhibited (display)
668     (do* ((boffset (index+ buffer-boffset 16))
669     (src-chunk 0)
670     (dst-chunk 0)
671     (offset 0)
672     (overall-width 0)
673     (stop-p nil))
674     ((or stop-p (zerop length))
675     ;; Ensure terminated with zero bytes
676     (do ((end (lround boffset)))
677     ((index>= boffset end))
678     (setf (aref buffer-bbuf boffset) 0)
679     (index-incf boffset))
680     (length-put 2 (index-ash (index- boffset buffer-boffset) -2))
681     (setf (buffer-boffset display) boffset)
682     (unless (zerop length) (setq next-start src-start))
683     (when overall-width (setq width overall-width)))
684    
685     (declare (type array-index boffset src-chunk dst-chunk offset)
686     (type (or null int32) overall-width)
687     (type boolean stop-p))
688     (setq src-chunk (index-min length *max-string-size*))
689     (multiple-value-bind (new-start new-font translated-width)
690     (funcall translate
691     sequence src-start (index+ src-start src-chunk)
692     font buffer 0)
693     (setq dst-chunk (index- new-start src-start)
694     length (index- length dst-chunk)
695     src-start new-start)
696 ram 1.2 (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk)
697 ram 1.1 (if translated-width
698     (when overall-width (incf overall-width translated-width))
699     (setq overall-width nil))
700     (when (index-plusp dst-chunk)
701     (setf (aref buffer-bbuf boffset) dst-chunk)
702     (setf (aref buffer-bbuf (index+ boffset 1)) offset)
703     (index-incf boffset (index+ dst-chunk dst-chunk 2)))
704     (setq offset 0)
705     (cond ((null new-font)
706     ;; Don't stop if translate copied whole chunk
707     (unless (index= src-chunk dst-chunk)
708     (setq stop-p t)))
709     ((integerp new-font) (setq offset new-font))
710     ((type? new-font 'font)
711     (setq font new-font)
712     (let ((font-id (font-id font))
713     (buffer-boffset boffset))
714     (declare (type resource-id font-id)
715     (type array-index buffer-boffset))
716     ;; This changes the gcontext font in the SERVER
717     ;; Update the gcontext cache (both local and server state)
718     (let ((local-state (gcontext-local-state gcontext))
719     (server-state (gcontext-server-state gcontext)))
720     (declare (type gcontext-state local-state server-state))
721     (setf (gcontext-internal-font-obj server-state) font
722     (gcontext-internal-font server-state) font-id)
723     (without-interrupts
724     (setf (gcontext-internal-font-obj local-state) font
725     (gcontext-internal-font local-state) font-id)))
726     (card8-put 0 #xff)
727     (card8-put 1 (ldb (byte 8 24) font-id))
728     (card8-put 2 (ldb (byte 8 16) font-id))
729     (card8-put 3 (ldb (byte 8 8) font-id))
730     (card8-put 4 (ldb (byte 8 0) font-id)))
731     (index-incf boffset 5)))
732     )))))
733     (values next-start width)))
734    
735     (defun draw-image-glyph (drawable gcontext x y elt
736     &key translate width (size :default))
737     ;; Returns true if elt is output, nil if translate refuses to output it.
738     ;; Second result is overall width, if known. An initial font change is
739     ;; allowed from translate.
740     (declare (type drawable drawable)
741     (type gcontext gcontext)
742     (type int16 x y)
743     (type (or null int32) width)
744     (type index-size size))
745     (declare (type (or null translation-function) translate)
746 ram 1.2 #+clx-ansi-common-lisp
747     (dynamic-extent translate)
748     #+(and lispm (not clx-ansi-common-lisp))
749     (sys:downward-funarg #+Genera * #-Genera translate))
750 ram 1.1 (declare (values boolean (or null int32)))
751     (let* ((display (gcontext-display gcontext))
752     (result t)
753     (opcode *x-imagetext8*))
754     (declare (type display display))
755     (let ((vector (allocate-gcontext-state)))
756     (declare (type gcontext-state vector))
757     (setf (aref vector 0) elt)
758     (multiple-value-bind (new-start new-font translate-width)
759     (funcall (or translate #'translate-default)
760     vector 0 1 (gcontext-font gcontext t) vector 1)
761     ;; Allow translate to set a new font
762     (when (type? new-font 'font)
763     (setf (gcontext-font gcontext) new-font)
764     (multiple-value-setq (new-start new-font translate-width)
765     (funcall translate vector 0 1 new-font vector 1)))
766     ;; If new-start is zero, translate refuses to output it
767     (setq result (index-plusp new-start)
768     elt (aref vector 1))
769     (deallocate-gcontext-state vector)
770     (when translate-width (setq width translate-width))))
771     (when result
772     (when (eql size 16)
773     (setq opcode *x-imagetext16*)
774     (setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
775     (with-buffer-request (display opcode :gc-force gcontext)
776     (drawable drawable)
777     (gcontext gcontext)
778     (data 1) ;; 1 character
779     (int16 x y)
780     (card8 (ldb (byte 8 0) elt))
781     (card8 (ldb (byte 8 8) elt)))
782     (values t width))))
783    
784     (defun draw-image-glyphs (drawable gcontext x y sequence
785 ram 1.2 &key (start 0) end translate width (size :default))
786 ram 1.1 ;; An initial font change is allowed from translate, but any subsequent font
787     ;; change or horizontal motion will cause termination (because the protocol
788     ;; doesn't support chaining). [Alternatively, font changes could be accepted
789     ;; as long as they are accompanied with a width return value, or always
790     ;; accept font changes and call text-width as required. However, horizontal
791     ;; motion can't really be accepted, due to semantics.] First result is new
792     ;; start, if end was not reached. Second result is overall width, if known.
793     (declare (type drawable drawable)
794     (type gcontext gcontext)
795     (type int16 x y)
796     (type array-index start)
797     (type (or null array-index) end)
798     (type sequence sequence)
799     (type (or null int32) width)
800     (type index-size size))
801     (declare (type (or null translation-function) translate)
802 ram 1.2 #+clx-ansi-common-lisp
803     (dynamic-extent translate)
804     #+(and lispm (not clx-ansi-common-lisp))
805     (sys:downward-funarg #+Genera * #-Genera translate))
806 ram 1.1 (declare (values (or null array-index) (or null int32)))
807 ram 1.2 (setf end (index-min (index+ start 255) (or end (length sequence))))
808 ram 1.1 (ecase size
809     ((:default 8)
810 ram 1.2 (draw-image-glyphs8 drawable gcontext x y sequence start end translate width))
811 ram 1.1 (16
812 ram 1.2 (draw-image-glyphs16 drawable gcontext x y sequence start end translate width))))
813 ram 1.1
814 ram 1.2 (defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width)
815 ram 1.1 ;; An initial font change is allowed from translate, but any subsequent font
816     ;; change or horizontal motion will cause termination (because the protocol
817     ;; doesn't support chaining). [Alternatively, font changes could be accepted
818     ;; as long as they are accompanied with a width return value, or always
819     ;; accept font changes and call text-width as required. However, horizontal
820     ;; motion can't really be accepted, due to semantics.] First result is new
821     ;; start, if end was not reached. Second result is overall width, if known.
822     (declare (type drawable drawable)
823     (type gcontext gcontext)
824     (type int16 x y)
825     (type array-index start)
826     (type sequence sequence)
827     (type (or null array-index) end)
828     (type (or null int32) width))
829     (declare (type (or null translation-function) translate)
830 ram 1.2 #+clx-ansi-common-lisp
831     (dynamic-extent translate)
832     #+(and lispm (not clx-ansi-common-lisp))
833     (sys:downward-funarg translate))
834 ram 1.1 (declare (values (or null array-index) (or null int32)))
835     (do* ((display (gcontext-display gcontext))
836     (length (index- end start))
837     ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
838     (font (gcontext-font gcontext t))
839     (font-change nil)
840     (new-start) (translated-width) (chunk))
841     (nil) ;; forever
842     (declare (type display display)
843     (type array-index length)
844     (type (or null array-index) new-start chunk))
845    
846     (when font-change
847     (setf (gcontext-font gcontext) font))
848     (block change-font
849     (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
850     (drawable drawable)
851     (gcontext gcontext)
852     (int16 x y)
853     (progn
854     ;; Don't let any flushes happen since we manually set the request
855     ;; length when we're done.
856     (with-buffer-flush-inhibited (display)
857     ;; Translate the sequence into the buffer
858     (multiple-value-setq (new-start font translated-width)
859     (funcall (or translate #'translate-default) sequence start end
860     font buffer-bbuf (index+ buffer-boffset 16)))
861     ;; Number of glyphs translated
862     (setq chunk (index- new-start start))
863     ;; Check for initial font change
864     (when (and (index-zerop chunk) (type? font 'font))
865     (setq font-change t) ;; Loop around changing font
866     (return-from change-font))
867     ;; Quit when nothing translated
868     (when (index-zerop chunk)
869     (return-from draw-image-glyphs8 new-start))
870     ;; Update buffer pointers
871     (data-put 1 chunk)
872     (let ((blen (lround (index+ 16 chunk))))
873     (length-put 2 (index-ash blen -2))
874     (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
875     ;; Normal exit
876     (return-from draw-image-glyphs8
877     (values (if (index= chunk length) nil new-start)
878     (or translated-width width))))))
879    
880 ram 1.2 (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width)
881 ram 1.1 ;; An initial font change is allowed from translate, but any subsequent font
882     ;; change or horizontal motion will cause termination (because the protocol
883     ;; doesn't support chaining). [Alternatively, font changes could be accepted
884     ;; as long as they are accompanied with a width return value, or always
885     ;; accept font changes and call text-width as required. However, horizontal
886     ;; motion can't really be accepted, due to semantics.] First result is new
887     ;; start, if end was not reached. Second result is overall width, if known.
888     (declare (type drawable drawable)
889     (type gcontext gcontext)
890     (type int16 x y)
891     (type array-index start)
892     (type sequence sequence)
893     (type (or null array-index) end)
894     (type (or null int32) width))
895     (declare (type (or null translation-function) translate)
896 ram 1.2 #+clx-ansi-common-lisp
897     (dynamic-extent translate)
898     #+(and lispm (not clx-ansi-common-lisp))
899     (sys:downward-funarg translate))
900 ram 1.1 (declare (values (or null array-index) (or null int32)))
901     (do* ((display (gcontext-display gcontext))
902     (length (index- end start))
903     ;; Should metrics-p be T? Don't want to pass a NIL font into translate...
904     (font (gcontext-font gcontext t))
905     (font-change nil)
906     (new-start) (translated-width) (chunk)
907     (buffer (buffer-tbuf16 display)))
908     (nil) ;; forever
909    
910     (declare (type display display)
911     (type array-index length)
912     (type (or null array-index) new-start chunk)
913     (type buffer-text16 buffer))
914     (when font-change
915     (setf (gcontext-font gcontext) font))
916    
917     (block change-font
918     (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
919     (drawable drawable)
920     (gcontext gcontext)
921     (int16 x y)
922     (progn
923     ;; Don't let any flushes happen since we manually set the request
924     ;; length when we're done.
925     (with-buffer-flush-inhibited (display)
926     ;; Translate the sequence into the buffer
927     (multiple-value-setq (new-start font translated-width)
928     (funcall (or translate #'translate-default) sequence start end
929     font buffer 0))
930     ;; Number of glyphs translated
931     (setq chunk (index- new-start start))
932     ;; Check for initial font change
933     (when (and (index-zerop chunk) (type? font 'font))
934     (setq font-change t) ;; Loop around changing font
935     (return-from change-font))
936     ;; Quit when nothing translated
937     (when (index-zerop chunk)
938     (return-from draw-image-glyphs16 new-start))
939 ram 1.2 (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk)
940 ram 1.1 ;; Update buffer pointers
941     (data-put 1 chunk)
942     (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
943     (length-put 2 (index-ash blen -2))
944     (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
945     ;; Normal exit
946     (return-from draw-image-glyphs16
947     (values (if (index= chunk length) nil new-start)
948     (or translated-width width))))))
949    
950    
951     ;;-----------------------------------------------------------------------------
952    
953     (defun display-keycode-range (display)
954     (declare (type display display))
955     (declare (values min max))
956     (values (display-min-keycode display)
957     (display-max-keycode display)))
958    
959     ;; Should this signal device-busy like the pointer-mapping setf, and return a
960     ;; boolean instead (true for success)? Alternatively, should the
961     ;; pointer-mapping setf be changed to set-pointer-mapping with a (member
962     ;; :success :busy) result?
963    
964     (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
965     ;; Setf ought to allow multiple values.
966     (declare (type display display)
967     (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
968     (declare (values (member :success :busy :failed)))
969     (let* ((keycodes-per-modifier (index-max (length shift)
970     (length lock)
971     (length control)
972     (length mod1)
973     (length mod2)
974     (length mod3)
975     (length mod4)
976     (length mod5)))
977     (data (make-array (index* 8 keycodes-per-modifier)
978     :element-type 'card8
979     :initial-element 0)))
980     (replace data shift)
981     (replace data lock :start1 keycodes-per-modifier)
982     (replace data control :start1 (index* 2 keycodes-per-modifier))
983     (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
984     (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
985     (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
986     (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
987     (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
988     (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)
989     ((data keycodes-per-modifier)
990     ((sequence :format card8) data))
991     (values (member8-get 1 :success :busy :failed)))))
992    
993     (defun modifier-mapping (display)
994     ;; each value is a list of integers
995     (declare (type display display))
996     (declare (values shift lock control mod1 mod2 mod3 mod4 mod5))
997     (let ((lists nil))
998     (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
999     ()
1000     (do* ((keycodes-per-modifier (card8-get 1))
1001     (advance-by *replysize* keycodes-per-modifier)
1002     (keys nil nil)
1003     (i 0 (index+ i 1)))
1004     ((index= i 8))
1005     (advance-buffer-offset advance-by)
1006     (dotimes (j keycodes-per-modifier)
1007     (let ((key (read-card8 j)))
1008     (unless (zerop key)
1009     (push key keys))))
1010     (push (nreverse keys) lists)))
1011     (values-list (nreverse lists))))
1012    
1013     ;; Either we will want lots of defconstants for well-known values, or perhaps
1014     ;; an integer-to-keyword translation function for well-known values.
1015    
1016     (defun change-keyboard-mapping
1017     (display keysyms &key (start 0) end (first-keycode start))
1018     ;; start/end give subrange of keysyms
1019     ;; first-keycode is the first-keycode to store at
1020     (declare (type display display)
1021     (type array-index start)
1022     (type card8 first-keycode)
1023     (type (or null array-index) end)
1024     (type (array * (* *)) keysyms))
1025     (let* ((keycode-end (or end (array-dimension keysyms 0)))
1026     (keysyms-per-keycode (array-dimension keysyms 1))
1027     (length (index- keycode-end start))
1028     (size (index* length keysyms-per-keycode))
1029     (request-length (index+ size 2)))
1030     (declare (type array-index keycode-end keysyms-per-keycode length request-length))
1031     (with-buffer-request (display *x-setkeyboardmapping*
1032     :length (index-ash request-length 2)
1033     :sizes (32))
1034     (data length)
1035     (length request-length)
1036     (card8 first-keycode keysyms-per-keycode)
1037     (progn
1038     (do ((limit (index-ash (buffer-size display) -2))
1039     (w (index+ 2 (index-ash buffer-boffset -2)))
1040     (i start (index+ i 1)))
1041     ((index>= i keycode-end)
1042     (setf (buffer-boffset display) (index-ash w 2)))
1043     (declare (type array-index limit w i))
1044     (when (index> w limit)
1045     (buffer-flush display)
1046     (setq w (index-ash (buffer-boffset display) -2)))
1047     (do ((j 0 (index+ j 1)))
1048     ((index>= j keysyms-per-keycode))
1049     (declare (type array-index j))
1050     (card29-put (index* w 4) (aref keysyms i j))
1051     (index-incf w)))))))
1052    
1053     (defun keyboard-mapping (display &key first-keycode start end data)
1054     ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
1055     ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
1056     ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
1057     ;; If DATA is specified, the results are put there.
1058     (declare (type display display)
1059     (type (or null card8) first-keycode)
1060     (type (or null array-index) start end)
1061     (type (or null (array * (* *))) data))
1062     (declare (values (array * (* *))))
1063     (unless first-keycode (setq first-keycode (display-min-keycode display)))
1064     (unless start (setq start first-keycode))
1065     (unless end (setq end (1+ (display-max-keycode display))))
1066     (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))
1067     ((card8 first-keycode (index- end start)))
1068     (do* ((keysyms-per-keycode (card8-get 1))
1069     (bytes-per-keycode (* keysyms-per-keycode 4))
1070     (advance-by *replysize* bytes-per-keycode)
1071     (keycode-count (floor (card32-get 4) keysyms-per-keycode)
1072     (index- keycode-count 1))
1073     (result (if (and (arrayp data)
1074     (= (array-rank data) 2)
1075     (>= (array-dimension data 0) (index+ start keycode-count))
1076     (>= (array-dimension data 1) keysyms-per-keycode))
1077     data
1078     (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
1079     :element-type 'keysym :initial-element 0)))
1080     (i start (1+ i)))
1081     ((zerop keycode-count) (setq data result))
1082     (advance-buffer-offset advance-by)
1083     (dotimes (j keysyms-per-keycode)
1084     (setf (aref result i j) (card29-get (* j 4))))))
1085     data)

  ViewVC Help
Powered by ViewVC 1.1.5