home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / text.l < prev    next >
Encoding:
Text File  |  1991-07-07  |  43.2 KB  |  1,086 lines
  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.        #+clx-ansi-common-lisp
  114.        (dynamic-extent translate)
  115.        #+(and lispm (not clx-ansi-common-lisp))
  116.        (sys:downward-funarg #+Genera * #-Genera translate))
  117.   (declare (values width ascent descent left right
  118.           font-ascent font-descent direction
  119.           (or null array-index)))
  120.   (when (type? font 'gcontext)
  121.     (force-gcontext-changes font)
  122.     (setq font (gcontext-font font t)))
  123.   (check-type font font)
  124.   (let* ((left-bearing 0)
  125.      (right-bearing 0)
  126.      ;; Sum of widths
  127.      (width 0)
  128.      (ascent 0)
  129.      (descent 0)
  130.      (overall-ascent (font-ascent font))
  131.      (overall-descent (font-descent font))
  132.      (overall-direction (font-direction font))     
  133.      (next-start nil)
  134.      (display (font-display font)))
  135.     (declare (type int16 ascent descent overall-ascent overall-descent)
  136.          (type int32 left-bearing right-bearing width)
  137.          (type (or null array-index) next-start)
  138.          (type display display))
  139.     (with-display (display)
  140.       (do* ((wbuf (display-tbuf16 display))
  141.         (src-end (or end (length sequence)))
  142.         (src-start start (index+ src-start buf-end))
  143.         (end (index-min src-end (index+ src-start *buffer-text16-size*))
  144.          (index-min src-end (index+ src-start *buffer-text16-size*)))
  145.         (buf-end 0)
  146.         (new-font)
  147.         (font-ascent 0)
  148.         (font-descent 0)
  149.         (font-direction)
  150.         (stop-p nil))
  151.        ((or stop-p (index>= src-start src-end))
  152.         (when (index< src-start src-end)
  153.           (setq next-start src-start)))
  154.     (declare (type buffer-text16 wbuf)
  155.          (type array-index src-start src-end end buf-end)
  156.          (type int16 font-ascent font-descent)
  157.          (type boolean stop-p))
  158.     ;; Translate the text
  159.     (multiple-value-setq (buf-end new-font)
  160.       (funcall (or translate #'translate-default)
  161.            sequence src-start end font wbuf 0))
  162.     (setq buf-end (- buf-end src-start))
  163.     (cond ((null new-font) (setq stop-p t))
  164.           ((integerp new-font) (incf width (the int32 new-font))))
  165.     
  166.     (let (w a d l r)
  167.       (if (or (font-char-infos-internal font) (font-local-only-p font))
  168.           ;; Calculate text extents locally
  169.           (progn
  170.         (multiple-value-setq (w a d l r)
  171.           (text-extents-local font wbuf 0 buf-end nil))
  172.         (setq font-ascent (the int16 (font-ascent font))
  173.               font-descent (the int16 (font-descent font))
  174.               font-direction (font-direction font)))
  175.         ;; Let the server calculate text extents
  176.         (multiple-value-setq
  177.           (w a d l r font-ascent font-descent font-direction)
  178.           (text-extents-server font wbuf 0 buf-end)))
  179.       (incf width (the int32 w))
  180.       (cond ((index= src-start start)
  181.          (setq left-bearing (the int32 l))
  182.          (setq right-bearing (the int32 r))
  183.          (setq ascent (the int16 a))
  184.          (setq descent (the int16 d)))
  185.         (t
  186.          (setq left-bearing (the int32 (min left-bearing (the int32 l))))
  187.          (setq right-bearing (the int32 (max right-bearing (the int32 r))))
  188.          (setq ascent (the int16 (max ascent (the int16 a))))
  189.          (setq descent (the int16 (max descent (the int16 d)))))))
  190.  
  191.     (when (type? new-font 'font)
  192.       (setq font new-font))
  193.  
  194.     (setq overall-ascent (the int16 (max overall-ascent font-ascent)))
  195.     (setq overall-descent (the int16 (max overall-descent font-descent)))
  196.     (case overall-direction
  197.       (:unknown (setq overall-direction font-direction))
  198.       (:left-to-right (unless (eq font-direction :left-to-right)
  199.                 (setq overall-direction nil)))
  200.       (:right-to-left (unless (eq font-direction :right-to-left)
  201.                 (setq overall-direction nil))))))
  202.     
  203.     (values width
  204.         ascent
  205.         descent
  206.         left-bearing
  207.         right-bearing
  208.         overall-ascent
  209.         overall-descent
  210.         overall-direction
  211.         next-start)))
  212.  
  213. (defun text-width (font sequence &key (start 0) end translate)
  214.   ;; Translate will always be called with a 16-bit dst buffer.
  215.   (declare (type sequence sequence)
  216.        (type (or font gcontext) font)
  217.        (type array-index start)
  218.        (type (or null array-index) end))
  219.   (declare (type (or null translation-function) translate)
  220.        #+clx-ansi-common-lisp
  221.        (dynamic-extent translate)
  222.        #+(and lispm (not clx-ansi-common-lisp))
  223.        (sys:downward-funarg #+Genera * #-Genera translate))
  224.   (declare (values integer (or null integer)))
  225.   (when (type? font 'gcontext)
  226.     (force-gcontext-changes font)
  227.     (setq font (gcontext-font font t)))
  228.   (check-type font font)
  229.   (let* ((width 0)
  230.      (next-start nil)
  231.      (display (font-display font)))
  232.     (declare (type int32 width)
  233.          (type (or null array-index) next-start)
  234.          (type display display))
  235.     (with-display (display)
  236.       (do* ((wbuf (display-tbuf16 display))
  237.         (src-end (or end (length sequence)))
  238.         (src-start start (index+ src-start buf-end))
  239.         (end (index-min src-end (index+ src-start *buffer-text16-size*))
  240.          (index-min src-end (index+ src-start *buffer-text16-size*)))
  241.         (buf-end 0)
  242.         (new-font)
  243.         (stop-p nil))
  244.        ((or stop-p (index>= src-start src-end))
  245.         (when (index< src-start src-end)
  246.           (setq next-start src-start)))
  247.     (declare (type buffer-text16 wbuf)
  248.          (type array-index src-start src-end end buf-end)
  249.          (type boolean stop-p))
  250.     ;; Translate the text
  251.     (multiple-value-setq (buf-end new-font)
  252.       (funcall (or translate #'translate-default)
  253.            sequence src-start end font wbuf 0))
  254.     (setq buf-end (- buf-end src-start))
  255.     (cond ((null new-font) (setq stop-p t))
  256.           ((integerp new-font) (incf width (the int32 new-font))))
  257.     
  258.     (incf width
  259.           (if (or (font-char-infos-internal font) (font-local-only-p font))
  260.           (text-extents-local font wbuf 0 buf-end :width-only)
  261.         (text-width-server font wbuf 0 buf-end)))
  262.     (when (type? new-font 'font)
  263.       (setq font new-font))))
  264.     (values width next-start)))
  265.  
  266. (defun text-extents-server (font string start end)
  267.   (declare (type font font)
  268.        (type string string)
  269.        (type array-index start end))
  270.   (declare (values width ascent descent left right font-ascent font-descent direction))
  271.   (let ((display (font-display font))
  272.     (length (index- end start))
  273.     (font-id (font-id font)))
  274.     (declare (type display display)
  275.          (type array-index length)
  276.          (type resource-id font-id))
  277.     (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32))
  278.      (((data boolean) (oddp length))
  279.       (length (index+ (index-ceiling length 2) 2))
  280.       (resource-id font-id)
  281.       ((sequence :format char2b :start start :end end :appending t)
  282.        string))
  283.       (values
  284.     (integer-get 16)
  285.     (int16-get 12)
  286.     (int16-get 14)
  287.     (integer-get 20)
  288.     (integer-get 24)
  289.     (int16-get 8)
  290.     (int16-get 10)
  291.     (member8-get 1 :left-to-right :right-to-left)))))
  292.  
  293. (defun text-width-server (font string start end)
  294.   (declare (type (or font gcontext) font)
  295.        (type string string)
  296.        (type array-index start end))
  297.   (declare (values integer))
  298.   (let ((display (font-display font))
  299.     (length (index- end start))
  300.     (font-id (font-id font)))
  301.     (declare (type display display)
  302.          (type array-index length)
  303.          (type resource-id font-id))
  304.     (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)
  305.      (((data boolean) (oddp length))
  306.       (length (index+ (index-ceiling length 2) 2))
  307.       (resource-id font-id)
  308.       ((sequence :format char2b :start start :end end :appending t)
  309.        string))
  310.       (values (integer-get 16)))))
  311.  
  312. (defun text-extents-local (font sequence start end width-only-p)
  313.   (declare (type font font)
  314.        (type sequence sequence)
  315.        (type integer start end)
  316.        (type 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.              (ascent #x-7fff)
  373.              (descent #x-7fff)
  374.              (left #x7fff)
  375.              (right #x-7fff))
  376.             ((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.            (ascent #x-7fff)
  412.            (descent #x-7fff)
  413.            (left #x7fff)
  414.            (right #x-7fff))
  415.           ((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.        #+clx-ansi-common-lisp
  466.        (dynamic-extent translate)
  467.        #+(and lispm (not clx-ansi-common-lisp))
  468.        (sys:downward-funarg #+Genera * #-Genera translate))
  469.   (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.        #+clx-ansi-common-lisp
  517.        (dynamic-extent translate)
  518.        #+(and lispm (not clx-ansi-common-lisp))
  519.        (sys:downward-funarg #+Genera * #-Genera translate))
  520.   (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.        (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.   (declare (values (or null array-index) (or null int32)))
  539.   (declare (type translation-function translate)
  540.        #+clx-ansi-common-lisp
  541.        (dynamic-extent translate)
  542.        #+(and lispm (not clx-ansi-common-lisp))
  543.        (sys:downward-funarg translate)) 
  544.   (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.        (type array-index start)
  638.        (type sequence sequence)
  639.        (type (or null array-index) end)
  640.        (type (or null int32) width))
  641.   (declare (values (or null array-index) (or null int32)))
  642.   (declare (type translation-function translate)
  643.        #+clx-ansi-common-lisp
  644.        (dynamic-extent translate)
  645.        #+(and lispm (not clx-ansi-common-lisp))
  646.        (sys:downward-funarg translate))
  647.   (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.           (write-sequence-char2b display (index+ boffset 2) buffer 0 dst-chunk)
  697.           (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.        #+clx-ansi-common-lisp
  747.        (dynamic-extent translate)
  748.        #+(and lispm (not clx-ansi-common-lisp))
  749.        (sys:downward-funarg #+Genera * #-Genera translate))
  750.   (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.               &key (start 0) end translate width (size :default))
  786.   ;; 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.        #+clx-ansi-common-lisp
  803.        (dynamic-extent translate)
  804.        #+(and lispm (not clx-ansi-common-lisp))
  805.        (sys:downward-funarg #+Genera * #-Genera translate))
  806.   (declare (values (or null array-index) (or null int32)))
  807.   (setf end (index-min (index+ start 255) (or end (length sequence))))
  808.   (ecase size
  809.     ((:default 8)
  810.      (draw-image-glyphs8 drawable gcontext x y sequence start end translate width))
  811.     (16
  812.      (draw-image-glyphs16 drawable gcontext x y sequence start end translate width))))
  813.  
  814. (defun draw-image-glyphs8 (drawable gcontext x y sequence start end translate width)
  815.   ;; 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.        #+clx-ansi-common-lisp
  831.        (dynamic-extent translate)
  832.        #+(and lispm (not clx-ansi-common-lisp))
  833.        (sys:downward-funarg translate))
  834.   (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. (defun draw-image-glyphs16 (drawable gcontext x y sequence start end translate width)
  881.   ;; 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.        #+clx-ansi-common-lisp
  897.        (dynamic-extent translate)
  898.        #+(and lispm (not clx-ansi-common-lisp))
  899.        (sys:downward-funarg translate))
  900.   (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.         (write-sequence-char2b display (index+ buffer-boffset 16) buffer 0 chunk)
  940.         ;; 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)
  1086.