Skip to content
Snippets Groups Projects
text.lisp 43.5 KiB
Newer Older
dan's avatar
dan committed
	 ()
      (do* ((keycodes-per-modifier (card8-get 1))
	    (advance-by *replysize* keycodes-per-modifier)
	    (keys nil nil)
	    (i 0 (index+ i 1)))
	   ((index= i 8))
	(advance-buffer-offset advance-by)
	(dotimes (j keycodes-per-modifier)
	  (let ((key (read-card8 j)))
	    (unless (zerop key)
	      (push key keys))))
	(push (nreverse keys) lists)))
    (values-list (nreverse lists))))

;; Either we will want lots of defconstants for well-known values, or perhaps
;; an integer-to-keyword translation function for well-known values.

(defun change-keyboard-mapping
       (display keysyms &key (start 0) end (first-keycode start))
  ;; start/end give subrange of keysyms
  ;; first-keycode is the first-keycode to store at
  (declare (type display display)
	   (type array-index start)
	   (type card8 first-keycode)
	   (type (or null array-index) end)
	   (type (array * (* *)) keysyms))
  (let* ((keycode-end (or end (array-dimension keysyms 0)))
	 (keysyms-per-keycode (array-dimension keysyms 1))
	 (length (index- keycode-end start))
	 (size (index* length keysyms-per-keycode))
	 (request-length (index+ size 2)))
    (declare (type array-index keycode-end keysyms-per-keycode length request-length))
    (with-buffer-request (display *x-setkeyboardmapping*
				  :length (index-ash request-length 2)
				  :sizes (32))
      (data length)
      (length request-length)
      (card8 first-keycode keysyms-per-keycode)
      (progn
	(do ((limit (index-ash (buffer-size display) -2))
	     (w (index+ 2 (index-ash buffer-boffset -2)))
	     (i start (index+ i 1)))
	    ((index>= i keycode-end)
	     (setf (buffer-boffset display) (index-ash w 2)))
	  (declare (type array-index limit w i))
	  (when (index> w limit)
	    (buffer-flush display)
	    (setq w (index-ash (buffer-boffset display) -2)))
	  (do ((j 0 (index+ j 1)))
	      ((index>= j keysyms-per-keycode))
	    (declare (type array-index j))
	    (card29-put (index* w 4) (aref keysyms i j))
	    (index-incf w))))))) 

(defun keyboard-mapping (display &key first-keycode start end data)
  ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
  ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
  ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
  ;; If DATA is specified, the results are put there.
  (declare (type display display)
	   (type (or null card8) first-keycode)
	   (type (or null array-index) start end)
	   (type (or null (array * (* *))) data))
  (declare (clx-values (array * (* *))))
  (unless first-keycode (setq first-keycode (display-min-keycode display)))
  (unless start (setq start first-keycode))
  (unless end (setq end (1+ (display-max-keycode display))))
  (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))
       ((card8 first-keycode (index- end start)))
    (do* ((keysyms-per-keycode (card8-get 1))
	  (bytes-per-keycode (* keysyms-per-keycode 4))
	  (advance-by *replysize* bytes-per-keycode)
	  (keycode-count (floor (card32-get 4) keysyms-per-keycode)
			 (index- keycode-count 1))
	  (result (if (and (arrayp data)
			   (= (array-rank data) 2)
			   (>= (array-dimension data 0) (index+ start keycode-count))
			   (>= (array-dimension data 1) keysyms-per-keycode))
		      data
		    (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
				:element-type 'keysym :initial-element 0)))
	  (i start (1+ i)))
	 ((zerop keycode-count) (setq data result))
      (advance-buffer-offset advance-by)
      (dotimes (j keysyms-per-keycode)
	(setf (aref result i j) (card29-get (* j 4))))))
  data)