;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: requests.sc,v 1.5 90/04/01 13:51:15 johani Exp $

;;; requests.sc -- the code that constructs the individual requests, i e here
;;;                we have the translation from the OO-level to the X protocol
;;;                level.

(module requests (top-level))

(include "../include/opcodes.sch")
(include "../include/types.sch")
(include "../include/util.sch")
(include "../include/msg-handler.sch")
(include "../include/lowlevel.sch")

(define-external create-event createevent)
(define-external x-protocol-atoms global) ; Note: Wrong place, should be moved.
(define-external *reply-formats* replies)

(define-constant X-major-version 11)
(define-constant X-minor-version 0)

;;; send-initConnection -- the initial handshaking between the client and the
;;;                        server. 
(define (send-initConnection dpy . rest)
  (let ((prot-major X-major-version)
	(prot-minor X-minor-version)
	(auth-prot-name "")
	(auth-prot-data "") )
    (let ((n (string-length auth-prot-name))
	  (d (string-length auth-prot-name)) )
      (dpy 'scix-xas `((,a-card8   . ,(byte-order))
		       (,a-card8   . 0)			; 1 unused byte
		       (,a-card16  . ,prot-major)
		       (,a-card16  . ,prot-minor)
		       (,a-card16  . ,n)
		       (,a-card16  . ,d)
		       (,a-card16  . 0)			; 2 unused bytes
		       (,a-string8 . ,auth-prot-name)
		       (,a-string8 . ,auth-prot-data) )
	   rest)))
  (dpy 'flush!)				; Flush pending connection request
  (let loop ((str (readfromserver dpy)))
    (cond ((null? str)
	   (loop (readfromserver dpy)) )
	  ((or (< (c-input-string-length str) 8)
	       (< (c-input-string-length str)     ; Partial message read.
		  (+ 8 (* 4 (c-shortunsigned-ref
			     (c-input-string-string str) 6)))))
	   (loop (readmorefromserver dpy str)) )
	  ((zero? (get-next-byte! str))	; Check out the initial byte
	   (make-reply 'connectrefuse str dpy))
	  (else
	   (make-reply 'connectaccept str dpy)) )))

;;; Request #1: CreateWindow
(define (send-CreateWindow w data scr . rest)
  (let ((cl (lookup-constant (w 'class) '((CopyFromParent . 0)
					  (InputOutput    . 1)
					  (InputOnly      . 2) )))
	(vid (lookup-constant (w 'visual) '((CopyFromParent . 0)))) )
    (scr 'scix-xas `((,a-request     . ,CreateWindow)
		     (,a-card8       . ,(w 'depth))
		     (,a-card16      . ,(+ 8 (data 'length)))
		     (,a-window      . ,w)
		     (,a-window      . ,(w 'parent))
		     (,a-int16       . ,(w 'x))
		     (,a-int16       . ,(w 'y))
		     (,a-card16      . ,(w 'width))
		     (,a-card16      . ,(w 'height))
		     (,a-card16      . ,(w 'border-width))
		     (,a-card16      . ,cl)
		     (,a-visualid    . ,vid)
		     (,a-bitmask     . ,(data 'mask))
		     (,a-listofvalue . ,(data 'listofvalue)) )
	 rest)))

;;; Request #2: ChangeWindowAttributes
(define (send-ChangeWindowattributes w data scr . rest)
  (scr 'scix-xas `((,a-request     . ,ChangeWindowAttributes)
		   (,a-card8       . 0)        		; 1 unused byte
		   (,a-card16      . ,(+ 3 (data 'length)))
		   (,a-window      . ,w)
		   (,a-bitmask     . ,(data 'mask))
		   (,a-listofvalue . ,(data 'listofvalue)) )
       rest))

;;; Request #3: GetWindowAttributes
(define (send-GetWindowattributes w scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetWindowAttributes)
				 (,a-card8   . 0)             ; 1 unused byte
				 (,a-card16  . 2)             ; Request length
				 (,a-window  . ,w) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetWindowAttributes scr) ))

;;; Request #4: DestroyWindow
(define (send-DestroyWindow w scr . rest)
  (scr 'scix-xas `((,a-request . ,DestroyWindow )
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #5: DestroySubWindows
(define (send-DestroySubWindows w scr . rest)
  (scr 'scix-xas `((,a-request . ,DestroySubWindows)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #6: ChangeSaveSet
(define (send-ChangeSaveSet w mode scr . rest)
  (scr 'scix-xas `((,a-request . ,ChangeSaveSet)
		   (,a-card8   . ,(lookup-constant mode '((Insert . 0)
							  (Delete . 1) )))
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #7: ReparentWindow
(define (send-ReparentWindow w parent scr . rest)
  (scr 'scix-xas `((,a-request . ,ReparentWindow )
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 4)			; length of request
		   (,a-window  . ,w)
		   (,a-window  . ,parent)
		   (,a-int16   . ,(w 'x))
		   (,a-int16   . ,(w 'y)) )
       rest))

;;; Request #8: MapWindow
(define (send-MapWindow w scr . rest)
  (scr 'scix-xas `((,a-request . ,MapWindow )
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #9: MapSubWindows
(define (send-MapSubWindows w scr . rest)
  (scr 'scix-xas `((,a-request . ,MapSubWindows )
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #10: UnMapWindow
(define (send-UnMapWindow w scr . rest)
  (scr 'scix-xas `((,a-request . ,UnMapWindow)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #11: UnMapSubWindows
(define (send-UnMapSubWindows w scr . rest)
  (scr 'scix-xas `((,a-request . ,UnMapSubWindows)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #12: ConfigureWindow
(define (send-ConfigureWindow w data scr . rest)
  (scr 'scix-xas `((,a-request     . ,ConfigureWindow)
		   (,a-card8       . 0)		            ; 1 unused byte
		   (,a-card16      . ,(+ 3 (data 'length))) ; length of request
		   (,a-window      . ,w)
		   (,a-bitmask16   . ,(data 'mask))
		   (,a-card16      . 0)	                ; 2 unused bytes
		   (,a-listofvalue . ,(data 'listofvalue)) )
       rest))

;;; Request #13: CirculateWindow
(define (send-CirculateWindow w direction scr . rest)
  (scr 'scix-xas `((,a-request . ,CirculateWindow)
		   (,a-card8   . ,(lookup-constant direction
						   '((RaiseLowest  . 0)
						     (LowerHighest . 1) )))
		   (,a-card16  . 2)			; length of request
		   (,a-window  . ,w) )
       rest))

;;; Request #14: GetGeometry
(define (send-GetGeometry drawable scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request  . ,GetGeometry)
				 (,a-card8    . 0)     	; 1 unused byte
				 (,a-card16   . 2)     	; length of request
				 (,a-drawable . ,drawable) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetGeometry scr) ))

;;; Request #15: QueryTree
(define (send-QueryTree w scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,QueryTree)
				 (,a-card8   . 0)             ; 1 unused byte
				 (,a-card16  . 2)             ; request length
				 (,a-window  . ,w) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryTree scr) ))

;;; Request #16: InternAtom
(define (send-InternAtom only-if-exists name scr . rest)
  (let* ((n (string-length name))
	 (req-len (+ 2 (/ (+ n (pad n)) 4)))
	 (seq-nr (scr 'scix-xas `((,a-request . ,InternAtom)
				  (,a-bool    . ,only-if-exists)
				  (,a-card16  . ,req-len) ; length of request
				  (,a-card16  . ,n)
				  (,a-card16  . 0)        ; 2 unused bytes
				  (,a-string8 . ,name) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'InternAtom scr) ))

;;; Request #17: GetAtomName
(define (send-GetAtomName atom scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetAtomName)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; length of request
				 (,a-atom    . ,atom) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetAtomName scr) ))

;;; Request #18: ChangeProperty
(define (send-ChangeProperty w mode prop type format data scr . rest)
  (let ((m (lookup-constant mode '((Replace . 0)
				   (Prepend . 1)
				   (Append  . 2) )))
	(atombox (scr 'atombox))
	(n (if (pair? data)
	       (length data)
	       (string-length data))) )
    (let ((fu-len (/ (* 8 n) format))
	  (req-len (+ 6 (/ (+ n (pad n)) 4))) )
      (scr 'scix-xas `((,a-request    . ,ChangeProperty)
		       (,a-card8      . ,m)		
		       (,a-card16     . ,req-len)
		       (,a-window     . ,w)
		       (,a-atom       . ,(atombox 'lookup-id prop))
		       (,a-atom       . ,(atombox 'lookup-id type))
		       (,a-card8      . ,format)  ; Format = { 8 | 16 | 32 }
		       (,a-card8      . 0)	  ; 3 unused bytes
		       (,a-card16     . 0)
		       (,a-card32     . ,fu-len)  ; Length of data in fmt units
		       (,a-listofbyte . ,data) )
	   rest))))

;;; Request #19: DeleteProperty
(define (send-DeleteProperty w prop scr . rest)
  (scr 'scix-xas `((,a-request . ,DeleteProperty)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 3)			; Request length
		   (,a-window  . ,w)
		   (,a-atom    . ,((scr 'atombox) 'lookup-id prop)) )
       rest))

;;; Request #20: GetProperty
(define (send-GetProperty delete w prop type long-offset long-len scr . rest)
  (let* ((atombox (scr 'atombox))
	 (seq-nr (scr 'scix-xas `((,a-request . ,GetProperty)
				  (,a-bool    . ,delete)
				  (,a-card16  . 6)	; Request length
				  (,a-window  . ,w)
				  (,a-atom    . ,(atombox 'lookup-id prop))
				  (,a-atom   . ,(if (eq? type 'AnyPropertyType)
						    0
						    (atombox 'lookup-id type)))
				  (,a-card32 . ,long-offset)
				  (,a-card32 . ,long-len) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetProperty scr) ))

;;; Request #21: ListProperties
(define (send-ListProperties w scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,ListProperties)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; Request length
				 (,a-window  . ,w) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'ListProperties scr) ))

;;; Request #22: SetSelectionOwner
(define (send-SetSelectionOwner owner selection time scr . rest)
  (scr 'scix-xas `((,a-request        . ,SetSelectionOwner)
		   (,a-card8          . 0)		; 1 unused byte
		   (,a-card16         . 4)		; Request length
		   (,a-window-or-none . ,owner)
		   (,a-atom           . ,((scr 'atombox) 'lookup-id selection))
		   (,a-timestamp      . ,time) )
       rest))

;;; Request #23: GetSelectionOwner
(define (send-GetSelectionOwner selection scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetSelectionOwner)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; Request length
				 (,a-atom    . ,((scr 'atombox) 'lookup-id
								selection) ))
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetSelectionOwner scr) ))

;;; Request #24: ConvertSelection
(define (send-ConvertSelection requestor selection target prop time scr . rest)
  (let ((atombox (scr 'atombox)))
    (scr 'scix-xas `((,a-request   . ,ConvertSelection)
		     (,a-card8     . 0)			; 1 unused byte
		     (,a-card16    . 6)			; Request length
		     (,a-window    . ,requestor)
		     (,a-atom      . ,(atombox 'lookup-id selection))
		     (,a-atom      . ,(atombox 'lookup-id target))
		     (,a-atom      . ,(if (eq? prop 'None)
					  0
					  (atombox 'lookup-id prop) ))
		     (,a-timestamp . ,time) )
	 rest)))

;;; Request #25: SendEvent
(define (send-SendEvent propagate w event-mask
			event-name event-data scr . rest)
  (let ((win (lookup-constant w '((PointerWindow . 0)
				  (InputFocus . 1) )))
	(evmask (event-mask 'mask))
	(ev (create-event event-name event-data)) )
    (scr 'scix-xas `((,a-request    . ,SendEvent)
		     (,a-bool       . ,propagate)
		     (,a-card16     . 11)		; Request length
		     (,a-window     . ,win)
		     (,a-setofevent . ,evmask)
		     (,a-intlist    . ,ev) )	; Johan: Should use strings...
	 rest)))

;;; Request #26: GrabPointer
(define (send-GrabPointer owner-events grab-window event-mask pntr-mode
			  keybd-mode confine-to cursor time scr . rest)
  (let* ((alist '((Synchronous . 0) (Asynchronous . 1)))
	 (pm (lookup-constant pntr-mode alist))
	 (km (lookup-constant keybd-mode alist))
	 (seq-nr (scr 'scix-xas `((,a-request           . ,GrabPointer)
				  (,a-bool              . ,owner-events)
				  (,a-card16            . 6) ; Request length
				  (,a-window            . ,grab-window)
				  (,a-setofpointerevent . ,(event-mask 'mask))
				  (,a-card8             . ,pm)
				  (,a-card8             . ,km)
				  (,a-window-or-none    . ,confine-to)
				  (,a-cursor-or-none    . ,cursor)
				  (,a-timestamp         . ,time) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GrabPointer scr) ))

;;; Request #27: UngrabPointer
(define (send-UngrabPointer time scr . rest)
  (scr 'scix-xas `((,a-request   . ,UngrabPointer)
		   (,a-card8     . 0)			; 1 unused byte
		   (,a-card16    . 2)			; Request length
		   (,a-timestamp . ,time) )
       rest))

;;; Request #28: GrabButton
(define (send-GrabButton owner-ev grab-win event-mask ptr-mode kbd-mode
			 confine-to cursor button modifiers scr . rest)
  (let* ((alist '((Synchronous . 0) (Asynchronous . 1)))
	 (mod (if (eq? modifiers 'AnyModifier)
		  #x8000
		  (modifiers 'mask) )))
    (scr 'scix-xas `((,a-request           . ,GrabButton)
		     (,a-bool              . ,owner-ev)
		     (,a-card16            . 6)		; Request length
		     (,a-window            . ,grab-win)
		     (,a-setofpointerevent . ,(event-mask 'mask))
		     (,a-card8             . ,(lookup-constant ptr-mode alist))
		     (,a-card8             . ,(lookup-constant kbd-mode alist))
		     (,a-window-or-none    . ,confine-to)
		     (,a-cursor-or-none    . ,cursor)
		     (,a-button            . ,(if (eq? button 'AnyButton)
						  0
						  button))
		     (,a-card8             . 0)		; 1 unused byte
		     (,a-setofkeymask      . ,mod) )
	 rest)))

;;; Request #29: UngrabButton
(define (send-UngrabButton button grab-win modifiers scr . rest)
  (let ((mod (if (eq? modifiers 'AnyModifier)
		 #x8000
		 (modifiers 'mask) )))
    (scr 'scix-xas `((,a-request      . ,UngrabButton)
		     (,a-button       . ,(if (eq? button 'AnyButton)
					     0
					     button))
		     (,a-card16       . 3)		; Request length
		     (,a-window       . ,grab-win)
		     (,a-setofkeymask . ,mod)
		     (,a-card16       . 0) )  		; 2 unused bytes
	 rest)))

;;; Request #30: ChangeActivePointerGrab
(define (send-ChangeActivePointerGrab cursor time event-mask scr . rest)
  (scr 'scix-xas `((,a-request           . ,ChangeActivePointerGrab)
		   (,a-card8             . 0)		; 1 unused byte
		   (,a-card16            . 4)		; Request length
		   (,a-cursor-or-none    . ,cursor)
		   (,a-timestamp         . ,time)
		   (,a-setofpointerevent . ,(event-mask 'mask))
		   (,a-card16            . 0) )		; 2 unused bytes
       rest))

;;; Request #31: GrabKeyboard
(define (send-GrabKeyboard owner-events grab-window time
			   pntr-mode keybd-mode scr . rest)
  (let* ((alist '((Synchronous . 0) (Asynchronous . 1)))
	 (seq-nr (scr 'scix-xas `((,a-request   . ,GrabKeyboard)
				  (,a-bool      . ,owner-events)
				  (,a-card16    . 4)	; Request length
				  (,a-window    . ,grab-window)
				  (,a-timestamp . ,time)
				  (,a-card8     . ,(lookup-constant pntr-mode
								    alist))
				  (,a-card8     . ,(lookup-constant keybd-mode
								    alist))
				  (,a-card16    . 0) )	; 2 unused bytes
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GrabKeyboard scr) ))

;;; Request #32: UngrabKeyboard
(define (send-UngrabKeyboard time scr . rest)
  (scr 'scix-xas `((,a-request   . ,UngrabKeyboard)
		   (,a-card8     . 0)			; 1 unused byte
		   (,a-card16    . 2)			; Request length
		   (,a-timestamp . ,time) )
       rest))

;;; Request #33: GrabKey
(define (send-GrabKey owner-ev grab-win modifiers key
		      pntr-mode kbd-mode scr . rest)
  (let* ((alist '((Synchronous . 0) (Asynchronous . 1)))
	 (mod (if (eq? modifiers 'AnyModifier)
		  #x8000
		  (modifiers 'mask) )))
    (scr 'scix-xas `((,a-request      . ,GrabKey)
		     (,a-bool         . ,owner-ev)
		     (,a-card16       . 4)		; Request length
		     (,a-window       . ,grab-win)
		     (,a-setofkeymask . ,mod)
		     (,a-keycode      . ,(lookup-constant key '((AnyKey . 0))))
		     (,a-card8        . ,(lookup-constant pntr-mode alist))
		     (,a-card8        . ,(lookup-constant kbd-mode alist))
		     (,a-card8        . 0)		; 1 unused byte
		     (,a-card16       . 0) )   		; and 2 more
	 rest)))

;;; Request #34: UngrabKey
(define (send-UngrabKey key grab-win modifiers scr . rest)
  (let ((mod (if (eq? modifiers 'AnyModifier)
		 #x8000
		 (modifiers 'mask) )))
    (scr 'scix-xas `((,a-request      . ,UngrabKey)
		     (,a-keycode      . ,(lookup-constant key '((AnyKey . 0))))
		     (,a-card16       . 3)		; Request length
		     (,a-window       . ,grab-win)
		     (,a-setofkeymask . ,mod)
		     (,a-card16       . 0) )   		; 2 unused bytes
	 rest)))

;;; Request #35: AllowEvents
(define (send-AllowEvents mode time scr . rest)
  (let ((md (lookup-constant mode '((AsyncPointer   . 0)
				    (SyncPointer    . 1)
				    (ReplayPointer  . 2)
				    (AsyncKeyboard  . 3)
				    (SyncKeyboard   . 4)
				    (ReplayKeyboard . 5)
				    (AsyncBoth      . 6)
				    (SyncBoth       . 7) ))))
    (scr 'scix-xas `((,a-request   . ,AllowEvents)
		     (,a-card8     . ,md)
		     (,a-card16    . 2)			; Request length
		     (,a-timestamp . ,time) )
	 rest)))

;;; Request #36: GrabServer
(define (send-GrabServer scr . rest)
  (scr 'scix-xas `((,a-request . ,GrabServer)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 1) )   		; Request length
       rest))

;;; Request #37: UngrabServer
(define (send-UngrabServer scr . rest)
  (scr 'scix-xas `((,a-request . ,UngrabServer)
		   (,a-card8   . 0)     		; 1 unused byte
		   (,a-card16  . 1) )  	        	; Request length
       rest))

;;; Request #38: QueryPointer
(define (send-QueryPointer w scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,QueryPointer)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; Request length
				 (,a-window  . ,w) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryPointer scr) ))

;;; Request #39: GetMotionEvents
(define (send-GetMotionEvents w start stop scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request   . ,GetMotionEvents)
				 (,a-card8     . 0)	; 1 unused byte
				 (,a-card16    . 4)	; Request length
				 (,a-window    . ,w)
				 (,a-timestamp . ,start)
				 (,a-timestamp . ,stop) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetMotionEvents scr)) )

;;; Request #40: TranslateCoordinates
(define (send-TranslateCoordinates src-win dst-win src-x src-y scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,TranslateCoordinates)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 4)	; Request length
				 (,a-window  . ,src-win)
				 (,a-window  . ,dst-win)
				 (,a-int16   . ,src-x)
				 (,a-int16   . ,src-y) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'TranslateCoordinates scr) ))

;;; Request #41: WarpPointer
(define (send-WarpPointer src-win dst-win src-x src-y
			  src-width src-height dst-x dst-y scr . rest)
  (scr 'scix-xas `((,a-request        . ,WarpPointer)
		   (,a-card8          . 0)		; 1 unused byte
		   (,a-card16         . 6)		; Request length
		   (,a-window-or-none . ,src-win)
		   (,a-window-or-none . ,dst-win)
		   (,a-int16          . ,src-x)
		   (,a-int16          . ,src-y)
		   (,a-card16         . ,src-width)
		   (,a-card16         . ,src-height)
		   (,a-int16          . ,dst-x)
		   (,a-int16          . ,dst-y) )
       rest))

;;; Request #42: SetInputFocus
(define (send-SetInputFocus revert-to focus time scr . rest)
  (let ((rt (lookup-constant revert-to '((None        . 0)
					 (PointerRoot . 1)
					 (Parent      . 2) )))
	(win (lookup-constant focus '((None        . 0)
				      (PointerRoot . 1) ))))
    (scr 'scix-xas `((,a-request   . ,SetInputFocus)
		     (,a-card8     . ,rt)
		     (,a-card16    . 3)		; Request length
		     (,a-window    . ,win)
		     (,a-timestamp . ,time) )
	 rest)))

;;; Request #43: GetInputFocus
(define (send-GetInputFocus scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetInputFocus)
				 (,a-card8   . 0)	 ; 1 unused byte
				 (,a-card16  . 1) )     ; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetInputFocus scr) ))

;;; Request #44: QueryKeymap
(define (send-QueryKeymap scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,QueryKeymap)
				 (,a-card8   . 0)	 ; 1 unused byte
				 (,a-card16  . 1) )     ; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryKeymap scr) ))

;;; Request #45: OpenFont
(define (send-OpenFont font name scr . rest)
  (let ((name-len (string-length name)))
    (scr 'scix-xas `((,a-request . ,OpenFont)
		     (,a-card8   . 0)			; 1 unused byte
		     (,a-card16  . ,(+ 3 (/ (+ name-len (pad name-len)) 4)))
		     (,a-font    . ,font)
		     (,a-card16  . ,name-len)
		     (,a-card16  . 0)			; 2 unused bytes
		     (,a-string8 . ,name) )
	 rest)))

;;; Request #46: CloseFont
(define (send-CloseFont font scr . rest)
  (scr 'scix-xas `((,a-request . ,CloseFont)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; Request length
		   (,a-font    . ,font) )
       rest))

;;; Request #47: QueryFont
(define (send-QueryFont fontable scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request  . ,QueryFont)
				 (,a-card8    . 0)	; 1 unused byte
				 (,a-card16   . 2)	; Request length
				 (,a-fontable . ,fontable) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryFont scr) ))

;;; Request #48: QueryTextExtents
(define (send-QueryTextExtents fontable string scr . rest)
  (let* ((p (string-length string))
	 (odd (if (zero? (pad p)) #f #t))
	 (seq-nr (scr 'scix-xas `((,a-request  . ,QueryTextExtents)
				  (,a-bool     . ,odd)
				  (,a-card16   . ,(+ 2 (/ (+ p (pad p)) 4)))
				  (,a-fontable . ,fontable)
				  (,a-string16 . ,string) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryTextExtents scr) ))

;;; Request #49: ListFonts
(define (send-ListFonts  maxnames pattern scr . rest)
  (let* ((n (string-length pattern))
	 (seq-nr (scr 'scix-xas `((,a-request . ,ListFonts)
				  (,a-card8   . 0)	; 1 unused byte
				  (,a-card16  . ,(+ 2 (/ (+ n (pad n)) 4)))
				  (,a-card16  . ,maxnames)
				  (,a-card16  . ,n)
				  (,a-string8 . ,pattern) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'ListFonts scr) ))

;;; Request #50: ListFontsWithInfo
(define (send-ListFontsWithInfo maxnames pattern scr . rest)
  (let* ((n (string-length pattern))
	 (seq-nr (scr 'scix-xas `((,a-request . ,ListFontsWithInfo)
				  (,a-card8   . 0)	; 1 unused byte
				  (,a-card16  . ,(+ 2 (/ (+ n (pad n)) 4)))
				  (,a-card16  . ,maxnames)
				  (,a-card16  . ,n)
				  (,a-string8 . ,pattern) )
		      rest))
	 (reply (msg-handler 'scix-wait-for-reply seq-nr 'ListFontsWithInfo scr)) )
    (if (x-error? reply)
	reply
	(let loop ((repl reply) (result '()))
	  (if (zero? (repl 'length-of-name))
	      result
	      (loop (msg-handler 'scix-wait-for-reply
				 seq-nr
				 'ListFontsWithInfo
				 scr) 
		    (append result (list repl)) ))))))

;;; Request #51: SetFontPath
;;; Note: The contraption below has not been tested.
(define (send-SetFontPath list-of-str scr . rest)
  (let* ((nr-of-strings (length list-of-str))
	 (tot-str-l (+ nr-of-strings
			 (apply + (map string-length list-of-str)) )))
    (scr 'scix-xas `((,a-request . ,SetFontPath)
		     (,a-card8   . 0)			; 1 unused byte
		     (,a-card16  . ,(+ 2 (/ (+ tot-str-l (pad tot-str-l)) 4)))
		     (,a-card16  . ,nr-of-strings)
		     (,a-card16  . 0)			; 2 unused bytes
		     (,a-string8 . ,(apply string-append
					   (apply append
						  (map (lambda (s)
							 (list
							  (list->string
							   (list
							    (integer->char
							     (string-length
							      s))))
							  s))
						       list-of-str)))) )
	 rest)))

;;; Request #52: GetFontPath
(define (send-GetFontPath scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetFontPath)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 1) )	; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetFontPath scr) ))

;;; Request #53: CreatePixmap
(define (send-CreatePixmap pmap scr . rest)
  (scr 'scix-xas `((,a-request  . ,CreatePixmap)
		   (,a-card8    . ,(pmap 'depth))
		   (,a-card16   . 4)			; Request length
		   (,a-pixmap   . ,pmap)
		   (,a-drawable . ,(pmap 'drawable))
		   (,a-card16   . ,(pmap 'width))
		   (,a-card16   . ,(pmap 'height)) )
       rest))

;;; Request #54: FreePixmap
(define (send-FreePixmap pmap scr . rest)
  (scr 'scix-xas `((,a-request . ,FreePixmap)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; Request length
		   (,a-pixmap  . ,pmap) )
       rest))

;;; Request #55: CreateGC
(define (send-CreateGC gc data scr . rest)
  (scr 'scix-xas `((,a-request     . ,CreateGC)
		   (,a-card8       . 0)		; 1 unused byte
		   (,a-card16      . ,(+ 4 (data 'length)))
		   (,a-gcontext    . ,gc)
		   (,a-drawable    . ,(gc 'drawable))
		   (,a-bitmask     . ,(data 'mask))
		   (,a-listofvalue . ,(data 'listofvalue)) )
       rest))

;;; Request #56: ChangeGC
(define (send-ChangeGC gc data scr . rest)
  (scr 'scix-xas `((,a-request     . ,ChangeGC)
		   (,a-card8       . 0)			; 1 unused byte
		   (,a-card16      . ,(+ 3 (data 'length)))
		   (,a-gcontext    . ,gc)
		   (,a-bitmask     . ,(data 'mask))
		   (,a-listofvalue . ,(data 'listofvalue)) )
       rest))

;;; Request #57: CopyGC
(define (send-CopyGC src-gc dst-gc data scr . rest)
  (scr 'scix-xas `((,a-request  . ,CopyGC)
		   (,a-card8    . 0)		; 1 unused byte
		   (,a-card16   . 4)		; req-len is constant
		   (,a-gcontext . ,src-gc)
		   (,a-gcontext . ,dst-gc)
		   (,a-bitmask  . ,(data 'mask)) )
       rest))

;;; Request #58: SetDashes
(define (send-SetDashes gc dash-offset dash-list scr . rest)
  (let ((n (length dash-list)))
    (scr 'scix-xas `((,a-request  . ,SetDashes)
		     (,a-card8    . 0)		    ; 1 unused byte
		     (,a-card16   . ,(+ 3 (/ (+ n (pad n)) 4))) ; Request length
		     (,a-gcontext . ,gc)
		     (,a-card16   . ,dash-offset)
		     (,a-card16   . ,n)		    ; Length of dashes
		     (,a-intlist  . ,(list-pad4 dash-list)) )
	 rest)))

;;; Request #59: SetClipRectangles
(define (send-SetClipRectangles ordering gc clip-x-orig clip-y-orig 
				rectangle-list scr . rest) 
  (let ((ord (lookup-constant ordering '((UnSorted . 0)
					 (YSorted  . 1)
					 (YXSorted . 2)
					 (YXBanded . 3) ))))
    (scr 'scix-xas `((,a-request  . ,SetClipRectangles)
		     (,a-card8    . ,ord)
		     (,a-card16   . ,(+ 3 (* 2 (length rectangle-list))))
		     (,a-gcontext . ,gc)
		     (,a-int16    . ,clip-x-orig)
		     (,a-int16    . ,clip-x-orig)
		     (,(a-list a-rectangle) . ,rectangle-list) )
	 rest)))

;;; Request #60: FreeGC
(define (send-FreeGC gc scr . rest)
  (scr 'scix-xas `((,a-request  . ,FreeGC)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 2)			; Request length
		   (,a-gcontext . ,gc) )
       rest))

;;; Request #61: ClearArea
(define (send-ClearArea exposures w x y width height scr . rest)
  (scr 'scix-xas `((,a-request . ,ClearArea)
		   (,a-bool    . ,exposures)
		   (,a-card16  . 4)			; Request length
		   (,a-window  . ,w)
		   (,a-int16   . ,x)
		   (,a-int16   . ,y)
		   (,a-card16  . ,width)
		   (,a-card16  . ,height) )
       rest))

;;; Request #62: CopyArea
(define (send-CopyArea src-d dst-d gc src-x src-y
		       dst-x dst-y width height scr . rest)
  (scr 'scix-xas `((,a-request  . ,CopyArea)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 7)			; Request length
		   (,a-drawable . ,src-d)
		   (,a-drawable . ,dst-d)
		   (,a-gcontext . ,gc)
		   (,a-int16    . ,src-x)
		   (,a-int16    . ,src-y)
		   (,a-int16    . ,dst-x)
		   (,a-int16    . ,dst-y)
		   (,a-card16   . ,width)
		   (,a-card16   . ,height) )
       rest))

 ;;; Request #63: CopyPlane
(define (send-CopyPlane src-d dst-d gc src-x src-y
			dst-x dst-y width height bit-plane scr . rest)
  (scr 'scix-xas `((,a-request  . ,CopyPlane)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 8)			; Request length
		   (,a-drawable . ,src-d)
		   (,a-drawable . ,dst-d)
		   (,a-gcontext . ,gc)
		   (,a-int16    . ,src-x)
		   (,a-int16    . ,src-y)
		   (,a-int16    . ,dst-x)
		   (,a-int16    . ,dst-y)
		   (,a-card16   . ,width)
		   (,a-card16   . ,height)
		   (,a-card32   . ,bit-plane) )
       rest))

;;; Request #64: PolyPoint
;;; Note: None of the "graphics objects" requests deal with the actual graphics
;;; objects. Instead the objects supply all the parameters to the requests.
;;; This is inconsistent with the rest of the requests but is done to keep the
;;; graphics objects as simple as possible.
;;;
(define (send-PolyPoint drawable gc c-mode point-list scr . rest)
  (scr 'scix-xas `((,a-request        . ,PolyPoint)
		   (,a-card8          . ,(lookup-constant c-mode
							  '((Origin . 0)
							    (Previous . 1) )))
		   (,a-card16         . ,(+ 3 (length point-list)))
		   (,a-drawable       . ,drawable)
		   (,a-gcontext       . ,gc)
		   (,(a-list a-point) . ,point-list) )
       rest))

;;; Request #65: PolyLine
(define (send-PolyLine drawable gc c-mode point-list scr . rest)
  (scr 'scix-xas `((,a-request        . ,PolyLine)
		   (,a-card8          . ,(lookup-constant c-mode
							  '((Origin . 0)
							    (Previous . 1) )))
		   (,a-card16         . ,(+ 3 (length point-list)))
		   (,a-drawable       . ,drawable)
		   (,a-gcontext       . ,gc)
		   (,(a-list a-point) . ,point-list) )
       rest))

;;; Request #66: PolySegment
(define (send-PolySegment drawable gc seg-list scr . rest)
  (scr 'scix-xas `((,a-request  . ,PolySegment)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . ,(+ 3 (* 2 (length seg-list))))
		   (,a-drawable . ,drawable)
		   (,a-gcontext . ,gc)
		   (,(a-list (lambda (seg-l buffer)
			       (a-int16 (car seg-l) buffer)
			       (a-int16 (cadr seg-l) buffer)
			       (a-int16 (caddr seg-l) buffer)
			       (a-int16 (cadddr seg-l) buffer))) . ,seg-list) )
       rest))

;;; Request #67: PolyRectangle
(define (send-PolyRectangle drawable gc rect-list scr . rest)
  (scr 'scix-xas `((,a-request            . ,PolyRectangle)
		   (,a-card8              . 0)		; 1 unused byte
		   (,a-card16             . ,(+ 3 (* 2 (length rect-list))))
		   (,a-drawable           . ,drawable)
		   (,a-gcontext           . ,gc)
		   (,(a-list a-rectangle) . ,rect-list) )
       rest))

;;; Request #68: PolyArc
(define (send-PolyArc drawable gc arc-list scr . rest)
  (scr 'scix-xas `((,a-request      . ,PolyArc)
		   (,a-card8        . 0)			; 1 unused byte
		   (,a-card16       . ,(+ 3 (* 3 (length arc-list))))
		   (,a-drawable     . ,drawable)
		   (,a-gcontext     . ,gc)
		   (,(a-list a-arc) . ,arc-list) )
       rest))

;;; Request #69: FillPoly
(define (send-FillPoly drawable gc shape coord-mode point-list scr . rest)
  (let ((sh (lookup-constant shape '((Complex . 0)
				     (Nonconvex . 1)
				     (Convex . 2) )))
	(cm (lookup-constant coord-mode '((Origin . 0)
					  (Previous . 1) ))))
    (scr 'scix-xas `((,a-request        . ,FillPoly)
		     (,a-card8          . 0)		; 1 unused byte
		     (,a-card16         . ,(+ 4 (length point-list)))
		     (,a-drawable       . ,drawable)
		     (,a-gcontext       . ,gc)
		     (,a-card8          . ,sh)
		     (,a-card8          . ,cm)
		     (,a-card16         . 0)		; 2 unused bytes
		     (,(a-list a-point) . ,point-list) )
	 rest)))

;;; Request #70: PolyFillRectangle
(define (send-PolyFillRectangle drawable gc rect-list scr . rest)
  (scr 'scix-xas `((,a-request            . ,PolyFillRectangle)
		   (,a-card8              . 0)		; 1 unused byte
		   (,a-card16             . ,(+ 3 (* 2 (length rect-list))))
		   (,a-drawable           . ,drawable)
		   (,a-gcontext           . ,gc)
		   (,(a-list a-rectangle) . ,rect-list) )
       rest))

;;; Request #71: PolyFillArc
(define (send-PolyFillArc drawable gc arc-list scr . rest)
  (scr 'scix-xas `((,a-request      . ,PolyFillArc)
		   (,a-card8        . 0)		; 1 unused byte
		   (,a-card16       . ,(+ 3 (* 3 (length arc-list))))
		   (,a-drawable     . ,drawable)
		   (,a-gcontext     . ,gc)
		   (,(a-list a-arc) . ,arc-list) )
       rest))

;;; Request #72: PutImage
;;; Note: Not tested.
(define (send-PutImage image-format drawable gc width height dst-x dst-y
		       left-pad byte-list scr . rest)
  (let ((n (length byte-list))
	(fmt (lookup-constant image-format '((Bitmap . 0)
					     (XYPixmap . 1)
					     (ZPixmap . 2) ))))
    (scr 'scix-xas `((,a-request  . ,PutImage)
		     (,a-card8    . ,fmt)
		     (,a-card16   . ,(+ 6 (/ (+ n (pad n)) 4)))
		     (,a-drawable . ,drawable)
		     (,a-gcontext . ,gc)
		     (,a-card16   . ,width)
		     (,a-card16   . ,height)
		     (,a-int16    . ,dst-x)
		     (,a-int16    . ,dst-y)
		     (,a-card8    . ,left-pad)
		     (,a-card8    . ,(if (eq? image-format 'Bitmap) 
					 1        ; The depth can be calculated
					 (drawable 'depth)))
		     (,a-card16   . 0)			; 2 unused bytes
		     (,a-intlist  . ,(list-pad4 byte-list)) )
	 rest)))

;;; Request #73: GetImage
(define (send-GetImage format drawable x y width height plane-mask scr . rest)
  (let* ((fmt (lookup-constant format '((XYPixmap . 1) (ZPixmap . 2))))
	 (seq-nr (scr 'scix-xas `((,a-request  . ,GetImage)
				  (,a-card8    . ,fmt)
				  (,a-card16   . 5)	; Request length
				  (,a-drawable . ,drawable)
				  (,a-int16    . ,x)
				  (,a-int16    . ,y)
				  (,a-card16   . ,width)
				  (,a-card16   . ,height)
				  (,a-card32   . ,plane-mask) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetImage scr) ))

;;; Request #74: PolyText8
(define (send-PolyText8 drawable gc x y textobj scr . rest)
  (scr 'scix-xas `((,a-request  . ,PolyText8)
		   (,a-card8    . 0)		               ; 1 unused byte
		   (,a-card16   . ,(+ 4 (textobj 'length)))    ; Request length
		   (,a-drawable . ,drawable)
		   (,a-gcontext . ,gc)
		   (,a-int16    . ,x)
		   (,a-int16    . ,y)
		   (,a-intlist  . ,(textobj 'items)) )
       rest))

;;; Request #75: PolyText16
(define (send-PolyText16 drawable gc x y textobj scr . rest)
  (scr 'scix-xas `((,a-request  . ,PolyText16)
		   (,a-card8    . 0)		               ; 1 unused byte
		   (,a-card16   . ,(+ 4 (textobj 'length)))
		   (,a-drawable . ,drawable)
		   (,a-gcontext . ,gc)
		   (,a-int16    . ,x)
		   (,a-int16    . ,y)
		   (,a-intlist  . ,(textobj 'items)) ) ; Should use strings...
       rest))

;;; Request #76: ImageText8
(define (send-ImageText8 drawable gc x y str scr . rest)
  (let ((n (string-length str)))
    (scr 'scix-xas `((,a-request  . ,ImageText8)
		     (,a-card8    . ,n)
		     (,a-card16   . ,(+ 4 (/ (+ n (pad n)) 4))) ; Request len
		     (,a-drawable . ,drawable)
		     (,a-gcontext . ,gc)
		     (,a-int16    . ,x)
		     (,a-int16    . ,y)
		     (,a-string8  . ,str) )
	 rest)))

;;; Request #77: ImageText16 -- Note: STRING16 is represented as an ordinary
;;;                             STRING8 with two bytes per CHAR16. If some
;;;                             other representation (like a list of pairs for
;;;                             instance) should turn out to be better then
;;;                             change it.
;;;
(define (send-ImageText16 drawable gc x y str scr . rest)
  (let ((n (/ (string-length str) 2)))
    (scr 'scix-xas `((,a-request  . ,ImageText8)
		     (,a-card8    . ,n)
		     (,a-card16   . ,(+ 4 (/ (+ n (pad n)) 4))) ; Request len
		     (,a-drawable . ,drawable)
		     (,a-gcontext . ,gc)
		     (,a-int16    . ,x)
		     (,a-int16    . ,y)
		     (,a-string8  . ,str) )                 ; a-string8 pads.
	 rest)))

;;; Request #78: CreateColormap
(define (send-CreateColormap alloc cmap visual scr . rest)
  (scr 'scix-xas `((,a-request  . ,CreateColormap)
		   (,a-card8    . ,(lookup-constant alloc '((None . 0)
							    (All  . 1) )))
		   (,a-card16   . 4)		; Request length
		   (,a-colormap . ,cmap)
		   (,a-window   . ,(scr 'root))
		   (,a-visualid . ,visual) )
       rest))

;;; Request #79: FreeColormap
(define (send-FreeColormap cmap scr . rest)
  (scr 'scix-xas `((,a-request  . ,FreeColormap)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 2)			; Request length
		   (,a-colormap . ,cmap) )
       rest))

;;; Request #80: CopyColormapAndFree
(define (send-CopyColormapAndFree cmap src-cmap scr . rest)
  (scr 'scix-xas `((,a-request  . ,CopyColormapAndFree)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 3)			; Request length
		   (,a-colormap . ,cmap)
		   (,a-colormap . ,src-cmap) )
       rest))

;;; Request #81: InstallColormap
(define (send-InstallColormap cmap scr . rest)
  (scr 'scix-xas `((,a-request  . ,InstallColormap)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 2)			; Request length
		   (,a-colormap . ,cmap) )
       rest))

;;; Request #82: UninstallColormap
(define (send-UninstallColormap cmap scr . rest)
  (scr 'scix-xas `((,a-request  . ,UninstallColormap)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 2)			; Request length
		   (,a-colormap . ,cmap) )
       rest))

;;; Request #83: ListInstalledColormaps
(define (send-ListInstalledColormaps scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,ListInstalledColormaps)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; Request length
				 (,a-window  . ,(scr 'root)) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'ListInstalledColormaps scr) ))

;;; Request #84: AllocColor
(define (send-AllocColor cmap red green blue scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request  . ,AllocColor)
				 (,a-card8    . 0)	; 1 unused byte
				 (,a-card16   . 4)	; Request length
				 (,a-colormap . ,cmap)
				 (,a-card16   . ,red)
				 (,a-card16   . ,green)
				 (,a-card16   . ,blue)
				 (,a-card16   . 0) )	; 2 unused bytes
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'AllocColor scr) ))

;;; Request #85: AllocNamedColor
(define (send-AllocNamedColor cmap name scr . rest)
  (let* ((n (string-length name))
	 (seq-nr (scr 'scix-xas `((,a-request  . ,AllocNamedColor)
				  (,a-card8    . 0)	; 1 unused byte
				  (,a-card16   . ,(+ 3 (/ (+ n (pad n)) 4)))
				  (,a-colormap . ,cmap)
				  (,a-card16   . ,n)
				  (,a-card16   . 0)	; 2 unused bytes
				  (,a-string8  . ,name) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'AllocNamedColor scr) ))

;;; Request #86: AllocColorCells
;;; Note: see comment at method alloccolorcells in the colormap object.
(define (send-AllocColorCells cont cmap colors planes scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request  . ,AllocColorCells)
				 (,a-bool     . ,cont)
				 (,a-card16   . 3)	; Request length
				 (,a-colormap . ,cmap)
				 (,a-card16   . ,colors)
				 (,a-card16   . ,planes) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'AllocColorCells scr) ))

;;; Request #87: AllocColorPlanes
(define (send-AllocColorPlanes cont cmap colors reds greens blues scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request  . ,AllocColorPlanes)
				 (,a-bool     . ,cont)
				 (,a-card16   . 4)
				 (,a-colormap . ,cmap)
				 (,a-card16   . ,colors)
				 (,a-card16   . ,reds)
				 (,a-card16   . ,greens)
				 (,a-card16   . ,blues) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'AllocColorPlanes scr) ))

;;; Request #88: FreeColors
(define (send-FreeColors cmap plane-mask pixels scr . rest)
  (scr 'scix-xas `((,a-request  . ,FreeColors)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . ,(+ 3 (length pixels)))
		   (,a-colormap . ,cmap)
		   (,a-card32   . ,plane-mask)
		   (,(a-list a-card32) . ,pixels) )
       rest))

;;; Request #89: StoreColors
(define (send-StoreColors cmap colors scr . rest)
  (scr 'scix-xas `((,a-request  . ,StoreColors)
		   (,a-card8    . 0)
		   (,a-card16   . ,(+ 2 (* 3 (length colors))))
		   (,a-colormap . ,cmap)
		   (,(a-list (lambda (c str)
			       (a-color c str)
			       (a-card16 (c 'red) str)
			       (a-card16 (c 'green) str)
			       (a-card16 (c 'blue) str)
			       (a-card8  (c 'do-mask) str)
			       (a-card8 0 str) )) . ,colors))
       rest))

;;; Request #90: StoreNamedColor
(define (send-StoreNamedColor cmap color name scr . rest)
  (let ((name-len (string-length name)))
    (scr 'scix-xas `((,a-request  . ,StoreNamedColor)
		     (,a-card8    . ,(color 'do-mask))
		     (,a-card16   . ,(+ 4 (/ (+ name-len (pad name-len)) 4)))
		     (,a-colormap . ,cmap)
		     (,a-color    . ,color)
		     (,a-card16   . ,name-len)
		     (,a-card16   . 0)			; 2 unused bytes
		     (,a-string8  . ,name) )
	 rest)))

;;; Request #91: QueryColors 
(define (send-QueryColors cmap colors scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request        . ,QueryColors)
				 (,a-card8          . 0)       ; 1 unused byte
				 (,a-card16         . ,(+ 2 (length colors)))
				 (,a-colormap       . ,cmap)
				 (,(a-list a-color) . ,colors) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryColors scr) ))

;;; Request #92: LookupColor
(define (send-LookupColor name scr . rest)
  (let* ((n (string-length name))
	 (seq-nr (scr 'scix-xas `((,a-request  . ,LookupColor)
				  (,a-card8    . 0)	; 1 unused byte
				  (,a-card16   . ,(+ 3 (/ (+ n (pad n)) 4)))
				  (,a-colormap . ,(scr 'default-colormap))
				  (,a-card16   . ,n)
				  (,a-card16   . 0)	; 2 unused bytes
				  (,a-string8  . ,name) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'LookupColor scr) ))

;;; Request #93: CreateCursor
(define (send-CreateCursor cursor source mask fore back x y scr . rest)
  (scr 'scix-xas `((,a-request . ,CreateCursor)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 8)			; Request length
		   (,a-cursor  . ,cursor)
		   (,a-pixmap  . ,source)
		   (,a-pixmap  . ,(if (eq? mask 'None)
				      0
				      mask))
		   (,a-card16  . ,(fore 'red))
		   (,a-card16  . ,(fore 'green))
		   (,a-card16  . ,(fore 'blue))
		   (,a-card16  . ,(back 'red))
		   (,a-card16  . ,(back 'green))
		   (,a-card16  . ,(back 'blue))
		   (,a-card16  . ,x)
		   (,a-card16  . ,y) )
       rest))

;;; Request #94: CreateGlyphCursor
(define (send-CreateGlyphCursor cursor source-font mask-font
				source-char mask-char fore back scr . rest)
  (scr 'scix-xas `((,a-request . ,CreateGlyphCursor)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 8)			; Request length
		   (,a-cursor  . ,cursor)
		   (,a-font    . ,source-font)
		   (,a-font    . ,(if (eq? mask-font 'None)
				      0
				      mask-font))
		   (,a-card16  . ,source-char)
		   (,a-card16  . ,mask-char)
		   (,a-card16  . ,(fore 'red))
		   (,a-card16  . ,(fore 'green))
		   (,a-card16  . ,(fore 'blue))
		   (,a-card16  . ,(back 'red))
		   (,a-card16  . ,(back 'green))
		   (,a-card16  . ,(back 'blue) ))
       rest))

;;; Request #95: FreeCursor
(define (send-FreeCursor cursor scr . rest)
  (scr 'scix-xas `((,a-request . ,FreeCursor)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 2)			; Request length
		   (,a-cursor  . ,cursor) )
       rest))

;;; Request #96: RecolorCursor
(define (send-RecolorCursor cursor fore back scr . rest)
  (scr 'scix-xas `((,a-request . ,RecolorCursor)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 5)			; Request length
		   (,a-cursor  . ,cursor)
		   (,a-card16  . ,(fore 'red))
		   (,a-card16  . ,(fore 'green))
		   (,a-card16  . ,(fore 'blue))
		   (,a-card16  . ,(back 'red))
		   (,a-card16  . ,(back 'green))
		   (,a-card16  . ,(back 'blue) ))
       rest))

;;; Request #97: QueryBestSize
;;; Note: What is the use of the width and height parameters?
(define (send-QueryBestSize cl drawable width height scr . rest)
  (let* ((class (lookup-constant cl '((Cursor . 0)
				      (Tile . 1)
				      (Stipple . 2) )))
	 (seq-nr (scr 'scix-xas `((,a-request  . ,QueryBestSize)
				  (,a-card8    . ,class)
				  (,a-card16   . 3)	      ; Request length
				  (,a-drawable . ,drawable)
				  (,a-card16   . ,width)
				  (,a-card16   . ,height) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryBestSize scr) ))

;;; Request #98: QueryExtension
(define (send-QueryExtension name scr . rest)
  (let* ((len (string-length name))
	 (seq-nr (scr 'scix-xas `((,a-request . ,QueryExtension)
				  (,a-card8   . 0)	; 1 unused byte
				  (,a-card16  . ,(+ 2 (/ (+ len (pad len)) 4)))
				  (,a-card16  . ,len)
				  (,a-card16  . 0)	; 2 unused bytes
				  (,a-string8 . ,name) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'QueryExtension scr) ))

;;; Request #99: ListExtensions
(define (send-ListExtensions scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,ListExtensions)
				 (,a-card8   . 0)	   ; 1 unused byte
				 (,a-card16  . 1) )        ; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'ListExtensions scr) ))

;;; Request #100: ChangeKeyboardMapping
;;; Note that key-count and keysyms/keycode are calculated from other params.
;;;(send-ChangeKeyboardMapping 64 '((12312 12312 142414 124124)
;;;                                 (13451 435435 34534 435345)
;;;                                 (34234 324342 32432 234324)) scr . rest)
(define (send-ChangeKeyboardMapping first-keycode keysyms scr . rest)
  (let ((keycode-count (length keysyms))
	(keysyms-per-keycode (length (car keysyms))) )
    (scr 'scix-xas `((,a-request . ,ChangeKeyboardMapping)
		     (,a-card8   . ,keycode-count)
		     (,a-card16  . ,(+ 2 (* keycode-count
					    keysyms-per-keycode)))
		     (,a-keycode . ,first-keycode)
		     (,a-card8   . ,keysyms-per-keycode)
		     (,a-card16  . 0)			; 2 unused bytes
		     (,(a-list (a-list a-keysym)) . ,keysyms) )
	 rest)))

;;; Request #101: GetKeyboardMapping
(define (send-GetKeyboardMapping first-keycode count scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetKeyboardMapping)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 2)	; Request length
				 (,a-keycode . ,first-keycode)
				 (,a-card8   . ,count)
				 (,a-card16  . 0) )   ; 2 unused bytes
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetKeyboardMapping scr) ))

;;; Request #102: ChangeKeyboardControl
(define (send-ChangeKeyboardControl data scr . rest)
  (scr 'scix-xas `((,a-request     . ,ChangeKeyboardControl)
		   (,a-card8       . 0)		         ; 1 unused byte
		   (,a-card16      . ,(+ 2 (data 'length)))    ; Request length
		   (,a-bitmask     . ,(data 'mask))
		   (,a-listofvalue . ,(data 'listofvalue)) )
       rest))

;;; Request #103: GetKeyboardControl
(define (send-GetKeyboardControl scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetKeyboardControl)
				 (,a-card8   . 0)   	; 1 unused byte
				 (,a-card16  . 1) )	; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetKeyboardControl scr) ))

;;; Request #104: Bell
(define (send-Bell percent scr . rest)
  (scr 'scix-xas `((,a-request . ,Bell)
		   (,a-int8    . ,percent)
		   (,a-card16  . 1) )			; Request length
       rest))

;;; Request #105: ChangePointerControl
(define (send-ChangePointerControl acc-num acc-den thr
				   do-acc do-thr scr . rest)
  (scr 'scix-xas `((,a-request . ,ChangePointerControl)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 3)			; Request length
		   (,a-int16   . ,acc-num)
		   (,a-int16   . ,acc-den)
		   (,a-int16   . ,thr)
		   (,a-bool    . ,do-acc)
		   (,a-bool    . ,do-thr) )
       rest))

;;; Request #106: GetPointerControl
(define (send-GetPointerControl scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetPointerControl)
				 (,a-card8   . 0)        ; 1 unused byte
				 (,a-card16  . 1) )      ; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetPointerControl scr) ))

;;; Request #107: SetScreenSaver
(define (send-SetScreenSaver timeout interval prefer-blanking
			     allow-exposures scr . rest)
  (let ((alist '((No . 0) (Yes . 1) (Default . 2))))
    (scr 'scix-xas `((,a-request . ,SetScreenSaver)
		     (,a-card8   . 0)			; 1 unused byte
		     (,a-card16  . 3)			; Request length
		     (,a-int16   . ,timeout)
		     (,a-int16   . ,interval)
		     (,a-card8   . ,(lookup-constant prefer-blanking alist))
		     (,a-card8   . ,(lookup-constant allow-exposures alist))
		     (,a-card16  . 0) )    		; 2 unused bytes
	 rest)))

;;; Request #108: GetScreenSaver
(define (send-GetScreenSaver scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetScreenSaver)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 1) )	; request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetScreenSaver scr) ))

;;; Request #109: ChangeHosts
;;; Note: This looks ugly, but there is no better place for it. Maybe bugs left
(define (send-ChangeHosts mode family addr scr . rest)
  (let* ((addr (if (eq? family 'DECnet)
		   (list (bit-and (cadr addr) 255) ; Mask off LSByte of node-nr
			 (bit-or (bit-rsh (car addr) 2) ; Area part of byte2
				 (bit-rsh (cadr addr) 6) ))
		   addr))
	 (addr-len (length addr)) )
    (scr 'scix-xas `((,a-request . ,ChangeHosts)
		     (,a-card8   . ,(lookup-constant mode '((Insert . 0)
							    (Delete . 1) )))
		     (,a-card16  . ,(+ 2 (/ (+ addr-len (pad addr-len)) 4)))
		     (,a-card8   . ,(lookup-constant family '((Internet . 0)
							      (DECnet   . 1)
							      (Chaos    . 2))))
		     (,a-card8   . 0)		; 1 unused byte
		     (,a-card16  . ,addr-len)
		     (,(a-list a-card8) . ,addr) )
	 rest)))

;;; Request #110: ListHosts
;;; Note: some kind of trouble with DECnet addresses
(define (send-ListHosts scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,ListHosts)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 1) )	; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'ListHosts scr) ))

;;; Request #111: SetAccessControl
(define (send-SetAccessControl mode scr . rest)
  (let ((md (lookup-constant mode '((Disable . 0)
				    (Enable  . 1)))))
    (scr 'scix-xas `((,a-request . ,SetAccessControl)
		     (,a-card8   . ,md)
		     (,a-card16  . 1) )		; Request length
	 rest)))

;;; Request #112: SetCloseDownMode
(define (send-SetCloseDownMode mode scr . rest)
  (let ((md (lookup-constant mode '((Destroy         . 0)
				    (RetainPermanent . 1)
				    (RetainTemporary . 2) ))))
    (scr 'scix-xas `((,a-request . ,SetCloseDownMode)
		     (,a-card8   . ,md)
		     (,a-card16  . 1) )		; Request length
	 rest)))

;;; Request #113: KillClient
;;; Note: We use the type window here for the resource, as there is no generic
;;;       type for all resources. It is not possible to use a-card32, because
;;;       it does not now about objects.
(define (send-KillClient resource scr . rest)
  (scr 'scix-xas `((,a-request  . ,KillClient)
		   (,a-card8    . 0)			; 1 unused byte
		   (,a-card16   . 2)			; Request length
		   (,a-resource . ,(lookup-constant resource
						    '((AllTemporary . 0)))) )
       rest))

;;; Request #114: RotateProperties
(define (send-RotateProperties w delta properties scr . rest)
  (let* ((atombox (scr 'atombox))
	 (properties (map (lambda (p)
			    (atombox 'lookup-id p) )
			  properties) ))
    (scr 'scix-xas `((,a-request       . ,RotateProperties)
		     (,a-card8         . 0)		      ; 1 unused byte
		     (,a-card16        . ,(+ 3 (length properties))) ; Req len
		     (,a-window        . ,w)
		     (,a-card16        . ,(length properties))
		     (,a-int16         . ,delta)
		     (,(a-list a-atom) . ,properties) )
	 rest)))

;;; Request #115: ForceScreenSaver
(define (send-ForceScreenSaver mode scr . rest)
  (let ((onoff (lookup-constant mode '((Reset    . 0)
				       (Activate . 1)))))
    (scr 'scix-xas `((,a-request . ,ForceScreenSaver)
		     (,a-card8   . ,onoff)
		     (,a-card16  . 1) )
	 rest)))

;;; Request #116: SetPointerMapping
(define (send-SetPointerMapping p-map scr . rest)
  (let* ((n (length p-map))
	 (seq-nr (scr 'scix-xas `((,a-request . ,SetPointerMapping)
				  (,a-card8   . ,n)
				  (,a-card16  . ,(+ 1 (/ (+ n (pad n)) 4)))
				  (,(a-list a-card8) . ,(list-pad4 p-map)) )
		      rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'SetPointerMapping scr) ))

;;; Request #117: GetPointerMapping
(define (send-GetPointerMapping scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetPointerMapping)
				 (,a-card8   . 0)	; 1 unused byte
				 (,a-card16  . 1) )    	; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetPointerMapping scr) ))

;;; Request #118: SetModifierMapping
;;; Note: keycodes is a list of lists, one for each modifier.
(define (send-SetModifierMapping keycodes scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,SetModifierMapping)
				 (,a-card8   . ,(length (car keycodes)))
				 (,a-card16  . ,(+ 1 (* 2 (length
							   (car keycodes)))))
				 (,(a-list
				    (lambda (keycode-list buffer)
				      (for-each (lambda (keycode)
						  (a-keycode keycode buffer))
						keycode-list))) . ,keycodes) )
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'SetModifierMapping scr) ))

;;; Request #119: GetModifierMapping
(define (send-GetModifierMapping scr . rest)
  (let ((seq-nr (scr 'scix-xas `((,a-request . ,GetModifierMapping)
				 (,a-card8   . 0)       ; 1 unused byte
				 (,a-card16  . 1) )     ; Request length
		     rest)))
    (msg-handler 'scix-wait-for-reply seq-nr 'GetModifierMapping scr) ))

;;; Request #127: NoOperation
(define (send-NoOperation scr . rest)
  (scr 'scix-xas `((,a-request . ,NoOperation)
		   (,a-card8   . 0)			; 1 unused byte
		   (,a-card16  . 1) )  			; Request length
       rest))