;;; xlib-xc.el --- X Connection.

;; Copyright (C) 2003-2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 18 October 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xc.el,v 1.7 2005-04-04 19:55:29 lg Exp $
;; X-URL: http://lgarc.narod.ru/xwem/index.html

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; 

;;; Code:

(eval-when-compile
  (require 'cl)

  (mapc (lambda (el)
          (autoload el "xlib-xwin"))
        '(X-Win-event-handlers X-Win-EventHandler-runall make-X-Rect
          X-Win-find-or-make X-Atom-find-or-make X-Win-p))
  )

(require 'xlib-math)
(require 'xlib-const)

(defvar X-Dpy-dpys-list nil
  "List of all opened displays.")

(defstruct X-Visual
  id
  class
  bits-per-rgb
  cmap-entries
  red-mask
  green-mask
  blue-mask)

(defstruct X-Depth
  depth
  visuals)				; List of X-Visual

(defstruct X-Screen
  dpy					; display
  root					; Root window
  colormap
  white-pixel black-pixel
  root-event-mask			; Event mask for root window

  visualid
  backingstores
  save-unders
  width height				; in pixels
  mwidth mheight			; in millimeters
  min-maps max-maps
  default-gc
  root-depth				; Root depth
  depths				; List of X-Depth
  )

(defstruct X-ScreenFormat
  depth
  bits-per-pixel
  scanline-pad)

(defstruct (X-Dpy (:predicate X-Dpy-isxdpy-p))
  proc					; process, which holds X connection
  log-buffer				; buffer for logs, when debugging is non-nil
  properties				; User defined plist

  ;; Protecting section
  (readings 0)				; non-zero mean we are in reading mode
  evq                                   ; saved events queue, normally should be nil

  snd-queue                             ; Send queue, each call to
					; `X-Dpy-send' adds data to
					; this queue

  (parse-guess-dispatcher 'X-Dpy-parse-message-guess)
  (events-dispatcher 'X-Dpy-default-events-dispatcher)

  event-handlers			; event handlers, same as in X-Win

  message-buffer

  ;; X section
  name					; display name
  proto-maj proto-min			; major and minor numbers for X protocol
  vendor				; Vendor string
  min-keycode max-keycode		; keycodes allowed
  resource-base resource-mask (resource-id 1)
  (rseq-id 0)				; requests sequence number
  max-request-size			; Maximum request size allowed
  motion-bufsize
  byte-order				; Images byte order

  bitmap-scanline-unit
  bitmap-scanline-pad
  bitmap-bit-order

  formats				; List of X-ScreenFormat

  (default-screen 0)			; default screen number
  screens				; List of X-Screen

  error-hooks				; Hooks called when X error occurs

  ;; Various display lists
  atoms					; list of atoms
  windows				; list of windows
  fonts					; list of opened fonts
  extensions				; list of extensions
  )

(defmacro X-Dpy-put-property (xdpy prop val)
  "Put property PROP with value VAL in XDPY's properties list."
  `(setf (X-Dpy-properties ,xdpy)
	 (plist-put (X-Dpy-properties ,xdpy) ,prop ,val)))

(defmacro X-Dpy-get-property (xdpy prop)
  "Get property PROP from XDPY's properties list."
  `(plist-get (X-Dpy-properties ,xdpy) ,prop))

(defsetf X-Dpy-get-property X-Dpy-put-property)

(defmacro X-Dpy-rem-property (xdpy prop)
  "Remove property PROP from XDPY's properties list."
  `(setf (X-Dpy-properties ,xdpy) (plist-remprop (X-Dpy-properties ,xdpy) ,prop)))

(defsubst X-Dpy-EventHandler-add (dpy handler &optional priority evtypes-list)
  "To DPY's event handlers list add HANDLER."
  (setf (X-Dpy-event-handlers dpy)
	(X-EventHandler-add (X-Dpy-event-handlers dpy) handler priority evtypes-list)))

(defsubst X-Dpy-EventHandler-isset (dpy handler &optional priority evtypes-list)
  "Return non-nil if on DPY event HANDLER is set."
  (X-EventHandler-isset (X-Dpy-event-handlers dpy) handler priority evtypes-list))

(defsubst X-Dpy-EventHandler-rem (dpy handler &optional priority evtypes-list)
  "From DPY's event handlers list, remove HANDLER."
  (setf (X-Dpy-event-handlers dpy)
	(X-EventHandler-rem (X-Dpy-event-handlers dpy) handler priority evtypes-list)))

(defsubst X-Dpy-EventHandler-enable (dpy handler &optional priority evtypes-list)
  "In DPY's list of event handlers activate HANDLER."
  (X-EventHandler-enable (X-Dpy-event-handlers dpy) handler priority evtypes-list))

(defsubst X-Dpy-EventHandler-disable (dpy handler &optional priority evtypes-list)
  "In DPY's list of event handlers disable HANDLER."
  (X-EventHandler-disable (X-Dpy-event-handlers dpy) handler priority evtypes-list))

(defsubst X-Dpy-EventHandler-runall (dpy xev)
  "Run all DPY's event handlers on XEV.
Signal `X-Events-stop' to stop events processing."
  (X-EventHandler-runall (X-Dpy-event-handlers dpy) xev))

;; Formats operations
(defun X-formatfind (xdpy depth)
  "On display XDPY find proper X-ScreenFormat for gived DEPTH."
  (let ((formats (X-Dpy-formats xdpy)))
    (while (and formats (not (= depth (X-ScreenFormat-depth (car formats)))))
      (setq formats (cdr formats)))

    (car formats)))

(defun X-formatint (xdpy depth num)
  "On display XDPY convert NUM to string."
  (let ((fmt (X-formatfind xdpy depth))
	bpp cfun)
    (if (not (X-ScreenFormat-p fmt))
	""

      (setq bpp (/ (X-ScreenFormat-bits-per-pixel fmt) 8))
      (setq cfun (intern (format "int->string%d" bpp)))
      (funcall cfun num))))

(defun X-formatpad (xdpy depth str)
  "Return padded STR."
  (let ((fmt (X-formatfind xdpy depth))
	bp)
    
    ;; XXX Can't deal with bits
    (if (not (X-ScreenFormat-p fmt))
	;; XXX Assume depth is 1 for bitmaps
	str

      (setq bp (/ (X-ScreenFormat-scanline-pad fmt) 8))
      (concat str
	      (make-string (% (- bp (% (length str) bp)) bp) ?\x00)))))

(defun X-Dpy-p (xdpy &optional sig)
  "Return non-nil if XDPY is X display.
If SIG is given and XDPY is not X display, SIG will be signaled."
  (let ((isdpy (X-Dpy-isxdpy-p xdpy)))
    (if (and (not isdpy) sig)
	(signal 'wrong-type-argument (list sig 'X-Dpy-p xdpy))
      isdpy)))

(defun X-Dpy-get-id (xdpy)
  "Get id to be used on X display XDPY."
  (X-Dpy-p xdpy 'X-Dpy-get-id)

  (let* ((newid (X-Dpy-resource-id xdpy))
	 (newword (float 0))
	 (bitcnt 0)			;bit counter in mask
	 (idcnt 0)			;bit counter in id
	 (servmask (X-Dpy-resource-mask xdpy)) ;service mask (our unique bits)
	 (servbase (X-Dpy-resource-base xdpy)))	;service base (always set)
    ;; we can say <30 because top 3 bits are always 0
    (while (< bitcnt 30)		;while there is more in the mask
      (if (Xtest servmask (Xmask bitcnt))
	  (progn
	    (if (Xtest newid (Xmask idcnt)) ;set bit in id if it is
					;set in the id value.
		(setq newword (Xmask-or newword (Xmask bitcnt))))
	    (setq idcnt (1+ idcnt))))	;inc idcnt when we have a mask match
      (setq bitcnt (1+ bitcnt)))	;always inc bitmask cnter

    (incf (X-Dpy-resource-id xdpy))	;inc to next id counter value
    (Xmask-or newword servbase)))	;return the id with base attached

;;; Process functions
(defun X-Dpy-create-connection (dname dnum)
  "Create X connection to display with name DNAME and number DNUM."

  (let* ((xcon (open-network-stream (format "X-%s:%d" dname dnum)
				   nil	; no buffer
				   dname
				   (+ 6000 dnum)))
	 (xdpy (make-X-Dpy :proc xcon :name (format "%s:%d" dname dnum))))
    
    (set-process-filter xcon 'X-Dpy-filter)
    (set-process-sentinel xcon 'X-Dpy-sentinel)

    (add-to-list 'X-Dpy-dpys-list xdpy)
    xdpy))

(defun X-Dpy-find-dpy (proc)
  "Find xdpy by process PROC."
  (let ((dpys X-Dpy-dpys-list))
    (while (and dpys (not (eq proc (X-Dpy-proc (car dpys)))))
      (setq dpys (cdr dpys)))
    (car dpys)))

(defun X-Dpy-filter (proc out)
  "Filter for X nework connections."
  (let ((xdpy (X-Dpy-find-dpy proc)))
    (X-Dpy-p xdpy 'X-Dpy-filter)

    (setf (X-Dpy-message-buffer xdpy)
	  (concat (X-Dpy-message-buffer xdpy) out))
    
    (funcall (X-Dpy-parse-guess-dispatcher xdpy) xdpy)))

(defun X-Dpy-sentinel (proc &optional event)
  "Sentinel for X connections."
  (let ((xdpy (X-Dpy-find-dpy proc)))
    (X-Dpy-p xdpy 'X-Dpy-sentinel)

    (message "X: Removing process %S" proc)
    (sit-for 1)
    (delete-process proc)

    (setq X-Dpy-dpys-list (delq xdpy X-Dpy-dpys-list))))

(defun X-Dpy-close (xdpy)
  "Close connection associated with XDPY."
  (X-Dpy-p xdpy 'X-Dpy-close)
  (X-Dpy-send-flush xdpy)
  (X-Dpy-sentinel (X-Dpy-proc xdpy)))

;; Logging
;; Supported routines are:
;;   x-display  - display related
;;   x-error    - X Errors related
;;   x-event    - X Event related
;;   x-tray     - X tray related
;;   x-misc     - Misc stuff
;;   x-record   - RECORD extension

(defun X-Dpy-set-log-routines (xdpy routines)
  "Set XDPY's log routines to ROUTINES."
  (X-Dpy-put-property xdpy 'log-routines routines))

(defun X-Dpy-get-log-routines (xdpy)
  "Return XDPY's log routines."
  (X-Dpy-get-property xdpy 'log-routines))

(defun X-Dpy-has-log-routine-p (xdpy routine)
  "Return non-nil if XDPY has log ROUTINE."
  (memq routine (X-Dpy-get-log-routines xdpy)))

(defun X-Dpy-log (xdpy routine &rest args)
  "Put a ROUTINE's message in the in the log buffer specified by XDPY.
If XDPY is nil, then put into current buffer.  Log additional ARGS as well."
  (X-Dpy-p xdpy 'X-Dpy-log)

  (when (and (X-Dpy-log-buffer xdpy)
             (X-Dpy-has-log-routine-p xdpy routine)
	     (bufferp (get-buffer-create (X-Dpy-log-buffer xdpy))))
    (with-current-buffer (get-buffer-create (X-Dpy-log-buffer xdpy))
      (save-excursion
        (goto-char (point-min))
        (insert (format "%d %S: " (nth 1 (current-time)) routine))
        (insert (apply 'format (mapcar 'eval args)))
        (insert "\n")))))

(defun X-Dpy-log-verbatim (xdpy arg)
  (X-Dpy-p xdpy 'X-Dpy-log-verbatim)

  (when (bufferp (X-Dpy-log-buffer xdpy))
    (with-current-buffer (X-Dpy-log-buffer xdpy)
      (goto-char (point-min))
      (insert "[" arg "]" "\n"))
    ))

;;; Sending/receiving functions
(defun X-Dpy-send-flush (xdpy)
  "Send XDPY's send buffer to X server."
  (process-send-string (X-Dpy-proc xdpy)
                       (mapconcat 'identity (nreverse (X-Dpy-snd-queue xdpy)) ""))
  (setf (X-Dpy-snd-queue xdpy) nil))

(defun X-Dpy-send (xdpy s)
  "Send the X server DPY the string S. Increase request id rseq-id.
There is special mode when we are collecting X output to send it all at once."
  (setf (X-Dpy-snd-queue xdpy)
        (cons s (X-Dpy-snd-queue xdpy)))
  (enqueue-eval-event 'X-Dpy-send-flush xdpy)
  ;; increase request sequence number
  (incf (X-Dpy-rseq-id xdpy)))

;;; Sending section
(defmacro X-Force-char-num (maybechar)
  "Force MAYBECHAR to be a number for XEmacs platform."
  ;; This is an annoying XEmacs problem  To bad it slows down
  ;; Emacs too.
  (if (fboundp 'characterp)
      (list 'if (list 'characterp maybechar)
	    (list 'setq maybechar (list 'char-to-int maybechar)))))

(defconst X-byte-order ?l "Byte order used by emacs X.  B MSB, l LSB.")
(defconst X-protocol-minor-version 0 "Minor version of client.")
(defconst X-protocol-major-version 11 "Major version of client.")

(defconst X-client-to-open
  (list [1 X-byte-order]
	[1 0]				;unused
	[2 X-protocol-major-version]
	[2 X-protocol-minor-version]
	[2 0]				;auth name
	[2 0]				;auth data
	[2 0]				;unused
	;; No auth name or data, so empty
	)
  "XStruct list of sizes when opening a connection.")

(defun X-Create-message (message-s &optional pad-notneed)
  "Takes the MESSAGE-S structure and builds a net string.
MESSAGE-S is a list of vectors and symbols which formulate the message
to be sent to the XServer.  Each vector is of this form:
  [ SIZE VALUE ]
  SIZE is the number of BYTES used by the message.
  VALUE is the lisp object whose value is to take up SIZE bytes.
  If VALUE or SIZE is a symbol or list, extract that elements value.
    If the resulting value is still a list or symbol, extract it's value
    until it is no longer a symbol or a list.
  If VALUE is a number, massage it to the correct size.
  If VALUE is a string, append that string verbatum.
  If VALUE is nil, fill it with that many NULL characters.

When PAD-NOTNEED is non-nil, then do not pad to 4 bytes."
  
  (let ((gc-cons-threshold most-positive-fixnum)	;inhibit gc'ing
	(news nil)
	(ts   nil)
	(tvec nil)
	(tval nil)
	(tlen nil))
    (while message-s
      (setq tvec (car message-s))
      (setq tval (aref tvec 1))
      (setq tlen (aref tvec 0))

      ;; Check for symbols, or symbols containing symbols.
      (while (and tlen (or (listp tlen) (symbolp tlen)))
	(setq tlen (eval tlen)))

      ;; Check for symbols, or symbols containing symbols.
      (while (and (not (null tval))	; nil symbol allowed
		  (not (eq tval t))	; t symbol allowed
		  (or (listp tval) (symbolp tval)))
	(setq tval (eval tval)))

      ;; Fix XEmacs 20 broken characters
      (X-Force-char-num tval)

      ;; Numbers, put in.
      (cond
       ;; numbers get converted based on size.
       ((numberp tval)
	(cond
	 ((= tlen 1)
	  (setq ts (int->string1 tval)))
	 ((= tlen 2)
	  (setq ts (int->string tval)))
	 ((= tlen 4)
	  (setq ts (int->string4 tval)))
	 (t
	  (error "Wrong size for a message part to be a number!"))))

       ;; strings get appended onto the end.
       ((stringp tval)
	(setq ts tval))

       ;; nil is usually filler, so stuff on some 0s
       ((eq tval nil)
	(setq ts (make-string tlen ?\x00)))

       ;; t is alias for True
       ((eq tval t)
	(setq ts (concat (make-string (- tlen 1) ?\x00) (make-string 1 ?\x01))))

       ;; some sort of error
       (t
	(error "Invalid type to be put into an Xmessage")))

      (setq ts (concat ts "\0\0\0\0"))	; make sure we fill length req.
      (setq ts (substring ts 0 tlen))
      (setq news (concat news ts))
      (setq message-s (cdr message-s)))

    ;; pad the message
    (if (and (not pad-notneed)
	     (/= (% (length news) 4) 0))
	(let ((s "\0\0\0\0"))
	  (setq news (concat news (substring s 0 (- 4 (% (length news) 4)))))))
    news))

;;;; NEW stuff, X types declarations

;; Not yet workable.

;; Why is this needed?  Gives flexibility in implementing and
;; accessing X server and its resources.

;; Autogenerator can be written, which will generate types according
;; to proto.TXT or other papers.

(defmacro define-X-type (type type-description)
  "Define new X value type.
TYPE-DESCRIPTION is list where car of it is one of:

   `type' - Specifies static type, next values are - LENGTH
            VALUE-PACKER VALUE-EXTRACTOR.

   `resource' - Specifies some resource which has PREDICATE and
                ID-EXTRACTOR functions. 

   `alias' - Alias to some already defined type.

   `enum' - for use by SETofXXXX types.

   `struct' - Define stucture.

   `or' - One of other type.
"
  `(put (quote ,type) 'X-type-description ,type-description))

(defun X-type-pack (dpy type val)
  (let* ((xtd (or (and (listp type) type)
                  (get type 'X-type-description)))
         (xt (car xtd)))
    (cond ((and (eq xt 'resource) (funcall (cadr xtd) val))
           (int32->string (funcall (caddr xtd) val)))

          ((eq xt 'type)
           (funcall (caddr xtd) val))

          ((and (eq xt 'enum) (memq val (cddr xtd)))
           (int->string val))

          ((eq xt 'alias)
           (X-type-pack dpy (cadr xtd) val))

          ((eq xt 'listof)
           (apply 'concat (mapcar #'(lambda (el)
                                      (X-type-pack dpy (cadr xtd) el))
                                  val)))

          ((eq xt 'setof)
           (funcall (cond ((= (cadr xtd) 1) 'int->string1)
                          ((= (cadr xtd) 2) 'int->string2)
                          ((= (cadr xtd) 4) 'int->string4))
                    (apply 'Xmask-or val)))

          ((eq xt 'struct)
           (apply 'concat (mapcar #'(lambda (tt)
                                      (X-type-pack dpy (cdr tt)
                                                   (funcall (car tt) val)))
                                  (cddr xt))))

          ((eq xt 'or)
           (setq xt (cdr xt))
           (let (orval)
             (while (and xt (not orval))
               (setq orval (X-type-pack dpy (car xt) val)
                     xt (cdr xt)))
             orval)))))

(defun X-type-extract (dpy type &optional llen)
  (let* ((xtd (or (and (listp type) type)
                  (get type 'X-type-description)))
         (xt (car xtd)))
    (cond ((eq xt 'resource)
           (funcall (cadddr xtd) dpy (string->int32 (X-Dpy-grab-bytes dpy 4))))

          ((eq xt 'type)
           (funcall (cadddr xtd) (X-Dpy-grab-bytes dpy (cadr xtd))))

          ((eq xt 'enum)
           (string->int (X-Dpy-grab-bytes dpy (cadr xtd))))

          ((eq xt 'alias)
           (X-type-extract dpy (cadr xtd)))

          ((eq xt 'listof)
           (when (numberp llen)
             (let (rval)
               (while (> llen 0)
                 (setq rval (X-type-extract dpy (cadr xtd)))
                 (decf llen))
               rval)))

          ((eq xt 'setof)
           (let ((smask (funcall (cond ((= (cadr xtd) 1) 'string1->int)
                                       ((= (cadr xtd) 2) 'string->int)
                                       ((= (cadr xtd) 4) 'string4->int))
                                 (X-Dpy-grab-bytes dpy (cadr xtd))))
                 (dd (get (caddr xtd) 'X-type-description))
                 (cmask 1)
                 rval)
             (when (eq (car dd) 'enum)
               (setq dd (cddr dd))
               (while dd
                 (when (Xtest smask cmask)
                   (setq rval (cons (car dd) rval)))
                 (setq cmask (lsh cmask 1)
                       dd (cdr dd))))
             rval))

          ((eq xt 'struct)
           (let ((rval (funcall (cadr xtd))))
             (mapc #'(lambda (tt)
                       (eval `(setf (,(car tt) rval)
                                    (X-type-extract dpy ,(cdr tt)))))
                   (cdr xtd))
             rval)))))

;; Add some built-in types
(define-X-type WINDOW '(resource X-Win-p X-Win-id X-Win-find-or-make))
(define-X-type PIXMAP '(resource X-Pixmap-p X-Pixmap-id X-Pixmap-find-or-make))
(define-X-type CURSOR '(resource X-Cursor-p X-Cursor-id X-Cursor-find-or-make))
(define-X-type FONT '(resource X-Font-p X-Font-id X-Font-find))
(define-X-type GCONTEXT '(resource X-Gc-p X-Gc-id ignore))
(define-X-type COLORMAP '(resource X-Colormap-p X-Colormap-id))
(define-X-type DRAWABLE '(or WINDOW PIXMAP))
(define-X-type FONTABLE '(or FONT GCONTEXT))
(define-X-type ATOM '(resource X-Atom-p X-Atom-id X-Atom-find-or-make))
(define-X-type VISUALID '(resource X-Visual-p X-Visual-id ignore))
(define-X-type BYTE '(type 1 char-to-string string-to-char))
(define-X-type INT8 '(type 1 x-int8->string x-string->int8))
(define-X-type INT16 '(type 2 x-int16->string x-string->int16))
(define-X-type INT32 '(type 4 x-int32->string x-string->int32))
(define-X-type CARD8 '(type 1 x-card8->string x-string->card8))
(define-X-type CARD16 '(type 2 x-card16->string x-string->card16))
(define-X-type CARD32 '(type 4 x-card32->string x-string->card32))
(define-X-type TIMESTAMP '(alias CARD32))
(define-X-type BITGRAVITY (list 'enum 1
                                 X-ForgetGravity X-StaticGravity X-NorthWestGravity
                                 X-NorthGravity X-NorthEastGravity X-WestGravity
                                 X-CenterGravity X-EastGravity X-SouthWestGravity
                                 X-SouthGravity X-SouthEastGravity))
(define-X-type WINGRAVITY (list 'enum 1
                                 X-UnmapGravity X-StaticGravity X-NorthWestGravity
                                 X-NorthGravity X-NorthEastGravity X-WestGravity
                                 X-CenterGravity X-EastGravity X-SouthWestGravity
                                 X-SouthGravity X-SouthEastGravity))
(define-X-type BOOL (list 'enum 1 X-True X-False))
(define-X-type EVENT (list 'enum 4
                            XM-KeyPress XM-KeyRelease XM-OwnerGrabButton XM-ButtonPress
                            XM-ButtonRelease XM-EnterWindow XM-LeaveWindow XM-PointerMotion
                            XM-PointerMotionHint XM-Button1Motion XM-Button2Motion 
                            XM-Button3Motion XM-Button4Motion XM-Button5Motion 
                            XM-ButtonMotion XM-Exposure XM-VisibilityChange XM-StructureNotify
                            XM-ResizeRedirect XM-SubstructureNotify XM-SubstructureRedirect 
                            XM-FocusChange XM-PropertyChange XM-ColormapChange XM-KeymapState))
(define-X-type POINTEREVENT (list 'enum 4
                                   XM-ButtonPress XM-ButtonRelease XM-EnterWindow
                                   XM-LeaveWindow XM-PointerMotion XM-PointerMotionHint
                                   XM-Button1Motion XM-Button2Motion XM-Button3Motion
                                   XM-Button4Motion XM-Button5Motion XM-ButtonMotion XM-KeymapState))
(define-X-type DEVICEEVENT (list 'enum 4
                                  XM-KeyPress XM-KeyRelease XM-ButtonPress XM-ButtonRelease
                                  XM-PointerMotion XM-Button1Motion XM-Button2Motion
                                  XM-Button3Motion XM-Button4Motion XM-Button5Motion
                                  XM-ButtonMotion))
(define-X-type KEYSYM '(alias INT32))
(define-X-type KEYCODE '(alias CARD8))
(define-X-type BUTTON '(alias CARD8))
(define-X-type KEYMASK (list 'enum 2 X-Shift X-Lock X-Control X-Mod1 X-Mod2 X-Mod3 X-Mod4 X-Mod5))
(define-X-type BUTMASK (list 'enum 2 X-Button1 X-Button2 X-Button3 X-Button4 X-Button5))
(define-X-type KEYBUTMASK '(or KEYMASK BUTMASK))

(defun make-X-Char2B ()
  (make-string 2 ?\x00))
(defun X-Char2B-byte0 (c2b)
  (aref c2b 0))
(defsetf X-Char2B-byte0 (c2b) (b)
  `(aset ,c2b 0 ,b))
(defun X-Char2B-byte1 (c2b)
  (aref c2b 1))
(defsetf X-Char2B-byte1 (c2b) (b)
  `(aset ,c2b 1 ,b))

(define-X-type CHAR2B '(struct X-Char2B
                               (X-Char2B-byte0 . BYTE)
                               (X-Char2B-byte1 . BYTE)))
(define-X-type STRING8 '(listof BYTE))
(define-X-type STRING16 '(listof CHAR2B))

(define-X-type POINT '(struct X-Point
                              (X-Point-x . INT16)
                              (X-Point-y . INT16)))
(define-X-type RECTANGLE '(struct X-Rect
                                  (X-Rect-x . INT16)
                                  (X-Rect-y . INT16)
                                  (X-Rect-width . CARD16)
                                  (X-Rect-height . CARD16)))
(define-X-type ARC '(struct X-Arc
                            (X-Arc-x . INT16)
                            (X-Arc-y . INT16)
                            (X-Arc-width . CARD16)
                            (X-Arc-height . CARD16)
                            (X-Arc-angle1 . INT16)
                            (X-Arc-angle2 . INT16)))
(defun make-X-Host ()
  (vector nil nil))
(defun X-Host-family (h)
  (aref h 0))
(defsetf X-Host-family (h) (f)
  `(aset ,h 0 ,f))
(defun X-Host-address (h)
  (aref h 1))
(defsetf X-Host-address (h) (a)
  `(aset ,h 1 ,a))

(define-X-type HOST `(struct X-Host
                             (X-Host-family . (enum 1 ,X-FamilyInternet ,X-FamilyDECnet ,X-FamilyChaos))
                             (X-Host-address . STRING8)))

(defun X-Create-Message (message-s &optional pad-notneed)
  "Takes the MESSAGE-S structure and builds a net string.
MESSAGE-S is a list of vectors and symbols which formulate the message
to be sent to the XServer.  Each vector is of this form:
  [ SIZE VALUE ]
  SIZE is the number of BYTES used by the message.
  VALUE is the lisp object whose value is to take up SIZE bytes.
  If VALUE or SIZE is a symbol or list, extract that elements value.
    If the resulting value is still a list or symbol, extract it's value
    until it is no longer a symbol or a list.
  If VALUE is a number, massage it to the correct size.
  If VALUE is a string, append that string verbatum.
  If VALUE is nil, fill it with that many NULL characters.

When PAD-NOTNEED is non-nil, then do not pad to 4 bytes."
  
  (let ((gc-cons-threshold most-positive-fixnum) ;inhibit gc'ing
	(news "")                       ; resulting message
        (padlen 0)                      ; resulting message padlen (if needed)
        (tlen nil)
	(ttype nil)
	(tval nil))
    (while message-s
      (if (= (length (car message-s)) 2)
          (setq tlen 1
                ttype (aref (car message-s) 0)
                tval (aref (car message-s) 1))
        (setq tlen (aref (car message-s) 0)
              ttype (aref (car message-s) 1)
              tval (aref (car message-s) 2)))

      ;; Check for symbols, or symbols containing symbols.
      (while (and (not (null tval))	; nil symbol allowed
		  (not (eq tval t))	; t symbol allowed
		  (or (listp tval) (symbolp tval)))
	(setq tval (eval tval)))

      (while (> tlen 0)
        (cond ((eq tval nil)
               (setq tval (make-string tlen ?\x00)))
              ((eq tval t)
               (setq tval (concat (make-string (- tlen 1) ?\x00) (make-string 1 ?\x01))))
              (t (setq tval (X-type-pack nil ttype tval))))
        (setq news (concat news tval))
        (decf tlen))
      (setq message-s (cdr message-s)))

    ;; pad the message
    (if (and (not pad-notneed)
	     (/= (setq padlen (% (length news) 4)) 0))
        (concat news (make-string (- 4 padlen) ?\x00))
      news)))

(defun X-Parse-Message (dpy message-s)
  ;; TODO: write me using `X-type-extract'
  )


(provide 'xlib-xc)

;;; xlib-xc.el ends here