From fd703282d2df84ad958b1b33128156a10768e021 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 14 May 1990 14:49:20 +0000
Subject: [PATCH] Initial revision

---
 clx/CHANGES         |   51 +
 clx/README          |   48 +
 clx/attributes.lisp |  671 ++++++++
 clx/buffer.lisp     | 1535 +++++++++++++++++
 clx/bufmac.lisp     |  174 ++
 clx/clx.lisp        | 1104 +++++++++++++
 clx/defsystem.lisp  |  603 +++++++
 clx/depdefs.lisp    |  654 ++++++++
 clx/dependent.lisp  | 3064 ++++++++++++++++++++++++++++++++++
 clx/display.lisp    |  533 ++++++
 clx/doc.lisp        | 3807 +++++++++++++++++++++++++++++++++++++++++++
 clx/exclMakefile    |  133 ++
 clx/exclREADME      |   59 +
 clx/exclcmac.lisp   |  313 ++++
 clx/excldefsys.lisp |  186 +++
 clx/excldep.c       |   73 +
 clx/excldep.lisp    |  514 ++++++
 clx/fonts.lisp      |  373 +++++
 clx/gcontext.lisp   |  994 +++++++++++
 clx/generalock.lisp |   62 +
 clx/graphics.lisp   |  460 ++++++
 clx/image.lisp      | 2697 ++++++++++++++++++++++++++++++
 clx/input.lisp      | 1927 ++++++++++++++++++++++
 clx/keysyms.lisp    |  408 +++++
 clx/macros.lisp     | 1078 ++++++++++++
 clx/manager.lisp    |  851 ++++++++++
 clx/ms-patch.uu     |   57 +
 clx/provide.lisp    |   41 +
 clx/requests.lisp   | 1590 ++++++++++++++++++
 clx/resource.lisp   |  713 ++++++++
 clx/sockcl.lisp     |  163 ++
 clx/socket.c        |  144 ++
 clx/text.lisp       | 1083 ++++++++++++
 clx/translate.lisp  |  619 +++++++
 34 files changed, 26782 insertions(+)
 create mode 100644 clx/CHANGES
 create mode 100644 clx/README
 create mode 100644 clx/attributes.lisp
 create mode 100644 clx/buffer.lisp
 create mode 100644 clx/bufmac.lisp
 create mode 100644 clx/clx.lisp
 create mode 100644 clx/defsystem.lisp
 create mode 100644 clx/depdefs.lisp
 create mode 100644 clx/dependent.lisp
 create mode 100644 clx/display.lisp
 create mode 100644 clx/doc.lisp
 create mode 100644 clx/exclMakefile
 create mode 100644 clx/exclREADME
 create mode 100644 clx/exclcmac.lisp
 create mode 100644 clx/excldefsys.lisp
 create mode 100644 clx/excldep.c
 create mode 100644 clx/excldep.lisp
 create mode 100644 clx/fonts.lisp
 create mode 100644 clx/gcontext.lisp
 create mode 100644 clx/generalock.lisp
 create mode 100644 clx/graphics.lisp
 create mode 100644 clx/image.lisp
 create mode 100644 clx/input.lisp
 create mode 100644 clx/keysyms.lisp
 create mode 100644 clx/macros.lisp
 create mode 100644 clx/manager.lisp
 create mode 100644 clx/ms-patch.uu
 create mode 100644 clx/provide.lisp
 create mode 100644 clx/requests.lisp
 create mode 100644 clx/resource.lisp
 create mode 100644 clx/sockcl.lisp
 create mode 100644 clx/socket.c
 create mode 100644 clx/text.lisp
 create mode 100644 clx/translate.lisp

diff --git a/clx/CHANGES b/clx/CHANGES
new file mode 100644
index 000000000..def193673
--- /dev/null
+++ b/clx/CHANGES
@@ -0,0 +1,51 @@
+R4 changes:
+
+o Numerous bug fixes
+
+o Multiprocess locking and error reporting made more robust
+
+o Event queue consing reduced
+
+o ICCCM support
+
+R4.1 changes:
+
+o Fix reported bugs and to include the vendor-specific
+  bug-fixing and performance-improving patches that I recently received.
+
+o Code compiled with the R4 CLX will work with the R4.1X CLX, but code
+  compiled with the R4.1X CLX will NOT work with the R4 CLX.  I made an effort
+  to ensure backward binary compatibility with R4 CLX so that old code doesn't
+  have to be recompiled to still work.  It does have to be recompiled to fix
+  an event-queue bug, since the fix involved a change to the event-loop macro.
+
+R4.2 changes:
+
+o Atoms and visuals are now correctly maintained in a separate namespace from 
+  windows, pixmaps, cursors, fonts, gcontexts, and colormaps.
+
+o I have made an attempt to make socket code work for kcl and ibcl.  I have
+  akcl here, but not kcl and ibcl, so it's only guesswork that kcl and ibcl 
+  works.
+
+o compile-clx and load-clx do more pathname merging to work around problems
+  in some lisp implementations. *default-pathname-defaults* is never bound 
+  anymore.
+
+o Some ansi common lisp stuff.  If you have :ansi-common-lisp on *features*,
+  CLX will:
+
+  - Use the common-lisp package instead of the lisp package.
+
+  - Use the common lisp condition system, being careful not to stomp on 
+    define-condition and type-error.
+
+  - Use declaim instead of proclaim.
+
+  - Use the dynamic-extent declaration for rest args and closures.
+
+  - Use print-unreadable-object.
+
+o Code compiled with the R4 and R4.1 CLX will work with the R4.2 CLX, provided
+  you don't have :ansi-common-lisp on your features list.  Code compiled with 
+  the R4.2 CLX will NOT work with the R4 CLX.
diff --git a/clx/README b/clx/README
new file mode 100644
index 000000000..61696276c
--- /dev/null
+++ b/clx/README
@@ -0,0 +1,48 @@
+These files contain beta code, but they have been tested to some extent under
+Symbolics, TI, Lucid and Franz.  The files have been given .l suffixes to keep
+them within 12 characters, to keep SysV sites happy.  Please rename them with
+more appropriate suffixes for your system.
+
+
+For Franz systems, see exclREADME.
+
+
+For Symbolics systems, first rename all the .l files to .lisp.  Then edit your
+sys.translations file so that sys:x11;clx; points to this directory and put a
+clx.system file in your sys:site;directory that has the form
+
+    (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp")
+
+in it.   After that CLX can be compiled with the "Compile System CLX" command
+and loaded with the "Load System CLX" command.
+
+
+
+For TI systems, rename all the .l files to .lisp, and make a clx.translations
+file in your sys:site; directory pointing to this directory and a
+sys:site;clx.system file like the one described for symbolics systems above,
+but with the defsystem file being in the clx:clx; directory.  Then CLX can be
+compiled with (make-system "CLX" :compile :noconfirm) and loaded with
+(make-system "CLX" :noconfirm).
+
+
+
+For Lucid systems, you should rename all the .l files to .lisp too (This might
+not be possible on SysV systems).  After loading the defsystem.l file, CLX can
+be compiled with the (xlib:compile-clx) function and loaded with the
+(xlib:load-clx) form.  
+
+The ms-patch.uu file is a patch to Lucid version 2 systems.  You probably
+don't need it, as you are probably running Lucid version 3 or later, but if
+you are still using Lucid version 2, you need this patch.  You'll need to
+uudecode it to produce the binary.
+
+
+
+For kcl systems, after loading the defsystem.l file, CLX can be compiled with
+the (xlib:compile-clx) function and loaded with the (xlib:load-clx) form.
+
+
+
+For more information, see defsystem.l and provide.l.
+
diff --git a/clx/attributes.lisp b/clx/attributes.lisp
new file mode 100644
index 000000000..59be1388c
--- /dev/null
+++ b/clx/attributes.lisp
@@ -0,0 +1,671 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; Window Attributes
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;;	The special variable *window-attributes* is an alist containg:
+;;;	(drawable attributes attribute-changes geometry geometry-changes)
+;;;	Where DRAWABLE is the associated window or pixmap
+;;;	      ATTRIBUTES is NIL or a reply-buffer containing the drawable's
+;;;		         attributes for use by the accessors.
+;;;	      ATTRIBUTE-CHANGES is NIL or an array.  The first element
+;;;			 of the array is a "value-mask", indicating which
+;;;			 attributes have changed.  The other elements are
+;;;			 integers associated with the changed values, ready
+;;;			 for insertion into a server request.
+;;;	      GEOMETRY is like ATTRIBUTES, but for window geometry
+;;;	      GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
+;;;
+;;;	Attribute and Geometry accessors and SETF's look on the special variable
+;;;	*window-attributes* for the drawable.  If its not there, the accessor is
+;;;     NOT within a WITH-STATE, and a server request is made to get or put a value.
+;;;     If an entry is found in *window-attributes*, the cache buffers are used
+;;;	for the access.
+;;;
+;;;	All WITH-STATE has to do (re)bind *Window-attributes* to a list including
+;;;	the new drawable.  The caches are initialized to NIL and allocated as needed.
+
+(in-package :xlib)
+
+(export '(
+	  with-state
+	  window-visual-info
+	  window-visual
+	  window-class
+	  window-background ;; setf only
+	  window-border
+	  window-bit-gravity
+	  window-gravity
+	  window-backing-store
+	  window-backing-planes
+	  window-backing-pixel
+	  window-save-under
+	  window-override-redirect
+	  window-event-mask
+	  window-do-not-propagate-mask
+	  window-colormap
+	  window-cursor
+	  window-colormap-installed-p
+	  window-all-event-masks
+	  window-map-state
+	  
+	  drawable-root
+	  drawable-x
+	  drawable-y
+	  drawable-width
+	  drawable-height
+	  drawable-depth
+	  drawable-border-width
+
+	  window-priority
+	  ))
+
+(eval-when (compile load eval)			;needed by Franz Lisp
+(defconstant *attribute-size* 44)
+(defconstant *geometry-size* 24)
+(defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4))))
+
+(defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
+
+;; Window Attribute reply buffer resource
+(defvar *context-free-list* nil) ;; resource of free reply buffers
+
+(defun allocate-context ()
+  (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
+      (make-reply-buffer *context-size*)))
+
+(defun deallocate-context (context)
+  (declare (type reply-buffer context))
+  (threaded-atomic-push context *context-free-list* reply-next reply-buffer))
+
+(defmacro state-attributes (state) `(second ,state))
+(defmacro state-attribute-changes (state) `(third ,state))
+(defmacro state-geometry (state) `(fourth ,state))
+(defmacro state-geometry-changes (state) `(fifth ,state))
+ 
+(defmacro drawable-equal-function ()
+  (if (member 'drawable *clx-cached-types*)
+      ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
+    ''drawable-equal))
+
+(defmacro window-equal-function ()
+  (if (member 'window *clx-cached-types*)
+      ''eq
+    ''drawable-equal))
+
+(defmacro with-state ((drawable) &body body)
+  ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
+  ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
+  ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
+  ;; indefinite scope of the body, on a per-process basis in a multi-process
+  ;; environment, the first call within an Accessor Group on the specified drawable
+  ;; (the object, not just the variable) causes the complete results of the protocol
+  ;; request to be retained, and returned in any subsequent accessor calls.  Calls
+  ;; within a Setf Group are delayed, and executed in a single request on exit from
+  ;; the body.  In addition, if a call on a function within an Accessor Group follows
+  ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
+  ;; that group are executed, any retained accessor information for that group is
+  ;; discarded, the corresponding protocol request is (re)issued, and the results are
+  ;; (again) retained, and returned in any subsequent accessor calls.
+
+  ;; Accessor Group A (for GetWindowAttributes):
+  ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
+  ;; window-backing-store, window-backing-planes, window-backing-pixel,
+  ;; window-save-under, window-colormap, window-colormap-installed-p,
+  ;; window-map-state, window-all-event-masks, window-event-mask,
+  ;; window-do-not-propagate-mask, window-override-redirect
+
+  ;; Setf Group A (for ChangeWindowAttributes):
+  ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
+  ;; window-backing-pixel, window-save-under, window-event-mask,
+  ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
+  ;; window-cursor
+
+  ;; Accessor Group G (for GetGeometry):
+  ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
+  ;; drawable-height, drawable-border-width
+
+  ;; Setf Group G (for ConfigureWindow):
+  ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
+  ;; window-priority
+  (let ((state-entry (gensym)))
+     ;; alist of (drawable attributes attribute-changes geometry geometry-changes)
+    `(with-stack-list (,state-entry ,drawable nil nil nil nil)
+       (with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
+	 (multiple-value-prog1
+	   (progn ,@body)
+	   (cleanup-state-entry ,state-entry))))))
+
+(defun cleanup-state-entry (state)
+  ;; Return buffers to the free-list
+  (let ((entry (state-attributes state)))
+    (when entry (deallocate-context entry)))
+  (let ((entry (state-attribute-changes state)))
+    (when entry
+      (put-window-attribute-changes (car state) entry)
+      (deallocate-gcontext-state entry)))
+  (let ((entry (state-geometry state)))
+    (when entry (deallocate-context entry)))
+  (let ((entry (state-geometry-changes state)))
+    (when entry
+      (put-drawable-geometry-changes (car state) entry)
+      (deallocate-gcontext-state entry))))
+
+
+
+(defun change-window-attribute (window number value)
+  ;; Called from window attribute SETF's to alter an attribute value
+  ;; number is the change-attributes request mask bit number
+  (declare (type window window)
+	   (type card8 number)
+	   (type card32 value))
+  (let ((state-entry nil)
+	(changes nil))
+    (if (and *window-attributes*
+	     (setq state-entry (assoc window (the list *window-attributes*)
+				      :test (window-equal-function))))
+	(progn					; Within a WITH-STATE - cache changes
+	  (setq changes (state-attribute-changes state-entry))
+	  (unless changes
+	    (setq changes (allocate-gcontext-state))
+	    (setf (state-attribute-changes state-entry) changes)
+	    (setf (aref changes 0) 0)) ;; Initialize mask to zero
+	  (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
+	  (setf (aref changes (1+ number)) value))	;; save value
+						; Send change to the server
+      (with-buffer-request ((window-display window) *x-changewindowattributes*)
+	(window window)
+	(card32 (ash 1 number) value)))))
+;;
+;; These two are twins (change-window-attribute change-drawable-geometry)
+;; If you change one, you probably need to change the other...
+;;
+(defun change-drawable-geometry (drawable number value)
+  ;; Called from drawable geometry SETF's to alter an attribute value
+  ;; number is the change-attributes request mask bit number
+  (declare (type drawable drawable)
+	   (type card8 number)
+	   (type card29 value))
+  (let ((state-entry nil)
+	(changes nil))
+    (if (and *window-attributes*
+	     (setq state-entry (assoc drawable (the list *window-attributes*)
+				      :test (drawable-equal-function))))
+	(progn					; Within a WITH-STATE - cache changes
+	  (setq changes (state-geometry-changes state-entry))
+	  (unless changes
+	    (setq changes (allocate-gcontext-state))
+	    (setf (state-geometry-changes state-entry) changes)
+	    (setf (aref changes 0) 0)) ;; Initialize mask to zero
+	  (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
+	  (setf (aref changes (1+ number)) value))	;; save value
+						; Send change to the server
+      (with-buffer-request ((drawable-display drawable) *x-configurewindow*)
+	(drawable drawable)
+	(card16 (ash 1 number))
+	(card29 value)))))
+
+(defun get-window-attributes-buffer (window)
+  (declare (type window window))
+  (let ((state-entry nil)
+	(changes nil))
+    (or (and *window-attributes*
+	     (setq state-entry (assoc window (the list *window-attributes*)
+				      :test (window-equal-function)))
+	     (null (setq changes (state-attribute-changes state-entry)))
+	     (state-attributes state-entry))
+	(let ((display (window-display window)))
+	  (with-display (display)
+	    ;; When SETF's have been done, flush changes to the server
+	    (when changes
+	      (put-window-attribute-changes window changes)
+	      (deallocate-gcontext-state (state-attribute-changes state-entry))
+	      (setf (state-attribute-changes state-entry) nil))
+	    ;; Get window attributes
+	    (with-buffer-request-and-reply (display *x-getwindowattributes* size :sizes (8))
+		 ((window window))
+	      (let ((repbuf (or (state-attributes state-entry) (allocate-context))))
+		(declare (type reply-buffer repbuf))
+		;; Copy into repbuf from reply buffer
+		(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
+		(when state-entry (setf (state-attributes state-entry) repbuf))
+		repbuf)))))))
+
+;;
+;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
+;; If you change one, you probably need to change the other...
+;;
+(defun get-drawable-geometry-buffer (drawable)
+  (declare (type drawable drawable))
+  (let ((state-entry nil)
+	(changes nil))
+    (or (and *window-attributes*
+	     (setq state-entry (assoc drawable (the list *window-attributes*)
+				      :test (drawable-equal-function)))
+	     (null (setq changes (state-geometry-changes state-entry)))
+	     (state-geometry state-entry))
+	(let ((display (drawable-display drawable)))
+	  (with-display (display)
+	    ;; When SETF's have been done, flush changes to the server
+	    (when changes
+	      (put-drawable-geometry-changes drawable changes)
+	      (deallocate-gcontext-state (state-geometry-changes state-entry))
+	      (setf (state-geometry-changes state-entry) nil))
+	    ;; Get drawable attributes
+	    (with-buffer-request-and-reply (display *x-getgeometry* size :sizes (8))
+		 ((drawable drawable))
+	      (let ((repbuf (or (state-geometry state-entry) (allocate-context))))
+		(declare (type reply-buffer repbuf))
+		;; Copy into repbuf from reply buffer
+		(buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
+		(when state-entry (setf (state-geometry state-entry) repbuf))
+		repbuf)))))))
+
+(defun put-window-attribute-changes (window changes)
+  ;; change window attributes
+  ;; Always from Called within a WITH-DISPLAY
+  (declare (type window window)
+	   (type gcontext-state changes))
+  (let* ((display (window-display window))
+	 (mask (aref changes 0)))
+    (declare (type display display)
+	     (type mask32 mask))
+    (with-buffer-request (display *x-changewindowattributes*)
+      (window window)
+      (card32 mask)
+      (progn ;; Insert a word in the request for each one bit in the mask
+	(do ((bits mask (ash bits -1))
+	     (request-size 2)			;Word count
+	     (i 1 (index+ i 1)))		;Entry count
+	    ((zerop bits)
+	     (card16-put 2 (index-incf request-size))
+	     (index-incf (buffer-boffset display) (index* request-size 4)))
+	  (declare (type mask32 bits)
+		   (type array-index i request-size))
+	  (when (oddp bits)
+	    (card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
+;;
+;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
+;; If you change one, you probably need to change the other...
+;;
+(defun put-drawable-geometry-changes (window changes)
+  ;; change window attributes or geometry (depending on request-number...)
+  ;; Always from Called within a WITH-DISPLAY
+  (declare (type window window)
+	   (type gcontext-state changes))
+  (let* ((display (window-display window))
+	 (mask (aref changes 0)))
+    (declare (type display display)
+	     (type mask16 mask))
+    (with-buffer-request (display *x-configurewindow*)
+      (window window)
+      (card16 mask)
+      (progn ;; Insert a word in the request for each one bit in the mask
+	(do ((bits mask (ash bits -1))
+	     (request-size 2)			;Word count
+	     (i 1 (index+ i 1)))		;Entry count
+	    ((zerop bits)
+	     (card16-put 2 (incf request-size))
+	     (index-incf (buffer-boffset display) (* request-size 4)))
+	  (declare (type mask16 bits)
+		   (type fixnum request-size)
+		   (type array-index i))
+	  (when (oddp bits)
+	    (card29-put (* (incf request-size) 4) (aref changes i))))))))
+
+(defmacro with-attributes ((window &rest options) &body body)
+  `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
+     (declare (type reply-buffer .with-attributes-reply-buffer.))
+     (prog1 
+       (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
+       (unless *window-attributes*
+	 (deallocate-context .with-attributes-reply-buffer.)))))
+;;
+;; These two are twins (with-attributes with-geometry)
+;; If you change one, you probably need to change the other...
+;;
+(defmacro with-geometry ((window &rest options) &body body)
+  `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
+     (declare (type reply-buffer .with-geometry-reply-buffer.))
+     (prog1 
+       (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
+       (unless *window-attributes*
+	 (deallocate-context .with-geometry-reply-buffer.)))))
+
+;;;-----------------------------------------------------------------------------
+;;; Group A: (for GetWindowAttributes)
+;;;-----------------------------------------------------------------------------
+
+(defun window-visual (window)
+  (declare (type window window))
+  (declare (values resource-id))
+  (with-attributes (window :sizes 32)
+    (resource-id-get 8)))
+
+(defun window-visual-info (window)
+  (declare (type window window))
+  (declare (values visual-info))
+  (with-attributes (window :sizes 32)
+    (visual-info (window-display window) (resource-id-get 8))))
+
+(defun window-class (window)
+  (declare (type window window))
+  (declare (values (member :input-output :input-only)))
+  (with-attributes (window :sizes 16)
+    (member16-get 12 :copy :input-output :input-only)))
+
+(defun set-window-background (window background)
+  (declare (type window window)
+	   (type (or (member :none :parent-relative) pixel pixmap) background))
+  (cond ((eq background :none) (change-window-attribute window 0 0))
+	((eq background :parent-relative) (change-window-attribute window 0 1))
+	((integerp background) ;; Background pixel
+	 (change-window-attribute window 0 0) ;; pixmap :NONE
+	 (change-window-attribute window 1 background))
+	((type? background 'pixmap) ;; Background pixmap
+	 (change-window-attribute window 0 (pixmap-id background)))
+	(t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
+  background)
+
+#+Genera (eval-when (compile) (compiler:function-defined 'window-background))
+
+(defsetf window-background set-window-background)
+
+(defun set-window-border (window border)
+  (declare (type window window)
+	   (type (or (member :copy) pixel pixmap) border))
+  (cond ((eq border :copy) (change-window-attribute window 2 0))
+	((type? border 'pixmap) ;; Border pixmap
+	 (change-window-attribute window 2 (pixmap-id border)))
+	((integerp border) ;; Border pixel
+	 (change-window-attribute window 3 border))
+	(t (x-type-error border '(or (member :copy) integer pixmap))))
+  border)
+
+#+Genera (eval-when (compile) (compiler:function-defined 'window-border))
+
+(defsetf window-border set-window-border)
+
+(defun window-bit-gravity (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values bit-gravity))
+  (with-attributes (window :sizes 8)
+    (member8-vector-get 14 *bit-gravity-vector*)))
+
+(defun set-window-bit-gravity (window gravity)
+  (change-window-attribute
+    window 4 (encode-type (member-vector *bit-gravity-vector*) gravity))
+  gravity)
+
+(defsetf window-bit-gravity set-window-bit-gravity)
+
+(defun window-gravity (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values win-gravity))
+  (with-attributes (window :sizes 8)
+    (member8-vector-get 15 *win-gravity-vector*)))
+
+(defun set-window-gravity (window gravity)
+  (change-window-attribute
+    window 5 (encode-type (member-vector *win-gravity-vector*) gravity))
+  gravity)
+
+(defsetf window-gravity set-window-gravity)
+
+(defun window-backing-store (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values (member :not-useful :when-mapped :always)))
+  (with-attributes (window :sizes 8)
+    (member8-get 1 :not-useful :when-mapped :always)))
+
+(defun set-window-backing-store (window when)
+  (change-window-attribute
+    window 6 (encode-type (member :not-useful :when-mapped :always) when))
+  when)
+
+(defsetf window-backing-store set-window-backing-store)
+
+(defun window-backing-planes (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values pixel))
+  (with-attributes (window :sizes 32)
+    (card32-get 16)))
+
+(defun set-window-backing-planes (window planes)
+  (change-window-attribute window 7 (encode-type card32 planes))
+  planes)
+
+(defsetf window-backing-planes set-window-backing-planes)
+
+(defun window-backing-pixel (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values pixel))
+  (with-attributes (window :sizes 32)
+    (card32-get 20)))
+
+(defun set-window-backing-pixel (window pixel)
+  (change-window-attribute window 8 (encode-type card32 pixel))
+  pixel)
+
+(defsetf window-backing-pixel set-window-backing-pixel)
+
+(defun window-save-under (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values (member :off :on)))
+  (with-attributes (window :sizes 8)
+    (member8-get 24 :off :on)))
+
+(defun set-window-save-under (window when)
+  (change-window-attribute window 10 (encode-type (member :off :on) when))
+  when)
+
+(defsetf window-save-under set-window-save-under)
+
+(defun window-override-redirect (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values (member :off :on)))
+  (with-attributes (window :sizes 8)
+    (member8-get 27 :off :on)))
+
+(defun set-window-override-redirect (window when)
+  (change-window-attribute window 9 (encode-type (member :off :on) when))
+  when)
+
+(defsetf window-override-redirect set-window-override-redirect)
+
+(defun window-event-mask (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values mask32))
+  (with-attributes (window :sizes 32)
+    (card32-get 36)))
+
+(defsetf window-event-mask (window) (event-mask)
+  (let ((em (gensym)))
+    `(let ((,em ,event-mask))
+       (declare (type event-mask ,em))
+       (change-window-attribute ,window 11 (encode-event-mask ,em))
+       ,em)))
+
+(defun window-do-not-propagate-mask (window)
+  ;; setf'able
+  (declare (type window window))
+  (declare (values mask32))
+  (with-attributes (window :sizes 32)
+    (card32-get 40)))
+
+(defsetf window-do-not-propagate-mask (window) (device-event-mask)
+  (let ((em (gensym)))
+    `(let ((,em ,device-event-mask))
+       (declare (type device-event-mask ,em))
+       (change-window-attribute ,window 12 (encode-device-event-mask ,em))
+       ,em)))
+
+(defun window-colormap (window)
+  (declare (type window window))
+  (declare (values (or null colormap)))
+  (with-attributes (window :sizes 32)
+    (let ((id (resource-id-get 28)))
+      (if (zerop id) nil
+	(lookup-colormap (window-display window) id)))))
+
+(defun set-window-colormap (window colormap)
+  (change-window-attribute
+    window 13 (encode-type (or (member :copy) colormap) colormap))
+  colormap)
+
+(defsetf window-colormap set-window-colormap)
+
+(defun window-cursor (window)
+  (declare (type window window))
+  (declare (values cursor))
+  window
+  (error "~S can only be set" 'window-cursor))
+
+(defun set-window-cursor (window cursor)
+  (change-window-attribute
+    window 14 (encode-type (or (member :none) cursor) cursor))
+  cursor)
+
+(defsetf window-cursor set-window-cursor)
+
+(defun window-colormap-installed-p (window)
+  (declare (type window window))
+  (declare (values boolean))
+  (with-attributes (window :sizes 8)
+    (boolean-get 25)))
+
+(defun window-all-event-masks (window)
+  (declare (type window window))
+  (declare (values mask32))
+  (with-attributes (window :sizes 32)
+    (card32-get 32)))
+
+(defun window-map-state (window)
+  (declare (type window window))
+  (declare (values (member :unmapped :unviewable :viewable)))
+  (with-attributes (window :sizes 8)
+    (member8-get 26 :unmapped :unviewable :viewable)))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Group G: (for GetGeometry)
+;;;-----------------------------------------------------------------------------
+
+(defun drawable-root (drawable)
+  (declare (type drawable drawable))
+  (declare (values window))
+  (with-geometry (drawable :sizes 32)
+    (window-get 8 (drawable-display drawable))))
+
+(defun drawable-x (drawable)
+  ;; setf'able
+  (declare (type drawable drawable))
+  (declare (values int16))
+  (with-geometry (drawable :sizes 16)
+    (int16-get 12)))
+
+(defun set-drawable-x (drawable x)
+  (change-drawable-geometry drawable 0 (encode-type int16 x))
+  x)
+
+(defsetf drawable-x set-drawable-x)
+
+(defun drawable-y (drawable)
+  ;; setf'able
+  (declare (type drawable drawable))
+  (declare (values int16))
+  (with-geometry (drawable :sizes 16)
+    (int16-get 14)))
+
+(defun set-drawable-y (drawable y)
+  (change-drawable-geometry drawable 1 (encode-type int16 y))
+  y)
+
+(defsetf drawable-y set-drawable-y)
+
+(defun drawable-width (drawable)
+  ;; setf'able
+  ;; Inside width, excluding border.
+  (declare (type drawable drawable))
+  (declare (values card16))
+  (with-geometry (drawable :sizes 16)
+    (card16-get 16)))
+
+(defun set-drawable-width (drawable width)
+  (change-drawable-geometry drawable 2 (encode-type card16 width))
+  width)
+
+(defsetf drawable-width set-drawable-width)
+
+(defun drawable-height (drawable)
+  ;; setf'able
+  ;; Inside height, excluding border.
+  (declare (type drawable drawable))
+  (declare (values card16))
+  (with-geometry (drawable :sizes 16)
+    (card16-get 18)))
+
+(defun set-drawable-height (drawable height)
+  (change-drawable-geometry drawable 3 (encode-type card16 height))
+  height)
+
+(defsetf drawable-height set-drawable-height)
+
+(defun drawable-depth (drawable)
+  (declare (type drawable drawable))
+  (declare (values card8))
+  (with-geometry (drawable :sizes 8)
+    (card8-get 1)))
+
+(defun drawable-border-width (drawable)
+  ;; setf'able
+  (declare (type drawable drawable))
+  (declare (values integer))
+  (with-geometry (drawable :sizes 16)
+    (card16-get 20)))
+
+(defun set-drawable-border-width (drawable width)
+  (change-drawable-geometry drawable 4 (encode-type card16 width))
+  width)
+
+(defsetf drawable-border-width set-drawable-border-width)
+
+(defun set-window-priority (mode window sibling)
+  (declare (type (member :above :below :top-if :bottom-if :opposite) mode)
+	   (type window window)
+	   (type (or null window) sibling))
+  (with-state (window)
+    (change-drawable-geometry
+      window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
+    (when sibling
+      (change-drawable-geometry window 5 (encode-type window sibling))))
+  mode)
+
+#+Genera (eval-when (compile) (compiler:function-defined 'window-priority))
+
+(defsetf window-priority (window &optional sibling) (mode)
+  ;; A bit strange, but retains setf form.
+  `(set-window-priority ,mode ,window ,sibling))
diff --git a/clx/buffer.lisp b/clx/buffer.lisp
new file mode 100644
index 000000000..f77b310ad
--- /dev/null
+++ b/clx/buffer.lisp
@@ -0,0 +1,1535 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains definitions for the BUFFER object for Common-Lisp X
+;;; windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;; A few notes:
+;;
+;;  1. The BUFFER implements a two-way buffered byte / half-word
+;;     / word stream.  Hooks are left for implementing this with a
+;;     shared memory buffer, or with effenciency hooks to the network
+;;     code.
+;;
+;;  2. The BUFFER object uses overlapping displaced arrays for
+;;     inserting and removing bytes half-words and words.
+;;
+;;  3. The BYTE component of these arrays is written to a STREAM
+;;     associated with the BUFFER.  The stream has its own buffer.
+;;     This may be made more efficient by using the Zetalisp
+;;     :Send-Output-Buffer operation.
+;;
+;;  4. The BUFFER object is INCLUDED in the DISPLAY object.
+;;     This was done to reduce access time when sending requests,
+;;     while maintaing some code modularity.
+;;     Several buffer functions are duplicated (with-buffer,
+;;     buffer-force-output, close-buffer) to keep the naming
+;;     conventions consistent.
+;;
+;;  5. A nother layer of software is built on top of this for generating
+;;     both client and server interface routines, given a specification
+;;     of the protocol. (see the INTERFACE file)
+;;
+;;  6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
+;;     a point after a complete request.  This is to ensure that a partial
+;;     request won't be left after aborts (e.g. control-abort on a lispm).
+
+(in-package :xlib)
+
+(defconstant *requestsize* 160) ;; Max request size (excluding variable length requests)
+
+;;; This is here instead of in bufmac so that with-display can be
+;;; compiled without macros and bufmac being loaded.
+
+(defmacro with-buffer ((buffer &key timeout inline)
+		       &body body &environment env)
+  ;; This macro is for use in a multi-process environment.  It provides
+  ;; exclusive access to the local buffer object for request generation and
+  ;; reply processing.
+  `(macrolet ((with-buffer ((buffer &key timeout) &body body)
+		;; Speedup hack for lexically nested with-buffers
+		`(progn
+		   (progn ,buffer ,@(and timeout `(,timeout)) nil)
+		   ,@body)))
+     ,(if (and (null inline) (macroexpand '(use-closures) env))
+	  `(flet ((.with-buffer-body. () ,@body))
+	     #+ansi-common-lisp
+	     (declare (dynamic-extent #'.with-buffer-body.))
+	     (with-buffer-function ,buffer ,timeout #'.with-buffer-body.))
+	(let ((buf (if (or (symbolp buffer) (constantp buffer))
+		       buffer
+		     '.buffer.)))
+	  `(let (,@(unless (eq buf buffer) `((,buf ,buffer))))
+	     ,@(unless (eq buf buffer) `((declare (type buffer ,buf))))
+	     ,(declare-bufmac)
+	     (when (buffer-dead ,buf)
+	       (x-error 'closed-display :display ,buf))
+	     (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock"
+			    ,@(and timeout `(:timeout ,timeout)))
+	       ,@body))))))
+
+(defun with-buffer-function (buffer timeout function)
+  (declare (type display buffer)
+	   (type (or null number) timeout)
+	   (type function function)
+	   (downward-funarg function))
+  (with-buffer (buffer :timeout timeout :inline t)
+    (funcall function)))
+
+;;; The following are here instead of in bufmac so that event-case can
+;;; be compiled without macros and bufmac being loaded.
+
+(defmacro read-card8 (byte-index)
+  `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-int8 (byte-index)
+  `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-card16 (byte-index)
+  #+clx-overlapping-arrays
+  `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
+  #-clx-overlapping-arrays
+  `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-int16 (byte-index)
+  #+clx-overlapping-arrays
+  `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
+  #-clx-overlapping-arrays
+  `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-card32 (byte-index)
+  #+clx-overlapping-arrays
+  `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-int32 (byte-index)
+  #+clx-overlapping-arrays
+  `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro read-card29 (byte-index)
+  #+clx-overlapping-arrays
+  `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro event-code (reply-buffer)
+  ;; The reply-buffer structure is used for events.
+  ;; The size slot is used for the event code.
+  `(reply-size ,reply-buffer))
+
+(defmacro reading-event ((event &rest options) &body body)
+  (declare (arglist (buffer &key sizes) &body body))
+  ;; BODY may contain calls to (READ32 &optional index) etc.
+  ;; These calls will read from the input buffer at byte
+  ;; offset INDEX.  If INDEX is not supplied, then the next
+  ;; word, half-word or byte is returned.
+  `(with-buffer-input (,event ,@options) ,@body))
+
+(defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index)
+			     &body body)
+  (unless (listp sizes) (setq sizes (list sizes)))
+  ;; 160 is a special hack for client-message-events
+  (when (set-difference sizes '(0 8 16 32 160 256))
+    (error "Illegal sizes in ~a" sizes))
+  `(let ((%reply-buffer ,reply-buffer)
+	 ,@(and display `((%buffer ,display))))
+     (declare (type reply-buffer %reply-buffer)
+	      ,@(and display '((type display %buffer))))
+     ,(declare-bufmac)
+     ,@(and display '(%buffer))
+     (let* ((buffer-boffset (the array-index ,(or index 0)))
+	    #-clx-overlapping-arrays
+	    (buffer-bbuf (reply-ibuf8 %reply-buffer))
+	    #+clx-overlapping-arrays
+	    ,@(append
+		(when (member 8 sizes)
+		  `((buffer-bbuf (reply-ibuf8 %reply-buffer))))
+		(when (or (member 16 sizes) (member 160 sizes))
+		  `((buffer-woffset (index-ash buffer-boffset -1))
+		    (buffer-wbuf (reply-ibuf16 %reply-buffer))))
+		(when (member 32 sizes)
+		  `((buffer-loffset (index-ash buffer-boffset -2))
+		    (buffer-lbuf (reply-ibuf32 %reply-buffer))))))
+       (declare (type array-index buffer-boffset))
+       #-clx-overlapping-arrays
+       (declare (type buffer-bytes buffer-bbuf)
+		(array-register buffer-bbuf))
+       #+clx-overlapping-arrays
+       ,@(append
+	   (when (member 8 sizes)
+	     '((declare (type buffer-bytes buffer-bbuf)
+			(array-register buffer-bbuf))))
+	   (when (member 16 sizes)
+	     '((declare (type array-index buffer-woffset))
+	       (declare (type buffer-words buffer-wbuf)
+			(array-register buffer-wbuf))))
+	   (when (member 32 sizes)
+	     '((declare (type array-index buffer-loffset))
+	       (declare (type buffer-longs buffer-lbuf)
+			(array-register buffer-lbuf)))))
+       buffer-boffset
+       #-clx-overlapping-arrays
+       buffer-bbuf
+       #+clx-overlapping-arrays
+       ,@(append
+	   (when (member 8  sizes) '(buffer-bbuf))
+	   (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
+	   (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
+       (macrolet ((%buffer-sizes () ',sizes))
+	 ,@body))))
+
+(defun make-buffer (output-size constructor &rest options)
+  (declare (dynamic-extent options))
+  ;; Output-Size is the output-buffer size in bytes.
+  (let ((byte-output (make-array output-size :element-type 'card8
+				 :initial-element 0)))
+    (apply constructor
+	   :size output-size
+	   :obuf8 byte-output
+	   #+clx-overlapping-arrays
+	   :obuf16
+	   #+clx-overlapping-arrays
+	   (make-array (index-ash output-size -1)
+		       :element-type 'overlap16
+		       :displaced-to byte-output)
+	   #+clx-overlapping-arrays
+	   :obuf32
+	   #+clx-overlapping-arrays
+	   (make-array (index-ash output-size -2)
+		       :element-type 'overlap32
+		       :displaced-to byte-output)
+	   options))) 
+
+(defun make-reply-buffer (size)
+  ;; Size is the buffer size in bytes
+  (let ((byte-input (make-array size :element-type 'card8
+				:initial-element 0)))
+    (make-reply-buffer-internal
+      :size size
+      :ibuf8 byte-input
+      #+clx-overlapping-arrays
+      :ibuf16
+      #+clx-overlapping-arrays
+      (make-array (index-ash size -1)
+		  :element-type 'overlap16
+		  :displaced-to byte-input)
+      #+clx-overlapping-arrays
+      :ibuf32
+      #+clx-overlapping-arrays
+      (make-array (index-ash size -2)
+		  :element-type 'overlap32
+		  :displaced-to byte-input))))
+
+(defun buffer-ensure-size (buffer size)
+  (declare (type buffer buffer)
+	   (type array-index size))
+  (when (index> size (buffer-size buffer))
+    (with-buffer (buffer)
+      (buffer-flush buffer)
+      (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size))))
+	     (new-buffer (make-array new-buffer-size :element-type 'card8
+				     :initial-element 0)))
+	(setf (buffer-obuf8 buffer) new-buffer)
+	#+clx-overlapping-arrays
+	(setf (buffer-obuf16 buffer)
+	      (make-array (index-ash new-buffer-size -1)
+			  :element-type 'overlap16
+			  :displaced-to new-buffer)
+	      (buffer-obuf32 buffer)
+	      (make-array (index-ash new-buffer-size -2)
+			  :element-type 'overlap32
+			  :displaced-to new-buffer))))))
+
+(defun buffer-pad-request (buffer pad)
+  (declare (type buffer buffer)
+	   (type array-index pad))
+  (unless (index-zerop pad)
+    (when (index> (index+ (buffer-boffset buffer) pad)
+		  (buffer-size buffer))
+      (buffer-flush buffer))
+    (incf (buffer-boffset buffer) pad)
+    (unless (index-zerop (index-mod (buffer-boffset buffer) 4))
+      (buffer-flush buffer))))
+
+(declaim (inline buffer-new-request-number))
+
+(defun buffer-new-request-number (buffer)
+  (declare (type buffer buffer))
+  (setf (buffer-request-number buffer)
+	(ldb (byte 16 0) (1+ (buffer-request-number buffer)))))
+
+(defun with-buffer-request-function (display gc-force request-function)
+  (declare (type display display)
+	   (type (or null gcontext) gc-force))
+  (declare (type function request-function)
+	   (downward-funarg request-function))
+  (with-buffer (display :inline t)
+    (multiple-value-prog1
+      (progn
+	(when gc-force (force-gcontext-changes-internal gc-force))
+	(without-aborts (funcall request-function display)))
+      (display-invoke-after-function display))))
+
+(defun with-buffer-request-function-nolock (display gc-force request-function)
+  (declare (type display display)
+	   (type (or null gcontext) gc-force))
+  (declare (type function request-function)
+	   (downward-funarg request-function))
+  (multiple-value-prog1
+    (progn
+      (when gc-force (force-gcontext-changes-internal gc-force))
+      (without-aborts (funcall request-function display)))
+    (display-invoke-after-function display)))
+
+(defstruct (pending-command (:copier nil) (:predicate nil))
+  (sequence 0 :type card16)
+  (reply-buffer nil :type (or null reply-buffer))
+  (process nil)
+  (next nil #-explorer :type #-explorer (or null pending-command)))
+
+(defun with-buffer-request-and-reply-function
+       (display multiple-reply request-function reply-function)
+  (declare (type display display)
+	   (type boolean multiple-reply))
+  (declare (type function request-function reply-function)
+	   (downward-funarg request-function reply-function))
+  (let ((pending-command nil)
+	(reply-buffer nil))
+    (declare (type (or null pending-command) pending-command)
+	     (type (or null reply-buffer) reply-buffer))
+    (unwind-protect
+	(progn 
+	  (with-buffer (display :inline t)
+	    (setq pending-command (start-pending-command display))
+	    (without-aborts (funcall request-function display))
+	    (buffer-force-output display)
+	    (display-invoke-after-function display))
+	  (cond (multiple-reply
+		 (loop
+		   (setq reply-buffer (read-reply display pending-command))
+		   (when (funcall reply-function display reply-buffer) (return nil))
+		   (deallocate-reply-buffer (shiftf reply-buffer nil))))
+		(t
+		 (setq reply-buffer (read-reply display pending-command))
+		 (funcall reply-function display reply-buffer))))
+      (when reply-buffer (deallocate-reply-buffer reply-buffer))
+      (when pending-command (stop-pending-command display pending-command)))))
+
+;;
+;; Buffer stream operations
+;;
+
+(defun buffer-write (vector buffer start end)
+  ;; Write out VECTOR from START to END into BUFFER
+  ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
+  (declare (type buffer buffer)
+	   (type array-index start end))
+  (when (buffer-dead buffer)
+    (x-error 'closed-display :display buffer))
+  (wrap-buf-output (buffer)
+    (funcall (buffer-write-function buffer) vector buffer start end))
+  nil)
+
+(defun buffer-flush (buffer)
+  ;; Write the buffer contents to the server stream - doesn't force-output the stream
+  ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
+  (declare (type buffer buffer))
+  (unless (buffer-flush-inhibit buffer)
+    (let ((boffset (buffer-boffset buffer)))
+      (declare (type array-index boffset))
+      (when (index-plusp boffset)
+	(buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
+	(setf (buffer-boffset buffer) 0)
+	(setf (buffer-last-request buffer) nil))))
+  nil)
+
+(defmacro with-buffer-flush-inhibited ((buffer) &body body)
+  (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.)))
+    `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer)))
+	    (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf)))
+       (unwind-protect
+	   (progn
+	     (setf (buffer-flush-inhibit ,buf) t)
+	     ,@body)
+	 (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.)))))
+
+(defun buffer-force-output (buffer)
+  ;; Output is normally buffered, this forces any buffered output to the server.
+  (declare (type buffer buffer))
+  (when (buffer-dead buffer)
+    (x-error 'closed-display :display buffer))
+  (buffer-flush buffer)
+  (wrap-buf-output (buffer)
+    (without-aborts
+      (funcall (buffer-force-output-function buffer) buffer)))
+  nil)
+
+(defun close-buffer (buffer &key abort)
+  ;; Close the host connection in BUFFER
+  (declare (type buffer buffer))
+  (unless (null (buffer-output-stream buffer))
+    (wrap-buf-output (buffer)
+      (funcall (buffer-close-function buffer) buffer :abort abort))
+    (setf (buffer-dead buffer) t)
+    ;; Zap pointers to the streams, to ensure they're GC'd
+    (setf (buffer-output-stream buffer) nil)
+    (setf (buffer-input-stream buffer) nil)
+    )
+  nil)
+
+(defun buffer-input  (buffer vector start end &optional timeout)
+  ;; Read into VECTOR from the buffer stream
+  ;; Timeout, when non-nil, is in seconds
+  ;; Returns non-nil if EOF encountered
+  ;; Returns :TIMEOUT when timeout exceeded
+  (declare (type buffer buffer)
+	   (type vector vector)
+	   (type array-index start end)
+	   (type (or null number) timeout))
+  (declare (values eof-p))
+  (when (buffer-dead buffer)
+    (x-error 'closed-display :display buffer))
+  (unless (= start end)
+    (let ((result
+	    (wrap-buf-input (buffer)
+	      (funcall (buffer-input-function buffer)
+		       buffer vector start end timeout))))
+      (unless (or (null result) (eq result :timeout))
+	(close-buffer buffer))
+      result)))
+
+(defun buffer-input-wait  (buffer timeout)
+  ;; Timeout, when non-nil, is in seconds
+  ;; Returns non-nil if EOF encountered
+  ;; Returns :TIMEOUT when timeout exceeded
+  (declare (type buffer buffer)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (when (buffer-dead buffer)
+    (x-error 'closed-display :display buffer))
+  (let ((result
+	  (wrap-buf-input (buffer)
+	    (funcall (buffer-input-wait-function buffer)
+		     buffer timeout))))
+    (unless (or (null result) (eq result :timeout))
+      (close-buffer buffer))
+    result))
+
+(defun buffer-listen (buffer)
+  ;; Returns T if there is input available for the buffer. This should never
+  ;; block, so it can be called from the scheduler.
+  (declare (type buffer buffer))
+  (declare (values input-available))
+  (or (not (null (buffer-dead buffer)))
+      (wrap-buf-input (buffer)
+	(funcall (buffer-listen-function buffer) buffer))))
+
+;;; Reading sequences of strings
+
+;;; a list of pascal-strings with card8 lengths, no padding in between
+;;; can't use read-sequence-char
+(defun read-sequence-string (buffer-bbuf length nitems result-type
+			     &optional (buffer-boffset 0))
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type array-index length nitems buffer-boffset))
+  length
+  (with-vector (buffer-bbuf buffer-bytes)
+    (let ((result (make-sequence result-type nitems)))
+      (do* ((index 0 (index+ index 1 string-length))
+	    (count 0 (index1+ count))
+	    (string-length 0)
+	    (string ""))
+	   ((index>= count nitems)
+	    result)
+	(declare (type array-index index count string-length)
+		 (type string string))
+	(setq string-length (read-card8 index)
+	      string (make-sequence 'string string-length))
+	(do ((i (index1+ index) (index1+ i))
+	     (j 0 (index1+ j)))
+	    ((index>= j string-length)
+	     (setf (elt result count) string))
+	  (declare (type array-index i j))
+	  (setf (aref string j) (card8->char (read-card8 i))))))))
+
+;;; Reading sequences of chars
+
+(defun read-sequence-char (reply-buffer result-type nitems &optional transform data
+			   (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (character) t)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((card8->char->transform (v)
+	       (declare (type card8 v))
+	       (funcall transform (card8->char v))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'card8->char->transform))
+	(read-sequence-card8
+	  reply-buffer result-type nitems #'card8->char->transform
+	  data start index))
+    (read-sequence-card8
+      reply-buffer result-type nitems #'card8->char
+      data start index)))
+
+;;; Reading sequences of card8's
+
+(defun read-list-card8 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (with-buffer-input (reply-buffer :sizes (8) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data)  (cdr lst))
+	  (index 0 (index+ index 1)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (read-card8 index)))))
+
+(defun read-list-card8-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (declare (type (function (card8) t) transform)
+	   (downward-funarg transform))
+  (with-buffer-input (reply-buffer :sizes (8) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data) (cdr lst))
+	  (index 0 (index+ index 1)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (funcall transform (read-card8 index))))))
+
+#-lispm
+(defun read-simple-array-card8 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card8 (*)) data))
+  (with-vector (data (simple-array card8 (*)))
+    (with-buffer-input (reply-buffer :sizes (8))
+      (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
+
+#-lispm
+(defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card8 (*)) data))
+  (declare (type (function (card8) card8) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card8 (*)))
+    (with-buffer-input (reply-buffer :sizes (8) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 1)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
+
+(defun read-vector-card8 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (8))
+      (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
+
+(defun read-vector-card8-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (declare (type (function (card8) t) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (8) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 1)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (funcall transform (read-card8 index)))))))
+
+(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data
+			    (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (card8) t)) transform)
+	   (downward-funarg transform))
+  (let ((result (or data (make-sequence result-type nitems))))
+    (typecase result
+      (list
+	(if transform 
+	    (read-list-card8-with-transform
+	      reply-buffer nitems result transform start index)
+	  (read-list-card8 reply-buffer nitems result start index)))
+      #-lispm
+      ((simple-array card8 (*))
+       (if transform 
+	   (read-simple-array-card8-with-transform
+	     reply-buffer nitems result transform start index)
+	 (read-simple-array-card8 reply-buffer nitems result start index)))
+      (t
+	(if transform 
+	    (read-vector-card8-with-transform
+	      reply-buffer nitems result transform start index)
+	  (read-vector-card8 reply-buffer nitems result start index))))
+    result))
+
+;;; For now, perhaps performance it isn't worth doing better?
+
+(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data
+			   (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (int8) t)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((card8->int8->transform (v)
+	       (declare (type card8 v))
+	       (funcall transform (card8->int8 v))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'card8->int8->transform))
+	(read-sequence-card8
+	  reply-buffer result-type nitems #'card8->int8->transform
+	  data start index))
+    (read-sequence-card8
+      reply-buffer result-type nitems #'card8->int8
+      data start index)))
+
+;;; Reading sequences of card16's
+
+(defun read-list-card16 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (with-buffer-input (reply-buffer :sizes (16) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data) (cdr lst))
+	  (index 0 (index+ index 2)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (read-card16 index)))))
+
+(defun read-list-card16-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (declare (type (function (card16) t) transform)
+	   (downward-funarg transform))
+  (with-buffer-input (reply-buffer :sizes (16) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data) (cdr lst))
+	  (index 0 (index+ index 2)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (funcall transform (read-card16 index))))))
+
+#-lispm
+(defun read-simple-array-card16 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card16 (*)) data))
+  (with-vector (data (simple-array card16 (*)))
+    (with-buffer-input (reply-buffer :sizes (16) :index index)
+      #-clx-overlapping-arrays
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 2)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (the card16 (read-card16 index))))
+      #+clx-overlapping-arrays
+      (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
+
+#-lispm
+(defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card16 (*)) data))
+  (declare (type (function (card16) card16) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card16 (*)))
+    (with-buffer-input (reply-buffer :sizes (16) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 2)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
+
+(defun read-vector-card16 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (16) :index index)
+      #-clx-overlapping-arrays
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 2)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (read-card16 index)))
+      #+clx-overlapping-arrays
+      (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
+
+(defun read-vector-card16-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (declare (type (function (card16) t) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (16) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 2)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (funcall transform (read-card16 index)))))))
+
+(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data
+			     (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (card16) t)) transform)
+	   (downward-funarg transform))
+  (let ((result (or data (make-sequence result-type nitems))))
+    (typecase result
+      (list
+	(if transform 
+	    (read-list-card16-with-transform reply-buffer nitems result transform start index)
+	  (read-list-card16 reply-buffer nitems result start index)))
+      #-lispm
+      ((simple-array card16 (*))
+       (if transform 
+	   (read-simple-array-card16-with-transform
+	     reply-buffer nitems result transform start index)
+	 (read-simple-array-card16 reply-buffer nitems result start index)))
+      (t
+	(if transform 
+	    (read-vector-card16-with-transform
+	      reply-buffer nitems result transform start index)
+	  (read-vector-card16 reply-buffer nitems result start index))))
+    result))
+  
+;;; For now, perhaps performance it isn't worth doing better?
+
+(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data
+			    (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (int16) t)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((card16->int16->transform (v)
+	       (declare (type card16 v))
+	       (funcall transform (card16->int16 v))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'card16->int16->transform))
+	(read-sequence-card16
+	  reply-buffer result-type nitems #'card16->int16->transform
+	  data start index))
+    (read-sequence-card16
+      reply-buffer result-type nitems #'card16->int16
+      data start index)))
+
+;;; Reading sequences of card32's
+
+(defun read-list-card32 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (with-buffer-input (reply-buffer :sizes (32) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data) (cdr lst))
+	  (index 0 (index+ index 4)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (read-card32 index)))))
+
+(defun read-list-card32-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type list data))
+  (declare (type (function (card32) t) transform)
+	   (downward-funarg transform))
+  (with-buffer-input (reply-buffer :sizes (32) :index index)
+    (do* ((j nitems (index- j 1))
+	  (lst (nthcdr start data) (cdr lst))
+	  (index 0 (index+ index 4)))
+	 ((index-zerop j))
+      (declare (type array-index j index)
+	       (type cons lst))
+      (setf (car lst) (funcall transform (read-card32 index))))))
+
+#-lispm
+(defun read-simple-array-card32 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card32 (*)) data))
+  (with-vector (data (simple-array card32 (*)))
+    (with-buffer-input (reply-buffer :sizes (32) :index index)
+      #-clx-overlapping-arrays
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 4)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (the card32 (read-card32 index))))
+      #+clx-overlapping-arrays
+      (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
+
+#-lispm
+(defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type (simple-array card32 (*)) data))
+  (declare (type (function (card32) card32) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card32 (*)))
+    (with-buffer-input (reply-buffer :sizes (32) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 4)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
+
+(defun read-vector-card32 (reply-buffer nitems data start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (32) :index index)
+      #-clx-overlapping-arrays
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 4)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (read-card32 index)))
+      #+clx-overlapping-arrays
+      (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
+
+(defun read-vector-card32-with-transform (reply-buffer nitems data transform start index)
+  (declare (type reply-buffer reply-buffer)
+	   (type array-index nitems start index)
+	   (type vector data))
+  (declare (type (function (card32) t) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (with-buffer-input (reply-buffer :sizes (32) :index index)
+      (do* ((j start (index+ j 1))
+	    (end (index+ start nitems))
+	    (index 0 (index+ index 4)))
+	   ((index>= j end))
+	(declare (type array-index j index))
+	(setf (aref data j) (funcall transform (read-card32 index)))))))
+
+(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data
+			     (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (card32) t)) transform)
+	   (downward-funarg transform))
+  (let ((result (or data (make-sequence result-type nitems))))
+    (typecase result
+      (list
+	(if transform 
+	    (read-list-card32-with-transform reply-buffer nitems result transform start index)
+	  (read-list-card32 reply-buffer nitems result start index)))
+      #-lispm
+      ((simple-array card32 (*))
+       (if transform 
+	   (read-simple-array-card32-with-transform
+	     reply-buffer nitems result transform start index)
+	 (read-simple-array-card32 reply-buffer nitems result start index)))
+      (t
+	(if transform 
+	    (read-vector-card32-with-transform
+	      reply-buffer nitems result transform start index)
+	  (read-vector-card32 reply-buffer nitems result start index))))
+    result))
+
+;;; For now, perhaps performance it isn't worth doing better?
+
+(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data
+			    (start 0) (index 0))
+  (declare (type reply-buffer reply-buffer)
+	   (type t result-type) ;; CL type
+	   (type array-index nitems start index)
+	   (type (or null sequence) data))
+  (declare (type (or null (function (int32) t)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((card32->int32->transform (v)
+	       (declare (type card32 v))
+	       (funcall transform (card32->int32 v))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'card32->int32->transform))
+	(read-sequence-card32
+	  reply-buffer result-type nitems #'card32->int32->transform
+	  data start index))
+    (read-sequence-card32
+      reply-buffer result-type nitems #'card32->int32
+      data start index)))
+
+;;; Writing sequences of chars
+
+(defun write-sequence-char
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) character)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((transform->char->card8 (x)
+	       (char->card8 (the character (funcall transform x)))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'transform->char->card8))
+	(write-sequence-card8
+	  buffer boffset data start end #'transform->char->card8))
+    (write-sequence-card8 buffer boffset data start end #'char->card8)))
+
+;;; Writing sequences of card8's
+
+(defun write-list-card8 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (writing-buffer-chunks card8
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    (dotimes (j chunk)
+      (declare (type array-index j))
+      #-ti (write-card8 j (pop lst))		;TI Compiler bug
+      #+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst))
+      ))
+  nil)
+
+(defun write-list-card8-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card8) transform)
+	   (downward-funarg transform))
+  (writing-buffer-chunks card8
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    (dotimes (j chunk)
+      (declare (type array-index j))
+      (write-card8 j (funcall transform (pop lst)))))
+  nil)
+
+;;; Should really write directly from data, instead of into the buffer first
+#-lispm
+(defun write-simple-array-card8 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type (simple-array card8 (*)) data)
+	   (type array-index boffset start end))
+  (with-vector (data (simple-array card8 (*)))
+    (writing-buffer-chunks card8
+			   ((index start (index+ index chunk)))
+			   ((type array-index index))
+      (buffer-replace buffer-bbuf data
+		      buffer-boffset
+		      (index+ buffer-boffset chunk)
+		      index)))
+  nil)
+
+#-lispm
+(defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type (simple-array card8 (*)) data)
+	   (type array-index boffset start end))
+  (declare (type (function (card8) card8) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card8 (*)))
+    (writing-buffer-chunks card8
+			   ((index start))
+			   ((type array-index index))
+      (dotimes (j chunk)
+	(declare (type array-index j))
+	(write-card8 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-vector-card8 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (with-vector (data vector)
+    (writing-buffer-chunks card8
+			   ((index start (index+ index chunk)))
+			   ((type array-index index))
+      (buffer-replace buffer-bbuf data
+		      buffer-boffset
+		      (index+ buffer-boffset chunk)
+		      index)))
+  nil)
+
+(defun write-vector-card8-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card8) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (writing-buffer-chunks card8
+			   ((index start))
+			   ((type array-index index))
+      (dotimes (j chunk)
+	(declare (type array-index j))
+	(write-card8 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-sequence-card8
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) card8)) transform)
+	   (downward-funarg transform))
+  (typecase data
+    (list
+      (if transform
+	  (write-list-card8-with-transform buffer boffset data start end transform)
+	  (write-list-card8 buffer boffset data start end)))
+    #-lispm
+    ((simple-array card8 (*))
+     (if transform
+	 (write-simple-array-card8-with-transform buffer boffset data start end transform)
+	 (write-simple-array-card8 buffer boffset data start end)))
+    (t
+      (if transform
+	  (write-vector-card8-with-transform buffer boffset data start end transform)
+	  (write-vector-card8 buffer boffset data start end)))))
+
+;;; For now, perhaps performance it isn't worth doing better?
+
+(defun write-sequence-int8
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) int8)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((transform->int8->card8 (x)
+	       (int8->card8 (the int8 (funcall transform x)))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'transform->int8->card8))
+	(write-sequence-card8
+	  buffer boffset data start end #'transform->int8->card8))
+      (write-sequence-card8 buffer boffset data start end #'int8->card8)))
+
+;;; Writing sequences of card16's
+
+(defun write-list-card16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (writing-buffer-chunks card16
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of card16's big
+    (do ((j 0 (index+ j 2)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-card16 j (pop lst))))
+  nil)
+
+(defun write-list-card16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card16) transform)
+	   (downward-funarg transform))
+  (writing-buffer-chunks card16
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of card16's big
+    (do ((j 0 (index+ j 2)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-card16 j (funcall transform (pop lst)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-card16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type (simple-array card16 (*)) data)
+	   (type array-index boffset start end))
+  (with-vector (data (simple-array card16 (*)))
+    (writing-buffer-chunks card16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card16 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 2)))
+	(buffer-replace buffer-wbuf data
+			buffer-woffset
+			(index+ buffer-woffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type (simple-array card16 (*)) data)
+	   (type array-index boffset start end))
+  (declare (type (function (card16) card16) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card16 (*)))
+    (writing-buffer-chunks card16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card16 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-vector-card16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (with-vector (data vector)
+    (writing-buffer-chunks card16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card16 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 2)))
+	(buffer-replace buffer-wbuf data
+			buffer-woffset
+			(index+ buffer-woffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+(defun write-vector-card16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card16) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (writing-buffer-chunks card16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card16 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-sequence-card16
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) card16)) transform)
+	   (downward-funarg transform))
+  (typecase data
+    (list
+      (if transform
+	  (write-list-card16-with-transform buffer boffset data start end transform)
+	  (write-list-card16 buffer boffset data start end)))
+    #-lispm
+    ((simple-array card16 (*))
+     (if transform
+	 (write-simple-array-card16-with-transform buffer boffset data start end transform)
+	 (write-simple-array-card16 buffer boffset data start end)))
+    (t
+      (if transform
+	  (write-vector-card16-with-transform buffer boffset data start end transform)
+	  (write-vector-card16 buffer boffset data start end)))))
+
+;;; Writing sequences of int16's
+
+(defun write-list-int16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (writing-buffer-chunks int16
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of int16's big
+    (do ((j 0 (index+ j 2)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-int16 j (pop lst))))
+  nil)
+
+(defun write-list-int16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) int16) transform)
+	   (downward-funarg transform))
+  (writing-buffer-chunks int16
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of int16's big
+    (do ((j 0 (index+ j 2)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-int16 j (funcall transform (pop lst)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-int16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type (simple-array int16 (*)) data)
+	   (type array-index boffset start end))
+  (with-vector (data (simple-array int16 (*)))
+    (writing-buffer-chunks int16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of int16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-int16 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 2)))
+	(buffer-replace buffer-wbuf data
+			buffer-woffset
+			(index+ buffer-woffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type (simple-array int16 (*)) data)
+	   (type array-index boffset start end))
+  (declare (type (function (int16) int16) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array int16 (*)))
+    (writing-buffer-chunks int16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of int16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-int16 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-vector-int16 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (with-vector (data vector)
+    (writing-buffer-chunks int16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of int16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-int16 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 2)))
+	(buffer-replace buffer-wbuf data
+			buffer-woffset
+			(index+ buffer-woffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+(defun write-vector-int16-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) int16) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (writing-buffer-chunks int16
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of int16's big
+      (do ((j 0 (index+ j 2)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-int16 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-sequence-int16
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) int16)) transform)
+	   (downward-funarg transform))
+  (typecase data
+    (list
+      (if transform
+	  (write-list-int16-with-transform buffer boffset data start end transform)
+	  (write-list-int16 buffer boffset data start end)))
+    #-lispm
+    ((simple-array int16 (*))
+     (if transform
+	 (write-simple-array-int16-with-transform buffer boffset data start end transform)
+	 (write-simple-array-int16 buffer boffset data start end)))
+    (t
+      (if transform
+	  (write-vector-int16-with-transform buffer boffset data start end transform)
+	  (write-vector-int16 buffer boffset data start end)))))
+
+;;; Writing sequences of card32's
+
+(defun write-list-card32 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (writing-buffer-chunks card32
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of card32's big
+    (do ((j 0 (index+ j 4)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-card32 j (pop lst))))
+  nil)
+
+(defun write-list-card32-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type list data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card32) transform)
+	   (downward-funarg transform))
+  (writing-buffer-chunks card32
+			 ((lst (nthcdr start data)))
+			 ((type list lst))
+    ;; Depends upon the chunks being an even multiple of card32's big
+    (do ((j 0 (index+ j 4)))
+	((index>= j chunk))
+      (declare (type array-index j))
+      (write-card32 j (funcall transform (pop lst)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-card32 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type (simple-array card32 (*)) data)
+	   (type array-index boffset start end))
+  (with-vector (data (simple-array card32 (*)))
+    (writing-buffer-chunks card32
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card32's big
+      (do ((j 0 (index+ j 4)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card32 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 4)))
+	(buffer-replace buffer-lbuf data
+			buffer-loffset
+			(index+ buffer-loffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+#-lispm
+(defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type (simple-array card32 (*)) data)
+	   (type array-index boffset start end))
+  (declare (type (function (card32) card32) transform)
+	   (downward-funarg transform))
+  (with-vector (data (simple-array card32 (*)))
+    (writing-buffer-chunks card32
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card32's big
+      (do ((j 0 (index+ j 4)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card32 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-vector-card32 (buffer boffset data start end)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (with-vector (data vector)
+    (writing-buffer-chunks card32
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card32's big
+      (do ((j 0 (index+ j 4)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card32 j (aref data index))
+	(setq index (index+ index 1)))
+      ;; overlapping case
+      (let ((length (floor chunk 4)))
+	(buffer-replace buffer-lbuf data
+			buffer-loffset
+			(index+ buffer-loffset length)
+			index)
+	(setq index (index+ index length)))))
+  nil)
+
+(defun write-vector-card32-with-transform (buffer boffset data start end transform)
+  (declare (type buffer buffer)
+	   (type vector data)
+	   (type array-index boffset start end))
+  (declare (type (function (t) card32) transform)
+	   (downward-funarg transform))
+  (with-vector (data vector)
+    (writing-buffer-chunks card32
+			   ((index start))
+			   ((type array-index index))
+      ;; Depends upon the chunks being an even multiple of card32's big
+      (do ((j 0 (index+ j 4)))
+	  ((index>= j chunk))
+	(declare (type array-index j))
+	(write-card32 j (funcall transform (aref data index)))
+	(setq index (index+ index 1)))))
+  nil)
+
+(defun write-sequence-card32
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) card32)) transform)
+	   (downward-funarg transform))
+  (typecase data
+    (list
+      (if transform
+	  (write-list-card32-with-transform buffer boffset data start end transform)
+	  (write-list-card32 buffer boffset data start end)))
+    #-lispm
+    ((simple-array card32 (*))
+     (if transform
+	 (write-simple-array-card32-with-transform buffer boffset data start end transform)
+	 (write-simple-array-card32 buffer boffset data start end)))
+    (t
+      (if transform
+	  (write-vector-card32-with-transform buffer boffset data start end transform)
+	  (write-vector-card32 buffer boffset data start end)))))
+
+;;; For now, perhaps performance it isn't worth doing better?
+
+(defun write-sequence-int32
+       (buffer boffset data &optional (start 0) (end (length data)) transform)
+  (declare (type buffer buffer)
+	   (type sequence data)
+	   (type array-index boffset start end))
+  (declare (type (or null (function (t) int32)) transform)
+	   (downward-funarg transform))
+  (if transform 
+      (flet ((transform->int32->card32 (x)
+	       (int32->card32 (the int32 (funcall transform x)))))
+	#+ansi-common-lisp
+	(declare (dynamic-extent #'transform->int32->card32))
+	(write-sequence-card32
+	  buffer boffset data start end #'transform->int32->card32))
+    (write-sequence-card32 buffer boffset data start end #'int32->card32)))
+
+(defun read-bitvector256 (buffer-bbuf boffset data)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type array-index boffset)
+	   (type (or null (simple-bit-vector 256)) data))
+  (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
+    (declare (type (simple-bit-vector 256) result)
+	     (array-register result))
+    (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
+	 (j 8 (index+ j 8)))
+	((index>= j 256))
+      (declare (type array-index i j))
+      (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
+	   (k j (index+ k 1)))
+	  ((zerop byte)
+	   (when data ;; Clear uninitialized bits in data
+	     (do ((end (index+ j 8)))
+		 ((= k end))
+	       (setf (aref result k) 0)
+	       (index-incf k))))
+	(declare (type array-index k)
+		 (type card8 byte))
+	(setf (aref result k) (the bit (logand byte 1)))))
+    result))
+
+(defun write-bitvector256 (buffer boffset map)
+  (declare (type buffer buffer)
+	   (type array-index boffset)
+	   (type (simple-array bit (*)) map))
+  (with-buffer-output (buffer :index boffset :sizes 8)
+    (do* ((i (index+ buffer-boffset 1) (index+ i 1))	; Skip first byte
+	  (j 8 (index+ j 8)))		
+	 ((index>= j 256))
+      (declare (type array-index i j))
+      (do ((byte 0)
+	   (bit (index+ j 7) (index- bit 1)))
+	  ((index< bit j)
+	   (aset-card8 byte buffer-bbuf i))
+	(declare (type array-index bit)
+		 (type card8 byte))
+	(setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp
new file mode 100644
index 000000000..bb811edf7
--- /dev/null
+++ b/clx/bufmac.lisp
@@ -0,0 +1,174 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains macro definitions for the BUFFER object for Common-Lisp
+;;; X windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them.
+
+(defmacro write-card8 (byte-index item)
+  `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro write-int8 (byte-index item)
+  `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index)))
+
+(defmacro write-card16 (byte-index item)
+  #+clx-overlapping-arrays
+  `(aset-card16 (the card16 ,item) buffer-wbuf
+		(index+ buffer-woffset (index-ash ,byte-index -1)))
+  #-clx-overlapping-arrays
+  `(aset-card16 (the card16 ,item) buffer-bbuf
+		(index+ buffer-boffset ,byte-index)))
+
+(defmacro write-int16 (byte-index item)
+  #+clx-overlapping-arrays
+  `(aset-int16 (the int16 ,item) buffer-wbuf
+	       (index+ buffer-woffset (index-ash ,byte-index -1)))
+  #-clx-overlapping-arrays
+  `(aset-int16 (the int16 ,item) buffer-bbuf
+	       (index+ buffer-boffset ,byte-index)))
+
+(defmacro write-card32 (byte-index item)
+  #+clx-overlapping-arrays
+  `(aset-card32 (the card32 ,item) buffer-lbuf
+		(index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aset-card32 (the card32 ,item) buffer-bbuf
+		(index+ buffer-boffset ,byte-index)))
+
+(defmacro write-int32 (byte-index item)
+  #+clx-overlapping-arrays
+  `(aset-int32 (the int32 ,item) buffer-lbuf
+	       (index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aset-int32 (the int32 ,item) buffer-bbuf
+	       (index+ buffer-boffset ,byte-index)))
+
+(defmacro write-card29 (byte-index item)
+  #+clx-overlapping-arrays
+  `(aset-card29 (the card29 ,item) buffer-lbuf
+		(index+ buffer-loffset (index-ash ,byte-index -2)))
+  #-clx-overlapping-arrays
+  `(aset-card29 (the card29 ,item) buffer-bbuf
+		(index+ buffer-boffset ,byte-index)))
+
+(defmacro set-buffer-offset (value &environment env)
+  env
+  `(let ((.boffset. ,value))
+     (declare (type array-index .boffset.))
+     (setq buffer-boffset .boffset.)
+     #+clx-overlapping-arrays
+     ,@(when (member 16 (macroexpand '(%buffer-sizes) env))
+	 `((setq buffer-woffset (index-ash .boffset. -1))))
+     #+clx-overlapping-arrays
+     ,@(when (member 32 (macroexpand '(%buffer-sizes) env))
+	 `((setq buffer-loffset (index-ash .boffset. -2))))
+     #+clx-overlapping-arrays
+     .boffset.))
+
+(defmacro advance-buffer-offset (value)
+  `(set-buffer-offset (index+ buffer-boffset ,value)))
+
+(defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body)
+  (unless (listp sizes) (setq sizes (list sizes)))
+  `(let ((%buffer ,buffer))
+     (declare (type display %buffer))
+     ,(declare-bufmac)
+     ,(when length
+	`(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer))
+	   (buffer-flush %buffer)))
+     (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer))))
+	    #-clx-overlapping-arrays
+	    (buffer-bbuf (buffer-obuf8 %buffer))
+	    #+clx-overlapping-arrays
+	    ,@(append
+		(when (member 8 sizes)
+		  `((buffer-bbuf (buffer-obuf8 %buffer))))
+		(when (or (member 16 sizes) (member 160 sizes))
+		  `((buffer-woffset (index-ash buffer-boffset -1))
+		    (buffer-wbuf (buffer-obuf16 %buffer))))
+		(when (member 32 sizes)
+		  `((buffer-loffset (index-ash buffer-boffset -2))
+		    (buffer-lbuf (buffer-obuf32 %buffer))))))
+       (declare (type array-index buffer-boffset))
+       #-clx-overlapping-arrays
+       (declare (type buffer-bytes buffer-bbuf)
+		(array-register buffer-bbuf))
+       #+clx-overlapping-arrays
+       ,@(append
+	   (when (member 8  sizes)
+	     '((declare (type buffer-bytes buffer-bbuf)
+			(array-register buffer-bbuf))))
+	   (when (member 16 sizes)
+	     '((declare (type array-index buffer-woffset))
+	       (declare (type buffer-words buffer-wbuf)
+			(array-register buffer-wbuf))))
+	   (when (member 32 sizes)
+	     '((declare (type array-index buffer-loffset))
+	       (declare (type buffer-longs buffer-lbuf)
+			(array-register buffer-lbuf)))))
+       buffer-boffset
+       #-clx-overlapping-arrays
+       buffer-bbuf
+       #+clx-overlapping-arrays
+       ,@(append
+	   (when (member 8  sizes) '(buffer-bbuf))
+	   (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
+	   (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
+       (macrolet ((%buffer-sizes () ',sizes))
+	 ,@body))))
+
+;;; This macro is just used internally in buffer
+
+(defmacro writing-buffer-chunks (type args decls &body body)
+  (when (> (length body) 2)
+    (error "writing-buffer-chunks called with too many forms"))
+  (let* ((size (* 8 (index-increment type)))
+	 (form #-clx-overlapping-arrays
+	       (first body)
+	       #+clx-overlapping-arrays		; XXX type dependencies
+	       (or (second body)
+		   (first body))))
+    `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8))))
+       ;; Loop filling the buffer
+       (do* (,@args
+	     ;; Number of bytes needed to output
+	     (len ,(if (= size 8)
+		       `(index- end start)
+		       `(index-ash (index- end start) ,(truncate size 16)))
+		  (index- len chunk))
+	     ;; Number of bytes available in buffer
+	     (chunk (index-min len (index- (buffer-size buffer) buffer-boffset))
+		    (index-min len (index- (buffer-size buffer) buffer-boffset))))
+	    ((not (index-plusp len)))
+	 (declare ,@decls
+		  (type array-index len chunk))
+	 ,form
+	 (index-incf buffer-boffset chunk)
+	 ;; Flush the buffer
+	 (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer)))
+	   (setf (buffer-boffset buffer) buffer-boffset)
+	   (buffer-flush buffer)
+	   (setq buffer-boffset (buffer-boffset buffer))
+	   #+clx-overlapping-arrays
+	   ,(case size
+	      (16 '(setq buffer-woffset (index-ash buffer-boffset -1)))
+	      (32 '(setq buffer-loffset (index-ash buffer-boffset -2))))))
+       (setf (buffer-boffset buffer) (lround buffer-boffset))))) 
diff --git a/clx/clx.lisp b/clx/clx.lisp
new file mode 100644
index 000000000..c560354ea
--- /dev/null
+++ b/clx/clx.lisp
@@ -0,0 +1,1104 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;; Primary Interface Author:
+;;	Robert W. Scheifler
+;;	MIT Laboratory for Computer Science
+;;	545 Technology Square, Room 418
+;;	Cambridge, MA 02139
+;;	rws@zermatt.lcs.mit.edu
+
+;; Design Contributors:
+;;	Dan Cerys, Texas Instruments
+;;	Scott Fahlman, CMU
+;;      Charles Hornig, Symbolics
+;;      John Irwin, Franz
+;;	Kerry Kimbrough, Texas Instruments
+;;	Chris Lindblad, MIT
+;;	Rob MacLachlan, CMU
+;;	Mike McMahon, Symbolics
+;;	David Moon, Symbolics
+;;	LaMott Oren, Texas Instruments
+;;	Daniel Weinreb, Symbolics
+;;	John Wroclawski, MIT
+;;	Richard Zippel, Symbolics
+
+;; Primary Implementation Author:
+;;	LaMott Oren, Texas Instruments
+
+;; Implementation Contributors:
+;;      Charles Hornig, Symbolics
+;;      John Irwin, Franz
+;;	Chris Lindblad, MIT
+;;	Robert Scheifler, MIT
+
+;;;
+;;; Change history:
+;;;
+;;;  Date	Author		Description
+;;; -------------------------------------------------------------------------------------
+;;; 04/07/87	R.Scheifler	Created code stubs
+;;; 04/08/87	L.Oren		Started Implementation
+;;; 05/11/87	L.Oren		Included draft 3 revisions
+;;; 07/07/87	L.Oren		Untested alpha release to MIT
+;;; 07/17/87	L.Oren		Alpha release
+;;; 08/**/87	C.Lindblad	Rewrite of buffer code
+;;; 08/**/87	et al		Various random bug fixes
+;;; 08/**/87	R.Scheifler	General syntactic and portability cleanups
+;;; 08/**/87	R.Scheifler	Rewrite of gcontext caching and shadowing
+;;; 09/02/87	L.Oren		Change events from resource-ids to objects
+;;; 12/24/87	R.Budzianowski	KCL support
+;;; 12/**/87	J.Irwin		ExCL 2.0 support
+;;; 01/20/88	L.Oren		Add server extension mechanisms
+;;; 01/20/88	L.Oren		Only force output when blocking on input
+;;; 01/20/88	L.Oren		Uniform support for :event-window on events
+;;; 01/28/88	L.Oren		Add window manager property functions
+;;; 01/28/88	L.Oren		Add character translation facility
+;;; 02/**/87	J.Irwin		Allegro 2.2 support
+
+;;; This is considered a somewhat changeable interface.  Discussion of better
+;;; integration with CLOS, support for user-specified subclassess of basic
+;;; objects, and the additional functionality to match the C Xlib is still in
+;;; progress.  Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
+
+;; Note: all of the following is in the package XLIB.
+
+(in-package :xlib)
+
+(export '(
+	  *version*
+	  card32
+	  card29
+	  int32
+	  card16
+	  int16
+	  card8
+	  int8
+	  rgb-val
+	  angle
+	  mask32
+	  mask16
+	  array-index
+	  pixel
+	  image-depth
+	  display
+	  display-p
+	  display-host
+	  display-display
+	  display-after-function
+	  display-protocol-major-version
+	  display-protocol-minor-version
+	  display-vendor-name
+	  display-resource-id-base
+	  display-resource-id-mask
+	  display-xid
+	  display-byte-order
+	  display-release-number
+	  display-max-request-length
+	  display-default-screen
+	  display-nscreens
+	  display-roots
+	  display-motion-buffer-size
+	  display-xdefaults
+	  display-image-lsb-first-p
+	  display-bitmap-format
+	  display-pixmap-formats
+	  display-min-keycode
+	  display-max-keycode
+	  display-error-handler
+	  display-authorization-name
+	  display-authorization-data
+	  display-plist
+	  display-report-asynchronous-errors
+	  color
+	  color-p
+	  color-red
+	  color-green
+	  color-blue
+	  make-color
+	  color-rgb
+	  resource-id
+	  drawable
+	  drawable-p
+	  drawable-equal
+	  drawable-id
+	  drawable-display
+	  drawable-plist
+	  window
+	  window-p
+	  window-equal
+	  window-id
+	  window-display
+	  window-plist
+	  pixmap
+	  pixmap-p
+	  pixmap-equal
+	  pixmap-id
+	  pixmap-display
+	  pixmap-plist
+	  colormap
+	  colormap-p
+	  colormap-equal
+	  colormap-id
+	  colormap-display
+	  colormap-visual-info
+	  cursor
+	  cursor-p
+	  cursor-equal
+	  cursor-id
+	  cursor-display
+	  xatom
+	  stringable
+	  fontable
+	  timestamp
+	  bit-gravity
+	  win-gravity
+	  grab-status
+	  boolean
+	  alist
+	  repeat-seq
+	  point-seq
+	  seg-seq
+	  rect-seq
+	  arc-seq
+	  gcontext
+	  gcontext-p
+	  gcontext-equal
+	  gcontext-id
+	  gcontext-display
+	  gcontext-plist
+	  event-mask-class
+	  event-mask
+	  pointer-event-mask-class
+	  pointer-event-mask
+	  device-event-mask-class
+	  device-event-mask
+	  modifier-key
+	  modifier-mask
+	  state-mask-key
+	  gcontext-key
+	  event-key
+	  error-key
+	  draw-direction
+	  boole-constant
+	  bitmap-format
+	  bitmap-format-p
+	  bitmap-format-unit
+	  bitmap-format-pad
+	  bitmap-format-lsb-first-p
+	  pixmap-format
+	  pixmap-format-p
+	  pixmap-format-depth
+	  pixmap-format-bits-per-pixel
+	  pixmap-format-scanline-pad
+	  visual-info
+	  visual-info-p
+	  visual-info-id
+	  visual-info-display
+	  visual-info-class
+	  visual-info-red-mask
+	  visual-info-green-mask
+	  visual-info-blue-mask
+	  visual-info-bits-per-rgb
+	  visual-info-colormap-entries
+	  visual-info-plist
+	  screen
+	  screen-p
+	  screen-root
+	  screen-width
+	  screen-height
+	  screen-width-in-millimeters
+	  screen-height-in-millimeters
+	  screen-depths
+	  screen-root-depth
+	  screen-root-visual-info
+	  screen-root-visual
+	  screen-default-colormap
+	  screen-white-pixel
+	  screen-black-pixel
+	  screen-min-installed-maps
+	  screen-max-installed-maps
+	  screen-backing-stores
+	  screen-save-unders-p
+	  screen-event-mask-at-open
+	  screen-plist
+	  font
+	  font-p
+	  font-equal
+	  font-id
+	  font-display
+	  font-name
+	  font-direction
+	  font-min-char
+	  font-max-char
+	  font-min-byte1
+	  font-max-byte1
+	  font-min-byte2
+	  font-max-byte2
+	  font-all-chars-exist-p
+	  font-default-char
+	  font-ascent
+	  font-descent
+	  font-properties
+	  font-property
+	  font-plist
+	  char-left-bearing
+	  max-char-left-bearing
+	  min-char-left-bearing
+	  char-right-bearing
+	  max-char-right-bearing
+	  min-char-right-bearing
+	  char-width
+	  max-char-width
+	  min-char-width
+	  char-ascent
+	  max-char-ascent
+	  min-char-ascent
+	  char-descent
+	  max-char-descent
+	  min-char-descent
+	  char-attributes
+	  max-char-attributes
+	  min-char-attributes
+	  make-event-mask
+	  make-event-keys
+	  make-state-mask
+	  make-state-keys
+	  ))
+
+(pushnew :clx *features*)
+(pushnew :xlib *features*)
+
+(defparameter *version* "MIT R4.2")
+(pushnew :clx-mit-r4 *features*)
+
+(defparameter *protocol-major-version* 11.)
+(defparameter *protocol-minor-version* 0)
+
+(defparameter *x-tcp-port* 6000) ;; add display number
+
+; Note: various perversions of the CL type system are used below.
+; Examples: (list elt-type) (sequence elt-type)
+
+;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
+;; the relationships should be fairly obvious.  We have no intention of writing yet
+;; another moby document for this interface.
+
+;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
+;; These types are defined solely by a functional interface; we do not specify
+;; whether they are implemented as structures or flavors or ...  Although functions
+;; below are written using DEFUN, this is not an implementation requirement (although
+;; it is a requirement that they be functions as opposed to macros or special forms).
+;; It is unclear whether with-slots in the Common Lisp Object System must work on
+;; them.
+
+;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
+;; compound objects, rather than as integer resource-ids.  This allows applications
+;; to deal with multiple displays without having an explicit display argument in the
+;; most common functions.  Every function uses the display object indicated by the
+;; first argument that is or contains a display; it is an error if arguments contain
+;; different displays, and predictable results are not guaranteed.
+
+;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
+;; five functions:
+
+;(defun make-<mumble> (display resource-id)
+;  ;; This function should almost never be called by applications, except in handling
+;  ;; events.  To minimize consing in some implementations, this may use a cache in
+;  ;; the display.  Make-gcontext creates with :cache-p nil.  Make-font creates with
+;  ;; cache-p true.
+;  (declare (type display display)
+;	   (type integer resource-id)
+;	   (values <mumble>)))
+
+;(defun <mumble>-display (<mumble>)
+;  (declare (type <mumble> <mumble>)
+;	   (values display)))
+
+;(defun <mumble>-id (<mumble>)
+;  (declare (type <mumble> <mumble>)
+;	   (values integer)))
+
+;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
+;  (declare (type <mumble> <mumble>-1 <mumble>-2)))
+
+;(defun <mumble>-p (<mumble>-1 <mumble>-2)
+;  (declare (type <mumble> <mumble>-1 <mumble>-2)
+;	   (values boolean)))
+
+(deftype boolean () '(or null (not null)))
+
+(deftype card32 () '(unsigned-byte 32))
+
+(deftype card29 () '(unsigned-byte 29))
+
+(deftype card24 () '(unsigned-byte 24))
+
+(deftype int32 () '(signed-byte 32))
+
+(deftype card16 () '(unsigned-byte 16))
+
+(deftype int16 () '(signed-byte 16))
+
+(deftype card8 () '(unsigned-byte 8))
+
+(deftype int8 () '(signed-byte 8))
+
+(deftype card4 () '(unsigned-byte 4))
+
+(deftype real (&optional (min '*) (max '*))
+  (labels ((convert (limit floatp)
+	     (typecase limit
+	       (number (if floatp (float limit 0s0) (rational limit)))
+	       (list (map 'list #'convert limit))
+	       (otherwise limit))))
+    `(or (float ,(convert min t) ,(convert max t))
+	 (rational ,(convert min nil) ,(convert max nil)))))
+
+; Note that we are explicitly using a different rgb representation than what
+; is actually transmitted in the protocol.
+
+(deftype rgb-val () '(real 0 1))
+
+; Note that we are explicitly using a different angle representation than what
+; is actually transmitted in the protocol.
+
+(deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
+
+(deftype mask32 () 'card32)
+
+(deftype mask16 () 'card16)
+
+(deftype pixel () '(unsigned-byte 32))
+(deftype image-depth () '(integer 0 32))
+
+(deftype resource-id () 'card29)
+
+(deftype keysym () 'card32)
+
+; The following functions are provided by color objects:
+
+; The intention is that IHS and YIQ and CYM interfaces will also exist.
+; Note that we are explicitly using a different spectrum representation
+; than what is actually transmitted in the protocol.
+
+(def-clx-class (color (:constructor make-color-internal (red green blue))
+		      (:copier nil) (:print-function print-color))
+  (red 0.0 :type rgb-val)
+  (green 0.0 :type rgb-val)
+  (blue 0.0 :type rgb-val))
+
+(defun print-color (color stream depth)
+  (declare (type color color)
+	   (ignore depth))
+  (print-unreadable-object (color stream :type t)
+    (prin1 (color-red color) stream)
+    (princ " " stream)
+    (prin1 (color-green color) stream)
+    (princ " " stream)
+    (prin1 (color-blue color) stream)))
+
+(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
+  (declare (type rgb-val red green blue))
+  (declare (values color))
+  (make-color-internal red green blue))
+
+(defun color-rgb (color)
+  (declare (type color color))
+  (declare (values red green blue))
+  (values (color-red color) (color-green color) (color-blue color)))
+
+(def-clx-class (bitmap-format (:copier nil))
+  (unit 8 :type (member 8 16 32))
+  (pad 8 :type (member 8 16 32))
+  (lsb-first-p nil :type boolean))
+
+(def-clx-class (pixmap-format (:copier nil))
+  (depth 0 :type image-depth)
+  (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
+  (scanline-pad 8 :type (member 8 16 32)))
+
+(defparameter *atom-cache-size* 200)
+(defparameter *resource-id-map-size* 500)
+
+(def-clx-class (display (:include buffer)
+			(:constructor make-display-internal)
+			(:print-function print-display)
+			(:copier nil))
+  (host)					; Server Host
+  (display 0 :type integer)			; Display number on host
+  (after-function nil)				; Function to call after every request
+  (event-lock
+    (make-process-lock "CLX Event Lock"))	; with-event-queue lock
+  (event-queue-lock
+    (make-process-lock "CLX Event Queue Lock"))	; new-events/event-queue lock
+  (event-queue-tail				; last event in the event queue
+    nil :type (or null reply-buffer))
+  (event-queue-head				; Threaded queue of events
+    nil :type (or null reply-buffer))
+  (atom-cache (make-hash-table :test #'eq :size *atom-cache-size*)
+	      :type hash-table)			; Hash table relating atoms keywords
+						; to atom id's
+  (font-cache nil)				; list of font
+  (protocol-major-version 0 :type card16)	; Major version of server's X protocol
+  (protocol-minor-version 0 :type card16)	; minor version of servers X protocol
+  (vendor-name "" :type string)			; vendor of the server hardware
+  (resource-id-base 0 :type resource-id)	; resouce ID base
+  (resource-id-mask 0 :type resource-id)	; resource ID mask bits
+  (resource-id-byte nil)			; resource ID mask field (used with DPB & LDB)
+  (resource-id-count 0 :type resource-id)	; resource ID mask count
+						; (used for allocating ID's)
+  (resource-id-map (make-hash-table :test (resource-id-map-test)
+				    :size *resource-id-map-size*)
+		   :type hash-table)		; hash table maps resource-id's to
+						; objects (used in lookup functions)
+  (xid 'resourcealloc)				; allocator function
+  (byte-order #+clx-little-endian :lsbfirst     ; connection byte order
+	      #-clx-little-endian :msbfirst)
+  (release-number 0 :type card32)		; release of the server
+  (max-request-length 0 :type card16)		; maximum number 32 bit words in request
+  (default-screen)				; default screen for operations
+  (roots nil :type list)			; List of screens
+  (motion-buffer-size 0 :type card32)		; size of motion buffer
+  (xdefaults)					; contents of defaults from server
+  (image-lsb-first-p nil :type boolean)
+  (bitmap-format (make-bitmap-format)		; Screen image info
+		 :type bitmap-format)
+  (pixmap-formats nil :type sequence)		; list of pixmap formats
+  (min-keycode 0 :type card8)			; minimum key-code
+  (max-keycode 0 :type card8)			; maximum key-code
+  (error-handler 'default-error-handler)	; Error handler function
+  (close-down-mode :destroy)  			; Close down mode saved by Set-Close-Down-Mode
+  (authorization-name "" :type string)
+  (authorization-data "" :type string)
+  (last-width nil :type (or null card29))	; Accumulated width of last string
+  (keysym-mapping nil				; Keysym mapping cached from server
+		  :type (or null (array * (* *))))
+  (modifier-mapping nil :type list)		; ALIST of (keysym . state-mask) for all modifier keysyms
+  (keysym-translation nil :type list)		; An alist of (keysym object function)
+						; for display-local keysyms
+  (extension-alist nil :type list)		; extension alist, which has elements:
+						; (name major-opcode first-event first-error)
+  (event-extensions '#() :type vector)		; Vector mapping X event-codes to event keys
+  (performance-info)				; Hook for gathering performance info
+  (trace-history)				; Hook for debug trace
+  (plist)					; hook for extension to hang data
+  ;; These slots are used to manage multi-process input.
+  (input-in-progress nil)			; Some process reading from the stream.
+						; Updated with CONDITIONAL-STORE.
+  (pending-commands nil)			; Threaded list of PENDING-COMMAND objects 
+						; for all commands awaiting replies.
+						; Protected by WITH-EVENT-QUEUE-INTERNAL.
+  (asynchronous-errors nil)			; Threaded list of REPLY-BUFFER objects
+						; containing error messages for commands
+						; which did not expect replies.
+						; Protected by WITH-EVENT-QUEUE-INTERNAL.
+  (report-asynchronous-errors			; When to report asynchronous errors
+    '(:immediately) :type list)			; The keywords that can be on this list 
+						; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING,
+						; and :AFTER-FINISH-OUTPUT
+  (event-process nil)				; Process ID of process awaiting events.
+						; Protected by WITH-EVENT-QUEUE.
+  (new-events nil :type (or null reply-buffer))	; Pointer to the first new event in the
+						; event queue.
+						; Protected by WITH-EVENT-QUEUE.
+  (current-event-symbol				; Bound with PROGV by event handling macros 
+    (list (gensym) (gensym)) :type cons)
+  (atom-id-map (make-hash-table :test (resource-id-map-test)
+				:size *atom-cache-size*)
+	       :type hash-table)
+  )
+
+(defun print-display (display stream depth)
+  (declare (type display display)
+	   (ignore depth))
+  (print-unreadable-object (display stream :type t)
+    (princ (display-host display) stream)
+    (princ ":" stream)
+    (princ (display-display display) stream)
+    (princ " (" stream)
+    (princ (display-vendor-name display) stream)
+    (princ " R" stream)
+    (prin1 (display-release-number display) stream)
+    (princ ")" stream)))
+
+;;(deftype drawable () '(or window pixmap))
+
+(def-clx-class (drawable (:copier nil) (:print-function print-drawable))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (plist nil :type list)			; Extension hook
+  )
+
+(defun print-drawable (drawable stream depth)
+  (declare (type drawable drawable)
+	   (ignore depth))
+  (print-unreadable-object (drawable stream :type t)
+    (princ (display-host (drawable-display drawable)) stream)
+    (princ ":" stream)
+    (princ (display-display (drawable-display drawable)) stream)
+    (princ " " stream)
+    (prin1 (drawable-id drawable) stream)))
+
+(def-clx-class (window (:include drawable) (:copier nil)
+		       (:print-function print-drawable))
+  )
+
+(def-clx-class (pixmap (:include drawable) (:copier nil)
+		       (:print-function print-drawable))
+  )
+
+(def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (class :static-gray :type (member :static-gray :static-color :true-color
+				    :gray-scale :pseudo-color :direct-color))
+  (red-mask 0 :type pixel)
+  (green-mask 0 :type pixel)
+  (blue-mask 0 :type pixel)
+  (bits-per-rgb 1 :type card8)
+  (colormap-entries 0 :type card16)
+  (plist nil :type list)			; Extension hook
+  )
+
+(defun print-visual-info (visual-info stream depth)
+  (declare (type visual-info visual-info)
+	   (ignore depth))
+  (print-unreadable-object (visual-info stream :type t)
+    (prin1 (visual-info-bits-per-rgb visual-info) stream)
+    (princ "-bit " stream)
+    (princ (visual-info-class visual-info) stream)
+    (princ " " stream)
+    (princ (display-host (visual-info-display visual-info)) stream)
+    (princ ":" stream)
+    (princ (display-display (visual-info-display visual-info)) stream)
+    (princ " " stream)
+    (prin1 (visual-info-id visual-info) stream)))
+
+(def-clx-class (colormap (:copier nil) (:print-function print-colormap))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (visual-info nil :type (or null visual-info))
+  )
+
+(defun print-colormap (colormap stream depth)
+  (declare (type colormap colormap)
+	   (ignore depth))
+  (print-unreadable-object (colormap stream :type t)
+    (when (colormap-visual-info colormap)
+      (princ (visual-info-class (colormap-visual-info colormap)) stream)
+      (princ " " stream))
+    (princ (display-host (colormap-display colormap)) stream)
+    (princ ":" stream)
+    (princ (display-display (colormap-display colormap)) stream)
+    (princ " " stream)
+    (prin1 (colormap-id colormap) stream)))
+
+(def-clx-class (cursor (:copier nil) (:print-function print-cursor))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  )
+
+(defun print-cursor (cursor stream depth)
+  (declare (type cursor cursor)
+	   (ignore depth))
+  (print-unreadable-object (cursor stream :type t)
+    (princ (display-host (cursor-display cursor)) stream)
+    (princ ":" stream)
+    (princ (display-display (cursor-display cursor)) stream)
+    (princ " " stream)
+    (prin1 (cursor-id cursor) stream)))
+
+; Atoms are accepted as strings or symbols, and are always returned as keywords.
+; Protocol-level integer atom ids are hidden, using a cache in the display object.
+
+(deftype xatom () '(or string symbol))
+
+(defconstant *predefined-atoms*
+	     '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
+		    :CARDINAL :COLORMAP :CURSOR
+		    :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+		    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
+		    :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
+		    :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
+		    :RGB_BLUE_MAP :RGB_DEFAULT_MAP
+		    :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
+		    :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
+		    :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
+		    :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
+		    :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
+		    :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
+		    :SUBSCRIPT_X :SUBSCRIPT_Y
+		    :UNDERLINE_POSITION :UNDERLINE_THICKNESS
+		    :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
+		    :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
+		    :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
+		    :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
+		    :WM_CLASS :WM_TRANSIENT_FOR))
+
+(deftype stringable () '(or string symbol))
+
+(deftype fontable () '(or stringable font))
+
+; Nil stands for CurrentTime.
+
+(deftype timestamp () '(or null card32))
+
+(defconstant *bit-gravity-vector*
+	     '#(:forget :north-west :north :north-east :west
+		:center :east :south-west :south
+		:south-east :static))
+
+(deftype bit-gravity ()
+  '(member :forget :north-west :north :north-east :west
+	   :center :east :south-west :south :south-east :static))
+
+(defconstant *win-gravity-vector*
+	     '#(:unmap :north-west :north :north-east :west
+		:center :east :south-west :south :south-east
+		:static))
+
+(deftype win-gravity ()
+  '(member :unmap :north-west :north :north-east :west
+	   :center :east :south-west :south :south-east :static))
+
+(deftype grab-status ()
+  '(member :success :already-grabbed :invalid-time :not-viewable))
+
+; An association list.
+
+(deftype alist (key-type-and-name datum-type-and-name)
+  (declare (ignore key-type-and-name datum-type-and-name))
+  'list)
+
+; A sequence, containing zero or more repetitions of the given elements,
+; with the elements expressed as (type name).
+
+(deftype repeat-seq (&rest elts) elts 'sequence)
+
+(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
+
+(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
+
+(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
+
+(deftype arc-seq ()
+  '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
+	       (angle angle1) (angle angle2)))
+
+(deftype gcontext-state () 'simple-vector)
+
+(def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
+  ;; The accessors convert to CLX data types.
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (drawable nil :type (or null drawable))
+  (cache-p t :type boolean)
+  (server-state (allocate-gcontext-state) :type gcontext-state)
+  (local-state (allocate-gcontext-state) :type gcontext-state)
+  (plist nil :type list)			; Extension hook
+  (next nil #-explorer :type #-explorer (or null gcontext))
+  )
+
+(defun print-gcontext (gcontext stream depth)
+  (declare (type gcontext gcontext)
+	   (ignore depth))
+  (print-unreadable-object (gcontext stream :type t)
+    (princ (display-host (gcontext-display gcontext)) stream)
+    (princ ":" stream)
+    (princ (display-display (gcontext-display gcontext)) stream)
+    (princ " " stream)
+    (prin1 (gcontext-id gcontext) stream)))
+
+(defconstant *event-mask-vector*
+	     '#(:key-press :key-release :button-press :button-release
+		:enter-window :leave-window :pointer-motion :pointer-motion-hint
+		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
+		:button-5-motion :button-motion :keymap-state :exposure :visibility-change
+		:structure-notify :resize-redirect :substructure-notify :substructure-redirect
+		:focus-change :property-change :colormap-change :owner-grab-button))
+
+(deftype event-mask-class ()
+  '(member :key-press :key-release :owner-grab-button :button-press :button-release
+	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion :exposure :visibility-change
+	   :structure-notify :resize-redirect :substructure-notify :substructure-redirect
+	   :focus-change :property-change :colormap-change :keymap-state))
+
+(deftype event-mask ()
+  '(or mask32 list)) ;; (OR integer (LIST event-mask-class))
+
+(defconstant *pointer-event-mask-vector*
+	     '#(%error %error :button-press :button-release
+		:enter-window :leave-window :pointer-motion :pointer-motion-hint
+		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
+		:button-5-motion :button-motion :keymap-state))
+
+(deftype pointer-event-mask-class ()
+  '(member :button-press :button-release
+	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion :keymap-state))
+
+(deftype pointer-event-mask ()
+  '(or mask32 list)) ;;  '(or integer (list pointer-event-mask-class)))
+
+(defconstant *device-event-mask-vector*
+	     '#(:key-press :key-release :button-press :button-release :pointer-motion
+		:button-1-motion :button-2-motion :button-3-motion :button-4-motion
+		:button-5-motion :button-motion))
+
+(deftype device-event-mask-class ()
+  '(member :key-press :key-release :button-press :button-release :pointer-motion
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion))
+
+(deftype device-event-mask ()
+  '(or mask32 list)) ;;  '(or integer (list device-event-mask-class)))
+
+(defconstant *state-mask-vector*
+	     '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
+		:button-1 :button-2 :button-3 :button-4 :button-5))
+
+(deftype modifier-key ()
+  '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
+
+(deftype modifier-mask ()
+  '(or (member :any) mask16 list)) ;;  '(or (member :any) integer (list modifier-key)))
+
+(deftype state-mask-key ()
+  '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
+
+(defconstant *gcontext-components*
+	     '(:function :plane-mask :foreground :background
+	       :line-width :line-style :cap-style :join-style :fill-style
+	       :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
+	       :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
+	       :arc-mode))
+
+(deftype gcontext-key ()
+  '(member :function :plane-mask :foreground :background
+	   :line-width :line-style :cap-style :join-style :fill-style
+	   :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
+	   :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
+	   :arc-mode))
+
+(deftype event-key ()
+  '(member :key-press :key-release :button-press :button-release :motion-notify
+	   :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
+	   :exposure :graphics-exposure :no-exposure :visibility-notify
+	   :create-notify :destroy-notify :unmap-notify :map-notify :map-request
+	   :reparent-notify :configure-notify :gravity-notify :resize-request
+	   :configure-request :circulate-notify :circulate-request :property-notify
+	   :selection-clear :selection-request :selection-notify
+	   :colormap-notify :client-message :mapping-notify))
+
+(deftype error-key ()
+  '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
+	   :illegal-request :implementation :length :match :name :pixmap :value :window))
+
+(deftype draw-direction ()
+  '(member :left-to-right :right-to-left))
+
+(defconstant *boole-vector*
+	     '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
+		#.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
+		#.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
+		#.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
+
+(deftype boole-constant ()
+  `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
+	   ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
+	   ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
+	   ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
+
+(def-clx-class (screen (:copier nil) (:print-function print-screen))
+  (root nil :type (or null window))
+  (width 0 :type card16)
+  (height 0 :type card16)
+  (width-in-millimeters 0 :type card16)
+  (height-in-millimeters 0 :type card16)
+  (depths nil :type (alist (image-depth depth) ((list visual-info) visuals)))
+  (root-depth 1 :type image-depth)
+  (root-visual-info nil :type (or null visual-info))
+  (default-colormap nil :type (or null colormap))
+  (white-pixel 0 :type pixel)
+  (black-pixel 1 :type pixel)
+  (min-installed-maps 1 :type card16)
+  (max-installed-maps 1 :type card16)
+  (backing-stores :never :type (member :never :when-mapped :always))
+  (save-unders-p nil :type boolean)
+  (event-mask-at-open 0 :type mask32)
+  (plist nil :type list)			; Extension hook
+  )
+
+(defun print-screen (screen stream depth)
+  (declare (type screen screen)
+	   (ignore depth))
+  (print-unreadable-object (screen stream :type t)
+    (let ((display (drawable-display (screen-root screen))))
+      (princ (display-host display) stream)
+      (princ ":" stream)
+      (princ (display-display display) stream)
+      (princ "." stream)
+      (princ (position screen (display-roots display)) stream))
+    (princ " " stream)
+    (prin1 (screen-width screen) stream)
+    (princ "x" stream)
+    (prin1 (screen-height screen) stream)
+    (princ "x" stream)
+    (prin1 (screen-root-depth screen) stream)
+    (when (screen-root-visual-info screen)
+      (princ " " stream)
+      (princ (visual-info-class (screen-root-visual-info screen)) stream))))
+
+(defun screen-root-visual (screen)
+  (declare (type screen screen)
+	   (values resource-id))
+  (visual-info-id (screen-root-visual-info screen)))
+
+;; The list contains alternating keywords and integers.
+(deftype font-props () 'list)
+
+(def-clx-class (font-info (:copier nil) (:predicate nil))
+  (direction :left-to-right :type draw-direction)
+  (min-char 0 :type card16)   ;; First character in font
+  (max-char 0 :type card16)   ;; Last character in font
+  (min-byte1 0 :type card8)   ;; The following are for 16 bit fonts
+  (max-byte1 0 :type card8)   ;; and specify min&max values for
+  (min-byte2 0 :type card8)   ;; the two character bytes
+  (max-byte2 0 :type card8)
+  (all-chars-exist-p nil :type boolean)
+  (default-char 0 :type card16)
+  (min-bounds nil :type (or null vector))
+  (max-bounds nil :type (or null vector))
+  (ascent 0 :type int16)
+  (descent 0 :type int16)
+  (properties nil :type font-props))
+
+(def-clx-class (font (:constructor make-font-internal) (:copier nil)
+		     (:print-function print-font))
+  (id-internal nil :type (or null resource-id)) ;; NIL when not opened
+  (display nil :type (or null display))
+  (reference-count 0 :type fixnum)
+  (name "" :type (or null string)) ;; NIL when ID is for a GContext
+  (font-info-internal nil :type (or null font-info))
+  (char-infos-internal nil :type (or null (simple-array int16 (*))))
+  (local-only-p t :type boolean) ;; When T, always calculate text extents locally
+  (plist nil :type list)			; Extension hook
+  )
+
+(defun print-font (font stream depth)
+  (declare (type font font)
+	   (ignore depth))
+  (print-unreadable-object (font stream :type t)
+    (if (font-name font)
+	(princ (font-name font) stream)
+      (princ "(gcontext)" stream))
+    (princ " " stream)
+    (princ (display-host (font-display font)) stream)
+    (princ ":" stream)
+    (princ (display-display (font-display font)) stream)
+    (when (font-id-internal font)
+      (princ " " stream)
+      (prin1 (font-id font) stream))))
+
+(defun font-id (font)
+  ;; Get font-id, opening font if needed
+  (or (font-id-internal font)
+      (open-font-internal font)))
+
+(defun font-font-info (font)
+  (or (font-font-info-internal font)
+      (query-font font)))
+
+(defun font-char-infos (font)
+  (or (font-char-infos-internal font)
+      (progn (query-font font)
+	     (font-char-infos-internal font))))
+
+(defun make-font (&key id
+		  display
+		  (reference-count 0)
+		  (name "")
+		  (local-only-p t)
+		  font-info-internal)
+  (make-font-internal :id-internal id
+		      :display display
+		      :reference-count reference-count
+		      :name name
+		      :local-only-p local-only-p
+		      :font-info-internal font-info-internal))
+
+; For each component (<name> <unspec> :type <type>) of font-info,
+; there is a corresponding function:
+
+;(defun font-<name> (font)
+;  (declare (type font font)
+;	   (values <type>)))
+
+(macrolet ((make-font-info-accessors (useless-name &body fields)
+	     `(within-definition (,useless-name make-font-info-accessors)
+		,@(mapcar
+		    #'(lambda (field)
+			(let* ((type (second field))
+			       (n (string (first field)))
+			       (name (xintern 'font- n))
+			       (accessor (xintern 'font-info- n)))
+			  `(defun ,name (font)
+			     (declare (type font font))
+			     (declare (values ,type))
+			     (,accessor (font-font-info font)))))
+		    fields))))
+  (make-font-info-accessors ignore
+    (direction draw-direction)
+    (min-char card16)
+    (max-char card16)
+    (min-byte1 card8)
+    (max-byte1 card8)
+    (min-byte2 card8)
+    (max-byte2 card8)
+    (all-chars-exist-p boolean)
+    (default-char card16)
+    (min-bounds vector)
+    (max-bounds vector)
+    (ascent int16)
+    (descent int16)
+    (properties font-props)))
+
+(defun font-property (font name)
+  (declare (type font font)
+	   (type keyword name))
+  (declare (values (or null int32)))
+  (getf (font-properties font) name))
+
+(macrolet ((make-mumble-equal (type)
+	     ;; When cached, EQ works fine, otherwise test resource id's and displays
+	     (let ((predicate (xintern type '-equal))
+		   (id (xintern type '-id))
+		   (dpy (xintern type '-display)))
+	       (if (member type *clx-cached-types*)
+		   `(within-definition (,type make-mumble-equal)
+		      (declaim (inline ,predicate))
+		      (defun ,predicate (a b) (eq a b)))
+		   `(within-definition (,type make-mumble-equal)
+		      (defun ,predicate (a b)
+			(declare (type ,type a b))
+			(and (= (,id a) (,id b))
+			     (eq (,dpy a) (,dpy b)))))))))
+  (make-mumble-equal window)
+  (make-mumble-equal pixmap)
+  (make-mumble-equal cursor)
+  (make-mumble-equal font)
+  (make-mumble-equal gcontext)
+  (make-mumble-equal colormap)
+  (make-mumble-equal drawable))
+
+;;;
+;;; Event-mask encode/decode functions
+;;;    Converts from keyword-lists to integer and back
+;;;
+(defun encode-mask (key-vector key-list key-type)
+  ;; KEY-VECTOR is a vector containg bit-position keywords.  The position of the
+  ;; keyword in the vector indicates its bit position in the resulting mask
+  ;; KEY-LIST is either a mask or a list of KEY-TYPE
+  ;; Returns NIL when KEY-LIST is not a list or mask.
+  (declare (type (simple-array keyword (*)) key-vector)
+	   (type (or mask32 list) key-list))
+  (declare (values (or mask32 nil)))
+  (typecase key-list
+    (mask32 key-list)
+    (list (let ((mask 0))
+	    (dolist (key key-list mask)
+	      (let ((bit (position key (the vector key-vector) :test #'eq)))
+		(unless bit
+		  (x-type-error key key-type))
+		(setq mask (logior mask (ash 1 bit)))))))))
+
+(defun decode-mask (key-vector mask)
+  (declare (type (simple-array keyword (*)) key-vector)
+	   (type mask32 mask))
+  (declare (values list))
+  (do ((m mask (ash m -1))
+       (bit 0 (1+ bit))
+       (len (length key-vector))
+       (result nil))       
+      ((or (zerop m) (>= bit len)) result)
+    (declare (type mask32 m)
+	     (fixnum bit len)
+	     (list result))
+    (when (oddp m)
+      (push (aref key-vector bit) result))))
+
+(defun encode-event-mask (event-mask)
+  (declare (type event-mask event-mask))
+  (declare (values mask32))
+  (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
+      (x-type-error event-mask 'event-mask)))
+
+(defun make-event-mask (&rest keys)
+  ;; This is only defined for core events.
+  ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
+  (declare (type list keys)) ;; (list event-mask-class)
+  (declare (values mask32))
+  (encode-mask *event-mask-vector* keys 'event-mask-class))
+
+(defun make-event-keys (event-mask)
+  ;; This is only defined for core events.
+  (declare (type mask32 event-mask))
+  (declare (values (list event-mask-class)))
+  (decode-mask *event-mask-vector* event-mask))
+
+(defun encode-device-event-mask (device-event-mask)
+  (declare (type device-event-mask device-event-mask))
+  (declare (values mask32))
+  (or (encode-mask *device-event-mask-vector* device-event-mask
+		   'device-event-mask-class)
+      (x-type-error device-event-mask 'device-event-mask)))
+
+(defun encode-modifier-mask (modifier-mask)
+  (declare (type modifier-mask modifier-mask)) ;; (list state-mask-key)
+  (declare (values mask16))
+  (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
+      (and (eq modifier-mask :any) #x8000)
+      (x-type-error modifier-mask 'modifier-mask)))
+
+(defun encode-state-mask (state-mask)
+  (declare (type (or mask16 list) state-mask)) ;; (list state-mask-key)
+  (declare (values mask16))
+  (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
+      (x-type-error state-mask '(or mask16 (list state-mask-key)))))
+
+(defun make-state-mask (&rest keys)
+  ;; Useful for constructing modifier-mask, state-mask.
+  (declare (type list keys)) ;; (list state-mask-key)
+  (declare (values mask16))
+  (encode-mask *state-mask-vector* keys 'state-mask-key))
+
+(defun make-state-keys (state-mask)
+  (declare (type mask16 state-mask))
+  (declare (values (list state-mask-key)))
+  (decode-mask *state-mask-vector* state-mask))
+
+(defun encode-pointer-event-mask (pointer-event-mask)
+  (declare (type pointer-event-mask pointer-event-mask))
+  (declare (values mask32))
+  (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
+		   'pointer-event-mask-class)
+      (x-type-error pointer-event-mask 'pointer-event-mask)))
diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp
new file mode 100644
index 000000000..b711c5950
--- /dev/null
+++ b/clx/defsystem.lisp
@@ -0,0 +1,603 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes;  -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;; #+ features used in this file
+;;;   ansi-common-lisp
+;;;   lispm
+;;;   genera
+;;;   lucid
+;;;   lcl3.0
+;;;   apollo
+;;;   kcl
+;;;   ibcl
+;;;   excl
+
+#-ansi-common-lisp 
+(lisp:in-package :xlib :use '(:lisp))
+
+#+ansi-common-lisp
+(common-lisp:in-package :common-lisp-user)
+
+#+ansi-common-lisp
+(common-lisp:defpackage xlib
+  (:use common-lisp)
+  (:size 3000)
+  #+Genera
+  (:import-from
+    (system
+      arglist downward-funarg array-register)
+    (zwei
+      indentation))
+  (:export
+    *version* access-control access-error access-hosts
+    activate-screen-saver add-access-host add-resource add-to-save-set
+    alist alloc-color alloc-color-cells alloc-color-planes alloc-error
+    allow-events angle arc-seq array-index atom-error atom-name
+    bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p
+    bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image
+    boole-constant boolean card16 card29 card32 card8
+    card8->char change-active-pointer-grab change-keyboard-control
+    change-keyboard-mapping change-pointer-control change-property
+    char->card8 char-ascent char-attributes char-descent
+    char-left-bearing char-right-bearing char-width character->keysyms
+    character-in-map-p circulate-window-down circulate-window-up clear-area
+    close-display close-down-mode close-font closed-display color
+    color-blue color-green color-p color-red color-rgb colormap
+    colormap-display colormap-equal colormap-error colormap-id
+    colormap-p colormap-visual-info connection-failure convert-selection
+    copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components
+    copy-image copy-plane create-colormap create-cursor
+    create-gcontext create-glyph-cursor create-image create-pixmap
+    create-window cursor cursor-display cursor-equal cursor-error
+    cursor-id cursor-p cut-buffer declare-event decode-core-error
+    default-error-handler default-keysym-index default-keysym-translate
+    define-error define-extension define-gcontext-accessor
+    define-keysym define-keysym-set delete-property delete-resource
+    destroy-subwindows destroy-window device-busy device-event-mask
+    device-event-mask-class discard-current-event discard-font-info display
+    display-after-function display-authorization-data display-authorization-name
+    display-bitmap-format display-byte-order display-default-screen
+    display-display display-error-handler display-finish-output
+    display-force-output display-host display-image-lsb-first-p
+    display-invoke-after-function display-keycode-range display-max-keycode
+    display-max-request-length display-min-keycode display-motion-buffer-size
+    display-nscreens display-p display-pixmap-formats display-plist
+    display-protocol-major-version display-protocol-minor-version
+    display-protocol-version display-release-number
+    display-report-asynchronous-errors display-resource-id-base
+    display-resource-id-mask display-roots display-vendor
+    display-vendor-name display-xdefaults display-xid draw-arc
+    draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph
+    draw-image-glyphs draw-line draw-lines draw-point draw-points
+    draw-rectangle draw-rectangles draw-segments drawable
+    drawable-border-width drawable-depth drawable-display drawable-equal
+    drawable-error drawable-height drawable-id drawable-p
+    drawable-plist drawable-root drawable-width drawable-x drawable-y
+    error-key event-case event-cond event-handler event-key
+    event-listen event-mask event-mask-class extension-opcode
+    find-atom font font-all-chars-exist-p font-ascent
+    font-default-char font-descent font-direction font-display
+    font-equal font-error font-id font-max-byte1 font-max-byte2
+    font-max-char font-min-byte1 font-min-byte2 font-min-char
+    font-name font-p font-path font-plist font-properties
+    font-property fontable force-gcontext-changes free-colormap
+    free-colors free-cursor free-gcontext free-pixmap gcontext
+    gcontext-arc-mode gcontext-background gcontext-cap-style
+    gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x
+    gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display
+    gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule
+    gcontext-fill-style gcontext-font gcontext-foreground gcontext-function
+    gcontext-id gcontext-join-style gcontext-key gcontext-line-style
+    gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist
+    gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x
+    gcontext-ts-y get-external-event-code get-image get-property
+    get-raw-image get-resource get-search-resource get-search-table
+    get-standard-colormap get-wm-class global-pointer-position grab-button
+    grab-key grab-keyboard grab-pointer grab-server grab-status
+    icon-sizes iconify-window id-choice-error illegal-request-error
+    image image-blue-mask image-depth image-green-mask image-height
+    image-name image-pixmap image-plist image-red-mask image-width
+    image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
+    image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
+    image-z-pixarray implementation-error input-focus install-colormap
+    installed-colormaps int16 int32 int8 intern-atom invalid-font
+    keyboard-control keyboard-mapping keycode->character keycode->keysym
+    keysym keysym->character keysym->keycodes keysym-in-map-p
+    keysym-set kill-client kill-temporary-clients length-error
+    list-extensions list-font-names list-fonts list-properties
+    lookup-color lookup-error make-color make-event-handlers
+    make-event-keys make-event-mask make-resource-database make-state-keys
+    make-state-mask make-wm-hints make-wm-size-hints map-resource
+    map-subwindows map-window mapping-notify mask16 mask32
+    match-error max-char-ascent max-char-attributes max-char-descent
+    max-char-left-bearing max-char-right-bearing max-char-width
+    merge-resources min-char-ascent min-char-attributes min-char-descent
+    min-char-left-bearing min-char-right-bearing min-char-width
+    missing-parameter modifier-key modifier-mapping modifier-mask
+    motion-events name-error no-operation open-display open-font
+    pixarray pixel pixmap pixmap-display pixmap-equal
+    pixmap-error pixmap-format pixmap-format-bits-per-pixel
+    pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad
+    pixmap-id pixmap-p pixmap-plist point-seq pointer-control
+    pointer-event-mask pointer-event-mask-class pointer-mapping
+    pointer-position process-event put-image put-raw-image
+    query-best-cursor query-best-stipple query-best-tile query-colors
+    query-extension query-keymap query-pointer query-tree queue-event
+    read-bitmap-file read-resources recolor-cursor rect-seq
+    remove-access-host remove-from-save-set reparent-window repeat-seq
+    reply-length-error reply-timeout request-error reset-screen-saver
+    resource-database resource-database-timestamp resource-error
+    resource-id resource-key rgb-colormaps rgb-val root-resources
+    rotate-cut-buffers rotate-properties screen screen-backing-stores
+    screen-black-pixel screen-default-colormap screen-depths
+    screen-event-mask-at-open screen-height screen-height-in-millimeters
+    screen-max-installed-maps screen-min-installed-maps screen-p
+    screen-plist screen-root screen-root-depth screen-root-visual
+    screen-root-visual-info screen-save-unders-p screen-saver
+    screen-white-pixel screen-width screen-width-in-millimeters seg-seq
+    selection-owner send-event sequence-error set-access-control
+    set-close-down-mode set-input-focus set-modifier-mapping
+    set-pointer-mapping set-screen-saver set-selection-owner
+    set-standard-colormap set-standard-properties set-wm-class
+    set-wm-properties set-wm-resources state-keysym-p state-mask-key
+    store-color store-colors stringable text-extents text-width
+    timestamp transient-for translate-coordinates translate-default
+    translation-function undefine-keysym unexpected-reply
+    ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
+    ungrab-server uninstall-colormap unknown-error unmap-subwindows
+    unmap-window value-error visual-info visual-info-bits-per-rgb
+    visual-info-blue-mask visual-info-class visual-info-colormap-entries
+    visual-info-display visual-info-green-mask visual-info-id visual-info-p
+    visual-info-plist visual-info-red-mask warp-pointer
+    warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside
+    win-gravity window window-all-event-masks window-background
+    window-backing-pixel window-backing-planes window-backing-store
+    window-bit-gravity window-border window-class window-colormap
+    window-colormap-installed-p window-cursor window-display
+    window-do-not-propagate-mask window-equal window-error
+    window-event-mask window-gravity window-id window-map-state
+    window-override-redirect window-p window-plist window-priority
+    window-save-under window-visual window-visual-info with-display
+    with-event-queue with-gcontext with-server-grabbed with-state
+    withdraw-window wm-client-machine wm-colormap-windows wm-command
+    wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
+    wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
+    wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
+    wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
+    wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
+    wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
+    wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect
+    wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p
+    wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
+    wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
+    wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
+    write-resources xatom))
+
+#+ansi-common-lisp
+(common-lisp:in-package :xlib)
+
+#-lispm
+(export '(
+	  compile-clx
+	  load-clx))
+
+#+excl (error "Use excldefsys")
+
+
+;;;; Lisp Machines
+
+;;; Lisp machines have their own defsystems, so we use them to define
+;;; the CLX load.
+
+#+(and lispm (not genera))
+(global:defsystem CLX
+  (:pathname-default "clx:clx;")
+  (:patchable "clx:patch;" clx-ti)
+  (:initial-status :experimental)
+
+  (:module depdefs "depdefs")
+  (:module clx "clx")
+  (:module dependent "dependent")
+  (:module macros "macros")
+  (:module bufmac "bufmac")
+  (:module buffer "buffer")
+  (:module display "display")
+  (:module gcontext "gcontext")
+  (:module requests "requests")
+  (:module input "input")
+  (:module fonts "fonts")
+  (:module graphics "graphics")
+  (:module text "text")
+  (:module attributes "attributes")
+  (:module translate "translate")
+  (:module keysyms "keysyms")
+  (:module manager "manager")
+  (:module image "image")
+  (:module resource "resource")
+  (:module doc "doc")
+
+  (:compile-load depdefs)
+  (:compile-load clx
+   (:fasload depdefs))
+  (:compile-load dependent
+   (:fasload depdefs clx))
+  ;; Macros only needed for compilation
+  (:skip :compile-load macros
+   (:fasload depdefs clx dependent))
+  ;; Bufmac only needed for compilation
+  (:skip :compile-load bufmac
+   (:fasload depdefs clx dependent macros))
+  (:compile-load buffer
+   (:fasload depdefs clx dependent macros bufmac))
+  (:compile-load display
+   (:fasload depdefs clx dependent macros bufmac buffer))
+  (:compile-load gcontext
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load input
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load requests
+   (:fasload depdefs clx dependent macros bufmac buffer display input))
+  (:compile-load fonts
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load graphics
+   (:fasload depdefs clx dependent macros fonts bufmac buffer display fonts))
+  (:compile-load text
+   (:fasload depdefs clx dependent macros fonts bufmac buffer display gcontext fonts))
+  (:compile-load-init attributes
+   (dependent)					;<- There may be other modules needed here.
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load translate
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load keysyms
+   (:fasload depdefs clx dependent macros bufmac buffer display translate))
+  (:compile-load manager
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load image
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load resource)
+  (:auxiliary doc)
+  )
+
+
+#+Genera
+(scl:defsystem CLX
+    (:default-pathname "SYS:X11;CLX;"
+     :default-package "XLIB"
+     :pretty-name "CLX"
+     :maintaining-sites (:scrc)
+     :distribute-sources t
+     :distribute-binaries t
+     :source-category :basic)
+  (:module doc ("doc")
+	   (:type :lisp-example))
+  (:module depdefs ("depdefs" "generalock"))
+  (:module clx ("clx")
+	   (:uses-definitions-from depdefs))
+  (:module dependent ("dependent")
+	   (:uses-definitions-from clx))
+  (:module macros ("macros")
+	   (:uses-definitions-from dependent))
+  (:module bufmac ("bufmac")
+	   (:uses-definitions-from dependent macros))
+  (:module buffer ("buffer")
+	   (:uses-definitions-from dependent macros bufmac))
+  (:module display ("display")
+	   (:uses-definitions-from dependent macros bufmac buffer))
+  (:module gcontext ("gcontext")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module input ("input")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module requests ("requests")
+	   (:uses-definitions-from dependent macros bufmac display input))
+  (:module fonts ("fonts")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module graphics ("graphics")
+	   (:uses-definitions-from dependent macros bufmac fonts))
+  (:module text ("text")
+	   (:uses-definitions-from dependent macros bufmac gcontext fonts))
+  (:module attributes ("attributes")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module translate ("translate")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module keysyms ("keysyms")
+	   (:uses-definitions-from translate))
+  (:module manager ("manager")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module image ("image")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module resource ("resource"))
+  )
+
+
+;;;; Non Lisp Machines
+
+#+lucid
+(defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites
+
+#+lucid
+(defun clx-foreign-files (binary-path)
+
+  ;; apply a patch to 2.0 systems
+  #+(and (not lcl3.0) (or mc68000 mc68020))
+  (load (merge-pathnames "make-sequence-patch" binary-path))
+
+  ;; Link lisp to the C function connect_to_server
+  #+(and apollo (not lcl3.0))
+  (lucid::define-foreign-function '(xlib::connect-to-server "connect_to_server")
+      '((:val host    :string)
+	(:val display :integer32))
+    :integer32)
+  #+(and (not apollo) (not lcl3.0))
+  (lucid::define-c-function xlib::connect-to-server
+      (host display)
+    :result-type :integer)
+  #+lcl3.0
+  (lucid::def-foreign-function (xlib::connect-to-server 
+				 (:language :c)
+				 (:return-type :signed-32bit))
+      (host :simple-string) (display :signed-32bit))
+  (unintern 'display)
+
+  ;; Load the definition of connect_to_server
+  #+apollo
+  (lucid::load-foreign-file (merge-pathnames "socket" binary-path)
+			    :preserve-pathname t)
+  #-apollo
+  (lucid::load-foreign-files (list (merge-pathnames "socket.o" binary-path))
+			     *foreign-libraries*))
+
+
+;; socket interface for kcl and ibcl
+;;   defines the function (open-socket-stream host display)
+;;
+;; You must first compile file socket.c
+#+(or kcl ibcl)
+(defun kcl-socket-init (binary-path)
+  (let ((sockcl (namestring (merge-pathnames "sockcl.o" binary-path)))
+	(socket (namestring (merge-pathnames "socket.o" binary-path))))
+    (si:faslink sockcl (format nil "~a -lc" socket))
+    ))
+
+
+;;;; Compile CLX
+
+;;; COMPILE-CLX compiles the lisp source files and loads the binaries.
+;;; It goes to some trouble to let the source files be in one directory
+;;; and the binary files in another.  Thus the same set of sources can
+;;; be used for different machines and/or lisp systems.  It also allows
+;;; you to supply explicit extensions, so source files do not have to
+;;; be renamed to fit into the naming conventions of an implementation.
+
+;;; For example,
+;;;     (compile-clx "*.lisp" "machine/")
+;;; compiles source files from the connected directory and puts them
+;;; into the "machine" subdirectory.  You can then load CLX out of the
+;;; machine directory.
+
+;;; The code has no knowledge of the source file types (eg, ".l" or
+;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin").  Calling
+;;; compile-file and load with a file type of NIL usually sorts things
+;;; out correctly, but you may have to explicitly give the source and
+;;; binary file types.
+
+;;; An attempt at compiling the C language sources is also made,
+;;; but you may have to set different compiler switches
+;;; should be.  If it doesn't do the right thing, then do
+;;;     (compile-clx "" "" :compile-c NIL)
+;;; to prevent the compilation.
+
+;;; compilation notes
+;;;   lucid2.0/hp9000
+;;;     must uudecode the file make-sequence-patch.uu
+
+#-lispm
+(defun compile-clx (&optional
+		    (source-pathname-defaults "")
+		    (binary-pathname-defaults "")
+		    &key
+		    (compile-c t))
+
+  ;; The pathname-defaults above might only be strings, so coerce them
+  ;; to pathnames.  Build a default binary path with every component
+  ;; of the source except the file type.  This should prevent
+  ;; (compile-clx "*.lisp") from destroying source files.
+  (let* ((source-path (pathname source-pathname-defaults))
+	 (path        (make-pathname
+			:host      (pathname-host      source-path)
+			:device    (pathname-device    source-path)
+			:directory (pathname-directory source-path)
+			:name      (pathname-name      source-path)
+			:type      nil
+			:version   (pathname-version   source-path)))
+	 (binary-path (merge-pathnames binary-pathname-defaults
+				       path)))
+				       
+    ;; Make sure source-path and binary-path file types are distinct so
+    ;; we don't accidently overwrite the source files.  NIL should be an
+    ;; ok type, but anything else spells trouble.
+    (if (and (equal (pathname-type source-path)
+		    (pathname-type binary-path))
+	     (not (null (pathname-type binary-path))))
+	(error "Source and binary pathname defaults have same type ~s ~s"
+	       source-path binary-path))
+
+    (format t ";;; Default paths: ~s ~s~%" source-path binary-path)
+
+    ;; In lucid make sure we're using the compiler in production mode.
+    #+lcl3.0
+    (progn
+      #-pqc 
+      (cerror "Go ahead anyway."
+	      "Lucid's production mode compiler must be loaded to compile CLX.")
+      (proclaim '(optimize (speed 3)
+			   (safety 1)
+			   (space 0)
+			   (compilation-speed 0))))
+
+    (flet ((compile-and-load (filename)
+	     (let ((source (merge-pathnames filename source-path))
+		   (binary (merge-pathnames filename binary-path)))
+	       ;; If the source and binary pathnames are the same,
+	       ;; then don't supply an output file just to be sure
+	       ;; compile-file defaults correctly.
+	       #+(or kcl ibcl) (load source)
+	       (if (equal source binary)
+		   (compile-file source)
+		   (compile-file source :output-file binary))
+	       (load binary))))
+
+      ;; Now compile and load all the files.
+      ;; Defer compiler warnings until everything's compiled, if possible.
+      (#.(if (fboundp 'with-compilation-unit)
+	     'with-compilation-unit
+	   #+lcl3.0 'lucid::with-deferred-warnings
+	   #-lcl3.0 'progn)
+       ()
+       
+       #+lucid
+       (progn 
+	 (when compile-c			; compile the C files
+	   #+(and (not lcl3.0) (or mc68000 mc68020))
+	   (progn				; sequence patch
+	     (format t "You may need to uudecode ms-patch.uu and copy~%")
+	     (format t "the result to the binary directory.~%")
+	     (format t "You also must rename the file to have the canonical~%")
+	     (format t "binary file type in order for lisp to realize it's a~%")
+	     (format t "binary file.~%"))
+	   ;; compile socket.c
+	   (let* ((src  (merge-pathnames "socket.c" source-path))
+		  (obj  (merge-pathnames "socket.o" binary-path))
+		  (args (list "-c" (namestring src)
+			      "-o" (namestring obj)
+			      "-DUNIXCONN")))
+	     (format t ";;; cc~{ ~a~}~%" args)
+	     (multiple-value-bind (iostream estream exitstatus pid)
+		 ;; in 2.0, run-program is exported from system:
+		 ;; in 3.0, run-program is exported from lcl:
+		 ;; system inheirits lcl
+		 (system::run-program "cc" :arguments args)
+	       (declare (ignore iostream estream pid))
+	       (if (/= 0 exitstatus)
+		   (error "Exit status of socket.c compile is ~d" exitstatus)))))
+	 (format t ";;; Loading foreign files~%")
+	 (clx-foreign-files binary-path))
+
+       #+(or kcl ibcl)
+       (progn
+	 (when compile-c			; compile the C files
+	   (let* ((src (merge-pathnames "socket.c" source-path))
+		  (obj (merge-pathnames "socket.o" binary-path))
+		  (arg (format nil "cc -c ~a -o ~a -DUNIXCONN"
+			       (namestring src)
+			       (namestring obj))))
+	     (format t ";;; ~a~%" arg)
+	     (if (/= 0 (system arg))
+		 (error "bad exit status for ~s" src))))
+	 ;; compile the lisp interface to the c code
+	 (let ((src (merge-pathnames "sockcl"   source-path))
+	       (obj (merge-pathnames "sockcl.o" binary-path)))
+	   (compile-file src :output-file obj))
+	 (kcl-socket-init binary-path))
+
+       (compile-and-load "depdefs")
+       (compile-and-load "clx")
+       (compile-and-load "dependent")
+       (compile-and-load "macros")		; these are just macros
+       (compile-and-load "bufmac")		; these are just macros
+       (compile-and-load "buffer")
+       (compile-and-load "display")
+       (compile-and-load "gcontext")
+       (compile-and-load "input")
+       (compile-and-load "requests")
+       (compile-and-load "fonts")
+       (compile-and-load "graphics")
+       (compile-and-load "text")
+       (compile-and-load "attributes")
+       (compile-and-load "translate")
+       (compile-and-load "keysyms")
+       (compile-and-load "manager")
+       (compile-and-load "image")
+       (compile-and-load "resource")
+       ))))
+
+
+;;;; Load CLX
+
+;;; This procedure loads the binaries for CLX.  All of the binaries
+;;; should be in the same directory, so setting the default pathname
+;;; should point load to the right place.
+
+;;; You should have a module definition somewhere so the require/provide
+;;; mechanism can avoid reloading CLX.  In an ideal world, somebody would
+;;; just put
+;;;		(REQUIRE 'CLX)
+;;; in their file (some implementations don't have a central registry for
+;;; modules, so a pathname needs to be supplied).
+
+;;; The REQUIRE should find a file that does
+;;;		(IN-PACKAGE 'XLIB :USE '(LISP))
+;;;		(PROVIDE 'CLX)
+;;;		(LOAD <clx-defsystem-file>)
+;;;		(LOAD-CLX <binary-specific-clx-directory>)
+
+#-lispm
+(defun load-clx (&optional (binary-pathname-defaults "")
+		 &key (macros-p nil))
+
+  (let* ((source-path (pathname ""))
+	 (path        (make-pathname
+			:host      (pathname-host      source-path)
+			:device    (pathname-device    source-path)
+			:directory (pathname-directory source-path)
+			:name      (pathname-name      source-path)
+			:type      nil
+			:version   (pathname-version   source-path)))
+	 (binary-path (merge-pathnames binary-pathname-defaults
+				       path)))
+
+    (flet ((load-binary (filename)
+	     (let ((binary (merge-pathnames filename binary-path)))
+	       (load binary))))
+
+      #+lucid
+      (clx-foreign-files binary-path)
+
+      #+(or kcl ibcl)
+      (kcl-socket-init binary-path)
+
+      (load-binary "depdefs")
+      (load-binary "clx")
+      (load-binary "dependent")
+      (when macros-p
+	(load-binary "macros")
+	(load-binary "bufmac"))
+      (load-binary "buffer")
+      (load-binary "display")
+      (load-binary "gcontext")
+      (load-binary "input")
+      (load-binary "requests")
+      (load-binary "fonts")
+      (load-binary "graphics")
+      (load-binary "text")
+      (load-binary "attributes")
+      (load-binary "translate")
+      (load-binary "keysyms")
+      (load-binary "manager")
+      (load-binary "image")
+      (load-binary "resource")
+      )))
diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp
new file mode 100644
index 000000000..1f86c22d6
--- /dev/null
+++ b/clx/depdefs.lisp
@@ -0,0 +1,654 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;; This file contains some of the system dependent code for CLX
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+;;;-------------------------------------------------------------------------
+;;; Declarations
+;;;-------------------------------------------------------------------------
+
+;;; fix a bug in kcl's RATIONAL...
+;;;   redefine both the function and the type.
+
+#+(or kcl ibcl)
+(shadow 'rational)
+
+#+(or kcl ibcl)
+(progn
+  (defun rational (x)
+    (if (rationalp x)
+	x
+	(lisp:rational x)))
+  (deftype rational () 'lisp:rational))
+
+;;; DECLAIM
+
+#-ansi-common-lisp
+(defmacro declaim (&rest decl-specs)
+  (if (cdr decl-specs)
+      `(progn
+	 ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
+		   decl-specs))
+    `(proclaim ',(car decl-specs))))
+
+;;; VALUES value1 value2 ... -- Documents the values returned by the function.
+
+#-lispm
+(declaim (declaration values))
+
+;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
+;;; the documentation that might get generated by the real arglist of the
+;;; function.
+
+#+lispm 
+(import '(sys:arglist))
+
+#+lcl3.0
+(import '(lcl:arglist))
+
+#-(or lispm lcl3.0)
+(declaim (declaration arglist))
+
+;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that
+;;; closures passed in as the argument named by name can be consed on the
+;;; stack, as they have dynamic extent.  In Genera keyword args can't be named
+;;; this way.  Instead use * to specify all functional args have dynamic
+;;; extent.
+
+#+lispm 
+(import '(sys:downward-funarg))
+
+#-lispm
+(declaim (declaration downward-funarg))
+
+;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
+;;; dynamic extent and therefore can be kept on the stack and not copied to
+;;; the heap, even though the value is passed out of the function.
+
+#+lcl3.0
+(import '(lcl:dynamic-extent))
+
+#-(or ansi-common-lisp lcl3.0)
+(declaim (declaration dynamic-extent))
+
+;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not
+;;; args) that hold vectors.  
+
+#+Genera
+(import '(sys:array-register))
+
+#-Genera 
+(declaim (declaration array-register))
+
+;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
+;;; indent calls to the function or macro containing the declaration.  
+
+#+genera
+(import '(zwei:indentation))
+
+#-genera
+(declaim (declaration indentation))
+
+;;;-------------------------------------------------------------------------
+;;; Declaration macros
+;;;-------------------------------------------------------------------------
+
+;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
+;;; and then does a type declaration and array register declaration
+(defmacro with-vector ((var type) &body body)
+  `(let ((,var ,var))
+     (declare (type ,type ,var)
+	      (array-register ,var))
+     ,@body))
+
+;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
+;;; Meta-.
+
+#+lispm
+(defmacro within-definition ((name type) &body body)
+  `(zl:local-declare
+     ((sys:function-parent ,name ,type))
+     (sys:record-source-file-name ',name ',type)
+     ,@body))
+
+#-lispm
+(defmacro within-definition ((name type) &body body)
+  (declare (ignore name type))
+  `(progn ,@body))
+
+
+;;;-------------------------------------------------------------------------
+;;; CLX can maintain a mapping from X server ID's to local data types.  If
+;;; one takes the view that CLX objects will be instance variables of
+;;; objects at the next higher level, then PROCESS-EVENT will typically map
+;;; from resource-id to higher-level object.  In that case, the lower-level
+;;; CLX mapping will almost never be used (except in rare cases like
+;;; query-tree), and only serve to consume space (which is difficult to
+;;; GC), in which case always-consing versions of the make-<mumble>s will
+;;; be better.  Even when maps are maintained, it isn't clear they are
+;;; useful for much beyond xatoms and windows (since almost nothing else
+;;; ever comes back in events).
+;;;--------------------------------------------------------------------------
+(defconstant *clx-cached-types*
+	     '( drawable
+		window
+		pixmap
+;		gcontext
+		cursor
+		colormap
+		font))
+
+(defmacro resource-id-map-test ()
+  #+excl '#'equal
+  #-excl '#'eql)		    ; (eq fixnum fixnum) is not guaranteed.
+
+(defmacro keysym->character-map-test ()
+  #+excl '#'equal
+  #-excl '#'eql)
+
+;;; You must define this to match the real byte order.  It is used by
+;;; overlapping array and image code.
+
+#+(or lispm vax little-endian)
+(eval-when (eval compile load)
+  (pushnew :clx-little-endian *features*))
+
+#+lcl3.0
+(eval-when (compile eval load)
+  (ecase lucid::machine-endian
+    (:big)
+    (:little (pushnew :clx-little-endian *features*))))
+
+;;; Steele's Common-Lisp states:  "It is an error if the array specified
+;;; as the :displaced-to argument  does not have the same :element-type
+;;; as the array being created" If this is the case on your lisp, then
+;;; leave the overlapping-arrays feature turned off.  Lisp machines
+;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
+;;; with different element types to overlap.  CLX will take advantage of
+;;; this to do fast array packing/unpacking when the overlapping-arrays
+;;; feature is enabled.
+
+#+(and clx-little-endian lispm)
+(eval-when (eval compile load)
+  (pushnew :clx-overlapping-arrays *features*))
+
+#+(and clx-overlapping-arrays genera)
+(progn
+(deftype overlap16 () '(unsigned-byte 16))
+(deftype overlap32 () '(signed-byte 32))
+)
+
+#+(and clx-overlapping-arrays (or explorer lambda cadr))
+(progn
+(deftype overlap16 () '(unsigned-byte 16))
+(deftype overlap32 () '(unsigned-byte 32))
+)
+
+(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
+
+#+clx-overlapping-arrays
+(progn
+(deftype buffer-words () `(vector overlap16))
+(deftype buffer-longs () `(vector overlap32))
+)
+
+;;; This defines a type which is a subtype of the integers.
+;;; This type is used to describe all variables that can be array indices.
+;;; It is here because it is used below.
+;;; This is inclusive because start/end can be 1 past the end.
+(deftype array-index () `(integer 0 ,array-dimension-limit))
+
+
+;; this is the best place to define these?
+
+#-Genera
+(progn
+
+(defun make-index-typed (form)
+  (if (constantp form) form `(the array-index ,form)))
+
+(defun make-index-op (operator args)
+  `(the array-index
+	(values 
+	  ,(case (length args)
+	     (0 `(,operator))
+	     (1 `(,operator
+		  ,(make-index-typed (first args))))
+	     (2 `(,operator
+		  ,(make-index-typed (first args))
+		  ,(make-index-typed (second args))))
+	     (otherwise
+	       `(,operator
+		 ,(make-index-op operator (subseq args 0 (1- (length args))))
+		 ,(make-index-typed (first (last args)))))))))
+
+(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
+(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
+(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
+(defmacro index- (&rest numbers) (make-index-op '- numbers))
+(defmacro index* (&rest numbers) (make-index-op '* numbers))
+
+(defmacro index1+ (number) (make-index-op '1+ (list number)))
+(defmacro index1- (number) (make-index-op '1- (list number)))
+
+(defmacro index-incf (place &optional (delta 1))
+  (make-index-op 'incf (list place delta)))
+(defmacro index-decf (place &optional (delta 1))
+  (make-index-op 'decf (list place delta)))
+
+(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
+(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
+
+(defmacro index-floor (number divisor)
+  (make-index-op 'floor (list number divisor)))
+(defmacro index-ceiling (number divisor)
+  (make-index-op 'ceiling (list number divisor)))
+(defmacro index-truncate (number divisor)
+  (make-index-op 'truncate (list number divisor)))
+
+(defmacro index-mod (number divisor)
+  (make-index-op 'mod (list number divisor)))
+
+(defmacro index-ash (number count)
+  (make-index-op 'ash (list number count)))
+
+(defmacro index-plusp (number) `(plusp (the array-index ,number)))
+(defmacro index-zerop (number) `(zerop (the array-index ,number)))
+(defmacro index-evenp (number) `(evenp (the array-index ,number)))
+(defmacro index-oddp  (number) `(oddp  (the array-index ,number)))
+
+(defmacro index> (&rest numbers)
+  `(> ,@(mapcar #'make-index-typed numbers)))
+(defmacro index= (&rest numbers)
+  `(= ,@(mapcar #'make-index-typed numbers)))
+(defmacro index< (&rest numbers)
+  `(< ,@(mapcar #'make-index-typed numbers)))
+(defmacro index>= (&rest numbers)
+  `(>= ,@(mapcar #'make-index-typed numbers)))
+(defmacro index<= (&rest numbers)
+  `(<= ,@(mapcar #'make-index-typed numbers)))
+
+)
+
+#+Genera
+(progn
+
+(defmacro index+ (&rest numbers) `(+ ,@numbers))
+(defmacro index-logand (&rest numbers) `(logand ,@numbers))
+(defmacro index-logior (&rest numbers) `(logior ,@numbers))
+(defmacro index- (&rest numbers) `(- ,@numbers))
+(defmacro index* (&rest numbers) `(* ,@numbers))
+
+(defmacro index1+ (number) `(1+ ,number))
+(defmacro index1- (number) `(1- ,number))
+
+(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
+(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
+
+(defmacro index-min (&rest numbers) `(min ,@numbers))
+(defmacro index-max (&rest numbers) `(max ,@numbers))
+
+(defun positive-power-of-two-p (x)
+  (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
+
+(defmacro index-floor (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,divisor))
+	(t `(floor ,number ,divisor))))
+
+(defmacro index-ceiling (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
+	 `(si:%fixnum-ceiling ,number ,divisor))
+	(t `(ceiling ,number ,divisor))))
+
+(defmacro index-truncate (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,divisor))
+	(t `(truncate ,number ,divisor))))
+
+(defmacro index-mod (number divisor)
+  (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
+	 `(si:%fixnum-mod ,number ,divisor))
+	(t `(mod ,number ,divisor))))
+
+(defmacro index-ash (number count)
+  (cond ((eql count 0) number)
+	((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,(expt 2 (- count))))
+	((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
+	 `(si:%fixnum-multiply ,number ,(expt 2 count)))
+	(t `(ash ,number ,count))))
+
+(defmacro index-plusp (number) `(plusp ,number))
+(defmacro index-zerop (number) `(zerop ,number))
+(defmacro index-evenp (number) `(evenp ,number))
+(defmacro index-oddp  (number) `(oddp  ,number))
+
+(defmacro index> (&rest numbers) `(> ,@numbers))
+(defmacro index= (&rest numbers) `(= ,@numbers))
+(defmacro index< (&rest numbers) `(< ,@numbers))
+(defmacro index>= (&rest numbers) `(>= ,@numbers))
+(defmacro index<= (&rest numbers) `(<= ,@numbers))
+
+)
+
+;;;; Stuff for BUFFER definition
+
+(defconstant *replysize* 32.)
+
+;; used in defstruct initializations to avoid compiler warnings
+(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
+(declaim (type buffer-bytes *empty-bytes*))
+#+clx-overlapping-arrays
+(progn
+(defvar *empty-words* (make-sequence 'buffer-words 0))
+(declaim (type buffer-words *empty-words*))
+)
+#+clx-overlapping-arrays
+(progn
+(defvar *empty-longs* (make-sequence 'buffer-longs 0))
+(declaim (type buffer-longs *empty-longs*))
+)
+
+(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
+			 (:copier nil) (:predicate nil))
+  (size 0 :type array-index)			;Buffer size
+  ;; Byte (8 bit) input buffer
+  (ibuf8 *empty-bytes* :type buffer-bytes)
+  ;; Word (16bit) input buffer
+  #+clx-overlapping-arrays
+  (ibuf16 *empty-words* :type buffer-words)
+  ;; Long (32bit) input buffer
+  #+clx-overlapping-arrays
+  (ibuf32 *empty-longs* :type buffer-longs)
+  (next nil #-explorer :type #-explorer (or null reply-buffer))
+  (data-size 0 :type array-index)
+  )
+
+(defconstant *buffer-text16-size* 256)
+(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
+
+;; These are here because.
+
+(defparameter *xlib-package* (find-package 'xlib))
+
+(defun xintern (&rest parts)
+  (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
+
+(defparameter *keyword-package* (find-package 'keyword))
+
+(defun kintern (name)
+  (intern (string name) *keyword-package*))
+
+;;; Pseudo-class mechanism.
+
+(defmacro def-clx-class ((name &rest options) &body slots)
+  (let ((clos-package (or (find-package 'clos)
+			  (find-package 'pcl)
+			  (let ((lisp-pkg (find-package 'lisp)))
+			    (and (find-symbol (string 'defclass) lisp-pkg)
+				 lisp-pkg)))))
+    (if clos-package
+	(let ((constructor t)
+	      (constructor-args t)
+	      (include nil)
+	      (print-function nil)
+	      (copier t)
+	      (predicate t))
+	  (dolist (option options)
+	    (ecase (pop option)
+	      (:constructor
+		(setf constructor (pop option))
+		(setf constructor-args (if (null option) t (pop option))))
+	      (:include
+		(setf include (pop option)))
+	      (:print-function
+		(setf print-function (pop option)))
+	      (:copier
+		(setf copier (pop option)))
+	      (:predicate
+		(setf predicate (pop option)))))
+	  (flet ((cintern (&rest symbols)
+		   (intern (apply #'concatenate 'simple-string
+				  (mapcar #'symbol-name symbols))
+			   *package*))
+		 (kintern (symbol)
+		   (intern (symbol-name symbol) (find-package 'keyword)))
+		 (closintern (symbol)
+		   (intern (symbol-name symbol) clos-package)))
+	    (when (eq constructor t)
+	      (setf constructor (cintern 'make- name)))
+	    (when (eq copier t)
+	      (setf copier (cintern 'copy- name)))
+	    (when (eq predicate t)
+	      (setf predicate (cintern name '-p)))
+	    (when include
+	      (setf slots (append (get include 'def-clx-class) slots)))
+	    (let* ((n-slots (length slots))
+		   (slot-names (make-list n-slots))
+		   (slot-initforms (make-list n-slots))
+		   (slot-types (make-list n-slots)))
+	      (dotimes (i n-slots)
+		(let ((slot (elt slots i)))
+		  (setf (elt slot-names i) (pop slot))
+		  (setf (elt slot-initforms i) (pop slot))
+		  (setf (elt slot-types i) (getf slot :type t))))
+	      `(progn
+
+		 (eval-when (compile load eval)
+		   (setf (get ',name 'def-clx-class) ',slots))
+
+		 ;; From here down are the system-specific expansions:
+
+		 ,(cond (clos-package
+			 `(within-definition (,name def-clx-class)
+			    (,(closintern 'defclass)
+			     ,name ,(and include `(,include))
+			     (,@(map 'list
+				     #'(lambda (slot-name slot-initform slot-type)
+					 `(,slot-name
+					   :initform ,slot-initform :type ,slot-type
+					   :accessor ,(cintern name '- slot-name)
+					   ,@(when (and constructor
+							(or (eq constructor-args t)
+							    (member slot-name
+								    constructor-args)))
+					       `(:initarg ,(kintern slot-name)))
+					   ))
+				     slot-names slot-initforms slot-types)))
+			    ,(when constructor
+			       (if (eq constructor-args t)
+				   `(defun ,constructor (&rest args)
+				      (apply #',(closintern 'make-instance)
+					     ',name args))
+				   `(defun ,constructor ,constructor-args
+				      (,(closintern 'make-instance) ',name
+				       ,@(mapcan #'(lambda (slot-name)
+						     (and (member slot-name slot-names)
+							  `(,(kintern slot-name) ,slot-name)))
+						 constructor-args)))))
+			    ,(when predicate
+			       `(defun ,predicate (object)
+				  (typep object ',name)))
+			    ,(when copier
+			       `(,(closintern 'defmethod) ,copier ((.object. ,name))
+				 (,(closintern 'with-slots) ,slot-names .object.
+				  (,(closintern 'make-instance) ',name
+				   ,@(mapcan #'(lambda (slot-name)
+						 `(,(kintern slot-name) ,slot-name))
+					     slot-names)))))
+			    ,(when print-function
+			       `(,(closintern 'defmethod)
+				 ,(closintern 'print-object)
+				 ((object ,name) stream)
+				 (,print-function object stream 0)))))
+
+			#+Genera
+			(t
+			 `(within-definition (,name def-clx-class)
+			    (flavor:defflavor ,name
+				    (,@(map 'list
+					    #'(lambda (slot-name slot-initform)
+						`(,slot-name ,slot-initform))
+					    slot-names slot-initforms))
+				    ,(and include `(,include))
+			      :initable-instance-variables
+			      :locatable-instance-variables
+			      :readable-instance-variables
+			      :writable-instance-variables
+			      ,(if constructor
+				   `(:constructor ,constructor
+				     ,(if (eq constructor-args t)
+					  `(&key ,@slot-names)
+					  constructor-args))
+				   :abstract-flavor))
+			    ,(when predicate
+			       `(defun ,predicate (object)
+				  (typep object ',name)))
+			    ,(when copier
+			       (error ":COPIER not supported."))
+			    ,(when print-function
+			       `(flavor:defmethod (sys:print-self ,name)
+						  (stream depth *print-escape*)
+				  (,print-function sys:self stream depth)))
+			    (flavor:compile-flavor-methods ,name))))))))
+	`(within-definition (,name def-clx-class)
+	   (defstruct (,name ,@options)
+	     ,@slots)))))
+
+#+Genera
+(progn
+  (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
+  (scl:defprop def-clx-class zwei:defselect-function-spec-finder
+	       zwei:definition-function-spec-finder))
+
+
+;; We need this here so we can define DISPLAY for CLX.
+;;
+;; This structure is :INCLUDEd in the DISPLAY structure.
+;; Overlapping (displaced) arrays are provided for byte
+;; half-word and word access on both input and output.
+;;
+(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
+  ;; Lock for multi-processing systems
+  (lock (make-process-lock "CLX Buffer Lock"))
+  #-excl (output-stream nil :type (or null stream))
+  #+excl (output-stream -1 :type fixnum)
+  ;; Buffer size
+  (size 0 :type array-index)
+  (request-number 0 :type (unsigned-byte 16))
+  ;; Byte position of start of last request
+  ;; used for appending requests and error recovery
+  (last-request nil :type (or null array-index))
+  ;; Byte position of start of last flushed request
+  (last-flushed-request nil :type (or null array-index))
+  ;; Current byte offset
+  (boffset 0 :type array-index)
+  ;; Byte (8 bit) output buffer
+  (obuf8 *empty-bytes* :type buffer-bytes)
+  ;; Word (16bit) output buffer
+  #+clx-overlapping-arrays
+  (obuf16 *empty-words* :type buffer-words)
+  ;; Long (32bit) output buffer
+  #+clx-overlapping-arrays
+  (obuf32 *empty-longs* :type buffer-longs)
+  ;; Holding buffer for 16-bit text
+  (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
+  ;; Probably EQ to Output-Stream
+  #-excl (input-stream nil :type (or null stream))
+  #+excl (input-stream -1 :type fixnum)
+  ;; T when the host connection has gotten errors
+  (dead nil :type (or null (not null)))
+  ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
+  (flush-inhibit nil :type (or null (not null)))
+  
+  ;; Change these functions when using shared memory buffers to the server
+  ;; Function to call when writing the buffer
+  (write-function 'buffer-write-default)
+  ;; Function to call when flushing the buffer
+  (force-output-function 'buffer-force-output-default)
+  ;; Function to call when closing a connection
+  (close-function 'buffer-close-default)
+  ;; Function to call when reading the buffer
+  (input-function 'buffer-read-default)
+  ;; Function to call to wait for data to be input
+  (input-wait-function 'buffer-input-wait-default)
+  ;; Function to call to listen for input data
+  (listen-function 'buffer-listen-default)
+
+  #+Genera (debug-io nil :type (or null stream))
+  ) 
+
+;;-----------------------------------------------------------------------------
+;; Printing routines.
+;;-----------------------------------------------------------------------------
+
+#+(and (not ansi-common-lisp) Genera)
+(import 'future-common-lisp:print-unreadable-object)
+
+#-(or ansi-common-lisp Genera)
+(defun print-unreadable-object-function (object stream type identity function)
+  (princ "#<" stream)
+  (when type
+    (let ((type (type-of object))
+	  (pcl-package (find-package 'pcl)))
+      ;; Handle pcl type-of lossage
+      (when (and pcl-package
+		 (symbolp type)
+		 (eq (symbol-package type) pcl-package)
+		 (string-equal (symbol-name type) "STD-INSTANCE"))
+	(setq type
+	      (funcall (intern (symbol-name 'class-name) pcl-package)
+		       (funcall (intern (symbol-name 'class-of) pcl-package)
+				object))))
+      (prin1 type stream)))
+  (when (and type function) (princ " " stream))
+  (when function (funcall function))
+  (when (and (or type function) identity) (princ " " stream))
+  (when identity (princ "???" stream))
+  (princ ">" stream)
+  nil)
+  
+#-(or ansi-common-lisp Genera)
+(defmacro print-unreadable-object
+	  ((object stream &key type identity) &body body)
+  `(print-unreadable-object-function
+     ,object ,stream ,type ,identity
+     ,(and body `#'(lambda () ,@body))))
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+(defconstant *image-bit-lsb-first-p*
+	     #+clx-little-endian t
+	     #-clx-little-endian nil)
+
+(defconstant *image-byte-lsb-first-p*
+	     #+clx-little-endian t
+	     #-clx-little-endian nil)
+
+(defconstant *image-unit* 32)
+
+(defconstant *image-pad* 32)
diff --git a/clx/dependent.lisp b/clx/dependent.lisp
new file mode 100644
index 000000000..b8e5a3d75
--- /dev/null
+++ b/clx/dependent.lisp
@@ -0,0 +1,3064 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;; This file contains some of the system dependent code for CLX
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+#+lcl3.0
+(import '(
+	  lcl:define-condition
+	  lcl:type-error
+	  lucid::type-error-datum
+	  lucid::type-error-expected-type
+	  sys:underlying-simple-vector))
+
+(export '(
+	  char->card8
+	  card8->char
+	  default-error-handler
+	  #-ansi-common-lisp define-condition))
+
+#+explorer
+(zwei:define-indentation event-case (1 1))
+
+;;; Number of seconds to wait for a reply to a server request
+(defparameter *reply-timeout* nil) 
+
+#-(or clx-overlapping-arrays (not clx-little-endian))
+(progn
+  (defconstant *word-0* 0)
+  (defconstant *word-1* 1)
+
+  (defconstant *long-0* 0)
+  (defconstant *long-1* 1)
+  (defconstant *long-2* 2)
+  (defconstant *long-3* 3))
+
+#-(or clx-overlapping-arrays clx-little-endian)
+(progn
+  (defconstant *word-0* 1)
+  (defconstant *word-1* 0)
+
+  (defconstant *long-0* 3)
+  (defconstant *long-1* 2)
+  (defconstant *long-2* 1)
+  (defconstant *long-3* 0))
+
+;;; Set some compiler-options for often used code
+
+(eval-when (eval compile load)
+
+(defconstant *buffer-speed* 3
+  "Speed compiler option for buffer code.")
+(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
+  "Safety compiler option for buffer code.")
+
+(defun declare-bufmac ()
+  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
+
+;;; It's my impression that in lucid there's some way to make a declaration
+;;; called fast-entry or something that causes a function to not do some
+;;; checking on args. Sadly, we have no lucid manuals here.  If such a
+;;; declaration is available, it would be a good idea to make it here when
+;;; *buffer-speed* is 3 and *buffer-safety* is 0.
+(defun declare-buffun ()
+  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
+
+)
+
+(declaim (inline card8->int8 int8->card8
+		 card16->int16 int16->card16
+		 card32->int32 int32->card32))
+
+#-Genera
+(progn
+
+(defun card8->int8 (x)
+  (declare (type card8 x))
+  (declare (values int8))
+  #.(declare-buffun)
+  (the int8 (if (logbitp 7 x)
+		(the int8 (- x #x100))
+	      x)))
+
+(defun int8->card8 (x)
+  (declare (type int8 x))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (ldb (byte 8 0) x)))
+
+(defun card16->int16 (x)
+  (declare (type card16 x))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16 (if (logbitp 15 x)
+		 (the int16 (- x #x10000))
+		 x)))
+
+(defun int16->card16 (x)
+  (declare (type int16 x))
+  (declare (values card16))
+  #.(declare-buffun)
+  (the card16 (ldb (byte 16 0) x)))
+
+(defun card32->int32 (x)
+  (declare (type card32 x))
+  (declare (values int32))
+  #.(declare-buffun)
+  (the int32 (if (logbitp 31 x)
+		 (the int32 (- x #x100000000))
+		 x)))
+
+(defun int32->card32 (x)
+  (declare (type int32 x))
+  (declare (values card32))
+  #.(declare-buffun)
+  (the card32 (ldb (byte 32 0) x)))
+
+)
+
+#+Genera
+(progn
+
+(defun card8->int8 (x)
+  (declare lt:(side-effects simple reducible))
+  (if (logbitp 7 x) (- x #x100) x))
+
+(defun int8->card8 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 8 0) x))
+
+(defun card16->int16 (x)
+  (declare lt:(side-effects simple reducible))
+  (if (logbitp 15 x) (- x #x10000) x))
+
+(defun int16->card16 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 16 0) x))
+
+(defun card32->int32 (x)
+  (declare lt:(side-effects simple reducible))
+  (sys:%logldb (byte 32 0) x))
+
+(defun int32->card32 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 32 0) x))
+
+)
+
+(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
+
+#-(or Genera lcl3.0)
+(progn
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (aref a i)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a i) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int8))
+  #.(declare-buffun)
+  (card8->int8 (aref a i)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a i) (int8->card8 v)))
+
+)
+
+#+Genera
+(progn
+
+(defun aref-card8 (a i)
+  (aref a i))
+
+(defun aset-card8 (v a i)
+  (zl:aset v a i))
+
+(defun aref-int8 (a i)
+  (card8->int8 (aref a i)))
+
+(defun aset-int8 (v a i)
+  (zl:aset (int8->card8 v) a i))
+
+)
+
+#+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too
+         ;many conditionalizations makes my brain hurt.
+(progn
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (sys:svref-8bit a i)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:svref-8bit a i) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int8))
+  #.(declare-buffun)
+  (the int8 (sys:svref-signed-8bit a i)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:svref-signed-8bit a i) v))
+
+)
+
+#+clx-overlapping-arrays
+(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
+		 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
+
+#+(and clx-overlapping-arrays Genera)
+(progn
+
+(defun aref-card16 (a i)
+  (aref a i))
+
+(defun aset-card16 (v a i)
+  (zl:aset v a i))
+
+(defun aref-int16 (a i)
+  (card16->int16 (aref a i)))
+
+(defun aset-int16 (v a i)
+  (zl:aset (int16->card16 v) a i)
+  v)
+
+(defun aref-card32 (a i)
+  (int32->card32 (aref a i)))
+
+(defun aset-card32 (v a i)
+  (zl:aset (card32->int32 v) a i))
+
+(defun aref-int32 (a i) (aref a i))
+
+(defun aset-int32 (v a i)
+  (zl:aset v a i))
+
+(defun aref-card29 (a i)
+  (aref a i))
+
+(defun aset-card29 (v a i)
+  (zl:aset v a i))
+
+)
+
+#+(and clx-overlapping-arrays (not Genera))
+(progn
+
+(defun aref-card16 (a i)
+  (aref a i))
+
+(defun aset-card16 (v a i)
+  (setf (aref a i) v))
+
+(defun aref-int16 (a i)
+  (card16->int16 (aref a i)))
+
+(defun aset-int16 (v a i)
+  (setf (aref a i) (int16->card16 v))
+  v)
+
+(defun aref-card32 (a i)
+  (aref a i))
+
+(defun aset-card32 (v a i)
+  (setf (aref a i) v))
+
+(defun aref-int32 (a i)
+  (card32->int32 (aref a i)))
+
+(defun aset-int32 (v a i)
+  (setf (aref a i) (int32->card32 v))
+  v)
+
+(defun aref-card29 (a i)
+  (aref a i))
+
+(defun aset-card29 (v a i)
+  (setf (aref a i) v))
+
+)
+
+#+excl
+(progn
+  
+  (defun aref-card16 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card16))
+    #.(declare-buffun)
+    (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-word)))
+  
+  (defun aset-card16 (v a i)
+    (declare (type card16 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-word) v))
+  
+  (defun aref-int16 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values int16))
+    #.(declare-buffun)
+    (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			   :signed-word)))
+  
+  (defun aset-int16 (v a i)
+    (declare (type int16 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :signed-word) v))
+  
+  (defun aref-card32 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card32))
+    #.(declare-buffun)
+    (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-long)))
+    
+  (defun aset-card32 (v a i)
+    (declare (type card32 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-long) v))
+
+  (defun aref-int32 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values int32))
+    #.(declare-buffun)
+    (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			   :signed-long)))
+    
+  (defun aset-int32 (v a i)
+    (declare (type int32 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :signed-long) v))
+
+  (defun aref-card29 (a i)
+    ;; Do I need to mask off a few bits here?  XXX
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card29))
+    #.(declare-buffun)
+    (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-long)))
+
+  (defun aset-card29 (v a i)
+    (declare (type card29 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-long) v))
+
+  
+)
+
+#+lcl3.0
+(progn ;; all these lucid optimizations need to be compiled to work.
+
+(defun aref-card16 (a i)
+  #.(declare-buffun)
+  (the card16 (sys:svref-16bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -1))))
+  
+(defun aset-card16 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-16bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -1))
+	(the card16 v)))
+  
+(defun aref-int16 (a i)
+  #.(declare-buffun)
+  (the int16 
+       (sys:svref-signed-16bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -1))))
+  
+(defun aset-int16 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-signed-16bit (the buffer-bytes a)
+				(lucid:ash& (the array-index i) -1))
+	(the int16 v)))
+
+(defun aref-card32 (a i)
+  #.(declare-buffun)
+  (the card32
+       (sys:svref-32bit (the buffer-bytes a)
+			(lucid:ash& (the array-index i) -2))))
+    
+(defun aset-card32 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-32bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -2))
+	(the card32 v)))
+
+(defun aref-int32 (a i)
+  #.(declare-buffun)
+  (the int32
+       (sys:svref-signed-32bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -2))))
+    
+(defun aset-int32 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-signed-32bit (the buffer-bytes a)
+				(lucid:ash& (the array-index i) -2))
+	(the int32 v)))
+
+(defun aref-card29 (a i)
+  ;; Don't need to mask bits here since X protocol guarantees top bits zero
+  #.(declare-buffun)
+  (the card29
+       (sys:svref-32bit (the buffer-bytes a)
+			(lucid:ash& (the array-index i) -2))))
+
+(defun aset-card29 (v a i)
+  ;; I also assume here Lisp is passing a number that fits in 29 bits.
+  #.(declare-buffun)
+  (setf (sys:svref-32bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -2))
+	(the card29 v)))
+)
+
+
+
+#-(or excl lcl3.0 clx-overlapping-arrays)
+(progn
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card16))
+  #.(declare-buffun)
+  (the card16
+       (logior (the card16
+		    (ash (the card8 (aref a (index+ i *word-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *word-0*))))))
+
+(defun aset-card16 (v a i)
+  (declare (type card16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-int16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16
+       (logior (the int16
+		    (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *word-0*))))))
+
+(defun aset-int16 (v a i)
+  (declare (type int16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-card32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card32))
+  #.(declare-buffun)
+  (the card32
+       (logior (the card32
+		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-card32 (v a i)
+  (declare (type card32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-int32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int32))
+  #.(declare-buffun)
+  (the int32
+       (logior (the int32
+		    (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-int32 (v a i)
+  (declare (type int32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-card29 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card29))
+  #.(declare-buffun)
+  (the card29
+       (logior (the card29
+		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-card29 (v a i)
+  (declare (type card29 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+)
+
+(defsetf aref-card8 (a i) (v)
+  `(aset-card8 ,v ,a ,i))
+
+(defsetf aref-int8 (a i) (v)
+  `(aset-int8 ,v ,a ,i))
+
+(defsetf aref-card16 (a i) (v)
+  `(aset-card16 ,v ,a ,i))
+
+(defsetf aref-int16 (a i) (v)
+  `(aset-int16 ,v ,a ,i))
+
+(defsetf aref-card32 (a i) (v)
+  `(aset-card32 ,v ,a ,i))
+
+(defsetf aref-int32 (a i) (v)
+  `(aset-int32 ,v ,a ,i))
+
+(defsetf aref-card29 (a i) (v)
+  `(aset-card29 ,v ,a ,i))
+
+;;; Other random conversions
+
+(defun rgb-val->card16 (value)
+  ;; Short floats are good enough
+  (declare (type rgb-val value))
+  (declare (values card16))
+  #.(declare-buffun)
+  ;; Convert VALUE from float to card16
+  (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
+
+(defun card16->rgb-val (value) 
+  ;; Short floats are good enough
+  (declare (type card16 value))
+  (declare (values short-float))
+  #.(declare-buffun)
+  ;; Convert VALUE from card16 to float
+  (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
+
+(defun radians->int16 (value)
+  ;; Short floats are good enough
+  (declare (type angle value))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
+
+(defun int16->radians (value)
+  ;; Short floats are good enough
+  (declare (type int16 value))
+  (declare (values short-float))
+  #.(declare-buffun)
+  (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
+
+
+;;-----------------------------------------------------------------------------
+;; Character transformation
+;;-----------------------------------------------------------------------------
+
+
+;;; This stuff transforms chars to ascii codes in card8's and back.
+;;; You might have to hack it a little to get it to work for your machine.
+
+(declaim (inline char->card8 card8->char))
+
+(macrolet ((char-translators ()
+	     (let ((alist
+		     `(#-lispm
+		       ;; The normal ascii codes for the control characters.
+		       ,@`((#\Return . 13)
+			   (#\Linefeed . 10)
+			   (#\Rubout . 127)
+			   (#\Page . 12)
+			   (#\Tab . 9)
+			   (#\Backspace . 8)
+			   (#\Newline . 10)
+			   (#\Space . 32))
+		       ;; One the lispm, #\Newline is #\Return, but we'd really like
+		       ;; #\Newline to translate to ascii code 10, so we swap the
+		       ;; Ascii codes for #\Return and #\Linefeed. We also provide
+		       ;; mappings from the counterparts of these control characters
+		       ;; so that the character mapping from the lisp machine
+		       ;; character set to ascii is invertible.
+		       #+lispm
+		       ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
+			   (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
+			   (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
+			   (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
+			   (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
+			   (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
+			   (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
+			   (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
+		       ;; The rest of the common lisp charater set with the normal
+		       ;; ascii codes for them.
+		       (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
+		       (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
+		       (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
+		       (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
+		       (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
+		       (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
+		       (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
+		       (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
+		       (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
+		       (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
+		       (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
+		       (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
+		       (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
+		       (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
+		       (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
+		       (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
+		       (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
+		       (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
+		       (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
+		       (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
+		       (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
+		       (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
+		       (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
+		       (#\} . 125) (#\~ . 126))))
+	       (cond ((dolist (pair alist nil)
+			(when (not (= (char-code (car pair)) (cdr pair)))
+			  (return t)))
+		      `(progn
+			 (defconstant *char-to-card8-translation-table*
+				      ',(let ((array (make-array
+						       (let ((max-char-code 255))
+							 (dolist (pair alist)
+							   (setq max-char-code
+								 (max max-char-code
+								      (char-code (car pair)))))
+							 (1+ max-char-code))
+						       :element-type 'card8)))
+					  (dotimes (i (length array))
+					    (setf (aref array i) (mod i 256)))
+					  (dolist (pair alist)
+					    (setf (aref array (char-code (car pair)))
+						  (cdr pair)))
+					  array))
+			 (defconstant *card8-to-char-translation-table*
+				      ',(let ((array (make-string 256)))
+					  (dotimes (i (length array))
+					    (setf (aref array i) (code-char i)))
+					  (dolist (pair alist)
+					    (setf (aref array (cdr pair)) (car pair)))
+					  array))
+			 #-Genera
+			 (progn
+  			   (defun char->card8 (char)
+			     (declare (type string-char char))
+			     #.(declare-buffun)
+			     (the card8 (aref (the (simple-array card8 (*))
+						   *char-to-card8-translation-table*)
+					      (the array-index (char-code char)))))
+			   (defun card8->char (card8)
+			     (declare (type card8 card8))
+			     #.(declare-buffun)
+			     (the string-char
+				  (aref (the simple-string *card8-to-char-translation-table*)
+					card8)))
+			   )
+			 #+Genera
+			 (progn
+			   (defun char->card8 (char)
+			     (declare lt:(side-effects reader reducible))
+			     (aref *char-to-card8-translation-table* (char-code char)))
+			   (defun card8->char (card8)
+			     (declare lt:(side-effects reader reducible))
+			     (aref *card8-to-char-translation-table* card8))
+			   )
+			 (dotimes (i 256)
+			   (unless (= i (char->card8 (card8->char i)))
+			     (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
+				   (list i
+					 (card8->char i)
+					 (char->card8 (card8->char i))))
+			     (return nil)))
+			 (dotimes (i (length *char-to-card8-translation-table*))
+			   (let ((char (code-char i)))
+			     (unless (eql char (card8->char (char->card8 char)))
+			       (warn "The char->card8 mapping is not invertible through card8->char.  Info:~%~S"
+				     (list char
+					   (char->card8 char)
+					   (card8->char (char->card8 char))))
+			       (return nil))))))
+		     (t
+		      `(progn
+			 (defun char->card8 (char)
+			   (declare (type string-char char))
+			   #.(declare-buffun)
+			   (the card8 (char-code char)))
+			 (defun card8->char (card8)
+			   (declare (type card8 card8))
+			   #.(declare-buffun)
+			   (the string-char (code-char card8)))
+			 ))))))
+  (char-translators))
+
+;;-----------------------------------------------------------------------------
+;; Process Locking
+;;
+;;	Common-Lisp doesn't provide process locking primitives, so we define
+;;	our own here, based on Zetalisp primitives.  Holding-Lock is very
+;;	similar to with-lock on The TI Explorer, and a little more efficient
+;;	than with-process-lock on a Symbolics.
+;;-----------------------------------------------------------------------------
+
+;;; MAKE-PROCESS-LOCK: Creating a process lock.
+
+#-(or LispM excl)
+(defun make-process-lock (name)
+  (declare (ignore name))
+  nil)
+
+#+excl
+(defun make-process-lock (name)
+  (mp:make-process-lock :name name))
+
+#+(and LispM (not Genera))
+(defun make-process-lock (name)
+  (vector nil name))
+
+#+Genera
+(defun make-process-lock (name)
+  (process:make-lock name :flavor 'clx-lock))
+
+;;; HOLDING-LOCK: Execute a body of code with a lock held.
+
+;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
+;;; passes its timeout to the holding-lock macro, so any timeout you want to
+;;; work for event-listen you should do for holding-lock.
+
+;; If you're not sharing DISPLAY objects within a multi-processing
+;; shared-memory environment, this is sufficient
+#-(or lispm excl lcl3.0)
+(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
+  (declare (ignore locator display whostate timeout))
+  `(progn ,@body))
+
+#+Genera
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore whostate))
+  `(process:with-lock (,locator :timeout ,timeout)
+     (let ((.debug-io. (buffer-debug-io ,display)))
+       (scl:let-if .debug-io. ((*debug-io* .debug-io.))
+	 ,@body))))
+
+#+(and lispm (not Genera))
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  ;; This macro is for use in a multi-process environment.
+  (let ((lock (gensym))
+	(have-lock (gensym))
+	(timeo (gensym)))
+    `(let* ((,lock (zl:locf (svref ,locator 0)))
+	    (,have-lock (eq (car ,lock) sys:current-process))
+	    (,timeo ,timeout))
+       (unwind-protect 
+	   (when (cond (,have-lock)
+		       ((#+explorer si:%store-conditional
+			 #-explorer sys:store-conditional
+			 ,lock nil sys:current-process))
+		       ((null ,timeo)
+			(sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
+		       ((sys:process-wait-with-timeout
+			    ,(or whostate "CLX Lock") (round (* ,timeo 60.))
+			  #'(lambda (lock process)
+			      (#+explorer si:%store-conditional
+			       #-explorer sys:store-conditional
+			       lock nil process))
+			  ,lock sys:current-process)))
+	     ,@body)
+	 (unless ,have-lock
+	   (#+explorer si:%store-conditional
+	    #-explorer sys:store-conditional
+	    ,lock sys:current-process nil))))))
+
+;; Lucid has a process locking mechanism as well under release 3.0
+#+lcl3.0
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  (if timeout
+      ;; Hair to support timeout.
+      `(let ((.have-lock. (eq ,locator lcl:*current-process*))
+	     (.timeout. ,timeout))
+	 (unwind-protect
+	     (when (cond (.have-lock.)
+			 ((conditional-store ,locator nil lcl:*current-process*))
+			 ((null .timeout.)
+			  (lcl:process-lock ,locator)
+			  t)
+			 ((lcl:process-wait-with-timeout ,whostate .timeout.
+			    #'(lambda ()
+				(conditional-store ,locator nil lcl:*current-process*)))))
+	       ,@body)
+	   (unless .have-lock. 
+	     (lcl:process-unlock ,locator))))
+    `(lcl:with-process-lock (,locator)
+       ,@body)))
+
+
+#+excl
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
+     (unwind-protect
+	 (block .hl-doit.
+	   (when mp::*scheduler-stack-group* ; fast test for scheduler running
+	     (setq .hl-lock. ,locator
+		   .hl-curproc. mp::*current-process*)
+	     (when (and .hl-curproc.	; nil if in process-wait fun
+			(not (eq (mp::process-lock-locker .hl-lock.)
+				 .hl-curproc.)))
+	       ;; Then we need to grab the lock.
+	       ,(if timeout
+		    `(if (not (mp::process-lock .hl-lock. .hl-curproc.
+						,whostate ,timeout))
+			 (return-from .hl-doit. nil))
+		  `(mp::process-lock .hl-lock. .hl-curproc.
+				     ,@(when whostate `(,whostate))))
+	       (setq .hl-obtained-lock. t)))
+	   ,@body)
+       (if (and .hl-obtained-lock.
+		;; Note -- next form added to allow error handler inside
+		;; body to unlock the lock prematurely if it knows that
+		;; the current process cannot possibly continue but will
+		;; throw out (or is it throw up?).
+		(eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
+	   (mp::process-unlock .hl-lock. .hl-curproc.)))))
+
+
+;;; WITHOUT-ABORTS
+
+;;; If you can inhibit asynchronous keyboard aborts inside the body of this
+;;; macro, then it is a good idea to do this.  This macro is wrapped around
+;;; request writing and reply reading to ensure that requests are atomically
+;;; written and replies are atomically read from the stream.
+
+#-(or Genera excl lcl3.0)
+(defmacro without-aborts (&body body)
+  `(progn ,@body))
+
+#+Genera
+(defmacro without-aborts (&body body)
+  `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
+     ,@body))
+
+#+excl
+(defmacro without-aborts (&body body)
+  `(without-interrupts ,@body))
+    
+#+lcl3.0
+(defmacro without-aborts (&body body)
+  `(lcl:with-interruptions-inhibited ,@body))
+
+;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
+;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
+;;; value changes.
+
+#-(or lispm excl lcl3.0)
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (ignore whostate))
+  (or (apply predicate predicate-args)
+      (error "Program tried to wait with no scheduler.")))
+
+#+Genera
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (apply #'process:block-process whostate predicate predicate-args))
+
+#+(and lispm (not Genera))
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (apply #'global:process-wait whostate predicate predicate-args))
+
+#+excl
+(defun process-block (whostate predicate &rest predicate-args)
+  (if mp::*scheduler-stack-group*
+      (apply #'mp::process-wait whostate predicate predicate-args)
+      (or (apply predicate predicate-args)
+	  (error "Program tried to wait with no scheduler."))))
+
+#+lcl3.0
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (dynamic-extent predicate-args))
+  (apply #'lcl:process-wait whostate predicate predicate-args))
+
+;;; PROCESS-WAKEUP: Check some other process' wait function.
+
+(declaim (inline process-wakeup))
+
+#-(or excl Genera)
+(defun process-wakeup (process)
+  (declare (ignore process))
+  nil)
+
+#+excl
+(defun process-wakeup (process)
+  (let ((curproc mp::*current-process*))
+    (when (and curproc process)
+      (unless (mp::process-p curproc)
+	(error "~s is not a process" curproc))
+      (unless (mp::process-p process)
+	(error "~s is not a process" process))
+      (if (> (mp::process-priority process) (mp::process-priority curproc))
+	  (mp::process-allow-schedule process)))))
+
+#+Genera
+(defun process-wakeup (process)
+  (process:wakeup process))
+
+;;; CURRENT-PROCESS: Return the current process object for input locking and
+;;; for calling PROCESS-WAKEUP.
+
+(declaim (inline current-process))
+
+;;; Default return NIL, which is acceptable even if there is a scheduler.
+
+#-(or lispm excl lcl3.0)
+(defun current-process ()
+  nil)
+
+#+lispm
+(defun current-process ()
+  sys:current-process)
+
+#+excl
+(defun current-process ()
+  (and mp::*scheduler-stack-group*
+       mp::*current-process*))
+
+#+lcl3.0
+(defun current-process ()
+  lcl:*current-process*)
+
+;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
+
+#-(or lispm excl lcl3.0)
+(defmacro without-interrupts (&body body)
+  `(progn ,@body))
+
+#+(and lispm (not Genera))
+(defmacro without-interrupts (&body body)
+  `(sys:without-interrupts ,@body))
+
+#+Genera
+(defmacro without-interrupts (&body body)
+  `(process:with-no-other-processes ,@body))
+
+#+LCL3.0
+(defmacro without-interrupts (&body body)
+  `(lcl:with-scheduling-inhibited ,@body))
+
+;;; CONDITIONAL-STORE:
+
+;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
+;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
+(defmacro conditional-store (place old-value new-value)
+  `(without-interrupts
+     (cond ((eq ,place ,old-value)
+	    (setf ,place ,new-value)
+	    t))))
+
+;;;----------------------------------------------------------------------------
+;;; IO Error Recovery
+;;;	All I/O operations are done within a WRAP-BUF-OUTPUT macro.
+;;;	It prevents multiple mindless errors when the network craters.
+;;;
+;;;----------------------------------------------------------------------------
+
+#-Genera
+(defmacro wrap-buf-output ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(unless (buffer-dead ,buffer)
+     ,@body))
+
+#+Genera
+(defmacro wrap-buf-output ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(let ((.buffer. ,buffer))
+     (unless (buffer-dead .buffer.)
+       (scl:condition-bind
+	 (((sys:network-error)
+	   #'(lambda (error)
+	       (scl:condition-case () 
+		    (funcall (buffer-close-function .buffer.) .buffer. :abort t)
+		  (sys:network-error))
+	       (setf (buffer-dead .buffer.) error)
+	       (setf (buffer-output-stream .buffer.) nil)
+	       (setf (buffer-input-stream .buffer.) nil)
+	       nil)))
+	 ,@body))))
+
+#-Genera
+(defmacro wrap-buf-input ((buffer) &body body)
+  (declare (ignore buffer))
+  ;; Error recovery wrapper
+  `(progn ,@body))
+
+#+Genera
+(defmacro wrap-buf-input ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(let ((.buffer. ,buffer))
+     (scl:condition-bind
+       (((sys:network-error)
+	 #'(lambda (error)
+	     (scl:condition-case () 
+		  (funcall (buffer-close-function .buffer.) .buffer. :abort t)
+		(sys:network-error))
+	     (setf (buffer-dead .buffer.) error)
+	     (setf (buffer-output-stream .buffer.) nil)
+	     (setf (buffer-input-stream .buffer.) nil)
+	     nil)))
+       ,@body)))
+
+
+;;;----------------------------------------------------------------------------
+;;; System dependent IO primitives
+;;;	Functions for opening, reading writing forcing-output and closing 
+;;;	the stream to the server.
+;;;----------------------------------------------------------------------------
+
+;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
+;;; server
+
+#-(or explorer Genera lucid kcl ibcl excl)
+(defun open-x-stream (host display protocol)
+  host display protocol ;; unused
+  (error "OPEN-X-STREAM not implemented yet."))
+
+;;; Genera:
+
+;;; TCP and DNA are both layered products, so try to work with either one.
+
+#+Genera
+(when (fboundp 'tcp:add-tcp-port-for-protocol)
+  (tcp:add-tcp-port-for-protocol :x-window-system 6000))
+
+#+Genera
+(when (fboundp 'dna:add-dna-contact-id-for-protocol)
+  (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
+
+#+Genera
+(net:define-protocol :x-window-system (:x-window-system :byte-stream)
+  (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
+    stream))
+
+#+Genera
+(eval-when (compile)
+  (compiler:function-defined 'tcp:open-tcp-stream)
+  (compiler:function-defined 'dna:open-dna-bidirectional-stream))
+
+#+Genera
+(defun open-x-stream (host display protocol)
+  (let ((host (net:parse-host host)))
+    (if (or protocol (plusp display))
+	;; The protocol was specified or the display isn't 0, so we
+	;; can't use the Generic Network System.  If the protocol was
+	;; specified, then use that protocol, otherwise, blindly use
+	;; TCP.
+	(ccase protocol
+	  ((:tcp nil)
+	   (tcp:open-tcp-stream
+	     host (+ *x-tcp-port* display) nil
+	     :direction :io
+	     :characters nil
+	     :ascii-translation nil))
+	  ((:dna)
+	   (dna:open-dna-bidirectional-stream
+	     host (format nil "X$X~D" display)
+	     :characters nil
+	     :ascii-translation nil)))
+      (let ((neti:*invoke-service-automatic-retry* t))
+	(net:invoke-service-on-host :x-window-system host)))))
+
+#+explorer
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol))
+  (net:open-connection-on-medium
+    (net:parse-host host)			;Host
+    :byte-stream				;Medium
+    "X11"					;Logical contact name
+    :stream-type :character-stream
+    :direction :bidirectional
+    :timeout-after-open nil
+    :remote-port (+ *x-tcp-port* display)))
+
+#+explorer
+(net:define-logical-contact-name
+  "X11"
+  `((:local "X11")
+    (:chaos "X11")
+    (:nsp-stream "X11")
+    (:tcp ,*x-tcp-port*)))
+
+#+lucid
+(defun open-x-stream (host display protocol)
+  protocol ;; unused
+  (let ((fd (connect-to-server host display)))
+    (when (minusp fd)
+      (error "Failed to connect to server: ~A ~D" host display))
+    (user::make-lisp-stream :input-handle fd
+			    :output-handle fd
+			    :element-type 'unsigned-byte
+			    #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
+
+#+(or kcl ibcl)
+(defun open-x-stream (host display protocol)
+  protocol ;; unused
+  (let ((stream (open-socket-stream host display)))
+    (if (streamp stream)
+	stream
+      (error "Cannot connect to server: ~A:~D" host display))))
+
+#+excl
+;;
+;; Note that since we don't use the CL i/o facilities to do i/o, the display
+;; input and output "stream" is really a file descriptor (fixnum).
+;;
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol));; unused
+  (let ((fd (connect-to-server (string host) display)))
+    (when (minusp fd)
+      (error "Failed to connect to server: ~A ~D" host display))
+    fd))
+
+;;; BUFFER-READ-DEFAULT - read data from the X stream
+
+#+(or Genera explorer)
+(defun buffer-read-default (display vector start end timeout)
+  ;; returns non-NIL if EOF encountered
+  ;; Returns :TIMEOUT when timeout exceeded
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (or (cond ((null stream))
+	      ((funcall stream :listen) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(multiple-value-bind (ignore eofp)
+	    (funcall stream :string-in nil vector start end)
+	  eofp))))
+
+
+#+excl
+;;
+;; Rewritten 10/89 to not use foreign function interface to do I/O.
+;;
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout))
+  #.(declare-buffun)
+    
+  (let* ((howmany (- end start))
+	 (fd (display-input-stream display)))
+    (declare (type array-index howmany)
+	     (fixnum fd))
+	  
+    (or (cond ((fd-char-avail-p fd) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(fd-read-bytes fd vector start howmany))))
+
+
+#+lcl3.0
+(defmacro extract-underlying-stream (stream display direction)
+  ;;;Our job is to quickly get at the underlying stream for this display's
+  ;;;input stream structure.
+  `(or (getf (display-plist ,display) ,direction)
+       (setf (getf (display-plist ,display) ,direction)
+	     (lucid::underlying-stream
+	       ,stream (if (eq ,direction 'input) :input :output)))))
+
+#+lcl3.0
+(defun buffer-read-default (display vector start end timeout)
+  ;;Note that LISTEN must still be done on "slow stream" or the I/O system
+  ;;gets confused.  But reading should be done from "fast stream" for speed.
+  ;;We used to inhibit scheduling because there were races in Lucid's 
+  ;;multitasking system.  Empirical evidence suggests they may be gone now.
+  ;;Should you decide you need to inhibit scheduling, do it around the do*.
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout)
+	   (optimize (speed 3)
+		     (safety 0)))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(let ((stream (extract-underlying-stream stream display 'input)))
+	  (do* ((index start (index1+ index)))
+	       ((index>= index end) nil)
+	    (declare (type array-index index))
+	    (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil)))
+	      (declare (type (or null card8) c))
+	      (if (null c)
+		  (return t)
+		  (setf (aref vector index) (the card8 c)))))))))
+
+
+
+;;; WARNING:
+;;;	CLX performance will suffer if your lisp uses read-byte for
+;;;	receiving all data from the X Window System server.
+;;;	You are encouraged to write a specialized version of
+;;;	buffer-read-default that does block transfers.
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null (rational 0 *) (float 0.0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(do* ((index start (index1+ index)))
+	     ((index>= index end) nil)
+	  (declare (type array-index index))
+	  (let ((c (read-byte stream nil nil)))
+	    (declare (type (or null card8) c))
+	    (if (null c)
+		(return t)
+	      (setf (aref vector index) (the card8 c))))))))
+
+;;; BUFFER-WRITE-DEFAULT - write data to the X stream
+
+#+(or Genera explorer)
+(defun buffer-write-default (vector display start end)
+  ;; The default buffer write function for use with common-lisp streams
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream) 
+      (write-string vector stream :start start :end end))))
+
+#+excl
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (excl::filesys-write-bytes (display-output-stream display) vector start
+			     (- end start)))
+  
+#+lcl3.0
+(defun buffer-write-default (vector display start end)
+  ;;We inhibit scheduling here because there seem to be races in Lucid's
+  ;;multitasking implementation.  Anyway, when we take it out we get bugs!
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (optimize (:tail-merge nil)
+		     (speed 3)
+		     (safety 0)))
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream) 
+      (let ((stream (extract-underlying-stream stream display 'output)))
+	(lcl:with-scheduling-inhibited
+          (lcl:write-array stream vector start end))))))
+
+;;; WARNING:
+;;;	CLX performance will be severely degraded if your lisp uses
+;;;	write-byte to send all data to the X Window System server.
+;;;	You are STRONGLY encouraged to write a specialized version
+;;;	of buffer-write-default that does block transfers.
+
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-write-default (vector display start end)
+  ;; The default buffer write function for use with common-lisp streams
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (with-vector (vector buffer-bytes)
+	(do ((index start (index1+ index)))
+	    ((index>= index end))
+	  (declare (type array-index index))
+	  (write-byte (aref vector index) stream))))))
+
+;;; buffer-force-output-default - force output to the X stream
+
+#+excl
+(defun buffer-force-output-default (display)
+  ;; buffer-write-default does the actual writing.
+  (declare (ignore display)))
+
+#-excl
+(defun buffer-force-output-default (display)
+  ;; The default buffer force-output function for use with common-lisp streams
+  (declare (type display display))
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (force-output stream))))
+
+;;; BUFFER-CLOSE-DEFAULT - close the X stream
+
+#+excl
+(defun buffer-close-default (display &key abort)
+  ;; The default buffer close function for use with common-lisp streams
+  (declare (type display display)
+	   (ignore abort))
+  #.(declare-buffun)
+  (excl::filesys-checking-close (display-output-stream display)))
+
+#-excl
+(defun buffer-close-default (display &key abort)
+  ;; The default buffer close function for use with common-lisp streams
+  (declare (type display display))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (close stream :abort abort))))
+
+;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
+;;; buffer.  This is called in read-input between requests, so that a process
+;;; waiting for input is abortable when between requests.  Should return
+;;; :TIMEOUT if it times out, NIL otherwise.
+
+;;; The default implementation
+
+;; Poll for input every *buffer-read-polling-time* SECONDS.
+#-(or Genera explorer excl lcl3.0)
+(defparameter *buffer-read-polling-time* 0.5)
+
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((eql timeout 0) :timeout)
+	  ((not (null timeout))
+	   (multiple-value-bind (npoll fraction)
+	       (truncate timeout *buffer-read-polling-time*)
+	     (dotimes (i npoll)			; Sleep for a time, then listen again
+	       (sleep *buffer-read-polling-time*)
+	       (when (listen stream)
+		 (return-from buffer-input-wait-default nil)))
+	     (when (plusp fraction)
+	       (sleep fraction)			; Sleep a fraction of a second
+	       (when (listen stream)		; and listen one last time
+		 (return-from buffer-input-wait-default nil)))
+	     :timeout)))))
+
+#+Genera
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((scl:send stream :listen) nil)
+	  ((eql timeout 0) :timeout)
+	  ((null timeout) (si:stream-input-block stream "CLX Input"))
+	  (t
+	   (scl:condition-bind ((neti:protocol-timeout
+				  #'(lambda (error)
+				      (when (eq stream (scl:send error :stream))
+					(return-from buffer-input-wait-default :timeout)))))
+	     (neti:with-stream-timeout (stream :input timeout)
+	       (si:stream-input-block stream "CLX Input")))))
+    nil))
+
+#+explorer
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((zl:send stream :listen) nil)
+	  ((eql timeout 0) :timeout)
+	  ((null timeout)
+	   (si:process-wait "CLX Input" stream :listen))
+	  (t
+	   (unless (si:process-wait-with-timeout
+		       "CLX Input" (round (* timeout 60.)) stream :listen)
+	     (return-from buffer-input-wait-default :timeout))))
+    nil))
+
+#+excl
+;;
+;; This is used so an 'eq' test may be used to find out whether or not we can
+;; safely throw this process out of the CLX read loop.
+;;
+(defparameter *read-whostate* "blocked on read from X server")
+
+;;
+;; Note that this function returns nil on error if the scheduler is running,
+;; t on error if not.  This is ok since buffer-read will detect the error.
+;;
+#+excl
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((fd (display-input-stream display)))
+    (declare (fixnum fd))
+    (when (>= fd 0)
+      (cond ((fd-char-avail-p fd)
+	     nil)
+	    
+	    ;; Otherwise no bytes were available on the socket
+	    ((and timeout (zerop timeout))
+	     ;; If there aren't enough and timeout == 0, timeout.
+	     :timeout)
+	  
+	    ;; If the scheduler is running let it do timeouts.
+	    (mp::*scheduler-stack-group*
+	     #+allegro
+	     (if (not
+		  (mp:wait-for-input-available fd :whostate *read-whostate*
+					       :wait-function #'fd-char-avail-p
+					       :timeout timeout))
+		 (return-from buffer-input-wait-default :timeout))
+	     #-allegro
+	     (mp::wait-for-input-available fd :whostate *read-whostate*
+					   :wait-function #'fd-char-avail-p))
+	    
+	    ;; Otherwise we have to handle timeouts by hand, and call select()
+	    ;; to block until input is available.  Note we don't really handle
+	    ;; the interaction of interrupts and (numberp timeout) here.  XX
+	    (t
+	     (let ((res 0))
+	       (declare (fixnum res))
+	       (with-interrupt-checking-on
+		(loop
+		  (setq res (fd-wait-for-input fd (if (null timeout) 0
+						    (truncate timeout))))
+		  (cond ((plusp res)	; success
+			 (return nil))
+			((eq res 0)	; timeout
+			 (return :timeout))
+			((eq res -1)	; error
+			 (return t))
+			;; Otherwise we got an interrupt -- go around again.
+			)))))))))
+
+	   
+#+lcl3.0
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (optimize (speed 3) (safety 0)))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((eql timeout 0) :timeout)
+	  ((let ((stream (extract-underlying-stream stream display 'input)))
+	     (lucid::waiting-for-input-from-stream stream
+               (lucid::with-io-unlocked
+		 (if (null timeout)
+		     (lcl:process-wait "CLX Input" #'listen stream)
+		   (lcl:process-wait-with-timeout
+		     "CLX Input" timeout #'listen stream)))))
+	   nil)
+	  (:timeout))))
+
+
+;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
+;;; buffer. This should never block, so it can be called from the scheduler.
+
+;;; The default implementation is to just use listen.
+#-excl
+(defun buffer-listen-default (display)
+  (declare (type display display))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (if (null stream)
+	t
+      (listen stream))))
+
+#+excl 
+(defun buffer-listen-default (display)
+  (declare (type display display))
+  (let ((fd (display-input-stream display)))
+    (declare (type fixnum fd))
+    (if (= fd -1)
+	t
+      (fd-char-avail-p fd))))
+
+
+;;;----------------------------------------------------------------------------
+;;; System dependent speed hacks
+;;;----------------------------------------------------------------------------
+
+;;
+;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
+;; If your lisp doesn't have stack-lists, and you're worried about
+;; consing garbage, you may want to re-write this to allocate and
+;; initialize lists from a resource.
+;;
+#+lispm
+(defmacro with-stack-list ((var &rest elements) &body body)
+  `(sys:with-stack-list (,var ,@elements) ,@body))
+
+#+lispm
+(defmacro with-stack-list* ((var &rest elements) &body body)
+  `(sys:with-stack-list* (,var ,@elements) ,@body))
+
+#-lispm
+(defmacro with-stack-list ((var &rest elements) &body body)
+  ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
+  ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
+  ;; except that the list produced by MAPCAR resides on the stack and
+  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
+  `(let ((,var (list ,@elements))) ,@body))
+
+#-lispm
+(defmacro with-stack-list* ((var &rest elements) &body body)
+  ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
+  ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
+  ;; except that the list produced by MAPCAR resides on the stack and
+  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
+  `(let ((,var (list* ,@elements))) ,@body))
+
+(declaim (inline buffer-replace))
+
+#+lispm
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type vector buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
+
+#+excl
+(defun buffer-replace (target-sequence source-sequence target-start
+				       target-end &optional (source-start 0))
+  (declare (type buffer-bytes target-sequence source-sequence)
+	   (type array-index target-start target-end source-start)
+	   (optimize (speed 3) (safety 0)))
+  
+  (let ((source-end (length source-sequence)))
+    (declare (type array-index source-end))
+    
+    (if* (and (eq target-sequence source-sequence)
+	      (> target-start source-start))
+       then (let ((nelts (min (- target-end target-start)
+			      (- source-end source-start))))
+	      (do ((target-index (+ target-start nelts -1) (1- target-index))
+		   (source-index (+ source-start nelts -1) (1- source-index)))
+		  ((= target-index (1- target-start)) target-sequence)
+		(declare (type array-index target-index source-index))
+		
+		(setf (aref target-sequence target-index)
+		  (aref source-sequence source-index))))
+       else (do ((target-index target-start (1+ target-index))
+		 (source-index source-start (1+ source-index)))
+		((or (= target-index target-end) (= source-index source-end))
+		 target-sequence)
+	      (declare (type array-index target-index source-index))
+
+	      (setf (aref target-sequence target-index)
+		(aref source-sequence source-index))))))
+
+#+lucid
+;;;The compiler is *supposed* to optimize calls to replace, but in actual
+;;;fact it does not.
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type buffer-bytes buf1 buf2)
+	   (type array-index start1 end1 start2))
+  #.(declare-buffun)
+  (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
+    (declare (type array-index end2))
+    (lucid::simple-8bit-vector-replace-internal
+      buf1 buf2 start1 end1 start2 end2)))
+
+#+(and clx-overlapping-arrays (not (or lispm excl)))
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type vector buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
+
+#-(or lispm lucid excl clx-overlapping-arrays)
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type buffer-bytes buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
+
+#+ti
+(defun with-location-bindings (sys:&quote bindings &rest body)
+  (do ((bindings bindings (cdr bindings)))
+      ((null bindings)
+       (sys:eval-body-as-progn body))
+    (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
+	      (sys:*eval (cadar bindings)))))
+
+#+ti
+(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
+  (let ((bindings (cadr form))
+	(body (cddr form)))
+    `(let ()
+       ,@(loop for (accessor value) in bindings
+	       collect `(si:bind (si:locf ,accessor) ,value))
+       ,@body)))
+
+#+ti
+(defun (:property with-location-bindings compiler::cw-handler) (exp)
+  (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
+	 (body (compiler::cw-clause (cddr exp))))
+    (and compiler::cw-return-expansion-flag
+	 (list* (first exp) bindlist body))))
+
+#+(and lispm (not ti))
+(defmacro with-location-bindings (bindings &body body)
+  `(sys:letf* ,bindings ,@body))
+
+#+lispm
+(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
+				  &body body)
+  ;; don't use svref on LHS because Symbolics didn't define locf for it
+  (let* ((local-state (gensym))
+	 (bindings `(((aref ,local-state ,ts-index) 0))))	; will become zero anyway
+    (dolist (index indexes)
+      (push `((aref ,local-state ,index) (svref ,saved-state ,index))
+	    bindings))
+    `(let ((,local-state (gcontext-local-state ,gc)))
+       (declare (type gcontext-state ,local-state))
+       (unwind-protect
+	   (with-location-bindings ,bindings
+	     ,@body)
+	 (setf (svref ,local-state ,ts-index) 0)
+	 (when ,temp-gc
+	   (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
+	 (deallocate-gcontext-state ,saved-state)))))
+
+#-lispm
+(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
+				  &body body)
+  (let ((local-state (gensym))
+	(resets nil))
+    (dolist (index indexes)
+      (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
+	    resets))
+    `(unwind-protect
+	 (progn
+	   ,@body)
+       (let ((,local-state (gcontext-local-state ,gc)))
+	 (declare (type gcontext-state ,local-state))
+	 ,@resets
+	 (setf (svref ,local-state ,ts-index) 0))
+       (when ,temp-gc
+	 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
+       (deallocate-gcontext-state ,saved-state))))
+
+;;;----------------------------------------------------------------------------
+;;; How error detection should CLX do?
+;;; Several levels are possible:
+;;;
+;;; 1. Do the equivalent of check-type on every argument.
+;;; 
+;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
+;;;    strings generated by check-type.
+;;; 
+;;; 3. Do error checking only on arguments that are likely to have errors
+;;;    (like keyword names)
+;;; 
+;;; 4. Do error checking only where not doing so may dammage the envirnment
+;;;    on a non-tagged machine (i.e. when storing into a structure that has
+;;;    been passed in)
+;;; 
+;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
+;;;    store a non-integer into a number array. 
+;;; 
+;;; How extensive should the error checking be?  For example, if the server
+;;; expects a CARD16, is is sufficient for CLX to check for integer, or
+;;; should it also check for non-negative and less than 65536?
+;;;----------------------------------------------------------------------------
+ 
+;; The *TYPE-CHECK?* constant controls how much error checking is done.
+;; Possible values are:
+;;    NIL      - Don't do any error checking
+;;    t        - Do the equivalent of checktype on every argument
+;;    :minimal - Do error checking only where errors are likely
+
+;;; This controls macro expansion, and isn't changable at run-time You will
+;;; probably want to set this to nil if you want good performance at
+;;; production time.
+(defconstant *type-check?* #+Genera nil #-Genera t)
+
+;; TYPE? is used to allow the code to do error checking at a different level from
+;; the declarations.  It also does some optimizations for systems that don't have
+;; good compiler support for TYPEP.  The definitions for CARD32, CARD16, INT16, etc.
+;; include range checks.  You can modify TYPE? to do less extensive checking
+;; for these types if you desire.
+
+(defmacro type? (object type)
+  (if (not (constantp type))
+      `(typep ,object ,type)
+    (progn
+      (setq type (eval type))
+      #+(or Genera explorer)
+      (if *type-check?*
+	  `(locally (declare (optimize safety)) (typep ,object ',type))
+	`(typep ,object ',type))
+      #-(or Genera explorer)
+      (let ((predicate (assoc type
+			      '((drawable drawable-p) (window window-p)
+				(pixmap pixmap-p) (cursor cursor-p)
+				(font font-p) (gcontext gcontext-p)
+				(colormap colormap-p) (null null)
+				(integer integerp)))))
+	(cond (predicate
+	       `(,(second predicate) ,object))
+	      ((eq type 'boolean)
+	       't)			; Everything is a boolean.
+	      (*type-check?*
+	       `(locally (declare (optimize safety)) (typep ,object ',type)))
+	      (t
+	       `(typep ,object ',type)))))))
+
+;; X-TYPE-ERROR is the function called for type errors.
+;; If you want lots of checking, but are concerned about code size,
+;; this can be made into a macro that ignores some parameters.
+
+(defun x-type-error (object type &optional error-string)
+  (x-error 'x-type-error
+	   :datum object
+	   :expected-type type
+	   :error-string error-string))
+
+
+;;-----------------------------------------------------------------------------
+;; Error handlers
+;;    Hack up KMP error signaling using zetalisp until the real thing comes 
+;;    along
+;;-----------------------------------------------------------------------------
+
+(defun default-error-handler (display error-key &rest key-vals
+			      &key asynchronous &allow-other-keys)
+  (declare (type boolean asynchronous)
+	   (dynamic-extent key-vals))
+  ;; The default display-error-handler.
+  ;; It signals the conditions listed in the DISPLAY file.
+  (if asynchronous
+      (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
+      (apply #'x-error error-key :display display :error-key error-key key-vals)))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (apply #'sys:signal condition keyargs))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (sys:signal (apply #'zl:make-condition condition keyargs)
+	      :proceed-types proceed-format-string))
+
+#+(and Genera (not ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (declare (dbg:error-reporter))
+  (apply #'sys:signal condition keyargs))
+
+#+(and Genera (not ansi-common-lisp))
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dbg:error-reporter))
+  (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(defun x-error (condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'error condition keyargs))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'cerror proceed-format-string condition keyargs))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun x-error (condition &rest keyargs)
+  (error "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (cerror proceed-format-string "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
+
+;; version 15 of Pitman error handling defines the syntax for define-condition to be:
+;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
+;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
+;; or (:report exp)
+
+#+(and lispm (not ansi-common-lisp))
+(defmacro define-condition (name parents &body options)
+  (let ((slots (pop options))
+	(documentation nil)
+	(conc-name (concatenate 'string (string name) "-"))	       
+	(reporter nil))
+    (dolist (item options)
+      (ecase (first item)
+	(:documentation (setq documentation (second item)))
+	(:conc-name (setq conc-name (string (second item))))
+	(:report (setq reporter (second item)))))
+    `(within-definition (,name define-condition)
+       (zl:defflavor ,name ,slots ,parents
+	 :initable-instance-variables
+	 #-Genera
+	 (:accessor-prefix ,conc-name)
+	 #+Genera
+	 (:conc-name ,conc-name)
+	 #-Genera
+	 (:outside-accessible-instance-variables ,@slots)
+	 #+Genera
+	 (:readable-instance-variables ,@slots))
+       ,(when reporter ;; when no reporter, parent's is inherited
+	  `(zl:defmethod #-Genera (,name :report)
+	                 #+Genera (dbg:report ,name) (stream)
+	      ,(if (stringp reporter)
+		   `(write-string ,reporter stream)
+		 `(,reporter global:self stream))
+	      global:self))
+       (zl:compile-flavor-methods ,name)
+       ,(when documentation
+	  `(setf (documentation name 'type) ,documentation))
+       ',name)))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(zl:defflavor x-error () (global:error))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defflavor x-error
+	((dbg:proceed-types '(:continue))	;
+	 continue-format-string)
+	(sys:error)
+  (:initable-instance-variables continue-format-string))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defmethod (scl:make-instance x-error) (&rest ignore)
+  (when (not (sys:variable-boundp continue-format-string))
+    (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defmethod (dbg:proceed x-error :continue) ()
+  :continue)
+
+#+(and Genera (not ansi-common-lisp))
+(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
+  (format stream continue-format-string))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(define-condition x-error (error))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defstruct x-error
+  report-function)
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun reporter-for-condition (name)
+  (xintern "." name '-reporter.))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defmacro define-condition (name parents &body options)
+  ;; Define a structure that when printed displays an error message
+  (let ((slots (pop options))
+	(documentation nil)
+	(conc-name (concatenate 'string (string name) "-"))	       
+	(reporter nil)
+	(condition (gensym))
+	(stream (gensym))
+	(report-function (reporter-for-condition name)))
+    (dolist (item options)
+      (ecase (first item)
+	(:documentation (setq documentation (second item)))
+	(:conc-name (setq conc-name (string (second item))))
+	(:report (setq reporter (second item)))))
+    (unless reporter (setq report-function (reporter-for-condition (car parents))))
+    `(within-definition (,name define-condition)
+       (defstruct (,name (:conc-name ,(intern conc-name))
+		         (:print-function condition-print)
+			 (:include ,(car parents) (report-function ',report-function)))
+	 ,@slots)
+       ,(when documentation
+	  `(setf (documentation name 'type) ,documentation))
+       ,(when reporter
+	  `(defun ,report-function (,condition ,stream)
+	     ,(if (stringp reporter)
+		  `(write-string ,reporter ,stream)
+		`(,reporter ,condition ,stream))
+	     ,condition))
+       ',name)))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun condition-print (condition stream depth)
+  (declare (type x-error condition)
+	   (type stream stream)
+	   (ignore depth))
+  (if *print-escape*
+      (print-unreadable-object (condition stream :type t))
+    (funcall (x-error-report-function condition) condition stream))
+  condition)
+  
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun make-condition (type &rest slot-initializations)
+  (declare (dynamic-extent slot-initializations))
+  (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
+			       (symbol-package type))))
+    (apply make-function slot-initializations)))
+
+#-(or ansi-common-lisp excl lcl3.0)
+(define-condition type-error (x-error)
+  (datum
+   expected-type)
+  (:report (lambda (condition stream)
+	     (format stream "~s isn't a ~a"
+		     (type-error-datum condition)
+		     (type-error-expected-type condition)))))
+
+
+;;-----------------------------------------------------------------------------
+;;  HOST hacking
+;;-----------------------------------------------------------------------------
+
+#-(or explorer Genera)
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  host family
+  (error "HOST-ADDRESS not implemented yet."))
+
+#+explorer
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  (ecase family
+    (:internet
+     (let ((addr (ip:get-ip-address host)))
+       (unless addr (error "~s isn't an internet host name" host))
+       (list :internet
+	     (ldb (byte 8 24) addr)
+	     (ldb (byte 8 16) addr)
+	     (ldb (byte 8 8) addr)
+	     (ldb (byte 8 0) addr))))
+    (:chaos
+     (let ((addr (first (chaos:chaos-addresses host))))
+       (unless addr (error "~s isn't a chaos host name" host))
+       (list :chaos
+	     (ldb (byte 8 0) addr)
+	     (ldb (byte 8 8) addr))))))
+
+#+Genera
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  (let ((net-type (if (eq family :DECnet)
+		      :DNA
+		      family)))
+    (dolist (addr
+	      (sys:send (net:parse-host host) :network-addresses)
+	      (error "~s isn't a valid ~(~A~) host name" host family))
+      (let ((network (car addr))
+	    (address (cadr addr)))
+	(when (sys:send network :network-typep net-type)
+	  (return (ecase family
+		    (:internet
+		      (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
+			(list :internet a b c d)))
+		    ((:chaos :DECnet)
+		     (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
+
+#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
+(defun get-host (host-object)
+  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type list host-object))
+  (declare (values string family))
+  (let* ((family (first host-object))
+	 (address (ecase family
+		    (:internet
+		     (dpb (second host-object)
+			  (byte 8 24)
+			  (dpb (third host-object)
+			       (byte 8 16)
+			       (dpb (fourth host-object)
+				    (byte 8 8)
+				    (fifth host-object)))))
+		    (:chaos
+		     (dpb (third host-object) (byte 8 8) (second host-object))))))
+    (when (eq family :internet) (setq family :ip))
+    (let ((host (si:get-host-from-address address family)))
+      (values (and host (funcall host :name)) family))))
+
+;;; This isn't required, but it helps make sense of the results from access-hosts
+#+Genera
+(defun get-host (host-object)
+  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type list host-object))
+  (declare (values string family))
+  (let ((family (first host-object)))
+    (values (sys:send (net:get-host-from-address 
+			(ecase family
+			  (:internet
+			    (apply #'tcp:build-internet-address (rest host-object)))
+			  ((:chaos :DECnet)
+			   (dpb (third host-object) (byte 8 8) (second host-object))))
+			(net:local-network-of-type (if (eq family :DECnet)
+						       :DNA
+						       family)))
+		      :name)
+	    family)))
+
+
+;;-----------------------------------------------------------------------------
+;; Whether to use closures for requests or not.
+;;-----------------------------------------------------------------------------
+
+;;; If this macro expands to non-NIL, then request and locking code is
+;;; compiled in a much more compact format, as the common code is shared, and
+;;; the specific code is built into a closure that is funcalled by the shared
+;;; code.  If your compiler makes efficient use of closures then you probably
+;;; want to make this expand to T, as it makes the code more compact.
+
+(defmacro use-closures ()
+  #+lispm t #-lispm nil)
+
+
+;;-----------------------------------------------------------------------------
+;; Resource stuff
+;;-----------------------------------------------------------------------------
+
+
+;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
+;;; a resource manager isn't running.
+
+(defun default-resources-pathname ()
+  (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal)
+    (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults"))))
+
+
+
+;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
+;;; defaults have been loaded.
+
+(defun resources-pathname ()
+  (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal)
+    (or #+(or excl lcl3.0)
+	(let ((string (#+excl sys:getenv
+		       #+lcl3.0 lcl:environment-variable
+		       "XENVIRONMENT")))
+	  (when string
+	    (pathname string)))
+	(merge-pathnames
+	  (user-homedir-pathname)
+	  (pathname 
+	    (concatenate 'simple-string ".Xdefaults-"
+			 #+excl (short-site-name)
+			 #-excl (machine-instance)))))))
+
+
+;;-----------------------------------------------------------------------------
+;; GC stuff
+;;-----------------------------------------------------------------------------
+
+#+Genera
+(si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
+  (declare (special *event-free-list*
+		    *pending-command-free-list*
+		    *reply-buffer-free-lists*
+		    *gcontext-local-state-cache*
+		    *temp-gcontext-cache*))
+  (setq *event-free-list* nil)
+  (setq *pending-command-free-list* nil)
+  (fill *reply-buffer-free-lists* nil)
+  (setq *gcontext-local-state-cache* nil)
+  (setq *temp-gcontext-cache* nil))
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+(deftype pixarray-1-element-type ()
+  'bit)
+
+(deftype pixarray-4-element-type ()
+  'card4)
+
+(deftype pixarray-8-element-type ()
+  'card8)
+
+(deftype pixarray-16-element-type ()
+  'card16)
+
+(deftype pixarray-24-element-type ()
+  #-Genera 'card24 #+Genera 'int32)
+
+(deftype pixarray-32-element-type ()
+  #-Genera 'card32 #+Genera 'int32)
+
+(deftype pixarray-1  ()
+  '(array pixarray-1-element-type (* *)))
+
+(deftype pixarray-4  ()
+  '(array pixarray-4-element-type (* *)))
+
+(deftype pixarray-8  ()
+  '(array pixarray-8-element-type (* *)))
+
+(deftype pixarray-16 ()
+  '(array pixarray-16-element-type (* *)))
+
+(deftype pixarray-24 ()
+  '(array pixarray-24-element-type (* *)))
+
+(deftype pixarray-32 ()
+  '(array pixarray-32-element-type (* *)))
+
+(deftype pixarray ()
+  '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
+
+(deftype bitmap ()
+  'pixarray-1)
+
+
+;;; These are used to read and write pixels from and to CARD8s.
+
+;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
+
+(defmacro read-image-load-byte (size position integer)
+  `(the (unsigned-byte ,size)
+	(#-Genera ldb #+Genera sys:%logldb
+	 (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 position)))
+	 (the card8 ,integer))))
+
+;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
+;;; the appropriate number of CARD8s.
+
+(defmacro read-image-assemble-bytes (&rest bytes)
+  (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes)))
+	 (it (first bytes))
+	 (count 0))
+    (dolist (byte (rest bytes))
+      (setq it
+	    `(#-Genera dpb #+Genera sys:%logdpb 
+	      (the card8 ,byte)
+	      (byte 8 ,(incf count 8))
+	      (the (unsigned-byte ,count) ,it))))
+    #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)
+    #+Genera it))
+
+;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
+;;; pixel.
+
+(defmacro write-image-load-byte (position integer integer-size)
+  integer-size
+  `(the card8
+	(#-Genera ldb #+Genera sys:%logldb
+	  (byte 8 ,(if *image-byte-lsb-first-p*
+		       position
+		     (- integer-size 8 position)))
+	  #-Genera (the (unsigned-byte ,integer-size) ,integer)
+	  #+Genera ,integer
+	  )))
+
+;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
+;;; pixels.
+
+(defmacro write-image-assemble-bytes (&rest bytes)
+  (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes)))
+	 (size (floor 8 (length bytes)))
+	 (it (first bytes))
+	 (count 0))
+    (dolist (byte (rest bytes))
+      (setq it `(#-Genera dpb #+Genera sys:%logdpb
+		 (the (unsigned-byte ,size) ,byte)
+		 (byte ,size ,(incf count size))
+		 (the (unsigned-byte ,count) ,it))))
+    `(the card8 ,it)))
+
+;;; If you can write fast routines that can read and write pixarrays out of a
+;;; buffer-bytes, do it!  It makes the image code a lot faster.  The
+;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
+;;; return T if they can do it, NIL if they can't.
+
+;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 8))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-bits (index-mod (index- x) 8))
+	  (right-bits (index-mod (index- width left-bits) 8))
+	  (middle-bits (index- width left-bits right-bits))
+	  (middle-bytes (index-floor middle-bits 8)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-1-element-type (*)) vector)
+	       (type array-index start y
+		     left-bits right-bits middle-bits middle-bytes))
+      (cond ((index< middle-bits 0)
+	     (let ((byte (aref buffer-bbuf (index1- start)))
+		   (x (array-row-major-index array y left-bits)))
+	       (declare (type card8 byte)
+			(type array-index x))
+	       (when (index> right-bits 6)
+		 (setf (aref vector (index- x 1))
+		       (read-image-load-byte 1 7 byte)))
+	       (when (and (index> left-bits 1)
+			  (index> right-bits 5))
+		 (setf (aref vector (index- x 2))
+		       (read-image-load-byte 1 6 byte)))
+	       (when (and (index> left-bits 2)
+			  (index> right-bits 4))
+		 (setf (aref vector (index- x 3))
+		       (read-image-load-byte 1 5 byte)))
+	       (when (and (index> left-bits 3)
+			  (index> right-bits 3))
+		 (setf (aref vector (index- x 4))
+		       (read-image-load-byte 1 4 byte)))
+	       (when (and (index> left-bits 4)
+			  (index> right-bits 2))
+		 (setf (aref vector (index- x 5))
+		       (read-image-load-byte 1 3 byte)))
+	       (when (and (index> left-bits 5)
+			  (index> right-bits 1))
+		 (setf (aref vector (index- x 6))
+		       (read-image-load-byte 1 2 byte)))
+	       (when (index> left-bits 6)
+		 (setf (aref vector (index- x 7))
+		       (read-image-load-byte 1 1 byte)))))
+	    (t
+	     (unless (index-zerop left-bits)
+	       (let ((byte (aref buffer-bbuf (index1- start)))
+		     (x (array-row-major-index array y left-bits)))
+		 (declare (type card8 byte)
+			  (type array-index x))
+		 (setf (aref vector (index- x 1))
+		       (read-image-load-byte 1 7 byte))
+		 (when (index> left-bits 1)
+		   (setf (aref vector (index- x 2))
+			 (read-image-load-byte 1 6 byte))
+		   (when (index> left-bits 2)
+		     (setf (aref vector (index- x 3))
+			   (read-image-load-byte 1 5 byte))
+		     (when (index> left-bits 3)
+		       (setf (aref vector (index- x 4))
+			     (read-image-load-byte 1 4 byte))
+		       (when (index> left-bits 4)
+			 (setf (aref vector (index- x 5))
+			       (read-image-load-byte 1 3 byte))
+			 (when (index> left-bits 5)
+			   (setf (aref vector (index- x 6))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> left-bits 6)
+			     (setf (aref vector (index- x 7))
+				   (read-image-load-byte 1 1 byte))
+			     ))))))))
+	     (do* ((end (index+ start middle-bytes))
+		   (i start (index1+ i))
+		   (x (array-row-major-index array y left-bits) (index+ x 8)))
+		  ((index>= i end)
+		   (unless (index-zerop right-bits)
+		     (let ((byte (aref buffer-bbuf end))
+			   (x (array-row-major-index
+				array y (index+ left-bits middle-bits))))
+		       (declare (type card8 byte)
+				(type array-index x))
+		       (setf (aref vector (index+ x 0))
+			     (read-image-load-byte 1 0 byte))
+		       (when (index> right-bits 1)
+			 (setf (aref vector (index+ x 1))
+			       (read-image-load-byte 1 1 byte))
+			 (when (index> right-bits 2)
+			   (setf (aref vector (index+ x 2))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> right-bits 3)
+			     (setf (aref vector (index+ x 3))
+				   (read-image-load-byte 1 3 byte))
+			     (when (index> right-bits 4)
+			       (setf (aref vector (index+ x 4))
+				     (read-image-load-byte 1 4 byte))
+			       (when (index> right-bits 5)
+				 (setf (aref vector (index+ x 5))
+				       (read-image-load-byte 1 5 byte))
+				 (when (index> right-bits 6)
+				   (setf (aref vector (index+ x 6))
+					 (read-image-load-byte 1 6 byte))
+				   )))))))))
+	       (declare (type array-index end i x))
+	       (let ((byte (aref buffer-bbuf i)))
+		 (declare (type card8 byte))
+		 (setf (aref vector (index+ x 0))
+		       (read-image-load-byte 1 0 byte))
+		 (setf (aref vector (index+ x 1))
+		       (read-image-load-byte 1 1 byte))
+		 (setf (aref vector (index+ x 2))
+		       (read-image-load-byte 1 2 byte))
+		 (setf (aref vector (index+ x 3))
+		       (read-image-load-byte 1 3 byte))
+		 (setf (aref vector (index+ x 4))
+		       (read-image-load-byte 1 4 byte))
+		 (setf (aref vector (index+ x 5))
+		       (read-image-load-byte 1 5 byte))
+		 (setf (aref vector (index+ x 6))
+		       (read-image-load-byte 1 6 byte))
+		 (setf (aref vector (index+ x 7))
+		       (read-image-load-byte 1 7 byte))))
+	     ))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height 
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-nibbles (index-mod (index- x) 2))
+	  (right-nibbles (index-mod (index- width left-nibbles) 2))
+	  (middle-nibbles (index- width left-nibbles right-nibbles))
+	  (middle-bytes (index-floor middle-nibbles 2)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-4-element-type (*)) vector)
+	       (type array-index start y
+		     left-nibbles right-nibbles middle-nibbles middle-bytes))
+      (unless (index-zerop left-nibbles)
+	(setf (aref array y 0)
+	      (read-image-load-byte
+		4 4 (aref buffer-bbuf (index1- start)))))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (x (array-row-major-index array y left-nibbles) (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref array y (index+ left-nibbles middle-nibbles))
+		    (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
+	(declare (type array-index end i x))
+	(let ((byte (aref buffer-bbuf i)))
+	  (declare (type card8 byte))
+	  (setf (aref vector (index+ x 0))
+		(read-image-load-byte 4 0 byte))
+	  (setf (aref vector (index+ x 1))
+		(read-image-load-byte 4 4 byte))))
+      ))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-8 (buffer-bbuf index array x y width height 
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 x)
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-8-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start width))
+ 	    (i start (index1+ i))
+ 	    (x (array-row-major-index array y 0) (index1+ x)))
+ 	   ((index>= i end))
+ 	(declare (type array-index end i x))
+ 	(setf (aref vector x)
+ 	      (the card8 (aref buffer-bbuf i))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-16 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-16-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1)))))))
+  t)
+
+#+Genera
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((array array)
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (sys:array-register-1d array)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (sys:%1d-aref array x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-24-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-32 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 4))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-32-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))
+		(aref buffer-bbuf (index+ i 3)))))))
+  t)
+
+(defun fast-read-pixarray (bbuf boffset pixarray
+			   x y width height padded-bytes-per-line
+			   bits-per-pixel)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index boffset
+		 padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((padded-bits-per-line (* padded-bytes-per-line 8))
+	   (padded-pixels-per-line
+	     (floor padded-bits-per-line bits-per-pixel))
+	   (pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod padded-bits-per-line 32))
+		 (zerop (index-mod pixarray-padded-bits-per-line 32)))
+	(#+Genera sys:stack-let* #-Genera let*
+	 ((dimensions (list height padded-pixels-per-line))
+	  (a (make-array
+	       dimensions
+	       :element-type (array-element-type pixarray)
+	       :displaced-to bbuf
+	       :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
+	 (sys:bitblt boole-1 width height a x y pixarray 0 0))
+	t))
+    #+Genera
+    (when (= bits-per-pixel 24)
+      (fast-read-pixarray-24
+	bbuf boffset pixarray x y width height padded-bytes-per-line))
+    #+(or lcl3.0 excl)
+    (funcall
+      (ecase bits-per-pixel 
+	(1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4)
+	(8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16)
+	(24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32))
+      bbuf boffset pixarray x y width height padded-bytes-per-line)
+    ))
+
+;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-bits (index-mod width 8))
+	  (middle-bits (index- width right-bits))
+	  (middle-bytes (index-ceiling middle-bits 8))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-1-element-type (*)) vector)
+	       (type array-index h y right-bits middle-bits
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x (array-row-major-index array y start-x) (index+ x 8)))
+	   ((index>= i end)
+	    (unless (index-zerop right-bits)
+	      (let ((x (array-row-major-index
+			 array y (index+ start-x middle-bits))))
+		(declare (type array-index x))
+		(setf (aref buffer-bbuf end)
+		      (write-image-assemble-bytes
+			(aref vector (index+ x 0))
+			(if (index> right-bits 1)
+			    (aref vector (index+ x 1))
+			  0)
+			(if (index> right-bits 2)
+			    (aref vector (index+ x 2))
+			  0)
+			(if (index> right-bits 3)
+			    (aref vector (index+ x 3))
+			  0)
+			(if (index> right-bits 4)
+			    (aref vector (index+ x 4))
+			  0)
+			(if (index> right-bits 5)
+			    (aref vector (index+ x 5))
+			  0)
+			(if (index> right-bits 6)
+			    (aref vector (index+ x 6))
+			  0)
+			0)))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref vector (index+ x 0))
+		(aref vector (index+ x 1))
+		(aref vector (index+ x 2))
+		(aref vector (index+ x 3))
+		(aref vector (index+ x 4))
+		(aref vector (index+ x 5))
+		(aref vector (index+ x 6))
+		(aref vector (index+ x 7)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-nibbles (index-mod width 2))
+	  (middle-nibbles (index- width right-nibbles))
+	  (middle-bytes (index-ceiling middle-nibbles 2))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-4-element-type (*)) vector)
+	       (type array-index h y right-nibbles middle-nibbles
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x (array-row-major-index array y start-x) (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref buffer-bbuf end)
+		    (write-image-assemble-bytes
+		      (aref array y (index+ start-x middle-nibbles))
+		      0))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref vector (index+ x 0))
+		(aref vector (index+ x 1)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-8 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-8-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref buffer-bbuf i) (the card8 (aref vector x))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-16 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-16-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-16-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 16))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 16))))))
+  t)
+
+#+Genera
+(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((array array)
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (sys:array-register-1d array)
+	       (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (sys:%1d-aref array x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-24-element-type (*)) vector)
+	       (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-32 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-32-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-32-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 24 pixel 32))))))
+  t)
+
+(defun fast-write-pixarray (bbuf boffset pixarray x y width height
+			    padded-bytes-per-line bits-per-pixel)
+  (declare (type buffer-bytes bbuf)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((padded-bits-per-line (* padded-bytes-per-line 8))
+	   (padded-pixels-per-line
+	     (floor padded-bits-per-line bits-per-pixel))
+	   (pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod padded-bits-per-line 32))
+		 (zerop (index-mod pixarray-padded-bits-per-line 32)))
+	(#+Genera sys:stack-let* #-Genera let*
+	 ((dimensions (list height padded-pixels-per-line))
+	  (a (make-array
+	       dimensions
+	       :element-type (array-element-type pixarray)
+	       :displaced-to bbuf
+	       :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
+	 (sys:bitblt boole-1 width height pixarray x y a 0 0))
+	t))
+    #+Genera
+    (when (= bits-per-pixel 24)
+      (fast-write-pixarray-24
+	bbuf boffset pixarray x y width height padded-bytes-per-line))
+    #+(or lcl3.0 excl)
+    (funcall
+      (ecase bits-per-pixel 
+	(1 #'fast-write-pixarray-1) (4 #'fast-write-pixarray-4)
+	(8 #'fast-write-pixarray-8) (16 #'fast-write-pixarray-16)
+	(24 #'fast-write-pixarray-24) (32 #'fast-write-pixarray-32))
+      bbuf boffset pixarray x y width height padded-bytes-per-line)
+    ))
+
+;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
+
+(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
+  (declare (type pixarray pixarray copy)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn pixarray copy x y width height bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel))
+	   (copy-padded-pixels-per-line
+	     #+Genera (sys:array-row-span copy)
+	     #-Genera (array-dimension copy 1))
+	   (copy-padded-bits-per-line
+	     (* copy-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod pixarray-padded-bits-per-line 32))
+		 (zerop (index-mod copy-padded-bits-per-line 32)))
+	(sys:bitblt boole-1 width height pixarray x y copy 0 0)
+	t))
+    #+Genera
+    (let ((src pixarray)
+	  (dest copy))
+      (declare (sys:array-register-1d src dest))
+      (do* ((dst-y 0 (index1+ dst-y))
+	    (src-y y (index1+ src-y)))
+	   ((index>= dst-y height))
+	(declare (type card16 dst-y src-y))
+	(do* ((dst-idx (array-row-major-index copy dst-y 0)
+		       (index1+ dst-idx))
+	      (dst-end (index+ dst-idx width))
+	      (src-idx (array-row-major-index pixarray src-y x)
+		       (index1+ src-idx)))
+	     ((index>= dst-idx dst-end))
+	  (declare (type array-index dst-idx src-idx dst-end))
+	  (setf (sys:%1d-aref dest dst-idx)
+		(sys:%1d-aref src src-idx))))
+      t)
+    #+(or lcl3.0 excl)
+    (macrolet
+      ((copy (type element-type)
+	 `(let* ((pixarray pixarray)
+		 (copy copy)
+		 (src (underlying-simple-vector pixarray))
+		 (dst (underlying-simple-vector copy)))
+	    (declare (type ,type pixarray copy)
+		     (type (simple-array ,element-type (*)) src dst))
+	    #.(declare-buffun)
+	    (do* ((dst-y 0 (index1+ dst-y))
+		  (src-y y (index1+ src-y)))
+		 ((index>= dst-y height))
+	      (declare (type card16 dst-y src-y))
+	      (do* ((dst-idx (array-row-major-index copy dst-y 0)
+			     (index1+ dst-idx))
+		    (dst-end (index+ dst-idx width))
+		    (src-idx (array-row-major-index pixarray src-y x)
+			     (index1+ src-idx)))
+		   ((index>= dst-idx dst-end))
+		(declare (type array-index dst-idx src-idx dst-end))
+		(setf (aref dst dst-idx)
+		      (the ,element-type (aref src src-idx))))))))
+      (ecase bits-per-pixel
+	(1  (copy pixarray-1  pixarray-1-element-type))
+	(4  (copy pixarray-4  pixarray-4-element-type))
+	(8  (copy pixarray-8  pixarray-8-element-type))
+	(16 (copy pixarray-16 pixarray-16-element-type))
+	(24 (copy pixarray-24 pixarray-24-element-type))
+	(32 (copy pixarray-32 pixarray-32-element-type)))
+      t)))
diff --git a/clx/display.lisp b/clx/display.lisp
new file mode 100644
index 000000000..05cbcc283
--- /dev/null
+++ b/clx/display.lisp
@@ -0,0 +1,533 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  with-display
+	  with-event-queue
+	  open-display
+	  display-force-output
+	  close-display
+	  display-protocol-version
+	  display-vendor
+	  display-roots
+	  display-motion-buffer-size
+	  display-max-request-length
+	  display-error-handler
+	  display-after-function
+	  display-invoke-after-function
+	  display-finish-output))
+
+;;
+;; Resource id management
+;;
+(defun initialize-resource-allocator (display)
+  ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
+  (let ((id-mask (display-resource-id-mask display)))
+    (unless (zerop id-mask) ;; zero mask is an error
+      (do ((first 0 (index1+ first))
+	   (mask id-mask (the mask32 (ash mask -1))))
+	  ((oddp mask)
+	   (setf (display-resource-id-byte display)
+		 (byte (integer-length mask) first)))
+	(declare (type array-index first)
+		 (type mask32 mask))))))
+
+(defun resourcealloc (display)
+  ;; Allocate a resource-id for in DISPLAY
+  (declare (type display display))
+  (declare (values resource-id))
+  (dpb (incf (display-resource-id-count display))
+       (display-resource-id-byte display)
+       (display-resource-id-base display)))
+
+(defmacro allocate-resource-id (display object type)
+  ;; Allocate a resource-id for OBJECT in DISPLAY
+  (declare (type display display)
+	   (type t object))
+  (declare (values resource-id))
+  (if (member (eval type) *clx-cached-types*)
+      `(let ((id (funcall (display-xid ,display) ,display)))
+	 (save-id ,display id ,object)
+	 id)
+    `(funcall (display-xid ,display) ,display)))
+
+(defmacro deallocate-resource-id (display id type)
+  ;; Deallocate a resource-id for OBJECT in DISPLAY
+  (when (member (eval type) *clx-cached-types*)
+    `(deallocate-resource-id-internal ,display ,id)))
+
+(defun deallocate-resource-id-internal (display id)
+  (remhash id (display-resource-id-map display)))
+
+(defun lookup-resource-id (display id)
+  ;; Find the object associated with resource ID
+  (gethash id (display-resource-id-map display)))
+
+(defun save-id (display id object)
+  ;; Register a resource-id from another display.
+  (declare (type display display)
+	   (type integer id)
+	   (type t object))
+  (declare (values object))
+  (setf (gethash id (display-resource-id-map display)) object))
+
+;; Define functions to find the CLX data types given a display and resource-id
+;; If the data type is being cached, look there first.
+(macrolet ((generate-lookup-functions (useless-name &body types)
+	    `(within-definition (,useless-name generate-lookup-functions)
+	       ,@(mapcar
+		   #'(lambda (type)
+		       `(defun ,(xintern 'lookup- type)
+			       (display id)
+			  (declare (type display display)
+				   (type resource-id id))
+			  (declare (values ,type))
+			  ,(if (member type *clx-cached-types*)
+			       `(let ((,type (lookup-resource-id display id)))
+				  (cond ((null ,type) ;; Not found, create and save it.
+					 (setq ,type (,(xintern 'make- type)
+						      :display display :id id))
+					 (save-id display id ,type))
+					;; Found.  Check the type
+					,(cond ((null *type-check?*)
+						`(t ,type))
+					       ((member type '(window pixmap))
+						`((type? ,type 'drawable) ,type))
+					       (t `((type? ,type ',type) ,type)))
+					,@(when *type-check?*
+					    `((t (x-error 'lookup-error
+							  :id id
+							  :display display
+							  :type ',type
+							  :object ,type))))))
+			       ;; Not being cached.  Create a new one each time.
+			       `(,(xintern 'make- type)
+				 :display display :id id))))
+		   types))))
+  (generate-lookup-functions ignore
+    drawable
+    window
+    pixmap
+    gcontext
+    cursor
+    colormap
+    font))
+
+(defun id-atom (id display)
+  ;; Return the cached atom for an atom ID
+  (declare (type resource-id id)
+	   (type display display))
+  (declare (values (or null keyword)))
+  (gethash id (display-atom-id-map display)))
+
+(defun atom-id (atom display)
+  ;; Return the ID for an atom in DISPLAY
+  (declare (type xatom atom)
+	   (type display display))
+  (declare (values (or null resource-id)))
+  (gethash (if (keywordp atom)
+	       atom
+	       (kintern atom))
+	   (display-atom-cache display)))
+
+(defun set-atom-id (atom display id)
+  ;; Set the ID for an atom in DISPLAY
+  (declare (type xatom atom)
+	   (type display display)
+	   (type resource-id id))
+  (declare (values resource-id))
+  (let ((atom (if (keywordp atom) atom (kintern atom))))
+    (declare (type keyword atom))
+    (setf (gethash id (display-atom-id-map display)) atom)
+    (setf (gethash atom (display-atom-cache display)) id)
+    id))
+
+(defsetf atom-id set-atom-id)
+
+(defun initialize-predefined-atoms (display)
+  (do ((i 1 (1+ i))
+       (end (length *predefined-atoms*)))
+      ((>= i end))
+    (declare (type resource-id i))
+    (setf (atom-id (svref *predefined-atoms* i) display) i)))
+
+(defun visual-info (display visual-id)
+  (declare (type display display)
+	   (type resource-id visual-id)
+	   (values visual-info))
+  (when (zerop visual-id)
+    (return-from visual-info nil))
+  (dolist (screen (display-roots display))
+    (declare (type screen screen))
+    (dolist (depth (screen-depths screen))
+      (declare (type cons depth))
+      (dolist (visual-info (rest depth))
+	(declare (type visual-info visual-info))
+	(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
+	  (return-from visual-info visual-info)))))
+  (error "Visual info not found for id #x~x in display ~s." visual-id display))
+
+
+;;
+;; Display functions
+;;
+(defmacro with-display ((display &key timeout inline)
+			&body body)
+  ;; This macro is for use in a multi-process environment.  It provides exclusive
+  ;; access to the local display object for multiple request generation.  It need not
+  ;; provide immediate exclusive access for replies; that is, if another process is
+  ;; waiting for a reply (while not in a with-display), then synchronization need not
+  ;; (but can) occur immediately.  Except where noted, all routines effectively
+  ;; contain an implicit with-display where needed, so that correct synchronization
+  ;; is always provided at the interface level on a per-call basis.  Nested uses of
+  ;; this macro will work correctly.  This macro does not prevent concurrent event
+  ;; processing; see with-event-queue.
+  `(with-buffer (,display
+		 ,@(and timeout `(:timeout ,timeout))
+		 ,@(and inline `(:inline ,inline)))
+     ,@body))
+
+(defmacro with-event-queue ((display &key timeout inline)
+			    &body body &environment env)
+  ;; exclusive access to event queue
+  `(macrolet ((with-event-queue ((display &key timeout) &body body)
+		;; Speedup hack for lexically nested with-event-queues
+		`(progn
+		   (progn ,display ,@(and timeout `(,timeout)) nil)
+		   ,@body)))
+     ,(if (and (null inline) (macroexpand '(use-closures) env))
+	  `(flet ((.with-event-queue-body. () ,@body))
+	     #+ansi-common-lisp
+	     (declare (dynamic-extent #'.with-event-queue-body.))
+	     (with-event-queue-function
+	       ,display ,timeout #'.with-event-queue-body.))
+	(let ((disp (if (or (symbolp display) (constantp display))
+			display
+		      '.display.)))
+	  `(let (,@(unless (eq disp display) `((,disp ,display))))
+	     (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
+			    ,@(and timeout `(:timeout ,timeout)))
+	       ,@body))))))
+
+(defun with-event-queue-function (display timeout function)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type function function)
+	   (downward-funarg function))
+  (with-event-queue (display :timeout timeout :inline t)
+    (funcall function)))
+
+(defmacro with-event-queue-internal ((display &key timeout) &body body)
+  ;; exclusive access to the internal event queues
+  (let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
+    `(let (,@(unless (eq disp display) `((,disp ,display))))
+       (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
+		      ,@(and timeout `(:timeout ,timeout)))
+	 ,@body))))
+
+(defun open-display (host  &rest options &key (display 0) protocol
+		     authorization-name authorization-data &allow-other-keys)
+  ;; Implementation specific routine to setup the buffer for a specific host and display.
+  ;; This must interface with the local network facilities, and will probably do special
+  ;; things to circumvent the nework when displaying on the local host.
+  ;;
+  ;; A string must be acceptable as a host, but otherwise the possible types
+  ;; for host and protocol are not constrained, and will likely be very
+  ;; system dependent.  The default protocol is system specific.  Authorization,
+  ;; if any, is assumed to come from the environment somehow.
+  (declare (type integer display)
+	   (dynamic-extent options))
+  (declare (values display))
+  ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
+  (let* ((stream (open-x-stream host display protocol))
+	 (disp (apply #'make-buffer
+		      #x2000 'make-display-internal
+		      :host host
+		      :display display
+		      :output-stream stream
+		      :input-stream stream
+		      :allow-other-keys t
+		      options))
+	 (ok-p nil))
+    (unwind-protect
+	(progn
+	  (display-connect disp
+			   :authorization-name authorization-name
+			   :authorization-data authorization-data)
+	  (initialize-resource-allocator disp)
+	  (initialize-predefined-atoms disp)
+	  (initialize-extensions disp)
+	  (setq ok-p t))
+      (unless ok-p (close-display disp :abort t)))
+    disp))
+
+(defun display-force-output (display)
+  ; Output is normally buffered, this forces any buffered output to the server.
+  (declare (type display display))
+  (with-display (display)
+    (buffer-force-output display)))
+
+(defun close-display (display &key abort)
+  ;; Close the host connection in DISPLAY
+  (declare (type display display))
+  (close-buffer display :abort abort))
+
+(defun display-connect (display &key authorization-name authorization-data)
+  (unless authorization-name (setq authorization-name ""))
+  (unless authorization-data (setq authorization-data ""))
+  (with-buffer-output (display :sizes (8 16))
+    (card8-put
+      0
+      (ecase (display-byte-order display)
+	(:lsbfirst #x6c)   ;; Ascii lowercase l - Least Significant Byte First
+	(:msbfirst #x42))) ;; Ascii uppercase B -  Most Significant Byte First
+    (card16-put 2 *protocol-major-version*)
+    (card16-put 4 *protocol-minor-version*)
+    (card16-put 6 (length authorization-name))
+    (card16-put 8 (length authorization-data))
+    (write-sequence-char display 12 authorization-name)
+    (write-sequence-char display
+			 (lround (+ 12 (length authorization-name))) authorization-data))
+  (buffer-force-output display)
+  (let ((reply-buffer nil))
+    (declare (type (or null reply-buffer) reply-buffer))
+    (unwind-protect
+	(progn
+	  (setq reply-buffer (allocate-reply-buffer #x1000))
+	  (with-buffer-input (reply-buffer :sizes (8 16 32))
+	    (buffer-input display buffer-bbuf 0 8)
+	    (let ((success (boolean-get 0))
+		  (reason-length (card8-get 1))
+		  (major-version (card16-get 2))
+		  (minor-version (card16-get 4))
+		  (total-length (card16-get 6))
+		  vendor-length
+		  num-roots
+		  num-formats)
+	      (declare (ignore total-length))
+	      (unless success
+		(x-error 'connection-failure
+			 :major-version major-version
+			 :minor-version minor-version
+			 :host (display-host display)
+			 :display (display-display display)
+			 :reason
+			 (progn (buffer-input display buffer-bbuf 0 reason-length)
+				(string-get reason-length 0 :reply-buffer reply-buffer))))
+	      (buffer-input display buffer-bbuf 0 32)
+	      (setf (display-protocol-major-version display) major-version)
+	      (setf (display-protocol-minor-version display) minor-version)
+	      (setf (display-release-number display) (card32-get 0))
+	      (setf (display-resource-id-base display) (card32-get 4))
+	      (setf (display-resource-id-mask display) (card32-get 8))
+	      (setf (display-motion-buffer-size display) (card32-get 12))
+	      (setq vendor-length (card16-get 16))
+	      (setf (display-max-request-length display) (card16-get 18))
+	      (setq num-roots (card8-get 20))
+	      (setq num-formats (card8-get 21))
+	      ;; Get the image-info
+	      (setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
+	      (let ((format (display-bitmap-format display)))
+		(declare (type bitmap-format format))
+		(setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
+		(setf (bitmap-format-unit format) (card8-get 24))
+		(setf (bitmap-format-pad format) (card8-get 25)))
+	      (setf (display-min-keycode display) (card8-get 26))
+	      (setf (display-max-keycode display) (card8-get 27))
+	      ;; 4 bytes unused
+	      ;; Get the vendor string
+	      (buffer-input display buffer-bbuf 0 (lround vendor-length))
+	      (setf (display-vendor-name display)
+		    (string-get vendor-length 0 :reply-buffer reply-buffer))
+	      ;; Initialize the pixmap formats
+	      (dotimes (i num-formats) ;; loop gathering pixmap formats
+		(buffer-input display buffer-bbuf 0 8)
+		(push (make-pixmap-format :depth (card8-get 0)
+					  :bits-per-pixel (card8-get 1)
+					  :scanline-pad (card8-get 2))
+						; 5 unused bytes
+		      (display-pixmap-formats display)))
+	      (setf (display-pixmap-formats display)
+		    (nreverse (display-pixmap-formats display)))
+	      ;; Initialize the screens
+	      (dotimes (i num-roots)
+		(buffer-input display buffer-bbuf 0 40)
+		(let* ((root (make-window :id (card32-get 0) :display display))
+		       (root-visual (card32-get 32))
+		       (default-colormap
+			 (make-colormap :id (card32-get 4)
+					:display display))
+		       (screen
+			 (make-screen
+			   :root root
+			   :default-colormap default-colormap
+			   :white-pixel (card32-get 8)
+			   :black-pixel (card32-get 12)
+			   :event-mask-at-open (card32-get 16)
+			   :width  (card16-get 20)
+			   :height (card16-get 22)
+			   :width-in-millimeters  (card16-get 24)
+			   :height-in-millimeters (card16-get 26)
+			   :min-installed-maps (card16-get 28)
+			   :max-installed-maps (card16-get 30)
+			   :backing-stores (member8-get 36 :never :when-mapped :always)
+			   :save-unders-p (boolean-get 37)
+			   :root-depth (card8-get 38)))
+		       (num-depths (card8-get 39))
+		       (depths nil))
+		  ;; Save root window for event reporting
+		  (save-id display (window-id root) root)
+		  ;; Create the depth AList for a screen, (depth . visual-infos)
+		  (dotimes (j num-depths)
+		    (buffer-input display buffer-bbuf 0 8)
+		    (let ((depth (card8-get 0))
+			  (num-visuals (card16-get 2))
+			  (visuals nil)) ;; 4 bytes unused
+		      (dotimes (k num-visuals)
+			(buffer-input display buffer-bbuf 0 24)
+			(let* ((visual (card32-get 0))
+			       (visual-info (make-visual-info
+					      :id visual
+					      :display display
+					      :class (member8-get 4 :static-gray :gray-scale
+								  :static-color :pseudo-color
+								  :true-color :direct-color)
+					      :bits-per-rgb (card8-get 5)
+					      :colormap-entries (card16-get 6)
+					      :red-mask (card32-get 8)
+					      :green-mask (card32-get 12)
+					      :blue-mask (card32-get 16)
+					      ;; 4 bytes unused
+					      )))
+			  (push visual-info visuals)
+			  (when (funcall (resource-id-map-test) root-visual visual)
+			    (setf (screen-root-visual-info screen)
+				  (setf (colormap-visual-info default-colormap)
+					visual-info)))))
+		      (push (cons depth (nreverse visuals)) depths)))
+		  (setf (screen-depths screen) (nreverse depths))
+		  (push screen (display-roots display))))
+	      (setf (display-roots display) (nreverse (display-roots display)))
+	      (setf (display-default-screen display) (first (display-roots display))))))
+      (when reply-buffer
+	(deallocate-reply-buffer reply-buffer))))
+  display)
+
+(defun display-protocol-version (display)
+  (declare (type display display))
+  (declare (values major minor))
+  (values (display-protocol-major-version display)
+	  (display-protocol-minor-version display)))
+
+(defun display-vendor (display)
+  (declare (type display display))
+  (declare (values name release))
+  (values (display-vendor-name display)
+	  (display-release-number display)))
+
+(defun display-nscreens (display)
+  (declare (type display display))
+  (length (display-roots display)))
+
+#+comment ;; defined by the DISPLAY defstruct
+(defsetf display-error-handler (display) (handler)
+  ;; All errors (synchronous and asynchronous) are processed by calling an error
+  ;; handler in the display.  If handler is a sequence it is expected to contain
+  ;; handler functions specific to each error; the error code is used to index the
+  ;; sequence, fetching the appropriate handler.  Any results returned by the handler
+  ;; are ignored; it is assumed the handler either takes care of the error
+  ;; completely, or else signals. For all core errors, the keyword/value argument
+  ;; pairs are:
+  ;;    :display display
+  ;;    :error-key error-key
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;;    :current-sequence integer
+  ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
+  ;; :window errors another pair is:
+  ;;    :resource-id integer
+  ;; For :atom errors, another pair is:
+  ;;    :atom-id integer
+  ;; For :value errors, another pair is:
+  ;;    :value integer
+  )
+
+  ;; setf'able
+  ;; If defined, called after every protocol request is generated, even those inside
+  ;; explicit with-display's, but never called from inside the after-function itself.
+  ;; The function is called inside the effective with-display for the associated
+  ;; request.  Default value is nil.  Can be set, for example, to
+  ;; #'display-force-output or #'display-finish-output.
+
+(defvar *inside-display-after-function* nil)
+
+(defun display-invoke-after-function (display)
+  ; Called after every protocal request is generated
+  (declare (type display display))
+  (when (and (display-after-function display)
+	     (not *inside-display-after-function*))
+    (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
+      (funcall (display-after-function display) display))))
+
+(defun display-finish-output (display)
+  ;; Forces output, then causes a round-trip to ensure that all possible
+  ;; errors and events have been received.
+  (declare (type display display))
+  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
+       ()
+    )
+  ;; Report asynchronous errors here if the user wants us to.
+  (report-asynchronous-errors display :after-finish-output))
+
+(defparameter
+  *request-names*
+  '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
+     "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
+     "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
+     "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
+     "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
+     "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
+     "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
+     "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
+     "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
+     "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
+     "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
+     "QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
+     "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
+     "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
+     "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
+     "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
+     "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
+     "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
+     "PutImage" "GetImage" "PolyText8" "PolyText16"
+     "ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
+     "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
+     "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
+     "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
+     "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
+     "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
+     "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
+     "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
+     "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
+     "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
+     "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))
diff --git a/clx/doc.lisp b/clx/doc.lisp
new file mode 100644
index 000000000..eb38a9363
--- /dev/null
+++ b/clx/doc.lisp
@@ -0,0 +1,3807 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and
+;;;			 Texas Instruments Incorporated
+
+;;; Permission to use, copy, modify, and distribute this document 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 permission
+;;; notice are retained, and that the name of M.I.T. not be used in advertising or
+;;; publicity pertaining to this document without specific, written prior
+;;; permission.  M.I.T. makes no representations about the suitability of this
+;;; document or the protocol defined in this document for any purpose.  It is
+;;; provided "as is" without express or implied warranty.
+
+;;; Texas Instruments Incorporated provides this document "as is" without
+;;; express or implied warranty.
+
+;; Version 4
+
+;; This is considered a somewhat changeable interface.  Discussion of better
+;; integration with CLOS, support for user-specified subclassess of basic
+;; objects, and the additional functionality to match the C Xlib is still in
+;; progress.
+
+;; Primary Interface Author:
+;;	Robert W. Scheifler
+;;	MIT Laboratory for Computer Science
+;;	545 Technology Square, Room 418
+;;	Cambridge, MA 02139
+;;	rws@zermatt.lcs.mit.edu
+
+;; Design Contributors:
+;;	Dan Cerys, Texas Instruments
+;;	Scott Fahlman, CMU
+;;      Charles Hornig, Symbolics
+;;      John Irwin, Franz
+;;	Kerry Kimbrough, Texas Instruments
+;;	Chris Lindblad, MIT
+;;	Rob MacLachlan, CMU
+;;	Mike McMahon, Symbolics
+;;	David Moon, Symbolics
+;;	LaMott Oren, Texas Instruments
+;;	Daniel Weinreb, Symbolics
+;;	John Wroclawski, MIT
+;;	Richard Zippel, Symbolics
+
+;; CLX Extensions
+;; Adds some of the functionality provided by the C XLIB library.
+;;
+;; Primary Author
+;;	LaMott G. Oren
+;;	Texas Instruments
+;; 
+;; Design Contributors:
+;;	Robert W. Scheifler, MIT
+
+
+;; Note: all of the following is in the package XLIB.
+
+;; Note: various perversions of the CL type system are used below.
+;; Examples: (list elt-type) (sequence elt-type)
+
+(proclaim '(declaration arglist values))
+
+;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
+;; the relationships should be fairly obvious.  We have no intention of writing yet
+;; another moby document for this interface.
+
+(deftype card32 () '(unsigned-byte 32))
+
+(deftype card29 () '(unsigned-byte 29))
+
+(deftype int32 () '(signed-byte 32))
+
+(deftype card16 () '(unsigned-byte 16))
+
+(deftype int16 () '(signed-byte 16))
+
+(deftype card8 () '(unsigned-byte 8))
+
+(deftype int8 () '(signed-byte 8))
+
+(deftype mask32 () 'card32)
+
+(deftype mask16 () 'card16)
+
+(deftype resource-id () 'card29)
+
+;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
+;; These types are defined solely by a functional interface; we do not specify
+;; whether they are implemented as structures or flavors or ...  Although functions
+;; below are written using DEFUN, this is not an implementation requirement (although
+;; it is a requirement that they be functions as opposed to macros or special forms).
+;; It is unclear whether with-slots in the Common Lisp Object System must work on
+;; them.
+
+;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
+;; compound objects, rather than as integer resource-ids.  This allows applications
+;; to deal with multiple displays without having an explicit display argument in the
+;; most common functions.  Every function uses the display object indicated by the
+;; first argument that is or contains a display; it is an error if arguments contain
+;; different displays, and predictable results are not guaranteed.
+
+;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the
+;; following five functions:
+
+(defun <mumble>-display (<mumble>)
+  (declare (type <mumble> <mumble>)
+	   (values display)))
+
+(defun <mumble>-id (<mumble>)
+  (declare (type <mumble> <mumble>)
+	   (values resource-id)))
+
+(defun <mumble>-equal (<mumble>-1 <mumble>-2)
+  (declare (type <mumble> <mumble>-1 <mumble>-2)))
+
+(defun <mumble>-p (<mumble>)
+  (declare (type <mumble> <mumble>)
+	   (values boolean)))
+
+;; The following functions are provided by color objects:
+
+;; The intention is that IHS and YIQ and CYM interfaces will also exist.  Note that
+;; we are explicitly using a different spectrum representation than what is actually
+;; transmitted in the protocol.
+
+(deftype rgb-val () '(real 0 1))
+
+(defun make-color (&key red green blue &allow-other-keys)	; for expansion
+  (declare (type rgb-val red green blue)
+	   (values color)))
+
+(defun color-rgb (color)
+  (declare (type color color)
+	   (values red green blue)))
+
+(defun color-red (color)
+  ;; setf'able
+  (declare (type color color)
+	   (values rgb-val)))
+
+(defun color-green (color)
+  ;; setf'able
+  (declare (type color color)
+	   (values rgb-val)))
+
+(defun color-blue (color)
+  ;; setf'able
+  (declare (type color color)
+	   (values rgb-val)))
+
+(deftype drawable () '(or window pixmap))
+
+;; Atoms are accepted as strings or symbols, and are always returned as keywords.
+;; Protocol-level integer atom ids are hidden, using a cache in the display object.
+
+(deftype xatom () '(or string symbol))
+
+(deftype stringable () '(or string symbol))
+
+(deftype fontable () '(or stringable font))
+
+;; Nil stands for CurrentTime.
+
+(deftype timestamp () '(or null card32))
+
+(deftype bit-gravity () '(member :forget :static :north-west :north :north-east
+				 :west :center :east :south-west :south :south-east))
+
+(deftype win-gravity () '(member :unmap :static :north-west :north :north-east
+				 :west :center :east :south-west :south :south-east))
+
+(deftype grab-status ()
+  '(member :success :already-grabbed :frozen :invalid-time :not-viewable))
+
+(deftype boolean () '(or null (not null)))
+
+(deftype pixel () '(unsigned-byte 32))
+(deftype image-depth () '(integer 0 32))
+
+(deftype keysym () 'card32)
+
+(deftype array-index () `(integer 0 ,array-dimension-limit))
+
+(deftype real (&optional (min '*) (max '*))
+  `(or (real ,min ,max) (rational ,min ,max)))
+
+;; An association list.
+
+(deftype alist (key-type-and-name datum-type-and-name) 'list)
+
+;; A sequence, containing zero or more repetitions of the given elements,
+;; with the elements expressed as (type name).
+
+(deftype repeat-seq (&rest elts) 'sequence)
+
+(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
+
+(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
+
+(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
+
+;; Note that we are explicitly using a different angle representation than what
+;; is actually transmitted in the protocol.
+
+(deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
+
+(deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
+				 (angle angle1) (angle angle2)))
+
+(deftype event-mask-class ()
+  '(member :key-press :key-release :owner-grab-button :button-press :button-release
+	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion :exposure :visibility-change
+	   :structure-notify :resize-redirect :substructure-notify :substructure-redirect
+	   :focus-change :property-change :colormap-change :keymap-state))
+
+(deftype event-mask ()
+  '(or mask32 (list event-mask-class)))
+
+(deftype pointer-event-mask-class ()
+  '(member :button-press :button-release
+	   :enter-window :leave-window :pointer-motion :pointer-motion-hint
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion :keymap-state))
+
+(deftype pointer-event-mask ()
+  '(or mask32 (list pointer-event-mask-class)))
+
+(deftype device-event-mask-class ()
+  '(member :key-press :key-release :button-press :button-release :pointer-motion
+	   :button-1-motion :button-2-motion :button-3-motion :button-4-motion
+	   :button-5-motion :button-motion))
+
+(deftype device-event-mask ()
+  '(or mask32 (list device-event-mask-class)))
+
+(deftype modifier-key ()
+  '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
+
+(deftype modifier-mask ()
+  '(or (member :any) mask16 (list modifier-key)))
+
+(deftype state-mask-key ()
+  '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
+
+(deftype gcontext-key ()
+  '(member :function :plane-mask :foreground :background
+	   :line-width :line-style :cap-style :join-style :fill-style :fill-rule
+	   :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode
+	   :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes))
+
+(deftype event-key ()
+  '(member :key-press :key-release :button-press :button-release :motion-notify
+	   :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
+	   :exposure :graphics-exposure :no-exposure :visibility-notify
+	   :create-notify :destroy-notify :unmap-notify :map-notify :map-request
+	   :reparent-notify :configure-notify :gravity-notify :resize-request
+	   :configure-request :circulate-notify :circulate-request :property-notify
+	   :selection-clear :selection-request :selection-notify
+	   :colormap-notify :client-message))
+
+(deftype error-key ()
+  '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
+	   :illegal-request :implementation :length :match :name :pixmap :value :window))
+
+(deftype draw-direction ()
+  '(member :left-to-right :right-to-left))
+
+(defstruct bitmap-format
+  (unit <unspec> :type (member 8 16 32))
+  (pad <unspec> :type (member 8 16 32))
+  (lsb-first-p <unspec> :type boolean))
+
+(defstruct pixmap-format
+  (depth <unspec> :type image-depth)
+  (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32))
+  (pad <unspec> :type (member 8 16 32)))
+
+(defstruct visual-info
+  (id <unspec> :type resource-id)
+  (display <unspec> :type display)
+  (class <unspec> :type (member :static-gray :static-color :true-color
+				:gray-scale :pseudo-color :direct-color))
+  (red-mask <unspec> :type pixel)
+  (green-mask <unspec> :type pixel)
+  (blue-mask <unspec> :type pixel)
+  (bits-per-rgb <unspec> :type card8)
+  (colormap-entries <unspec> :type card16))
+
+(defstruct screen
+  (root <unspec> :type window)
+  (width <unspec> :type card16)
+  (height <unspec> :type card16)
+  (width-in-millimeters <unspec> :type card16)
+  (height-in-millimeters <unspec> :type card16)
+  (depths <unspec> :type (alist (image-depth depth) ((list visual-info) visuals)))
+  (root-depth <unspec> :type image-depth)
+  (root-visual-info <unspec> :type visual-info)
+  (default-colormap <unspec> :type colormap)
+  (white-pixel <unspec> :type pixel)
+  (black-pixel <unspec> :type pixel)
+  (min-installed-maps <unspec> :type card16)
+  (max-installed-maps <unspec> :type card16)
+  (backing-stores <unspec> :type (member :never :when-mapped :always))
+  (save-unders-p <unspec> :type boolean)
+  (event-mask-at-open <unspec> :type mask32))
+
+(defun screen-root-visual (screen)
+  (declare (type screen screen)
+	   (values resource-id)))
+
+;; The list contains alternating keywords and integers.
+
+(deftype font-props () 'list)
+
+(defun open-display (host &key (display 0) protocol)
+  ;; A string must be acceptable as a host, but otherwise the possible types for host
+  ;; and protocol are not constrained, and will likely be very system dependent.  The
+  ;; default protocol is system specific.  Authorization, if any, is assumed to come
+  ;; from the environment somehow.
+  (declare (type integer display)
+	   (values display)))
+
+(defun display-protocol-major-version (display)
+  (declare (type display display)
+	   (values card16)))
+
+(defun display-protocol-minor-version (display)
+  (declare (type display display)
+	   (values card16)))
+
+(defun display-vendor-name (display)
+  (declare (type display display)
+	   (values string)))
+
+(defun display-release-number (display)
+  (declare (type display display)
+	   (values card32)))
+
+(defun display-image-lsb-first-p (display)
+  (declare (type display display)
+	   (values boolean)))
+
+(defun display-bitmap-formap (display)
+  (declare (type display display)
+	   (values bitmap-format)))
+
+(defun display-pixmap-formats (display)
+  (declare (type display display)
+	   (values (list pixmap-formats))))
+
+(defun display-roots (display)
+  (declare (type display display)
+	   (values (list screen))))
+
+(defun display-motion-buffer-size (display)
+  (declare (type display display)
+	   (values card32)))
+
+(defun display-max-request-length (display)
+  (declare (type display display)
+	   (values card16)))
+
+(defun display-min-keycode (display)
+  (declare (type display display)
+	   (values card8)))
+
+(defun display-max-keycode (display)
+  (declare (type display display)
+	   (values card8)))
+
+(defun close-display (display)
+  (declare (type display display)))
+
+(defun display-error-handler (display)
+  (declare (type display display)
+	   (values handler)))
+
+(defsetf display-error-handler (display) (handler)
+  ;; All errors (synchronous and asynchronous) are processed by calling an error
+  ;; handler in the display.  If handler is a sequence it is expected to contain
+  ;; handler functions specific to each error; the error code is used to index the
+  ;; sequence, fetching the appropriate handler.  Any results returned by the handler
+  ;; are ignored; it is assumed the handler either takes care of the error
+  ;; completely, or else signals. For all core errors, the keyword/value argument
+  ;; pairs are:
+  ;;    :major card8
+  ;;    :minor card16
+  ;;    :sequence card16
+  ;;    :current-sequence card16
+  ;;	:asynchronous (member t nil)
+  ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
+  ;; :window errors another pair is:
+  ;;    :resource-id card32
+  ;; For :atom errors, another pair is:
+  ;;    :atom-id card32
+  ;; For :value errors, another pair is:
+  ;;    :value card32
+  (declare (type display display)
+	   (type (or (sequence (function (display symbol &rest key-vals)))
+		     (function (display symbol &rest key-vals)))
+		 handler)))
+
+(defsetf display-report-asynchronous-errors (display) (when)
+  ;; Most useful in multi-process lisps.
+  ;;
+  ;; Synchronous errors are always signalled in the process that made the
+  ;; synchronous request.  An error is considered synchronous if a process is
+  ;; waiting for a reply with the same request-id as the error.
+  ;; 
+  ;; Asynchronous errors can be signalled at any one of these three times:
+  ;; 
+  ;; 1.  As soon as they are read.  They get signalled in whichever process 
+  ;; was doing the reading.  This is enabled by
+  ;;       (setf (xlib:display-report-asynchronous-errors display)
+  ;;             '(:immediately))
+  ;; This is the default.
+  ;; 
+  ;; 2.  Before any events are to be handled.  You get these by doing an
+  ;; event-listen with any timeout value other than 0, or in of the event
+  ;; processing forms.  This is useful if you using a background process to
+  ;; handle input.  This is enabled by
+  ;;       (setf (xlib:display-report-asynchronous-errors display)
+  ;;             '(:before-event-handling)) 
+  ;; 
+  ;; 3.  After a display-finish-output.  You get these by doing a
+  ;; display-finish-output.  A cliche using this might have a with-display
+  ;; wrapped around the display operations that possibly cause an asynchronous
+  ;; error, with a display-finish-output right the end of the with-display to
+  ;; catch any asynchronous errors.  This is enabled by
+  ;;       (setf (xlib:display-report-asynchronous-errors display)
+  ;;             '(:after-finish-output))
+  ;; 
+  ;; You can select any combination of the three keywords.  For example, to
+  ;; get errors reported before event handling and after finish-output,
+  ;;       (setf (xlib:display-report-asynchronous-errors display)
+  ;;             '(:before-event-handling :after-finish-output))
+  (declare (type list when))
+  )
+
+(defmacro define-condition (name base &body items)
+  ;; just a place-holder here for the real thing
+  )
+
+(define-condition request-error error
+  display
+  major
+  minor
+  sequence
+  current-sequence
+  asynchronous)
+
+(defun default-error-handler (display error-key &rest key-vals)
+  ;; The default display-error-handler.
+  ;; It signals the conditions listed below.
+  (declare (type display display)
+	   (type symbol error-key))
+  )
+
+(define-condition resource-error request-error
+  resource-id)
+
+(define-condition access-error request-error)
+
+(define-condition alloc-error request-error)
+
+(define-condition atom-error request-error
+  atom-id)
+
+(define-condition colormap-error resource-error)
+
+(define-condition cursor-error resource-error)
+
+(define-condition drawable-error resource-error)
+
+(define-condition font-error resource-error)
+
+(define-condition gcontext-error resource-error)
+
+(define-condition id-choice-error resource-error)
+
+(define-condition illegal-request-error request-error)
+
+(define-condition implementation-error request-error)
+
+(define-condition length-error request-error)
+
+(define-condition match-error request-error)
+
+(define-condition name-error request-error)
+
+(define-condition pixmap-error resource-error)
+
+(define-condition value-error request-error
+  value)
+
+(define-condition window-error resource-error)
+
+(defmacro with-display ((display) &body body)
+  ;; This macro is for use in a multi-process environment.  It provides exclusive
+  ;; access to the local display object for multiple request generation.  It need not
+  ;; provide immediate exclusive access for replies; that is, if another process is
+  ;; waiting for a reply (while not in a with-display), then synchronization need not
+  ;; (but can) occur immediately.  Except where noted, all routines effectively
+  ;; contain an implicit with-display where needed, so that correct synchronization
+  ;; is always provided at the interface level on a per-call basis.  Nested uses of
+  ;; this macro will work correctly.  This macro does not prevent concurrent event
+  ;; processing; see with-event-queue.
+  )
+
+(defun display-force-output (display)
+  ;; Output is normally buffered; this forces any buffered output.
+  (declare (type display display)))
+
+(defun display-finish-output (display)
+  ;; Forces output, then causes a round-trip to ensure that all possible errors and
+  ;; events have been received.
+  (declare (type display display)))
+
+(defun display-after-function (display)
+  ;; setf'able
+  ;; If defined, called after every protocol request is generated, even those inside
+  ;; explicit with-display's, but never called from inside the after-function itself.
+  ;; The function is called inside the effective with-display for the associated
+  ;; request.  Default value is nil.  Can be set, for example, to
+  ;; #'display-force-output or #'display-finish-output.
+  (declare (type display display)
+	   (values (or null (function (display))))))
+
+(defun create-window (&key parent x y width height (depth 0) (border-width 0)
+		      (class :copy) (visual :copy)
+		      background border gravity bit-gravity
+		      backing-store backing-planes backing-pixel save-under
+		      event-mask do-not-propagate-mask override-redirect
+		      colormap cursor)
+  ;; Display is obtained from parent.  Only non-nil attributes are passed on in the
+  ;; request: the function makes no assumptions about what the actual protocol
+  ;; defaults are.  Width and height are the inside size, excluding border.
+  (declare (type window parent)
+	   (type int16 x y)
+	   (type card16 width height depth border-width)
+	   (type (member :copy :input-output :input-only) class)
+	   (type (or (member :copy) visual-info) visual)
+	   (type (or null (member :none :parent-relative) pixel pixmap) background)
+	   (type (or null (member :copy) pixel pixmap) border)
+	   (type (or null win-gravity) gravity)
+	   (type (or null bit-gravity) bit-gravity)
+	   (type (or null (member :not-useful :when-mapped :always) backing-store))
+	   (type (or null pixel) backing-planes backing-pixel)
+	   (type (or null event-mask) event-mask)
+	   (type (or null device-event-mask) do-not-propagate-mask)
+	   (type (or null (member :on :off)) save-under override-redirect)
+	   (type (or null (member :copy) colormap) colormap)
+	   (type (or null (member :none) cursor) cursor)
+	   (values window)))
+
+(defun window-class (window)
+  (declare (type window window)
+	   (values (member :input-output :input-only))))
+
+(defun window-visual-info (window)
+  (declare (type window window)
+	   (values visual-info)))
+
+(defun window-visual (window)
+  (declare (type window window)
+	   (values resource-id)))
+
+(defsetf window-background (window) (background)
+  (declare (type window window)
+	   (type (or (member :none :parent-relative) pixel pixmap) background)))
+
+(defsetf window-border (window) (border)
+  (declare (type window window)
+	   (type (or (member :copy) pixel pixmap) border)))
+
+(defun window-gravity (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values win-gravity)))
+
+(defun window-bit-gravity (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values bit-gravity)))
+
+(defun window-backing-store (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values (member :not-useful :when-mapped :always))))
+
+(defun window-backing-planes (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values pixel)))
+
+(defun window-backing-pixel (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values pixel)))
+
+(defun window-save-under (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values (member :on :off))))
+
+(defun window-event-mask (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values mask32)))
+
+(defun window-do-not-propagate-mask (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values mask32)))
+
+(defun window-override-redirect (window)
+  ;; setf'able
+  (declare (type window window)
+	   (values (member :on :off))))
+
+(defun window-colormap (window)
+  (declare (type window window)
+	   (values (or null colormap))))
+
+(defsetf window-colormap (window) (colormap)
+  (declare (type window window)
+	   (type (or (member :copy) colormap) colormap)))
+
+(defsetf window-cursor (window) (cursor)
+  (declare (type window window)
+	   (type (or (member :none) cursor) cursor)))
+
+(defun window-colormap-installed-p (window)
+  (declare (type window window)
+	   (values boolean)))
+
+(defun window-all-event-masks (window)
+  (declare (type window window)
+	   (values mask32)))
+
+(defun window-map-state (window)
+  (declare (type window window)
+	   (values (member :unmapped :unviewable :viewable))))
+
+(defsetf drawable-x (window) (x)
+  (declare (type window window)
+	   (type int16 x)))
+
+(defsetf drawable-y (window) (y)
+  (declare (type window window)
+	   (type int16 y)))
+
+(defsetf drawable-width (window) (width)
+  ;; Inside width, excluding border.
+  (declare (type window window)
+	   (type card16 width)))
+
+(defsetf drawable-height (window) (height)
+  ;; Inside height, excluding border.
+  (declare (type window window)
+	   (type card16 height)))
+
+(defsetf drawable-border-width (window) (border-width)
+  (declare (type window window)
+	   (type card16 border-width)))
+
+(defsetf window-priority (window &optional sibling) (mode)
+  ;; A bit strange, but retains setf form.
+  (declare (type window window)
+	   (type (or null window) sibling)
+	   (type (member :above :below :top-if :bottom-if :opposite) mode)))
+
+(defmacro with-state ((drawable) &body body)
+  ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
+  ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
+  ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
+  ;; indefinite scope of the body, on a per-process basis in a multi-process
+  ;; environment, the first call within an Accessor Group on the specified drawable
+  ;; (the object, not just the variable) causes the complete results of the protocol
+  ;; request to be retained, and returned in any subsequent accessor calls.  Calls
+  ;; within a Setf Group are delayed, and executed in a single request on exit from
+  ;; the body.  In addition, if a call on a function within an Accessor Group follows
+  ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
+  ;; that group are executed, any retained accessor information for that group is
+  ;; discarded, the corresponding protocol request is (re)issued, and the results are
+  ;; (again) retained, and returned in any subsequent accessor calls.
+
+  ;; Accessor Group A (for GetWindowAttributes):
+  ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity,
+  ;; window-backing-store, window-backing-planes, window-backing-pixel,
+  ;; window-save-under, window-colormap, window-colormap-installed-p,
+  ;; window-map-state, window-all-event-masks, window-event-mask,
+  ;; window-do-not-propagate-mask, window-override-redirect
+
+  ;; Setf Group A (for ChangeWindowAttributes):
+  ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
+  ;; window-backing-pixel, window-save-under, window-event-mask,
+  ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
+  ;; window-cursor
+
+  ;; Accessor Group G (for GetGeometry):
+  ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
+  ;; drawable-height, drawable-border-width
+
+  ;; Setf Group G (for ConfigureWindow):
+  ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
+  ;; window-priority
+  )
+
+(defun destroy-window (window)
+  (declare (type window window)))
+
+(defun destroy-subwindows (window)
+  (declare (type window window)))
+
+(defun add-to-save-set (window)
+  (declare (type window window)))
+
+(defun remove-from-save-set (window)
+  (declare (type window window)))
+
+(defun reparent-window (window parent x y)
+  (declare (type window window parent)
+	   (type int16 x y)))
+
+(defun map-window (window)
+  (declare (type window window)))
+
+(defun map-subwindows (window)
+  (declare (type window window)))
+
+(defun unmap-window (window)
+  (declare (type window window)))
+
+(defun unmap-subwindows (window)
+  (declare (type window window)))
+
+(defun circulate-window-up (window)
+  (declare (type window window)))
+
+(defun circulate-window-down (window)
+  (declare (type window window)))
+
+(defun drawable-root (drawable)
+  (declare (type drawable drawable)
+	   (values window)))
+
+(defun drawable-depth (drawable)
+  (declare (type drawable drawable)
+	   (values card8)))
+
+(defun drawable-x (drawable)
+  (declare (type drawable drawable)
+	   (values int16)))
+
+(defun drawable-y (drawable)
+  (declare (type drawable drawable)
+	   (values int16)))
+
+(defun drawable-width (drawable)
+  ;; For windows, inside width, excluding border.
+  (declare (type drawable drawable)
+	   (values card16)))
+
+(defun drawable-height (drawable)
+  ;; For windows, inside height, excluding border.
+  (declare (type drawable drawable)
+	   (values card16)))
+
+(defun drawable-border-width (drawable)
+  (declare (type drawable drawable)
+	   (values card16)))
+
+(defun query-tree (window &key (result-type 'list))
+  (declare (type window window)
+	   (type type result-type)
+	   (values (sequence window) parent root)))
+
+(defun change-property (window property data type format
+			&key (mode :replace) (start 0) end transform)
+  ;; Start and end affect sub-sequence extracted from data.
+  ;; Transform is applied to each extracted element.
+  (declare (type window window)
+	   (type xatom property type)
+	   (type (member 8 16 32) format)
+	   (type sequence data)
+	   (type (member :replace :prepend :append) mode)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type (or null (function (t) integer)) transform)))
+
+(defun delete-property (window property)
+  (declare (type window window)
+	   (type xatom property)))
+
+(defun get-property (window property
+		     &key type (start 0) end delete-p (result-type 'list) transform)
+  ;; Transform is applied to each integer retrieved.
+  ;; Nil is returned for type when the protocol returns None.
+  (declare (type window window)
+	   (type xatom property)
+	   (type (or null xatom) type)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type boolean delete-p)
+	   (type type result-type)
+	   (type (or null (function (integer) t)) transform)
+	   (values data type format bytes-after)))
+
+(defun rotate-properties (window properties &optional (delta 1))
+  ;; Postive rotates left, negative rotates right (opposite of actual protocol request).
+  (declare (type window window)
+	   (type (sequence xatom) properties)
+	   (type int16 delta)))
+
+(defun list-properties (window &key (result-type 'list))
+  (declare (type window window)
+	   (type type result-type)
+	   (values (sequence keyword))))
+
+;; Although atom-ids are not visible in the normal user interface, atom-ids might
+;; appear in window properties and other user data, so conversion hooks are needed.
+
+(defun intern-atom (display name)
+  (declare (type display display)
+	   (type xatom name)
+	   (values resource-id)))
+
+(defun find-atom (display name)
+  (declare (type display display)
+	   (type xatom name)
+	   (values (or null resource-id))))
+
+(defun atom-name (display atom-id)
+  (declare (type display display)
+	   (type resource-id atom-id)
+	   (values keyword)))
+
+(defun selection-owner (display selection)
+  (declare (type display display)
+	   (type xatom selection)
+	   (values (or null window))))
+
+(defsetf selection-owner (display selection &optional time) (owner)
+  ;; A bit strange, but retains setf form.
+  (declare (type display display)
+	   (type xatom selection)
+	   (type (or null window) owner)
+	   (type timestamp time)))
+
+(defun convert-selection (selection type requestor &optional property time)
+  (declare (type xatom selection type)
+	   (type window requestor)
+	   (type (or null xatom) property)
+	   (type timestamp time)))
+
+(defun send-event (window event-key event-mask &rest args
+		   &key propagate-p display &allow-other-keys)
+  ;; Additional arguments depend on event-key, and are as specified further below
+  ;; with declare-event, except that both resource-ids and resource objects are
+  ;; accepted in the event components.  The display argument is only required if the
+  ;; window is :pointer-window or :input-focus.  If an argument has synonyms, it is
+  ;; only necessary to supply a value for one of them; it is an error to specify
+  ;; different values for synonyms.
+  (declare (type (or window (member :pointer-window :input-focus)) window)
+	   (type (or null event-key) event-key)
+	   (type event-mask event-mask)
+	   (type boolean propagate-p)
+	   (type (or null display) display)))
+
+(defun grab-pointer (window event-mask
+		     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
+  (declare (type window window)
+	   (type pointer-event-mask event-mask)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or null window) confine-to)
+	   (type (or null cursor) cursor)
+	   (type timestamp time)
+	   (values grab-status)))
+
+(defun ungrab-pointer (display &key time)
+  (declare (type display display)
+	   (type timestamp time)))
+
+(defun grab-button (window button event-mask
+		    &key (modifiers 0)
+			 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
+  (declare (type window window)
+	   (type (or (member :any) card8) button)
+	   (type modifier-mask modifiers)
+	   (type pointer-event-mask event-mask)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or null window) confine-to)
+	   (type (or null cursor) cursor)))
+
+(defun ungrab-button (window button &key (modifiers 0))
+  (declare (type window window)
+	   (type (or (member :any) card8) button)
+	   (type modifier-mask modifiers)))
+
+(defun change-active-pointer-grab (display event-mask &optional cursor time)
+  (declare (type display display)
+	   (type pointer-event-mask event-mask)
+	   (type (or null cursor) cursor)
+	   (type timestamp time)))
+
+(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
+  (declare (type window window)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type timestamp time)
+	   (values grab-status)))
+
+(defun ungrab-keyboard (display &key time)
+  (declare (type display display)
+	   (type timestamp time)))
+
+(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
+  (declare (type window window)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or (member :any) card8) key)
+	   (type modifier-mask modifiers)))
+
+(defun ungrab-key (window key &key (modifiers 0))
+  (declare (type window window)
+	   (type (or (member :any) card8) key)
+	   (type modifier-mask modifiers)))
+
+(defun allow-events (display mode &optional time)
+  (declare (type display display)
+	   (type (member :async-pointer :sync-pointer :reply-pointer
+			 :async-keyboard :sync-keyboard :replay-keyboard
+			 :async-both :sync-both)
+		 mode)
+	   (type timestamp time)))
+
+(defun grab-server (display)
+  (declare (type display display)))
+
+(defun ungrab-server (display)
+  (declare (type display display)))
+
+(defmacro with-server-grabbed ((display) &body body)
+  ;; The body is not surrounded by a with-display.
+  )
+
+(defun query-pointer (window)
+  (declare (type window window)
+	   (values x y same-screen-p child mask root-x root-y root)))
+
+(defun pointer-position (window)
+  (declare (type window window)
+	   (values x y same-screen-p)))
+
+(defun global-pointer-position (display)
+  (declare (type display display)
+	   (values root-x root-y root)))
+
+(defun motion-events (window &key start stop (result-type 'list))
+  (declare (type window window)
+	   (type timestamp start stop)
+	   (type type result-type)
+	   (values (repeat-seq (int16 x) (int16 y) (timestamp time)))))
+
+(defun translate-coordinates (src src-x src-y dst)
+  ;; If src and dst are not on the same screen, nil is returned.
+  (declare (type window src)
+	   (type int16 src-x src-y)
+	   (type window dst)
+	   (values dst-x dst-y child)))
+
+(defun warp-pointer (dst dst-x dst-y)
+  (declare (type window dst)
+	   (type int16 dst-x dst-y)))
+
+(defun warp-pointer-relative (display x-off y-off)
+  (declare (type display display)
+	   (type int16 x-off y-off)))
+
+(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
+			       &optional src-width src-height)
+  ;; Passing in a zero src-width or src-height is a no-op.  A null src-width or
+  ;; src-height translates into a zero value in the protocol request.
+  (declare (type window dst src)
+	   (type int16 dst-x dst-y src-x src-y)
+	   (type (or null card16) src-width src-height)))
+
+(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
+					&optional src-width src-height)
+  ;; Passing in a zero src-width or src-height is a no-op.  A null src-width or
+  ;; src-height translates into a zero value in the protocol request.
+  (declare (type window src)
+	   (type int16 x-off y-off src-x src-y)
+	   (type (or null card16) src-width src-height)))
+
+(defun set-input-focus (display focus revert-to &optional time)
+  ;; Setf ought to allow multiple values.
+  (declare (type display display)
+	   (type (or (member :none :pointer-root) window) focus)
+	   (type (member :none :parent :pointer-root) revert-to)
+	   (type timestamp time)))
+
+(defun input-focus (display)
+  (declare (type display display)
+	   (values focus revert-to)))
+
+(defun query-keymap (display)
+  (declare (type display display)
+	   (values (bit-vector 256))))
+
+(defun open-font (display name)
+  ;; Font objects may be cached and reference counted locally within the display
+  ;; object.  This function might not execute a with-display if the font is cached.
+  ;; The protocol QueryFont request happens on-demand under the covers.
+  (declare (type display display)
+	   (type stringable name)
+	   (values font)))
+
+;; We probably want a per-font bit to indicate whether caching on
+;; text-extents/width calls is desirable.  But what to name it?
+
+(defun discard-font-info (font)
+  ;; Discards any state that can be re-obtained with QueryFont.  This is simply
+  ;; a performance hint for memory-limited systems.
+  (declare (type font font)))
+
+;; This can be signalled anywhere a pseudo font access fails.
+
+(define-condition invalid-font error
+  font)
+
+;; Note: font-font-info removed.
+
+(defun font-name (font)
+  ;; Returns nil for a pseudo font returned by gcontext-font.
+  (declare (type font font)
+	   (values (or null string))))
+
+(defun font-direction (font)
+  (declare (type font font)
+	   (values draw-direction)))
+
+(defun font-min-char (font)
+  (declare (type font font)
+	   (values card16)))
+
+(defun font-max-char (font)
+  (declare (type font font)
+	   (values card16)))
+
+(defun font-min-byte1 (font)
+  (declare (type font font)
+	   (values card8)))
+
+(defun font-max-byte1 (font)
+  (declare (type font font)
+	   (values card8)))
+
+(defun font-min-byte2 (font)
+  (declare (type font font)
+	   (values card8)))
+
+(defun font-max-byte2 (font)
+  (declare (type font font)
+	   (values card8)))
+
+(defun font-all-chars-exist-p (font)
+  (declare (type font font)
+	   (values boolean)))
+
+(defun font-default-char (font)
+  (declare (type font font)
+	   (values card16)))
+
+(defun font-ascent (font)
+  (declare (type font font)
+	   (values int16)))
+
+(defun font-descent (font)
+  (declare (type font font)
+	   (values int16)))
+
+;; The list contains alternating keywords and int32s.
+
+(deftype font-props () 'list)
+
+(defun font-properties (font)
+  (declare (type font font)
+	   (values font-props)))
+
+(defun font-property (font name)
+  (declare (type font font)
+	   (type keyword name)
+	   (values (or null int32))))
+
+;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
+
+(defun char-<metric> (font index)
+  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
+  ;; (or an in-bounds index on a pseudo font), although returning zero or
+  ;; signalling might be better.
+  (declare (type font font)
+	   (type card16 index)
+	   (values (or null int16))))
+
+(defun max-char-<metric> (font)
+  ;; Note: I have tentatively chosen separate accessors over allowing :min and
+  ;; :max as an index above.
+  (declare (type font font)
+	   (values int16)))
+
+(defun min-char-<metric> (font)
+  (declare (type font font)
+	   (values int16)))
+
+;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
+
+(defun close-font (font)
+  ;; This might not generate a protocol request if the font is reference
+  ;; counted locally or if it is a pseudo font.
+  (declare (type font font)))
+
+(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
+  (declare (type display display)
+	   (type string pattern)
+	   (type card16 max-fonts)
+	   (type type result-type)
+	   (values (sequence string))))
+
+(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
+  ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
+  ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
+  ;; converted (internally) to real fonts dynamically as needed, by issuing an
+  ;; OpenFont request.  However, the OpenFont might fail, in which case the
+  ;; invalid-font error can arise.
+  (declare (type display display)
+	   (type string pattern)
+	   (type card16 max-fonts)
+	   (type type result-type)
+	   (values (sequence font))))
+
+(defun font-path (display &key (result-type 'list))
+  (declare (type display display)
+	   (type type result-type)
+	   (values (sequence (or string pathname)))))
+
+(defsetf font-path (display) (paths)
+  (declare (type display display)
+	   (type (sequence (or string pathname)) paths)))
+
+(defun create-pixmap (&key width height depth drawable)
+  (declare (type card16 width height)
+	   (type card8 depth)
+	   (type drawable drawable)
+	   (values pixmap)))
+
+(defun free-pixmap (pixmap)
+  (declare (type pixmap pixmap)))
+
+(defun create-gcontext (&key drawable function plane-mask foreground background
+			     line-width line-style cap-style join-style fill-style fill-rule
+			     arc-mode tile stipple ts-x ts-y font subwindow-mode
+			     exposures clip-x clip-y clip-mask clip-ordering
+			     dash-offset dashes
+			     (cache-p t))
+  ;; Only non-nil components are passed on in the request, but for effective caching
+  ;; assumptions have to be made about what the actual protocol defaults are.  For
+  ;; all gcontext components, a value of nil causes the default gcontext value to be
+  ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
+  ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
+  ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
+  ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
+  ;; component will have no effect unless the new value differs from the cached
+  ;; value.  Component changes (setfs and with-gcontext) are always deferred
+  ;; regardless of the cache mode, and sent over the protocol only when required by a
+  ;; local operation or by an explicit call to force-gcontext-changes.
+  (declare (type drawable drawable)
+	   (type (or null boole-constant) function)
+	   (type (or null pixel) plane-mask foreground background)
+	   (type (or null card16) line-width dash-offset)
+	   (type (or null int16) ts-x ts-y clip-x clip-y)
+	   (type (or null (member :solid :dash :double-dash)) line-style)
+	   (type (or null (member :not-last :butt :round :projecting)) cap-style)
+	   (type (or null (member :miter :round :bevel)) join-style)
+	   (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
+	   (type (or null (member :even-odd :winding)) fill-rule)
+	   (type (or null (member :chord :pie-slice)) arc-mode)
+	   (type (or null pixmap) tile stipple)
+	   (type (or null fontable) font)
+	   (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
+	   (type (or null (member :on :off)) exposures)
+	   (type (or null (member :none) pixmap rect-seq) clip-mask)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
+	   (type (or null (or card8 (sequence card8))) dashes)
+	   (type boolean cache)
+	   (values gcontext)))
+
+;; For each argument to create-gcontext (except font, clip-mask and
+;; clip-ordering) declared as (type <type> <name>), there is an accessor:
+
+(defun gcontext-<name> (gcontext)
+  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
+  ;; off, or the component was copied from a gcontext with unknown state).
+  (declare (type gcontext gcontext)
+	   (values <type>)))
+
+;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
+;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
+
+(defsetf gcontext-<name> (gcontext) (value)
+  (declare (type gcontext gcontext)
+	   (type <type> value)))
+
+(defun gcontext-font (gcontext &optional metrics-p)
+  ;; If the stored font is known, it is returned.  If it is not known and
+  ;; metrics-p is false, then nil is returned.  If it is not known and
+  ;; metrics-p is true, then a pseudo font is returned.  Full metric and
+  ;; property information can be obtained, but the font does not have a name or
+  ;; a resource-id, and attempts to use it where a resource-id is required will
+  ;; result in an invalid-font error.
+  (declare (type gcontext gcontext)
+	   (type boolean metrics-p)
+	   (values (or null font))))
+
+(defun gcontext-clip-mask (gcontext)
+  (declare (type gcontext gcontext)
+	   (values (or null (member :none) pixmap rect-seq)
+		   (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))))
+
+(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
+  ;; Is nil illegal here, or is it transformed to a vector?
+  ;; A bit strange, but retains setf form.
+  (declare (type gcontext gcontext)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
+	   (type (or (member :none) pixmap rect-seq) clip-mask)))
+
+(defun force-gcontext-changes (gcontext)
+  ;; Force any delayed changes.
+  (declare (type gcontext gcontext)))
+
+(defmacro with-gcontext ((gcontext &key
+			  function plane-mask foreground background
+			  line-width line-style cap-style join-style fill-style fill-rule
+			  arc-mode tile stipple ts-x ts-y font subwindow-mode
+			  exposures clip-x clip-y clip-mask clip-ordering
+			  dashes dash-offset)
+			 &body body)
+  ;; Changes gcontext components within the dynamic scope of the body (i.e.,
+  ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process
+  ;; environment.  The values are all evaluated before bindings are performed.  The
+  ;; body is not surrounded by a with-display.  If cache-p is nil or the some
+  ;; component states are unknown, this will implement save/restore by creating a
+  ;; temporary gcontext and doing gcontext-components to and from it.
+  )
+
+(defun copy-gcontext-components (src dst &rest keys)
+  (declare (type gcontext src dst)
+	   (type (list gcontext-key) keys)))
+
+(defun copy-gcontext (src dst)
+  (declare (type gcontext src dst))
+  ;; Copies all components.
+  )
+	   
+(defun free-gcontext (gcontext)
+  (declare (type gcontext gcontext)))
+
+(defun clear-area (window &key (x 0) (y 0) width height exposures-p)
+  ;; Passing in a zero width or height is a no-op.  A null width or height translates
+  ;; into a zero value in the protocol request.
+  (declare (type window window)
+	   (type int16 x y)
+	   (type (or null card16) width height)
+	   (type boolean exposures-p)))
+
+(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
+  (declare (type drawable src dst)
+	   (type gcontext gcontext)
+	   (type int16 src-x src-y dst-x dst-y)
+	   (type card16 width height)))
+
+(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
+  (declare (type drawable src dst)
+	   (type gcontext gcontext)
+	   (type pixel plane)
+	   (type int16 src-x src-y dst-x dst-y)
+	   (type card16 width height)))
+
+(defun draw-point (drawable gcontext x y)
+  ;; Should be clever about appending to existing buffered protocol request, provided
+  ;; gcontext has not been modified.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)))
+
+(defun draw-points (drawable gcontext points &optional relative-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type point-seq points)
+	   (type boolean relative-p)))
+
+(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
+  ;; Should be clever about appending to existing buffered protocol request, provided
+  ;; gcontext has not been modified.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x1 y1 x2 y2)
+	   (type boolean relative-p)))
+
+(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type point-seq points)
+	   (type boolean relative-p fill-p)
+	   (type (member :complex :non-convex :convex) shape)))
+
+(defun draw-segments (drawable gcontext segments)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type seg-seq segments)))
+
+(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
+  ;; Should be clever about appending to existing buffered protocol request, provided
+  ;; gcontext has not been modified.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type boolean fill-p)))
+
+(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type rect-seq rectangles)
+	   (type boolean fill-p)))
+
+(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
+  ;; Should be clever about appending to existing buffered protocol request, provided
+  ;; gcontext has not been modified.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type angle angle1 angle2)
+	   (type boolean fill-p)))
+
+(defun draw-arcs (drawable gcontext arcs &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type arc-seq arcs)
+	   (type boolean fill-p)))
+
+;; The following image routines are bare minimum.  It may be useful to define some
+;; form of "image" object to hide representation details and format conversions.  It
+;; also may be useful to provide stream-oriented interfaces for reading and writing
+;; the data.
+
+(defun put-raw-image (drawable gcontext data
+		      &key (start 0) depth x y width height (left-pad 0) format)
+  ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
+  ;; for transmission; the caller is responsible for all byte and bit swapping and
+  ;; compaction.  Start is the starting index in data; the end is computed from the
+  ;; other arguments.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type (sequence card8) data)
+	   (type array-index start)
+	   (type card8 depth left-pad)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type (member :bitmap :xy-pixmap :z-pixmap) format)))
+
+(defun get-raw-image (drawable &key data (start 0) x y width height
+				    (plane-mask 0xffffffff) format
+				    (result-type '(vector (unsigned-byte 8))))
+  ;; If data is given, it is modified in place (and returned), otherwise a new
+  ;; sequence is created and returned, with a size computed from the other arguments
+  ;; and the returned depth.  The sequence is filled with 8-bit quantities, in
+  ;; transmission format; the caller is responsible for any byte and bit swapping and
+  ;; compaction required for further local use.
+  (declare (type drawable drawable)
+	   (type (or null (sequence card8)) data)
+	   (type array-index start)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type pixel plane-mask)
+	   (type (member :xy-pixmap :z-pixmap) format)
+	   (values (sequence card8) depth visual-info)))
+
+(defun translate-default (src src-start src-end font dst dst-start)
+  ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
+  ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
+  ;; on context.  font is the current font, if known.  The function should
+  ;; translate as many elements of src as possible into indexes in the current
+  ;; font, and store them into dst.  The first return value should be the src
+  ;; index of the first untranslated element.  If no further elements need to
+  ;; be translated, the second return value should be nil.  If a horizontal
+  ;; motion is required before further translation, the second return value
+  ;; should be the delta in x coordinate.  If a font change is required for
+  ;; further translation, the second return value should be the new font.  If
+  ;; known, the pixel width of the translated text can be returned as the third
+  ;; value; this can allow for appending of subsequent output to the same
+  ;; protocol request, if no overall width has been specified at the higher
+  ;; level.
+  (declare (type sequence src)
+	   (type array-index src-start src-end dst-start)
+	   (type (or null font) font)
+	   (type vector dst)
+	   (values array-index (or null int16 font) (or null int32))))
+
+;; There is a question below of whether translate should always be required, or
+;; if not, what the default should be or where it should come from.  For
+;; example, the default could be something that expected a string as src and
+;; translated the CL standard character set to ASCII indexes, and ignored fonts
+;; and bits.  Or the default could expect a string but otherwise be "system
+;; dependent".  Or the default could be something that expected a vector of
+;; integers and did no translation.  Or the default could come from the
+;; gcontext (but what about text-extents and text-width?).
+
+(defun text-extents (font sequence &key (start 0) end translate)
+  ;; If multiple fonts are involved, font-ascent and font-descent will be the
+  ;; maximums.  If multiple directions are involved, the direction will be nil.
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font)
+	   (type translate translate)
+	   (values width ascent descent left right font-ascent font-descent direction
+		   (or null array-index))))
+
+(defun text-width (font sequence &key (start 0) end translate)
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font)
+	   (type translate translate)
+	   (values int32 (or null array-index))))
+
+;; This controls the element size of the dst buffer given to translate.  If
+;; :default is specified, the size will be based on the current font, if known,
+;; and otherwise 16 will be used.  [An alternative would be to pass the buffer
+;; size to translate, and allow it to return the desired size if it doesn't
+;; like the current size.  The problem is that the protocol doesn't allow
+;; switching within a single request, so to allow switching would require
+;; knowing the width of text, which isn't necessarily known.  We could call
+;; text-width to compute it, but perhaps that is doing too many favors?]  [An
+;; additional possibility is to allow an index-size of :two-byte, in which case
+;; translate would be given a double-length 8-bit array, and translate would be
+;; expected to store first-byte/second-byte instead of 16-bit integers.]
+
+(deftype index-size () '(member :default 8 16))
+
+;; In the glyph functions below, if width is specified, it is assumed to be the
+;; total pixel width of whatever string of glyphs is actually drawn.
+;; Specifying width will allow for appending the output of subsequent calls to
+;; the same protocol request, provided gcontext has not been modified in the
+;; interim.  If width is not specified, appending of subsequent output might
+;; not occur (unless translate returns the width).  Specifying width is simply
+;; a hint, for performance.
+
+(defun draw-glyph (drawable gcontext x y elt
+		   &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type translate translate)
+	   (type (or null int32) width)
+	   (type index-size size)
+	   (values boolean (or null int32))))
+
+(defun draw-glyphs (drawable gcontext x y sequence
+		    &key (start 0) end translate width (size :default))
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type sequence sequence)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)
+	   (type translate translate)
+	   (type index-size size)
+	   (values (or null array-index) (or null int32))))
+
+(defun draw-image-glyph (drawable gcontext x y elt
+			 &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is overall width, if known.  An initial font change is
+  ;; allowed from translate.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type translate translate)
+	   (type (or null int32) width)
+	   (type index-size size)
+	   (values boolean (or null int32))))
+
+(defun draw-image-glyphs (drawable gcontext x y sequence
+			  &key (start 0) end width translate (size :default))
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type sequence sequence)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)
+	   (type translate translate)
+	   (type index-size size)
+	   (values (or null array-index) (or null int32))))
+
+(defun create-colormap (visual window &optional alloc-p)
+  (declare (type visual-info visual)
+	   (type window window)
+	   (type boolean alloc-p)
+	   (values colormap)))
+
+(defun free-colormap (colormap)
+  (declare (type colormap colormap)))
+
+(defun copy-colormap-and-free (colormap)
+  (declare (type colormap colormap)
+	   (values colormap)))
+
+(defun install-colormap (colormap)
+  (declare (type colormap colormap)))
+
+(defun uninstall-colormap (colormap)
+  (declare (type colormap colormap)))
+
+(defun installed-colormaps (window &key (result-type 'list))
+  (declare (type window window)
+	   (type type result-type)
+	   (values (sequence colormap))))
+
+(defun alloc-color (colormap color)
+  (declare (type colormap colormap)
+	   (type (or stringable color) color)
+	   (values pixel screen-color exact-color)))
+
+(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
+  (declare (type colormap colormap)
+	   (type card16 colors planes)
+	   (type boolean contiguous-p)
+	   (type type result-type)
+	   (values (sequence pixel) (sequence mask))))
+
+(defun alloc-color-planes (colormap colors
+			   &key (reds 0) (greens 0) (blues 0)
+				contiguous-p (result-type 'list))
+  (declare (type colormap colormap)
+	   (type card16 colors reds greens blues)
+	   (type boolean contiguous-p)
+	   (type type result-type)
+	   (values (sequence pixel) red-mask green-mask blue-mask)))
+
+(defun free-colors (colormap pixels &optional (plane-mask 0))
+  (declare (type colormap colormap)
+	   (type (sequence pixel) pixels)
+	   (type pixel plane-mask)))
+
+(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
+  (declare (type colormap colormap)
+	   (type pixel pixel)
+	   (type (or stringable color) spec)
+	   (type boolean red-p green-p blue-p)))
+
+(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
+  ;; If stringables are specified for colors, it is unspecified whether all
+  ;; stringables are first resolved and then a single StoreColors protocol request is
+  ;; issued, or whether multiple StoreColors protocol requests are issued.
+  (declare (type colormap colormap)
+	   (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs)
+	   (type boolean red-p green-p blue-p)))
+
+(defun query-colors (colormap pixels &key (result-type 'list))
+  (declare (type colormap colormap)
+	   (type (sequence pixel) pixels)
+	   (type type result-type)
+	   (values (sequence color))))
+
+(defun lookup-color (colormap name)
+  (declare (type colormap colormap)
+	   (type stringable name)
+	   (values screen-color true-color)))
+
+(defun create-cursor (&key source mask x y foreground background)
+  (declare (type pixmap source)
+	   (type (or null pixmap) mask)
+	   (type card16 x y)
+	   (type color foreground background)
+	   (values cursor)))
+
+(defun create-glyph-cursor (&key source-font source-char mask-font mask-char
+				 foreground background)
+  (declare (type font source-font)
+	   (type card16 source-char)
+	   (type (or null font) mask-font)
+	   (type (or null card16) mask-char)
+	   (type color foreground background)
+	   (values cursor)))
+
+(defun free-cursor (cursor)
+  (declare (type cursor cursor)))
+
+(defun recolor-cursor (cursor foreground background)
+  (declare (type cursor cursor)
+	   (type color foreground background)))
+
+(defun query-best-cursor (width height drawable)
+  (declare (type card16 width height)
+	   (type drawable display)
+	   (values width height)))
+
+(defun query-best-tile (width height drawable)
+  (declare (type card16 width height)
+	   (type drawable drawable)
+	   (values width height)))
+
+(defun query-best-stipple (width height drawable)
+  (declare (type card16 width height)
+	   (type drawable drawable)
+	   (values width height)))
+
+(defun query-extension (display name)
+  (declare (type display display)
+	   (type stringable name)
+	   (values major-opcode first-event first-error)))
+
+(defun list-extensions (display &key (result-type 'list))
+  (declare (type display display)
+	   (type type result-type)
+	   (values (sequence string))))
+
+;; Should pointer-mapping setf be changed to set-pointer-mapping?
+
+(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
+  ;; Can signal device-busy.
+  ;; Setf ought to allow multiple values.
+  ;; Returns true for success, nil for failure
+  (declare (type display display)
+	   (type (sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5)
+	   (values (member :success :busy :failed))))
+
+(defun modifier-mapping (display)
+  ;; each value is a list of card8s
+  (declare (type display display)
+	   (values shift lock control mod1 mod2 mod3 mod4 mod5)))
+
+;; 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 * (* *)) keysyms)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type card8 first-keycode)))
+
+(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)
+	   (values (array * (* *)))))
+
+(defun change-keyboard-control (display &key key-click-percent
+				bell-percent bell-pitch bell-duration
+				led led-mode key auto-repeat-mode)
+  (declare (type display display)
+	   (type (or null (member :default) int16) key-click-percent
+						   bell-percent bell-pitch bell-duration)
+	   (type (or null card8) led key)
+	   (type (or null (member :on :off)) led-mode)
+	   (type (or null (member :on :off :default)) auto-repeat-mode)))
+
+(defun keyboard-control (display)
+  (declare (type display display)
+	   (values key-click-percent bell-percent bell-pitch bell-duration
+		   led-mask global-auto-repeat auto-repeats)))
+
+(defun bell (display &optional (percent-from-normal 0))
+  ;; It is assumed that an eventual audio extension to X will provide more complete
+  ;; control.
+  (declare (type display display)
+	   (type int8 percent-from-normal)))
+
+(defun pointer-mapping (display &key (result-type 'list))
+  (declare (type display display)
+	   (type type result-type)
+	   (values (sequence card8))))
+
+(defsetf pointer-mapping (display) (map)
+  ;; Can signal device-busy.
+  (declare (type display display)
+	   (type (sequence card8) map)))
+
+(defun change-pointer-control (display &key acceleration threshold)
+  ;; Acceleration is rationalized if necessary.
+  (declare (type display display)
+	   (type (or null (member :default) number) acceleration)
+	   (type (or null (member :default) integer) threshold)))
+
+(defun pointer-control (display)
+  (declare (type display display)
+	   (values acceleration threshold)))
+
+(defun set-screen-saver (display timeout interval blanking exposures)
+  ;; Setf ought to allow multiple values.
+  ;; Timeout and interval are in seconds, will be rounded to minutes.
+  (declare (type display display)
+	   (type (or (member :default) int16) timeout interval)
+	   (type (member :on :off :default) blanking exposures)))
+
+(defun screen-saver (display)
+  ;; Returns timeout and interval in seconds.
+  (declare (type display display)
+	   (values timeout interval blanking exposures)))
+
+(defun activate-screen-saver (display)
+  (declare (type display display)))
+
+(defun reset-screen-saver (display)
+  (declare (type display display)))
+
+(defun add-access-host (display host)
+  ;; A string must be acceptable as a host, but otherwise the possible types for host
+  ;; are not constrained, and will likely be very system dependent.
+  (declare (type display display)))
+
+(defun remove-access-host (display host)
+  ;; A string must be acceptable as a host, but otherwise the possible types for host
+  ;; are not constrained, and will likely be very system dependent.
+  (declare (type display display)))
+
+(defun access-hosts (display &key (result-type 'list))
+  ;; The type of host objects returned is not constrained, except that the hosts must
+  ;; be acceptable to add-access-host and remove-access-host.
+  (declare (type display display)
+	   (type type result-type)
+	   (values (sequence host) enabled-p)))
+
+(defun access-control (display)
+  ;; setf'able
+  (declare (type display display)
+	   (values boolean)))
+
+(defun close-down-mode (display)
+  ;; setf'able
+  ;; Cached locally in display object.
+  (declare (type display display)
+	   (values (member :destroy :retain-permanent :retain-temporary))))
+
+(defun kill-client (display resource-id)
+  (declare (type display display)
+	   (type resource-id resource-id)))
+
+(defun kill-temporary-clients (display)
+  (declare (type display display)))
+
+(defun make-event-mask (&rest keys)
+  ;; This is only defined for core events.
+  ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
+  (declare (type (list event-mask-class) keys)
+	   (values mask32)))
+
+(defun make-event-keys (event-mask)
+  ;; This is only defined for core events.
+  (declare (type mask32 event-mask)
+	   (values (list event-mask-class))))
+
+(defun make-state-mask (&rest keys)
+  ;; Useful for constructing modifier-mask, state-mask.
+  (declare (type (list state-mask-key) keys)
+	   (values mask16)))
+
+(defun make-state-keys (state-mask)
+  (declare (type mask16 mask)
+	   (values (list state-mask-key))))
+
+(defmacro with-event-queue ((display) &body body)
+  ;; Grants exclusive access to event queue.
+  )
+
+(defun event-listen (display &optional (timeout 0))
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (values (or null number) (or null (member :timeout) (not null))))
+  ;; Returns the number of events queued locally, if any, else nil.  Hangs
+  ;; waiting for events, forever if timeout is nil, else for the specified
+  ;; number of seconds.  The second value returned is :timeout if the
+  ;; operation timed out, and some other non-nil value if an EOF has been
+  ;; detected.
+  )
+
+(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
+  ;; If force-output-p is true, first invokes display-force-output.  Invokes
+  ;; handler on each queued event until handler returns non-nil, and that
+  ;; returned object is then returned by process-event.  If peek-p is true,
+  ;; then the event is not removed from the queue.  If discard-p is true, then
+  ;; events for which handler returns nil are removed from the queue,
+  ;; otherwise they are left in place.  Hangs until non-nil is generated for
+  ;; some event, or for the specified timeout (in seconds, if given); however,
+  ;; it is acceptable for an implementation to wait only once on network data,
+  ;; and therefore timeout prematurely.  Returns nil on timeout or EOF, with a
+  ;; second return value being :timeout for a timeout and some other non-nil
+  ;; value for EOF.  If handler is a sequence, it is expected to contain
+  ;; handler functions specific to each event class; the event code is used to
+  ;; index the sequence, fetching the appropriate handler.  The arguments to
+  ;; the handler are described further below using declare-event.  If
+  ;; process-event is invoked recursively, the nested invocation begins with
+  ;; the event after the one currently being processed.
+  (declare (type display display)
+	   (type (or (sequence (function (&rest key-vals) t))
+		     (function (&rest key-vals) t))
+		 handler)
+	   (type (or null number) timeout)
+	   (type boolean peek-p)))
+
+(defun make-event-handlers (&key (type 'array) default)
+  (declare (type t type)			;Sequence type specifier
+	   (type function default)
+	   (values sequence))			;Default handler for initial content
+  ;; Makes a handler sequence suitable for process-event
+  )
+   
+(defun event-handler (handlers event-key)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (values function))
+  ;; Accessor for a handler sequence
+  )
+
+(defsetf event-handler (handlers event-key) (handler)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (type function handler)
+	   (values function))
+  ;; Setf accessor for a handler sequence
+  )
+
+(defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t))
+		      &body clauses)
+  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
+		    (event-or-events ((&rest args) |...|) &body body) |...|))
+  ;; If force-output-p is true, first invokes display-force-output.  Executes
+  ;; the matching clause for each queued event until a clause returns non-nil,
+  ;; and that returned object is then returned by event-case.  If peek-p is
+  ;; true, then the event is not removed from the queue.  If discard-p is
+  ;; true, then events for which the clause returns nil are removed from the
+  ;; queue, otherwise they are left in place.  Hangs until non-nil is
+  ;; generated for some event, or for the specified timeout (in seconds, if
+  ;; given); however, it is acceptable for an implementation to wait only once
+  ;; on network data, and therefore timeout prematurely.  Returns nil on
+  ;; timeout or EOF with a second return value being :timeout for a timeout
+  ;; and some other non-nil value for EOF.  In each clause, event-or-events is
+  ;; an event-key or a list of event-keys (but they need not be typed as
+  ;; keywords) or the symbol t or otherwise (but only in the last clause).
+  ;; The keys are not evaluated, and it is an error for the same key to appear
+  ;; in more than one clause.  Args is the list of event components of
+  ;; interest; corresponding values (if any) are bound to variables with these
+  ;; names (i.e., the args are variable names, not keywords, the keywords are
+  ;; derived from the variable names).  An arg can also be a (keyword var)
+  ;; form, as for keyword args in a lambda lists.  If no t/otherwise clause
+  ;; appears, it is equivalent to having one that returns nil.  If
+  ;; process-event is invoked recursively, the nested invocation begins with
+  ;; the event after the one currently being processed.
+  )
+
+(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
+		      &body clauses)
+  ;; The clauses of event-cond are of the form:
+  ;; (event-or-events binding-list test-form . body-forms)
+  ;;
+  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
+  ;;			need not be typed as keywords) or the symbol t
+  ;;			or otherwise (but only in the last clause).  If
+  ;;			no t/otherwise clause appears, it is equivalent
+  ;;			to having one that returns nil.  The keys are
+  ;;			not evaluated, and it is an error for the same
+  ;;			key to appear in more than one clause.
+  ;;
+  ;; BINDING-LIST	The list of event components of interest.
+  ;;			corresponding values (if any) are bound to
+  ;;			variables with these names (i.e., the binding-list
+  ;;			has variable names, not keywords, the keywords are
+  ;;			derived from the variable names).  An arg can also
+  ;;			be a (keyword var) form, as for keyword args in a
+  ;;			lambda list.
+  ;;
+  ;; The matching TEST-FORM for each queued event is executed until a
+  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
+  ;; evaluated, returning the (possibly multiple) values of the last
+  ;; form from event-cond.  If there are no body-forms then, if the
+  ;; test-form is non-nil, the value of the test-form is returned as a
+  ;; single value.
+  ;;
+  ;; Options:
+  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
+  ;;		  	input is pending.
+  ;;
+  ;; PEEK-P		When true, then the event is not removed from the queue.
+  ;;
+  ;; DISCARD-P		When true, then events for which the clause returns nil
+  ;; 			are removed from the queue, otherwise they are left in place.
+  ;;
+  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
+  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
+  ;;			elapsed.  NIL is also returned whenever EOF is read.
+  ;;			Whenever NIL is returned a second value is returned which
+  ;;			is either :TIMEOUT if a timeout occurred or some other
+  ;;			non-NIL value if an EOF is detected.
+  ;;
+  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
+		   (event-or-events (&rest args) test-form &body body) |...|))
+  )
+
+(defun discard-current-event (display)
+  (declare (type display display)
+	   (values boolean))
+  ;; Discard the current event for DISPLAY.
+  ;; Returns NIL when the event queue is empty, else T.
+  ;; To ensure events aren't ignored, application code should only call
+  ;; this when throwing out of event-case or process-next-event, or from
+  ;; inside even-case, event-cond or process-event when :peek-p is T and
+  ;; :discard-p is NIL.
+ )
+
+(defmacro declare-event (event-codes &rest declares)
+  ;; Used to indicate the keyword arguments for handler functions in process-event
+  ;; and event-case.  In the declares, an argument listed as (name1 name2) indicates
+  ;; synonyms for the same argument.  All process-event handlers can have
+  ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword
+  ;; arguments, and an event-case clause can also have event-key and send-event-p as
+  ;; arguments.
+  (declare (arglist event-key-or-keys &rest (type &rest keywords))))
+
+(declare-event (:key-press :key-release :button-press :button-release)
+  (card16 sequence)
+  (window (window event-window) root)
+  ((or null window) child)
+  (boolean same-screen-p)
+  (int16 x y root-x root-y)
+  (card16 state)
+  (card32 time)
+  ;; for key-press and key-release, code is the keycode
+  ;; for button-press and button-release, code is the button number
+  (card8 code))
+
+(declare-event :motion-notify
+  (card16 sequence)
+  (window (window event-window) root)
+  ((or null window) child)
+  (boolean same-screen-p)
+  (int16 x y root-x root-y)
+  (card16 state)
+  (card32 time)
+  (boolean hint-p))
+
+(declare-event (:enter-notify :leave-notify)
+  (card16 sequence)
+  (window (window event-window) root)
+  ((or null window) child)
+  (boolean same-screen-p)
+  (int16 x y root-x root-y)
+  (card16 state)
+  (card32 time)
+  ((member :normal :grab :ungrab) mode)
+  ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind)
+  (boolean focus-p))
+
+(declare-event (:focus-in :focus-out)
+  (card16 sequence)
+  (window (window event-window))
+  ((member :normal :while-grabbed :grab :ungrab) mode)
+  ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
+	   :pointer :pointer-root :none)
+   kind))
+
+(declare-event :keymap-notify
+  ((bit-vector 256) keymap))
+
+(declare-event :exposure
+  (card16 sequence)
+  (window (window event-window))
+  (card16 x y width height count))
+
+(declare-event :graphics-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card16 x y width height count)
+  (card8 major)
+  (card16 minor))
+
+(declare-event :no-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card8 major)
+  (card16 minor))
+
+(declare-event :visibility-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((member :unobscured :partially-obscured :fully-obscured) state))
+
+(declare-event :create-notify
+  (card16 sequence)
+  (window window (parent event-window))
+  (int16 x y)
+  (card16 width height border-width)
+  (boolean override-redirect-p))
+
+(declare-event :destroy-notify
+  (card16 sequence)
+  (window event-window window))
+
+(declare-event :unmap-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean configure-p))
+
+(declare-event :map-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean override-redirect-p))
+
+(declare-event :map-request
+  (card16 sequence)
+  (window (parent event-window) window))
+
+(declare-event :reparent-notify
+  (card16 sequence)
+  (window event-window window parent)
+  (int16 x y)
+  (boolean override-redirect-p))
+
+(declare-event :configure-notify
+  (card16 sequence)
+  (window event-window window)
+  (int16 x y)
+  (card16 width height border-width)
+  ((or null window) above-sibling)
+  (boolean override-redirect-p))
+
+(declare-event :gravity-notify
+  (card16 sequence)
+  (window event-window window)
+  (int16 x y))
+
+(declare-event :resize-request
+  (card16 sequence)
+  (window (window event-window))
+  (card16 width height))
+
+(declare-event :configure-request
+  (card16 sequence)
+  (window (parent event-window) window)
+  (int16 x y)
+  (card16 width height border-width)
+  ((member :above :below :top-if :bottom-if :opposite) stack-mode)
+  ((or null window) above-sibling)
+  (mask16 value-mask))
+
+(declare-event :circulate-notify
+  (card16 sequence)
+  (window event-window window)
+  ((member :top :bottom) place))
+
+(declare-event :circulate-request
+  (card16 sequence)
+  (window (parent event-window) window)
+  ((member :top :bottom) place))
+
+(declare-event :property-notify
+  (card16 sequence)
+  (window (window event-window))
+  (keyword atom)
+  ((member :new-value :deleted) state)
+  (card32 time))
+
+(declare-event :selection-clear
+  (card16 sequence)
+  (window (window event-window))
+  (keyword selection)
+  (card32 time))
+
+(declare-event :selection-request
+  (card16 sequence)
+  (window (window event-window) requestor)
+  (keyword selection target)
+  ((or null keyword) property)
+  (card32 time))
+
+(declare-event :selection-notify
+  (card16 sequence)
+  (window (window event-window))
+  (keyword selection target)
+  ((or null keyword) property)
+  (card32 time))
+
+(declare-event :colormap-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((or null colormap) colormap)
+  (boolean new-p installed-p))
+
+(declare-event :mapping-notify
+  (card16 sequence)
+  ((member :modifier :keyboard :pointer) request)
+  (card8 start count))
+
+(declare-event :client-message
+  (card16 sequence)
+  (window (window event-window))
+  ((member 8 16 32) format)
+  ((sequence integer) data))
+
+(defun queue-event (display event-key &rest args &key append-p &allow-other-keys)
+  ;; The event is put at the head of the queue if append-p is nil, else the tail.
+  ;; Additional arguments depend on event-key, and are as specified above with
+  ;; declare-event, except that both resource-ids and resource objects are accepted
+  ;; in the event components.
+  (declare (type display display)
+	   (type event-key event-key)
+	   (type boolean append-p)))
+
+
+
+;;; From here on, there has been less coherent review of the interface:
+
+;;;-----------------------------------------------------------------------------
+;;; Window Manager Property functions
+
+(defun wm-name (window)
+  (declare (type window window)
+	   (values string)))
+
+(defsetf wm-name (window) (name))
+
+(defun wm-icon-name (window)
+  (declare (type window window)
+	   (values string)))
+
+(defsetf wm-icon-name (window) (name))
+
+(defun get-wm-class (window)
+  (declare (type window window)
+	   (values (or null name-string) (or null class-string))))
+
+(defun set-wm-class (window resource-name resource-class)
+  (declare (type window window)
+	   (type (or null stringable) resource-name resource-class)))
+
+(defun wm-command (window)
+  ;; Returns a list whose car is a command string and 
+  ;; whose cdr is the list of argument strings.
+  (declare (type window window)
+	   (values (list string))))
+
+(defsetf wm-command (window) (command)
+  ;; Uses PRIN1 to a string-stream with the following bindings:
+  ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
+  ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
+  ;; each element of command is seperated with NULL characters.
+  ;; This enables (mapcar #'read-from-string (wm-command window))
+  ;; to recover a lisp command.
+  (declare (type window window)
+	   (type (list stringable) command)))
+
+(defun wm-client-machine (window)
+  ;; Returns a list whose car is a command string and 
+  ;; whose cdr is the list of argument strings.
+  (declare (type window window)
+	   (values string)))
+
+(defsetf wm-client-machine (window) (string)
+  (declare (type window window)
+	   (type stringable string)))
+
+(defstruct wm-hints
+  (input nil :type (or null (member :off :on)))
+  (initial-state nil :type (or null (member :normal :iconic)))
+  (icon-pixmap nil :type (or null pixmap))
+  (icon-window nil :type (or null window))
+  (icon-x nil :type (or null card16))
+  (icon-y nil :type (or null card16))
+  (icon-mask nil :type (or null pixmap))
+  (window-group nil :type (or null resource-id))
+  (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
+  ;; may be extended in the future
+  )
+
+(defun wm-hints (window)
+  (declare (type window window)
+	   (values wm-hints)))
+
+(defsetf wm-hints (window) (wm-hints))
+
+
+(defstruct wm-size-hints
+  ;; Defaulted T to put the burden of remembering these on widget programmers.
+  (user-specified-position-p t :type boolean) ;; True when user specified x y
+  (user-specified-size-p t :type boolean)     ;; True when user specified width height
+  (x nil :type (or null int16))		      ;; Obsolete
+  (y nil :type (or null int16))		      ;; Obsolete
+  (width nil :type (or null card16))	      ;; Obsolete
+  (height nil :type (or null card16))	      ;; Obsolete
+  (min-width nil :type (or null card16))
+  (min-height nil :type (or null card16))
+  (max-width nil :type (or null card16))
+  (max-height nil :type (or null card16))
+  (width-inc nil :type (or null card16))
+  (height-inc nil :type (or null card16))
+  (min-aspect nil :type (or null number))
+  (max-aspect nil :type (or null number))
+  (base-width nil :type (or null card16))
+  (base-height nil :type (or null card16))
+  (win-gravity nil :type (or null win-gravity)))
+
+(defun wm-normal-hints (window)
+  (declare (type window window)
+	   (values wm-size-hints)))
+
+(defsetf wm-normal-hints (window) (wm-size-hints))
+
+;; ICON-SIZES uses the SIZE-HINTS structure
+
+(defun icon-sizes (window)
+  (declare (type window window)
+	   (values wm-size-hints)))
+  
+(defsetf icon-sizes (window) (wm-size-hints))
+
+(defun wm-protocols (window)
+  (declare (type window window)
+	   (values protocols)))
+  
+(defsetf wm-protocols (window) (protocols)
+  (declare (type window window)
+	   (type (list keyword) protocols)))
+
+(defun wm-colormap-windows (window)
+  (declare (type window window)
+	   (values windows)))
+  
+(defsetf wm-colormap-windows (window) (windows)
+  (declare (type window window)
+	   (type (list window) windows)))
+
+(defun transient-for (window)
+  (declare (type window window)
+	   (values window)))
+
+(defsetf transient-for (window) (transient)
+  (declare (type window window transient)))
+
+(defun set-wm-properties (window &rest options &key 
+			  name icon-name resource-name resource-class command
+			  hints normal-hints
+			  ;; the following are used for wm-normal-hints
+			  user-specified-position-p
+			  user-specified-size-p
+			  min-width min-height max-width max-height
+			  width-inc height-inc min-aspect max-aspect
+			  base-width base-height win-gravity
+			  ;; the following are used for wm-hints
+			  input initial-state icon-pixmap icon-window
+			  icon-x icon-y icon-mask window-group)
+  ;; Set properties for WINDOW.
+  (declare (type window window)
+	   (type (or null stringable) name icoin-name resource-name resource-class)
+	   (type (or null list) command)
+	   (type (or null wm-hints) hints)
+	   (type (or null wm-size-hints) normal-hints)
+	   (type (or null boolean) user-specified-position-p user-specified-size-p)
+	   (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity)
+	   (type (or null number) min-aspect max-aspect)
+	   (type (or null (member :off :on)) input)
+	   (type (or null (member :normal :iconic)) initial-state)
+	   (type (or null pixmap) icon-pixmap icon-mask)
+	   (type (or null window) icon-window)
+	   (type (or null card16) icon-x icon-y)
+	   (type (or null resource-id) window-group)))
+
+(defun iconify-window (window)
+  (declare (type window window)))
+
+(defun withdraw-window (window)
+  (declare (type window window)))
+ 
+(defstruct standard-colormap
+  (colormap nil :type (or null colormap))
+  (base-pixel 0 :type pixel)
+  (max-color nil :type (or null color))
+  (mult-color nil :type (or null color))
+  (visual nil :type (or null visual-info))
+  (kill nil :type (or (member nil :release-by-freeing-colormap)
+		      drawable gcontext cursor colormap font)))
+
+(defun rgb-colormaps (window property)
+  (declare (type window window)
+	   (type (member :rgb_default_map :rgb_best_map :rgb_red_map
+			 :rgb_green_map :rgb_blue_map) property)
+	   (values (list standard-colormap))))
+
+(defsetf rgb-colormaps (window property) (standard-colormaps)
+  (declare (type window window)
+	   (type (member :rgb_default_map :rgb_best_map :rgb_red_map
+			 :rgb_green_map :rgb_blue_map) property)
+	   (type (list standard-colormap) standard-colormaps)))
+
+(defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string)
+		                (transform #'card8->char) (start 0) end)
+  ;; Return the contents of cut-buffer BUFFER
+  (declare (type display display)
+	   (type (integer 0 7) buffer)
+	   (type xatom type)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type t result-type)			;a sequence type
+	   (type (or null (function (integer) t)) transform)
+	   (values sequence type format bytes-after)))
+
+(defsetf cut-buffer (display buffer &key (type :string) (format 8)
+			     (transform #'char->card8) (start 0) end) (data))
+
+(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
+  ;; Positive rotates left, negative rotates right (opposite of actual
+  ;; protocol request).  When careful-p, ensure all cut-buffer
+  ;; properties are defined, to prevent errors.
+  (declare (type display display)
+	   (type int16 delta)
+	   (type boolean careful-p)))
+
+;;;-----------------------------------------------------------------------------
+;;; Keycode mapping
+
+(defun define-keysym-set (set first-keysym last-keysym)
+  ;; Define all keysyms from first-keysym up to and including
+  ;; last-keysym to be in SET (returned from the keysym-set function).
+  ;; Signals an error if the keysym range overlaps an existing set.
+ (declare (type keyword set)
+	  (type keysym first-keysym last-keysym)))
+
+(defun keysym-set (keysym)
+  ;; Return the character code set name of keysym
+  ;; Note that the keyboard set (255) has been broken up into its parts.
+  (declare (type keysym keysym)
+	   (values keyword)))
+
+(defun define-keysym (object keysym &key lowercase translate modifiers mask display)	              
+  ;; Define the translation from keysym/modifiers to a (usually
+  ;; character) object.  ANy previous keysym definition with
+  ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
+  ;;
+  ;; MODIFIERS is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying when to use this
+  ;; keysym-translation.  The default is NIL.
+  ;;
+  ;; MASK is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying which modifiers to look at
+  ;; (i.e.  modifiers not specified are don't-cares).
+  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
+  ;; (i.e.  modifiers not specified by modifiers are don't cares)
+  ;; The default mask is *default-keysym-translate-mask*
+  ;;
+  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
+  ;; otherwise it will be the default translation for all displays.
+  ;;
+  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
+  ;; is the associated lowercase keysym.  This information is used
+  ;; by the keysym-both-case-p predicate (for caps-lock computations)
+  ;; and by the keysym-downcase function.
+  ;;
+  ;; TRANSLATE will be called with parameters (display state OBJECT)
+  ;; when translating KEYSYM and modifiers and mask are satisfied.
+  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
+  ;;                     (or modifiers 0)))
+  ;;      when mask and modifiers aren't lists of keysyms]
+  ;; The default is #'default-keysym-translate
+  ;;
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key))
+	         mask)
+	   (type (or null display) display)
+           (type (or null keysym) lowercase)
+	   (type (function (display card16 t) t) translate)))
+
+(defvar *default-keysym-translate-mask*
+	(the (or (member :modifiers) mask16 list)	; (list (or keysym state-mask-key))
+	     (logand #xff (lognot (make-state-mask :lock))))
+  "Default keysym state mask to use during keysym-translation.")
+
+(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
+  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
+  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null display) display)))
+
+(defun default-keysym-translate (display state object)
+  ;; If object is a character, char-bits are set from state.
+  ;; If object is a list, it is an alist with entries:
+  ;; (string-char [modifiers] [mask-modifiers)
+  ;; When MODIFIERS are specified, this character translation
+  ;; will only take effect when the specified modifiers are pressed.
+  ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
+  ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
+  ;; In ambiguous cases, the most specific translation is used.
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object)
+	   (values t))) ;; Object returned by keycode->character
+   
+(defmacro keysym (keysym &rest bytes)
+  ;; Build a keysym.
+  ;; If KEYSYM is an integer, it is used as the most significant bits of
+  ;; the keysym, and BYTES are used to specify low order bytes. The last
+  ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
+  ;; integer, the keysym associated with KEYSYM is returned.
+  ;;
+  ;; This is a macro and not a function macro to promote compile-time
+  ;; lookup. All arguments are evaluated.
+  (declare (type t keysym)
+	   (type (list card8) bytes)
+	   (values keysym)))
+
+(defun character->keysyms (character &optional display)
+  ;; Given a character, return a list of all matching keysyms.
+  ;; If DISPLAY is given, translations specific to DISPLAY are used,
+  ;; otherwise only global translations are used.
+  ;; Implementation dependent function.
+  ;; May be slow [i.e. do a linear search over all known keysyms]
+  (declare (type t character)
+	   (type (or null display) display)
+	   (values (list keysym))))
+
+(defun keycode->keysym (display keycode keysym-index)
+  (declare (type display display)
+	   (type card8 code)
+	   (type card16 state)
+	   (type card8 keysym-index)
+	   (values keysym)))
+
+(defun keysym->keycodes (display keysym)
+  ;; Return keycodes for keysym, as multiple values
+  (declare (type display display)
+	   (type keysym keysym)
+	   (values (or null keycode) (or null keycode) (or null keycode)))
+  )
+
+(defun keysym->character (display keysym &optional state)
+  ;; Find the character associated with a keysym.
+  ;; STATE is used for adding char-bits to character as follows:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type (or null card16) state)
+	   (values (or null character))))
+
+(defun keycode->character (display keycode state &key keysym-index
+	                   (keysym-index-function #'default-keysym-index))
+  ;; keysym-index defaults to the result of keysym-index-function which
+  ;; is called with the following parameters:
+  ;; (char0 state caps-lock-p keysyms-per-keycode)
+  ;; where char0 is the "character" object associated with keysym-index 0 and
+  ;; caps-lock-p is non-nil when the keysym associated with the lock
+  ;; modifier is for caps-lock.
+  ;; STATE is also used for setting char-bits:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type card8 keycode)
+	   (type card16 state)
+	   (type (or null card8) keysym-index)
+	   (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8))
+		 keysym-index-function)
+	   (values (or null character))))
+
+(defun default-keysym-index (display keycode state)
+  ;; Returns a keysym-index for use with keycode->character
+  (declare (values card8))
+)
+
+;;; default-keysym-index implements the following tables:
+;;;
+;;; control shift caps-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\8
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\*
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-8
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-*
+;;;
+;;; control shift shift-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\*
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\8
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-*
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-8
+
+(defun state-keysymp (display state keysym)
+  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
+  (declare (type display display)
+	   (type card16 state)
+	   (type keysym keysym)
+	   (values boolean)))
+
+(defun mapping-notify (display request start count)
+  ;; Called on a mapping-notify event to update
+  ;; the keyboard-mapping cache in DISPLAY
+  (declare (type display display)
+	   (type (member :modifier :keyboard :pointer) request)
+	   (type card8 start count)))
+
+(defun keysym-in-map-p (display keysym keymap)
+  ;; Returns T if keysym is found in keymap
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type (bit-vector 256) keymap)
+	   (value boolean)))
+
+(defun character-in-map-p (display character keymap)
+  ;; Implementation dependent function.
+  ;; Returns T if character is found in keymap
+  (declare (type display display)
+	   (type t character)
+	   (type (bit-vector 256) keymap)
+	   (value boolean)))
+
+;;;-----------------------------------------------------------------------------
+;;; Extensions
+
+(defmacro define-extension (name &key events errors)
+  ;; Define extension NAME with EVENTS and ERRORS.
+  ;; Note: The case of NAME is important.
+  ;; To define the request, Use:
+  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
+  ;;     See the REQUESTS file for lots of examples.
+  ;; To define event handlers, use declare-event.
+  ;; To define error handlers, use declare-error and define-condition.
+  (declare (type stringable name)
+	   (type (list symbol) events errors)))
+
+(defmacro extension-opcode (display name)
+  ;; Returns the major opcode for extension NAME.
+  ;; This is a macro to enable NAME to be interned for fast run-time
+  ;; retrieval. 
+  ;; Note: The case of NAME is important.
+  (declare (type display display)
+	   (type stringable name)
+	   (values card8)))
+
+(defmacro define-error (error-key function)
+  ;; Associate a function with ERROR-KEY which will be called with
+  ;; parameters DISPLAY and REPLY-BUFFER and returns a plist of
+  ;; keyword/value pairs which will be passed on to the error handler.
+  ;; A compiler warning is printed when ERROR-KEY is not defined in a
+  ;; preceding DEFINE-EXTENSION.
+  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
+  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
+  ;        an example.
+  (declare (type symbol error-key)
+	   (type function function)))
+
+;; All core errors use this, so we make it available to extensions.
+(defun decode-core-error (display event &optional arg)
+  ;; All core errors have the following keyword/argument pairs:
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;;    :current-sequence integer
+  ;; In addition, many have an additional argument that comes from the
+  ;; same place in the event, but is named differently.  When the ARG
+  ;; argument is specified, the keyword ARG with card32 value starting
+  ;; at byte 4 of the event is returned with the other keyword/argument
+  ;; pairs.
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type (or null keyword) arg)
+	   (values keyword/arg-plist)))
+
+;; This isn't new, just extended.
+(defmacro declare-event (event-codes &body declares)
+  ;; Used to indicate the keyword arguments for handler functions in
+  ;; process-event and event-case.
+  ;; Generates functions used in SEND-EVENT.
+  ;; A compiler warning is printed when all of EVENT-CODES are not
+  ;; defined by a preceding DEFINE-EXTENSION.
+  ;; See the INPUT file for lots of examples.
+  (declare (type (or keyword (list keywords)) event-codes)
+	   (type (alist (field-type symbol) (field-names (list symbol)))
+                 declares)))
+
+(defmacro define-gcontext-accessor (name &key default set-function copy-function)
+  ;; This will define a new gcontext accessor called NAME.
+  ;; Defines the gcontext-NAME accessor function and its defsetf.
+  ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
+  ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
+  ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
+  ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
+  ;; from create-gcontext, and force-gcontext-changes.
+  ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
+  ;; from copy-gcontext and copy-gcontext-components.
+  ;; The copy-function defaults to:
+  ;; (lambda (ignore dst-gc value)
+  ;;    (if value
+  ;;	    (,set-function dst-gc value)
+  ;;	  (error "Can't copy unknown GContext component ~a" ',name)))
+  (declare (type symbol name)
+	   (type t default)
+	   (type (function (gcontext t) t) set-function) ;; required
+	   (type (or null (function (gcontext gcontext t) t))
+		 copy-function)))
+
+
+;; To aid extension implementors in attaching additional information to
+;; clx data structures, the following accessors (with SETF's) are
+;; defined.  GETF can be used on these to extend the structures.
+
+display-plist
+screen-plist
+visual-info-plist
+gcontext-plist
+font-plist
+drawable-plist
+
+
+
+;;; These have had perhaps even less review.
+
+;;; Add some of the functionality provided by the C XLIB library.
+;;;
+;;; LaMott G. Oren, Texas Instruments  10/87
+;;; 
+;;; Design Contributors:
+;;;	Robert W. Scheifler, MIT
+
+;;;-----------------------------------------------------------------------------
+;;; Regions (not yet implemented)
+
+;;; Regions are arbitrary collections of pixels.  This is represented
+;;; in the region structure as either a list of rectangles or a bitmap.
+
+(defun make-region (&optional x y width height)
+  ;; With no parameters, returns an empty region
+  ;; If some parameters are given, all must be given.
+  (declare (type (or null int16) x y width height)
+	   (values region)))
+
+(defun region-p (thing))
+
+(defun copy-region (region))
+
+(defun region-empty-p (region)
+  (declare (type region region)
+	   (values boolean)))
+
+(defun region-clip-box (region)
+  ;; Returns a region which is the smallest enclosing rectangle
+  ;; enclosing REGION
+  (declare (type region region)
+	   (values region)))
+
+;; Accessors that return the boundaries of a region
+(defun region-x (region))
+(defun region-y (region))
+(defun region-width (region))
+(defun region-height (region))
+
+(defsetf region-x (region) (x))
+(defsetf region-y (region) (y))
+;; Setting a region's X/Y translates the region
+
+(defun region-intersection (&rest regions)
+  "Returns a region which is the intersection of one or more REGIONS.
+Returns an empty region if the intersection is empty.
+If there are no regions given, return a very large region."
+  (declare (type (list region) regions)
+	   (values region)))
+
+(defun region-union (&rest regions)
+  "Returns a region which is the union of a number of REGIONS
+ (i.e. the smallest region that can contain all the other regions)
+ Returns the empty region if no regions are given."
+  (declare (type (list region) regions)
+	   (values region)))
+
+(defun region-subtract (region subtract)
+  "Returns a region containing the points that are in REGION but not in SUBTRACT"
+  (declare (type region region subtract)
+	   (values region)))
+
+(defun point-in-region-p (region x y)
+  ;; Returns T when X/Y are a point within REGION.
+  (declare (type region region)
+	   (type int16 x y)
+	   (values boolean)))
+
+(defun region-equal (a b)
+  ;; Returns T when regions a and b contain the same points.
+  ;; That is, return t when for every X/Y (point-in-region-p a x y)
+  ;; equals (point-in-region-p b x y)
+  (declare (type region a b)
+	   (values boolean)))
+
+(defun subregion-p (large small)
+  "Returns T if SMALL is within LARGE.
+ That is, return T when for every X/Y (point-in-region-p small X Y)
+ implies (point-in-region-p large X Y)."
+  (declare (type region large small)
+	   (values boolean)))
+
+(defun region-intersect-p (a b)
+  "Returns T if A intersects B.
+ That is, return T when there is some point common to regions A and B."
+  (declare (type region a b)
+	   (values boolean)))
+
+(defun map-region (region function &rest args)
+  ;; Calls function with arguments (x y . args) for every point in REGION.
+  (declare (type region region)
+	   (type (function x y &rest args) function)))
+
+;;   Why isn't it better to augment
+;;   gcontext-clip-mask to deal with
+;;   	(or null (member :none) pixmap rect-seq region)
+;;   and force conversions on the caller?
+;; Good idea.
+
+;;(defun gcontext-clip-region (gcontext)
+;;  ;; If the clip-mask of GCONTEXT is known, return it as a region.
+;;  (declare (type gcontext gcontext)
+;;	   (values (or null region))))
+
+;;(defsetf gcontext-clip-region (gcontext) (region)
+;;  ;; Set the clip-rectangles or clip-mask for for GCONTEXT to include
+;;  ;; only the pixels within REGION.
+;;  (declare (type gcontext gcontext)
+;;	   (type region region)))
+
+(defun image->region (image)
+  ;; Returns a region containing the 1 bits of a depth-1 image
+  ;; Signals an error if image isn't of depth 1.
+  (declare (type image image)
+	   (values region)))
+
+(defun region->image (region)
+  ;; Returns a depth-1 image containg 1 bits for every pixel in REGION.
+  (declare (type region region)
+	   (values image)))
+
+(defun polygon-region (points &optional (fill-rule :even-odd))
+  (declare (type sequence points) ;(repeat-seq (integer x) (integer y))
+	   (type (member :even-odd :winding) fill-rule)
+	   (values region)))
+
+;;;-----------------------------------------------------------------------------
+;;; IMAGE functions
+
+
+(deftype bitmap () '(array bit (* *)))
+(deftype pixarray () '(array pixel (* *)))
+
+(defconstant *lisp-byte-lsb-first-p* #+lispm t #-lispm nil
+	     "Byte order in pixel arrays")
+
+(defstruct image
+  ;; Public structure
+  (width 0 :type card16 :read-only t)
+  (height 0 :type card16 :read-only t)
+  (depth 1 :type card8 :read-only t)
+  (plist nil :type list))
+
+;; Image-Plist accessors:
+(defun image-name (image))
+(defun image-x-hot (image))
+(defun image-y-hot (image))
+(defun image-red-mask (image))
+(defun image-blue-mask (image))
+(defun image-green-mask (image))
+
+(defsetf image-name (image) (name))
+(defsetf image-x-hot (image) (x))
+(defsetf image-y-hot (image) (y))
+(defsetf image-red-mask (image) (mask))
+(defsetf image-blue-mask (image) (mask))
+(defsetf image-green-mask (image) (mask))
+
+(defstruct (image-x (:include image))
+  ;; Use this format for shoveling image data
+  ;; Private structure. Accessors for these NOT exported.
+  (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
+  (bytes-per-line 0 :type card16)
+  (scanline-pad 32 :type (member 8 16 32))
+  (bits-per-pixel 0 :type (member 1 4 8 16 24 32))
+  (bit-lsb-first-p nil :type boolean)		; Bit order
+  (byte-lsb-first-p nil :type boolean)		; Byte order
+  (data #() :type (array card8 (*))))		; row-major
+
+(defstruct (image-xy (:include image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bitmap-list nil :type (list bitmap)))
+
+(defstruct (image-z (:include image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bits-per-pixel 0 :type (member 1 4 8 16 24 32))
+  (pixarray #() :type pixarray))
+
+(defun create-image (&key (width (required-arg width))
+		          (height (required-arg height))
+		     depth data plist name x-hot y-hot
+		     red-mask blue-mask green-mask
+		     bits-per-pixel format scanline-pad bytes-per-line
+		     byte-lsb-first-p bit-lsb-first-p )
+  ;; Returns an image-x image-xy or image-z structure, depending on the
+  ;; type of the :DATA parameter.
+  (declare
+    (type card16 width height)			; Required
+    (type (or null card8) depth)		; Defualts to 1
+    (type (or (array card8 (*))			;Returns image-x
+	      (list bitmap)			;Returns image-xy
+	      pixarray) data)			;Returns image-z
+    (type list plist)
+    (type (or null stringable) name)
+    (type (or null card16) x-hot y-hot)
+    (type (or null pixel) red-mask blue-mask green-mask)
+    (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
+
+    ;; The following parameters are ignored for image-xy and image-z:
+    (type (or null (member :bitmap :xy-pixmap :z-pixmap))
+	  format)				; defaults to :z-pixmap
+    (type (or null (member 8 16 32)) scanline-pad)
+    (type (or null card16) bytes-per-line) ;default from width and scanline-pad
+    (type boolean byte-lsb-first-p bit-lsb-first-p)
+    (values image)))
+
+(defun get-image (drawable &key 
+		  (x (required-arg x))
+		  (y (required-arg y))
+		  (width (required-arg width))
+		  (height (required-arg height))
+		  plane-mask format result-type)
+  ;; Get an image from the server.
+  ;; Format defaults to :z-pixmap.  Result-Type defaults from Format,
+  ;; image-z for :z-pixmap, and image-xy for :xy-pixmap.
+  ;; Plane-mask defaults to #xFFFFFFFF.
+  ;; Returns an image-x image-xy or image-z structure, depending on the
+  ;; result-type parameter.
+  (declare (type drawable drawable)
+	   (type int16 x y) ;; required
+	   (type card16 width height) ;; required
+	   (type (or null pixel) plane-mask)
+	   (type (or null (member :xy-pixmap :z-pixmap)) format)
+	   (type (or null (member image-x image-xy image-z)) result-type)
+	   (values image)))
+
+(defun put-image (drawable gcontext image &key
+		  (src-x 0) (src-y 0)
+		  (x (required-arg x))
+		  (y (required-arg y))
+		  width height
+		  bitmap-p)
+  ;; When BITMAP-P, force format to be :bitmap when depth=1
+  ;; This causes gcontext to supply foreground & background pixels.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type image image)
+	   (type int16 x y) ;; required
+	   (type (or null card16) width height)
+	   (type boolean bitmap-p)))
+
+(defun copy-image (image &key (x 0) (y 0) width height result-type)
+  ;; Copy with optional sub-imaging and format conversion.
+  ;; result-type defaults to (type-of image)
+  (declare (type image image)
+	   (type card16 x y)
+	   (type (or null card16) width height) ;; Default from image
+	   (type (or null (member image-x image-xy image-z)) result-type)
+	   (values image)))
+
+(defun read-bitmap-file (pathname)
+  ;; Creates an image from a C include file in standard X11 format
+  (declare (type (or pathname string stream) pathname)
+	   (values image)))
+
+(defun write-bitmap-file (pathname image &optional name)
+  ;; Writes an image to a C include file in standard X11 format
+  ;; NAME argument used for variable prefixes.  Defaults to "image"
+  (declare (type (or pathname string stream) pathname)
+	   (type image image)
+	   (type (or null stringable) name)))
+
+;;;-----------------------------------------------------------------------------
+;;; Resource data-base
+
+
+(defun make-resource-database ()
+  ;; Returns an empty resource data-base
+  (declare (values resource-database)))
+
+(defun get-resource (database value-name value-class full-name full-class)
+  ;; Return the value of the resource in DATABASE whose partial name
+  ;; most closely matches (append full-name (list value-name)) and
+  ;;                      (append full-class (list value-class)).
+  (declare (type resource-database database)
+	   (type stringable value-name value-class)
+	   (type (list stringable) full-name full-class)
+	   (values value)))
+
+(defun add-resource (database name-list value)
+  ;; name-list is a list of either strings or symbols. If a symbol, 
+  ;; case-insensitive comparisons will be used, if a string,
+  ;; case-sensitive comparisons will be used.  The symbol '* or
+  ;; string "*" are used as wildcards, matching anything or nothing.
+  (declare (type resource-database database)
+	   (type (list stringable) name-list)
+	   (type t value)))
+
+(defun delete-resource (database name-list)
+  (declare (type resource-database database)
+	   (type (list stringable) name-list)))
+
+(defun map-resource (database function &rest args)
+  ;; Call FUNCTION on each resource in DATABASE.
+  ;; FUNCTION is called with arguments (name-list value . args)
+  (declare (type resource-database database)
+	   (type (function ((list stringable) t &rest t) t) function)
+	   (values nil)))
+
+(defun merge-resources (database with-database)
+  (declare (type resource-database database with-database)
+	   (values resource-database))
+  (map-resource #'add-resource database with-database)
+  with-database)
+
+;; Note: with-input-from-string can be used with read-resources to define
+;;       default resources in a program file.
+
+(defun read-resources (database pathname &key key test test-not)
+  ;; Merges resources from a file in standard X11 format with DATABASE.
+  ;; KEY is a function used for converting value-strings, the default is
+  ;; identity.  TEST and TEST-NOT are predicates used for filtering
+  ;; which resources to include in the database.  They are called with
+  ;; the name and results of the KEY function.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function ((list string) t) boolean))
+                 test test-not)
+	   (values resource-database)))
+
+(defun write-resources (database pathname &key write test test-not)
+  ;; Write resources to PATHNAME in the standard X11 format.
+  ;; WRITE is a function used for writing values, the default is #'princ
+  ;; TEST and TEST-NOT are predicates used for filtering which resources
+  ;; to include in the database.  They are called with the name and value.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string stream) t)) write)
+	   (type (or null (function ((list string) t) boolean))
+                 test test-not)))
+
+(defun root-resources (screen &key database key test test-not)
+  "Returns a resource database containing the contents of the root window
+   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
+   then its default screen is used. If an existing DATABASE is given, then
+   resource values are merged with the DATABASE and the modified DATABASE is
+   returned.
+
+   TEST and TEST-NOT are predicates for selecting which resources are
+   read.  Arguments are a resource name list and a resource value. The KEY
+   function, if given, is called to convert a resource value string to the
+   value given to TEST or TEST-NOT."
+
+  (declare (type (or screen display) screen)
+	   (type (or null resource-database) database)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean)) test test-not)
+	   (values resource-database)))
+
+(defsetf root-resources (screen &key test test-not (write 'princ)) (database)
+  "Changes the contents of the root window RESOURCE_MANAGER property for the
+   given SCREEN. If SCREEN is a display, then its default screen is used. 
+
+   TEST and TEST-NOT are predicates for selecting which resources from the
+   DATABASE are written.  Arguments are a resource name list and a resource
+   value.  The WRITE function is used to convert a resource value into a
+   string stored in the property."
+
+  (declare (type (or screen display) screen)
+	(type (or null resource-database) database)
+	(type (or null (function (list t) boolean)) test test-not)
+	(type (or null (function (string stream) t)) write)
+	(values resource-database)))
+
+;;;-----------------------------------------------------------------------------
+;;; Shared GContext's
+
+(defmacro using-gcontext ((var &rest options &key drawable
+			       function plane-mask foreground background
+			       line-width line-style cap-style
+			       join-style fill-style fill-rule arc-mode
+			       tile stipple ts-x ts-y font
+			       subwindow-mode exposures clip-x clip-y
+			       clip-mask clip-ordering dash-offset
+			       dashes)
+			  &body body)
+  ;; Equivalent to (let ((var (apply #'make-gcontext options))) ,@body)
+  ;; but more efficient because it uses a gcontext cache associated with
+  ;; drawable's display.
+  )
+
+
+
+ X11 Request Name       CLX Function Name
+-----------------       -----------------
+AllocColor              ALLOC-COLOR
+AllocColorCells         ALLOC-COLOR-CELLS
+AllocColorPlanes        ALLOC-COLOR-PLANES
+AllocNamedColor         ALLOC-COLOR
+AllowEvents             ALLOW-EVENTS
+Bell                    BELL
+ChangeAccessControl     (setf (ACCESS-CONTROL display) boolean)
+ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB
+ChangeCloseDownMode     (setf (CLOSE-DOWN-MODE display) mode)
+ChangeGC                FORCE-GCONTEXT-CHANGES
+     ;; See WITH-GCONTEXT
+     (setf (gcontext-function gc) boole-constant)
+     (setf (gcontext-plane-mask gc) card32)
+     (setf (gcontext-foreground gc) card32)
+     (setf (gcontext-background gc) card32)
+     (setf (gcontext-line-width gc) card16)
+     (setf (gcontext-line-style gc) keyword)
+     (setf (gcontext-cap-style gc) keyword)
+     (setf (gcontext-join-style gc) keyword)
+     (setf (gcontext-fill-style gc) keyword)
+     (setf (gcontext-fill-rule gc) keyword)
+     (setf (gcontext-tile gc) pixmap)
+     (setf (gcontext-stipple gc) pixmap)
+     (setf (gcontext-ts-x gc) int16) ;; Tile-Stipple-X-origin
+     (setf (gcontext-ts-y gc) int16) ;; Tile-Stipple-Y-origin
+     (setf (gcontext-font gc &optional metrics-p) font)
+     (setf (gcontext-subwindow-mode gc) keyword)
+     (setf (gcontext-exposures gc) (member :on :off))
+     (setf (gcontext-clip-x gc) int16)
+     (setf (gcontext-clip-y gc) int16)
+     (setf (gcontext-clip-mask gc &optional ordering)
+	   (or (member :none) pixmap rect-seq))
+     (setf (gcontext-dash-offset gc) card16)
+     (setf (gcontext-dashes gc) (or card8 sequence))
+     (setf (gcontext-arc-mode gc) (member :chord :pie-slice))
+     (setf (gcontext-clip-ordering gc) keyword)
+
+ChangeHosts             ADD-ACCESS-HOST
+ChangeHosts             REMOVE-ACCESS-HOST
+ChangeKeyboardControl   CHANGE-KEYBOARD-CONTROL
+ChangePointerControl    CHANGE-POINTER-CONTROL
+ChangeProperty          CHANGE-PROPERTY
+ChangeSaveSet           REMOVE-FROM-SAVE-SET
+ChangeSaveSet           ADD-TO-SAVE-SET
+ChangeWindowAttributes
+     ;; See WITH-STATE
+     (setf (window-background window) value)
+     (setf (window-border window) value)
+     (setf (window-bit-gravity window) value)
+     (setf (window-gravity window) value)
+     (setf (window-backing-store window) value)
+     (setf (window-backing-planes window) value)
+     (setf (window-backing-pixel window) value)
+     (setf (window-override-redirect window) value)
+     (setf (window-save-under window) value)
+     (setf (window-colormap window) value)
+     (setf (window-cursor window) value)
+     (setf (window-event-mask window) value)
+     (setf (window-do-not-propagate-mask window) value)
+
+CirculateWindow         CIRCULATE-WINDOW-DOWN
+CirculateWindow         CIRCULATE-WINDOW-UP
+ClearToBackground       CLEAR-AREA
+CloseFont               CLOSE-FONT
+ConfigureWindow
+     ;; See WITH-STATE
+     (setf (drawable-x drawable) integer)
+     (setf (drawable-y drawable) integer)
+     (setf (drawable-width drawable) integer)
+     (setf (drawable-height drawable) integer)
+     (setf (drawable-depth drawable) integer)
+     (setf (drawable-border-width drawable) integer)
+     (setf (window-priority window &optional sibling) integer)
+
+ConvertSelection        CONVERT-SELECTION
+CopyArea                COPY-AREA
+CopyColormapAndFree     COPY-COLORMAP-AND-FREE
+CopyGC                  COPY-GCONTEXT
+CopyGC                  COPY-GCONTEXT-COMPONENTS
+CopyPlane               COPY-PLANE
+CreateColormap          CREATE-COLORMAP
+CreateCursor            CREATE-CURSOR
+CreateGC                CREATE-GCONTEXT
+CreateGlyphCursor       CREATE-GLYPH-CURSOR
+CreatePixmap            CREATE-PIXMAP
+CreateWindow            CREATE-WINDOW
+DeleteProperty          DELETE-PROPERTY
+DestroySubwindows       DESTROY-SUBWINDOWS
+DestroyWindow           DESTROY-WINDOW
+FillPoly                DRAW-LINES
+ForceScreenSaver        RESET-SCREEN-SAVER
+ForceScreenSaver        ACTIVATE-SCREEN-SAVER
+FreeColormap            FREE-COLORMAP
+FreeColors              FREE-COLORS
+FreeCursor              FREE-CURSOR
+FreeGC                  FREE-GCONTEXT
+FreePixmap              FREE-PIXMAP
+GetAtomName             ATOM-NAME
+GetFontPath             FONT-PATH
+GetGeometry             ;; See WITH-STATE
+                        DRAWABLE-ROOT
+                        DRAWABLE-X
+                        DRAWABLE-Y
+                        DRAWABLE-WIDTH
+                        DRAWABLE-HEIGHT
+                        DRAWABLE-DEPTH
+                        DRAWABLE-BORDER-WIDTH
+
+GetImage                GET-RAW-IMAGE
+GetInputFocus           INPUT-FOCUS
+GetKeyboardControl      KEYBOARD-CONTROL
+GetKeyboardMapping      KEYBOARD-MAPPING
+GetModifierMapping      MODIFIER-MAPPING
+GetMotionEvents         MOTION-EVENTS
+GetPointerControl       POINTER-CONTROL
+GetPointerMapping       POINTER-MAPPING
+GetProperty             GET-PROPERTY
+GetScreenSaver          SCREEN-SAVER
+GetSelectionOwner       SELECTION-OWNER
+GetWindowAttributes     ;; See WITH-STATE
+                        WINDOW-VISUAL-INFO
+                        WINDOW-CLASS
+                        WINDOW-BIT-GRAVITY
+                        WINDOW-GRAVITY
+                        WINDOW-BACKING-STORE
+                        WINDOW-BACKING-PLANES
+                        WINDOW-BACKING-PIXEL
+                        WINDOW-SAVE-UNDER
+                        WINDOW-OVERRIDE-REDIRECT
+                        WINDOW-EVENT-MASK
+                        WINDOW-DO-NOT-PROPAGATE-MASK
+                        WINDOW-COLORMAP
+                        WINDOW-COLORMAP-INSTALLED-P
+                        WINDOW-ALL-EVENT-MASKS
+                        WINDOW-MAP-STATE
+
+GrabButton              GRAB-BUTTON
+GrabKey                 GRAB-KEY
+GrabKeyboard            GRAB-KEYBOARD
+GrabPointer             GRAB-POINTER
+GrabServer              GRAB-SERVER
+ImageText16             DRAW-IMAGE-GLYPHS
+ImageText16             DRAW-IMAGE-GLYPH
+ImageText8              DRAW-IMAGE-GLYPHS
+InstallColormap         INSTALL-COLORMAP
+InternAtom              FIND-ATOM
+InternAtom              INTERN-ATOM
+KillClient              KILL-TEMPORARY-CLIENTS
+KillClient              KILL-CLIENT
+ListExtensions          LIST-EXTENSIONS
+ListFonts               LIST-FONT-NAMES
+ListFontsWithInfo       LIST-FONTS
+ListHosts               ACCESS-CONTROL
+ListHosts               ACCESS-HOSTS
+ListInstalledColormaps  INSTALLED-COLORMAPS
+ListProperties          LIST-PROPERTIES
+LookupColor             LOOKUP-COLOR
+MapSubwindows           MAP-SUBWINDOWS
+MapWindow               MAP-WINDOW
+OpenFont                OPEN-FONT
+PolyArc                 DRAW-ARC
+PolyArc                 DRAW-ARCS
+PolyFillArc             DRAW-ARC
+PolyFillArc             DRAW-ARCS
+PolyFillRectangle       DRAW-RECTANGLE
+PolyFillRectangle       DRAW-RECTANGLES
+PolyLine                DRAW-LINE
+PolyLine                DRAW-LINES
+PolyPoint               DRAW-POINT
+PolyPoint               DRAW-POINTS
+PolyRectangle           DRAW-RECTANGLE
+PolyRectangle           DRAW-RECTANGLES
+PolySegment             DRAW-SEGMENTS
+PolyText16              DRAW-GLYPH
+PolyText16              DRAW-GLYPHS
+PolyText8               DRAW-GLYPHS
+PutImage                PUT-RAW-IMAGE
+QueryBestSize           QUERY-BEST-CURSOR
+QueryBestSize           QUERY-BEST-STIPPLE
+QueryBestSize           QUERY-BEST-TILE
+QueryColors             QUERY-COLORS
+QueryExtension          QUERY-EXTENSION
+QueryFont               FONT-NAME
+                        FONT-NAME
+                        FONT-DIRECTION
+                        FONT-MIN-CHAR
+                        FONT-MAX-CHAR
+                        FONT-MIN-BYTE1
+                        FONT-MAX-BYTE1
+                        FONT-MIN-BYTE2
+                        FONT-MAX-BYTE2
+                        FONT-ALL-CHARS-EXIST-P
+                        FONT-DEFAULT-CHAR
+                        FONT-ASCENT
+                        FONT-DESCENT
+                        FONT-PROPERTIES
+                        FONT-PROPERTY
+     
+                        CHAR-LEFT-BEARING
+                        CHAR-RIGHT-BEARING
+                        CHAR-WIDTH
+                        CHAR-ASCENT
+                        CHAR-DESCENT
+                        CHAR-ATTRIBUTES
+     
+                        MIN-CHAR-LEFT-BEARING
+                        MIN-CHAR-RIGHT-BEARING
+                        MIN-CHAR-WIDTH
+                        MIN-CHAR-ASCENT
+                        MIN-CHAR-DESCENT
+                        MIN-CHAR-ATTRIBUTES
+     
+                        MAX-CHAR-LEFT-BEARING
+                        MAX-CHAR-RIGHT-BEARING
+                        MAX-CHAR-WIDTH
+                        MAX-CHAR-ASCENT
+                        MAX-CHAR-DESCENT
+                        MAX-CHAR-ATTRIBUTES
+
+QueryKeymap             QUERY-KEYMAP
+QueryPointer            GLOBAL-POINTER-POSITION
+QueryPointer            POINTER-POSITION
+QueryPointer            QUERY-POINTER
+QueryTextExtents        TEXT-EXTENTS
+QueryTextExtents        TEXT-WIDTH
+QueryTree               QUERY-TREE
+RecolorCursor           RECOLOR-CURSOR
+ReparentWindow          REPARENT-WINDOW
+RotateProperties        ROTATE-PROPERTIES
+SendEvent               SEND-EVENT
+SetClipRectangles       FORCE-GCONTEXT-CHANGES
+     ;; See WITH-GCONTEXT
+     (setf (gcontext-clip-x gc) int16)
+     (setf (gcontext-clip-y gc) int16)
+     (setf (gcontext-clip-mask gc &optional ordering)
+	   (or (member :none) pixmap rect-seq))
+     (setf (gcontext-clip-ordering gc) keyword)
+
+SetDashes               FORCE-GCONTEXT-CHANGES
+     ;; See WITH-GCONTEXT
+     (setf (gcontext-dash-offset gc) card16)
+     (setf (gcontext-dashes gc) (or card8 sequence))
+
+SetFontPath
+     (setf (font-path font) paths)
+	Where paths is (type (sequence (or string pathname)))
+
+SetInputFocus           SET-INPUT-FOCUS
+SetKeyboardMapping      CHANGE-KEYBOARD-MAPPING
+SetModifierMapping      SET-MODIFIER-MAPPING
+SetPointerMapping       SET-POINTER-MAPPING
+SetScreenSaver          SET-SCREEN-SAVER
+SetSelectionOwner       SET-SELECTION-OWNER
+StoreColors             STORE-COLOR
+StoreColors             STORE-COLORS
+StoreNamedColor         STORE-COLOR
+StoreNamedColor         STORE-COLORS
+TranslateCoords         TRANSLATE-COORDINATES
+UngrabButton            UNGRAB-BUTTON
+UngrabKey               UNGRAB-KEY
+UngrabKeyboard          UNGRAB-KEYBOARD
+UngrabPointer           UNGRAB-POINTER
+UngrabServer            UNGRAB-SERVER
+UninstallColormap       UNINSTALL-COLORMAP
+UnmapSubwindows         UNMAP-SUBWINDOWS
+UnmapWindow             UNMAP-WINDOW
+WarpPointer             WARP-POINTER
+WarpPointer             WARP-POINTER-IF-INSIDE
+WarpPointer             WARP-POINTER-RELATIVE
+WarpPointer             WARP-POINTER-RELATIVE-IF-INSIDE
+NoOperation             NO-OPERATION
+
+
+
+ X11 Request Name       CLX Function Name
+-----------------       -----------------
+ListHosts               ACCESS-CONTROL
+ListHosts               ACCESS-HOSTS
+ForceScreenSaver        ACTIVATE-SCREEN-SAVER
+ChangeHosts             ADD-ACCESS-HOST
+ChangeSaveSet           ADD-TO-SAVE-SET
+AllocColor              ALLOC-COLOR
+AllocNamedColor         ALLOC-COLOR
+AllocColorCells         ALLOC-COLOR-CELLS
+AllocColorPlanes        ALLOC-COLOR-PLANES
+AllowEvents             ALLOW-EVENTS
+GetAtomName             ATOM-NAME
+Bell                    BELL
+ChangeActivePointerGrab CHANGE-ACTIVE-POINTER-GRAB
+ChangeKeyboardControl   CHANGE-KEYBOARD-CONTROL
+SetKeyboardMapping      CHANGE-KEYBOARD-MAPPING
+ChangePointerControl    CHANGE-POINTER-CONTROL
+ChangeProperty          CHANGE-PROPERTY
+QueryFont               CHAR-ASCENT
+QueryFont               CHAR-ATTRIBUTES
+QueryFont               CHAR-DESCENT
+QueryFont               CHAR-LEFT-BEARING
+QueryFont               CHAR-RIGHT-BEARING
+QueryFont               CHAR-WIDTH
+CirculateWindow         CIRCULATE-WINDOW-DOWN
+CirculateWindow         CIRCULATE-WINDOW-UP
+ClearToBackground       CLEAR-AREA
+CloseFont               CLOSE-FONT
+ConvertSelection        CONVERT-SELECTION
+CopyArea                COPY-AREA
+CopyColormapAndFree     COPY-COLORMAP-AND-FREE
+CopyGC                  COPY-GCONTEXT
+CopyGC                  COPY-GCONTEXT-COMPONENTS
+CopyPlane               COPY-PLANE
+CreateColormap          CREATE-COLORMAP
+CreateCursor            CREATE-CURSOR
+CreateGC                CREATE-GCONTEXT
+CreateGlyphCursor       CREATE-GLYPH-CURSOR
+CreatePixmap            CREATE-PIXMAP
+CreateWindow            CREATE-WINDOW
+DeleteProperty          DELETE-PROPERTY
+DestroySubwindows       DESTROY-SUBWINDOWS
+DestroyWindow           DESTROY-WINDOW
+PolyArc                 DRAW-ARC
+PolyArc                 DRAW-ARCS
+PolyText16              DRAW-GLYPH
+PolyText16              DRAW-GLYPHS
+PolyText8               DRAW-GLYPHS
+ImageText16             DRAW-IMAGE-GLYPH
+ImageText16             DRAW-IMAGE-GLYPHS
+ImageText8              DRAW-IMAGE-GLYPHS
+PolyLine                DRAW-LINE
+PolyLine                DRAW-LINES
+PolyPoint               DRAW-POINT
+PolyPoint               DRAW-POINTS
+PolyFillRectangle       DRAW-RECTANGLE
+PolyRectangle           DRAW-RECTANGLE
+PolyFillRectangle       DRAW-RECTANGLES
+PolyRectangle           DRAW-RECTANGLES
+PolySegment             DRAW-SEGMENTS
+GetGeometry             DRAWABLE-BORDER-WIDTH
+GetGeometry             DRAWABLE-DEPTH
+GetGeometry             DRAWABLE-HEIGHT
+GetGeometry             DRAWABLE-ROOT
+GetGeometry             DRAWABLE-WIDTH
+GetGeometry             DRAWABLE-X
+GetGeometry             DRAWABLE-Y
+FillPoly                FILL-POLYGON
+InternAtom              FIND-ATOM
+QueryFont               FONT-ALL-CHARS-EXIST-P
+QueryFont               FONT-ASCENT
+QueryFont               FONT-DEFAULT-CHAR
+QueryFont               FONT-DESCENT
+QueryFont               FONT-DIRECTION
+QueryFont               FONT-MAX-BYTE1
+QueryFont               FONT-MAX-BYTE2
+QueryFont               FONT-MAX-CHAR
+QueryFont               FONT-MIN-BYTE1
+QueryFont               FONT-MIN-BYTE2
+QueryFont               FONT-MIN-CHAR
+QueryFont               FONT-NAME
+QueryFont               FONT-NAME
+GetFontPath             FONT-PATH
+QueryFont               FONT-PROPERTIES
+QueryFont               FONT-PROPERTY
+ChangeGC                FORCE-GCONTEXT-CHANGES
+SetClipRectangles       FORCE-GCONTEXT-CHANGES
+SetDashes               FORCE-GCONTEXT-CHANGES
+FreeColormap            FREE-COLORMAP
+FreeColors              FREE-COLORS
+FreeCursor              FREE-CURSOR
+FreeGC                  FREE-GCONTEXT
+FreePixmap              FREE-PIXMAP
+GetProperty             GET-PROPERTY
+GetImage                GET-RAW-IMAGE
+QueryPointer            GLOBAL-POINTER-POSITION
+GrabButton              GRAB-BUTTON
+GrabKey                 GRAB-KEY
+GrabKeyboard            GRAB-KEYBOARD
+GrabPointer             GRAB-POINTER
+GrabServer              GRAB-SERVER
+GrabServer              WITH-SERVER-GRABBED
+GetInputFocus           INPUT-FOCUS
+InstallColormap         INSTALL-COLORMAP
+ListInstalledColormaps  INSTALLED-COLORMAPS
+InternAtom              INTERN-ATOM
+GetKeyboardControl      KEYBOARD-CONTROL
+GetKeyboardMapping      KEYBOARD-MAPPING
+KillClient              KILL-CLIENT
+KillClient              KILL-TEMPORARY-CLIENTS
+ListExtensions          LIST-EXTENSIONS
+ListFonts               LIST-FONT-NAMES
+ListFontsWithInfo       LIST-FONTS
+ListProperties          LIST-PROPERTIES
+LookupColor             LOOKUP-COLOR
+MapSubwindows           MAP-SUBWINDOWS
+MapWindow               MAP-WINDOW
+QueryFont               MAX-CHAR-ASCENT
+QueryFont               MAX-CHAR-ATTRIBUTES
+QueryFont               MAX-CHAR-DESCENT
+QueryFont               MAX-CHAR-LEFT-BEARING
+QueryFont               MAX-CHAR-RIGHT-BEARING
+QueryFont               MAX-CHAR-WIDTH
+QueryFont               MIN-CHAR-ASCENT
+QueryFont               MIN-CHAR-ATTRIBUTES
+QueryFont               MIN-CHAR-DESCENT
+QueryFont               MIN-CHAR-LEFT-BEARING
+QueryFont               MIN-CHAR-RIGHT-BEARING
+QueryFont               MIN-CHAR-WIDTH
+GetModifierMapping      MODIFIER-MAPPING
+GetMotionEvents         MOTION-EVENTS
+NoOperation             NO-OPERATION
+OpenFont                OPEN-FONT
+GetPointerControl       POINTER-CONTROL
+GetPointerMapping       POINTER-MAPPING
+QueryPointer            POINTER-POSITION
+PutImage                PUT-RAW-IMAGE
+QueryBestSize           QUERY-BEST-CURSOR
+QueryBestSize           QUERY-BEST-STIPPLE
+QueryBestSize           QUERY-BEST-TILE
+QueryColors             QUERY-COLORS
+QueryExtension          QUERY-EXTENSION
+QueryKeymap             QUERY-KEYMAP
+QueryPointer            QUERY-POINTER
+QueryTree               QUERY-TREE
+RecolorCursor           RECOLOR-CURSOR
+ChangeHosts             REMOVE-ACCESS-HOST
+ChangeSaveSet           REMOVE-FROM-SAVE-SET
+ReparentWindow          REPARENT-WINDOW
+ForceScreenSaver        RESET-SCREEN-SAVER
+RotateProperties        ROTATE-PROPERTIES
+GetScreenSaver          SCREEN-SAVER
+GetSelectionOwner       SELECTION-OWNER
+SendEvent               SEND-EVENT
+ChangeAccessControl     SET-ACCESS-CONTROL
+ChangeCloseDownMode     SET-CLOSE-DOWN-MODE
+SetInputFocus           SET-INPUT-FOCUS
+SetModifierMapping      SET-MODIFIER-MAPPING
+SetPointerMapping       SET-POINTER-MAPPING
+SetScreenSaver          SET-SCREEN-SAVER
+SetSelectionOwner       SET-SELECTION-OWNER
+StoreColors             STORE-COLOR
+StoreColors             STORE-COLORS
+StoreNamedColor         STORE-COLOR
+StoreNamedColor         STORE-COLORS
+QueryTextExtents        TEXT-EXTENTS
+QueryTextExtents        TEXT-WIDTH
+TranslateCoords         TRANSLATE-COORDINATES
+UngrabButton            UNGRAB-BUTTON
+UngrabKey               UNGRAB-KEY
+UngrabKeyboard          UNGRAB-KEYBOARD
+UngrabPointer           UNGRAB-POINTER
+UngrabServer            UNGRAB-SERVER
+UngrabServer            WITH-SERVER-GRABBED
+UninstallColormap       UNINSTALL-COLORMAP
+UnmapSubwindows         UNMAP-SUBWINDOWS
+UnmapWindow             UNMAP-WINDOW
+WarpPointer             WARP-POINTER
+WarpPointer             WARP-POINTER-IF-INSIDE
+WarpPointer             WARP-POINTER-RELATIVE
+WarpPointer             WARP-POINTER-RELATIVE-IF-INSIDE
+GetWindowAttributes     WINDOW-ALL-EVENT-MASKS
+GetWindowAttributes     WINDOW-BACKING-PIXEL
+GetWindowAttributes     WINDOW-BACKING-PLANES
+GetWindowAttributes     WINDOW-BACKING-STORE
+GetWindowAttributes     WINDOW-BIT-GRAVITY
+GetWindowAttributes     WINDOW-CLASS
+GetWindowAttributes     WINDOW-COLORMAP
+GetWindowAttributes     WINDOW-COLORMAP-INSTALLED-P
+GetWindowAttributes     WINDOW-DO-NOT-PROPAGATE-MASK
+GetWindowAttributes     WINDOW-EVENT-MASK
+GetWindowAttributes     WINDOW-GRAVITY
+GetWindowAttributes     WINDOW-MAP-STATE
+GetWindowAttributes     WINDOW-OVERRIDE-REDIRECT
+GetWindowAttributes     WINDOW-SAVE-UNDER
+GetWindowAttributes     WINDOW-VISUAL-INFO
+
+ConfigureWindow         (SETF (DRAWABLE-BORDER-WIDTH DRAWABLE) INTEGER)
+ConfigureWindow         (SETF (DRAWABLE-DEPTH DRAWABLE) INTEGER)
+ConfigureWindow         (SETF (DRAWABLE-HEIGHT DRAWABLE) INTEGER)
+ConfigureWindow         (SETF (DRAWABLE-WIDTH DRAWABLE) INTEGER)
+ConfigureWindow         (SETF (DRAWABLE-X DRAWABLE) INTEGER)
+ConfigureWindow         (SETF (DRAWABLE-Y DRAWABLE) INTEGER)
+SetFontPath             (SETF (FONT-PATH FONT) PATHS)
+ChangeGC                (SETF (GCONTEXT-ARC-MODE GC) (MEMBER CHORD PIE-SLICE))
+ChangeGC                (SETF (GCONTEXT-BACKGROUND GC) CARD32)
+ChangeGC                (SETF (GCONTEXT-CAP-STYLE GC) KEYWORD)
+SetClipRectangles       (SETF (GCONTEXT-CLIP-MASK GC &OPTIONAL ORDERING)
+	                      (OR (MEMBER NONE) PIXMAP RECT-SEQ))
+SetClipRectangles       (SETF (GCONTEXT-CLIP-ORDERING GC) KEYWORD)
+SetClipRectangles       (SETF (GCONTEXT-CLIP-X GC) INT16)
+SetClipRectangles       (SETF (GCONTEXT-CLIP-Y GC) INT16)
+SetDashes               (SETF (GCONTEXT-DASH-OFFSET GC) CARD16)
+SetDashes               (SETF (GCONTEXT-DASHES GC) (OR CARD8 SEQUENCE))
+ChangeGC                (SETF (GCONTEXT-EXPOSURES GC) (MEMBER ON OFF))
+ChangeGC                (SETF (GCONTEXT-FILL-RULE GC) KEYWORD)
+ChangeGC                (SETF (GCONTEXT-FILL-STYLE GC) KEYWORD)
+ChangeGC                (SETF (GCONTEXT-FONT GC &OPTIONAL METRICS-P) FONT)
+ChangeGC                (SETF (GCONTEXT-FOREGROUND GC) CARD32)
+ChangeGC                (SETF (GCONTEXT-FUNCTION GC) BOOLE-CONSTANT)
+ChangeGC                (SETF (GCONTEXT-JOIN-STYLE GC) KEYWORD)
+ChangeGC                (SETF (GCONTEXT-LINE-STYLE GC) KEYWORD)
+ChangeGC                (SETF (GCONTEXT-LINE-WIDTH GC) CARD16)
+ChangeGC                (SETF (GCONTEXT-PLANE-MASK GC) CARD32)
+ChangeGC                (SETF (GCONTEXT-STIPPLE GC) PIXMAP)
+ChangeGC                (SETF (GCONTEXT-SUBWINDOW-MODE GC) KEYWORD)
+ChangeGC                (SETF (GCONTEXT-TILE GC) PIXMAP)
+ChangeGC                (SETF (GCONTEXT-TS-X GC) INT16)
+ChangeGC                (SETF (GCONTEXT-TS-Y GC) INT16)
+ChangeWindowAttributes  (SETF (WINDOW-BACKGROUND WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-BACKING-PIXEL WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-BACKING-PLANES WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-BACKING-STORE WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-BIT-GRAVITY WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-BORDER WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-COLORMAP WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-CURSOR WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-DO-NOT-PROPAGATE-MASK WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-EVENT-MASK WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-GRAVITY WINDOW) VALUE)
+ChangeWindowAttributes  (SETF (WINDOW-OVERRIDE-REDIRECT WINDOW) VALUE)
+ConfigureWindow         (SETF (WINDOW-PRIORITY WINDOW &OPTIONAL SIBLING) INTEGER)
+ChangeWindowAttributes  (SETF (WINDOW-SAVE-UNDER WINDOW) VALUE)
+
+
+
+;; Here's a list of the CLX functions that don't directly correspond to 
+;; X Window System requests.  The've been categorized by function:
+
+					   ;Display Management
+CLOSE-DISPLAY
+CLOSE-DOWN-MODE
+DISPLAY-AFTER-FUNCTION ;; SETF'able
+DISPLAY-FINISH-OUTPUT
+DISPLAY-FORCE-OUTPUT
+DISPLAY-INVOKE-AFTER-FUNCTION
+OPEN-DISPLAY
+WITH-DISPLAY
+WITH-EVENT-QUEUE
+					   ;Extensions
+DECLARE-EVENT
+DECODE-CORE-ERROR
+DEFAULT-ERROR-HANDLER
+DEFINE-CONDITION
+DEFINE-ERROR
+DEFINE-EXTENSION
+DEFINE-GCONTEXT-ACCESSOR
+EXTENSION-OPCODE
+					   ;Events
+EVENT-CASE
+EVENT-LISTEN
+MAPPING-NOTIFY
+PROCESS-EVENT
+EVENT-HANDLER
+MAKE-EVENT-HANDLERS
+QUEUE-EVENT
+					   ;Image
+COPY-IMAGE
+CREATE-IMAGE
+GET-IMAGE
+IMAGE-BLUE-MASK
+IMAGE-DEPTH
+IMAGE-GREEN-MASK
+IMAGE-HEIGHT
+IMAGE-NAME
+IMAGE-PIXMAP
+IMAGE-PLIST
+IMAGE-RED-MASK
+IMAGE-WIDTH
+IMAGE-X-HOT
+IMAGE-Y-HOT
+PUT-IMAGE
+READ-BITMAP-FILE
+WRITE-BITMAP-FILE
+					   ;Keysyms
+CHARACTER->KEYSYMS
+CHARACTER-IN-MAP-P
+DEFAULT-KEYSYM-INDEX
+DEFAULT-KEYSYM-TRANSLATE
+DEFINE-KEYSYM
+DEFINE-KEYSYM-SET
+KEYCODE->CHARACTER
+KEYCODE->KEYSYM
+KEYSYM
+KEYSYM->CHARACTER
+KEYSYM-IN-MAP-P
+KEYSYM-SET
+UNDEFINE-KEYSYM
+					   ;Properties
+CUT-BUFFER
+GET-STANDARD-COLORMAP
+GET-WM-CLASS
+ICON-SIZES
+MAKE-WM-HINTS
+MAKE-WM-SIZE-HINTS
+ROTATE-CUT-BUFFERS
+SET-STANDARD-COLORMAP
+SET-WM-CLASS
+TRANSIENT-FOR
+WM-CLIENT-MACHINE
+WM-COMMAND
+WM-HINTS
+WM-HINTS-FLAGS
+WM-HINTS-ICON-MASK
+WM-HINTS-ICON-PIXMAP
+WM-HINTS-ICON-WINDOW
+WM-HINTS-ICON-X
+WM-HINTS-ICON-Y
+WM-HINTS-INITIAL-STATE
+WM-HINTS-INPUT
+WM-HINTS-P
+WM-HINTS-WINDOW-GROUP
+WM-ICON-NAME
+WM-NAME
+WM-NORMAL-HINTS
+WM-SIZE-HINTS-HEIGHT
+WM-SIZE-HINTS-HEIGHT-INC
+WM-SIZE-HINTS-MAX-ASPECT
+WM-SIZE-HINTS-MAX-HEIGHT
+WM-SIZE-HINTS-MAX-WIDTH
+WM-SIZE-HINTS-MIN-ASPECT
+WM-SIZE-HINTS-MIN-HEIGHT
+WM-SIZE-HINTS-MIN-WIDTH
+WM-SIZE-HINTS-P
+WM-SIZE-HINTS-USER-SPECIFIED-POSITION-P
+WM-SIZE-HINTS-USER-SPECIFIED-SIZE-P
+WM-SIZE-HINTS-WIDTH
+WM-SIZE-HINTS-WIDTH-INC
+WM-SIZE-HINTS-X
+WM-SIZE-HINTS-Y
+WM-ZOOM-HINTS
+					   ;Misc.
+MAKE-COLOR
+MAKE-EVENT-KEYS
+MAKE-EVENT-MASK
+MAKE-RESOURCE-DATABASE
+MAKE-STATE-KEYS
+MAKE-STATE-MASK
+DISCARD-FONT-INFO
+TRANSLATE-DEFAULT
+					   ;Structures
+BITMAP-FORMAT-LSB-FIRST-P
+BITMAP-FORMAT-P
+BITMAP-FORMAT-PAD
+BITMAP-FORMAT-UNIT
+BITMAP-IMAGE
+
+COLOR-BLUE
+COLOR-GREEN
+COLOR-P
+COLOR-RED
+COLOR-RGB
+COLORMAP-DISPLAY
+COLORMAP-EQUAL
+COLORMAP-ID
+COLORMAP-P
+COLORMAP-VISUAL-INFO
+
+CURSOR-DISPLAY
+CURSOR-EQUAL
+CURSOR-ID
+CURSOR-P
+
+DRAWABLE-DISPLAY
+DRAWABLE-EQUAL
+DRAWABLE-ID
+DRAWABLE-P
+
+FONT-DISPLAY
+FONT-EQUAL
+FONT-ID
+FONT-MAX-BOUNDS
+FONT-MIN-BOUNDS
+FONT-P
+FONT-PLIST
+
+GCONTEXT-DISPLAY
+GCONTEXT-EQUAL
+GCONTEXT-ID
+GCONTEXT-P
+GCONTEXT-PLIST
+
+DISPLAY-AUTHORIZATION-DATA
+DISPLAY-AUTHORIZATION-NAME
+DISPLAY-BITMAP-FORMAT
+DISPLAY-BYTE-ORDER
+DISPLAY-DEFAULT-SCREEN
+DISPLAY-DISPLAY
+DISPLAY-ERROR-HANDLER
+DISPLAY-IMAGE-LSB-FIRST-P
+DISPLAY-KEYCODE-RANGE
+DISPLAY-MAX-KEYCODE
+DISPLAY-MAX-REQUEST-LENGTH
+DISPLAY-MIN-KEYCODE
+DISPLAY-MOTION-BUFFER-SIZE
+DISPLAY-NSCREENS
+DISPLAY-P
+DISPLAY-PIXMAP-FORMATS
+DISPLAY-PLIST
+DISPLAY-PROTOCOL-MAJOR-VERSION
+DISPLAY-PROTOCOL-MINOR-VERSION
+DISPLAY-PROTOCOL-VERSION
+DISPLAY-RELEASE-NUMBER
+DISPLAY-RESOURCE-ID-BASE
+DISPLAY-RESOURCE-ID-MASK
+DISPLAY-ROOTS
+DISPLAY-SQUISH
+DISPLAY-VENDOR
+DISPLAY-VENDOR-NAME
+DISPLAY-VERSION-NUMBER
+DISPLAY-XDEFAULTS
+DISPLAY-XID
+
+PIXMAP-DISPLAY
+PIXMAP-EQUAL
+PIXMAP-FORMAT-BITS-PER-PIXEL
+PIXMAP-FORMAT-DEPTH
+PIXMAP-FORMAT-P
+PIXMAP-FORMAT-SCANLINE-PAD
+PIXMAP-ID
+PIXMAP-P
+PIXMAP-PLIST
+
+SCREEN-BACKING-STORES
+SCREEN-BLACK-PIXEL
+SCREEN-DEFAULT-COLORMAP
+SCREEN-DEPTHS
+SCREEN-EVENT-MASK-AT-OPEN
+SCREEN-HEIGHT
+SCREEN-HEIGHT-IN-MILLIMETERS
+SCREEN-MAX-INSTALLED-MAPS
+SCREEN-MIN-INSTALLED-MAPS
+SCREEN-P
+SCREEN-PLIST
+SCREEN-ROOT
+SCREEN-ROOT-DEPTH
+SCREEN-ROOT-VISUAL-INFO
+SCREEN-SAVE-UNDERS-P
+SCREEN-WHITE-PIXEL
+SCREEN-WIDTH
+SCREEN-WIDTH-IN-MILLIMETERS
+
+VISUAL-INFO
+VISUAL-INFO-BITS-PER-RGB
+VISUAL-INFO-BLUE-MASK
+VISUAL-INFO-CLASS
+VISUAL-INFO-COLORMAP-ENTRIES
+VISUAL-INFO-GREEN-MASK
+VISUAL-INFO-ID
+VISUAL-INFO-P
+VISUAL-INFO-PLIST
+VISUAL-INFO-RED-MASK
+
+WINDOW-DISPLAY
+WINDOW-EQUAL
+WINDOW-ID
+WINDOW-P
+WINDOW-PLIST
diff --git a/clx/exclMakefile b/clx/exclMakefile
new file mode 100644
index 000000000..567023432
--- /dev/null
+++ b/clx/exclMakefile
@@ -0,0 +1,133 @@
+# 
+#  Makefile for CLX
+#  (X11 R4 release, Franz Allegro Common Lisp version)
+#
+
+# *************************************************************************
+# * Change the next line to point to where you have Common Lisp installed *
+# *        (make sure the Lisp doesn't already have CLX loaded in)        *
+# *************************************************************************
+CL	= /usr/local/bin/cl
+
+RM	= /bin/rm
+SHELL	= /bin/sh
+ECHO	= /bin/echo
+TAGS	= /usr/local/lib/emacs/etc/etags
+
+# Name of dumped lisp
+CLX	= CLX
+
+CLOPTS	= -qq
+
+# Use this one for Suns
+CFLAGS	= -O -DUNIXCONN
+# Use this one for Silicon Graphics & Mips Inc MIPS based machines
+# CFLAGS = -O -G 0 -I/usr/include/bsd
+# Use this one for DEC MIPS based machines
+# CFLAGS = -O -G 0 -DUNIXCONN
+# Use this one for HP machines
+# CFLAGS = -O -DSYSV -DUNIXCONN
+
+
+# Lisp optimization for compiling
+SPEED	= 3
+SAFETY	= 0
+
+
+C_SRC	= excldep.c socket.c
+C_OBJS	= excldep.o socket.o
+
+L_OBJS	= excldep.fasl defsystem.fasl depdefs.fasl clx.fasl dependent.fasl \
+	  exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl display.fasl \
+	  gcontext.fasl requests.fasl input.fasl fonts.fasl graphics.fasl \
+	  text.fasl attributes.fasl translate.fasl keysyms.fasl manager.fasl \
+	  image.fasl resource.fasl
+
+L_NOMACROS_OBJS	= excldep.fasl depdefs.fasl clx.fasl dependent.fasl \
+	buffer.fasl display.fasl gcontext.fasl \
+	requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \
+	attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \
+	resource.fasl
+
+L_SRC	= defsystem.cl depdefs.cl clx.cl dependent.cl exclcmac.cl \
+	  macros.cl bufmac.cl buffer.cl display.cl gcontext.cl \
+	  requests.cl input.cl fonts.cl graphics.cl text.cl \
+	  attributes.cl translate.cl keysyms.cl manager.cl image.cl \
+	  resource.cl
+
+
+all:	$(C_OBJS) compile-CLX cat
+
+clos:	$(C_OBJS) compile-closified-CLX cat
+
+CLX:	$(C_OBJS) compile-CLX load-CLX
+
+
+c:	$(C_OBJS)
+
+
+lisp:	compile-CLX
+
+
+compile-CLX:	$(C_OBJS)
+	$(ECHO) " \
+		(set-case-mode :case-sensitive-lower) \
+		(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
+		(compile-file-if-needed \"excldep\") \
+		(compile-file-if-needed \"defsystem\") \
+		(load \"defsystem\") \
+		#+allegro (compile-system :clx) \
+		#-allegro (xlib::compile-clx) \
+		#+allegro (compile-system :clx-debug)" \
+		| $(CL) $(CLOPTS) -batch
+
+
+compile-closified-CLX:	$(C_OBJS)
+	$(ECHO) " \
+		(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
+		(setq excl::*print-nickname* t) \
+		(unless (or (find-package 'clos) (find-package 'pcl)) \
+		  (let ((spread (sys:gsgc-parameter :generation-spread))) \
+		    (setf (sys:gsgc-parameter :generation-spread) 1) \
+		    (require :pcl) \
+		    (provide :pcl) \
+		    (gc) (gc) \
+		    (setf (sys:gsgc-parameter :generation-spread) spread))) \
+		(compile-file-if-needed \"excldep\") \
+		(compile-file-if-needed \"defsystem\") \
+		(load \"defsystem\") \
+		#+allegro (compile-system :clx) \
+		#-allegro (xlib::compile-clx) \
+		#+allegro (compile-system :clx-debug)" \
+		| $(CL) $(CLOPTS) -batch
+
+
+cat:
+	-cat $(L_NOMACROS_OBJS) > CLX.fasl
+
+
+load-CLX:
+	$(ECHO)  '(load "defsystem")' \
+		 "(let (#+allegro (spread (sys:gsgc-parameter :generation-spread)))" \
+		 "  #+allegro (setf (sys:gsgc-parameter :generation-spread) 1)" \
+		 "  #+allegro (load-system :clx)" \
+		 "  #-allegro (xlib::load-clx)" \
+		 "  #+allegro (gc :tenure)" \
+		 "  #+allegro (setf (sys:gsgc-parameter :generation-spread) spread)" \
+		 ")" \
+		 '#+allegro (gc t)' \
+		 '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \
+		 '(exit)' | $(CL) $(CLOPTS)
+
+
+clean:
+	$(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS)
+
+
+install:
+	mv CLX.fasl $(DEST)/clx.fasl
+	mv *.o $(DEST)
+
+
+tags:
+	$(TAGS) $(L_SRC) $(C_SRC)
diff --git a/clx/exclREADME b/clx/exclREADME
new file mode 100644
index 000000000..02ed020a8
--- /dev/null
+++ b/clx/exclREADME
@@ -0,0 +1,59 @@
+     This file contains instructions on how to make CLX work with Franz
+Common Lisp.  CLX should work on any machine that supports Allegro Common
+Lisp version 3.0.1 or greater.  It also works under ExCL version 2.0.10.
+However it has been tested extensively with only Allegro CL versions 3.0
+and 3.1.
+
+     There are three steps to compile and install CLX.  The first is simply
+moving files around.  In this directory, execute (assuming you using csh):
+
+% foreach i (*.l */*.l)
+? mv $i $i:r.cl
+? end
+% mkdir MIT
+% mv defsystem.cl MIT
+% mv excldefsys.cl defsystem.cl
+% mv exclMakefile Makefile
+
+     The second is compiling the source files into fasl files.  The fasl files
+will be combined into one big fasl file, CLX.fasl.  This file is then installed
+in your Common Lisp library directory in the next step.  You may need to edit
+the Makefile to select the proper CFLAGS for your machine -- look in Makefile
+for examples.  Then just:
+
+% make
+
+     Now you must move the CLX.fasl file into the standard CL library.
+This is normally "/usr/local/lib/cl/code", but you can find out for sure
+by typing:
+
+<cl> (directory-namestring excl::*library-code-pathname*)
+
+to a running Lisp.  If it prints something other than "/usr/local/lib/cl/code"
+substitute what it prints in the below instructions.
+
+% mv CLX.fasl /usr/local/lib/cl/code/clx.fasl
+% mv *.o /usr/local/lib/cl/code
+
+Now you can just start up Lisp and type:
+
+<cl> (load "clx")
+
+to load in CLX.  You may want to dump a lisp at this point since CLX is a large
+package and can take some time to load into Lisp.  You probably also want to
+set the :generation-spread to 1 while loading CLX.  Please see your Allegro CL
+User Guide for more information on :generation-spread.
+
+
+     Sophisticated users may wish to peruse the Makefile and defsystem.cl
+and note how things are set up.  For example we hardwire the compiler
+interrupt check switch on, so that CL can still be interrupted while it
+is reading from the X11 socket.  Please see chapter 7 of the CL User's
+guide for more information on compiler switches and their effects.
+
+
+Please report Franz specific CLX bugs to:
+
+	ucbvax!franz!bugs
+	       or
+	 bugs@Franz.COM
diff --git a/clx/exclcmac.lisp b/clx/exclcmac.lisp
new file mode 100644
index 000000000..9759e4d00
--- /dev/null
+++ b/clx/exclcmac.lisp
@@ -0,0 +1,313 @@
+;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
+;;;
+;;; CLX -- exclcmac.cl
+;;;           This file provides for inline expansion of some functions.
+;;;
+;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.
+;;;
+;;; Franz Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib :use '(:foreign-functions :lisp :excl))
+
+(import '(excl::defcmacro))
+
+;;
+;; Type predicates
+;;
+(defcmacro card8p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
+
+(defcmacro card16p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
+
+(defcmacro int8p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
+
+(defcmacro int16p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
+
+;; Card29p, card32p, int32p are too large to expand inline
+
+
+;;
+;; Type transformers
+;;
+(defcmacro card8->int8 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card8 ,xx))
+       (the int8 (if (logbitp 7 ,xx)
+		     (the int8 (- ,xx #x100))
+		   ,xx)))))
+(defcmacro int8->card8 (x)
+  `(locally ,(declare-bufmac)
+     (the card8 (ldb (byte 8 0) (the int8 ,x)))))
+
+(defcmacro card16->int16 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card16 ,xx))
+       (the int16 (if (logbitp 15 ,xx)
+		      (the int16 (- ,xx #x10000))
+		    ,xx)))))
+
+(defcmacro int16->card16 (x)
+  `(locally ,(declare-bufmac)
+     (the card16 (ldb (byte 16 0) (the int16 ,x)))))
+
+(defcmacro card32->int32 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card32 ,xx))
+       (the int32 (if (logbitp 31 ,xx)
+		      (the int32 (- ,xx #x100000000))
+		    ,xx)))))
+
+(defcmacro int32->card32 (x)
+  `(locally ,(declare-bufmac)
+     (the card32 (ldb (byte 32 0) (the int32 ,x)))))
+
+(defcmacro char->card8 (char)
+  `(locally ,(declare-bufmac)
+     (the card8 (char-code (the string-char ,char)))))
+
+(defcmacro card8->char (card8)
+  `(locally ,(declare-bufmac)
+     (the string-char (code-char (the card8 ,card8)))))
+
+
+;;
+;; Array accessors and setters
+;;
+(defcmacro aref-card8 (a i)
+  `(locally ,(declare-bufmac)
+	    (the card8 (aref (the buffer-bytes ,a) (the array-index ,i)))))
+
+(defcmacro aset-card8 (v a i)
+  `(locally ,(declare-bufmac)
+	    (setf (aref (the buffer-bytes ,a) (the array-index ,i))
+	      (the card8 ,v))))
+
+(defcmacro aref-int8 (a i)
+  `(locally ,(declare-bufmac)
+	    (card8->int8 (aref (the buffer-bytes ,a) (the array-index ,i)))))
+
+(defcmacro aset-int8 (v a i)
+  `(locally ,(declare-bufmac)
+	    (setf (aref (the buffer-bytes ,a) (the array-index ,i))
+	      (int8->card8 ,v))))
+
+(defcmacro aref-card16 (a i)
+  `(locally ,(declare-bufmac)
+     (the card16 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-word))))
+  
+(defcmacro aset-card16 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-word)
+       (the card16 ,v))))
+  
+(defcmacro aref-int16 (a i)
+  `(locally ,(declare-bufmac)
+     (the int16 (sys:memref (the buffer-bytes ,a)
+			    #.(comp::mdparam 'comp::md-svector-data0-adj)
+			    (the array-index ,i)
+			    :signed-word))))
+  
+(defcmacro aset-int16 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :signed-word)
+       (the int16 ,v))))
+  
+(defcmacro aref-card32 (a i)
+  `(locally ,(declare-bufmac)
+     (the card32 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-long))))
+    
+(defcmacro aset-card32 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-long)
+       (the card32 ,v))))
+
+(defcmacro aref-int32 (a i)
+  `(locally ,(declare-bufmac)
+     (the int32 (sys:memref (the buffer-bytes ,a)
+			    #.(comp::mdparam 'comp::md-svector-data0-adj)
+			    (the array-index ,i)
+			    :signed-long))))
+    
+(defcmacro aset-int32 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :signed-long)
+       (the int32 ,v))))
+
+(defcmacro aref-card29 (a i)
+  ;; Don't need to mask bits here since X protocol guarantees top bits zero
+  `(locally ,(declare-bufmac)
+     (the card29 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-long))))
+
+(defcmacro aset-card29 (v a i)
+  ;; I also assume here Lisp is passing a number that fits in 29 bits.
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-long)
+       (the card29 ,v))))
+
+;;
+;; Font accessors
+;;
+(defcmacro font-id (font)
+  ;; Get font-id, opening font if needed
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-id-internal ,f)
+	   (open-font-internal ,f)))))
+
+(defcmacro font-font-info (font)
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-font-info-internal ,f)
+	   (query-font ,f)))))
+
+(defcmacro font-char-infos (font)
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-char-infos-internal ,f)
+	   (progn (query-font ,f)
+		  (font-char-infos-internal ,f))))))
+
+
+;;
+;; Miscellaneous
+;;
+(defcmacro current-process ()
+  `(the (or mp::process null) (and mp::*scheduler-stack-group*
+				  mp::*current-process*)))
+
+(defcmacro process-wakeup (process)
+  (let ((proc (gensym)))
+    `(let ((.pw-curproc. mp::*current-process*)
+	   (,proc ,process))
+       (when (and .pw-curproc. ,proc)
+	 (if (> (mp::process-priority ,proc)
+		(mp::process-priority .pw-curproc.))
+	     (mp::process-allow-schedule ,proc))))))
+
+#+notyet
+(defcmacro buffer-replace (target-sequence source-sequence target-start
+					   target-end &optional (source-start 0))
+  (let ((tv (gensym)) (sv (gensym)) (ts (gensym)) (te (gensym)) (ss (gensym)))
+    `(let ((,tv ,target-sequence) (,sv ,source-sequence)
+	   (,ts ,target-start) (,te ,target-end) (,ss ,source-start))
+       (declare (type buffer-bytes ,tv ,sv)
+		(type array-index ,ts ,te ,ss)
+		(optimize (speed 3) (safety 0)))
+  
+       (let ((source-end (length ,sv)))
+	 (declare (type array-index source-end))
+    
+	 (if* (and (eq ,tv ,sv)
+		   (> ,ts ,ss))
+	    then (let ((nelts (min (- ,te ,ts)
+				   (- source-end ,ss))))
+		   (do ((target-index (+ ,ts nelts -1) (1- target-index))
+			(source-index (+ ,ss nelts -1) (1- source-index)))
+		       ((= target-index (1- ,ts)) ,tv)
+		     (declare (type array-index target-index source-index))
+		
+		     (setf (aref ,tv target-index)
+		       (aref ,sv source-index))))
+	    else (do ((target-index ,ts (1+ target-index))
+		      (source-index ,ss (1+ source-index)))
+		     ((or (= target-index ,te) (= source-index source-end))
+		      ,tv)
+		   (declare (type array-index target-index source-index))
+
+		   (setf (aref ,tv target-index)
+		     (aref ,sv source-index))))))))
+
+(defcmacro buffer-new-request-number (buffer)
+  (let ((buf (gensym)))
+    `(let ((,buf ,buffer))
+       (declare (type buffer ,buf))
+       (setf (buffer-request-number ,buf)
+	 (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
+
+(defcmacro byte-reverse (byte)
+  `(aref ,'#.(coerce
+	     '#(0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
+		8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
+		4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
+		12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
+		2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
+		10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
+		6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
+		14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
+		1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
+		9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
+		5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
+		13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
+		3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
+		11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
+		7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
+		15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
+	     '(vector card8))
+	 ,byte))
+
+#|
+#+(or allegro-v3.0 allegro-v3.1)
+(defcmacro graphic-char-p (char)
+  `(let* ((cint (char-int ,char)))
+     (if (and (<= #.(char-code #\space) cint)
+	      (<= cint #.(char-code #\~)))
+	 t
+       nil)))
+|#
+
diff --git a/clx/excldefsys.lisp b/clx/excldefsys.lisp
new file mode 100644
index 000000000..abbc5dc71
--- /dev/null
+++ b/clx/excldefsys.lisp
@@ -0,0 +1,186 @@
+;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
+;;;
+;;; Copyright (c) 1988, 1989 Franz Inc, Berkeley, Ca.
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.
+;;;
+;;; Franz Incorporated provides this software "as is" without express or
+;;; implied warranty.
+;;;
+
+(in-package :xlib :use '(:foreign-functions :lisp :excl))
+
+#+allegro
+(require :defsystem "defsys")
+
+(eval-when (load)
+  (require :clxexcldep "excldep"))
+
+;;
+;; The following is a suggestion.  If you comment out this form be
+;; prepared for possible deadlock, since no interrupts will be recognized
+;; while reading from the X socket if the scheduler is not running.
+;;
+(setq compiler::generate-interrupt-checks-switch
+  (compile nil '(lambda (safety size speed)
+		   (declare (ignore size))
+		  (or (< speed 3) (> safety 0)))))
+
+
+#+allegro
+(excl:defsystem :clx
+    ()
+  |depdefs|
+  (|clx| :load-before-compile (|depdefs|)
+	 :recompile-on (|depdefs|))
+  (|dependent| :load-before-compile (|depdefs| |clx|)
+	       :recompile-on (|clx|))
+  (|exclcmac| :load-before-compile (|depdefs| |clx| |dependent|)
+	      :recompile-on (|dependent|))
+  (|macros| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|)
+	    :recompile-on (|exclcmac|))
+  (|bufmac| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					    |macros|)
+	    :recompile-on (|macros|))
+  (|buffer| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					    |macros| |bufmac|)
+	    :recompile-on (|bufmac|))
+  (|display| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					     |macros| |bufmac| |buffer|)
+	     :recompile-on (|buffer|))
+  (|gcontext| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					      |macros| |bufmac| |buffer|
+					      |display|)
+	      :recompile-on (|display|))
+  (|input| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					   |macros| |bufmac| |buffer| |display|
+					   )
+	   :recompile-on (|display|))
+  (|requests| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					      |macros| |bufmac| |buffer|
+					      |display| |input|)
+	      :recompile-on (|display|))
+  (|fonts| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					   |macros| |bufmac| |buffer| |display|
+					   )
+	   :recompile-on (|display|))
+  (|graphics| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					      |macros| |bufmac| |buffer|
+					      |display| |fonts|)
+	      :recompile-on (|fonts|))
+  (|text| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac| |macros|
+					  |bufmac| |buffer| |display|
+					  |gcontext| |fonts|)
+	  :recompile-on (|gcontext| |fonts|)
+	  :load-after (|translate|))
+  ;; The above line gets around a compiler macro expansion bug.
+  
+  (|attributes| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+						|macros| |bufmac| |buffer|
+						|display|)
+		:recompile-on (|display|))
+  (|translate| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					       |macros| |bufmac| |buffer|
+					       |display| |text|)
+	       :recompile-on (|display|))
+  (|keysyms| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					     |macros| |bufmac| |buffer|
+					     |display| |translate|)
+	     :recompile-on (|translate|))
+  (|manager| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					     |macros| |bufmac| |buffer|
+					     |display|)
+	     :recompile-on (|display|))
+  (|image| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					   |macros| |bufmac| |buffer| |display|
+					   )
+	   :recompile-on (|display|))
+  
+  ;; Don't know if l-b-c list is correct.  XX
+  (|resource| :load-before-compile (|depdefs| |clx| |dependent| |exclcmac|
+					      |macros| |bufmac| |buffer|
+					      |display|)
+	      :recompile-on (|display|))
+  )
+
+#+allegro
+(excl:defsystem :clx-debug
+    (:default-pathname "debug/"
+     :needed-systems (:clx)
+     :load-before-compile (:clx))
+  |describe| |keytrans| |trace| |util|)
+
+
+(defun compile-clx (&optional pathname-defaults)
+  (let ((*default-pathname-defaults*
+	  (or pathname-defaults *default-pathname-defaults*)))
+    (declare (special *default-pathname-defaults*))
+    (compile-file "depdefs")
+    (load "depdefs")
+    (compile-file "clx")
+    (load "clx")
+    (compile-file "dependent")
+    (load "dependent")
+    (compile-file "macros")
+    (load "macros")
+    (compile-file "bufmac")
+    (load "bufmac")
+    (compile-file "buffer")
+    (load "buffer")
+    (compile-file "display")
+    (load "display")
+    (compile-file "gcontext")
+    (load "gcontext")
+    (compile-file "input")
+    (load "input")
+    (compile-file "requests")
+    (load "requests")
+    (compile-file "fonts")
+    (load "fonts")
+    (compile-file "graphics")
+    (load "graphics")
+    (compile-file "text")
+    (load "text")
+    (compile-file "attributes")
+    (load "attributes")
+    (load "translate")
+    (compile-file "translate")		; work-around bug in 2.0 and 2.2
+    (load "translate")
+    (compile-file "keysyms")
+    (load "keysyms")
+    (compile-file "manager")
+    (load "manager")
+    (compile-file "image")
+    (load "image")
+    (compile-file "resource")
+    (load "resource")
+    ))
+
+
+(defun load-clx (&optional pathname-defaults)
+  (let ((*default-pathname-defaults*
+	  (or pathname-defaults *default-pathname-defaults*)))
+    (declare (special *default-pathname-defaults*))
+    (load "depdefs")
+    (load "clx")
+    (load "dependent")
+    (load "macros")
+    (load "bufmac")
+    (load "buffer")
+    (load "display")
+    (load "gcontext")
+    (load "input")
+    (load "requests")
+    (load "fonts")
+    (load "graphics")
+    (load "text")
+    (load "attributes")
+    (load "translate")
+    (load "keysyms")
+    (load "manager")
+    (load "image")
+    (load "resource")
+    ))
diff --git a/clx/excldep.c b/clx/excldep.c
new file mode 100644
index 000000000..c6fe25c64
--- /dev/null
+++ b/clx/excldep.c
@@ -0,0 +1,73 @@
+/*
+ * Allegro CL dependent C helper routines for CLX
+ */
+
+/*
+ * This code requires select and interval timers.
+ * This means you probably need BSD, or a version
+ * of Unix with select and interval timers added.
+ */
+
+#include <sys/types.h>
+#include <sys/errno.h>
+#include <sys/time.h>
+#include <stdio.h>
+
+#define ERROR -1
+#define INTERRUPT -2
+#define TIMEOUT 0
+#define SUCCESS 1
+
+#ifdef FD_SETSIZE
+#define NUMBER_OF_FDS FD_SETSIZE	/* Highest possible file descriptor */
+#else
+#define NUMBER_OF_FDS 32
+#endif
+
+/* Length of array needed to hold all file descriptor bits */
+#define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int)))
+
+extern int errno;
+
+/*
+ * This function waits for input to become available on 'fd'.  If timeout is
+ * 0, wait forever.  Otherwise wait 'timeout' seconds.  If input becomes
+ * available before the timer expires, return SUCCESS.  If the timer expires
+ * return TIMEOUT.  If an error occurs, return ERROR.  If an interrupt occurs
+ * while waiting, return INTERRUPT.
+ */
+int fd_wait_for_input(fd, timeout)
+    register int fd;
+    register int timeout;
+{
+    struct timeval timer;
+    register int i;
+    int checkfds[CHECKLEN];
+
+    if (fd < 0 || fd >= NUMBER_OF_FDS) {
+	fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd);
+	fflush(stderr);
+    }
+
+    for (i = 0; i < CHECKLEN; i++)
+      checkfds[i] = 0;
+    checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int)));
+
+    if (timeout) {
+	timer.tv_sec = timeout;
+	timer.tv_usec = 0;
+	i = select(32, checkfds, (int *)0, (int *)0, &timer);
+    } else
+      i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0);
+
+    if (i < 0)
+      /* error condition */
+      if (errno == EINTR)
+	return (INTERRUPT);
+      else
+	return (ERROR);
+    else if (i == 0)
+      return (TIMEOUT);
+    else
+      return (SUCCESS);
+}
diff --git a/clx/excldep.lisp b/clx/excldep.lisp
new file mode 100644
index 000000000..62c4574dd
--- /dev/null
+++ b/clx/excldep.lisp
@@ -0,0 +1,514 @@
+;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
+;;;
+;;; CLX -- excldep.cl
+;;;
+;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca.
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.
+;;;
+;;; Franz Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib :use '(:foreign-functions :lisp :excl))
+
+(eval-when (load)
+  (provide :clxexcldep)
+  (provide :clx))
+
+(require :foreign)
+(require :process)			; Needed even if scheduler is not
+					; running.  (Must be able to make
+					; a process-lock.)
+
+(import '(excl::if*
+	  excl::type-error
+	  excl::type-error-datum
+	  excl::type-error-expected-type))
+#+allegro
+(import '(excl::without-interrupts))
+
+#-(or little-endian big-endian)
+(eval-when (eval compile load)
+  (let ((x '#(1)))
+    (if (not (eq 0 (sys::memref x
+				#.(comp::mdparam 'comp::md-svector-data0-adj)
+				0 :unsigned-byte)))
+	(pushnew :little-endian *features*)
+      (pushnew :big-endian *features*))))
+
+
+(defmacro define-condition (name (parent-type) &optional slots &rest args)
+  `(excl::define-condition ,name (,parent-type) ,slots ,@args))
+
+
+(defmacro correct-case (string)
+  ;; This macro converts the given string to the 
+  ;; current preferred case, or leaves it alone in a case-sensitive mode.
+  (let ((str (gensym)))
+    `(let ((,str ,string))
+       (case excl::*current-case-mode*
+	 (:case-insensitive-lower
+	  (string-downcase ,str))
+	 (:case-insensitive-upper
+	  (string-upcase ,str))
+	 ((:case-sensitive-lower :case-sensitive-upper)
+	  ,str)))))
+
+
+(defun underlying-simple-vector (array)
+  (cond ((excl::svectorp array)
+	 array)
+	((arrayp array)
+	 (cdr (excl::ah_data array)))
+	(t
+	 (error "~s is not an array" array))))
+
+
+(defconstant type-pred-alist
+  '(
+    (card8  . card8p)
+    (card16 . card16p)
+    (card29 . card29p)
+    (card32 . card32p)
+    (int8   . int8p)
+    (int16  . int16p)
+    (int32  . int32p)
+    (mask16 . card16p)
+    (mask32 . card32p)
+    (pixel  . card32p)
+    (resource-id . card29p)
+    (keysym . card32p)
+    ))
+
+;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 
+;; sun4 compiler opencode the `and'.
+
+(defun card8p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (fixnump x) (> #.(expt 2 8) x) (>= x 0))
+      t
+    nil))
+
+(defun card16p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (fixnump x) (> #.(expt 2 16) x) (>= x 0))
+      t
+    nil))
+
+(defun card29p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (and (fixnump x) (>= (the fixnum x) 0))
+	  (and (bignump x) (> #.(expt 2 29) (the bignum x))
+	       (>= (the bignum x) 0)))
+      t
+    nil))
+
+(defun card32p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (and (fixnump x) (>= (the fixnum x) 0))
+	  (and (bignump x) (> #.(expt 2 32) (the bignum x))
+	       (>= (the bignum x) 0)))
+      t
+    nil))
+
+(defun int8p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
+      t
+    nil))
+
+(defun int16p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
+      t
+    nil))
+
+(defun int32p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (fixnump x)
+	  (and (bignump x) (> #.(expt 2 31) (the bignum x))
+	       (>= (the bignum x) #.(expt -2 31))))
+      t
+    nil))
+
+(comp::def-tr comp::new-tr-typep typep (form type)
+   (let (ent)
+      (if* (and (consp type)
+		(eq 'quote (car type))
+		(consp (cdr type)))
+	 then (setq ent (franz:assq (cadr type) type-pred-alist)))
+      (if* ent
+	 then `(,(cdr ent) ,form)
+	 else (if* (and (consp type)
+			(eq 'quote (car type))
+			(consp (cdr type)))
+		 then (setq ent (franz:assq (cadr type)
+					    excl::type-pred-alist)))
+	      (if* ent
+		 then `(,(cdr ent) ,form)
+		 else (comp::no-transform)))))
+
+
+;; Return t if there is a character available for reading or on error,
+;; otherwise return nil.
+(defun fd-char-avail-p (fd)
+  (multiple-value-bind (available-p errcode)
+      (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
+    (if* errcode
+       then t
+       else available-p)))
+
+(defmacro with-interrupt-checking-on (&body body)
+  `(locally (declare (optimize (safety 1)))
+     ,@body))
+
+;; Read from the given fd into 'vector', which has element type card8.
+;; Start storing at index 'start-index' and read exactly 'length' bytes.
+;; Return t if an error or eof occurred, nil otherwise.
+(defun fd-read-bytes (fd vector start-index length)
+  (declare (fixnum fd start-index length)
+	   (type (simple-array (unsigned-byte 8) (*)) vector))
+  (with-interrupt-checking-on
+   (do ((rest length))
+       ((eq 0 rest) nil)
+     (declare (fixnum rest))
+     (multiple-value-bind (numread errcode)
+	 (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
+				start-index rest)
+       (declare (fixnum numread))
+       (if* errcode
+	  then (if (not (eq errcode
+			    excl::*error-code-interrupted-system-call*))
+		   (return t))
+	elseif (eq 0 numread)
+	  then (return t)
+	  else (decf rest numread)
+	       (incf start-index numread))))))
+
+
+(when (plusp (ff:get-entry-points
+	      (make-array 1 :initial-contents
+			  (list (ff:convert-to-lang "fd_wait_for_input")))
+	      (make-array 1 :element-type '(unsigned-byte 32))))
+  (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
+  (load "excldep.o"))
+
+(when (plusp (ff:get-entry-points
+	      (make-array 1 :initial-contents
+			  (list (ff:convert-to-lang "connect_to_server")))
+	      (make-array 1 :element-type '(unsigned-byte 32))))
+  (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
+  (load "socket.o"))
+
+(ff:defforeign-list `((connect-to-server
+		       :entry-point
+		       ,(ff:convert-to-lang "connect_to_server")
+		       :return-type :fixnum
+		       :arg-checking nil
+		       :arguments (string fixnum))
+		      (fd-wait-for-input
+		       :entry-point ,(ff:convert-to-lang "fd_wait_for_input")
+		       :return-type :fixnum
+		       :arg-checking nil
+		       :call-direct t
+		       :callback nil
+		       :allow-other-keys t
+		       :arguments (fixnum fixnum))))
+
+
+#-allegro
+(defmacro without-interrupts (&body body)
+  `(let ((excl::*without-interrupts* t)) ,@body))
+
+
+(in-package :excl)
+
+#-allegro
+(defun type-array-element-type-to-array (type &aux temp) 
+   ;; type is a type descriptor, return a descriptor which tells
+   ;; the array code what kind of array to make
+
+   ; convert the given element type to one of the symbols which
+   ; is in the car of the array-descriptors list
+   ;(msg "beginning type is " type 'N)
+   (if* (symbolp type)
+      then (if* (franz:memq type '(t bit string-char fixnum))
+	      thenret	; it is ok as it is
+	      else (let ((temp (get type 'deftype-expander)))
+		     (if* temp
+			then
+			     (return-from type-array-element-type-to-array
+			       (type-array-element-type-to-array
+				(funcall temp (list type))))
+			else
+			     (setq type (case type
+					  (standard-char 'string-char)
+					  ((single-float short-float) 'single-float)
+					  ((double-float long-float) 'double-float)
+					  (t t))))))
+    elseif (consp type)
+      then (setq type
+		 (case (car type)
+		    (mod (if* (integerp (setq temp (cadr type)))
+			    then (cond ((< temp 1) t)
+				       ((<= temp 2) 'bit)
+				       ((<= temp 256) 'ubyte)
+				       ((<= temp 65536) 'uword)
+				       ((<= temp 4294967296) 'ulong)
+				       (t t))
+			    else t))
+		    (signed-byte
+		       (if* (integerp (setq temp (cadr type)))
+			  then (cond ((<= temp 0) t)
+				     ((<= temp 8) 'byte)
+				     ((<= temp 16) 'word)
+				     ((<= temp 29) 'fixnum)
+				     ((<= temp 32) 'long)
+				     (t  t))
+			  else t))
+		    (unsigned-byte
+		       (if* (integerp (setq temp (cadr type)))
+			  then (cond ((<= temp 0) t)
+				     ((<= temp 8) 'ubyte)
+				     ((<= temp 16) 'uword)
+				     ((<= temp 32) 'ulong)
+				     (t  t))
+			  else t))
+		    (t t)))
+      else (setq type t))
+   ; type is now one of the valid types.  We return a descriptor
+   ; based on that name
+   ;(msg "resulting type is " type 'N)
+   (let ((res (franz:assq type array-descriptors)))
+      ;(msg " resulting decriptor " res 'N)
+      res))
+
+#-allegro
+(defun make-sequence (type length &rest rest &key initial-element)
+  "Returns a sequence of the given Type and Length, with elements initialized
+  to :Initial-Element."
+  (declare (fixnum length)
+	   (ignore initial-element))
+  (case (type-specifier type)
+    (list (apply #'make-list length rest))
+    ((simple-string string)
+     (apply #'make-string length rest))
+    ((array simple-array vector simple-vector)
+     (if* (listp type)
+	 then (apply #'make-array length :element-type (cadr type) rest)
+	 else (apply #'make-array length rest)))
+    ((bit-vector simple-bit-vector)
+     (apply #'make-array length :element-type 'bit rest))
+    (t
+     ;; Now, we can either have a user-defined type symbol, or an error.
+     (if* (symbolp type)
+	then (let ((temp (get type 'excl::deftype-expander)))
+	       (if* temp
+		  then (cond (rest (return-from make-sequence
+				     (make-sequence (funcall temp (list type)) length
+						   :initial-element (cadr rest))))
+			      (t (return-from make-sequence (make-sequence
+				   (funcall temp (list type)) length)))))))
+     (error "~s is a bad type specifier for sequences." type ))))
+
+;; special patch for CLX (various process fixes)
+;; patch1000.2
+
+(in-package 'patch :use '(lisp excl))
+
+(defvar *patches* nil)
+
+#+allegro
+(eval-when (compile eval load)
+  (when (and (= excl::cl-major-version-number 3)
+	     (or (= excl::cl-minor-version-number 0)
+		 (and (= excl::cl-minor-version-number 1)
+		      (< excl::cl-generation-number 9))))
+    (push :clx-r4-process-patches *features*)))
+
+#+clx-r4-process-patches
+(push (cons 1000.2 "special patch for CLX (various process fixes)")
+      *patches*)
+
+
+(in-package :mp)
+
+#+clx-r4-process-patches
+(export 'wait-for-input-available)
+
+
+#+clx-r4-process-patches
+(defun with-timeout-event (seconds fnc args)
+  (unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
+  (let ((clock-event (make-clock-event)))
+    (when (<= seconds 0) (setq seconds 0))
+    (multiple-value-bind (secs msecs) (truncate seconds)
+      ;; secs is now a nonegative integer, and msecs is either fixnum zero
+      ;; or else something interesting.
+      (unless (eq 0 msecs)
+	(setq msecs (truncate (* 1000.0 msecs))))
+      ;; Now msecs is also a nonnegative fixnum.
+      (multiple-value-bind (now mnow) (excl::cl-internal-real-time)
+	(incf secs now)
+	(incf msecs mnow)
+	(when (>= msecs 1000)
+	  (decf msecs 1000)
+	  (incf secs))
+	(unless (fixnump secs) (setq secs most-positive-fixnum))
+	(setf (clock-event-secs clock-event) secs
+	      (clock-event-msecs clock-event) msecs
+	      (clock-event-function clock-event) fnc
+	      (clock-event-args clock-event) args)))
+    clock-event))
+
+
+#+clx-r4-process-patches
+(defmacro with-timeout ((seconds &body timeout-body) &body body)
+  `(let* ((clock-event (with-timeout-event ,seconds
+					   #'process-interrupt
+					   (cons *current-process*
+						 '(with-timeout-internal))))
+	  (excl::*without-interrupts* t)
+	  ret)
+     (unwind-protect
+	 ;; Warning: Branch tensioner better not reorder this code!
+	 (setq ret (catch 'with-timeout-internal
+		     (add-to-clock-queue clock-event)
+		     (let ((excl::*without-interrupts* nil))
+		       (multiple-value-list (progn ,@body)))))
+       (if* (eq ret 'with-timeout-internal)
+	  then (let ((excl::*without-interrupts* nil))
+		 (setq ret (multiple-value-list (progn ,@timeout-body))))
+	  else (remove-from-clock-queue clock-event)))
+     (values-list ret)))
+
+
+#+clx-r4-process-patches
+(defun process-lock (lock &optional (lock-value *current-process*)
+				    (whostate "Lock") timeout)
+  (declare (optimize (speed 3)))
+  (unless (process-lock-p lock)
+    (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
+  (without-interrupts
+   (if* (null (process-lock-locker lock))
+      then (setf (process-lock-locker lock) lock-value)
+      else (if* timeout
+	      then (if* (or (eq 0 timeout) ;for speed
+			    (zerop timeout))
+		      then nil
+		      else (with-timeout (timeout)
+			     (process-lock-1 lock lock-value whostate)))
+	      else (process-lock-1 lock lock-value whostate)))))
+
+
+#+clx-r4-process-patches
+(defun process-lock-1 (lock lock-value whostate)
+  (declare (type process-lock lock)
+	   (optimize (speed 3)))
+  (let ((process *current-process*))
+    (declare (type process process))
+    (unless process
+      (error
+       "PROCESS-LOCK may not be called on the scheduler's stack group."))
+    (loop (unless (process-lock-locker lock)
+	    (return (setf (process-lock-locker lock) lock-value)))
+      (push process (process-lock-waiting lock))
+      (let ((saved-whostate (process-whostate process)))
+	(unwind-protect
+	    (progn (setf (process-whostate process) whostate)
+		   (process-add-arrest-reason process lock))
+	  (setf (process-whostate process) saved-whostate))))))
+
+
+#+clx-r4-process-patches
+(defun process-wait (whostate function &rest args)
+  (declare (optimize (speed 3)))
+  ;; Run the wait function once here both for efficiency and as a
+  ;; first line check for errors in the function.
+  (unless (apply function args)
+    (process-wait-1 whostate function args)))
+
+
+#+clx-r4-process-patches
+(defun process-wait-1 (whostate function args)
+  (declare (optimize (speed 3)))
+  (let ((process *current-process*))
+    (declare (type process process))
+    (unless process
+      (error
+       "Process-wait may not be called within the scheduler's stack group."))
+    (let ((saved-whostate (process-whostate process)))
+      (unwind-protect
+	  (without-scheduling-internal
+	   (without-interrupts
+	    (setf (process-whostate process) whostate
+		  (process-wait-function process) function
+		  (process-wait-args process) args)
+	    (chain-rem-q process)
+	    (chain-ins-q process *waiting-processes*))
+	   (process-resume-scheduler nil))
+	(setf (process-whostate process) saved-whostate
+	      (process-wait-function process) nil
+	      (process-wait-args process) nil)))))
+
+
+#+clx-r4-process-patches
+(defun process-wait-with-timeout (whostate seconds function &rest args)
+  ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
+  ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
+  ;;  -- 28Feb90 smh
+  ;; Run the wait function once here both for efficiency and as a
+  ;; first line check for errors in the function.
+  (if* (apply function args)
+     then t
+     else (let ((ret (list nil)))
+            (without-interrupts
+             (let ((clock-event
+                    (with-timeout-event seconds #'identity '(nil))))
+               (add-to-clock-queue clock-event)
+               (process-wait-1 whostate
+                               #'(lambda (clock-event function args ret)
+                                   (or (null (chain-next clock-event))
+                                       (and (apply function args)
+                                            (setf (car ret) 't))))
+                               (list clock-event function args ret))))
+            (car ret))))
+
+
+;;
+;; Returns nil on timeout, otherwise t.
+;;
+#+clx-r4-process-patches
+(defun wait-for-input-available
+    (stream-or-fd &key (wait-function #'listen)
+		       (whostate "waiting for input")
+		       timeout)
+  (let ((fd (if* (fixnump stream-or-fd) then stream-or-fd
+	     elseif (streamp stream-or-fd)
+	       then (excl::stream-input-fn stream-or-fd)
+	       else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
+    ;; At this point fd could be nil, since stream-input-fn returns nil for
+    ;; streams that are output only, or for certain special purpose streams.
+    (if fd
+	(unwind-protect
+	    (progn
+	      (mp::mpwatchfor fd)
+	      (if* timeout
+		 then (mp::process-wait-with-timeout
+		       whostate timeout wait-function stream-or-fd)
+		 else (mp::process-wait whostate wait-function stream-or-fd)
+		      t))
+	  (mp::mpunwatchfor fd))
+      (if* timeout
+	 then (mp::process-wait-with-timeout
+	       whostate timeout wait-function stream-or-fd)
+	 else (mp::process-wait whostate wait-function stream-or-fd)
+	      t))))
diff --git a/clx/fonts.lisp b/clx/fonts.lisp
new file mode 100644
index 000000000..b40f98679
--- /dev/null
+++ b/clx/fonts.lisp
@@ -0,0 +1,373 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  open-font
+	  discard-font-info
+	  close-font
+	  list-font-names
+	  list-fonts
+	  font-path))
+
+;; The char-info stuff is here instead of CLX because of uses of int16->card16.
+
+; To allow efficient storage representations, the type char-info is not
+; required to be a structure.
+
+;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
+
+;(defun char-<metric> (font index)
+;  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
+;  ;; (or an in-bounds index on a pseudo font), although returning zero or
+;  ;; signalling might be better.
+;  (declare (type font font)
+;	   (type integer index)
+;	   (values (or null integer))))
+
+;(defun max-char-<metric> (font)
+;  ;; Note: I have tentatively chosen separate accessors over allowing :min and
+;  ;; :max as an index above.
+;  (declare (type font font)
+;	   (values integer)))
+
+;(defun min-char-<metric> (font)
+;  (declare (type font font)
+;	   (values integer)))
+
+;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
+
+(deftype char-info-vec () '(simple-array int16 (6)))
+
+(macrolet ((def-char-info-accessors (useless-name &body fields)
+	    `(within-definition (,useless-name def-char-info-accessors)
+	       ,@(do ((field fields (cdr field))
+		      (n 0 (1+ n))
+		      (name) (type)
+		      (result nil))
+		     ((endp field) result)
+		   (setq name (xintern 'char- (caar field)))
+		   (setq type (cadar field))
+		   (flet ((from (form)
+			    (if (eq type 'int16)
+				form
+				`(,(xintern 'int16-> type) ,form))))
+		     (push
+		       `(defun ,name (font index)
+			  (declare (type font font)
+				   (type array-index index))
+			  (declare (values (or null ,type)))
+			  (when (and (font-name font)
+				     (index>= (font-max-char font) index (font-min-char font)))
+			    (the ,type
+				 ,(from
+				    `(the int16
+					  (let ((char-info-vector (font-char-infos font)))
+					    (declare (type char-info-vec char-info-vector))
+					    (if (index-zerop (length char-info-vector))
+						;; Fixed width font
+						(aref (the char-info-vec
+							   (font-max-bounds font))
+						      ,n)
+						;; Variable width font
+						(aref char-info-vector
+						      (index+
+							(index*
+							  6
+							  (index-
+							    index
+							    (font-min-char font)))
+							,n)))))))))
+		       result)
+		     (setq name (xintern 'min-char- (caar field)))
+		     (push
+		       `(defun ,name (font)
+			  (declare (type font font))
+			  (declare (values (or null ,type)))
+			  (when (font-name font)
+			    (the ,type
+				 ,(from
+				    `(the int16
+					  (aref (the char-info-vec (font-min-bounds font))
+						,n))))))
+		       result)
+		     (setq name (xintern 'max-char- (caar field)))
+		     (push
+		       `(defun ,name (font)
+			  (declare (type font font))
+			  (declare (values (or null ,type)))
+			  (when (font-name font)
+			    (the ,type
+				 ,(from
+				    `(the int16
+					  (aref (the char-info-vec (font-max-bounds font))
+						,n))))))
+		       result)))
+	  
+	       (defun make-char-info
+		      (&key ,@(mapcar
+				#'(lambda (field)
+				    `(,(car field) (required-arg ,(car field))))
+				fields))
+		 (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
+		 (let ((result (make-array ,(length fields) :element-type 'int16)))
+		   (declare (type char-info-vec result)
+			    (array-register result))
+		   ,@(do* ((field fields (cdr field))
+			   (var (caar field) (caar field))
+			   (type (cadar field) (cadar field))
+			   (n 0 (1+ n))
+			   (result nil))
+			  ((endp field) (nreverse result))
+		       (push `(setf (aref result ,n)
+				    ,(if (eq type 'int16)
+					 var
+					 `(,(xintern type '->int16) ,var)))
+			     result))
+		   result)))))
+  (def-char-info-accessors ignore
+    (left-bearing int16)
+    (right-bearing int16)
+    (width int16)
+    (ascent int16)
+    (descent int16)
+    (attributes card16)))
+    
+(defun open-font (display name)
+  ;; Font objects may be cached and reference counted locally within the display
+  ;; object.  This function might not execute a with-display if the font is cached.
+  ;; The protocol QueryFont request happens on-demand under the covers.
+  (declare (type display display)
+	   (type stringable name))
+  (declare (values font))
+  (let* ((name-string (string-downcase (string name)))
+	 (font (car (member name-string (display-font-cache display)
+			    :key 'font-name
+			    :test 'equal)))
+	 font-id)
+    (unless font
+      (setq font (make-font :display display :name name-string))
+      (setq font-id (allocate-resource-id display font 'font))
+      (setf (font-id-internal font) font-id)
+      (with-buffer-request (display *x-openfont*)
+	(resource-id font-id)
+	(card16 (length name-string))
+	(pad16 nil)
+	(string name-string))
+      (push font (display-font-cache display)))
+    (incf (font-reference-count font))
+    font))
+
+(defun open-font-internal (font)
+  ;; Called "under the covers" to open a font object
+  (declare (type font font))
+  (declare (values resource-id))
+  (let* ((name-string (font-name font))
+	 (display (font-display font))
+	 (id (allocate-resource-id display font 'font)))
+    (setf (font-id-internal font) id)
+    (with-buffer-request (display *x-openfont*)
+      (resource-id id)
+      (card16 (length name-string))
+      (pad16 nil)
+      (string name-string))
+    (push font (display-font-cache display))
+    (incf (font-reference-count font))
+    id))
+
+(defun discard-font-info (font)
+  ;; Discards any state that can be re-obtained with QueryFont.  This is
+  ;; simply a performance hint for memory-limited systems.
+  (declare (type font font))
+  (setf (font-font-info-internal font) nil
+	(font-char-infos-internal font) nil))
+
+(defun query-font (font)
+  ;; Internal function called by font and char info accessors
+  (declare (type font font))
+  (declare (values font-info))
+  (let ((display (font-display font))
+	font-id
+	font-info
+	props)
+    (setq font-id (font-id font)) ;; May issue an open-font request
+    (with-buffer-request-and-reply (display *x-queryfont* 60)
+	 ((resource-id font-id))
+      (let* ((min-byte2 (card16-get 40))
+	     (max-byte2 (card16-get 42))
+	     (min-byte1 (card8-get 49))
+	     (max-byte1 (card8-get 50))
+	     (min-char  min-byte2)
+	     (max-char  (index+ (index-ash max-byte1 8) max-byte2))
+	     (nfont-props (card16-get 46))
+	     (nchar-infos (index* (card32-get 56) 6))
+	     (char-info (make-array nchar-infos :element-type 'int16)))
+	(setq font-info
+	      (make-font-info
+		:direction (member8-get 48 :left-to-right :right-to-left)
+		:min-char min-char
+		:max-char max-char
+		:min-byte1 min-byte1
+		:max-byte1 max-byte1
+		:min-byte2 min-byte2
+		:max-byte2 max-byte2
+		:all-chars-exist-p (boolean-get 51)
+		:default-char (card16-get 44)
+		:ascent (int16-get 52)
+		:descent (int16-get 54)
+		:min-bounds (char-info-get 8)
+		:max-bounds (char-info-get 24)))
+	(setq props (sequence-get :length (index* 2 nfont-props) :format int32
+				  :result-type 'list :index 60))
+	(sequence-get :length nchar-infos :format int16 :data char-info
+		      :index (index+ 60 (index* 2 nfont-props 4)))
+	(setf (font-char-infos-internal font) char-info)
+	(setf (font-font-info-internal font) font-info)))
+    ;; Replace atom id's with keywords in the plist
+    (do ((p props (cddr p)))
+	((endp p))
+      (setf (car p) (atom-name display (car p))))
+    (setf (font-info-properties font-info) props)
+    font-info))
+
+(defun close-font (font)
+  ;; This might not generate a protocol request if the font is reference
+  ;; counted locally.
+  (declare (type font font))
+  (when (and (not (plusp (decf (font-reference-count font))))
+	     (font-id-internal font))
+    (let ((display (font-display font))
+	  (id (font-id-internal font)))
+      (declare (type display display))
+      ;; Remove font from cache
+      (setf (display-font-cache display) (delete font (display-font-cache display)))
+      ;; Close the font
+      (with-buffer-request (display *x-closefont*)
+	(resource-id id)))))
+
+(defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
+  (declare (type display display)
+	   (type string pattern)
+	   (type card16 max-fonts)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence string)))
+  (let ((string (string pattern)))
+    (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
+	 ((card16 max-fonts (length string))
+	  (string string))
+      (values
+	(read-sequence-string
+	  buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))))
+
+(defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
+  ;; Note: Was called list-fonts-with-info.
+  ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
+  ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
+  ;; converted (internally) to real fonts dynamically as needed, by issuing an
+  ;; OpenFont request.  However, the OpenFont might fail, in which case the
+  ;; invalid-font error can arise.
+  (declare (type display display)
+	   (type string pattern)
+	   (type card16 max-fonts)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence font)))
+  (let ((string (string pattern))
+	(result nil))
+    (with-buffer-request-and-reply (display *x-listfontswithinfo* 60
+					    :sizes (8 16) :multiple-reply t)
+	 ((card16 max-fonts (length string))
+	  (string string))
+      (cond ((zerop (card8-get 1)) t)
+	    (t
+	(let* ((name-len (card8-get 1))
+	       (min-byte2 (card16-get 40))
+	       (max-byte2 (card16-get 42))
+	       (min-byte1 (card8-get 49))
+	       (max-byte1 (card8-get 50))
+	       (min-char  min-byte2)
+	       (max-char  (index+ (index-ash max-byte1 8) max-byte2))
+	       (nfont-props (card16-get 46))
+	       (font
+		 (make-font
+		   :display display
+		   :name nil
+		   :font-info-internal
+		   (make-font-info
+		     :direction (member8-get 48 :left-to-right :right-to-left)
+		     :min-char min-char
+		     :max-char max-char
+		     :min-byte1 min-byte1
+		     :max-byte1 max-byte1
+		     :min-byte2 min-byte2
+		     :max-byte2 max-byte2
+		     :all-chars-exist-p (boolean-get 51)
+		     :default-char (card16-get 44)
+		     :ascent (int16-get 52)
+		     :descent (int16-get 54)
+		     :min-bounds (char-info-get 8)
+		     :max-bounds (char-info-get 24)
+		     :properties (sequence-get :length (index* 2 nfont-props)
+					       :format int32
+					       :result-type 'list
+					       :index 60)))))
+	  (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
+	  (push font result))
+	nil)))
+    ;; Replace atom id's with keywords in the plist
+    (dolist (font result)
+      (do ((p (font-properties font) (cddr p)))
+	  ((endp p))
+	(setf (car p) (atom-name display (car p)))))
+    (coerce (nreverse result) result-type)))
+
+(defun font-path (display &key (result-type 'list))
+  (declare (type display display)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence (or string pathname))))
+  (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))
+       ()
+    (values
+      (read-sequence-string
+	buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))
+
+(defun set-font-path (display paths)
+  (declare (type display display)
+	   (type sequence paths)) ;; (sequence (or string pathname))
+  (let ((path-length (length paths))
+	(request-length 8))
+    ;; Find the request length
+    (dotimes (i path-length)
+      (let* ((string (string (elt paths i)))
+	     (len (length string)))
+	(incf request-length (1+ len))))
+    (with-buffer-request (display *x-setfontpath* :length request-length)
+      (length (ceiling request-length 4))
+      (card16 path-length)
+      (pad16 nil)
+      (progn
+	(incf buffer-boffset 8)
+	(dotimes (i path-length)
+	  (let* ((string (string (elt paths i)))
+		 (len (length string)))
+	    (card8-put 0 len)
+	    (string-put 1 string :appending t :header-length 1)
+	    (incf buffer-boffset (1+ len))))
+	(setf (buffer-boffset display) (lround buffer-boffset))))))
+
+(defsetf font-path set-font-path)
diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp
new file mode 100644
index 000000000..41c33a6c2
--- /dev/null
+++ b/clx/gcontext.lisp
@@ -0,0 +1,994 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; GContext
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;;	GContext values are usually cached locally in the GContext object.
+;;;	This is required because the X.11 server doesn't have any requests
+;;;	for getting GContext values back.
+;;;
+;;;	GContext changes are cached until force-GContext-changes is called.
+;;;	All the requests that use GContext (including the GContext accessors,
+;;;	but not the SETF's) call force-GContext-changes.
+;;;	In addition, the macro WITH-GCONTEXT may be used to provide a 
+;;;	local view if a GContext.
+;;;
+;;;	Each GContext keeps a copy of the values the server has seen, and
+;;;	a copy altered by SETF, called the LOCAL-STATE (bad name...).
+;;;	The SETF accessors increment a timestamp in the GContext.
+;;;	When the timestamp in a GContext isn't equal to the timestamp in
+;;;	the local-state, changes have been made, and force-GContext-changes
+;;;	loops through the GContext and local-state, sending differences to
+;;;	the server, and updating GContext.
+;;;
+;;;	WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
+;;;	a private copy.  This is easy (and fast) for lisp machines, but other
+;;;	lisps will have problems.  Fortunately, most other lisps don't care,
+;;;	because they don't run in a multi-processing shared-address space
+;;;	environment.
+
+(in-package :xlib)
+
+(export '(force-gcontext-changes
+	  with-gcontext
+	  create-gcontext
+	  copy-gcontext-components
+	  copy-gcontext
+	  free-gcontext
+	  
+	  gcontext-function
+	  gcontext-plane-mask
+	  gcontext-foreground
+	  gcontext-background
+	  gcontext-line-width
+	  gcontext-line-style
+	  gcontext-cap-style
+	  gcontext-join-style
+	  gcontext-fill-style
+	  gcontext-fill-rule
+	  gcontext-tile
+	  gcontext-stipple
+	  gcontext-ts-x
+	  gcontext-ts-y
+	  gcontext-font
+	  gcontext-subwindow-mode
+	  gcontext-exposures
+	  gcontext-clip-x
+	  gcontext-clip-y
+	  gcontext-clip-mask
+	  gcontext-dashes
+	  gcontext-arc-mode
+	  gcontext-dash-offset
+          gcontext-clip-ordering
+
+	  define-gcontext-accessor
+	  ))
+
+;; GContext state accessors
+;;	The state vector contains all card32s to speed server updating
+
+(eval-when (eval compile load)
+
+(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
+
+(macrolet ((def-gc-internals (name &rest extras)
+	    (let ((macros nil)
+		  (indexes nil)
+		  (masks nil)
+		  (index 0))
+	      (dolist (name *gcontext-components*)
+		(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
+			 `(svref ,state ,,index))
+		      macros)
+		(setf (getf indexes name) index)
+		(push (ash 1 index) masks)
+		(incf index))
+	      (dolist (extra extras)
+		(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
+			 `(svref ,state ,,index))
+		      macros)
+		;; don't override already correct index entries
+		(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
+		  (setf (getf indexes (or (second extra) (first extra))) index))
+		(push (logior (ash 1 index)
+			      (if (second extra)
+				  (ash 1 (position (second extra) *gcontext-components*))
+				  0))
+		      masks)
+		(incf index))
+	      `(within-definition (def-gc-internals ,name)
+		 ,@(nreverse macros)
+		 (eval-when (eval compile load)
+		   (defconstant *gcontext-data-length* ,index)
+		   (defconstant *gcontext-indexes* ',indexes)
+		   (defconstant *gcontext-masks*
+				',(coerce (nreverse masks) 'simple-vector)))))))
+  (def-gc-internals ignore
+    (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
+
+) ;; end EVAL-WHEN
+
+(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
+
+(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
+
+(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
+  (name nil :type symbol :read-only t)
+  (default nil :type t :read-only t)
+  (set-function #'identity :type (function (gcontext t) t) :read-only t)
+  (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t))
+
+(defvar *gcontext-extensions* nil) ;; list of gcontext-extension
+
+;; Gcontext state Resource
+(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
+
+(defmacro gcontext-state-next (state)
+  `(svref ,state 0))
+
+(defun allocate-gcontext-state ()
+  ;; Allocate a gcontext-state
+  ;; Loop until a local state is found that's large enough to hold
+  ;; any extensions that may exist.
+  (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
+    (declare (type array-index length))
+    (loop
+      (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
+					    gcontext-state-next gcontext-state)
+		       (make-array length :initial-element nil))))
+	(declare (type gcontext-state state))
+	(when (index>= (length state) length)
+	  (return state))))))
+
+(defun deallocate-gcontext-state (state)
+  (declare (type gcontext-state state))
+  (fill state nil)
+  (threaded-atomic-push state *gcontext-local-state-cache*
+			gcontext-state-next gcontext-state))
+
+;; Temp-Gcontext Resource
+(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
+
+(defun allocate-temp-gcontext ()
+  (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
+      (make-gcontext :local-state '#() :server-state '#())))
+
+(defun deallocate-temp-gcontext (gc)
+  (declare (type gcontext gc))
+  (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
+
+;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
+;; as (type <type> <name>), there is an accessor:
+
+;(defun gcontext-<name> (gcontext)
+;  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
+;  ;; off, or the component was copied from a gcontext with unknown state).
+;  (declare (type gcontext gcontext)
+;	   (values <type>)))
+
+;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
+;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
+
+;(defsetf gcontext-<name> (gcontext) (value)
+;  )
+
+;; Generate all the accessors and defsetf's for GContext
+
+(defmacro xgcmask->gcmask (mask)
+  `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
+
+(defmacro access-gcontext ((gcontext local-state) &body body)
+  `(let ((,local-state (gcontext-local-state ,gcontext)))
+     (declare (type gcontext-state ,local-state))
+     ,@body))
+
+(defmacro modify-gcontext ((gcontext local-state) &body body)
+  ;; The timestamp must be altered after the modification
+  `(let ((,local-state (gcontext-local-state ,gcontext)))
+     (declare (type gcontext-state ,local-state))
+     (prog1
+	 (progn ,@body)
+       (setf (gcontext-internal-timestamp ,local-state) 0))))
+
+(defmacro def-gc-accessor (name type)
+  (let* ((gcontext-name (xintern 'gcontext- name))
+	 (internal-accessor (xintern 'gcontext-internal- name))
+	 (internal-setfer (xintern 'set- gcontext-name)))
+    `(within-definition (,name def-gc-accessor)
+
+       (defun ,gcontext-name (gcontext)
+	 (declare (type gcontext gcontext))
+	 (declare (values (or null ,type)))
+	 (let ((value (,internal-accessor (gcontext-local-state gcontext))))
+	   (declare (type (or null card32) value))
+	   (when value ;; Don't do anything when value isn't known
+	     (let ((%buffer (gcontext-display gcontext)))
+	       (declare (type display %buffer))
+	       %buffer
+	       (decode-type ,type value)))))
+       
+       (defun ,internal-setfer (gcontext value)
+	 (declare (type gcontext gcontext)
+		  (type ,type value))
+	 (modify-gcontext (gcontext local-state)
+	   (setf (,internal-accessor local-state) (encode-type ,type value))
+	   ,@(when (eq type 'pixmap)
+	       ;; write-through pixmaps, because the protocol allows
+	       ;; the server to copy the pixmap contents at the time
+	       ;; of the store, rather than continuing to share with
+	       ;; the pixmap.
+	       `((let ((server-state (gcontext-server-state gcontext)))
+		   (setf (,internal-accessor server-state) nil))))
+	   value))
+       
+       (defsetf ,gcontext-name ,internal-setfer))))
+
+(defmacro incf-internal-timestamp (state)
+  (let ((ts (gensym)))
+    `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
+       (declare (type fixnum ,ts))
+       ;; the probability seems low enough
+       (setq ,ts (if (= ,ts most-positive-fixnum)
+		     1
+		     (the fixnum (1+ ,ts))))
+       (setf (gcontext-internal-timestamp ,state) ,ts))))
+
+(def-gc-accessor function boole-constant)
+(def-gc-accessor plane-mask card32)
+(def-gc-accessor foreground card32)
+(def-gc-accessor background card32)
+(def-gc-accessor line-width card16)
+(def-gc-accessor line-style (member :solid :dash :double-dash))
+(def-gc-accessor cap-style (member :not-last :butt :round :projecting))
+(def-gc-accessor join-style (member :miter :round :bevel))
+(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
+(def-gc-accessor fill-rule (member :even-odd :winding))
+(def-gc-accessor tile pixmap)
+(def-gc-accessor stipple pixmap)
+(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
+(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
+;; (def-GC-accessor font font) ;; See below
+(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
+(def-gc-accessor exposures (member :off :on))
+(def-gc-accessor clip-x int16)
+(def-gc-accessor clip-y int16)
+;; (def-GC-accessor clip-mask) ;; see below
+(def-gc-accessor dash-offset card16)
+;; (def-GC-accessor dashes)  ;; see below
+(def-gc-accessor arc-mode (member :chord :pie-slice))
+
+
+(defun gcontext-clip-mask (gcontext)
+  (declare (type gcontext gcontext))
+  (declare (values (or null (member :none) pixmap rect-seq)
+		   (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
+  (access-gcontext (gcontext local-state)
+    (multiple-value-bind (clip clip-mask)
+	(without-interrupts
+	  (values (gcontext-internal-clip local-state)
+		  (gcontext-internal-clip-mask local-state)))
+      (if (null clip)
+	  (values (let ((%buffer (gcontext-display gcontext)))
+		    (declare (type display %buffer))
+		    (decode-type (or (member :none) pixmap) clip-mask))
+		  nil)
+	(values (second clip)
+		(decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
+			     (first clip)))))))
+
+(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
+  ;; A bit strange, but retains setf form.
+  ;; a nil clip-mask is transformed to an empty vector
+  `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
+
+(defun set-gcontext-clip-mask (gcontext ordering clip-mask)
+  ;; a nil clip-mask is transformed to an empty vector
+  (declare (type gcontext gcontext)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
+	   (type (or (member :none) pixmap rect-seq) clip-mask))
+  (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
+  (multiple-value-bind (clip-mask clip)
+      (typecase clip-mask
+	(pixmap (values (pixmap-id clip-mask) nil))
+	((member :none) (values 0 nil))
+	(sequence
+	  (values nil
+		  (list (encode-type
+			  (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
+			  ordering)
+			(copy-seq clip-mask))))
+	(otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-clip local-state) clip
+		(gcontext-internal-clip-mask local-state) clip-mask)
+	  (if (null clip)
+	      (setf (gcontext-internal-clip server-state) nil)
+	    (setf (gcontext-internal-clip-mask server-state) nil))
+	  (when (and clip-mask (not (zerop clip-mask)))
+	    ;; write-through clip-mask pixmap, because the protocol allows the
+	    ;; server to copy the pixmap contents at the time of the store,
+	    ;; rather than continuing to share with the pixmap.
+	    (setf (gcontext-internal-clip-mask server-state) nil))))))
+  clip-mask)
+
+(defun gcontext-dashes (gcontext)
+  (declare (type gcontext gcontext))
+  (declare (values (or null card8 sequence)))
+  (access-gcontext (gcontext local-state)
+    (multiple-value-bind (dash dashes)
+	(without-interrupts 
+	  (values (gcontext-internal-dash local-state)
+		  (gcontext-internal-dashes local-state)))
+      (if (null dash)
+	  dashes
+	dash))))
+
+(defsetf gcontext-dashes set-gcontext-dashes)
+
+(defun set-gcontext-dashes (gcontext dashes)
+  (declare (type gcontext gcontext)
+	   (type (or card8 sequence) dashes))
+  (multiple-value-bind (dashes dash)
+      (if (type? dashes 'sequence)
+	  (if (zerop (length dashes))
+	      (x-type-error dashes '(or card8 sequence) "non-empty sequence")
+	    (values nil (or (copy-seq dashes) (vector))))
+	(values (encode-type card8 dashes) nil))
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-dash local-state) dash
+		(gcontext-internal-dashes local-state) dashes)
+	  (if (null dash)
+	      (setf (gcontext-internal-dash server-state) nil)
+	    (setf (gcontext-internal-dashes server-state) nil))))))
+  dashes)
+
+(defun gcontext-font (gcontext &optional metrics-p)
+  ;; If the stored font is known, it is returned.  If it is not known and
+  ;; metrics-p is false, then nil is returned.  If it is not known and
+  ;; metrics-p is true, then a pseudo font is returned.  Full metric and
+  ;; property information can be obtained, but the font does not have a name or
+  ;; a resource-id, and attempts to use it where a resource-id is required will
+  ;; result in an invalid-font error.
+  (declare (type gcontext gcontext)
+	   (type boolean metrics-p))
+  (declare (values (or null font)))
+  (access-gcontext (gcontext local-state)
+    (let ((font (gcontext-internal-font-obj local-state)))
+      (or font
+	  (when metrics-p
+	    ;; XXX this isn't correct
+	    (make-font :display (gcontext-display gcontext)
+		       :id (gcontext-id gcontext)
+		       :name nil))))))
+
+(defsetf gcontext-font set-gcontext-font)
+
+(defun set-gcontext-font (gcontext font)
+  (declare (type gcontext gcontext)
+	   (type fontable font))
+  (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
+	 (font (and font-object (font-id font-object))))
+    ;; XXX need to check font has id (and name?)
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-font-obj local-state) font-object
+		(gcontext-internal-font local-state) font)
+	  ;; check against font, not against font-obj
+	  (if (null font)
+	      (setf (gcontext-internal-font server-state) nil)
+	    (setf (gcontext-internal-font-obj server-state) font-object))))))
+  font)
+
+(defun force-gcontext-changes-internal (gcontext)
+  ;; Force any delayed changes.
+  (declare (type gcontext gcontext))
+  #.(declare-buffun)
+
+  (let ((display (gcontext-display gcontext))
+	(server-state (gcontext-server-state gcontext))
+	(local-state (gcontext-local-state gcontext)))
+    (declare (type display display)
+	     (type gcontext-state server-state local-state))
+
+    ;; Update server when timestamps don't match
+    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
+	       (the fixnum (gcontext-internal-timestamp server-state)))
+
+      ;; The display is already locked.
+      (macrolet ((with-buffer ((buffer &key timeout) &body body)
+		   `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
+			   ,@body)))
+
+	;; Because there is no locking on the local state we have to
+	;; assume that state will change and set timestamps up front,
+	;; otherwise by the time we figured out there were no changes
+	;; and tried to store the server stamp as the local stamp, the
+	;; local stamp might have since been modified.
+	(setf (gcontext-internal-timestamp local-state)
+	      (incf-internal-timestamp server-state))
+
+	(block no-changes
+	  (let ((last-request (buffer-last-request display)))
+	    (with-buffer-request (display *x-changegc*)
+	      (gcontext gcontext)
+	      (progn
+		(do ((i 0 (index+ i 1))
+		     (bit 1 (the xgcmask (ash bit 1)))
+		     (nbyte 12)
+		     (mask 0)
+		     (local 0))
+		    ((index>= i *gcontext-fast-change-length*)
+		     (when (zerop mask)
+		       ;; If nothing changed, restore last-request and quit
+		       (setf (buffer-last-request display)
+			     (if (zerop (buffer-last-request display))
+				 nil
+			       last-request))
+		       (return-from no-changes nil))
+		     (card29-put 8 mask)
+		     (card16-put 2 (index-ash nbyte -2))
+		     (index-incf (buffer-boffset display) nbyte))
+		  (declare (type array-index i nbyte)
+			   (type xgcmask bit)
+			   (type gcmask mask)
+			   (type (or null card32) local))
+		  (unless (eql (the (or null card32) (svref server-state i))
+			       (setq local (the (or null card32) (svref local-state i))))
+		    (setf (svref server-state i) local)
+		    (card32-put nbyte local)
+		    (setq mask (the gcmask (logior mask bit)))
+		    (index-incf nbyte 4)))))))
+
+	;; Update GContext extensions
+	(do ((extension *gcontext-extensions* (cdr extension))
+	     (i *gcontext-data-length* (index+ i 1))
+	     (local))
+	    ((endp extension))
+	  (unless (eql (svref server-state i)
+		       (setq local (svref local-state i)))
+	    (setf (svref server-state i) local)
+	    (funcall (gcontext-extension-set-function (car extension)) gcontext local)))
+
+	;; Update clipping rectangles
+	(multiple-value-bind (local-clip server-clip)
+	    (without-interrupts 
+	      (values (gcontext-internal-clip local-state)
+		      (gcontext-internal-clip server-state)))
+	  (unless (equalp local-clip server-clip)
+	    (setf (gcontext-internal-clip server-state) nil)
+	    (unless (null local-clip)
+	      (with-buffer-request (display *x-setcliprectangles*)
+		(data (first local-clip))
+		(gcontext gcontext)
+		;; XXX treat nil correctly
+		(card16 (or (gcontext-internal-clip-x local-state) 0)
+			(or (gcontext-internal-clip-y local-state) 0))
+		;; XXX this has both int16 and card16 values
+		((sequence :format int16) (second local-clip)))
+	      (setf (gcontext-internal-clip server-state) local-clip))))
+
+	;; Update dashes
+	(multiple-value-bind (local-dash server-dash)
+	    (without-interrupts 
+	      (values (gcontext-internal-dash local-state)
+		      (gcontext-internal-dash server-state)))
+	  (unless (equalp local-dash server-dash)
+	    (setf (gcontext-internal-dash server-state) nil)
+	    (unless (null local-dash)
+	      (with-buffer-request (display *x-setdashes*)
+		(gcontext gcontext)
+		;; XXX treat nil correctly
+		(card16 (or (gcontext-internal-dash-offset local-state) 0)
+			(length local-dash))
+		((sequence :format card8) local-dash))
+	      (setf (gcontext-internal-dash server-state) local-dash))))))))
+
+(defun force-gcontext-changes (gcontext)
+  ;; Force any delayed changes.
+  (declare (type gcontext gcontext))
+  (let ((display (gcontext-display gcontext))
+	(server-state (gcontext-server-state gcontext))
+	(local-state (gcontext-local-state gcontext)))
+    (declare (type gcontext-state server-state local-state)
+	     (array-register server-state local-state))
+    ;; Update server when timestamps don't match
+    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
+	       (the fixnum (gcontext-internal-timestamp server-state)))
+      (with-display (display)
+	(force-gcontext-changes-internal gcontext)))))
+
+;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
+;;;	     SET IN THE GCONTEXT ON ENTRY.  BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
+;;;	     UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
+;;;	     COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
+;;;          BACK.
+
+(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
+				   &allow-other-keys)
+			 &body body)
+  ;; "Binds" the gcontext components specified by options within the
+  ;; dynamic scope of the body (i.e., indefinite scope and dynamic
+  ;; extent), on a per-process basis in a multi-process environment.
+  ;; The body is not surrounded by a with-display.  If cache-p is nil or
+  ;; the some component states are unknown, this will implement
+  ;; save/restore by creating a temporary gcontext and doing
+  ;; copy-gcontext-components to and from it.
+
+  (declare (arglist (gcontext &rest options &key
+			     function plane-mask foreground background
+			     line-width line-style cap-style join-style
+			     fill-style fill-rule arc-mode tile stipple ts-x
+			     ts-y font subwindow-mode exposures clip-x clip-y
+			     clip-mask clip-ordering dash-offset dashes
+			     &allow-other-keys)
+		   &body body))
+  (remf options :clip-ordering)
+
+  (let ((gc (gensym))
+	(saved-state (gensym))
+	(temp-gc (gensym))
+	(temp-mask (gensym))
+	(temp-vars nil)
+	(setfs nil)
+	(indexes nil) ; List of gcontext field indices
+	(extension-indexes nil) ; List of gcontext extension field indices
+	(ts-index (getf *gcontext-indexes* :timestamp)))
+
+    (do* ((option options (cddr option))
+	  (name (car option) (car option))
+	  (value (cadr option) (cadr option)))
+	 ((endp option) (setq setfs (nreverse setfs)))
+      (let ((index (getf *gcontext-indexes* name)))
+	(if index
+	    (push index indexes)
+	  (let ((extension (find name *gcontext-extensions*
+				 :key #'gcontext-extension-name)))
+	    (if extension
+		(progn
+		  (push (xintern "Internal-" 'gcontext- name "-State-Index")
+			extension-indexes))
+	      (x-type-error name 'gcontext-key)))))
+      (let ((accessor `(,(xintern 'gcontext- name) ,gc
+			,@(when (eq name :clip-mask) `(,clip-ordering))))
+	    (temp-var (gensym)))
+	(when value
+	  (push `(,temp-var ,value) temp-vars)
+	  (push `(setf ,accessor ,temp-var) setfs))))
+    (if setfs
+	`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
+	     (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
+	   (declare (type gcontext ,gc)
+		    (type gcontext-state ,saved-state)
+		    (type xgcmask ,temp-mask)
+		    (type (or null resource-id) ,temp-gc))
+	   (with-gcontext-bindings (,gc ,saved-state
+					,(append indexes extension-indexes)
+				    ,ts-index ,temp-mask ,temp-gc)
+	     (let ,temp-vars
+	       ,@setfs)
+	     ,@body))
+      `(progn ,@body))))
+
+(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
+  ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
+  (declare (type gcontext gcontext)
+	   (type list indexes)
+	   (dynamic-extent extension-indices))
+  (let ((local-state (gcontext-local-state gcontext))
+	(saved-state (allocate-gcontext-state))
+	(cache-p (gcontext-cache-p gcontext)))
+    (declare (type gcontext-state local-state saved-state))
+    (setf (gcontext-internal-timestamp saved-state) 1)
+    (let ((temp-gc nil)
+	  (temp-mask 0)
+	  (extension-mask 0))
+      (declare (type xgcmask temp-mask)
+	       (type integer extension-mask))
+      (dolist (i indexes)
+	(when (or (not (setf (svref saved-state i) (svref local-state i)))
+		  (not cache-p))
+	  (setq temp-mask
+		(the xgcmask (logior temp-mask
+				     (the xgcmask (svref *gcontext-masks* i)))))))
+      (dolist (i extension-indices)
+	(when (or (not (setf (svref saved-state i) (svref local-state i)))
+		  (not cache-p))
+	  (setq extension-mask
+		(the xgcmask (logior extension-mask (ash 1 i))))))
+      (when (or (plusp temp-mask)
+		(plusp extension-mask))
+	;; Copy to temporary GC when field unknown or cache-p false
+	(let ((display (gcontext-display gcontext)))
+	  (declare (type display display))
+	  (with-display (display)
+	    (setq temp-gc (allocate-temp-gcontext))
+	    (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
+		  (gcontext-display temp-gc) display
+		  (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
+		  (gcontext-server-state temp-gc) saved-state
+		  (gcontext-local-state temp-gc) saved-state)
+	    ;; Create a new (temporary) gcontext
+	    (with-buffer-request (display *x-creategc*)
+	      (gcontext temp-gc)
+	      (drawable (gcontext-drawable gcontext))
+	      (card29 0))
+	    ;; Copy changed components to the temporary gcontext
+	    (when (plusp temp-mask)
+	      (with-buffer-request (display *x-copygc*)
+		(gcontext gcontext)
+		(gcontext temp-gc)
+		(card29 (xgcmask->gcmask temp-mask))))
+	    ;; Copy extension fields to the new gcontext
+	    (when (plusp extension-mask)
+	      ;; Copy extension fields from temp back to gcontext
+	      (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
+		   (i 0 (index+ i 1)))
+		  ((zerop bit))
+		(let ((copy-function (gcontext-extension-copy-function
+				       (elt *gcontext-extensions* i))))
+		  (funcall copy-function gcontext temp-gc
+			   (svref local-state (index+ i *gcontext-data-length*))))))
+	    )))
+      (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) 
+
+(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
+  (declare (type gcontext gcontext temp-gc)
+	   (type xgcmask temp-mask))
+  (let ((display (gcontext-display gcontext)))
+    (declare (type display display))
+    (with-display (display)
+      (with-buffer-request (display *x-copygc*)
+	(gcontext temp-gc)
+	(gcontext gcontext)
+	(card29 (xgcmask->gcmask temp-mask)))
+      ;; Copy extension fields from temp back to gcontext
+      (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
+	   (extensions *gcontext-extensions* (cdr extensions))
+	   (i *gcontext-data-length* (index+ i 1))
+	   (local-state (gcontext-local-state temp-gc)))
+	  ((zerop bit))
+	(let ((copy-function (gcontext-extension-copy-function (car extensions))))
+	  (funcall copy-function temp-gc gcontext (svref local-state i))))
+      ;; free gcontext
+      (with-buffer-request (display *x-freegc*)
+	(gcontext temp-gc))
+      (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
+      (deallocate-temp-gcontext temp-gc)
+      ;; Copy saved state back to server state
+      (do ((server-state (gcontext-server-state gcontext))
+	   (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
+	   (i 0 (index+ i 1)))
+	  ((zerop bit)
+	   (incf-internal-timestamp server-state))
+	(declare (type gcontext-state server-state)
+		 (type gcmask bit)
+		 (type array-index i))
+	(when (oddp bit)
+	  (setf (svref server-state i) nil))))))
+
+(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
+			function plane-mask foreground background
+			line-width line-style cap-style join-style fill-style fill-rule
+			arc-mode tile stipple ts-x ts-y font subwindow-mode
+			exposures clip-x clip-y clip-mask clip-ordering
+			dash-offset dashes
+			(cache-p t)
+			&allow-other-keys)
+  ;; Only non-nil components are passed on in the request, but for effective caching
+  ;; assumptions have to be made about what the actual protocol defaults are.  For
+  ;; all gcontext components, a value of nil causes the default gcontext value to be
+  ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
+  ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
+  ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
+  ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
+  ;; component will have no effect unless the new value differs from the cached
+  ;; value.  Component changes (setfs and with-gcontext) are always deferred
+  ;; regardless of the cache mode, and sent over the protocol only when required by a
+  ;; local operation or by an explicit call to force-gcontext-changes.
+  (declare (type drawable drawable) ; Required to be non-null
+	   (type (or null boole-constant) function)
+	   (type (or null pixel) plane-mask foreground background)
+	   (type (or null card16) line-width dash-offset)
+	   (type (or null int16) ts-x ts-y clip-x clip-y)
+	   (type (or null (member :solid :dash :double-dash)) line-style)
+	   (type (or null (member :not-last :butt :round :projecting)) cap-style)
+	   (type (or null (member :miter :round :bevel)) join-style)
+	   (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
+	   (type (or null (member :even-odd :winding)) fill-rule)
+	   (type (or null (member :chord :pie-slice)) arc-mode)
+	   (type (or null pixmap) tile stipple)
+	   (type (or null fontable) font)
+	   (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
+	   (type (or null (member :on :off)) exposures)
+	   (type (or null (member :none) pixmap rect-seq) clip-mask)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
+	   (type (or null card8 sequence) dashes)
+	   (dynamic-extent options)
+	   (type boolean cache-p))
+  (declare (values gcontext))
+  (let* ((display (drawable-display drawable))
+	 (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
+	 (local-state (gcontext-local-state gcontext))
+	 (server-state (gcontext-server-state gcontext))
+	 (gcontextid (allocate-resource-id display gcontext 'gcontext)))
+    (declare (type display display)
+	     (type gcontext gcontext)
+	     (type resource-id gcontextid)
+	     (type gcontext-state local-state server-state))
+    (setf (gcontext-id gcontext) gcontextid)
+
+    (unless function (setf (gcontext-function gcontext) boole-1))
+    ;; using the depth of the drawable would be better, but ...
+    (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
+    (unless foreground (setf (gcontext-foreground gcontext) 0))
+    (unless background (setf (gcontext-background gcontext) 1))
+    (unless line-width (setf (gcontext-line-width gcontext) 0))
+    (unless line-style (setf (gcontext-line-style gcontext) :solid))
+    (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
+    (unless join-style (setf (gcontext-join-style gcontext) :miter))
+    (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
+    (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
+    (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
+    (unless ts-x (setf (gcontext-ts-x gcontext) 0))
+    (unless ts-y (setf (gcontext-ts-y gcontext) 0))
+    (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
+				 :clip-by-children))
+    (unless exposures (setf (gcontext-exposures gcontext) :on))
+    (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
+    (unless clip-x (setf (gcontext-clip-x gcontext) 0))
+    (unless clip-y (setf (gcontext-clip-y gcontext) 0))
+    (unless dashes (setf (gcontext-dashes gcontext) 4))
+    (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
+    ;; a bit kludgy, but ...
+    (replace server-state local-state)
+
+    (when function (setf (gcontext-function gcontext) function))
+    (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
+    (when foreground (setf (gcontext-foreground gcontext) foreground))
+    (when background (setf (gcontext-background gcontext) background))
+    (when line-width (setf (gcontext-line-width gcontext) line-width))
+    (when line-style (setf (gcontext-line-style gcontext) line-style))
+    (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
+    (when join-style (setf (gcontext-join-style gcontext) join-style))
+    (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
+    (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
+    (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
+    (when tile (setf (gcontext-tile gcontext) tile))
+    (when stipple (setf (gcontext-stipple gcontext) stipple))
+    (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
+    (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
+    (when font (setf (gcontext-font gcontext) font))
+    (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
+    (when exposures (setf (gcontext-exposures gcontext) exposures))
+    (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
+    (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
+    (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
+    (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
+    (when dashes (setf (gcontext-dashes gcontext) dashes))
+    
+    (setf (gcontext-internal-timestamp server-state) 1)
+    (setf (gcontext-internal-timestamp local-state) 1)
+    
+    (with-buffer-request (display *x-creategc*)
+      (resource-id gcontextid)
+      (drawable drawable)
+      (progn (do* ((i 0 (index+ i 1))
+		   (bit 1 (the xgcmask (ash bit 1)))
+		   (nbyte 16)
+		   (mask 0)
+		   (local (svref local-state i) (svref local-state i)))
+		 ((index>= i *gcontext-fast-change-length*)
+		  (card29-put 12 mask)
+		  (card16-put 2 (index-ash nbyte -2))
+		  (index-incf (buffer-boffset display) nbyte))
+	       (declare (type array-index i nbyte)
+			(type xgcmask bit)
+			(type gcmask mask)
+			(type (or null card32) local))
+	       (unless (eql local (the (or null card32) (svref server-state i)))
+		 (setf (svref server-state i) local)
+		 (card32-put nbyte local)
+		 (setq mask (the gcmask (logior mask bit)))
+		 (index-incf nbyte 4)))))
+
+    ;; Initialize extensions
+    (do ((extensions *gcontext-extensions* (cdr extensions))
+	 (i *gcontext-data-length* (index+ i 1)))
+	((endp extensions))
+      (declare (type list extensions)
+	       (type array-index i))
+      (setf (svref server-state i)
+	    (setf (svref local-state i)
+		  (gcontext-extension-default (car extensions)))))
+
+    ;; Set extension values
+    (do* ((option-list options (cddr option-list))
+	  (option (car option-list) (car option-list))
+	  (extension))
+	 ((endp option-list))
+      (declare (type list option-list))
+      (cond ((getf *gcontext-indexes* option))	; Gcontext field
+	    ((member option '(:drawable :clip-ordering :cache-p)))	; Optional parameter
+	    ((setq extension (find option *gcontext-extensions*
+				   :key #'gcontext-extension-name))
+	     (funcall (gcontext-extension-set-function extension)
+		      gcontext (second option-list)))
+	    (t (x-type-error option 'gcontext-key))))
+    gcontext)) 
+
+(defun copy-gcontext-components (src dst &rest keys)
+  (declare (type gcontext src dst)
+	   (dynamic-extent keys))
+  ;; you might ask why this isn't just a bunch of
+  ;;   (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
+  ;; the answer is that you can do that yourself if you want, what we are
+  ;; providing here is access to the protocol request, which will generally
+  ;; be more efficient (particularly for things like clip and dash lists).
+  (when keys
+    (let ((display (gcontext-display src))
+	  (mask 0))
+      (declare (type xgcmask mask))
+      (with-display (display)
+	(force-gcontext-changes-internal src)
+	(force-gcontext-changes-internal dst)
+	
+	;; collect entire mask and handle extensions
+	(dolist (key keys)
+	  (let ((i (getf *gcontext-indexes* key)))
+	    (declare (type (or null array-index) i))
+	    (if i
+		(setq mask (the xgcmask (logior mask
+						(the xgcmask (svref *gcontext-masks* i)))))
+	      (multiple-value-bind (extension index)
+		  (find key *gcontext-extensions* :key #'gcontext-extension-name)
+		(if extension
+		    (funcall (gcontext-extension-copy-function extension)
+			     src dst (svref (gcontext-local-state src)
+					    (index+ index *gcontext-data-length*)))
+		  (x-type-error key 'gcontext-key))))))
+	
+	(when (plusp mask)
+	  (do ((src-server-state (gcontext-server-state src))
+	       (dst-server-state (gcontext-server-state dst))
+	       (dst-local-state (gcontext-local-state dst))
+	       (bit mask (the xgcmask (ash bit -1)))
+	       (i 0 (index+ i 1)))
+	      ((zerop bit)
+	       (incf-internal-timestamp dst-server-state)
+	       (setf (gcontext-internal-timestamp dst-local-state) 0))
+	    (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
+		     (type xgcmask bit)
+		     (type array-index i))
+	    (when (oddp bit)
+	      (setf (svref dst-local-state i)
+		    (setf (svref dst-server-state i) (svref src-server-state i)))))
+	  (with-buffer-request (display *x-copygc*)
+	    (gcontext src dst)
+	    (card29 (xgcmask->gcmask mask))))))))
+
+(defun copy-gcontext (src dst)
+  (declare (type gcontext src dst))
+  ;; Copies all components.
+  (apply #'copy-gcontext-components src dst *gcontext-components*)
+  (do ((extensions *gcontext-extensions* (cdr extensions))
+       (i *gcontext-data-length* (index+ i 1)))
+      ((endp extensions))
+    (funcall (gcontext-extension-copy-function (car extensions))
+	     src dst (svref (gcontext-local-state src) i))))
+	   
+(defun free-gcontext (gcontext)
+  (declare (type gcontext gcontext))
+  (let ((display (gcontext-display gcontext)))
+    (with-buffer-request (display *x-freegc*)
+      (gcontext gcontext))
+    (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
+    (deallocate-gcontext-state (gcontext-server-state gcontext))
+    (deallocate-gcontext-state (gcontext-local-state gcontext))
+    nil))
+
+(defmacro define-gcontext-accessor (name &key default set-function copy-function)
+  ;; This will define a new gcontext accessor called NAME.
+  ;; Defines the gcontext-NAME accessor function and its defsetf.
+  ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
+  ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
+  ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
+  ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
+  ;; from create-gcontext, and force-gcontext-changes.
+  ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
+  ;; from copy-gcontext and copy-gcontext-components.
+  ;; The copy-function defaults to:
+  ;; (lambda (ignore dst-gc value)
+  ;;    (if value
+  ;;	    (,set-function dst-gc value)
+  ;;	  (error "Can't copy unknown GContext component ~a" ',name)))
+  (declare (type symbol name)
+	   (type t default)
+	   (type (function (gcontext t) t) set-function) ;; required
+	   (type (or null (function (gcontext gcontext t) t))
+		 copy-function))
+  (let* ((gc-name (intern (concatenate 'string
+				       (string 'gcontext-)
+				       (string name)))) ;; in current package
+	 (key-name (kintern name))
+	 (setfer (xintern "Set-" gc-name))
+	 (internal-set-function (xintern "Internal-Set-" gc-name))
+	 (internal-copy-function (xintern "Internal-Copy-" gc-name))
+	 (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
+    (unless copy-function
+      (setq copy-function
+	    `(lambda (src-gc dst-gc value)
+	       (declare (ignore src-gc))
+	       (if value
+		   (,set-function dst-gc value)
+		 (error "Can't copy unknown GContext component ~a" ',name)))))
+    `(progn
+       (eval-when (compile load eval)
+	 (defparameter ,internal-state-index
+		       (add-gcontext-extension ',key-name ,default ',internal-set-function
+					       ',internal-copy-function))
+	 ) ;; end eval-when
+       (defun ,gc-name (gcontext)
+	 (svref (gcontext-local-state gcontext) ,internal-state-index))
+       (defun ,setfer (gcontext new-value)
+	 (let ((local-state (gcontext-local-state gcontext)))
+	   (setf (gcontext-internal-timestamp local-state) 0)
+	   (setf (svref local-state ,internal-state-index) new-value)))
+       (defsetf ,gc-name ,setfer)
+       (defun ,internal-set-function (gcontext new-value)
+	 (,set-function gcontext new-value)
+	 (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
+	       (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
+		     new-value)))
+       (defun ,internal-copy-function (src-gc dst-gc new-value)
+	 (,copy-function src-gc dst-gc new-value)
+	 (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
+	       (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
+		     new-value)))
+       ',name)))
+
+;; GContext extension fields are treated in much the same way as normal GContext
+;; components.  The current value is stored in a slot of the gcontext-local-state,
+;; and the value known to the server is in a slot of the gcontext-server-state.
+;; The slot-number is defined by its position in the *gcontext-extensions* list.
+;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is 
+;; the extension component name) reflects this position.  The position within
+;; *gcontext-extensions* and the value of the special value are determined at
+;; LOAD time to facilitate merging of seperately compiled extension files.
+
+(defun add-gcontext-extension (name default-value set-function copy-function)
+  (declare (type symbol name)
+	   (type t default-value)
+	   (type (function (gcontext t) t) set-function)
+	   (type (function (gcontext gcontext t) t) copy-function))
+  (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
+		    (prog1 (length *gcontext-extensions*)
+			   (push nil *gcontext-extensions*)))))
+    (setf (nth number *gcontext-extensions*)
+	  (make-gcontext-extension :name name
+				   :default default-value
+				   :set-function set-function
+				   :copy-function copy-function))
+    (+ number *gcontext-data-length*)))
diff --git a/clx/generalock.lisp b/clx/generalock.lisp
new file mode 100644
index 000000000..0319ab599
--- /dev/null
+++ b/clx/generalock.lisp
@@ -0,0 +1,62 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*-
+
+(defflavor xlib::clx-lock () (simple-recursive-normal-lock)
+  (:init-keywords :flavor))
+
+(defwhopper (lock-internal xlib::clx-lock) (lock-argument)
+  (catch 'timeout
+    (continue-whopper lock-argument)))
+
+(defmethod (lock-block-internal xlib::clx-lock) (lock-argument)
+  (declare (dbg:locking-function describe-process-lock-for-debugger self))
+  (when (null waiter-queue)
+    (setf waiter-queue (make-scheduler-queue :name name))
+    (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name)))
+  (let ((process (lock-argument-process lock-argument)))
+    (unwind-protect
+	(progn
+	  (lock-map-over-conflicting-owners
+	    self lock-argument
+	    #'(lambda (other-lock-arg)
+		(add-promotion process lock-argument
+			       (lock-argument-process other-lock-arg) other-lock-arg)))
+	  (unless (timer-pending-p timer)
+	    (when (and (safe-to-use-timers %real-current-process)
+		       (not dbg:*debugger-might-have-system-problems*))
+	      (reset-timer-relative-timer-units timer *lock-timer-interval*)))
+	  (assert (store-conditional (locf latch) process nil))
+	  (sys:with-aborts-enabled (lock-latch)
+	    (let ((timeout (lock-argument-getf lock-argument :timeout nil)))
+	      (cond ((null timeout)
+		     (promotion-block waiter-queue name #'lock-lockable self lock-argument))
+		    ((and (plusp timeout)
+			  (using-resource (timer process-block-timers)
+			    ;; Yeah, we know about the internal representation
+			    ;; of timers here.
+			    (setf (car (timer-args timer)) %real-current-process)
+			    (with-scheduler-locked
+			      (reset-timer-relative timer timeout)
+			      (flet ((lock-lockable-or-timeout (timer lock lock-argument)
+				       (or (not (timer-pending-p timer))
+					   (lock-lockable lock lock-argument))))
+				(let ((priority (process-process-priority *current-process*)))
+				  (if (ldb-test %%scheduler-priority-preemption-field priority)
+				      (promotion-block waiter-queue name
+						       #'lock-lockable-or-timeout
+						       timer self lock-argument)
+				      ;; Change to preemptive priority so that when
+				      ;; unlock-internal wakes us up so we can have the lock,
+				      ;; we will really wake up right away
+				      (with-process-priority
+					  (dpb 1 %%scheduler-priority-preemption-field
+					       priority)
+					(promotion-block waiter-queue name
+						       #'lock-lockable-or-timeout
+						       timer self lock-argument)))))
+			      (lock-lockable self lock-argument)))))
+		    (t (throw 'timeout nil))))))
+      (unless (store-conditional (locf latch) nil process)
+	(lock-latch-wait-internal self))
+      (remove-promotions process lock-argument))))
+
+(compile-flavor-methods xlib::clx-lock)
diff --git a/clx/graphics.lisp b/clx/graphics.lisp
new file mode 100644
index 000000000..2f560888b
--- /dev/null
+++ b/clx/graphics.lisp
@@ -0,0 +1,460 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; CLX drawing requests
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  draw-point
+	  draw-points
+	  draw-line
+	  draw-lines
+	  draw-segments
+	  draw-rectangle
+	  draw-rectangles
+	  draw-arc
+	  draw-arcs
+	  put-raw-image
+	  get-raw-image))
+
+(defvar *inhibit-appending* nil)
+
+(defun draw-point (drawable gcontext x y)
+  ;; Should be clever about appending to existing buffered protocol request.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y))
+  (let ((display (drawable-display drawable)))
+    (declare (type display display))
+    (with-display (display)
+      (force-gcontext-changes-internal gcontext)
+      (with-buffer-output (display :length *requestsize*)
+	(let* ((last-request-byte (display-last-request display))
+	       (current-boffset buffer-boffset))
+	  ;; To append or not append, that is the question
+	  (if (and (not *inhibit-appending*)
+		   last-request-byte
+		   ;; Same request?
+		   (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
+		   (progn ;; Set buffer pointers to last request
+		     (set-buffer-offset last-request-byte)
+		     ;; same drawable and gcontext?
+		     (or (compare-request (4)
+			   (data 0)
+			   (drawable drawable)
+			   (gcontext gcontext))
+			 (progn ;; If failed, reset buffer pointers
+			   (set-buffer-offset current-boffset)
+			   nil))))
+	      ;; Append request
+	      (progn
+		;; Set new request length		
+		(card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
+						   -2)))
+		(set-buffer-offset current-boffset)
+		(put-items (0)			; Insert new point
+		  (int16 x y))
+		(setf (display-boffset display) (index+ buffer-boffset 4)))
+	    ;; New Request
+	    (progn
+	      (put-items (4)
+		(code *x-polypoint*)
+		(data 0) ;; Relative-p false
+		(length 4)
+		(drawable drawable)
+		(gcontext gcontext)
+		(int16 x y))
+	      (buffer-new-request-number display)
+	      (setf (buffer-last-request display) buffer-boffset)
+	      (setf (display-boffset display) (index+ buffer-boffset 16)))))))
+    (display-invoke-after-function display))) 
+
+
+(defun draw-points (drawable gcontext points &optional relative-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type sequence points)		;(repeat-seq (integer x) (integer y))
+	   (type boolean relative-p))
+  (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
+    ((data boolean) relative-p)
+    (drawable drawable)
+    (gcontext gcontext)
+    ((sequence :format int16) points)))
+
+(defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
+  ;; Should be clever about appending to existing buffered protocol request.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x1 y1 x2 y2)
+	   (type boolean relative-p))
+  (let ((display (drawable-display drawable)))
+    (declare (type display display))
+    (when relative-p
+      (incf x2 x1)
+      (incf y2 y1))
+    (with-display (display)
+      (force-gcontext-changes-internal gcontext)
+      (with-buffer-output (display :length *requestsize*)
+	(let* ((last-request-byte (display-last-request display))
+	       (current-boffset buffer-boffset))
+	  ;; To append or not append, that is the question
+	  (if (and (not *inhibit-appending*)
+		   last-request-byte
+		   ;; Same request?
+		   (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
+		   (progn ;; Set buffer pointers to last request
+		     (set-buffer-offset last-request-byte)
+		     ;; same drawable and gcontext?
+		     (or (compare-request (4)
+			   (drawable drawable)
+			   (gcontext gcontext))
+			 (progn ;; If failed, reset buffer pointers
+			   (set-buffer-offset current-boffset)
+			   nil))))
+	      ;; Append request
+	      (progn
+		;; Set new request length
+		(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
+						   -2)))
+		(set-buffer-offset current-boffset)
+		(put-items (0)			; Insert new point
+		  (int16 x1 y1 x2 y2))
+		(setf (display-boffset display) (index+ buffer-boffset 8)))
+	    ;; New Request
+	    (progn
+	      (put-items (4)
+		(code *x-polysegment*)
+		(length 5)
+		(drawable drawable)
+		(gcontext gcontext)
+		(int16 x1 y1 x2 y2))
+	      (buffer-new-request-number display)
+	      (setf (buffer-last-request display) buffer-boffset)
+	      (setf (display-boffset display) (index+ buffer-boffset 20)))))))
+    (display-invoke-after-function display))) 
+
+(defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type sequence points) ;(repeat-seq (integer x) (integer y))
+	   (type boolean relative-p fill-p)
+	   (type (member :complex :non-convex :convex) shape))
+  (if fill-p
+      (fill-polygon drawable gcontext points relative-p shape)
+    (with-buffer-request ((drawable-display drawable)  *x-polyline* :gc-force gcontext)
+      ((data boolean) relative-p)
+      (drawable drawable)
+      (gcontext gcontext)
+      ((sequence :format int16) points))))
+
+;; Internal function called from DRAW-LINES
+(defun fill-polygon (drawable gcontext points relative-p shape)
+  ;; This is clever about appending to previous requests.  Should it be?
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type sequence points)		;(repeat-seq (integer x) (integer y))
+	   (type boolean relative-p)
+	   (type (member :complex :non-convex :convex) shape))
+  (with-buffer-request ((drawable-display drawable)  *x-fillpoly* :gc-force gcontext)
+    (drawable drawable)
+    (gcontext gcontext)
+    ((member8 :complex :non-convex :convex) shape)
+    (boolean relative-p)
+    ((sequence :format int16) points)))
+
+(defun draw-segments (drawable gcontext segments)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
+	   (type sequence segments)) 
+  (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
+    (drawable drawable)
+    (gcontext gcontext)
+    ((sequence :format int16) segments)))
+
+(defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
+  ;; Should be clever about appending to existing buffered protocol request.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type boolean fill-p))
+  (let ((display (drawable-display drawable))
+	(request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
+    (declare (type display display)
+	     (type card16 request))
+    (with-display (display)
+      (force-gcontext-changes-internal gcontext)
+      (with-buffer-output (display :length *requestsize*)
+	(let* ((last-request-byte (display-last-request display))
+	       (current-boffset buffer-boffset))
+	  ;; To append or not append, that is the question
+	  (if (and (not *inhibit-appending*)
+		   last-request-byte
+		   ;; Same request?
+		   (= (aref-card8 buffer-bbuf last-request-byte) request)
+		   (progn ;; Set buffer pointers to last request
+		     (set-buffer-offset last-request-byte)
+		     ;; same drawable and gcontext?
+		     (or (compare-request (4)
+			   (drawable drawable)
+			   (gcontext gcontext))
+			 (progn ;; If failed, reset buffer pointers
+			   (set-buffer-offset current-boffset)
+			   nil))))
+	      ;; Append request
+	      (progn
+		;; Set new request length
+		(card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
+						   -2)))
+		(set-buffer-offset current-boffset)
+		(put-items (0)			; Insert new point
+		  (int16 x y)
+		  (card16 width height))
+		(setf (display-boffset display) (index+ buffer-boffset 8)))
+	    ;; New Request
+	    (progn
+	      (put-items (4)
+		(code request)
+		(length 5)
+		(drawable drawable)
+		(gcontext gcontext)
+		(int16 x y)
+		(card16 width height))
+	      (buffer-new-request-number display)
+	      (setf (buffer-last-request display) buffer-boffset)
+	      (setf (display-boffset display) (index+ buffer-boffset 20)))))))
+    (display-invoke-after-function display))) 
+
+(defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
+	   (type sequence rectangles)
+	   (type boolean fill-p))
+  (with-buffer-request ((drawable-display drawable)
+			(if fill-p *x-polyfillrectangle* *x-polyrectangle*)
+			:gc-force gcontext)
+    (drawable drawable)
+    (gcontext gcontext)
+    ((sequence :format int16) rectangles)))
+
+(defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
+  ;; Should be clever about appending to existing buffered protocol request.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type angle angle1 angle2)
+	   (type boolean fill-p))
+  (let ((display (drawable-display drawable))
+	(request (if fill-p *x-polyfillarc* *x-polyarc*)))
+    (declare (type display display)
+	     (type card16 request))
+    (with-display (display)
+      (force-gcontext-changes-internal gcontext)
+      (with-buffer-output (display :length *requestsize*)
+	(let* ((last-request-byte (display-last-request display))
+	       (current-boffset buffer-boffset))
+	  ;; To append or not append, that is the question
+	  (if (and (not *inhibit-appending*)
+		   last-request-byte
+		   ;; Same request?
+		   (= (aref-card8 buffer-bbuf last-request-byte) request)
+		   (progn ;; Set buffer pointers to last request
+		     (set-buffer-offset last-request-byte)
+		     ;; same drawable and gcontext?
+		     (or (compare-request (4)
+			   (drawable drawable)
+			   (gcontext gcontext))
+			 (progn ;; If failed, reset buffer pointers
+			   (set-buffer-offset current-boffset)
+			   nil))))
+	      ;; Append request
+	      (progn
+		;; Set new request length		
+		(card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
+						   -2)))
+		(set-buffer-offset current-boffset)
+		(put-items (0)			; Insert new point
+		  (int16 x y)
+		  (card16 width height)
+		  (angle angle1 angle2))
+		(setf (display-boffset display) (index+ buffer-boffset 12)))
+	    ;; New Request
+	    (progn
+	      (put-items (4)
+		(code request)
+		(length 6)
+		(drawable drawable)
+		(gcontext gcontext)
+		(int16 x y)
+		(card16 width height)
+		(angle angle1 angle2))
+	      (buffer-new-request-number display)
+	      (setf (buffer-last-request display) buffer-boffset)
+	      (setf (display-boffset display) (index+ buffer-boffset 24)))))))
+    (display-invoke-after-function display))) 
+
+(defun draw-arcs-list (drawable gcontext arcs &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type list arcs) 
+	   (type boolean fill-p))
+  (let* ((display (drawable-display drawable))
+	 (limit (index- (buffer-size display) 12))
+	 (length (length arcs))
+	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
+    (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
+      (drawable drawable)
+      (gcontext gcontext)
+      (progn
+	(card16-put 2 (index+ (index-ash length -1) 3))	; Set request length (in words)
+	(set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
+	(do ((arc arcs))
+	    ((endp arc)
+	     (setf (buffer-boffset display) buffer-boffset))
+	  ;; Make sure there's room
+	  (when (index>= buffer-boffset limit)
+	    (setf (buffer-boffset display) buffer-boffset)
+	    (buffer-flush display)
+	    (set-buffer-offset (buffer-boffset display)))
+	  (int16-put  0 (pop arc))
+	  (int16-put  2 (pop arc))
+	  (card16-put 4 (pop arc))
+	  (card16-put 6 (pop arc))
+	  (angle-put  8 (pop arc))
+	  (angle-put 10 (pop arc))
+	  (set-buffer-offset (index+ buffer-boffset 12)))))))
+
+(defun draw-arcs-vector (drawable gcontext arcs &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type vector arcs) 
+	   (type boolean fill-p))
+  (let* ((display (drawable-display drawable))
+	 (limit (index- (buffer-size display) 12))
+	 (length (length arcs))
+	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
+    (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
+      (drawable drawable)
+      (gcontext gcontext)
+      (progn
+	(card16-put 2 (index+ (index-ash length -1) 3))	; Set request length (in words)
+	(set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
+	(do ((n 0 (index+ n 6))
+	     (length (length arcs)))
+	    ((index>= n length)
+	     (setf (buffer-boffset display) buffer-boffset))
+	  ;; Make sure there's room
+	  (when (index>= buffer-boffset limit)
+	    (setf (buffer-boffset display) buffer-boffset)
+	    (buffer-flush display)
+	    (set-buffer-offset (buffer-boffset display)))
+	  (int16-put  0 (aref arcs (index+ n 0)))
+	  (int16-put  2 (aref arcs (index+ n 1)))
+	  (card16-put 4 (aref arcs (index+ n 2)))
+	  (card16-put 6 (aref arcs (index+ n 3)))
+	  (angle-put  8 (aref arcs (index+ n 4)))
+	  (angle-put 10 (aref arcs (index+ n 5)))
+	  (set-buffer-offset (index+ buffer-boffset 12)))))))
+
+(defun draw-arcs (drawable gcontext arcs &optional fill-p)
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type sequence arcs) 
+	   (type boolean fill-p))
+  (etypecase arcs
+    (list (draw-arcs-list drawable gcontext arcs fill-p))
+    (vector (draw-arcs-vector drawable gcontext arcs fill-p))))
+
+;; The following image routines are bare minimum.  It may be useful to define
+;; some form of "image" object to hide representation details and format
+;; conversions.  It also may be useful to provide stream-oriented interfaces
+;; for reading and writing the data.
+
+(defun put-raw-image (drawable gcontext data &key
+		      (start 0)
+		      (depth (required-arg depth))
+		      (x (required-arg x))
+		      (y (required-arg y))
+		      (width (required-arg width))
+		      (height (required-arg height))
+		      (left-pad 0)
+		      (format (required-arg format)))
+  ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
+  ;; for transmission; the caller is responsible for all byte and bit swapping and
+  ;; compaction.  Start is the starting index in data; the end is computed from the
+  ;; other arguments.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type sequence data) ; Sequence of integers
+	   (type array-index start)
+	   (type card8 depth left-pad) ;; required
+	   (type int16 x y) ;; required
+	   (type card16 width height) ;; required
+	   (type (member :bitmap :xy-pixmap :z-pixmap) format))
+  (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
+    ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
+    (drawable drawable)
+    (gcontext gcontext)
+    (card16 width height)
+    (int16 x y)
+    (card8 left-pad depth)
+    (pad16 nil)
+    ((sequence :format card8 :start start) data)))
+
+(defun get-raw-image (drawable &key
+		      data
+		      (start 0)
+		      (x (required-arg x))
+		      (y (required-arg y))
+		      (width (required-arg width))
+		      (height (required-arg height))
+		      (plane-mask #xffffffff)
+		      (format (required-arg format))
+		      (result-type '(vector card8)))
+  ;; If data is given, it is modified in place (and returned), otherwise a new sequence
+  ;; is created and returned, with a size computed from the other arguments and the
+  ;; returned depth.  The sequence is filled with 8-bit quantities, in transmission
+  ;; format; the caller is responsible for any byte and bit swapping and compaction
+  ;; required for further local use.
+  (declare (type drawable drawable)
+	   (type (or null sequence) data) ;; sequence of integers
+	   (type int16 x y) ;; required
+	   (type card16 width height) ;; required
+	   (type array-index start)
+	   (type pixel plane-mask)
+	   (type (member :xy-pixmap :z-pixmap) format))
+  (declare (values (sequence integer) depth visual-info))
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
+	 (((data (member error :xy-pixmap :z-pixmap)) format)
+	  (drawable drawable)
+	  (int16 x y)
+	  (card16 width height)
+	  (card32 plane-mask))
+      (let ((depth (card8-get 1))
+	    (length (* 4 (card32-get 4)))
+	    (visual (resource-id-get 8)))
+	(values (sequence-get :result-type result-type :format card8
+			      :length length :start start :data data
+			      :index *replysize*)
+		depth
+		(visual-info display visual))))))
diff --git a/clx/image.lisp b/clx/image.lisp
new file mode 100644
index 000000000..152af53f8
--- /dev/null
+++ b/clx/image.lisp
@@ -0,0 +1,2697 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;;; CLX Image functions
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(bitmap
+	  pixarray 
+	  image
+	  image-width
+	  image-height
+	  image-depth
+	  image-plist
+	  image-name
+	  image-x-hot
+	  image-y-hot
+	  image-red-mask
+	  image-blue-mask
+	  image-green-mask
+	  image-x
+	  image-xy
+	  image-z
+	  image-x-p
+	  image-xy-p
+	  image-z-p
+	  image-xy-bitmap-list
+	  image-z-bits-per-pixel
+	  image-z-pixarray
+	  create-image
+	  get-image
+	  put-image
+	  copy-image
+	  read-bitmap-file
+	  write-bitmap-file
+	  bitmap-image
+	  image-pixmap))
+
+(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil))
+  ;; Public structure
+  (width 0 :type card16 :read-only t)
+  (height 0 :type card16 :read-only t)
+  (depth 1 :type card8 :read-only t)
+  (plist nil :type list))
+
+;; Image-Plist accessors:
+(defmacro image-name (image) `(getf (image-plist ,image) :name))
+(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot))
+(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot))
+(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask))
+(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask))
+(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask))
+
+(defun print-image (image stream depth)
+  (declare (type image image)
+	   (ignore depth))
+  (print-unreadable-object (image stream :type t)
+    (when (image-name image)
+      (princ (image-name image) stream)
+      (princ " " stream))
+    (prin1 (image-width image) stream)
+    (princ "x" stream)
+    (prin1 (image-height image) stream)
+    (princ "x" stream)
+    (prin1 (image-depth image) stream)))
+
+(defconstant *empty-data-x* #.(make-sequence '(array card8 (*)) 0))
+
+(defconstant *empty-data-z*
+	     #.(make-array '(0 0) :element-type 'pixarray-1-element-type))
+
+(def-clx-class (image-x (:include image) (:copier nil)
+			(:print-function print-image))
+  ;; Use this format for shoveling image data
+  ;; Private structure. Accessors for these NOT exported.
+  (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
+  (bytes-per-line 0 :type card16)
+  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
+  (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean)	; Bit order
+  (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean)	; Byte order
+  (data *empty-data-x* :type (array card8 (*)))			; row-major
+  (unit *image-unit* :type (member 8 16 32))			; Bitmap unit
+  (pad *image-pad* :type (member 8 16 32))			; Scanline pad
+  (left-pad 0 :type card8))					; Left pad
+
+(def-clx-class (image-xy (:include image) (:copier nil)
+			 (:print-function print-image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bitmap-list nil :type list)) ;; list of bitmaps
+
+(def-clx-class (image-z (:include image) (:copier nil)
+			(:print-function print-image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
+  (pixarray *empty-data-z* :type pixarray))
+
+(defun create-image (&key width height depth
+		     (data (required-arg data))
+		     plist name x-hot y-hot
+		     red-mask blue-mask green-mask
+		     bits-per-pixel format bytes-per-line
+		     (byte-lsb-first-p *image-byte-lsb-first-p*)
+		     (bit-lsb-first-p *image-bit-lsb-first-p*)
+		     unit pad left-pad)
+  ;; Returns an image-x image-xy or image-z structure, depending on the
+  ;; type of the :DATA parameter.
+  (declare
+    (type (or null card16) width height)	; Required
+    (type (or null card8) depth)		; Defualts to 1
+    (type (or buffer-bytes			; Returns image-x
+	      list				; Returns image-xy
+	      pixarray) data)			; Returns image-z
+    (type list plist)
+    (type (or null stringable) name)
+    (type (or null card16) x-hot y-hot)
+    (type (or null pixel) red-mask blue-mask green-mask)
+    (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
+    
+    ;; The following parameters are ignored for image-xy and image-z:
+    (type (or null (member :bitmap :xy-pixmap :z-pixmap))
+	  format)				; defaults to :z-pixmap
+    (type (or null card16) bytes-per-line)
+    (type boolean byte-lsb-first-p bit-lsb-first-p)
+    (type (or null (member 8 16 32)) unit pad)
+    (type (or null card8) left-pad))
+  (declare (values image))
+  (let ((image
+	  (etypecase data
+	    (buffer-bytes			; image-x
+	      (let ((data data))
+		(declare (type buffer-bytes data))
+		(unless depth (setq depth (or bits-per-pixel 1)))
+		(unless format
+		  (setq format (if (= depth 1) :xy-pixmap :z-pixmap)))
+		(unless bits-per-pixel
+		  (setq bits-per-pixel
+			(cond ((eq format :xy-pixmap) 1)
+			      ((index> depth 24) 32)
+			      ((index> depth 16) 24)
+			      ((index> depth 8)  16)
+			      ((index> depth 4)   8)
+			      ((index> depth 1)   4)
+			      (t                  1))))
+		(unless width (required-arg width))
+		(unless height (required-arg height))
+		(unless bytes-per-line
+		  (let* ((pad (or pad 8))
+			 (bits-per-line (index* width bits-per-pixel))
+			 (padded-bits-per-line
+			   (index* (index-ceiling bits-per-line pad) pad)))
+		    (declare (type array-index pad bits-per-line
+				   padded-bits-per-line))
+		    (setq bytes-per-line (index-ceiling padded-bits-per-line 8))))
+		(unless unit (setq unit *image-unit*))
+		(unless pad
+		  (setq pad
+			(dolist (pad '(32 16 8))
+			  (when (and (index<= pad *image-pad*)
+				     (zerop
+				       (index-mod
+					 (index* bytes-per-line 8) pad)))
+			    (return pad)))))
+		(unless left-pad (setq left-pad 0))
+		(make-image-x
+		  :width width :height height :depth depth :plist plist
+		  :format format :data data
+		  :bits-per-pixel bits-per-pixel 
+		  :bytes-per-line bytes-per-line
+		  :byte-lsb-first-p byte-lsb-first-p
+		  :bit-lsb-first-p bit-lsb-first-p
+		  :unit unit :pad pad :left-pad left-pad)))
+	    (list				; image-xy
+	      (let ((data data))
+		(declare (type list data))
+		(unless depth (setq depth (length data)))
+		(when data
+		  (unless width (setq width (array-dimension (car data) 1)))
+		  (unless height (setq height (array-dimension (car data) 0))))
+		(make-image-xy
+		  :width width :height height :plist plist :depth depth
+		  :bitmap-list data)))
+	    (pixarray				; image-z
+	      (let ((data data))
+		(declare (type pixarray data))
+		(unless width (setq width (array-dimension data 1)))
+		(unless height (setq height (array-dimension data 0)))
+		(unless bits-per-pixel
+		  (setq bits-per-pixel
+			(etypecase data
+			  (pixarray-32 32)
+			  (pixarray-24 24)
+			  (pixarray-16 16)
+			  (pixarray-8   8)
+			  (pixarray-4   4)
+			  (pixarray-1   1)))))
+	      (unless depth (setq depth bits-per-pixel))
+	      (make-image-z
+		:width width :height height :depth depth :plist plist
+		:bits-per-pixel bits-per-pixel :pixarray data)))))
+    (declare (type image image))
+    (when name (setf (image-name image) name))
+    (when x-hot (setf (image-x-hot image) x-hot))
+    (when y-hot (setf (image-y-hot image) y-hot))
+    (when red-mask (setf (image-red-mask image) red-mask))
+    (when blue-mask (setf (image-blue-mask image) blue-mask))
+    (when green-mask (setf (image-green-mask image) green-mask))
+    image))
+
+;;;-----------------------------------------------------------------------------
+;;; Swapping stuff
+
+(defun image-noswap
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p)
+	   (ignore lsb-first-p))
+  #.(declare-buffun)
+  (if (index= srcinc destinc)
+      (buffer-replace
+	dest src destoff
+	(index+ destoff (index* srcinc (index1- height)) srclen)
+	srcoff)
+    (do* ((h height (index1- h))
+	  (srcstart srcoff (index+ srcstart srcinc))
+	  (deststart destoff (index+ deststart destinc))
+	  (destend (index+ deststart srclen) (index+ deststart srclen)))
+	 ((index-zerop h))
+      (declare (type array-index srcstart deststart destend)
+	       (type card16 h))
+      (buffer-replace dest src deststart destend srcstart))))
+
+(defun image-swap-two-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 2) 2))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 2)
+	  (if lsb-first-p
+	      (setf (aref dest (index1+ (index+ deststart length)))
+		    (the card8 (aref src (index+ srcstart length))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index1+ (index+ srcstart length)))))))
+	(do ((i length (index- i 2))
+	     (srcidx srcstart (index+ srcidx 2))
+	     (destidx deststart (index+ destidx 2)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-three-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 3) 3))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 3)
+	  (when (index= (index- srclen length) 2)
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (if lsb-first-p
+	      (setf (aref dest (index+ deststart length 2))
+		    (the card8 (aref src (index+ srcstart length))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 2))))))
+	(do ((i length (index- i 3))
+	     (srcidx srcstart (index+ srcidx 3))
+	     (destidx deststart (index+ destidx 3)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-four-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 4) 4))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 4)
+	  (unless lsb-first-p
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 3)))))
+	  (when (if lsb-first-p
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 2)))))
+	  (when (if (null lsb-first-p)
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 2))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (when lsb-first-p
+	    (setf (aref dest (index+ deststart length 3))
+		  (the card8 (aref src (index+ srcstart length))))))
+	(do ((i length (index- i 4))
+	     (srcidx srcstart (index+ srcidx 4))
+	     (destidx deststart (index+ destidx 4)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 3))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index+ destidx 3))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-words
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 4) 4))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 4)
+	  (unless lsb-first-p
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 3)))))
+	  (when (if lsb-first-p
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 2)))))
+	  (when (if (null lsb-first-p)
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 3))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (when lsb-first-p
+	    (setf (aref dest (index+ deststart length 2))
+		  (the card8 (aref src (index+ srcstart length))))))
+	(do ((i length (index- i 4))
+	     (srcidx srcstart (index+ srcidx 4))
+	     (destidx deststart (index+ destidx 4)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index+ srcidx 3))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src srcidx)))
+	  (setf (aref dest (index+ destidx 3))
+		(the card8 (aref src (index1+ srcidx)))))))))
+
+(defun image-swap-nibbles
+       (src dest srcoff destoff srclen srcinc destinc height)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index srcstart deststart)
+		 (type card16 h))
+	(do ((i srclen (index1- i))
+	     (srcidx srcstart (index1+ srcidx))
+	     (destidx deststart (index1+ destidx)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8
+		     (let ((byte (aref src srcidx)))
+		       (declare (type card8 byte))
+		       (dpb (the card4 (ldb (byte 4 0) byte))
+			    (byte 4 4)
+			    (the card4 (ldb (byte 4 4) byte)))))))))))
+
+(defun image-swap-nibbles-left
+       (src dest srcoff destoff srclen srcinc destinc height)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index srcstart deststart)
+		 (type card16 h))
+	(do ((i srclen (index1- i))
+	     (srcidx srcstart (index1+ srcidx))
+	     (destidx deststart (index1+ destidx)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8
+		     (let ((byte1 (aref src srcidx))
+			   (byte2 (aref src (index1+ srcidx))))
+		       (declare (type card8 byte1 byte2))
+		       (dpb (the card4 (ldb (byte 4 0) byte1))
+			    (byte 4 4)
+			    (the card4 (ldb (byte 4 4) byte2)))))))))))
+
+(defconstant
+  *image-byte-reverse*
+  '#.(coerce
+       '#(
+	  0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
+	  8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
+	  4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
+	  12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
+	  2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
+	  10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
+	  6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
+	  14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
+	  1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
+	  9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
+	  5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
+	  13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
+	  3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
+	  11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
+	  7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
+	  15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
+       '(vector card8)))
+
+(defun image-swap-bits
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p)
+	   (ignore lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index srcstart deststart)
+		       (type card16 h))
+	      (do ((i srclen (index1- i))
+		   (srcidx srcstart (index1+ srcidx))
+		   (destidx deststart (index1+ destidx)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx) (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-two-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 2) 2))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 2)
+		(if lsb-first-p
+		    (setf (aref dest (index1+ (index+ deststart length)))
+			  (br (aref src (index+ srcstart length))))
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index1+ (index+ srcstart length)))))))
+	      (do ((i length (index- i 2))
+		   (srcidx srcstart (index+ srcidx 2))
+		   (destidx deststart (index+ destidx 2)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index1+ srcidx))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-four-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 4) 4))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 4)
+		(unless lsb-first-p
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index+ srcstart length 3)))))
+		(when (if lsb-first-p
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 1))
+			(br (aref src (index+ srcstart length 2)))))
+		(when (if (null lsb-first-p)
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 2))
+			(br (aref src (index+ srcstart length 1)))))
+		(when lsb-first-p
+		  (setf (aref dest (index+ deststart length 3))
+			(br (aref src (index+ srcstart length))))))
+	      (do ((i length (index- i 4))
+		   (srcidx srcstart (index+ srcidx 4))
+		   (destidx deststart (index+ destidx 4)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index+ srcidx 3))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src (index+ srcidx 2))))
+		(setf (aref dest (index+ destidx 2))
+		      (br (aref src (index1+ srcidx))))
+		(setf (aref dest (index+ destidx 3))
+		      (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-words
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 4) 4))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 4)
+		(unless lsb-first-p
+		  (setf (aref dest (index+ deststart length 1))
+			(br (aref src (index+ srcstart length 3)))))
+		(when (if lsb-first-p
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index+ srcstart length 2)))))
+		(when (if (null lsb-first-p)
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 3))
+			(br (aref src (index+ srcstart length 1)))))
+		(when lsb-first-p
+		  (setf (aref dest (index+ deststart length 2))
+			(br (aref src (index+ srcstart length))))))
+	      (do ((i length (index- i 4))
+		   (srcidx srcstart (index+ srcidx 4))
+		   (destidx deststart (index+ destidx 4)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index+ srcidx 2))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src (index+ srcidx 3))))
+		(setf (aref dest (index+ destidx 2))
+		      (br (aref src srcidx)))
+		(setf (aref dest (index+ destidx 3))
+		      (br (aref src (index1+ srcidx))))))))))))
+
+;;; The following table gives the bit ordering within bytes (when accessed
+;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
+;;; 31, where bit 0 should be leftmost on the display.  For a given byte
+;;; labelled A-B, A is for the most significant bit of the byte, and B is
+;;; for the least significant bit.
+;;; 
+;;; legend:
+;;; 	1   scanline-unit = 8
+;;; 	2   scanline-unit = 16
+;;; 	4   scanline-unit = 32
+;;; 	M   byte-order = MostSignificant
+;;; 	L   byte-order = LeastSignificant
+;;; 	m   bit-order = MostSignificant
+;;; 	l   bit-order = LeastSignificant
+;;; 
+;;; 
+;;; format	ordering
+;;; 
+;;; 1Mm	00-07 08-15 16-23 24-31
+;;; 2Mm	00-07 08-15 16-23 24-31
+;;; 4Mm	00-07 08-15 16-23 24-31
+;;; 1Ml	07-00 15-08 23-16 31-24
+;;; 2Ml	15-08 07-00 31-24 23-16
+;;; 4Ml	31-24 23-16 15-08 07-00
+;;; 1Lm	00-07 08-15 16-23 24-31
+;;; 2Lm	08-15 00-07 24-31 16-23
+;;; 4Lm	24-31 16-23 08-15 00-07
+;;; 1Ll	07-00 15-08 23-16 31-24
+;;; 2Ll	07-00 15-08 23-16 31-24
+;;; 4Ll	07-00 15-08 23-16 31-24
+;;; 
+;;; 
+;;; The following table gives the required conversion between any two
+;;; formats.  It is based strictly on the table above.  If you believe one,
+;;; you should believe the other.
+;;; 
+;;; legend:
+;;; 	n   no changes
+;;; 	s   reverse 8-bit units within 16-bit units
+;;; 	l   reverse 8-bit units within 32-bit units
+;;; 	w   reverse 16-bit units within 32-bit units
+;;; 	r   reverse bits within 8-bit units
+;;; 	sr  s+R
+;;; 	lr  l+R
+;;; 	wr  w+R
+
+(defconstant 
+  *image-swap-function*
+  '#.(make-array
+       '(12 12) :initial-contents
+       (let ((n  'image-noswap)
+	     (s  'image-swap-two-bytes)
+	     (l  'image-swap-four-bytes)
+	     (w  'image-swap-words)
+	     (r  'image-swap-bits)
+	     (sr 'image-swap-bits-and-two-bytes)
+	     (lr 'image-swap-bits-and-four-bytes)
+	     (wr 'image-swap-bits-and-words))
+	 (list #|             1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll  |#
+	       (list #| 1Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 2Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 4Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 1Ml |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 2Ml |# sr  sr  sr  s   n   w   sr  r   wr  s   s   s )
+	       (list #| 4Ml |# lr  lr  lr  l   w   n   lr  wr  r   l   l   l )
+	       (list #| 1Lm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 2Lm |# s   s   s   sr  r   wr  s   n   w   sr  sr  sr)
+	       (list #| 4Lm |# l   l   l   lr  wr  r   l   w   n   lr  lr  lr)
+	       (list #| 1Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 2Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 4Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )))))
+
+;;; Of course, the table above is a lie.  We also need to factor in the
+;;; order of the source data to cope with swapping half of a unit at the
+;;; end of a scanline, since we are trying to avoid de-ref'ing off the
+;;; end of the source.
+;;;
+;;; Defines whether the first half of a unit has the first half of the data
+
+(defconstant
+  *image-swap-lsb-first-p*
+  '#.(make-array
+       12 :initial-contents
+       (list t   #| 1mm |#
+	     t   #| 2mm |#
+	     t   #| 4mm |#
+	     t   #| 1ml |#
+	     nil #| 2ml |#
+	     nil #| 4ml |#
+	     t   #| 1lm |#
+	     nil #| 2lm |#
+	     nil #| 4lm |#
+	     t   #| 1ll |#
+	     t   #| 2ll |#
+	     t   #| 4ll |#
+	     )))
+
+(defun image-swap-function
+       (from-bitmap-unit from-bitmap-byte-lsb-first-p
+	from-bitmap-bit-lsb-first-p to-bitmap-unit
+	to-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p)
+  (declare (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-bitmap-bit-lsb-first-p
+		 from-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p
+		 to-bitmap-byte-lsb-first-p)
+	   (values function lsb-first-p))
+  (let ((from-index
+	  (index+
+	    (ecase from-bitmap-unit (32 2) (16 1) (8 0))
+	    (if from-bitmap-bit-lsb-first-p 3 0)
+	    (if from-bitmap-byte-lsb-first-p 6 0))))
+    (values
+      (aref *image-swap-function* from-index
+	    (index+
+	      (ecase to-bitmap-unit (32 2) (16 1) (8 0))
+	      (if to-bitmap-bit-lsb-first-p 3 0)
+	      (if to-bitmap-byte-lsb-first-p 6 0)))
+      (aref *image-swap-lsb-first-p* from-index))))
+
+(defun image-swap-xy
+       (src dest srcoff destoff srclen srcinc destinc height
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (multiple-value-bind (function lsb-first-p)
+      (image-swap-function
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+    (declare (type symbol function)
+	     (type boolean lsb-first-p))
+    (funcall function src dest srcoff destoff srclen srcinc destinc height
+	     lsb-first-p)))
+
+(defun image-swap-z
+       (src dest srcoff destoff srclen srcinc destinc height
+	bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type card16 height)
+	   (type boolean from-byte-lsb-first-p to-byte-lsb-first-p))
+  (cond ((or (eq from-byte-lsb-first-p to-byte-lsb-first-p)
+	     (= bits-per-pixel 8))
+	 (image-noswap
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 32)
+	 (image-swap-four-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 24)
+	 (image-swap-three-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 16)
+	 (image-swap-two-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	(t
+	 (image-swap-nibbles
+	   src dest srcoff destoff srclen srcinc destinc height))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; GET-IMAGE
+
+(defun read-pixarray-1 (buffer-bbuf index array x y width height  
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 8))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-bits (index-mod (index- x) 8))
+	  (right-bits (index-mod (index- width left-bits) 8))
+	  (middle-bits (index- width left-bits right-bits))
+	  (middle-bytes (index-floor middle-bits 8)))
+	 ((index>= y height))
+      (declare (type array-index start y
+		     left-bits right-bits middle-bits middle-bytes))
+      (cond ((index< middle-bits 0)
+	     (let ((byte (aref buffer-bbuf (index1- start)))
+		   (x left-bits))
+	       (declare (type card8 byte)
+			(type array-index x))
+	       (when (index> right-bits 6)
+		 (setf (aref array y (index- x 1))
+		       (read-image-load-byte 1 7 byte)))
+	       (when (and (index> left-bits 1)
+			  (index> right-bits 5))
+		 (setf (aref array y (index- x 2))
+		       (read-image-load-byte 1 6 byte)))
+	       (when (and (index> left-bits 2)
+			  (index> right-bits 4))
+		 (setf (aref array y (index- x 3))
+		       (read-image-load-byte 1 5 byte)))
+	       (when (and (index> left-bits 3)
+			  (index> right-bits 3))
+		 (setf (aref array y (index- x 4))
+		       (read-image-load-byte 1 4 byte)))
+	       (when (and (index> left-bits 4)
+			  (index> right-bits 2))
+		 (setf (aref array y (index- x 5))
+		       (read-image-load-byte 1 3 byte)))
+	       (when (and (index> left-bits 5)
+			  (index> right-bits 1))
+		 (setf (aref array y (index- x 6))
+		       (read-image-load-byte 1 2 byte)))
+	       (when (index> left-bits 6)
+		 (setf (aref array y (index- x 7))
+		       (read-image-load-byte 1 1 byte)))))
+	    (t
+	     (unless (index-zerop left-bits)
+	       (let ((byte (aref buffer-bbuf (index1- start)))
+		     (x left-bits))
+		 (declare (type card8 byte)
+			  (type array-index x))
+		 (setf (aref array y (index- x 1))
+		       (read-image-load-byte 1 7 byte))
+		 (when (index> left-bits 1)
+		   (setf (aref array y (index- x 2))
+			 (read-image-load-byte 1 6 byte))
+		   (when (index> left-bits 2)
+		     (setf (aref array y (index- x 3))
+			   (read-image-load-byte 1 5 byte))
+		     (when (index> left-bits 3)
+		       (setf (aref array y (index- x 4))
+			     (read-image-load-byte 1 4 byte))
+		       (when (index> left-bits 4)
+			 (setf (aref array y (index- x 5))
+			       (read-image-load-byte 1 3 byte))
+			 (when (index> left-bits 5)
+			   (setf (aref array y (index- x 6))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> left-bits 6)
+			     (setf (aref array y (index- x 7))
+				   (read-image-load-byte 1 1 byte))
+			     ))))))))
+	     (do* ((end (index+ start middle-bytes))
+		   (i start (index1+ i))
+		   (x left-bits (index+ x 8)))
+		  ((index>= i end)
+		   (unless (index-zerop right-bits)
+		     (let ((byte (aref buffer-bbuf end))
+			   (x (index+ left-bits middle-bits)))
+		       (declare (type card8 byte)
+				(type array-index x))
+		       (setf (aref array y (index+ x 0))
+			     (read-image-load-byte 1 0 byte))
+		       (when (index> right-bits 1)
+			 (setf (aref array y (index+ x 1))
+			       (read-image-load-byte 1 1 byte))
+			 (when (index> right-bits 2)
+			   (setf (aref array y (index+ x 2))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> right-bits 3)
+			     (setf (aref array y (index+ x 3))
+				   (read-image-load-byte 1 3 byte))
+			     (when (index> right-bits 4)
+			       (setf (aref array y (index+ x 4))
+				     (read-image-load-byte 1 4 byte))
+			       (when (index> right-bits 5)
+				 (setf (aref array y (index+ x 5))
+				       (read-image-load-byte 1 5 byte))
+				 (when (index> right-bits 6)
+				   (setf (aref array y (index+ x 6))
+					 (read-image-load-byte 1 6 byte))
+				   )))))))))
+	       (declare (type array-index end i x))
+	       (let ((byte (aref buffer-bbuf i)))
+		 (declare (type card8 byte))
+		 (setf (aref array y (index+ x 0))
+		       (read-image-load-byte 1 0 byte))
+		 (setf (aref array y (index+ x 1))
+		       (read-image-load-byte 1 1 byte))
+		 (setf (aref array y (index+ x 2))
+		       (read-image-load-byte 1 2 byte))
+		 (setf (aref array y (index+ x 3))
+		       (read-image-load-byte 1 3 byte))
+		 (setf (aref array y (index+ x 4))
+		       (read-image-load-byte 1 4 byte))
+		 (setf (aref array y (index+ x 5))
+		       (read-image-load-byte 1 5 byte))
+		 (setf (aref array y (index+ x 6))
+		       (read-image-load-byte 1 6 byte))
+		 (setf (aref array y (index+ x 7))
+		       (read-image-load-byte 1 7 byte))))
+	     )))))
+
+(defun read-pixarray-4 (buffer-bbuf index array x y width height 
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-nibbles (index-mod (index- x) 2))
+	  (right-nibbles (index-mod (index- width left-nibbles) 2))
+	  (middle-nibbles (index- width left-nibbles right-nibbles))
+	  (middle-bytes (index-floor middle-nibbles 2)))
+	 ((index>= y height))
+      (declare (type array-index start y
+		     left-nibbles right-nibbles middle-nibbles middle-bytes))
+      (unless (index-zerop left-nibbles)
+	(setf (aref array y 0)
+	      (read-image-load-byte
+		4 4 (aref buffer-bbuf (index1- start)))))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (x left-nibbles (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref array y (index+ left-nibbles middle-nibbles))
+		    (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
+	(declare (type array-index end i x))
+	(let ((byte (aref buffer-bbuf i)))
+	  (declare (type card8 byte))
+	  (setf (aref array y (index+ x 0))
+		(read-image-load-byte 4 0 byte))
+	  (setf (aref array y (index+ x 1))
+		(read-image-load-byte 4 4 byte))))
+      )))
+
+(defun read-pixarray-8 (buffer-bbuf index array x y width height 
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 x)
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (the card8 (aref buffer-bbuf i)))))))
+
+(defun read-pixarray-16 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))))))))
+
+(defun read-pixarray-24 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))))))))
+
+(defun read-pixarray-32 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 4))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))
+		(aref buffer-bbuf (index+ i 3))))))))
+
+(defun read-xy-format-image-x
+       (buffer-bbuf index length data width height depth
+	padded-bytes-per-line padded-bytes-per-plane
+	unit byte-lsb-first-p bit-lsb-first-p pad)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type card16 width height)
+	   (type array-index index length padded-bytes-per-line
+		 padded-bytes-per-plane)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit pad)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-x))
+  (assert (index<= (index* depth padded-bytes-per-plane) length))
+  (let* ((bytes-per-line (index-ceiling width 8))
+	 (data-length (index* padded-bytes-per-plane depth)))
+    (declare (type array-index bytes-per-line data-length))
+    (cond (data
+	   (check-type data buffer-bytes)
+	   (assert (index>= (length data) data-length)))
+	  (t
+	   (setq data (make-array data-length :element-type 'card8))))
+    (do ((plane 0 (index1+ plane)))
+	((index>= plane depth))
+      (declare (type image-depth plane))
+      (image-noswap
+	buffer-bbuf data
+	(index+ index (index* plane padded-bytes-per-plane))
+	(index* plane padded-bytes-per-plane)
+	bytes-per-line padded-bytes-per-line padded-bytes-per-line
+	height byte-lsb-first-p))
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel 1 :format :xy-pixmap
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad)))
+
+(defun read-z-format-image-x
+       (buffer-bbuf index length data width height depth
+	padded-bytes-per-line 
+	unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type card16 width height)
+	   (type array-index index length padded-bytes-per-line)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit pad)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (values image-x))
+  (assert (index<= (index* height padded-bytes-per-line) length))
+  (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8))
+	(data-length (index* padded-bytes-per-line height)))
+    (declare (type array-index bytes-per-line data-length))
+    (cond (data
+	   (check-type data buffer-bytes)
+	   (assert (index>= (length data) data-length)))
+	  (t
+	   (setq data (make-array data-length :element-type 'card8))))
+    (image-noswap
+      buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line
+      padded-bytes-per-line height byte-lsb-first-p)
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel bits-per-pixel :format :z-pixmap
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad)))
+
+(defmacro with-image-data-buffer ((buffer size) &body body)
+  (declare (indentation 0 4 1 1))
+  `(let ((.reply-buffer. (allocate-reply-buffer ,size)))
+     (declare (type reply-buffer .reply-buffer.))
+     (unwind-protect
+	 (let ((,buffer (reply-ibuf8 .reply-buffer.)))
+	   (declare (type buffer-bytes ,buffer))
+	   (with-vector (,buffer buffer-bytes)
+	     ,@body))
+       (deallocate-reply-buffer .reply-buffer.))))
+
+(defun read-image-xy-data (bbuf index pixarray x y width height
+			   padded-bytes-per-line
+			   unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index index padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (let* ((x1 (index* (index-floor x unit) unit))
+	 (x (index- x x1))
+	 (width1 (index+ width x))
+	 (padded-bits-per-line1
+	   (index* (index-ceiling width1 *image-pad*) *image-pad*))
+	 (padded-bytes-per-line1 (index-ceiling padded-bits-per-line1 8)))
+    (declare (type card16 x1 x width1)
+	     (type array-index padded-bits-per-line1 padded-bytes-per-line1))
+    (with-image-data-buffer (buf (index* height padded-bytes-per-line1))
+      (image-swap-xy
+	bbuf buf 
+	(index+ index
+		(index* y padded-bytes-per-line)
+		(index-floor x1 8))
+	0
+	(index-ceiling width1 8)
+	padded-bytes-per-line padded-bytes-per-line1
+	height
+	unit byte-lsb-first-p bit-lsb-first-p
+	*image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
+      (unless (fast-read-pixarray
+		buf 0 pixarray x 0 width height padded-bytes-per-line1 1)
+	(read-pixarray-1
+	  buf 0 pixarray x 0 width height padded-bytes-per-line1)))))
+
+(defun read-image-xy (bbuf index length data x y width height depth
+		      padded-bytes-per-line padded-bytes-per-plane
+		      unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type card16 x y width height)
+	   (type array-index index length padded-bytes-per-line
+		 padded-bytes-per-plane)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-xy))
+  (check-type data list)
+  (multiple-value-bind (dimensions element-type)
+      (if data
+	  (values (array-dimensions (first data))
+		  (array-element-type (first data)))
+	(values (list height
+		      (index* (index-ceiling width *image-pad*) *image-pad*))
+		'pixarray-1-element-type))
+    (do* ((arrays data)
+	  (result nil)
+	  (limit (index+ length index))
+	  (plane 0 (1+ plane))
+	  (index index (index+ index padded-bytes-per-plane)))
+	 ((or (>= plane depth)
+	      (index> (index+ index padded-bytes-per-plane) limit))
+	  (setq data (nreverse result) depth (length data)))
+      (declare (type array-index limit index)
+	       (type image-depth plane)
+	       (type list arrays result))
+      (let ((array (or (pop arrays)
+		       (make-array dimensions :element-type element-type))))
+	(declare (type pixarray-1 array))
+	(push array result)
+	(read-image-xy-data
+	  bbuf index array x y width height
+	  padded-bytes-per-line
+	  unit byte-lsb-first-p bit-lsb-first-p)))
+    (create-image 
+      :width width :height height :depth depth :data data)))
+
+(defun read-image-z-data (bbuf index pixarray x y width height
+			  padded-bytes-per-line
+			  bits-per-pixel
+			  unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index index padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (read-image-xy-data
+	bbuf index pixarray x y width height
+	padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+  (let* ((xbits (index* x bits-per-pixel))
+	 (xbits1 (index* (index-floor xbits unit) unit))
+	 (x1 (index-floor xbits1 bits-per-pixel))
+	 (x (index- x x1))
+	 (width1 (index+ width x))
+	 (bits-per-line1 (index* width1 bits-per-pixel))
+	 (bytes-per-line1 (index-ceiling bits-per-line1 8))
+	 (padded-bits-per-line1
+	   (index* (index-ceiling bits-per-line1 *image-pad*) *image-pad*))
+	 (padded-bytes-per-line1
+	   (index-ceiling padded-bits-per-line1 8)))
+      (declare (type array-index xbits xbits1 x1 x
+		     bits-per-line1 bytes-per-line1
+		     padded-bits-per-line1 padded-bytes-per-line1))
+      (with-image-data-buffer (buf (index* height padded-bytes-per-line1))
+	(image-swap-z
+	  bbuf buf 
+	  (index+ index
+		  (index* y padded-bytes-per-line)
+		  (index-floor xbits1 8))
+	  0
+	  bytes-per-line1
+	  padded-bytes-per-line padded-bytes-per-line1
+	  height
+	  bits-per-pixel byte-lsb-first-p *image-byte-lsb-first-p*)
+	(unless (fast-read-pixarray
+		  buf 0 pixarray x 0 width height padded-bytes-per-line1
+		  bits-per-pixel)
+	  (funcall
+	    (ecase bits-per-pixel 
+	      (1 #'read-pixarray-1) (4 #'read-pixarray-4)
+	      (8 #'read-pixarray-8) (16 #'read-pixarray-16)
+	      (24 #'read-pixarray-24) (32 #'read-pixarray-32))
+	    buf 0 pixarray x 0 width height padded-bytes-per-line1))))))
+
+(defun read-image-z (bbuf index length data x y width height depth
+		     padded-bytes-per-line bits-per-pixel
+		     unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type card16 x y width height)
+	   (type array-index index length padded-bytes-per-line)
+	   (type image-depth depth)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-z))
+  (assert (index<= (index* (index+ y height) padded-bytes-per-line) length))
+  (let* ((image-bits-per-line (index* width bits-per-pixel))
+	 (image-pixels-per-line
+	   (index-ceiling
+	     (index* (index-ceiling image-bits-per-line *image-pad*)
+		     *image-pad*)
+	     bits-per-pixel)))
+    (declare (type array-index image-bits-per-line image-pixels-per-line))
+    (unless data
+      (setq data
+	    (make-array
+	      (list height image-pixels-per-line)
+	      :element-type (ecase bits-per-pixel
+			      (1  'pixarray-1-element-type)
+			      (4  'pixarray-4-element-type)
+			      (8  'pixarray-8-element-type)
+			      (16 'pixarray-16-element-type)
+			      (24 'pixarray-24-element-type)
+			      (32 'pixarray-32-element-type)))))
+    (read-image-z-data
+      bbuf index data x y width height
+      padded-bytes-per-line bits-per-pixel
+      unit byte-lsb-first-p bit-lsb-first-p)
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel bits-per-pixel)))
+
+(defun get-image (drawable &key
+		  data
+		  (x (required-arg x))
+		  (y (required-arg y))
+		  (width (required-arg width))
+		  (height (required-arg height))
+		  plane-mask format result-type)
+  (declare (type drawable drawable)
+	   (type (or buffer-bytes list pixarray) data)
+	   (type int16 x y) ;; required
+	   (type card16 width height) ;; required
+	   (type (or null pixel) plane-mask)
+	   (type (or null (member :xy-pixmap :z-pixmap)) format)
+	   (type (or null (member image-xy image-x image-z)) result-type)
+	   (values image visual-info))
+  (unless result-type
+    (setq result-type (ecase format
+			(:xy-pixmap 'image-xy)
+			(:z-pixmap 'image-z)
+			((nil) 'image-x))))
+  (unless format
+    (setq format (case result-type
+		   (image-xy :xy-pixmap)
+		   ((image-z image-x) :z-pixmap))))
+  (unless (ecase result-type
+	    (image-xy (eq format :xy-pixmap))
+	    (image-z (eq format :z-pixmap))
+	    (image-x t))
+    (error "Result-type ~s is incompatable with format ~s"
+	   result-type format))
+  (unless plane-mask (setq plane-mask #xffffffff))
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
+	 (((data (member error :xy-pixmap :z-pixmap)) format)
+	  (drawable drawable)
+	  (int16 x y)
+	  (card16 width height)
+	  (card32 plane-mask))
+      (let* ((depth (card8-get 1))
+	     (length (index* 4 (card32-get 4)))
+	     (visual-info (visual-info display (resource-id-get 8)))
+	     (bitmap-format (display-bitmap-format display))
+	     (unit (bitmap-format-unit bitmap-format))
+	     (byte-lsb-first-p (display-image-lsb-first-p display))
+	     (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
+	(declare (type image-depth depth)
+		 (type array-index length)
+		 (type (or null visual-info) visual-info)
+		 (type bitmap-format bitmap-format)
+		 (type (member 8 16 32) unit)
+		 (type boolean byte-lsb-first-p bit-lsb-first-p))
+	(multiple-value-bind (pad bits-per-pixel)
+	    (ecase format
+	      (:xy-pixmap
+		(values (bitmap-format-pad bitmap-format) 1))
+	      (:z-pixmap
+		(if (= depth 1)
+		    (values (bitmap-format-pad bitmap-format) 1)
+		  (let ((pixmap-format
+			  (find depth (display-pixmap-formats display)
+				:key #'pixmap-format-depth)))
+		    (declare (type pixmap-format pixmap-format))
+		    (values (pixmap-format-scanline-pad pixmap-format)
+			    (pixmap-format-bits-per-pixel pixmap-format))))))
+	  (declare (type (member 8 16 32) pad)
+		   (type (member 1 4 8 16 24 32) bits-per-pixel))
+	  (let* ((bits-per-line (index* bits-per-pixel width))
+		 (padded-bits-per-line
+		   (index* (index-ceiling bits-per-line pad) pad))
+		 (padded-bytes-per-line
+		   (index-ceiling padded-bits-per-line 8))
+		 (padded-bytes-per-plane
+		   (index* padded-bytes-per-line height))
+		 (image
+		   (ecase result-type
+		     (image-x
+		       (ecase format
+			 (:xy-pixmap
+			   (read-xy-format-image-x
+			     buffer-bbuf *replysize* length data
+			     width height depth
+			     padded-bytes-per-line padded-bytes-per-plane
+			     unit byte-lsb-first-p bit-lsb-first-p
+			     pad))
+			 (:z-pixmap
+			   (read-z-format-image-x
+			     buffer-bbuf *replysize* length data
+			     width height depth
+			     padded-bytes-per-line
+			     unit byte-lsb-first-p bit-lsb-first-p
+			     pad bits-per-pixel))))
+		     (image-xy
+		       (read-image-xy
+			 buffer-bbuf *replysize* length data
+			 0 0 width height depth
+			 padded-bytes-per-line padded-bytes-per-plane
+			 unit byte-lsb-first-p bit-lsb-first-p))
+		     (image-z
+		       (read-image-z
+			 buffer-bbuf *replysize* length data
+			 0 0 width height depth padded-bytes-per-line
+			 bits-per-pixel 
+			 unit byte-lsb-first-p bit-lsb-first-p)))))
+	    (declare (type image image)
+		     (type array-index bits-per-line 
+			   padded-bits-per-line padded-bytes-per-line))
+	    (when visual-info
+	      (unless (zerop (visual-info-red-mask visual-info))
+		(setf (image-red-mask image)
+		      (visual-info-red-mask visual-info)))
+	      (unless (zerop (visual-info-green-mask visual-info))
+		(setf (image-green-mask image)
+		      (visual-info-green-mask visual-info)))
+	      (unless (zerop (visual-info-blue-mask visual-info))
+		(setf (image-blue-mask image)
+		      (visual-info-blue-mask visual-info))))
+	    (values image visual-info)))))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; PUT-IMAGE
+
+(defun write-pixarray-1 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-bits (index-mod width 8))
+	  (middle-bits (index- width right-bits))
+	  (middle-bytes (index-ceiling middle-bits 8))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y right-bits middle-bits
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x start-x (index+ x 8)))
+	   ((index>= i end)
+	    (unless (index-zerop right-bits)
+	      (let ((x (index+ start-x middle-bits)))
+		(declare (type array-index x))
+		(setf (aref buffer-bbuf end)
+		      (write-image-assemble-bytes
+			(aref array y (index+ x 0))
+			(if (index> right-bits 1)
+			    (aref array y (index+ x 1))
+			  0)
+			(if (index> right-bits 2)
+			    (aref array y (index+ x 2))
+			  0)
+			(if (index> right-bits 3)
+			    (aref array y (index+ x 3))
+			  0)
+			(if (index> right-bits 4)
+			    (aref array y (index+ x 4))
+			  0)
+			(if (index> right-bits 5)
+			    (aref array y (index+ x 5))
+			  0)
+			(if (index> right-bits 6)
+			    (aref array y (index+ x 6))
+			  0)
+			0)))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref array y (index+ x 0))
+		(aref array y (index+ x 1))
+		(aref array y (index+ x 2))
+		(aref array y (index+ x 3))
+		(aref array y (index+ x 4))
+		(aref array y (index+ x 5))
+		(aref array y (index+ x 6))
+		(aref array y (index+ x 7))))))))
+
+(defun write-pixarray-4 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-nibbles (index-mod width 2))
+	  (middle-nibbles (index- width right-nibbles))
+	  (middle-bytes (index-ceiling middle-nibbles 2))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y right-nibbles middle-nibbles
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x start-x (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref buffer-bbuf end)
+		    (write-image-assemble-bytes
+		      (aref array y (index+ start-x middle-nibbles))
+		      0))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref array y (index+ x 0))
+		(aref array y (index+ x 1))))))))
+
+(defun write-pixarray-8 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref buffer-bbuf i) (the card8 (aref array y x)))))))
+
+(defun write-pixarray-16 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-16-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 16))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 16)))))))
+
+(defun write-pixarray-24 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24)))))))
+
+(defun write-pixarray-32 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-32-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 24 pixel 32)))))))
+
+(defun write-xy-format-image-x-data
+       (data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes data obuf)
+	   (type array-index data-start obuf-start
+		 from-padded-bytes-per-line to-padded-bytes-per-line)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (assert (index-zerop (index-mod x 8)))
+  (let ((x-mod-unit (index-mod x from-bitmap-unit)))
+    (declare (type card16 x-mod-unit))
+    (if (and (index-plusp x-mod-unit)
+	     (not (eq from-byte-lsb-first-p from-bit-lsb-first-p)))
+	(let* ((temp-width (index+ width x-mod-unit))
+	       (temp-bytes-per-line (index-ceiling temp-width 8))
+	       (temp-padded-bits-per-line
+		 (index* (index-ceiling temp-width from-bitmap-unit)
+			 from-bitmap-unit))
+	       (temp-padded-bytes-per-line
+		 (index-ceiling temp-padded-bits-per-line 8)))
+	  (declare (type card16 temp-width temp-bytes-per-line
+			 temp-padded-bits-per-line temp-padded-bytes-per-line))
+	  (with-image-data-buffer (buf (index* height
+					       temp-padded-bytes-per-line))
+	    (image-swap-xy
+	      data buf
+	      (index+ data-start
+		      (index* y from-padded-bytes-per-line)
+		      (index-floor (index- x x-mod-unit) 8))
+	      0
+	      temp-bytes-per-line
+	      from-padded-bytes-per-line temp-padded-bytes-per-line
+	      height
+	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	      from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p)
+	    (write-xy-format-image-x-data
+	      buf obuf 0 obuf-start x-mod-unit 0 width height
+	      temp-padded-bytes-per-line to-padded-bytes-per-line
+	      from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p
+	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))
+      (image-swap-xy
+	data obuf 
+	(index+ data-start
+		(index* y from-padded-bytes-per-line)
+		(index-floor x 8))
+	obuf-start
+	(index-ceiling width 8)
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	height
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))))
+
+(defun write-xy-format-image-x
+       (display image src-x src-y width height
+	padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-x image)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type array-index padded-bytes-per-line)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (dotimes (plane (image-depth image))
+    (let ((data-start
+	    (index* (index* plane (image-height image))
+		    (image-x-bytes-per-line image)))
+	  (src-y src-y)
+	  (height height))
+      (declare (type int16 src-y)
+	       (type card16 height))
+      (loop 
+	(when (index-zerop height) (return))
+	(let ((nlines
+		(index-min (index-floor (index- (buffer-size display)
+						(buffer-boffset display))
+					padded-bytes-per-line)
+			   height)))
+	  (declare (type array-index nlines))
+	  (when (index-plusp nlines)
+	    (write-xy-format-image-x-data
+	      (image-x-data image) (buffer-obuf8 display)
+	      data-start (buffer-boffset display)
+	      src-x src-y width nlines 
+	      (image-x-bytes-per-line image) padded-bytes-per-line
+	      (image-x-unit image) (image-x-byte-lsb-first-p image)
+	      (image-x-bit-lsb-first-p image)
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	    (index-incf (buffer-boffset display)
+			(index* nlines padded-bytes-per-line))
+	    (index-incf src-y nlines)
+	    (when (index-zerop (index-decf height nlines)) (return))))
+	(buffer-flush display)))))
+
+(defun write-z-format-image-x-data
+       (data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	bits-per-pixel
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes data obuf)
+	   (type array-index data-start obuf-start
+		 from-padded-bytes-per-line to-padded-bytes-per-line)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (write-xy-format-image-x-data
+	data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+    (let ((srcoff
+	    (index+ data-start
+		    (index* y from-padded-bytes-per-line)
+		    (index-floor (index* x bits-per-pixel) 8)))
+	  (srclen (index-ceiling (index* width bits-per-pixel) 8)))
+      (declare (type array-index srcoff srclen))
+      (if (and (index= bits-per-pixel 4) (index-oddp x))
+	  (with-image-data-buffer (buf (index* height to-padded-bytes-per-line))
+	    (image-swap-nibbles-left
+	      data buf srcoff 0 srclen
+	      from-padded-bytes-per-line to-padded-bytes-per-line height)
+	    (write-z-format-image-x-data
+	      buf obuf 0 obuf-start 0 0 width height
+	      to-padded-bytes-per-line to-padded-bytes-per-line
+	      bits-per-pixel
+	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))
+	(image-swap-z
+	  data obuf srcoff obuf-start srclen
+	  from-padded-bytes-per-line to-padded-bytes-per-line height
+	  bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p)))))
+
+(defun write-z-format-image-x (display image src-x src-y width height
+			       padded-bytes-per-line
+			       unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-x image)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type array-index padded-bytes-per-line)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (loop 
+    (when (index-zerop height) (return))
+    (let ((nlines
+	    (index-min (index-floor (index- (buffer-size display)
+					    (buffer-boffset display))
+				    padded-bytes-per-line)
+		       height)))
+      (declare (type array-index nlines))
+      (when (index-plusp nlines)
+	(write-z-format-image-x-data 
+	  (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display)
+	  src-x src-y width nlines
+	  (image-x-bytes-per-line image) padded-bytes-per-line
+	  (image-x-bits-per-pixel image)
+	  (image-x-unit image) (image-x-byte-lsb-first-p image)
+	  (image-x-bit-lsb-first-p image)
+	  unit byte-lsb-first-p bit-lsb-first-p)
+	(index-incf (buffer-boffset display)
+		    (index* nlines padded-bytes-per-line))
+	(index-incf src-y nlines)
+	(when (index-zerop (index-decf height nlines)) (return))))
+    (buffer-flush display)))
+
+(defun write-image-xy-data (obuf boffset pixarray x y width height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes obuf)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type pixarray-1 pixarray)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (with-image-data-buffer (buf (index* height padded-bytes-per-line))
+    (unless (fast-write-pixarray
+	      buf 0 pixarray x y width height padded-bytes-per-line 1)
+      (write-pixarray-1 
+	buf 0 pixarray x y width height padded-bytes-per-line))
+    (image-swap-xy
+      buf obuf 0 boffset (index-ceiling width 8)
+      padded-bytes-per-line padded-bytes-per-line height
+      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
+      unit byte-lsb-first-p bit-lsb-first-p)))
+
+(defun write-image-xy (display image src-x src-y width height
+		       padded-bytes-per-line
+		       unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-xy image)
+	   (type array-index padded-bytes-per-line)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (dolist (bitmap (image-xy-bitmap-list image))
+    (declare (type pixarray-1 bitmap))
+    (let ((src-y src-y)
+	  (height height))
+      (declare (type int16 src-y)
+	       (type card16 height))
+      (loop 
+	(let ((nlines
+		(index-min (index-floor (index- (buffer-size display)
+						(buffer-boffset display))
+					padded-bytes-per-line)
+			   height)))
+	  (declare (type array-index nlines))
+	  (when (index-plusp nlines)
+	    (write-image-xy-data
+	      (buffer-obuf8 display) (buffer-boffset display)
+	      bitmap src-x src-y width nlines
+	      padded-bytes-per-line
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	    (index-incf (buffer-boffset display)
+			(index* nlines padded-bytes-per-line))
+	    (index-incf src-y nlines)
+	    (when (index-zerop (index-decf height nlines)) (return))))
+	(buffer-flush display)))))
+
+(defun write-image-z-data (obuf boffset pixarray x y width height
+			   padded-bytes-per-line bits-per-pixel
+			   unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes obuf)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type pixarray-1 pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (write-image-xy-data
+	obuf boffset pixarray x y width height padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+    (with-image-data-buffer (buf (index* height padded-bytes-per-line))
+      (unless (fast-write-pixarray
+		buf 0 pixarray x y width height
+		padded-bytes-per-line bits-per-pixel)
+	(funcall
+	  (ecase bits-per-pixel
+	    (1 #'write-pixarray-1) (4 #'write-pixarray-4)
+	    (8 #'write-pixarray-8) (16 #'write-pixarray-16)
+	    (24 #'write-pixarray-24) (32 #'write-pixarray-32))
+	  buf 0 pixarray x y width height padded-bytes-per-line))
+      (image-swap-z
+	buf obuf 0 boffset 
+	(index-ceiling (index* width bits-per-pixel) 8)
+	padded-bytes-per-line padded-bytes-per-line
+	height bits-per-pixel
+	*image-byte-lsb-first-p* byte-lsb-first-p))))
+
+(defun write-image-z (display image src-x src-y width height
+		      padded-bytes-per-line
+		      unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-z image)
+	   (type array-index padded-bytes-per-line)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (loop 
+    (let ((bits-per-pixel (image-z-bits-per-pixel image))
+	  (nlines
+	    (index-min (index-floor (index- (buffer-size display)
+					    (buffer-boffset display))
+				    padded-bytes-per-line)
+		       height)))
+      (declare (type (member 1 4 8 16 24 32) bits-per-pixel)
+	       (type array-index nlines))
+      (when (index-plusp nlines)
+	(write-image-z-data
+	  (buffer-obuf8 display) (buffer-boffset display)
+	  (image-z-pixarray image) src-x src-y width nlines
+	  padded-bytes-per-line bits-per-pixel
+	  unit byte-lsb-first-p bit-lsb-first-p)
+	(index-incf (buffer-boffset display)
+		    (index* nlines padded-bytes-per-line))
+	(index-incf src-y nlines)
+	(when (index-zerop (index-decf height nlines)) (return))))
+    (buffer-flush display)))
+
+;;; Note:	The only difference between a format of :bitmap and :xy-pixmap
+;;;		of depth 1 is that when sending a :bitmap format the foreground 
+;;;		and background in the gcontext are used.
+
+(defun put-image (drawable gcontext image &key
+		  (src-x 0) (src-y 0)		;Position within image
+		  (x (required-arg x))		;Position within drawable
+		  (y (required-arg y))
+		  width height
+		  bitmap-p)
+  ;; Copy an image into a drawable.
+  ;; WIDTH and HEIGHT default from IMAGE.
+  ;; When BITMAP-P, force format to be :bitmap when depth=1.
+  ;; This causes gcontext to supply foreground & background pixels.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type image image)
+	   (type int16 x y) ;; required
+	   (type int16 src-x src-y)
+	   (type (or null card16) width height)
+	   (type boolean bitmap-p))
+  (let* ((format
+	   (etypecase image
+	     (image-x (image-x-format (the image-x image)))
+	     (image-xy :xy-pixmap)
+	     (image-z :z-pixmap)))
+	 (src-x
+	   (if (image-x-p image)
+	       (index+ src-x (image-x-left-pad (the image-x image)))
+	     src-x))
+	 (image-width (image-width image))
+	 (image-height (image-height image))
+	 (width (min (or width image-width) (index- image-width src-x)))
+	 (height (min (or height image-height) (index- image-height src-y)))
+	 (depth (image-depth image))
+	 (display (drawable-display drawable))
+	 (bitmap-format (display-bitmap-format display))
+	 (unit (bitmap-format-unit bitmap-format))
+	 (byte-lsb-first-p (display-image-lsb-first-p display))
+	 (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
+    (declare (type (member :bitmap :xy-pixmap :z-pixmap) format)
+	     (type card16 src-x image-width image-height width height)
+	     (type image-depth depth)
+	     (type display display)
+	     (type bitmap-format bitmap-format)
+	     (type (member 8 16 32) unit)
+	     (type boolean byte-lsb-first-p bit-lsb-first-p))
+    (when (and bitmap-p (not (index= depth 1)))
+      (error "Bitmaps must have depth 1"))
+    (unless (index<= 0 src-x (index1- (image-width image)))
+      (error "src-x not inside image"))
+    (unless (index<= 0 src-y (index1- (image-height image)))
+      (error "src-y not inside image"))
+    (when (and (index> width 0) (index> height 0))
+      (multiple-value-bind (pad bits-per-pixel)
+	  (ecase format
+	    ((:bitmap :xy-pixmap)
+	      (values (bitmap-format-pad bitmap-format) 1))
+	    (:z-pixmap
+	      (if (= depth 1) 
+		  (values (bitmap-format-pad bitmap-format) 1)
+		(let ((pixmap-format
+			(find depth (display-pixmap-formats display)
+			      :key #'pixmap-format-depth)))
+		  (declare (type pixmap-format pixmap-format))
+		  (values (pixmap-format-scanline-pad pixmap-format)
+			  (pixmap-format-bits-per-pixel pixmap-format))))))
+	(declare (type (member 8 16 32) pad)
+		 (type (member 1 4 8 16 24 32) bits-per-pixel))
+	(let* ((left-pad
+		 (if (or (eq format :xy-pixmap) (= depth 1))
+		     (index-mod src-x (index-min pad *image-pad*))
+		   0))
+	       (left-padded-src-x (index- src-x left-pad))
+	       (left-padded-width (index+ width left-pad))
+	       (bits-per-line (index* left-padded-width bits-per-pixel))
+	       (padded-bits-per-line
+		 (index* (index-ceiling bits-per-line pad) pad))
+	       (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	       (request-bytes-per-line
+		 (ecase format
+		   ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth))
+		   (:z-pixmap padded-bytes-per-line)))
+	       (max-bytes-per-request
+		 (index* (index- (display-max-request-length display) 6) 4))
+	       (max-request-height
+		 (floor max-bytes-per-request request-bytes-per-line)))
+	  (declare (type card8 left-pad)
+		   (type int16 left-padded-src-x)
+		   (type card16 left-padded-width)
+		   (type array-index bits-per-line padded-bits-per-line
+			 padded-bytes-per-line request-bytes-per-line
+			 max-bytes-per-request max-request-height))
+	  ;; Be sure that a scanline can fit in a request
+	  (when (index-zerop max-request-height)
+	    (error "Can't even fit one image scanline in a request"))
+	  ;; Be sure a scanline can fit in a buffer
+	  (buffer-ensure-size display padded-bytes-per-line)
+	  ;; Send the image in multiple requests to avoid exceeding the
+	  ;; request limit
+	  (do* ((request-src-y src-y (index+ request-src-y request-height))
+		(request-y y (index+ request-y request-height))
+		(height-remaining
+		  height (index- height-remaining request-height))
+		(request-height
+		  (index-min height-remaining max-request-height)
+		  (index-min height-remaining max-request-height)))
+	       ((index<= height-remaining 0))
+	    (declare (type array-index request-src-y height-remaining
+			   request-height))
+	    (let* ((request-bytes (index* request-bytes-per-line request-height))
+		   (request-words (index-ceiling request-bytes 4))
+		   (request-length (index+ request-words 6)))
+	      (declare (type array-index request-bytes)
+		       (type card16 request-words request-length))
+	      (with-buffer-request (display *x-putimage* :gc-force gcontext)
+		((data (member :bitmap :xy-pixmap :z-pixmap))
+		 (cond ((or (eq format :bitmap) bitmap-p) :bitmap)
+		       ((plusp left-pad) :xy-pixmap)
+		       (t format)))
+		(drawable drawable)
+		(gcontext gcontext)
+		(card16 width request-height)
+		(int16 x request-y)
+		(card8 left-pad depth)
+		(pad16 nil)
+		(progn 
+		  (length-put 2 request-length)
+		  (setf (buffer-boffset display) (advance-buffer-offset 24))
+		  (etypecase image
+		    (image-x
+		      (ecase (image-x-format (the image-x image))
+			((:bitmap :xy-pixmap)
+			  (write-xy-format-image-x
+			    display image left-padded-src-x request-src-y
+			    left-padded-width request-height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p))
+			(:z-pixmap
+			  (write-z-format-image-x
+			    display image left-padded-src-x request-src-y
+			    left-padded-width request-height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p))))
+		    (image-xy
+		      (write-image-xy
+			display image left-padded-src-x request-src-y
+			left-padded-width request-height
+			padded-bytes-per-line
+			unit byte-lsb-first-p bit-lsb-first-p))
+		    (image-z
+		      (write-image-z
+			display image left-padded-src-x request-src-y
+			left-padded-width request-height
+			padded-bytes-per-line
+			unit byte-lsb-first-p bit-lsb-first-p)))
+		  ;; Be sure the request is padded to a multiple of 4 bytes
+		  (buffer-pad-request display (index- (index* request-words 4) request-bytes))
+		  )))))))))
+
+;;;-----------------------------------------------------------------------------
+;;; COPY-IMAGE
+
+(defun xy-format-image-x->image-x (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-x (index+ x (image-x-left-pad image)))
+	 (left-pad (index-mod padded-x 8))
+	 (x (index- padded-x left-pad))
+	 (unit (image-x-unit image))
+	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
+	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
+	 (pad (image-x-pad image))
+	 (padded-width
+	   (index* (index-ceiling (index+ width left-pad) pad) pad))
+	 (padded-bytes-per-line (index-ceiling padded-width 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (length (index* padded-bytes-per-plane (image-depth image)))
+	 (obuf (make-array length :element-type 'card8)))
+    (declare (type card16 x)
+	     (type card8 left-pad)
+	     (type (member 8 16 32) unit pad)
+	     (type array-index padded-width padded-bytes-per-line
+		   padded-bytes-per-plane length)
+	     (type buffer-bytes obuf))
+    (dotimes (plane (image-depth image))
+      (let ((data-start
+	      (index* (image-x-bytes-per-line image)
+		      (image-height image)
+		      plane))
+	    (obuf-start
+	      (index* padded-bytes-per-plane
+		      plane)))
+	(declare (type array-index data-start obuf-start))
+	(write-xy-format-image-x-data
+	  (image-x-data image) obuf data-start obuf-start
+	  x y width height 
+	  (image-x-bytes-per-line image) padded-bytes-per-line
+	  unit byte-lsb-first-p bit-lsb-first-p
+	  unit byte-lsb-first-p bit-lsb-first-p)))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data obuf :format (image-x-format image) :bits-per-pixel 1
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad)))
+
+(defun z-format-image-x->image-x (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-x (index+ x (image-x-left-pad image)))
+	 (left-pad
+	   (if (index= (image-depth image) 1)
+	       (index-mod padded-x 8)
+	     0))
+	 (x (index- padded-x left-pad))
+	 (bits-per-pixel (image-x-bits-per-pixel image))
+	 (unit (image-x-unit image))
+	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
+	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
+	 (pad (image-x-pad image))
+	 (bits-per-line (index* (index+ width left-pad) bits-per-pixel))
+	 (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (length (index* padded-bytes-per-plane (image-depth image)))
+	 (obuf (make-array length :element-type 'card8)))
+    (declare (type card16 x)
+	     (type card8 left-pad)
+	     (type (member 8 16 32) unit pad)
+	     (type array-index bits-per-pixel padded-bytes-per-line
+		   padded-bytes-per-plane length)
+	     (type buffer-bytes obuf))
+    (write-z-format-image-x-data
+      (image-x-data image) obuf 0 0
+      x y width height 
+      (image-x-bytes-per-line image) padded-bytes-per-line
+      bits-per-pixel
+      unit byte-lsb-first-p bit-lsb-first-p
+      unit byte-lsb-first-p bit-lsb-first-p)
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad)))
+
+(defun image-x->image-x  (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (ecase (image-x-format image)
+    ((:bitmap :xy-pixmap)
+      (xy-format-image-x->image-x image x y width height))
+    (:z-pixmap
+      (z-format-image-x->image-x image x y width height))))
+
+(defun image-x->image-xy (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-xy))
+  (unless (or (eq (image-x-format image) :bitmap)
+	      (eq (image-x-format image) :xy-pixmap)
+	      (and (eq (image-x-format image) :z-pixmap)
+		   (index= (image-depth image) 1)))
+    (error "Format conversion from ~S to ~S not supported"
+	   (image-x-format image) :xy-pixmap))
+  (read-image-xy
+    (image-x-data image) 0 (length (image-x-data image)) nil
+    (index+ x (image-x-left-pad image)) y width height
+    (image-depth image) (image-x-bytes-per-line image)
+    (index* (image-x-bytes-per-line image) (image-height image))
+    (image-x-unit image) (image-x-byte-lsb-first-p image)
+    (image-x-bit-lsb-first-p image)))
+
+(defun image-x->image-z  (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-z))
+  (unless (or (eq (image-x-format image) :z-pixmap)
+	      (eq (image-x-format image) :bitmap)
+	      (and (eq (image-x-format image) :xy-pixmap)
+		   (index= (image-depth image) 1)))
+    (error "Format conversion from ~S to ~S not supported"
+	   (image-x-format image) :z-pixmap))
+  (read-image-z
+    (image-x-data image) 0 (length (image-x-data image)) nil
+    (index+ x (image-x-left-pad image)) y width height
+    (image-depth image) (image-x-bytes-per-line image)
+    (image-x-bits-per-pixel image)
+    (image-x-unit image) (image-x-byte-lsb-first-p image)
+    (image-x-bit-lsb-first-p image)))
+
+(defun copy-pixarray (array x y width height bits-per-pixel)
+  (declare (type pixarray array)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (let* ((bits-per-line (index* bits-per-pixel width))
+	 (padded-bits-per-line
+	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
+	 (padded-width (index-ceiling padded-bits-per-line bits-per-pixel))
+	 (copy (make-array (list height padded-width)
+			   :element-type (array-element-type array))))
+    (declare (type array-index bits-per-line padded-bits-per-line padded-width)
+	     (type pixarray copy))
+    #.(declare-buffun)
+    (unless (fast-copy-pixarray array copy x y width height bits-per-pixel)
+      (macrolet
+	((copy (array-type element-type)
+	   `(let ((array array)
+		  (copy copy))
+	      (declare (type ,array-type array copy))
+	      (do* ((dst-y 0 (index1+ dst-y))
+		    (src-y y (index1+ src-y)))
+		   ((index>= dst-y height))
+		(declare (type card16 dst-y src-y))
+		(do* ((dst-x 0 (index1+ dst-x))
+		      (src-x x (index1+ src-x)))
+		     ((index>= dst-x width))
+		  (declare (type card16 dst-x src-x))
+		  (setf (aref copy dst-y dst-x)
+			(the ,element-type
+			     (aref array src-y src-x))))))))
+	(ecase bits-per-pixel
+	  (1  (copy pixarray-1  pixarray-1-element-type))
+	  (4  (copy pixarray-4  pixarray-4-element-type))
+	  (8  (copy pixarray-8  pixarray-8-element-type))
+	  (16 (copy pixarray-16 pixarray-16-element-type))
+	  (24 (copy pixarray-24 pixarray-24-element-type))
+	  (32 (copy pixarray-32 pixarray-32-element-type)))))
+    copy))
+
+(defun image-xy->image-x (image x y width height)
+  (declare (type image-xy image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-bits-per-line
+	   (index* (index-ceiling width *image-pad*) *image-pad*))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (bytes-total (index* padded-bytes-per-plane (image-depth image)))
+	 (data (make-array bytes-total :element-type 'card8)))
+    (declare (type array-index padded-bits-per-line padded-bytes-per-line
+		   padded-bytes-per-plane bytes-total)
+	     (type buffer-bytes data))
+    (let ((index 0))
+      (declare (type array-index index))
+      (dolist (bitmap (image-xy-bitmap-list image))
+	(declare (type pixarray-1 bitmap))
+	(unless (fast-write-pixarray
+		  data index bitmap x y width height
+		  padded-bytes-per-line 1)
+	  (write-pixarray-1
+	    data index bitmap x y width height
+	    padded-bytes-per-line))
+	(index-incf index padded-bytes-per-plane)))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data data :format :xy-pixmap :bits-per-pixel 1
+      :bytes-per-line padded-bytes-per-line
+      :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p*
+      :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*)))
+
+(defun image-xy->image-xy (image x y width height)
+  (declare (type image-xy image)
+	   (type card16 x y width height)
+	   (values image-xy))
+  (create-image
+    :width width :height height :depth (image-depth image)
+    :data (mapcar
+	    #'(lambda (array)
+		(declare (type pixarray-1 array))
+		(copy-pixarray array x y width height 1))
+	    (image-xy-bitmap-list image))))
+
+(defun image-xy->image-z (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (ignore image x y width height))
+  (error "Format conversion from ~S to ~S not supported"
+	 :xy-pixmap :z-pixmap))
+
+(defun image-z->image-x (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((bits-per-line (index* width (image-z-bits-per-pixel image)))
+	 (padded-bits-per-line
+	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (bytes-total
+	   (index* padded-bytes-per-line height (image-depth image)))
+	 (data (make-array bytes-total :element-type 'card8)))
+    (declare (type array-index bits-per-line padded-bits-per-line
+		   padded-bytes-per-line bytes-total)
+	     (type buffer-bytes data))
+    (unless (fast-write-pixarray
+	      data 0 (image-z-pixarray image) x y width height
+	      padded-bytes-per-line 
+	      (image-z-bits-per-pixel image))
+      (funcall
+	(ecase (image-z-bits-per-pixel image)
+	  (1 #'write-pixarray-1) (4 #'write-pixarray-4)
+	  (8 #'write-pixarray-8) (16 #'write-pixarray-16)
+	  (24 #'write-pixarray-24) (32 #'write-pixarray-32))
+	data 0 (image-z-pixarray image) x y width height
+	padded-bytes-per-line))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data data :format :z-pixmap
+      :bits-per-pixel (image-z-bits-per-pixel image)
+      :bytes-per-line padded-bytes-per-line
+      :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p*
+      :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*)))
+
+(defun image-z->image-xy (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (ignore image x y width height))
+  (error "Format conversion from ~S to ~S not supported"
+	 :z-pixmap :xy-pixmap))
+
+(defun image-z->image-z (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (values image-z))
+  (create-image
+    :width width :height height :depth (image-depth image)
+    :data (copy-pixarray
+	    (image-z-pixarray image) x y width height
+	    (image-z-bits-per-pixel image))))
+
+(defun copy-image (image &key (x 0) (y 0) width height result-type)
+  ;; Copy with optional sub-imaging and format conversion.
+  ;; result-type defaults to (type-of image)
+  (declare (type image image)
+	   (type card16 x y)
+	   (type (or null card16) width height) ;; Default from image
+	   (type (or null (member image-x image-xy image-z)) result-type))
+  (declare (values image))
+  (let* ((image-width (image-width image))
+	 (image-height (image-height image))
+	 (width (or width image-width))
+	 (height (or height image-height)))
+    (declare (type card16 image-width image-height width height))
+    (unless (index<= 0 x (index1- image-width)) (error "x not inside image"))
+    (unless (index<= 0 y (index1- image-height)) (error "y not inside image"))
+    (setq width (index-min width (index-max (index- image-width x) 0)))
+    (setq height (index-min height (index-max (index- image-height y) 0)))
+    (let ((copy
+	    (etypecase image
+	      (image-x
+		(ecase result-type
+		  ((nil image-x) (image-x->image-x image x y width height))
+		  (image-xy (image-x->image-xy image x y width height))
+		  (image-z  (image-x->image-z  image x y width height))))
+	      (image-xy
+		(ecase result-type
+		  (image-x (image-xy->image-x image x y width height))
+		  ((nil image-xy) (image-xy->image-xy image x y width height))
+		  (image-z  (image-xy->image-z image x y width height))))
+	      (image-z 
+		(ecase result-type
+		  (image-x (image-z->image-x image x y width height))
+		  (image-xy  (image-z->image-xy image x y width height))
+		  ((nil image-z) (image-z->image-z image x y width height)))))))
+      (declare (type image copy))
+      (setf (image-plist copy) (copy-list (image-plist image)))
+      (when (and (image-x-hot image) (not (index-zerop x)))
+	(setf (image-x-hot copy) (index- (image-x-hot image) x)))
+      (when (and (image-y-hot image) (not (index-zerop y)))
+	(setf (image-y-hot copy) (index- (image-y-hot image) y)))
+      copy)))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Image I/O functions
+
+
+(defun read-bitmap-file (pathname)
+  ;; Creates an image from a C include file in standard X11 format
+  (declare (type (or pathname string stream) pathname))
+  (declare (values image))
+  (with-open-file (fstream pathname :direction :input)
+    (let ((line "")
+	  (properties nil)
+	  (name nil)
+	  (name-end nil)
+	  (*package* (find-package 'keyword))
+	  (*read-base* 10))
+      (declare (type string line)
+	       (type stringable name)
+	       (type list properties))
+      ;; Get properties
+      (loop
+	(setq line (read-line fstream))
+	(unless (char= (aref line 0) #\#) (return))
+	(flet ((read-keyword (line start end)
+		 (kintern
+		   (substitute
+		     #\- #\_
+		     (#-excl string-upcase
+		      #+excl correct-case
+		      (subseq line start end))
+		     :test #'char=))))
+	  (when (null name)
+	    (setq name-end (position #\_ line :test #'char= :from-end t)
+		  name (read-keyword line 8 name-end))
+	    (unless (eq name :image)
+	      (setf (getf properties :name) name)))
+	  (let* ((ind-start (index1+ name-end))
+		 (ind-end (position #\Space line :test #'char=
+				    :start ind-start))
+		 (ind (read-keyword line ind-start ind-end))
+		 (val-start (index1+ ind-end))
+		 (val (parse-integer line :start val-start)))
+	    (setf (getf properties ind) val))))
+      ;; Calculate sizes
+      (multiple-value-bind (width height depth left-pad)
+	  (flet ((extract-property (ind &rest default)
+		   (prog1 (apply #'getf properties ind default)
+			  (remf properties ind))))
+	    (values (extract-property :width)
+		    (extract-property :height)
+		    (extract-property :depth 1)
+		    (extract-property :left-pad 0)))
+	(declare (type (or null card16) width height)
+		 (type image-depth depth)
+		 (type card8 left-pad))
+	(unless (and width height) (error "Not a BITMAP file"))
+	(let* ((bits-per-pixel
+		 (cond ((index> depth 24) 32)
+		       ((index> depth 16) 24)
+		       ((index> depth 8)  16)
+		       ((index> depth 4)   8)
+		       ((index> depth 1)   4)
+		       (t                  1)))
+	       (bits-per-line (index* width bits-per-pixel))
+	       (bytes-per-line (index-ceiling bits-per-line 8))
+	       (padded-bits-per-line
+		 (index* (index-ceiling bits-per-line 32) 32))
+	       (padded-bytes-per-line
+		 (index-ceiling padded-bits-per-line 8))
+	       (data (make-array (* padded-bytes-per-line height)
+				 :element-type 'card8))
+	       (line-base 0)
+	       (byte 0))
+	  (declare (type array-index bits-per-line bytes-per-line
+			 padded-bits-per-line padded-bytes-per-line
+			 line-base byte)
+		   (type buffer-bytes data))
+	  (with-vector (data buffer-bytes)
+	    (flet ((parse-hex (char)
+		     (second
+		       (assoc char
+			      '((#\0  0) (#\1  1) (#\2  2) (#\3  3)
+				(#\4  4) (#\5  5) (#\6  6) (#\7  7)
+				(#\8  8) (#\9  6) (#\a 10) (#\b 11)
+				(#\c 12) (#\d 13) (#\e 14) (#\f 15))
+			      :test #'char-equal))))
+	      ;; Read data
+	      ;; Note: using read-line instead of read-char would be 20% faster,
+	      ;;       but would cons a lot of garbage...
+	      (dotimes (i height)
+		(dotimes (j bytes-per-line)
+		  (loop (when (eql (read-char fstream) #\x) (return)))
+		  (setf (aref data (index+ line-base byte))
+			(index+ (index-ash (parse-hex (read-char fstream)) 4)
+				(parse-hex (read-char fstream))))
+		  (incf byte))
+		(setq byte 0
+		      line-base (index+ line-base padded-bytes-per-line)))))
+	  ;; Compensate for left-pad in width and x-hot
+	  (index-decf width left-pad)
+	  (when (getf properties :x-hot)
+	    (index-decf (getf properties :x-hot) left-pad))
+	  (create-image
+	    :width width :height height
+	    :depth depth :bits-per-pixel bits-per-pixel
+	    :data data :plist properties :format :z-pixmap
+	    :bytes-per-line padded-bytes-per-line
+	    :unit 32 :byte-lsb-first-p t :bit-lsb-first-p t
+	    :pad 32 :left-pad left-pad))))))
+
+(defun write-bitmap-file (pathname image &optional name)
+  ;; Writes an image to a C include file in standard X11 format
+  ;; NAME argument used for variable prefixes.  Defaults to "image"
+  (declare (type (or pathname string stream) pathname)
+	   (type image image)
+	   (type (or null stringable) name))
+  (unless (typep image 'image-x)
+    (setq image (copy-image image :result-type 'image-x)))
+  (let* ((plist (image-plist image))
+	 (name (or name (image-name image) 'image))
+	 (left-pad (image-x-left-pad image))
+	 (width (index+ (image-width image) left-pad))
+	 (height (image-height image))
+	 (depth
+	   (if (eq (image-x-format image) :z-pixmap)
+	       (image-depth image)
+	     1))
+	 (bits-per-pixel (image-x-bits-per-pixel image))
+	 (bits-per-line (index* width bits-per-pixel))
+	 (bytes-per-line (index-ceiling bits-per-line 8))
+	 (last (index* bytes-per-line height))
+	 (count 0))
+    (declare (type list plist)
+	     (type stringable name)
+	     (type card8 left-pad)
+	     (type card16 width height)
+	     (type (member 1 4 8 16 24 32) bits-per-pixel)
+	     (type image-depth depth)
+	     (type array-index bits-per-line bytes-per-line count last))
+    ;; Move x-hot by left-pad, if there is an x-hot, so image readers that
+    ;; don't know about left pad get the hot spot in the right place.  We have
+    ;; already increased width by left-pad.
+    (when (getf plist :x-hot)
+      (setq plist (copy-list plist))
+      (index-incf (getf plist :x-hot) left-pad))
+    (with-image-data-buffer (data last)
+      (if (index> bits-per-pixel 1)
+	  (image-swap-z
+	    (image-x-data image) data 0 0 bytes-per-line
+	    (image-x-bytes-per-line image) bytes-per-line
+	    height bits-per-pixel
+	    (image-x-byte-lsb-first-p image) t)
+	(image-swap-xy
+	  (image-x-data image) data 0 0 bytes-per-line
+	  (image-x-bytes-per-line image) bytes-per-line
+	  height 
+	  (image-x-unit image) (image-x-byte-lsb-first-p image)
+	  (image-x-bit-lsb-first-p image)
+	  32 t t))
+      (with-vector (data buffer-bytes)
+	(setq name (string-downcase (string name)))
+	(with-open-file (fstream pathname :direction :output)
+	  (format fstream "#define ~a_width ~d~%" name width)
+	  (format fstream "#define ~a_height ~d~%" name height)
+	  (unless (= depth 1)
+	    (format fstream "#define ~a_depth ~d~%" name depth))
+	  (unless (zerop left-pad)
+	    (format fstream "#define ~a_left_pad ~d~%" name left-pad))
+	  (do ((prop plist (cddr prop)))
+	      ((endp prop))
+	    (when (and (not (member (car prop) '(:width :height)))
+		       (numberp (cadr prop)))
+	      (format fstream "#define ~a_~a ~d~%"
+		      name
+		      (substitute
+			#\_ #\- (string-downcase (string (car prop)))
+			:test #'char=)
+		      (cadr prop))))
+	  (format fstream "static char ~a_bits[] = {" name)
+	  (dotimes (i height)
+	    (dotimes (j bytes-per-line)
+	      (when (zerop (index-mod count 15))
+		(terpri fstream)
+		(write-char #\space fstream))
+	      (write-string "0x" fstream)
+	      ;; Faster than (format fstream "0x~2,'0x," byte)
+	      (let ((byte (aref data count))
+		    (translate "0123456789abcdef"))
+		(declare (type card8 byte))
+		(write-char (char translate (ldb (byte 4 4) byte)) fstream)
+		(write-char (char translate (ldb (byte 4 0) byte)) fstream))
+	      (index-incf count)
+	      (unless (index= count last)
+		(write-char #\, fstream))))
+	  (format fstream "};~%" fstream))))))
+
+(defun bitmap-image (&optional plist &rest patterns)
+  ;; Create an image containg pattern
+  ;; PATTERNS are bit-vector constants (e.g. #*10101)
+  ;; If the first parameter is a list, its used as the image property-list.
+  (declare (type (or list bit-vector) plist)
+	   (type list patterns)) ;; list of bitvector
+  (declare (values image))
+  (unless (listp plist)
+    (push plist patterns)
+    (setq plist nil))
+  (let* ((width (length (first patterns)))
+	 (height (length patterns))
+	 (bitarray (make-array (list height width) :element-type 'bit))
+	 (row 0))
+    (declare (type card16 width height row)
+	     (type pixarray-1 bitarray))
+    (dolist (pattern patterns)
+      (declare (type simple-bit-vector pattern))
+      (dotimes (col width)
+	(declare (type card16 col))
+	(setf (aref bitarray row col) (the bit (aref pattern col))))
+      (incf row))
+    (create-image :width width :height height :plist plist :data bitarray)))
+
+(defun image-pixmap (drawable image &key gcontext width height depth)
+  ;; Create a pixmap containing IMAGE. Size defaults from the image.
+  ;; DEPTH is the pixmap depth.
+  ;; GCONTEXT is used for putting the image into the pixmap.
+  ;; If none is supplied, then one is created, used then freed.
+  (declare (type drawable drawable)
+	   (type image image)
+	   (type (or null gcontext) gcontext)
+	   (type (or null card16) width height)
+	   (type (or null card8) depth))
+  (declare (values pixmap))
+  (let* ((image-width (image-width image))
+	 (image-height (image-height image))
+	 (image-depth (image-depth image))
+	 (width (or width image-width))
+	 (height (or height image-height))
+	 (depth (or depth image-depth))
+	 (pixmap (create-pixmap :drawable drawable
+			       :width width
+			       :height height
+			       :depth depth))
+	 (gc (or gcontext (create-gcontext
+			    :drawable pixmap
+			    :foreground 1
+			    :background 0))))
+    (unless (= depth image-depth)
+      (if (= image-depth 1)
+	  (unless gcontext (xlib::required-arg gcontext))
+	(error "Pixmap depth ~d incompatable with image depth ~d"
+	       depth image-depth)))	       
+    (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext))
+    ;; Tile when image-width is less than the pixmap width, or
+    ;; the image-height is less than the pixmap height.
+    ;; ??? Would it be better to create a temporary pixmap and 
+    ;; ??? let the server do the tileing?
+    (do ((x image-width (+ x image-width)))
+	((>= x width))
+      (copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
+      (incf image-width image-width))
+    (do ((y image-height (+ y image-height)))
+	((>= y height))
+      (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
+      (incf image-height image-height))
+    (unless gcontext (free-gcontext gc))
+    pixmap))
+
diff --git a/clx/input.lisp b/clx/input.lisp
new file mode 100644
index 000000000..b2ed08220
--- /dev/null
+++ b/clx/input.lisp
@@ -0,0 +1,1927 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;;
+;;; Change history:
+;;;
+;;;  Date	Author	Description
+;;; -------------------------------------------------------------------------------------
+;;; 12/10/87	LGO	Created
+
+(in-package :xlib)
+
+(export '(
+	  event-listen
+	  queue-event
+	  process-event
+	  make-event-handlers
+	  event-handler
+	  event-case
+	  event-cond
+	  discard-current-event
+	  request-error
+	  value-error
+	  window-error
+	  pixmap-error
+	  atom-error
+	  cursor-error
+	  font-error
+	  match-error
+	  drawable-error
+	  access-error
+	  alloc-error
+	  colormap-error
+	  gcontext-error
+	  id-choice-error
+	  name-error
+	  length-error
+	  implementation-error
+	  request-error
+	  resource-error
+	  unknown-error
+	  access-error
+	  alloc-error
+	  atom-error
+	  colormap-error
+	  cursor-error
+	  drawable-error
+	  font-error
+	  gcontext-error
+	  id-choice-error
+	  illegal-request-error
+	  length-error
+	  match-error
+	  name-error
+	  pixmap-error
+	  value-error
+	  window-error
+	  implementation-error
+	  #-ansi-common-lisp type-error
+	  closed-display
+	  lookup-error
+	  connection-failure
+	  reply-length-error
+	  reply-timeout
+	  sequence-error
+	  unexpected-reply
+	  missing-parameter
+	  invalid-font
+	  device-busy
+	  get-external-event-code
+	  define-extension
+	  extension-opcode
+	  define-error
+	  decode-core-error
+	  declare-event
+	  ))
+
+;; Event Resource
+(defvar *event-free-list* nil) ;; List of unused (processed) events
+
+(eval-when (eval compile load)
+(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
+(defvar *event-key-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event keys - See define-event")
+)
+(defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event handler functions - See declare-event")
+(defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event handler functions - See declare-event")
+(defvar *event-send-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event sending functions - See declare-event")
+
+(defun allocate-event ()
+  (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
+      (make-reply-buffer *replysize*)))
+
+(defun deallocate-event (reply-buffer)
+  (declare (type reply-buffer reply-buffer))
+  (setf (reply-size reply-buffer) *replysize*)
+  (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
+
+;; Extensions are handled as follows:
+;; DEFINITION:	Use DEFINE-EXTENSION
+;;
+;; CODE:	Use EXTENSION-CODE to get the X11 opcode for an extension.
+;;		This looks up the code on the display-extension-alist.
+;;
+;; EVENTS:	Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
+;;		at LOAD time to define an internal event-code number
+;;		(stored in the 'event-code property of the event-name)
+;;		used to index the following vectors:
+;;		*event-key-vector* 	Used for getting the event-key
+;;		*event-macro-vector*	Used for getting the event-parameter getting macros
+;;
+;;		The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
+;;		a server event-code into an internal event-code used to index the following
+;;		vectors:
+;;		*event-handler-vector*	Used for getting the event-handler function
+;;		*event-send-vector*	Used for getting the event-sending function
+;;
+;;		The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
+;;		internal event-codes to external (server) codes.
+;;
+;; ERRORS:	Use DEFINE-ERROR to define new error decodings.
+;;
+
+
+;; Any event-code greater than 34 is for an extension
+(defparameter *first-extension-event-code* 35)
+
+(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
+
+(defmacro define-extension (name &key events errors)
+  ;; Define extension NAME with EVENTS and ERRORS.
+  ;; Note: The case of NAME is important.
+  ;; To define the request, Use:
+  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
+  ;;     See the REQUESTS file for lots of examples.
+  ;; To define event handlers, use declare-event.
+  ;; To define error handlers, use declare-error and define-condition.
+  (declare (type stringable name)
+	   (type list events errors))
+  (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
+	(event-list (mapcar #'canonicalize-event-name events)))
+    `(eval-when (compile load eval)
+       (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
+				(delete ',name-symbol *extensions* :key #'car))))))
+
+(eval-when (compile eval load)
+(defun canonicalize-event-name (event)
+  ;; Returns the event name keyword given an event name stringable
+  (declare (type stringable event))
+  (declare (values event-key))
+  (kintern event))
+) ;; end eval-when
+
+(eval-when (compile eval load)
+(defun allocate-extension-event-code (name)
+  ;; Allocate an event-code for an extension
+  ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
+  ;; The event-code is used at compile-time by macros to index the following vectors:
+  ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
+  (let ((event-code (get name 'event-code)))
+    (declare (type (or null card8) event-code))
+    (unless event-code
+      ;; First ensure the name is for a declared extension
+      (unless (dolist (extension *extensions*)
+		(when (member name (second extension))
+		  (return t)))
+	(x-type-error name 'event-key))
+      (setq event-code (position nil *event-key-vector*
+				 :start *first-extension-event-code*))
+      (setf (svref *event-key-vector* event-code) name)
+      (setf (get name 'event-code) event-code))
+    event-code))
+) ;; end eval-when
+
+(defun get-internal-event-code (display code)
+  ;; Given an X11 event-code, return the internal event-code.
+  ;; The internal event-code is used for indexing into the following vectors:
+  ;; *event-key-vector* *event-handler-vector* *event-send-vector*
+  ;; Returns NIL when the event-code is for an extension that isn't handled.
+  (declare (type display display)
+	   (type card8 code))
+  (declare (values (or nil card8)))
+  (setq code (logand #x7f code))
+  (if (< code *first-extension-event-code*)
+      code
+    (let* ((code-offset (- code *first-extension-event-code*))
+	   (event-extensions (display-event-extensions display))
+	   (code (if (< code-offset (length event-extensions))
+		     (aref event-extensions code-offset)
+		   0)))
+      (declare (type card8 code-offset code))
+      (when (zerop code)
+	(x-cerror "Ignore the event"
+		  'unimplemented-event :event-code code :display display))
+      code)))
+
+(defun get-external-event-code (display event)
+  ;; Given an X11 event name, return the event-code
+  (declare (type display display)
+	   (type event-key event))
+  (declare (values card8))
+  (let ((code (get-event-code event)))
+    (declare (type (or null card8) code))
+    (when (>= code *first-extension-event-code*)
+      (setq code (+ *first-extension-event-code*
+		    (or (position code (display-event-extensions display))
+			(x-error 'undefined-event :display display :event-name event)))))
+    code))
+
+(defmacro extension-opcode (display name)
+  ;; Returns the major opcode for extension NAME.
+  ;; This is a macro to enable NAME to be interned for fast run-time
+  ;; retrieval. 
+  ;; Note: The case of NAME is important.
+  (declare (type display display)
+	   (type stringable name))
+  (declare (values card8))
+  (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
+    `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
+	 (x-error 'absent-extension :name ',name-symbol :display ,display))))
+
+(defun initialize-extensions (display)
+  ;; Initialize extensions for DISPLAY
+  (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
+	(extension-alist nil))
+    (declare (type vector event-extensions)
+	     (type list extension-alist))
+    (dolist (extension *extensions*)
+      (let ((name (first extension))
+	    (events (second extension)))
+	(declare (type keyword name)
+		 (type list events))
+	(multiple-value-bind (major-opcode first-event first-error)
+	    (query-extension display name)
+	  (declare (type (or null card8) major-opcode first-event first-error))
+	  (when (and major-opcode (plusp major-opcode))
+	    (push (list name major-opcode first-event first-error)
+		  extension-alist)
+	    (when (plusp first-event) ;; When there are extension events
+	      ;; Grow extension vector when needed
+	      (let ((max-event (- (+ first-event (length events))
+				  *first-extension-event-code*)))
+		(declare (type card8 max-event))
+		(when (>= max-event (length event-extensions))
+		  (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
+						    :initial-element 0)))
+		    (declare (type vector new-extensions))
+		    (replace new-extensions event-extensions)
+		    (setq event-extensions new-extensions))))
+	      (dolist (event events)
+		(declare (type symbol event))
+		(setf (aref event-extensions (- first-event *first-extension-event-code*))
+		      (get-event-code event))
+		(incf first-event)))))))
+    (setf (display-event-extensions display) event-extensions)
+    (setf (display-extension-alist display) extension-alist)))
+
+;;
+;; Reply handlers
+;;
+
+(defvar *pending-command-free-list* nil)
+
+(defun start-pending-command (display)
+  (declare (type display display))
+  (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
+						  pending-command-next pending-command)
+			     (make-pending-command))))
+    (declare (type pending-command pending-command))
+    (setf (pending-command-reply-buffer pending-command) nil)
+    (setf (pending-command-process pending-command) (current-process))
+    (setf (pending-command-sequence pending-command)
+	  (ldb (byte 16 0) (1+ (buffer-request-number display))))
+    ;; Add the pending command to the end of the threaded list of pending
+    ;; commands for the display.
+    (with-event-queue-internal (display)
+      (threaded-nconc pending-command (display-pending-commands display)
+		      pending-command-next pending-command))
+    pending-command))
+
+(defun stop-pending-command (display pending-command)
+  (declare (type display display)
+	   (type pending-command pending-command))
+  (with-event-queue-internal (display)
+    ;; Remove the pending command from the threaded list of pending commands
+    ;; for the display.
+    (threaded-delete pending-command (display-pending-commands display)
+		     pending-command-next pending-command)
+    ;; Deallocate any reply buffers in this pending command
+    (loop
+      (let ((reply-buffer
+	      (threaded-pop (pending-command-reply-buffer pending-command)
+			    reply-next reply-buffer)))
+	(declare (type (or null reply-buffer) reply-buffer))
+	(if reply-buffer
+	    (deallocate-reply-buffer reply-buffer)
+	  (return nil)))))
+  ;; Deallocate this pending-command
+  (threaded-atomic-push pending-command *pending-command-free-list*
+			pending-command-next pending-command)
+  nil)
+
+;;;
+
+(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
+
+(defun allocate-reply-buffer (size)
+  (declare (type array-index size))
+  (if (index<= size *replysize*)
+      (allocate-event)
+    (let ((index (integer-length (index1- size))))
+      (declare (type array-index index))
+      (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
+			       reply-next reply-buffer)
+	  (make-reply-buffer (index-ash 1 index))))))
+
+(defun deallocate-reply-buffer (reply-buffer)
+  (declare (type reply-buffer reply-buffer))
+  (let ((size (reply-size reply-buffer)))
+    (declare (type array-index size))
+    (if (index<= size *replysize*)
+	(deallocate-event reply-buffer)
+      (let ((index (integer-length (index1- size))))
+	(declare (type array-index index))
+	(threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
+			      reply-next reply-buffer)))))
+
+;;;
+
+(defun read-error-input (display sequence reply-buffer token)
+  (declare (type display display)
+	   (type reply-buffer reply-buffer)
+	   (type card16 sequence))
+  (tagbody
+    start
+       (with-event-queue-internal (display)
+	 (let ((command 
+		 ;; Find any pending command with this sequence number.
+		 (threaded-dolist (pending-command (display-pending-commands display)
+						   pending-command-next pending-command)
+		   (when (= (pending-command-sequence pending-command) sequence)
+		     (return pending-command)))))
+	   (declare (type (or null pending-command) command))
+	   (cond ((not (null command))
+		  ;; Give this reply to the pending command
+		  (threaded-nconc reply-buffer (pending-command-reply-buffer command)
+				  reply-next reply-buffer)
+		  (process-wakeup (pending-command-process command)))
+		 ((member :immediately (display-report-asynchronous-errors display))
+		  ;; No pending command and we should report the error immediately
+		  (go report-error))
+		 (t
+		  ;; No pending command found, count this as an asynchronous error
+		  (threaded-nconc reply-buffer (display-asynchronous-errors display)
+				  reply-next reply-buffer)))))
+       (return-from read-error-input nil)
+    report-error
+       (note-input-complete display token)
+       (apply #'report-error display
+	      (prog1 (make-error display reply-buffer t)
+		     (deallocate-event reply-buffer)))))
+
+(defun read-reply-input (display sequence length reply-buffer)
+  (declare (type display display)
+	   (type (or null reply-buffer) reply-buffer)
+	   (type card16 sequence)
+	   (type array-index length))
+  (unwind-protect 
+      (progn
+	(when (index< *replysize* length)
+	  (let ((repbuf nil))
+	    (declare (type (or null reply-buffer) repbuf))
+	    (unwind-protect
+		(progn
+		  (setq repbuf (allocate-reply-buffer length))
+		  (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
+				  0 *replysize*)
+		  (deallocate-event (shiftf reply-buffer repbuf nil)))
+	      (when repbuf
+		(deallocate-reply-buffer repbuf))))
+	  (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)
+	    (return-from read-reply-input t))
+	  (setf (reply-data-size reply-buffer) length))
+	(with-event-queue-internal (display)
+	  ;; Find any pending command with this sequence number.
+	  (let ((command 
+		  (threaded-dolist (pending-command (display-pending-commands display)
+						    pending-command-next pending-command)
+		    (when (= (pending-command-sequence pending-command) sequence)
+		      (return pending-command)))))
+	    (declare (type (or null pending-command) command))
+	    (when command 
+	      ;; Give this reply to the pending command
+	      (threaded-nconc (shiftf reply-buffer nil)
+			      (pending-command-reply-buffer command)
+			      reply-next reply-buffer)
+	      (process-wakeup (pending-command-process command)))))
+	nil)
+    (when reply-buffer
+      (deallocate-reply-buffer reply-buffer))))
+
+(defun read-event-input (display code reply-buffer)
+  (declare (type display display)
+	   (type card8 code)
+	   (type reply-buffer reply-buffer))
+  ;; Push the event in the input buffer on the display's event queue
+  (setf (event-code reply-buffer)
+	(get-internal-event-code display code))
+  (enqueue-event reply-buffer display)
+  nil)
+
+(defun note-input-complete (display token)
+  (declare (type display display))
+  (when (eq (display-input-in-progress display) token)
+    ;; Indicate that input is no longer in progress
+    (setf (display-input-in-progress display) nil)
+    ;; Let the event process get the first chance to do input
+    (let ((process (display-event-process display)))
+      (when (not (null process))
+	(process-wakeup process)))
+    ;; Then give processes waiting for command responses a chance
+    (unless (display-input-in-progress display)
+      (with-event-queue-internal (display)
+	(threaded-dolist (command (display-pending-commands display)
+				  pending-command-next pending-command)
+	  (process-wakeup (pending-command-process command)))))))
+
+(defun read-input (display timeout force-output-p predicate &rest predicate-args)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p)
+	   (dynamic-extent predicate-args))
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (let ((reply-buffer nil)
+	(token (or (current-process) (cons nil nil))))
+    (declare (type (or null reply-buffer) reply-buffer))
+    (unwind-protect 
+	(tagbody
+	  loop
+	     (when (display-dead display)
+	       (x-error 'closed-display :display display))
+	     (when (apply predicate predicate-args)
+	       (return-from read-input nil))
+	     ;; Check and see if we have to force output
+	     (when (and force-output-p
+			(or (and (not (eq (display-input-in-progress display) token))
+				 (not (conditional-store
+					(display-input-in-progress display) nil token)))
+			    (null (buffer-listen display))))
+	       (go force-output))
+	     ;; Ensure that ony one process is reading input.
+	     (unless (or (eq (display-input-in-progress display) token)
+			 (conditional-store (display-input-in-progress display) nil token))
+	       (if (eql timeout 0)
+		   (return-from read-input :timeout)
+		 (apply #'process-block "CLX Input Lock"
+			#'(lambda (display predicate &rest predicate-args)
+			    (declare (type display display)
+				     (dynamic-extent predicate-args)
+				     (type function predicate)
+				     (downward-funarg predicate))
+			    (or (apply predicate predicate-args)
+				(null (display-input-in-progress display))
+				(not (null (display-dead display)))))
+			display predicate predicate-args))
+	       (go loop))
+	     ;; Now start gobbling.
+	     (setq reply-buffer (allocate-event))
+	     (with-buffer-input (reply-buffer :sizes (8 16 32))
+	       (let ((type 0))
+		 (declare (type card8 type))
+		 ;; Wait for input before we disallow aborts.
+		 (unless (eql timeout 0)
+		   (let ((eof-p (buffer-input-wait display timeout)))
+		     (when eof-p (return-from read-input eof-p))))
+		 (without-aborts
+		   (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*
+					      (if force-output-p 0 timeout))))
+		     (when eof-p
+		       (when (eq eof-p :timeout)
+			 (if force-output-p
+			     (go force-output)
+			   (return-from read-input :timeout)))
+		       (setf (display-dead display) t)
+		       (return-from read-input eof-p)))
+		   (setf (reply-data-size reply-buffer) *replysize*)
+		   (when (= (the card8 (setq type (read-card8 0))) 1)
+		     ;; Normal replies can be longer than *replysize*, so we
+		     ;; have to handle them while aborts are still disallowed.
+		     (let ((value
+			     (read-reply-input
+			       display (read-card16 2)
+			       (index+ *replysize* (index* (read-card32 4) 4))
+			       (shiftf reply-buffer nil))))
+		       (when value
+			 (return-from read-input value))
+		       (go loop))))
+		 (if (zerop type)
+		     (read-error-input
+		       display (read-card16 2) (shiftf reply-buffer nil) token)
+		   (read-event-input
+		     display (read-card8 0) (shiftf reply-buffer nil)))))
+	     (go loop)
+	  force-output 
+	     (note-input-complete display token)
+	     (display-force-output display)
+	     (setq force-output-p nil)
+	     (go loop))
+      (when (not (null reply-buffer))
+	(deallocate-reply-buffer reply-buffer))
+      (note-input-complete display token))))
+
+(defun report-asynchronous-errors (display mode)
+  (when (and (display-asynchronous-errors display)
+	     (member mode (display-report-asynchronous-errors display)))
+    (let ((aborted t))
+      (unwind-protect 
+	  (loop
+	    (let ((error
+		    (with-event-queue-internal (display)
+		      (threaded-pop (display-asynchronous-errors display)
+				    reply-next reply-buffer))))
+	      (declare (type (or null reply-buffer) error))
+	      (if error
+		  (apply #'report-error display
+			 (prog1 (make-error display error t)
+				(deallocate-event error)))
+		(return (setq aborted nil)))))
+	;; If we get aborted out of this, deallocate all outstanding asynchronous
+	;; errors.
+	(when aborted 
+	  (with-event-queue-internal (display)
+	    (loop
+	      (let ((reply-buffer
+		      (threaded-pop (display-asynchronous-errors display)
+				    reply-next reply-buffer)))
+		(declare (type (or null reply-buffer) reply-buffer))
+		(if reply-buffer
+		    (deallocate-event reply-buffer)
+		  (return nil))))))))))
+
+(defun wait-for-event (display timeout force-output-p)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p))
+  (let ((event-process-p (not (eql timeout 0))))
+    (declare (type boolean event-process-p))
+    (unwind-protect
+	(loop
+	  (when event-process-p
+	    (conditional-store (display-event-process display) nil (current-process)))
+	  (let ((eof (read-input
+		       display timeout force-output-p 
+		       #'(lambda (display)
+			   (declare (type display display))
+			   (or (not (null (display-new-events display)))
+			       (and (display-asynchronous-errors display)
+				    (member :before-event-handling
+					    (display-report-asynchronous-errors display))
+				    t)))
+		       display)))
+	    (when eof (return eof)))
+	  ;; Report asynchronous errors here if the user wants us to.
+	  (when event-process-p
+	    (report-asynchronous-errors display :before-event-handling))
+	  (when (not (null (display-new-events display)))
+	    (return nil)))
+      (when (and event-process-p
+		 (eq (display-event-process display) (current-process)))
+	(setf (display-event-process display) nil)))))
+
+(defun read-reply (display pending-command)
+  (declare (type display display)
+	   (type pending-command pending-command))
+  (loop
+    (when (read-input display nil nil
+		      #'(lambda (pending-command)
+			  (declare (type pending-command pending-command))
+			  (not (null (pending-command-reply-buffer pending-command))))
+		      pending-command)
+      (x-error 'closed-display :display display))
+    (let ((reply-buffer
+	    (with-event-queue-internal (display)
+	      (threaded-pop (pending-command-reply-buffer pending-command)
+			    reply-next reply-buffer))))
+      (declare (type reply-buffer reply-buffer))
+      ;; Check for error.
+      (with-buffer-input (reply-buffer)
+	(ecase (read-card8 0)
+	  (0 (apply #'report-error display
+		    (prog1 (make-error display reply-buffer nil)
+			   (deallocate-reply-buffer reply-buffer))))
+	  (1 (return reply-buffer)))))))
+
+;;;
+
+(defun event-listen (display &optional (timeout 0))
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (values number-of-events-queued eof-or-timeout))
+  ;; Returns the number of events queued locally, if any, else nil.  Hangs
+  ;; waiting for events, forever if timeout is nil, else for the specified
+  ;; number of seconds.
+  (let* ((current-event-symbol (car (display-current-event-symbol display)))
+	 (current-event (and (boundp current-event-symbol)
+			     (symbol-value current-event-symbol)))
+	 (queue (or current-event (display-event-queue-head display))))
+    (declare (type symbol current-event-symbol)
+	     (type (or null reply-buffer) current-event queue))
+    (if queue
+	(values
+	  (with-event-queue-internal (display :timeout timeout)
+	    (threaded-length (or current-event (display-event-queue-head display))
+			     reply-next reply-buffer))
+	  nil)
+      (with-event-queue (display :timeout timeout :inline t)
+	(let ((eof-or-timeout (wait-for-event display timeout nil)))
+	  (if eof-or-timeout
+	      (values nil eof-or-timeout)
+	    (values 
+	      (with-event-queue-internal (display :timeout timeout)
+		(threaded-length (display-event-queue-head display)
+				 reply-next reply-buffer))
+	      nil)))))))
+
+(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
+  ;; The event is put at the head of the queue if append-p is nil, else the tail.
+  ;; Additional arguments depend on event-key, and are as specified above with
+  ;; declare-event, except that both resource-ids and resource objects are accepted
+  ;; in the event components.
+  (declare (type display display)
+	   (type event-key event-key)
+	   (type boolean append-p send-event-p)
+	   (dynamic-extent args))
+  (unless (get event-key 'event-code)
+    (x-type-error event-key 'event-key))
+  (let* ((event (allocate-event))
+	 (buffer (reply-ibuf8 event))
+	 (event-code (get event-key 'event-code)))
+    (declare (type reply-buffer event)
+	     (type buffer-bytes buffer)
+	     (type (or null card8) event-code))
+    (unless event-code (x-type-error event-key 'event-key))
+    (setf (event-code event) event-code)
+    (with-display (display)
+      (apply (svref *event-send-vector* event-code) display args)
+      (buffer-replace buffer
+		      (display-obuf8 display)
+		      0
+		      *replysize*
+		      (index+ 12 (buffer-boffset display)))
+      (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
+	    (aref buffer 2) 0
+	    (aref buffer 3) 0))
+    (with-event-queue (display)
+      (if append-p
+	  (enqueue-event event display)
+	(with-event-queue-internal (display)
+	  (threaded-requeue event
+			    (display-event-queue-head display)
+			    (display-event-queue-tail display)
+			    reply-next reply-buffer))))))
+
+(defun enqueue-event (new-event display)
+  (declare (type reply-buffer new-event)
+	   (type display display))
+  ;; Place EVENT at the end of the event queue for DISPLAY
+  (let* ((event-code (event-code new-event))
+	 (event-key (and (index< event-code (length *event-key-vector*))
+			 (svref *event-key-vector* event-code))))
+    (declare (type array-index event-code)
+	     (type (or null keyword) event-key))
+    (if (null event-key)
+	(unwind-protect
+	    (cerror "Ignore this event" "No handler for ~s event" event-key)
+	  (deallocate-event new-event))
+      (with-event-queue-internal (display)
+	(threaded-enqueue new-event
+			  (display-event-queue-head display)
+			  (display-event-queue-tail display)
+			  reply-next reply-buffer)
+	(unless (display-new-events display)
+	  (setf (display-new-events display) new-event))))))
+
+
+(defmacro define-event (name code)
+  `(eval-when (eval compile load)
+     (setf (svref *event-key-vector* ,code) ',name)
+     (setf (get ',name 'event-code) ,code)))
+
+;; Event names.  Used in "type" field in XEvent structures.  Not to be
+;; confused with event masks above.  They start from 2 because 0 and 1
+;; are reserved in the protocol for errors and replies. */
+
+(define-event :key-press 2)
+(define-event :key-release 3)
+(define-event :button-press 4)
+(define-event :button-release 5)
+(define-event :motion-notify 6)
+(define-event :enter-notify 7)
+(define-event :leave-notify 8)
+(define-event :focus-in 9)
+(define-event :focus-out 10)
+(define-event :keymap-notify 11)
+(define-event :exposure 12)
+(define-event :graphics-exposure 13)
+(define-event :no-exposure 14)
+(define-event :visibility-notify 15)
+(define-event :create-notify 16)
+(define-event :destroy-notify 17)
+(define-event :unmap-notify 18)
+(define-event :map-notify 19)
+(define-event :map-request 20)
+(define-event :reparent-notify 21)
+(define-event :configure-notify 22)
+(define-event :configure-request 23)
+(define-event :gravity-notify 24)
+(define-event :resize-request 25)
+(define-event :circulate-notify 26)
+(define-event :circulate-request 27)
+(define-event :property-notify 28)
+(define-event :selection-clear 29)
+(define-event :selection-request 30)
+(define-event :selection-notify 31)
+(define-event :colormap-notify 32)
+(define-event :client-message 33)
+(define-event :mapping-notify 34)
+
+
+(defmacro declare-event (event-codes &body declares)
+  ;; Used to indicate the keyword arguments for handler functions in
+  ;; process-event and event-case.
+  ;; Generates the functions used in SEND-EVENT.
+  ;; A compiler warning is printed when all of EVENT-CODES are not
+  ;; defined by a preceding DEFINE-EXTENSION.
+  ;; The body is a list of declarations, each of which has the form:
+  ;; (type . items)  Where type is a data-type, and items is a list of
+  ;; symbol names.  The item order corresponds to the order of fields
+  ;; in the event sent by the server.  An item may be a list of items.
+  ;; In this case, each item is aliased to the same event field.
+  ;; This is used to give all events an EVENT-WINDOW item.
+  ;; See the INPUT file for lots of examples.
+  (declare (type (or keyword list) event-codes)
+	   (type (alist (field-type symbol) (field-names list))
+                 declares))
+  (when (atom event-codes) (setq event-codes (list event-codes)))
+  (setq event-codes (mapcar #'canonicalize-event-name event-codes))
+  (let* ((keywords nil)
+	 (name (first event-codes))
+	 (get-macro (xintern name '-event-get-macro))
+	 (get-function (xintern name '-event-get))
+	 (put-function (xintern name '-event-put)))
+    (multiple-value-bind (get-code get-index get-sizes)
+	(get-put-items
+	  2 declares nil
+	  #'(lambda (type index item args)
+	      (flet ((event-get (type index item args)
+		       (unless (member type '(pad8 pad16))
+			 `(,(kintern item)
+			   (,(getify type) ,index ,@args)))))
+		(if (atom item)
+		    (event-get type index item args)
+		  (mapcan #'(lambda (item)
+			      (event-get type index item args))
+			  item)))))
+      (declare (ignore get-index))
+      (multiple-value-bind (put-code put-index put-sizes)
+	  (get-put-items
+	    2 declares t
+	    #'(lambda (type index item args)
+		(unless (member type '(pad8 pad16))
+		  (if (atom item)
+		      (progn
+			(push item keywords)
+			`((,(putify type) ,index ,item ,@args)))
+		    (let ((names (mapcar #'(lambda (name) (kintern name))
+					 item)))
+		      (setq keywords (append item keywords))
+		      `((,(putify type) ,index
+			 (check-consistency ',names ,@item) ,@args)))))))
+	(declare (ignore put-index))
+	`(within-definition (,name declare-event)
+	   (defun ,get-macro (display event-key variable)
+	     ;; Note: we take pains to macroexpand the get-code here to enable application
+	     ;; code to be compiled without having the CLX macros file loaded.
+	     (subst display '%buffer
+		    (getf `(:display (the display ,display)
+			    :event-key (the keyword ,event-key)
+			    :event-code (the card8 (logand #x7f (read-card8 0)))
+			    :send-event-p (the boolean (logbitp 7 (read-card8 0)))
+			    ,@',(mapcar #'macroexpand get-code))
+			  variable)))
+
+	   (defun ,get-function (display event handler)
+	     (declare (type display display)
+		      (type reply-buffer event))
+	     (declare (type function handler)
+		      (downward-funarg handler))
+	     (reading-event (event :display display :sizes (8 16 ,@get-sizes))
+	       (funcall handler
+			:display display
+			:event-key (svref *event-key-vector* (event-code event))
+			:event-code (logand #x7f (card8-get 0))
+			:send-event-p (logbitp 7 (card8-get 0))
+			,@get-code)))
+
+	   (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
+				 &allow-other-keys)
+	     (declare (type display display))
+	     ,(when (member 'sequence keywords)
+		`(unless sequence (setq sequence (display-request-number display))))
+	     (with-buffer-output (display :sizes ,put-sizes
+					  :index (index+ (buffer-boffset display) 12))
+	       ,@put-code))
+       
+	   ,@(mapcar #'(lambda (name)
+			 (allocate-extension-event-code name)
+			 `(let ((event-code (or (get ',name 'event-code)
+						(allocate-extension-event-code ',name))))
+			    (setf (svref *event-macro-vector* event-code)
+				  (function ,get-macro))
+			    (setf (svref *event-handler-vector* event-code)
+				  (function ,get-function))
+			    (setf (svref *event-send-vector* event-code)
+				  (function ,put-function))))
+		     event-codes)
+	   ',name)))))
+
+(defun check-consistency (names &rest args)
+  ;; Ensure all args are nil or have the same value.
+  ;; Returns the consistent non-nil value.
+  (let ((value (car args)))
+    (dolist (arg (cdr args))
+      (if value
+	  (when (and arg (not (eq arg value)))
+	    (x-error 'inconsistent-parameters
+		     :parameters (mapcan #'list names args)))
+	(setq value arg)))
+    value))
+
+(declare-event (:key-press :key-release :button-press :button-release)
+  ;; for key-press and key-release, code is the keycode
+  ;; for button-press and button-release, code is the button number
+  (data code)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  (boolean same-screen-p)
+  )
+
+(declare-event :motion-notify
+  ((data boolean) hint-p)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  (boolean same-screen-p))
+
+(declare-event (:enter-notify :leave-notify)
+  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  ((member8 :normal :grab :ungrab) mode)
+  ((bit 0) focus-p)
+  ((bit 1) same-screen-p))
+
+(declare-event (:focus-in :focus-out)
+  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
+		  :pointer :pointer-root :none))
+   kind)
+  (card16 sequence)
+  (window (window event-window))
+  ((member8 :normal :while-grabbed :grab :ungrab) mode))
+
+(declare-event :keymap-notify
+  ((bit-vector256 0) keymap))
+
+(declare-event :exposure
+  (card16 sequence)
+  (window (window event-window))
+  (card16 x y width height count))
+
+(declare-event :graphics-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card16 x y width height)
+  (card16 minor)  ;; Minor opcode
+  (card16 count)
+  (card8 major))
+
+(declare-event :no-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card16 minor)
+  (card8  major))
+
+(declare-event :visibility-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((member8 :unobscured :partially-obscured :fully-obscured) state))
+
+(declare-event :create-notify
+  (card16 sequence)
+  (window (parent event-window) window)
+  (int16 x y)
+  (card16 width height border-width)
+  (boolean override-redirect-p))
+
+(declare-event :destroy-notify
+  (card16 sequence)
+  (window event-window window))
+
+(declare-event :unmap-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean configure-p))
+
+(declare-event :map-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean override-redirect-p))
+
+(declare-event :map-request
+  (card16 sequence)
+  (window (parent event-window) window))
+
+(declare-event :reparent-notify
+  (card16 sequence)
+  (window event-window window parent)
+  (int16 x y)
+  (boolean override-redirect-p))
+
+(declare-event :configure-notify
+  (card16 sequence)
+  (window event-window window)
+  ((or null window) above-sibling)
+  (int16 x y)
+  (card16 width height border-width)
+  (boolean override-redirect-p))
+
+(declare-event :configure-request
+  ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
+  (card16 sequence)
+  (window (parent event-window) window)
+  ((or null window) above-sibling)
+  (int16 x y)
+  (card16 width height border-width value-mask))
+
+(declare-event :gravity-notify
+  (card16 sequence)
+  (window event-window window)
+  (int16 x y))
+
+(declare-event :resize-request
+  (card16 sequence)
+  (window (window event-window))
+  (card16 width height))
+
+(declare-event :circulate-notify
+  (card16 sequence)
+  (window event-window window parent)
+  ((member16 :top :bottom) place))
+
+(declare-event :circulate-request
+  (card16 sequence)
+  (window (parent event-window) window)
+  (pad16 1 2)
+  ((member16 :top :bottom) place))
+
+(declare-event :property-notify
+  (card16 sequence)
+  (window (window event-window))
+  (keyword atom) ;; keyword
+  (card32 time)
+  ((member16 :new-value :deleted) state))
+
+(declare-event :selection-clear
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window)) 
+  (keyword selection) ;; keyword
+  )
+
+(declare-event :selection-request
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window) requestor)
+  (keyword selection target)
+  ((or null keyword) property)
+  )
+
+(declare-event :selection-notify
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window))
+  (keyword selection target)
+  ((or null keyword) property)
+  )
+
+(declare-event :colormap-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((or null colormap) colormap)
+  (boolean new-p installed-p))
+
+(declare-event :client-message
+  (data format)
+  (card16 sequence)
+  (window (window event-window))
+  (keyword type)
+  ((client-message-sequence format) data))
+
+(declare-event :mapping-notify
+  (card16 sequence)
+  ((member8 :modifier :keyboard :pointer) request)
+  (card8 start) ;; first key-code
+  (card8 count))
+
+
+;;
+;; EVENT-LOOP
+;;
+
+(defun event-loop-setup (display)
+  (declare (type display display)
+	   (values progv-vars progv-vals
+		   current-event-symbol current-event-discarded-p-symbol))
+  (let* ((progv-vars (display-current-event-symbol display))
+	 (current-event-symbol (first progv-vars))
+	 (current-event-discarded-p-symbol (second progv-vars)))
+    (declare (type list progv-vars)
+	     (type symbol current-event-symbol current-event-discarded-p-symbol))
+    (values
+      progv-vars 
+      (list (if (boundp current-event-symbol)
+		;; The current event is already bound, so bind it to the next
+		;; event.
+		(let ((event (symbol-value current-event-symbol)))
+		  (declare (type (or null reply-buffer) event))
+		  (and event (reply-next (the reply-buffer event))))
+	      ;; The current event isn't bound, so bind it to the head of the
+	      ;; event queue.
+	      (display-event-queue-head display))
+	    nil)
+      current-event-symbol
+      current-event-discarded-p-symbol)))
+
+(defun event-loop-step-before (display timeout force-output-p current-event-symbol)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p)
+	   (type symbol current-event-symbol)
+	   (values event eof-or-timeout))
+  (unless (symbol-value current-event-symbol)
+    (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
+      (when eof-or-timeout
+	(return-from event-loop-step-before (values nil eof-or-timeout))))
+    (setf (symbol-value current-event-symbol) (display-new-events display)))
+  (let ((event (symbol-value current-event-symbol)))
+    (declare (type reply-buffer event))
+    (with-event-queue-internal (display)
+      (when (eq event (display-new-events display))
+	(setf (display-new-events display) (reply-next event))))
+    (values event nil)))
+
+(defvar *event-loop-version* 0)
+
+(defun dequeue-event (display event)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (values next))
+  ;; Remove the current event from the event queue
+  (with-event-queue-internal (display)
+    (let ((next (reply-next event))
+	  (head (display-event-queue-head display)))
+      (declare (type (or null reply-buffer) next head))
+      (when (eq event (display-new-events display))
+	(setf (display-new-events display) next))
+      (cond ((eq event head)
+	     (threaded-dequeue (display-event-queue-head display)
+			       (display-event-queue-tail display)
+			       reply-next reply-buffer))
+	    ((null head)
+	     (setq next nil))
+	    (t
+	     (do* ((previous head current)
+		   (current (reply-next previous) (reply-next previous)))
+		  ((or (null current) (eq event current))
+		   (when (eq event current)
+		     (when (eq current (display-event-queue-tail display))
+		       (setf (display-event-queue-tail display) previous))
+		     (setf (reply-next previous) next)))
+	       (declare (type reply-buffer previous)
+			(type (or null reply-buffer) current)))))
+      next)))
+
+(defun event-loop-step-after
+       (display event discard-p current-event-symbol current-event-discarded-p-symbol
+	&optional aborted)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type boolean discard-p aborted)
+	   (type symbol current-event-symbol current-event-discarded-p-symbol))
+  (when (and discard-p
+	     (not aborted)
+	     (not (symbol-value current-event-discarded-p-symbol)))
+    (discard-current-event display))
+  (let ((next (reply-next event)))
+    (declare (type (or null reply-buffer) next))
+    (when (symbol-value current-event-discarded-p-symbol)
+      (setf (symbol-value current-event-discarded-p-symbol) nil)
+      (ecase *event-loop-version*
+	;; in version 0 discard-current-event dequeues the event.
+	(0 )
+	;; in version 1 event-loop-step-after dequeues the event.
+	(1 (setq next (dequeue-event display event))))
+      (deallocate-event event))
+    (setf (symbol-value current-event-symbol) next)))
+
+(defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
+  ;; Bind EVENT to the events for DISPLAY.
+  ;; This is the "GUTS" of process-event and event-case.
+  `(let ((*event-loop-version* 1)
+	 (.display. ,display)
+	 (.timeout. ,timeout)
+	 (.force-output-p. ,force-output-p)
+	 (.discard-p. ,discard-p))
+     (declare (type display .display.)
+	      (type (or null number) .timeout.)
+	      (type boolean .force-output-p. .discard-p.))
+     (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
+       (multiple-value-bind (.progv-vars. .progv-vals.
+			     .current-event-symbol. .current-event-discarded-p-symbol.)
+	   (event-loop-setup .display.)
+	 (declare (type list .progv-vars. .progv-vals.)
+		  (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
+	 (progv .progv-vars. .progv-vals.
+	   (loop
+	     (multiple-value-bind (.event. .eof-or-timeout.)
+		 (event-loop-step-before
+		   .display. .timeout. .force-output-p.
+		   .current-event-symbol.)
+	       (declare (type (or null reply-buffer) .event.))
+	       (when (null .event.) (return (values nil .eof-or-timeout.)))
+	       (let ((.aborted. t))
+		 (unwind-protect 
+		     (progn
+		       (let ((,event .event.))
+			 (declare (type reply-buffer ,event))
+			 ,@body)
+		       (setq .aborted. nil))
+		   (event-loop-step-after
+		     .display. .event. .discard-p.
+		     .current-event-symbol. .current-event-discarded-p-symbol.
+		     .aborted.))))))))))
+
+(defun discard-current-event (display)
+  ;; Discard the current event for DISPLAY.
+  ;; Returns NIL when the event queue is empty, else T.
+  ;; To ensure events aren't ignored, application code should only call
+  ;; this when throwing out of event-case or process-next-event, or from
+  ;; inside even-case, event-cond or process-event when :peek-p is T and
+  ;; :discard-p is NIL.
+  (declare (type display display)
+	   (values boolean))
+  (let* ((symbols (display-current-event-symbol display))
+	 (event
+	   (let ((current-event-symbol (first symbols)))
+	     (declare (type symbol current-event-symbol))
+	     (when (boundp current-event-symbol)
+	       (symbol-value current-event-symbol)))))
+    (declare (type list symbols)
+	     (type (or null reply-buffer) event))
+    (unless (null event)
+      (ecase *event-loop-version*
+	;; in version 0 discard-current-event dequeues the event.
+	(0 (setf (reply-next (the reply-buffer event))
+		 (dequeue-event display event)))
+	;; in version 1 event-loop-step-after dequeues the event.
+	(1 ))
+      ;; Set the discarded-p flag
+      (let ((current-event-discarded-p-symbol (second symbols)))
+	(declare (type symbol current-event-discarded-p-symbol))
+	(when (boundp current-event-discarded-p-symbol)
+	  (setf (symbol-value current-event-discarded-p-symbol) t)))
+      ;; Return whether the event queue is empty
+      (not (null (reply-next (the reply-buffer event)))))))
+
+;;
+;; PROCESS-EVENT
+;;
+(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
+  ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
+  ;; on each queued event until handler returns non-nil, and that returned object is
+  ;; then returned by process-event.  If peek-p is true, then the event is not
+  ;; removed from the queue.  If discard-p is true, then events for which handler
+  ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
+  ;; until non-nil is generated for some event, or for the specified timeout (in
+  ;; seconds, if given); however, it is acceptable for an implementation to wait only
+  ;; once on network data, and therefore timeout prematurely.  Returns nil on
+  ;; timeout.  If handler is a sequence, it is expected to contain handler functions
+  ;; specific to each event class; the event code is used to index the sequence,
+  ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
+  ;; with resource objects.  The arguments to the handler are described using declare-event.
+  ;;
+  ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
+  ;; from the queue (it is left in place), NIL means the event is removed.
+  
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean peek-p discard-p force-output-p))
+  (declare (type t handler)
+	   (downward-funarg #+Genera * #-Genera handler))
+  (event-loop (display event timeout force-output-p discard-p)
+    (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
+	   (event-decoder (and (index< event-code (length *event-handler-vector*))
+			       (svref *event-handler-vector* event-code))))
+      (declare (type array-index event-code)
+	       (type (or null function) event-decoder))
+      (if event-decoder
+	  (let ((event-handler (if (functionp handler)
+				   handler
+				   (and (type? handler 'sequence)
+					(< event-code (length handler))
+					(elt handler event-code)))))
+	    (if event-handler
+		(let ((result (funcall event-decoder display event event-handler)))
+		  (when result
+		    (unless peek-p
+		      (discard-current-event display))
+		    (return result)))
+	      (cerror "Ignore this event"
+		      "No handler for ~s event"
+		      (svref *event-key-vector* event-code))))
+	(cerror "Ignore this event"
+		"Server Error: event with unknown event code ~d received."
+		event-code)))))
+
+(defun make-event-handlers (&key (type 'array) default)
+  (declare (type t type)			;Sequence type specifier
+	   (type function default)
+	   (values sequence))			;Default handler for initial content
+  ;; Makes a handler sequence suitable for process-event
+  (make-sequence type *max-events* :initial-element default))
+   
+(defun event-handler (handlers event-key)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (values function))
+  ;; Accessor for a handler sequence
+  (elt handlers (position event-key *event-key-vector* :test #'eq)))
+
+(defun set-event-handler (handlers event-key handler)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (type function handler)
+	   (values handler))
+  (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
+
+(defsetf event-handler set-event-handler)
+
+;;
+;; EVENT-CASE
+;; 
+
+(defmacro event-case ((&rest args) &body clauses)
+  ;; If force-output-p is true, first invokes display-force-output.  Executes the
+  ;; matching clause for each queued event until a clause returns non-nil, and that
+  ;; returned object is then returned by event-case.  If peek-p is true, then the
+  ;; event is not removed from the queue.  If discard-p is true, then events for
+  ;; which the clause returns nil are removed from the queue, otherwise they are left
+  ;; in place.  Hangs until non-nil is generated for some event, or for the specified
+  ;; timeout (in seconds, if given); however, it is acceptable for an implementation
+  ;; to wait only once on network data, and therefore timeout prematurely.  Returns
+  ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
+  ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
+  ;; (but only in the last clause).  The keys are not evaluated, and it is an error
+  ;; for the same key to appear in more than one clause.  Args is the list of event
+  ;; components of interest; corresponding values (if any) are bound to variables
+  ;; with these names (i.e., the args are variable names, not keywords, the keywords
+  ;; are derived from the variable names).  An arg can also be a (keyword var) form,
+  ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
+  ;; equivalent to having one that returns nil.
+  (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
+		   (event-or-events ((&rest args) |...|) &body body) |...|))
+  ;; Event-case is just event-cond with the whole body in the test-form
+  `(event-cond ,args
+	       ,@(mapcar
+		   #'(lambda (clause)
+		       `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
+		   clauses)))
+
+;;
+;; EVENT-COND
+;; 
+
+(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
+		      &body clauses)
+  ;; The clauses of event-cond are of the form:
+  ;; (event-or-events binding-list test-form . body-forms)
+  ;;
+  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
+  ;;			need not be typed as keywords) or the symbol t
+  ;;			or otherwise (but only in the last clause).  If
+  ;;			no t/otherwise clause appears, it is equivalent
+  ;;			to having one that returns nil.  The keys are
+  ;;			not evaluated, and it is an error for the same
+  ;;			key to appear in more than one clause.
+  ;;
+  ;; BINDING-LIST	The list of event components of interest.
+  ;;			corresponding values (if any) are bound to
+  ;;			variables with these names (i.e., the binding-list
+  ;;			has variable names, not keywords, the keywords are
+  ;;			derived from the variable names).  An arg can also
+  ;;			be a (keyword var) form, as for keyword args in a
+  ;;			lambda list.
+  ;;
+  ;; The matching TEST-FORM for each queued event is executed until a
+  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
+  ;; evaluated, returning the (possibly multiple) values of the last
+  ;; form from event-cond.  If there are no body-forms then, if the
+  ;; test-form is non-nil, the value of the test-form is returned as a
+  ;; single value.
+  ;;
+  ;; Options:
+  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
+  ;;		  	input is pending.
+  ;;
+  ;; PEEK-P		When true, then the event is not removed from the queue.
+  ;;
+  ;; DISCARD-P		When true, then events for which the clause returns nil
+  ;; 			are removed from the queue, otherwise they are left in place.
+  ;;
+  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
+  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
+  ;;			elapsed.
+  ;;
+  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
+		   (event-or-events (&rest args) test-form &body body) |...|))
+  (let ((event (gensym))
+	(disp (gensym))
+	(peek (gensym)))
+    `(let ((,disp ,display)
+	   (,peek ,peek-p))
+       (declare (type display ,disp))
+       (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
+	 (event-dispatch (,disp ,event ,peek) ,@clauses)))))
+
+(defun get-event-code (event)
+  ;; Returns the event code given an event-key
+  (declare (type event-key event))
+  (declare (values card8))
+  (or (get event 'event-code)
+      (x-type-error event 'event-key)))
+
+(defun universal-event-get-macro (display event-key variable)
+  (getf
+    `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
+	       (the card8 (logand 127 (read-card8 0))) :send-event-p
+	       (the boolean (logbitp 7 (read-card8 0))))
+    variable))
+
+(defmacro event-dispatch ((display event peek-p) &body clauses)
+  ;; Helper macro for event-case
+  ;; CLAUSES are of the form:
+  ;; (event-or-events binding-list test-form . body-forms)
+  (let ((event-key (gensym))
+	(all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
+    `(reading-event (,event)
+       (let ((,event-key (svref *event-key-vector* (event-code ,event))))
+	 (case ,event-key
+	   ,@(mapcar
+	       #'(lambda (clause)		; Translate event-cond clause to case clause
+		   (let* ((events (first clause))
+			  (arglist (second clause))
+			  (test-form (third clause))
+			  (body-forms (cdddr clause)))
+		     (flet ((event-clause (display peek-p first-form rest-of-forms)
+			      (if rest-of-forms
+				  `(when ,first-form
+				     (unless ,peek-p (discard-current-event ,display))
+				     (return (progn ,@rest-of-forms)))
+				;; No body forms, return the result of the test form
+				(let ((result (gensym)))
+				  `(let ((,result ,first-form))
+				     (when ,result
+				       (unless ,peek-p (discard-current-event ,display))
+				       (return ,result)))))))
+
+		       (if (member events '(otherwise t))
+			   ;; code for OTHERWISE clause.
+			   ;; Find all events NOT used by other clauses
+			   (let ((keys (do ((i 0 (1+ i))
+					    (key nil)
+					    (result nil))
+					   ((>= i *max-events*) result)
+					 (setq key (svref *event-key-vector* i))
+					 (when (and key (zerop (aref all-events i)))
+					   (push key result)))))
+			     `(otherwise
+				(binding-event-values
+				  (,display ,event-key ,(or keys :universal) ,@arglist)
+				  ,(event-clause display peek-p test-form body-forms))))
+
+			 ;; Code for normal clauses
+			 (let (true-events) ;; canonicalize event-names
+			   (if (consp events)
+			       (progn
+				 (setq true-events (mapcar #'canonicalize-event-name events))
+				 (dolist (event true-events)
+				   (setf (aref all-events (get-event-code event)) 1)))
+			     (setf true-events (canonicalize-event-name events)
+				   (aref all-events (get-event-code true-events)) 1))
+			   `(,true-events
+			     (binding-event-values
+			       (,display ,event-key ,true-events ,@arglist)
+			       ,(event-clause display peek-p test-form body-forms))))))))
+	       clauses))))))
+
+(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
+  ;; Execute BODY with the variables in VALUE-LIST bound to components of the
+  ;; EVENT-KEYS events.
+  (unless (consp event-keys) (setq event-keys (list event-keys)))
+  (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
+	 (var-symbol (var) (if (consp var) (second var) var)))
+    ;; VARS is an alist of:
+    ;;  (component-key ((event-key event-key ...) . extraction-code)
+    ;;		       ((event-key event-key ...) . extraction-code) ...)
+    ;; There should probably be accessor macros for this, instead of things like cdadr.
+    (let ((vars (mapcar #'(lambda (var) (list var)) value-list))
+	  (multiple-p nil))
+      ;; Fill in the VARS alist with event-keys and extraction-code
+      (do ((keys event-keys (cdr keys))
+	   (temp nil))
+	  ((endp keys))
+	(let* ((key (car keys))
+	       (binder (case key
+			 (:universal #'universal-event-get-macro)
+			 (otherwise (svref *event-macro-vector* (get-event-code key))))))
+	  (dolist (var vars)
+	    (let ((code (funcall binder display event-key (var-key (car var)))))
+	      (unless code (warn "~a isn't a component of the ~s event"
+				 (var-key (car var)) key))
+	      (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
+		  (push key (caar temp))
+		(push `((,key) . ,code) (cdr var)))))))
+      ;; Bind all the values
+      `(let ,(mapcar #'(lambda (var)
+			 (if (cddr var) ;; if more than one binding form
+			     (progn (setq multiple-p t)
+				    (var-symbol (car var)))
+			   (list (var-symbol (car var)) (cdadr var))))
+		     vars)
+	 ;; When some values come from different places, generate code to set them
+	 ,(when multiple-p
+	    `(case ,event-key
+	       ,@(do ((keys event-keys (cdr keys))
+		      (clauses nil) ;; alist of (event-keys bindings)
+		      (clause nil nil)
+		      (temp))
+		     ((endp keys)
+		      (dolist (clause clauses)
+			(unless (cdar clause) ;; Atomize single element lists
+			  (setf (car clause) (caar clause))))
+		      clauses)
+		   ;; Gather up all the bindings associated with (car keys)
+		   (dolist (var vars)
+		     (when (cddr var) ;; when more than one binding form
+		       (dolist (events (cdr var))
+			 (when (member (car keys) (car events))
+			   ;; Optimize for event-window being the same as some other binding
+			   (if (setq temp (member (cdr events) clause
+						  :key #'caddr
+						  :test #'equal))
+			       (setq clause
+				     (nconc clause `((setq ,(car var) ,(second (car temp))))))
+			     (push `(setq ,(car var) ,(cdr events)) clause))))))
+		   ;; Merge bindings for (car keys) with other bindings
+		   (when clause
+		     (if (setq temp (member clause clauses :key #'cdr :test #'equal))
+			 (push (car keys) (caar temp))
+		       (push `((,(car keys)) . ,clause) clauses))))))
+	 ,@body))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Error Handling
+;;;-----------------------------------------------------------------------------
+
+(eval-when (eval compile load)
+(defparameter
+  *xerror-vector*
+  '#(unknown-error
+     request-error				; 1  bad request code
+     value-error				; 2  integer parameter out of range
+     window-error				; 3  parameter not a Window
+     pixmap-error				; 4  parameter not a Pixmap
+     atom-error					; 5  parameter not an Atom
+     cursor-error				; 6  parameter not a Cursor
+     font-error					; 7  parameter not a Font
+     match-error				; 8  parameter mismatch
+     drawable-error				; 9  parameter not a Pixmap or Window
+     access-error				; 10 attempt to access private resource"
+     alloc-error				; 11 insufficient resources
+     colormap-error				; 12 no such colormap
+     gcontext-error				; 13 parameter not a GContext
+     id-choice-error				; 14 invalid resource ID for this connection
+     name-error					; 15 font or color name does not exist
+     length-error				; 16 request length incorrect;
+						;    internal Xlib error
+     implementation-error			; 17 server is defective
+     ))
+)
+
+(defun make-error (display event asynchronous)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type boolean asynchronous))
+  (reading-event (event)
+    (let* ((error-code (read-card8 1))
+	   (error-key (get-error-key display error-code))
+	   (error-decode-function (get error-key 'error-decode-function))
+	   (params (funcall error-decode-function display event)))
+      (list* error-code error-key
+	     :asynchronous asynchronous :current-sequence (display-request-number display)
+	     params))))
+
+(defun report-error (display error-code error-key &rest params)
+  (declare (type display display)
+	   (dynamic-extent params))
+  ;; All errors (synchronous and asynchronous) are processed by calling
+  ;; an error handler in the display.  The handler is called with the display
+  ;; as the first argument and the error-key as its second argument. If handler is
+  ;; an array it is expected to contain handler functions specific to
+  ;; each error; the error code is used to index the array, fetching the
+  ;; appropriate handler. Any results returned by the handler are ignored;;
+  ;; it is assumed the handler either takes care of the error completely,
+  ;; or else signals. For all core errors, additional keyword/value argument
+  ;; pairs are:
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;;    :current-sequence integer
+  ;;    :asynchronous (member t nil)
+  ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
+  ;; errors another pair is:
+  ;;    :resource-id integer
+  ;; For :atom errors, another pair is:
+  ;;    :atom-id integer
+  ;; For :value errors, another pair is:
+  ;;    :value integer
+  (let* ((handler (display-error-handler display))
+	 (handler-function
+	   (if (type? handler 'sequence)
+	       (elt handler error-code)
+	     handler)))
+    (apply handler-function display error-key params)))
+
+(defun request-name (code &optional display)
+  (if (< code (length *request-names*))
+      (svref *request-names* code)
+    (dolist (extension (and display (display-extension-alist display)) "unknown")
+      (when (= code (second extension))
+	(return (first extension))))))
+
+#-(or ansi-common-lisp excl lcl3.0)
+(define-condition request-error (x-error)
+  (display
+   error-key
+   major
+   minor
+   sequence
+   current-sequence
+   asynchronous)
+  (:report report-request-error))
+
+(defun report-request-error (condition stream)
+  (let ((error-key (request-error-error-key condition))
+	(asynchronous (request-error-asynchronous condition))
+	(major (request-error-major condition))
+	(minor (request-error-minor condition))
+	(sequence (request-error-sequence condition))
+	(current-sequence (request-error-current-sequence condition)))		   
+    (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
+	    asynchronous error-key (= sequence current-sequence)
+	    sequence current-sequence major minor
+	    (request-name major (request-error-display condition)))))
+
+;; Since the :report arg is evaluated as (function report-request-error) the
+;; define-condition must come after the function definition.
+#+(or ansi-common-lisp excl lcl3.0)
+(define-condition request-error (x-error)
+  (display
+   error-key
+   major
+   minor
+   sequence
+   current-sequence
+   asynchronous)
+  (:report report-request-error))
+
+(define-condition resource-error (request-error)
+  (resource-id)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " ID #x~x" (resource-error-resource-id condition)))))  
+
+(define-condition unknown-error (request-error)
+  (error-code)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Error Code ~d." (unknown-error-error-code condition)))))
+
+(define-condition access-error (request-error))
+
+(define-condition alloc-error (request-error))
+
+(define-condition atom-error (request-error)
+  (atom-id)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
+
+(define-condition colormap-error (resource-error))
+
+(define-condition cursor-error (resource-error))
+
+(define-condition drawable-error (resource-error))
+
+(define-condition font-error (resource-error))
+
+(define-condition gcontext-error (resource-error))
+
+(define-condition id-choice-error (resource-error))
+
+(define-condition illegal-request-error (request-error))
+
+(define-condition length-error (request-error))
+
+(define-condition match-error (request-error))
+
+(define-condition name-error (request-error))
+
+(define-condition pixmap-error (resource-error))
+
+(define-condition value-error (request-error)
+  (value)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Value ~d." (value-error-value condition)))))
+
+(define-condition window-error (resource-error))
+
+(define-condition implementation-error (request-error))
+
+;;-----------------------------------------------------------------------------
+;; Internal error conditions signaled by CLX
+
+(define-condition x-type-error (type-error)
+  (type-string)
+  (:report (lambda (condition stream)
+	     (format stream "~s isn't a ~a"
+		     (type-error-datum condition)
+		     (or (x-type-error-type-string condition)
+			 (type-error-expected-type condition))))))
+
+(define-condition closed-display (x-error)
+  (display)
+  (:report (lambda (condition stream)
+	     (format stream "Attempt to use closed display ~s"
+		     (closed-display-display condition)))))
+
+(define-condition lookup-error (x-error)
+  (id display type object)
+  (:report (lambda (condition stream)
+	     (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
+		     (lookup-error-id condition)
+		     (lookup-error-display condition)
+		     (lookup-error-type condition)
+		     (lookup-error-object condition)))))  
+
+(define-condition connection-failure (x-error)
+  (major-version
+   minor-version
+   host
+   display
+   reason)
+  (:report (lambda (condition stream)
+	     (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
+		     (connection-failure-major-version condition)
+		     (connection-failure-minor-version condition)
+		     (connection-failure-host condition)
+		     (connection-failure-display condition)
+		     (connection-failure-reason condition)))))
+  
+(define-condition reply-length-error (x-error)
+  (reply-length
+   expected-length
+   display)
+  (:report (lambda (condition stream)
+	     (format stream "Reply length was ~d when ~d words were expected for display ~s"
+		     (reply-length-error-reply-length condition)
+		     (reply-length-error-expected-length condition)
+		     (reply-length-error-display condition)))))  
+
+(define-condition reply-timeout (x-error)
+  (timeout
+   display)
+  (:report (lambda (condition stream)
+	     (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
+		     (reply-timeout-timeout condition)
+		     (reply-timeout-display condition)))))  
+
+(define-condition sequence-error (x-error)
+  (display
+   req-sequence
+   msg-sequence)
+  (:report (lambda (condition stream)
+	     (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
+		     (sequence-error-display condition)
+		     (sequence-error-req-sequence condition)
+		     (sequence-error-msg-sequence condition)))))  
+
+(define-condition unexpected-reply (x-error)
+  (display
+   msg-sequence
+   req-sequence
+   length)
+  (:report (lambda (condition stream)
+	     (format stream "Display ~s received a server reply when none was expected.~@
+		             Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
+		  (unexpected-reply-display condition)
+		  (unexpected-reply-req-sequence condition)
+		  (unexpected-reply-msg-sequence condition)
+		  (unexpected-reply-length condition)))))
+
+(define-condition missing-parameter (x-error)
+  (parameter)
+  (:report (lambda (condition stream)
+	     (let ((parm (missing-parameter-parameter condition)))
+	       (if (consp parm)
+		   (format stream "One or more of the required parameters ~a is missing."
+			   parm)
+		 (format stream "Required parameter ~a is missing or null." parm))))))
+
+;; This can be signalled anywhere a pseudo font access fails.
+(define-condition invalid-font (x-error)
+  (font)
+  (:report (lambda (condition stream)
+	     (format stream "Can't access font ~s" (invalid-font-font condition)))))
+
+(define-condition device-busy (x-error)
+  (display)
+  (:report (lambda (condition stream)
+	     (format stream "Device busy for display ~s"
+		     (device-busy-display condition)))))
+
+(define-condition unimplemented-event (x-error)
+  (display
+   event-code)
+  (:report (lambda (condition stream)
+	     (format stream "Event code ~d not implemented for display ~s"
+		     (unimplemented-event-event-code condition)
+		     (unimplemented-event-display condition)))))
+
+(define-condition undefined-event (x-error)
+  (display
+   event-name)
+  (:report (lambda (condition stream)
+	     (format stream "Event code ~d undefined for display ~s"
+		     (undefined-event-event-name condition)
+		     (undefined-event-display condition)))))
+
+(define-condition absent-extension (x-error)
+  (name display)
+  (:report (lambda (condition stream)
+	     (format stream "Extension ~a isn't defined for display ~s"
+		     (absent-extension-name condition)
+		     (absent-extension-display condition)))))
+
+(define-condition inconsistent-parameters (x-error)
+  (parameters)
+  (:report (lambda (condition stream)
+	     (format stream "inconsistent-parameters:~{ ~s~}"
+		     (inconsistent-parameters-parameters condition)))))
+
+(defun get-error-key (display error-code)
+  (declare (type display display)
+	   (type array-index error-code))
+  ;; Return the error-key associated with error-code
+  (if (< error-code (length *xerror-vector*))
+      (svref *xerror-vector* error-code)
+    ;; Search the extensions for the error
+    (dolist (entry (display-extension-alist display) 'unknown-error)
+      (let* ((event-name (first entry))
+	     (first-error (fourth entry))
+	     (errors (third (assoc event-name *extensions*))))
+	(declare (type keyword event-name)
+		 (type array-index first-error)
+		 (type list errors))
+	(when (and errors
+		   (index<= first-error error-code
+			    (index+ first-error (index- (length errors) 1))))
+	  (return (nth (index- error-code first-error) errors)))))))
+
+(defmacro define-error (error-key function)
+  ;; Associate a function with ERROR-KEY which will be called with
+  ;; parameters DISPLAY and REPLY-BUFFER and
+  ;; returns a plist of keyword/value pairs which will be passed on
+  ;; to the error handler.  A compiler warning is printed when
+  ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
+  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
+  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
+  ;;       an example.
+  (declare (type symbol error-key)
+	   (type function function))
+  ;; First ensure the name is for a declared extension
+  (unless (or (find error-key *xerror-vector*)
+	      (dolist (extension *extensions*)
+		(when (member error-key (third extension))
+		  (return t))))
+    (x-type-error error-key 'error-key))
+  `(setf (get ',error-key 'error-decode-function) (function ,function)))
+
+;; All core errors use this, so we make it available to extensions.
+(defun decode-core-error (display event &optional arg)
+  ;; All core errors have the following keyword/argument pairs:
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;; In addition, many have an additional argument that comes from the
+  ;; same place in the event, but is named differently.  When the ARG
+  ;; argument is specified, the keyword ARG with card32 value starting
+  ;; at byte 4 of the event is returned with the other keyword/argument
+  ;; pairs.
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type (or null keyword) arg))
+  (declare (values keyword/arg-plist))
+  display
+  (reading-event (event)
+    (let* ((sequence (read-card16 2))
+	   (minor-code (read-card16 8))
+	   (major-code (read-card8 10))
+	   (result (list :major major-code
+			 :minor minor-code
+			 :sequence sequence)))
+      (when arg
+	(setq result (list* arg (read-card32 4) result)))
+      result)))
+
+(defun decode-resource-error (display event)
+  (decode-core-error display event :resource-id))
+
+(define-error unknown-error
+  (lambda (display event)
+    (list* :error-code (aref (reply-ibuf8 event) 1)
+	   (decode-core-error display event))))
+
+(define-error request-error decode-core-error)		; 1  bad request code
+
+(define-error value-error				; 2  integer parameter out of range
+  (lambda (display event)
+    (decode-core-error display event :value)))
+
+(define-error window-error decode-resource-error)	; 3  parameter not a Window
+
+(define-error pixmap-error decode-resource-error)	; 4  parameter not a Pixmap
+
+(define-error atom-error				; 5  parameter not an Atom
+  (lambda (display event)
+    (decode-core-error display event :atom-id)))
+
+(define-error cursor-error decode-resource-error)	; 6  parameter not a Cursor
+
+(define-error font-error decode-resource-error)		; 7  parameter not a Font
+
+(define-error match-error decode-core-error)		; 8  parameter mismatch
+
+(define-error drawable-error decode-resource-error)	; 9  parameter not a Pixmap or Window
+
+(define-error access-error decode-core-error)		; 10 attempt to access private resource"
+
+(define-error alloc-error decode-core-error)		; 11 insufficient resources
+
+(define-error colormap-error decode-resource-error)	; 12 no such colormap
+
+(define-error gcontext-error decode-resource-error)	; 13 parameter not a GContext
+
+(define-error id-choice-error decode-resource-error)	; 14 invalid resource ID for this connection
+
+(define-error name-error decode-core-error)		; 15 font or color name does not exist
+
+(define-error length-error decode-core-error)		; 16 request length incorrect;
+							;    internal Xlib error
+
+(define-error implementation-error decode-core-error)	; 17 server is defective
diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp
new file mode 100644
index 000000000..96d160b83
--- /dev/null
+++ b/clx/keysyms.lisp
@@ -0,0 +1,408 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
+
+;;; Define lisp character to keysym mappings
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(define-keysym-set :latin-1	(keysym 0 0) (keysym 0 255))
+(define-keysym-set :latin-2	(keysym 1 0) (keysym 1 255))
+(define-keysym-set :latin-3	(keysym 2 0) (keysym 2 255))
+(define-keysym-set :latin-4	(keysym 3 0) (keysym 3 255))
+(define-keysym-set :kana	(keysym 4 0) (keysym 4 255))
+(define-keysym-set :arabic	(keysym 5 0) (keysym 5 255))
+(define-keysym-set :cryllic	(keysym 6 0) (keysym 6 255))
+(define-keysym-set :greek	(keysym 7 0) (keysym 7 255))
+(define-keysym-set :tech	(keysym 8 0) (keysym 8 255))
+(define-keysym-set :special	(keysym 9 0) (keysym 9 255))
+(define-keysym-set :publish	(keysym 10 0) (keysym 10 255))
+(define-keysym-set :apl		(keysym 11 0) (keysym 11 255))
+(define-keysym-set :hebrew	(keysym 12 0) (keysym 12 255))
+(define-keysym-set :keyboard	(keysym 255 0) (keysym 255 255))
+
+(define-keysym :character-set-switch character-set-switch-keysym)
+(define-keysym :left-shift left-shift-keysym)
+(define-keysym :right-shift right-shift-keysym)
+(define-keysym :left-control left-control-keysym)
+(define-keysym :right-control right-control-keysym)
+(define-keysym :caps-lock caps-lock-keysym)
+(define-keysym :shift-lock shift-lock-keysym)
+(define-keysym :left-meta left-meta-keysym)
+(define-keysym :right-meta right-meta-keysym)
+(define-keysym :left-alt left-alt-keysym)
+(define-keysym :right-alt right-alt-keysym)
+(define-keysym :left-super left-super-keysym)
+(define-keysym :right-super right-super-keysym)
+(define-keysym :left-hyper left-hyper-keysym)
+(define-keysym :right-hyper right-hyper-keysym)
+
+(define-keysym #\space 032)
+(define-keysym #\! 033)
+(define-keysym #\" 034)
+(define-keysym #\# 035)
+(define-keysym #\$ 036)
+(define-keysym #\% 037)
+(define-keysym #\& 038)
+(define-keysym #\' 039)
+(define-keysym #\( 040)
+(define-keysym #\) 041)
+(define-keysym #\* 042)
+(define-keysym #\+ 043)
+(define-keysym #\, 044)
+(define-keysym #\- 045)
+(define-keysym #\. 046)
+(define-keysym #\/ 047)
+(define-keysym #\0 048)
+(define-keysym #\1 049)
+(define-keysym #\2 050)
+(define-keysym #\3 051)
+(define-keysym #\4 052)
+(define-keysym #\5 053)
+(define-keysym #\6 054)
+(define-keysym #\7 055)
+(define-keysym #\8 056)
+(define-keysym #\9 057)
+(define-keysym #\: 058)
+(define-keysym #\; 059)
+(define-keysym #\< 060)
+(define-keysym #\= 061)
+(define-keysym #\> 062)
+(define-keysym #\? 063)
+(define-keysym #\@ 064)
+(define-keysym #\A 065 :lowercase 097)
+(define-keysym #\B 066 :lowercase 098)
+(define-keysym #\C 067 :lowercase 099)
+(define-keysym #\D 068 :lowercase 100)
+(define-keysym #\E 069 :lowercase 101)
+(define-keysym #\F 070 :lowercase 102)
+(define-keysym #\G 071 :lowercase 103)
+(define-keysym #\H 072 :lowercase 104)
+(define-keysym #\I 073 :lowercase 105)
+(define-keysym #\J 074 :lowercase 106)
+(define-keysym #\K 075 :lowercase 107)
+(define-keysym #\L 076 :lowercase 108)
+(define-keysym #\M 077 :lowercase 109)
+(define-keysym #\N 078 :lowercase 110)
+(define-keysym #\O 079 :lowercase 111)
+(define-keysym #\P 080 :lowercase 112)
+(define-keysym #\Q 081 :lowercase 113)
+(define-keysym #\R 082 :lowercase 114)
+(define-keysym #\S 083 :lowercase 115)
+(define-keysym #\T 084 :lowercase 116)
+(define-keysym #\U 085 :lowercase 117)
+(define-keysym #\V 086 :lowercase 118)
+(define-keysym #\W 087 :lowercase 119)
+(define-keysym #\X 088 :lowercase 120)
+(define-keysym #\Y 089 :lowercase 121)
+(define-keysym #\Z 090 :lowercase 122)
+(define-keysym #\[ 091)
+(define-keysym #\\ 092)
+(define-keysym #\] 093)
+(define-keysym #\^ 094)
+(define-keysym #\_ 095)
+(define-keysym #\` 096)
+(define-keysym #\a 097)
+(define-keysym #\b 098)
+(define-keysym #\c 099)
+(define-keysym #\d 100)
+(define-keysym #\e 101)
+(define-keysym #\f 102)
+(define-keysym #\g 103)
+(define-keysym #\h 104)
+(define-keysym #\i 105)
+(define-keysym #\j 106)
+(define-keysym #\k 107)
+(define-keysym #\l 108)
+(define-keysym #\m 109)
+(define-keysym #\n 110)
+(define-keysym #\o 111)
+(define-keysym #\p 112)
+(define-keysym #\q 113)
+(define-keysym #\r 114)
+(define-keysym #\s 115)
+(define-keysym #\t 116)
+(define-keysym #\u 117)
+(define-keysym #\v 118)
+(define-keysym #\w 119)
+(define-keysym #\x 120)
+(define-keysym #\y 121)
+(define-keysym #\z 122)
+(define-keysym #\{ 123)
+(define-keysym #\| 124)
+(define-keysym #\} 125)
+(define-keysym #\~ 126)
+
+(progn   ;; Semi-standard characters
+  (define-keysym #\rubout (keysym 255 255))	; :tty
+  (define-keysym #\tab (keysym 255 009))	; :tty
+  (define-keysym #\linefeed (keysym 255 010))	; :tty
+  (define-keysym #\page (keysym 009 227))	; :special
+  (define-keysym #\return (keysym 255 013))	; :tty
+  (define-keysym #\backspace (keysym 255 008))	; :tty
+  )
+
+#+(or lispm excl)
+(progn   ;; Nonstandard characters 
+  (define-keysym #\escape (keysym 255 027))	; :tty
+  )
+
+#+ti
+(progn
+  (define-keysym #\Inverted-exclamation-mark 161)
+  (define-keysym #\american-cent-sign 162)
+  (define-keysym #\british-pound-sign 163)
+  (define-keysym #\Currency-sign 164)
+  (define-keysym #\Japanese-yen-sign 165)
+  (define-keysym #\Yen 165)
+  (define-keysym #\Broken-bar 166)
+  (define-keysym #\Section-symbol 167)
+  (define-keysym #\Section 167)
+  (define-keysym #\Diaresis 168)
+  (define-keysym #\Umlaut 168)
+  (define-keysym #\Copyright-sign 169)
+  (define-keysym #\Copyright 169)
+  (define-keysym #\Feminine-ordinal-indicator 170)
+  (define-keysym #\Angle-quotation-left 171)
+  (define-keysym #\Soft-hyphen 173)
+  (define-keysym #\Shy 173)
+  (define-keysym #\Registered-trademark 174)
+  (define-keysym #\Macron 175)
+  (define-keysym #\Degree-sign 176)
+  (define-keysym #\Ring 176)
+  (define-keysym #\Plus-minus-sign 177)
+  (define-keysym #\Superscript-2 178)
+  (define-keysym #\Superscript-3 179)
+  (define-keysym #\Acute-accent 180)
+  (define-keysym #\Greek-mu 181)
+  (define-keysym #\Paragraph-symbol 182)
+  (define-keysym #\Paragraph 182)
+  (define-keysym #\Pilcrow-sign 182)
+  (define-keysym #\Middle-dot 183)
+  (define-keysym #\Cedilla 184)
+  (define-keysym #\Superscript-1 185)
+  (define-keysym #\Masculine-ordinal-indicator 186)
+  (define-keysym #\Angle-quotation-right 187)
+  (define-keysym #\Fraction-1/4 188)
+  (define-keysym #\One-quarter 188)
+  (define-keysym #\Fraction-1/2 189)
+  (define-keysym #\One-half 189)
+  (define-keysym #\Fraction-3/4 190)
+  (define-keysym #\Three-quarters 190)
+  (define-keysym #\Inverted-question-mark 191)
+  (define-keysym #\Multiplication-sign 215)
+  (define-keysym #\Eszet 223)
+  (define-keysym #\Division-sign 247)
+)
+
+#+ti
+(progn	;; There are no 7-bit ascii representations for the following
+        ;; European characters, so use int-char to create them to ensure
+        ;; nothing is lost while sending files through the mail.
+  (define-keysym (int-char 192) 192 :lowercase 224)
+  (define-keysym (int-char 193) 193 :lowercase 225)
+  (define-keysym (int-char 194) 194 :lowercase 226)
+  (define-keysym (int-char 195) 195 :lowercase 227)
+  (define-keysym (int-char 196) 196 :lowercase 228)
+  (define-keysym (int-char 197) 197 :lowercase 229)
+  (define-keysym (int-char 198) 198 :lowercase 230)
+  (define-keysym (int-char 199) 199 :lowercase 231)
+  (define-keysym (int-char 200) 200 :lowercase 232)
+  (define-keysym (int-char 201) 201 :lowercase 233)
+  (define-keysym (int-char 202) 202 :lowercase 234)
+  (define-keysym (int-char 203) 203 :lowercase 235)
+  (define-keysym (int-char 204) 204 :lowercase 236)
+  (define-keysym (int-char 205) 205 :lowercase 237)
+  (define-keysym (int-char 206) 206 :lowercase 238)
+  (define-keysym (int-char 207) 207 :lowercase 239)
+  (define-keysym (int-char 208) 208 :lowercase 240)
+  (define-keysym (int-char 209) 209 :lowercase 241)
+  (define-keysym (int-char 210) 210 :lowercase 242)
+  (define-keysym (int-char 211) 211 :lowercase 243)
+  (define-keysym (int-char 212) 212 :lowercase 244)
+  (define-keysym (int-char 213) 213 :lowercase 245)
+  (define-keysym (int-char 214) 214 :lowercase 246)
+  (define-keysym (int-char 215) 215)
+  (define-keysym (int-char 216) 216 :lowercase 248)
+  (define-keysym (int-char 217) 217 :lowercase 249)
+  (define-keysym (int-char 218) 218 :lowercase 250)
+  (define-keysym (int-char 219) 219 :lowercase 251)
+  (define-keysym (int-char 220) 220 :lowercase 252)
+  (define-keysym (int-char 221) 221 :lowercase 253)
+  (define-keysym (int-char 222) 222 :lowercase 254)
+  (define-keysym (int-char 223) 223)
+  (define-keysym (int-char 224) 224)
+  (define-keysym (int-char 225) 225)
+  (define-keysym (int-char 226) 226)
+  (define-keysym (int-char 227) 227)
+  (define-keysym (int-char 228) 228)
+  (define-keysym (int-char 229) 229)
+  (define-keysym (int-char 230) 230)
+  (define-keysym (int-char 231) 231)
+  (define-keysym (int-char 232) 232)
+  (define-keysym (int-char 233) 233)
+  (define-keysym (int-char 234) 234)
+  (define-keysym (int-char 235) 235)
+  (define-keysym (int-char 236) 236)
+  (define-keysym (int-char 237) 237)
+  (define-keysym (int-char 238) 238)
+  (define-keysym (int-char 239) 239)
+  (define-keysym (int-char 240) 240)
+  (define-keysym (int-char 241) 241)
+  (define-keysym (int-char 242) 242)
+  (define-keysym (int-char 243) 243)
+  (define-keysym (int-char 244) 244)
+  (define-keysym (int-char 245) 245)
+  (define-keysym (int-char 246) 246)
+  (define-keysym (int-char 247) 247)
+  (define-keysym (int-char 248) 248)
+  (define-keysym (int-char 249) 249)
+  (define-keysym (int-char 250) 250)
+  (define-keysym (int-char 251) 251)
+  (define-keysym (int-char 252) 252)
+  (define-keysym (int-char 253) 253)
+  (define-keysym (int-char 254) 254)
+  (define-keysym (int-char 255) 255)
+  )
+
+#+lispm  ;; Nonstandard characters
+(progn 
+  (define-keysym #\center-dot (keysym 183))	; :latin-1
+  (define-keysym #\down-arrow (keysym 008 254))	; :technical
+  (define-keysym #\alpha (keysym 007 225))	; :greek
+  (define-keysym #\beta (keysym 007 226))	; :greek
+  (define-keysym #\and-sign (keysym 008 222))	; :technical
+  (define-keysym #\not-sign (keysym 172))	; :latin-1
+  (define-keysym #\epsilon (keysym 007 229))	; :greek
+  (define-keysym #\pi (keysym 007 240))		; :greek
+  (define-keysym #\lambda (keysym 007 235))	; :greek
+  (define-keysym #\gamma (keysym 007 227))	; :greek
+  (define-keysym #\delta (keysym 007 228))	; :greek
+  (define-keysym #\up-arrow (keysym 008 252))	; :technical
+  (define-keysym #\plus-minus (keysym 177))	; :latin-1
+  (define-keysym #\infinity (keysym 008 194))	; :technical
+  (define-keysym #\partial-delta (keysym 008 239))	; :technical
+  (define-keysym #\left-horseshoe (keysym 011 218))	; :apl
+  (define-keysym #\right-horseshoe (keysym 011 216))	; :apl
+  (define-keysym #\up-horseshoe (keysym 011 195))	; :apl
+  (define-keysym #\down-horseshoe (keysym 011 214))	; :apl
+  (define-keysym #\double-arrow (keysym 008 205))	; :technical
+  (define-keysym #\left-arrow (keysym 008 251))	; :technical
+  (define-keysym #\right-arrow (keysym 008 253))	; :technical
+  (define-keysym #\not-equals (keysym 008 189))	; :technical
+  (define-keysym #\less-or-equal (keysym 008 188))	; :technical
+  (define-keysym #\greater-or-equal (keysym 008 190))	; :technical
+  (define-keysym #\equivalence (keysym 008 207))	; :technical
+  (define-keysym #\or-sign (keysym 008 223))	; :technical
+  (define-keysym #\integral (keysym 008 191))	; :technical
+;;  break isn't null
+;;  (define-keysym #\null (keysym 255 107))	; :function
+  (define-keysym #\clear-input (keysym 255 011))	; :tty
+  (define-keysym #\help (keysym 255 106))	; :function
+  (define-keysym #\refresh (keysym 255 097))	; :function
+  (define-keysym #\abort (keysym 255 105))	; :function
+  (define-keysym #\resume (keysym 255 098))	; :function
+  (define-keysym #\end (keysym 255 087))	; :cursor
+;;#\universal-quantifier
+;;#\existential-quantifier
+;;#\circle-plus
+;;#\circle-cross same as #\circle-x
+  )
+
+#+genera
+(progn
+;;#\network
+;;#\symbol-help
+  (define-keysym #\lozenge (keysym 009 224))	; :special
+  (define-keysym #\suspend (keysym 255 019))	; :tty
+  (define-keysym #\function (keysym 255 032))	; :function
+  (define-keysym #\square (keysym 010 231))	; :publishing
+  (define-keysym #\circle (keysym 010 230))	; :publishing
+  (define-keysym #\triangle (keysym 010 232))	; :publishing
+  (define-keysym #\scroll (keysym 255 086))	; :cursor
+  (define-keysym #\select (keysym 255 096))	; :function
+  (define-keysym #\complete (keysym 255 104))	; :function
+  )
+
+#+ti
+(progn
+  (define-keysym #\terminal (keysym 255 032))	; :function
+  (define-keysym #\system (keysym 255 096))	; :function
+  (define-keysym #\center-arrow (keysym 255 80))
+  (define-keysym #\left-arrow (keysym 255 081))	; :cursor
+  (define-keysym #\up-arrow (keysym 255 082))	; :cursor
+  (define-keysym #\right-arrow (keysym 255 083))	; :cursor
+  (define-keysym #\down-arrow (keysym 255 084))	; :cursor
+  (define-keysym #\end (keysym 255 087))	; :cursor
+  (define-keysym #\undo (keysym 255 101))	; :function
+  (define-keysym #\break (keysym 255 107))
+  (define-keysym #\keypad-space (keysym 255 128))	; :keypad
+  (define-keysym #\keypad-tab (keysym 255 137))	; :keypad
+  (define-keysym #\keypad-enter (keysym 255 141))	; :keypad
+  (define-keysym #\f1 (keysym 255 145))		; :keypad
+  (define-keysym #\f2 (keysym 255 146))		; :keypad
+  (define-keysym #\f3 (keysym 255 147))		; :keypad
+  (define-keysym #\f4 (keysym 255 148))		; :keypad
+  (define-keysym #\f1 (keysym 255 190))		; :keypad
+  (define-keysym #\f2 (keysym 255 191))		; :keypad
+  (define-keysym #\f3 (keysym 255 192))		; :keypad
+  (define-keysym #\f4 (keysym 255 193))		; :keypad
+  (define-keysym #\keypad-plus (keysym 255 171))	; :keypad
+  (define-keysym #\keypad-comma (keysym 255 172))	; :keypad
+  (define-keysym #\keypad-minus (keysym 255 173))	; :keypad
+  (define-keysym #\keypad-period (keysym 255 174))	; :keypad
+  (define-keysym #\keypad-0 (keysym 255 176))	; :keypad
+  (define-keysym #\keypad-1 (keysym 255 177))	; :keypad
+  (define-keysym #\keypad-2 (keysym 255 178))	; :keypad
+  (define-keysym #\keypad-3 (keysym 255 179))	; :keypad
+  (define-keysym #\keypad-4 (keysym 255 180))	; :keypad
+  (define-keysym #\keypad-5 (keysym 255 181))	; :keypad
+  (define-keysym #\keypad-6 (keysym 255 182))	; :keypad
+  (define-keysym #\keypad-7 (keysym 255 183))	; :keypad
+  (define-keysym #\keypad-8 (keysym 255 184))	; :keypad
+  (define-keysym #\keypad-9 (keysym 255 185))	; :keypad
+  (define-keysym #\keypad-equal (keysym 255 189))	; :keypad
+  (define-keysym #\f1 (keysym 255 192))		; :function
+  (define-keysym #\f2 (keysym 255 193))		; :function
+  (define-keysym #\f3 (keysym 255 194))		; :function
+  (define-keysym #\f4 (keysym 255 195))		; :function
+  (define-keysym #\network (keysym 255 214))
+  (define-keysym #\status (keysym 255 215))
+  (define-keysym #\clear-screen (keysym 255 217))
+  (define-keysym #\left (keysym 255 218))
+  (define-keysym #\middle (keysym 255 219))
+  (define-keysym #\right (keysym 255 220))
+  (define-keysym #\resume (keysym 255 221))
+  (define-keysym #\vt (keysym 009 233))		; :special ;; same as #\delete
+  )
+
+#+ti
+(progn  ;; Explorer specific characters
+  (define-keysym #\Call (keysym 131))		; :latin-1
+  (define-keysym #\Macro (keysym 133))		; :latin-1
+  (define-keysym #\Quote (keysym 142))		; :latin-1
+  (define-keysym #\Hold-output (keysym 143))	; :latin-1
+  (define-keysym #\Stop-output (keysym 144))	; :latin-1
+  (define-keysym #\Center (keysym 156))		; :latin-1
+  (define-keysym #\no-break-space (keysym 160))	; :latin-1
+
+  (define-keysym #\circle-plus (keysym 13))	; :latin-1
+  (define-keysym #\universal-quantifier (keysym 20))	; :latin-1
+  (define-keysym #\existential-quantifier (keysym 21))	; :latin-1
+  (define-keysym #\circle-cross (keysym 22))	; :latin-1
+  )
+
diff --git a/clx/macros.lisp b/clx/macros.lisp
new file mode 100644
index 000000000..fa829cdb2
--- /dev/null
+++ b/clx/macros.lisp
@@ -0,0 +1,1078 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;; CLX basicly implements a very low overhead remote procedure call
+;;; to the server.  This file contains macros which generate the code
+;;; for both the client AND the server, given a specification of the
+;;; interface. This was done to eliminate errors that may occur because
+;;; the client and server code get/put bytes in different places, and
+;;; it makes it easier to extend the protocol.
+
+;;; This is built on top of BUFFER
+
+(in-package :xlib)
+
+;;; This variable is used by the required-arg macro just to satisfy compilers.
+(defvar *required-arg-dummy*)
+
+;;; An error signalling macro use to specify that keyword arguments are required.
+(defmacro required-arg (name)
+  `(progn (x-error 'missing-parameter :parameter ',name)
+	  *required-arg-dummy*))
+
+(defmacro lround (index)
+  ;; Round up to the next 32 bit boundary
+  `(the array-index (logand (index+ ,index 3) -4)))
+
+(defmacro wround (index)
+  ;; Round up to the next 16 bit boundary
+  `(the array-index (logand (index+ ,index 1) -2)))
+
+;;
+;; Data-type accessor functions
+;;
+;;   These functions translate between lisp data-types and the byte,
+;;   half-word or word that gets transmitted across the client/server
+;;   connection
+
+(defun index-increment (type)
+  ;; Given a type, return its field width in bytes
+  (let* ((name (if (consp type) (car type) type))
+	 (increment (get name 'byte-width :not-found)))
+    (when (eq increment :not-found)
+      ;; Check for TYPE in a different package
+      (when (not (eq (symbol-package name) (find-package 'xlib)))
+	(setq name (xintern name))
+	(setq increment (get name 'byte-width :not-found)))
+      (when (eq increment :not-found)
+	(error "~s isn't a known field accessor" name)))
+    increment))
+
+(eval-when (eval compile load)
+(defun getify (name)
+  (xintern name '-get))
+
+(defun putify (name &optional predicate-p)
+  (xintern name '-put (if predicate-p '-predicating "")))
+
+					;; Use &body so zmacs indents properly
+(defmacro define-accessor (name (width) &body get-put-macros)
+  ;; The first body form defines the get macro
+  ;; The second body form defines the put macro
+  ;; The third body form is optional, and defines a put macro that does
+  ;; type checking and does a put when ok, else NIL when the type is incorrect.
+  ;; If no third body form is present, then these macros assume that
+  ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated.
+  ;; these predicating puts are used by the OR accessor.
+  (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro))
+  (when (cdddr get-put-macros)
+    (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros)))
+  (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name)))
+	(put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name))))
+    `(within-definition (,name define-accessor)
+       (setf (get ',name 'byte-width) ,(and width (floor width 8)))
+       (defmacro ,(getify name) ,(car get-macro)
+	 ,@(cdr get-macro))
+       (defmacro ,(putify name) ,(car put-macro)
+	 ,@(cdr put-macro))
+       ,@(when *type-check?*
+	   (let ((predicating-put (third get-put-macros)))
+	     (when predicating-put
+	       `((setf (get ',name 'predicating-put) t)
+		 (defmacro ,(putify name t) ,(car predicating-put)
+		   ,@(cdr predicating-put)))))))))
+) ;; End eval-when
+
+(define-accessor card32 (32)
+  ((index) `(read-card32 ,index))
+  ((index thing) `(write-card32 ,index ,thing)))
+
+(define-accessor card29 (32)
+  ((index) `(read-card29 ,index))
+  ((index thing) `(write-card29 ,index ,thing)))
+
+(define-accessor card16 (16)
+  ((index) `(read-card16 ,index))
+  ((index thing) `(write-card16 ,index ,thing)))
+
+(define-accessor card8 (8)
+  ((index) `(read-card8 ,index))
+  ((index thing) `(write-card8 ,index ,thing)))
+
+(define-accessor integer (32)
+  ((index) `(read-int32 ,index))
+  ((index thing) `(write-int32 ,index ,thing)))
+
+(define-accessor int16 (16)
+  ((index) `(read-int16 ,index))
+  ((index thing) `(write-int16 ,index ,thing)))
+
+(define-accessor rgb-val (16)
+  ;; Used for color's
+  ((index) `(card16->rgb-val (read-card16 ,index)))
+  ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing))))
+
+(define-accessor angle (16)
+  ;; Used for drawing arcs
+  ((index) `(int16->radians (read-int16 ,index)))
+  ((index thing) `(write-int16 ,index (radians->int16 ,thing))))
+
+(define-accessor bit (0)
+  ;; Like BOOLEAN, but tests bits
+  ;; only used by declare-event (:enter-notify :leave-notify)
+  ((index bit)
+   `(logbitp ,bit (read-card8 ,index)))
+  ((index thing bit)
+   (if (zerop bit)
+       `(write-card8 ,index (if ,thing 1 0))
+     `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index))))))
+
+(define-accessor boolean (8)
+  ((index)
+   `(plusp (read-card8 ,index)))
+  ((index thing) `(write-card8 ,index (if ,thing 1 0))))
+
+(define-accessor drawable (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-drawable ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (drawable-id ,thing))))
+
+(define-accessor window (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-window ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (window-id ,thing))))
+
+(define-accessor pixmap (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-pixmap ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (pixmap-id ,thing))))
+
+(define-accessor gcontext (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-gcontext ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (gcontext-id ,thing))))
+
+(define-accessor cursor (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-cursor ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (cursor-id ,thing))))
+
+(define-accessor colormap (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-colormap ,buffer (read-card29 ,index)))
+  ((index thing) `(write-card29 ,index (colormap-id ,thing))))
+
+(define-accessor font (32)
+  ((index &optional (buffer '%buffer))
+   `(lookup-font ,buffer (read-card29 ,index)))
+  ;; The FONT-ID accessor may make a OpenFont request.  Since we don't support recursive
+  ;; with-buffer-request, issue a compile time error, rather than barf at run-time.
+  ((index thing)
+   (declare (ignore index thing))
+   (error "FONT-ID must be called OUTSIDE with-buffer-request.  Use RESOURCE-ID instead.")))
+
+;; Needed to get and put xatom's in events
+(define-accessor keyword (32)
+  ((index &optional (buffer '%buffer))
+   `(atom-name ,buffer (read-card29 ,index)))
+  ((index thing &key (buffer '%buffer))
+   `(write-card29 ,index (or (atom-id ,thing ,buffer)
+			     (error "CLX implementation error in KEYWORD-PUT")))))
+
+(define-accessor resource-id (32)
+  ((index) `(read-card29 ,index))
+  ((index thing) `(write-card29 ,index ,thing)))
+
+(define-accessor resource-id-or-nil (32)
+  ((index) (let ((id (gensym)))
+	     `(let ((,id (read-card29 ,index)))
+		(and (plusp ,id) ,id))))
+  ((index thing) `(write-card29 ,index (or ,thing 0))))
+
+(defmacro char-info-get (index)
+  `(make-char-info
+     :left-bearing (int16-get ,index)
+     :right-bearing (int16-get ,(+ index 2))
+     :width	   (int16-get ,(+ index 4))
+     :ascent	   (int16-get ,(+ index 6))
+     :descent	   (int16-get ,(+ index 8))
+     :attributes   (card16-get ,(+ index 10))))
+
+(define-accessor member8 (8)
+  ((index &rest keywords)
+   (let ((value (gensym)))
+     `(let ((,value (read-card8 ,index)))
+	(and (< ,value ,(length keywords))
+	     (svref ',(apply #'vector keywords) ,value)))))
+  ((index thing &rest keywords)
+   `(write-card8 ,index (position ,thing
+				  #+lispm ',keywords ;; Lispm's prefer lists
+				  #-lispm (the simple-vector ',(apply #'vector keywords))
+				  :test #'eq)))
+  ((index thing &rest keywords)
+   (let ((value (gensym)))
+     `(let ((,value (position ,thing
+			      #+lispm ',keywords
+			      #-lispm (the simple-vector ',(apply #'vector keywords))
+			      :test #'eq)))
+	(and ,value (write-card8 ,index ,value))))))
+
+(define-accessor member16 (16)
+  ((index &rest keywords)
+   (let ((value (gensym)))
+     `(let ((,value (read-card16 ,index)))
+	(and (< ,value ,(length keywords))
+	     (svref ',(apply #'vector keywords) ,value)))))
+  ((index thing &rest keywords)
+   `(write-card16 ,index (position ,thing
+				   #+lispm ',keywords ;; Lispm's prefer lists
+				   #-lispm (the simple-vector ',(apply #'vector keywords))
+				   :test #'eq)))
+  ((index thing &rest keywords)
+   (let ((value (gensym)))
+     `(let ((,value (position ,thing
+			      #+lispm ',keywords
+			      #-lispm (the simple-vector ',(apply #'vector keywords))
+			      :test #'eq)))
+	(and ,value (write-card16 ,index ,value))))))
+
+(define-accessor member (32)
+  ((index &rest keywords)
+   (let ((value (gensym)))
+     `(let ((,value (read-card29 ,index)))
+	(and (< ,value ,(length keywords))
+	     (svref ',(apply #'vector keywords) ,value)))))
+  ((index thing &rest keywords)
+   `(write-card29 ,index (position ,thing
+				   #+lispm ',keywords ;; Lispm's prefer lists
+				   #-lispm (the simple-vector ',(apply #'vector keywords))
+				   :test #'eq)))
+  ((index thing &rest keywords)
+   (if (cdr keywords) ;; IF more than one
+       (let ((value (gensym)))
+	 `(let ((,value (position ,thing
+				   #+lispm ',keywords
+				   #-lispm (the simple-vector ',(apply #'vector keywords))
+				  :test #'eq)))
+	    (and ,value (write-card29 ,index ,value))))
+     `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
+
+(deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
+
+(define-accessor member-vector (32)
+  ((index membership-vector)
+   `(member-get ,index ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
+
+(define-accessor member16-vector (16)
+  ((index membership-vector)
+   `(member16-get ,index ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
+
+(define-accessor member8-vector (8)
+  ((index membership-vector)
+   `(member8-get ,index ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
+  ((index thing membership-vector)
+   `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
+
+(define-accessor boole-constant (32)
+  ;; this isn't member-vector because we need eql instead of eq
+  ((index)
+   (let ((value (gensym)))
+     `(let ((,value (read-card29 ,index)))
+	(and (< ,value ,(length *boole-vector*))
+	     (svref *boole-vector* ,value)))))
+  ((index thing)
+   `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*))))
+  ((index thing)
+   (let ((value (gensym)))
+     `(let ((,value (position ,thing (the simple-vector *boole-vector*))))
+	(and ,value (write-card29 ,index ,value))))))
+
+(define-accessor null (32)
+  ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
+  ((index value) (declare (ignore value)) `(write-card32 ,index 0)))
+
+(define-accessor pad8 (8)
+  ((index) (declare (ignore index)) nil)
+  ((index value) (declare (ignore index value))  nil))
+
+(define-accessor pad16 (16)
+  ((index) (declare (ignore index)) nil)
+  ((index value) (declare (ignore index value)) nil))
+
+(define-accessor bit-vector256 (256)
+  ;; used for key-maps
+  ;; REAL-INDEX parameter provided so the default index can be over-ridden.
+  ;; This is needed for the :keymap-notify event where the keymap overlaps
+  ;; the window id.
+  ((index &optional (real-index index) data)
+   `(read-bitvector256 buffer-bbuf ,real-index ,data))
+  ((index map &optional (real-index index) (buffer '%buffer))
+   `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
+   
+(define-accessor string (nil)
+  ((length index &key reply-buffer)
+   `(read-sequence-char
+      ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index))
+  ((index string &key buffer (start 0) end header-length appending)
+   (unless buffer (setq buffer '%buffer))
+   (unless header-length (setq header-length (lround index)))
+   (let* ((real-end (if appending (or end `(length ,string)) (gensym)))
+	  (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length)
+				      ,string ,start ,real-end)))
+     (if appending
+	 form
+       `(let ((,real-end ,(or end `(length ,string))))
+	  (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4))
+	  ,form)))))
+
+(define-accessor sequence (nil)
+  ((&key length (format 'card32) result-type transform reply-buffer data index start)
+   `(,(ecase format
+	(card8 'read-sequence-card8)
+	(int8 'read-sequence-int8)
+	(card16 'read-sequence-card16)
+	(int16 'read-sequence-int16)
+	(card32 'read-sequence-card32)
+	(int32 'read-sequence-int32))
+     ,(or reply-buffer '%reply-buffer)
+     ,result-type ,length ,transform ,data
+     ,@(when (or start index) `(,(or start 0)))
+     ,@(when index `(,index))))
+  ((index data &key (format 'card32) (start 0) end transform buffer appending)
+   (unless buffer (setq buffer '%buffer))
+   (let* ((real-end (if appending (or end `(length ,data)) (gensym)))
+	  (writer (xintern 'write-sequence- format))
+	  (form `(,writer ,buffer (index+ buffer-boffset ,(lround index))
+		  ,data ,start ,real-end ,transform)))
+     (flet ((maker (size)
+	      (if appending
+		  form
+		  (let ((idx `(index- ,real-end ,start)))
+		    (unless (= size 1)
+		      (setq idx `(index-ceiling ,idx ,size)))
+		    `(let ((,real-end ,(or end `(length ,data))))
+		       (write-card16 2 (index+ ,idx ,(index-ceiling index 4)))
+		       ,form)))))
+       (ecase format
+	 ((card8 int8)
+	  (maker 4))
+	 ((card16 int16)
+	  (maker 2))
+	 ((card32 int32)
+	  (maker 1)))))))
+
+(defmacro client-message-event-get-sequence ()
+  '(let* ((format (read-card8 1))
+ 	  (sequence (make-array (ceiling 160 format)
+				:element-type `(unsigned-byte ,format))))
+     (do ((i 12)
+	  (j 0 (1+ j)))
+	 ((>= i 32))
+       (case format
+	 (8 (setf (aref sequence j) (read-card8 i))
+	    (incf i))
+	 (16 (setf (aref sequence j) (read-card16 i))
+	     (incf i 2))
+	 (32 (setf (aref sequence j) (read-card32 i))
+	     (incf i 4))))
+     sequence))
+
+(defmacro client-message-event-put-sequence (format sequence)
+  `(ecase ,format
+     (8  (sequence-put 12 ,sequence
+		       :format card8
+		       :end (min (length ,sequence) 20)
+		       :appending t))
+     (16 (sequence-put 12 ,sequence
+		       :format card16
+		       :end (min (length ,sequence) 10)
+		       :appending t))
+     (32 (sequence-put 12 ,sequence
+		       :format card32
+		       :end (min (length ,sequence) 5)
+		       :appending t))))
+
+;; Used only in declare-event
+(define-accessor client-message-sequence (160)
+  ((index format) (declare (ignore index format)) `(client-message-event-get-sequence))
+  ((index value format) (declare (ignore index))
+   `(client-message-event-put-sequence ,format ,value)))
+
+
+;;;
+;;; Compound accessors
+;;;    Accessors that take other accessors as parameters
+;;;
+(define-accessor code (0)
+  ((index) (declare (ignore index)) '(read-card8 0))
+  ((index value) (declare (ignore index)) `(write-card8 0 ,value))
+  ((index value) (declare (ignore index)) `(write-card8 0 ,value)))
+
+(define-accessor length (0)
+  ((index) (declare (ignore index)) '(read-card16 2))
+  ((index value) (declare (ignore index)) `(write-card16 2 ,value))
+  ((index value) (declare (ignore index)) `(write-card16 2 ,value)))
+
+(deftype data () 'card8)
+
+(define-accessor data (0)
+  ;; Put data in byte 1 of the reqeust
+  ((index &optional stuff) (declare (ignore index))
+   (if stuff
+       (if (consp stuff)
+	   `(,(getify (car stuff)) 1 ,@(cdr stuff))
+	 `(,(getify stuff) 1))
+     `(read-card8 1)))
+  ((index thing &optional stuff)
+   (if stuff
+       (if (consp stuff)
+	   `(macrolet ((write-card32 (index value) index value))
+	      (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
+	 `(,(putify stuff) 1 ,thing))
+     `(write-card8 1 ,thing)))
+  ((index thing &optional stuff)
+   (if stuff
+       `(and (type? ,thing ',stuff)
+	     ,(if (consp stuff)
+		  `(macrolet ((write-card32 (index value) index value))
+		     (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
+		`(,(putify stuff) 1 ,thing)))
+     `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
+
+;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
+;; when using event-case.  This is pretty gross.
+
+(defmacro or-expand (&rest forms &environment environment)
+  `(cond ,@(mapcar #'(lambda (forms)
+		       (mapcar #'(lambda (form)
+				   (macroexpand form environment))
+			       forms))
+		   forms)))
+
+;;
+;; the OR type
+;;
+(define-accessor or (32)
+  ;; Select from among several types (usually NULL and something else)
+  ((index &rest type-list &environment environment)
+   (do ((types type-list (cdr types))
+	(value (gensym))
+	(result))
+       ((endp types)
+	`(let ((,value (read-card32 ,index)))
+	   (macrolet ((read-card32 (index) index ',value)
+		      (read-card29 (index) index ',value))
+	     ,(macroexpand `(or-expand ,@(nreverse result)) environment))))
+     (let ((item (car types))
+	   (args nil))
+       (when (consp item)
+	 (setq args (cdr item)
+	       item (car item)))
+       (if (eq item 'null)  ;; Special case for NULL
+	   (push `((zerop ,value) nil) result)
+	 (push
+	   `((,(getify item) ,index ,@args))
+	   result)))))
+
+  ((index value &rest type-list)
+   (do ((types type-list (cdr types))
+	(result))
+       ((endp types)
+	`(cond ,@(nreverse result)
+	       ,@(when *type-check?*
+		   `((t (x-type-error ,value '(or ,@type-list)))))))
+     (let* ((type (car types))
+	    (type-name type)
+	    (args nil))
+       (when (consp type)
+	 (setq args (cdr type)
+	       type-name (car type)))
+       (push
+	 `(,@(cond ((get type-name 'predicating-put) nil)
+		   ((or *type-check?* (cdr types)) `((type? ,value ',type)))
+		   (t '(t)))
+	   (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
+	 result)))))
+
+;;
+;; the MASK type...
+;;     is used to specify a subset of a collection of "optional" arguments.
+;;     A mask type consists of a 32 bit mask word followed by a word for each one-bit
+;;     in the mask.  The MASK type is ALWAYS the LAST item in a request.
+;;
+(setf (get 'mask 'byte-width) nil)
+
+(defun mask-get (index type-values body-function)
+  (declare (type function body-function)
+	   (downward-funarg body-function))
+  ;; This is a function, because it must return more than one form (called by get-put-items)
+  ;; Functions that use this must have a binding for %MASK
+  (let* ((bit 0)
+	 (result
+	   (mapcar
+	     #'(lambda (form)
+		 (if (atom form)
+		     form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs
+		   (prog1
+		     `(when (logbitp ,bit %mask)
+			;; Execute form when bit is set
+			,form)
+		     (incf bit))))
+	     (get-put-items
+	       (+ index 4) type-values nil
+	       #'(lambda (type index item args)
+		   (declare (ignore index))
+		   (funcall body-function type '(* (incf %index) 4) item args))))))
+    ;; First form must load %MASK
+    `(,@(when (atom (car result))
+	  (list (pop result)))
+      (progn (setq %mask (read-card32 ,index))
+	     (setq %index ,(ceiling index 4))
+	     ,(car result))
+      ,@(cdr result))))
+
+;; MASK-PUT 
+
+(defun mask-put (index type-values body-function)
+  (declare (type function body-function)
+	   (downward-funarg body-function))
+  ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
+  ;; A 32 bit value follows for each non-nil value.
+  `((let ((%mask 0)
+	  (%index ,index))
+      ,@(let ((bit 1))
+	  (get-put-items
+	    index type-values t 
+	    #'(lambda (type index item args)
+		(declare (ignore index))
+		(if (or (symbolp item) (constantp item))
+		    `((unless (null ,item)
+			(setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
+			,@(funcall body-function type
+				   `(index-incf %index 4) item args)))
+		  `((let ((.item. ,item))
+		      (unless (null .item.)
+			(setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
+			,@(funcall body-function type
+				   `(index-incf %index 4) '.item. args))))))))
+      (write-card32 ,index %mask)
+      (write-card16 2 (index-ceiling (index-incf %index 4) 4))
+      (incf (buffer-boffset %buffer) %index))))
+
+(define-accessor progn (nil)
+  ;; Catch-all for inserting random code
+  ;; Note that code using this is then responsible for setting the request length
+  ((index statement) (declare (ignore index)) statement)
+  ((index statement) (declare (ignore index)) statement))
+
+
+;
+; Wrapper macros, for use around the above
+;
+(defmacro type-check (value type)
+  value type
+  (when *type-check?*
+    `(unless (type? ,value ,type)
+       (x-type-error ,value ,type))))
+
+(defmacro check-put (index value type &rest args &environment env)
+  (let* ((var (if (or (symbolp value) (constantp value)) value '.value.))
+	 (body
+	   (if (or (null (macroexpand `(type-check ,var ',type) env))
+		   (member type '(or progn pad8 pad16))
+		   (constantp value))
+	       `(,(putify type) ,index ,var ,@args)
+	     ;; Do type checking
+	     (if (get type 'predicating-put)
+		 `(or (,(putify type t) ,index ,var ,@args)
+		      (x-type-error ,var ',(if args `(,type ,@args) type)))
+	       `(if (type? ,var ',type)
+		    (,(putify type) ,index ,var ,@args)
+		  (x-type-error ,var ',(if args `(,type ,@args) type)))))))
+    (if (eq var value)
+	body
+      `(let ((,var ,value))
+	 ,body))))
+
+(defun get-put-items (index type-args putp &optional body-function)
+  (declare (type (or null function) body-function)
+	   (downward-funarg body-function))
+  ;; Given a lists of the form (type item item ... item)
+  ;; Calls body-function with four arguments, a function name,
+  ;; index, item name, and optional arguments.
+  ;; The results are appended together and retured.
+  (unless body-function
+    (setq body-function
+	  #'(lambda (type index item args)
+	      `((check-put ,index ,item ,type ,@args)))))
+  (do* ((items type-args (cdr items))
+	(type (caar items) (caar items))
+	(args nil nil)
+	(result nil)
+	(sizes nil))
+       ((endp items) (values result index sizes))
+    (when (consp type)
+      (setq args (cdr type)
+	    type (car type)))
+    (cond ((member type '(return buffer)))
+	  ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values
+	   (setq result
+		 (append result (if putp
+				    (mask-put index (cdar items) body-function)
+				  (mask-get index (cdar items) body-function)))
+		 index nil))
+	  (t (do* ((item (cdar items) (cdr item))
+		   (increment (index-increment type)))
+		  ((endp item))
+	       (when (constantp index)
+		 (case increment		;Round up index when needed
+		   (2 (setq index (wround index)))
+		   (4 (setq index (lround index)))))
+	       (setq result
+		     (append result (funcall body-function type index (car item) args)))
+	       (when (constantp index)
+		 ;; Variable length requests have null length increment.
+		 ;; Variable length requests set the request size 
+		 ;; & maintain buffer pointers
+		 (if (null increment) 
+		     (setq index nil)
+		   (progn
+		     (incf index increment)
+		     (when (and increment (zerop increment)) (setq increment 1))
+		     (pushnew (* increment 8) sizes)))))))))
+
+(defmacro with-buffer-request-internal
+	  ((buffer opcode &key length sizes &allow-other-keys)
+	   &body type-args)
+  (declare (values request-number))
+  (multiple-value-bind (code index item-sizes)
+      (get-put-items 4 type-args t)
+    (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))
+	  (sizes (remove-duplicates (append '(8 16) item-sizes sizes))))
+      `(with-buffer-output (,buffer :length ,length :sizes ,sizes)
+	 (setf (buffer-last-request ,buffer) buffer-boffset)
+	 (write-card8 0 ,opcode)	   ;; Stick in the opcode
+	 ,@code
+	 ,@(when index
+	     (setq index (lround index))
+	     `((write-card16 2 ,(ceiling index 4))
+	       (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index))))
+	 (buffer-new-request-number ,buffer)))))
+
+(defmacro with-buffer-request
+	  ((buffer opcode &rest options &key inline gc-force &allow-other-keys)
+	   &body type-args &environment env)
+  (declare (values request-number))
+  (if (and (null inline) (macroexpand '(use-closures) env))
+      `(flet ((.request-body. (.display.)
+		(declare (type display .display.))
+		(with-buffer-request-internal (.display. ,opcode ,@options)
+		  ,@type-args)))
+	 #+ansi-common-lisp
+	 (declare (dynamic-extent #'.request-body.))
+	 (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
+	       'with-buffer-request-function-nolock
+	     'with-buffer-request-function)
+	  ,buffer ,gc-force #'.request-body.))
+    `(let ((.display. ,buffer))
+       (declare (type display .display.))
+       (with-buffer (.display.)
+	 ,@(when gc-force `((force-gcontext-changes-internal ,gc-force)))
+	 (multiple-value-prog1
+	   (without-aborts 
+	     (with-buffer-request-internal (.display. ,opcode ,@options)
+	       ,@type-args))
+	   (display-invoke-after-function .display.))))))
+
+(defmacro with-buffer-request-and-reply
+	  ((buffer opcode reply-size &key sizes multiple-reply inline)
+	   type-args &body reply-forms &environment env)
+  (declare (indentation 0 4 1 4 2 1))
+  (let* ((inner-reply-body
+	   `(with-buffer-input (.reply-buffer. :display .display.
+					       ,@(and sizes (list :sizes sizes)))
+	      nil ,@reply-forms))
+	 (reply-body
+	   (if (or (not (symbolp reply-size)) (constantp reply-size))
+	       inner-reply-body
+	     `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.))))
+		(declare (type array-index ,reply-size))
+		,inner-reply-body))))
+    (if (and (null inline) (macroexpand '(use-closures) env))
+	`(flet ((.request-body. (.display.)
+		  (declare (type display .display.))
+		  (with-buffer-request-internal (.display. ,opcode)
+		    ,@type-args))
+		(.reply-body. (.display. .reply-buffer.)
+		  (declare (type display .display.)
+			   (type reply-buffer .reply-buffer.))
+		  (progn .display. .reply-buffer. nil)
+		  ,reply-body))
+	   #+ansi-common-lisp
+	   (declare (dynamic-extent #'.request-body. #'.reply-body.))
+	   (with-buffer-request-and-reply-function
+	     ,buffer ,multiple-reply #'.request-body. #'.reply-body.))
+      `(let ((.display. ,buffer)
+	     (.pending-command. nil)
+	     (.reply-buffer. nil))
+	 (declare (type display .display.)
+		  (type (or null pending-command) .pending-command.)
+		  (type (or null reply-buffer) .reply-buffer.))
+	 (unwind-protect
+	     (progn 
+	       (with-buffer (.display.)
+		 (setq .pending-command. (start-pending-command .display.))
+		 (without-aborts
+		   (with-buffer-request-internal (.display. ,opcode)
+		     ,@type-args))
+		 (buffer-force-output .display.)
+		 (display-invoke-after-function .display.))
+	       ,@(if multiple-reply
+		     `((loop
+			 (setq .reply-buffer. (read-reply .display. .pending-command.))
+			 (when ,reply-body (return nil))
+			 (deallocate-reply-buffer (shiftf .reply-buffer. nil))))
+		   `((setq .reply-buffer. (read-reply .display. .pending-command.))
+		     ,reply-body)))
+	   (when .reply-buffer.
+	     (deallocate-reply-buffer .reply-buffer.))
+	   (when .pending-command.
+	     (stop-pending-command .display. .pending-command.)))))))
+
+(defmacro compare-request ((index) &body body)
+  `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index)))
+	      (write-int32 (index item) `(= ,item (read-int32 ,index)))
+	      (write-card29 (index item) `(= ,item (read-card29 ,index)))
+	      (write-int29 (index item) `(= ,item (read-int29 ,index)))
+	      (write-card16 (index item) `(= ,item (read-card16 ,index)))
+	      (write-int16 (index item) `(= ,item (read-int16 ,index)))
+	      (write-card8 (index item) `(= ,item (read-card8 ,index)))
+	      (write-int8 (index item) `(= ,item (read-int8 ,index))))
+     (macrolet ((type-check (value type) value type nil))
+       (and ,@(get-put-items index body t)))))
+
+(defmacro put-items ((index) &body body)
+  `(progn ,@(get-put-items index body t)))
+
+(defmacro decode-type (type value)
+  ;; Given an integer and type, return the value
+  (let ((args nil))
+    (when (consp type)
+      (setq args (cdr type)
+	    type (car type)))
+    `(macrolet ((read-card29 (value) value)
+		(read-card32 (value) value)
+		(read-int32 (value) `(card32->int32 ,value))
+		(read-card16 (value) value)
+		(read-int16 (value) `(card16->int16 ,value))
+		(read-card8 (value) value)
+		(read-int8 (value) `(int8->card8 ,value)))
+       (,(getify type) ,value ,@args))))
+
+(defmacro encode-type (type value)
+  ;; Given a value and type, return an integer
+  ;; When check-p, do type checking on value
+  (let ((args nil))
+    (when (consp type)
+      (setq args (cdr type)
+	    type (car type)))
+    `(macrolet ((write-card29 (index value) index value)
+		(write-card32 (index value) index value)
+		(write-int32 (index value) index `(int32->card32 ,value))
+		(write-card16 (index value) index value)
+		(write-int16 (index value) index `(int16->card16 ,value))
+		(write-card8 (index value) index value)
+		(write-int8 (index value) index `(int8->card8 ,value)))
+       (check-put 0 ,value ,type ,@args))))
+
+(defmacro set-decode-type (type accessor value)
+  `(setf ,accessor (encode-type ,type ,value)))
+(defsetf decode-type set-decode-type)
+
+
+;;;
+;;; Request codes
+;;; 
+
+(defconstant *x-createwindow*                  1)
+(defconstant *x-changewindowattributes*        2)
+(defconstant *x-getwindowattributes*           3)
+(defconstant *x-destroywindow*                 4)
+(defconstant *x-destroysubwindows*             5)  
+(defconstant *x-changesaveset*                 6)
+(defconstant *x-reparentwindow*                7)
+(defconstant *x-mapwindow*                     8)
+(defconstant *x-mapsubwindows*                 9)
+(defconstant *x-unmapwindow*                  10)
+(defconstant *x-unmapsubwindows*              11) 
+(defconstant *x-configurewindow*              12)
+(defconstant *x-circulatewindow*              13)
+(defconstant *x-getgeometry*                  14)
+(defconstant *x-querytree*                    15)
+(defconstant *x-internatom*                   16)
+(defconstant *x-getatomname*                  17)
+(defconstant *x-changeproperty*               18)
+(defconstant *x-deleteproperty*               19)
+(defconstant *x-getproperty*                  20)
+(defconstant *x-listproperties*               21)
+(defconstant *x-setselectionowner*            22)  
+(defconstant *x-getselectionowner*            23) 
+(defconstant *x-convertselection*             24)
+(defconstant *x-sendevent*                    25)
+(defconstant *x-grabpointer*                  26)
+(defconstant *x-ungrabpointer*                27)
+(defconstant *x-grabbutton*                   28)
+(defconstant *x-ungrabbutton*                 29)
+(defconstant *x-changeactivepointergrab*      30)         
+(defconstant *x-grabkeyboard*                 31)
+(defconstant *x-ungrabkeyboard*               32)
+(defconstant *x-grabkey*                      33)
+(defconstant *x-ungrabkey*                    34)
+(defconstant *x-allowevents*                  35)
+(defconstant *x-grabserver*                   36)     
+(defconstant *x-ungrabserver*                 37)       
+(defconstant *x-querypointer*                 38)       
+(defconstant *x-getmotionevents*              39)          
+(defconstant *x-translatecoords*              40)               
+(defconstant *x-warppointer*                  41)      
+(defconstant *x-setinputfocus*                42)        
+(defconstant *x-getinputfocus*                43)        
+(defconstant *x-querykeymap*                  44)      
+(defconstant *x-openfont*                     45)   
+(defconstant *x-closefont*                    46)    
+(defconstant *x-queryfont*                    47)
+(defconstant *x-querytextextents*             48)    
+(defconstant *x-listfonts*                    49) 
+(defconstant *x-listfontswithinfo*    	      50)
+(defconstant *x-setfontpath*                  51)
+(defconstant *x-getfontpath*                  52)
+(defconstant *x-createpixmap*                 53)      
+(defconstant *x-freepixmap*                   54)   
+(defconstant *x-creategc*                     55)
+(defconstant *x-changegc*                     56)
+(defconstant *x-copygc*                       57)
+(defconstant *x-setdashes*                    58)  
+(defconstant *x-setcliprectangles*            59)         
+(defconstant *x-freegc*                       60)
+(defconstant *x-cleartobackground*            61)          
+(defconstant *x-copyarea*                     62)
+(defconstant *x-copyplane*                    63)
+(defconstant *x-polypoint*                    64)
+(defconstant *x-polyline*                     65)
+(defconstant *x-polysegment*                  66)  
+(defconstant *x-polyrectangle*                67)   
+(defconstant *x-polyarc*                      68)
+(defconstant *x-fillpoly*                     69)
+(defconstant *x-polyfillrectangle*            70)        
+(defconstant *x-polyfillarc*                  71) 
+(defconstant *x-putimage*                     72)
+(defconstant *x-getimage*                     73)
+(defconstant *x-polytext8*                    74)   
+(defconstant *x-polytext16*                   75)   
+(defconstant *x-imagetext8*                   76)  
+(defconstant *x-imagetext16*                  77)  
+(defconstant *x-createcolormap*               78)    
+(defconstant *x-freecolormap*                 79) 
+(defconstant *x-copycolormapandfree*          80)       
+(defconstant *x-installcolormap*              81)  
+(defconstant *x-uninstallcolormap*            82)   
+(defconstant *x-listinstalledcolormaps*       83)       
+(defconstant *x-alloccolor*                   84)
+(defconstant *x-allocnamedcolor*              85)    
+(defconstant *x-alloccolorcells*              86)   
+(defconstant *x-alloccolorplanes*             87)   
+(defconstant *x-freecolors*                   88)
+(defconstant *x-storecolors*                  89)
+(defconstant *x-storenamedcolor*              90)   
+(defconstant *x-querycolors*                  91)
+(defconstant *x-lookupcolor*                  92)
+(defconstant *x-createcursor*                 93)
+(defconstant *x-createglyphcursor*            94)    
+(defconstant *x-freecursor*                   95)
+(defconstant *x-recolorcursor*                96)  
+(defconstant *x-querybestsize*                97) 
+(defconstant *x-queryextension*               98) 
+(defconstant *x-listextensions*               99)
+(defconstant *x-setkeyboardmapping*           100)
+(defconstant *x-getkeyboardmapping*           101)
+(defconstant *x-changekeyboardcontrol*        102)               
+(defconstant *x-getkeyboardcontrol*           103)           
+(defconstant *x-bell*                         104)
+(defconstant *x-changepointercontrol*         105)
+(defconstant *x-getpointercontrol*            106)
+(defconstant *x-setscreensaver*               107)         
+(defconstant *x-getscreensaver*               108)        
+(defconstant *x-changehosts*                  109)    
+(defconstant *x-listhosts*                    110) 
+(defconstant *x-changeaccesscontrol*          111)          
+(defconstant *x-changeclosedownmode*          112)
+(defconstant *x-killclient*                   113)
+(defconstant *x-rotateproperties*	      114)
+(defconstant *x-forcescreensaver*	      115)
+(defconstant *x-setpointermapping*            116)
+(defconstant *x-getpointermapping*            117)
+(defconstant *x-setmodifiermapping*	      118)
+(defconstant *x-getmodifiermapping*	      119)
+(defconstant *x-nooperation*                  127)
+
+;;; Some macros for threaded lists
+
+(defmacro threaded-atomic-push (item list next type)
+  (let ((x (gensym))
+	(y (gensym)))
+    `(let ((,x ,item))
+       (declare (type ,type ,x))
+       (loop
+	 (let ((,y ,list))
+	   (declare (type (or null ,type) ,y)
+		    (optimize (speed 3) (safety 0)))
+	   (setf (,next ,x) ,y)
+	   (when (conditional-store ,list ,y ,x)
+	     (return ,x)))))))
+
+(defmacro threaded-atomic-pop (list next type)
+  (let ((y (gensym)))
+    `(loop
+       (let ((,y ,list))
+	 (declare (type (or null ,type) ,y)
+		  (optimize (speed 3) (safety 0)))
+	 (if (null ,y)
+	     (return nil)
+	   (when (conditional-store ,list ,y (,next (the ,type ,y)))
+	     (setf (,next (the ,type ,y)) nil)
+	     (return ,y)))))))
+
+(defmacro threaded-nconc (item list next type)
+  (let ((first (gensym))
+	(x (gensym))
+	(y (gensym))
+	(z (gensym)))
+    `(let ((,z ,item)
+	   (,first ,list))
+       (declare (type ,type ,z)
+		(type (or null ,type) ,first)
+		(optimize (speed 3) (safety 0)))
+       (if (null ,first)
+	   (setf ,list ,z)
+	 (do* ((,x ,first ,y)
+	       (,y (,next ,x) (,next ,x)))
+	      ((null ,y)
+	       (setf (,next ,x) ,z)
+	       ,first)
+	   (declare (type ,type ,x)
+		    (type (or null ,type) ,y)))))))
+
+(defmacro threaded-push (item list next type)
+  (let ((x (gensym)))
+    `(let ((,x ,item))
+       (declare (type ,type ,x)
+		(optimize (speed 3) (safety 0)))
+       (shiftf (,next ,x) ,list ,x)
+       ,x)))
+
+(defmacro threaded-pop (list next type)
+  (let ((x (gensym)))
+    `(let ((,x ,list))
+       (declare (type (or null ,type) ,x)
+		(optimize (speed 3) (safety 0)))
+       (when ,x
+	 (shiftf ,list (,next (the ,type ,x)) nil))
+       ,x)))
+
+(defmacro threaded-enqueue (item head tail next type)
+  (let ((x (gensym)))
+    `(let ((,x ,item))
+       (declare (type ,type ,x)
+		(optimize (speed 3) (safety 0)))
+       (if (null ,tail)
+	   (threaded-nconc ,x ,head ,next ,type)
+	 (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type))
+       (setf ,tail ,x))))
+
+(defmacro threaded-dequeue (head tail next type)
+  (let ((x (gensym)))
+    `(let ((,x ,head))
+       (declare (type (or null ,type) ,x)
+		(optimize (speed 3) (safety 0)))
+       (when ,x
+	 (when (eq ,x ,tail)
+	   (setf ,tail (,next (the ,type ,x))))
+	 (setf ,head (,next (the ,type ,x))))
+       ,x)))
+
+(defmacro threaded-requeue (item head tail next type)
+  (let ((x (gensym)))
+    `(let ((,x ,item))
+       (declare (type ,type ,x)
+		(optimize (speed 3) (safety 0)))
+       (if (null ,tail)
+	   (setf ,tail (setf ,head ,x))
+	 (shiftf (,next ,x) ,head ,x))
+       ,x)))
+
+(defmacro threaded-dolist ((variable list next type) &body body)
+  `(block nil
+     (do* ((,variable ,list (,next (the ,type ,variable))))
+	  ((null ,variable))
+       (declare (type (or null ,type) ,variable))
+       ,@body)))
+
+(defmacro threaded-delete (item list next type)
+  (let ((x (gensym))
+	(y (gensym))
+	(z (gensym))
+	(first (gensym)))
+    `(let ((,x ,item)
+	   (,first ,list))
+       (declare (type ,type ,x)
+		(type (or null ,type) ,first)
+		(optimize (speed 3) (safety 0)))
+       (when ,first
+	 (if (eq ,first ,x)
+	     (setf ,first (setf ,list (,next ,x)))
+	   (do* ((,y ,first ,z)
+		 (,z (,next ,y) (,next ,y)))
+		((or (null ,z) (eq ,z ,x))
+		 (when (eq ,z ,x)
+		   (setf (,next ,y) (,next ,x))))
+	     (declare (type ,type ,y))
+	     (declare (type (or null ,type) ,z)))))
+       (setf (,next ,x) nil)
+       ,first)))
+
+(defmacro threaded-length (list next type)
+  (let ((x (gensym))
+	(count (gensym)))
+    `(do ((,x ,list (,next (the ,type ,x)))
+	  (,count 0 (index1+ ,count)))
+	 ((null ,x)
+	  ,count)
+       (declare (type (or null ,type) ,x)
+		(type array-index ,count)
+		(optimize (speed 3) (safety 0))))))
+
diff --git a/clx/manager.lisp b/clx/manager.lisp
new file mode 100644
index 000000000..96832df3b
--- /dev/null
+++ b/clx/manager.lisp
@@ -0,0 +1,851 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;;; Window Manager Property functions
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(wm-name		;These are all setf'able accessor functions
+	  wm-icon-name
+	  wm-client-machine
+	  wm-command
+	  wm-hints
+	  wm-normal-hints
+	  icon-sizes
+	  wm-protocols
+	  wm-colormap-windows
+
+	  wm-size-hints
+	  wm-size-hints-p
+	  make-wm-size-hints
+	  wm-size-hints-user-specified-position-p
+	  wm-size-hints-user-specified-size-p
+	  wm-size-hints-min-width
+	  wm-size-hints-min-height
+	  wm-size-hints-max-width
+	  wm-size-hints-max-height
+	  wm-size-hints-width-inc
+	  wm-size-hints-height-inc
+	  wm-size-hints-min-aspect
+	  wm-size-hints-max-aspect
+	  wm-size-hints-base-width
+	  wm-size-hints-base-height
+	  wm-size-hints-win-gravity
+
+	  wm-hints
+	  wm-hints-p
+	  make-wm-hints
+	  wm-hints-input
+	  wm-hints-initial-state
+	  wm-hints-icon-pixmap
+	  wm-hints-icon-window
+	  wm-hints-icon-x
+	  wm-hints-icon-y
+	  wm-hints-icon-mask
+	  wm-hints-window-group
+	  wm-hints-flags
+
+	  transient-for
+
+	  set-wm-properties
+	  iconify-window
+	  withdraw-window
+
+	  get-wm-class
+	  set-wm-class
+	  rgb-colormaps
+
+	  cut-buffer   ;; Setf'able
+	  rotate-cut-buffers
+
+	  ;; Obsolete
+	  wm-zoom-hints
+	  wm-size-hints-x
+	  wm-size-hints-y
+	  wm-size-hints-width
+	  wm-size-hints-height
+	  set-standard-properties
+	  get-standard-colormap
+	  set-standard-colormap
+	  ))
+
+(defun wm-name (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
+
+(defsetf wm-name (window) (name)
+  (declare (type window window))
+  (declare (values string))
+  `(set-string-property ,window :WM_NAME ,name))
+
+(defun set-string-property (window property string)
+  (declare (type window window)
+	   (type keyword property)
+	   (type stringable string))
+  (change-property window property (string string) :STRING 8 :transform #'char->card8)
+  string)
+
+(defun wm-icon-name (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_ICON_NAME :type :STRING
+		:result-type 'string :transform #'card8->char))
+
+(defsetf wm-icon-name (window) (name)
+  `(set-string-property ,window :WM_ICON_NAME ,name))
+
+(defun wm-client-machine (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_CLIENT_MACHINE :type :STRING
+		:result-type 'string :transform #'card8->char))
+
+(defsetf wm-client-machine (window) (name)
+  `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
+
+(defun get-wm-class (window)
+  (declare (type window window))
+  (declare (values (or null name-string) (or null class-string)))
+  (let ((value (get-property window :WM_CLASS :type :STRING
+			     :result-type 'string :transform #'card8->char)))
+    (declare (type (or null string) value))
+    (when value
+      (let* ((name-len (position #.(card8->char 0) (the string value)))
+	     (name (subseq (the string value) 0 name-len))
+	     (class (subseq (the string value) (1+ name-len) (1- (length value)))))
+	(values (and (plusp (length name)) name)
+		(and (plusp (length class)) class))))))
+
+(defun set-wm-class (window resource-name resource-class)
+  (declare (type window window)
+	   (type (or null stringable) resource-name resource-class))
+  (set-string-property window :WM_CLASS
+		       (concatenate 'string
+				    (string (or resource-name ""))
+				    #.(make-string 1 :initial-element (card8->char 0))
+				    (string (or resource-class ""))
+				    #.(make-string 1 :initial-element (card8->char 0))))
+  (values))
+
+(defun wm-command (window)
+  ;; Returns a list whose car is the command and 
+  ;; whose cdr is the list of arguments
+  (declare (type window window))
+  (declare (values list))
+  (do* ((command-string (get-property window :WM_COMMAND :type :STRING
+				      :result-type 'string :transform #'card8->char))
+	(command nil)
+	(start 0 (1+ end))
+	(end 0)
+	(len (length command-string)))
+       ((>= start len) (nreverse command))
+    (setq end (position #.(card8->char 0) command-string :start start))
+    (push (subseq command-string start end) command)))
+
+(defsetf wm-command set-wm-command)
+(defun set-wm-command (window command)
+  ;; Uses PRIN1 to a string-stream with the following bindings:
+  ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
+  ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
+  ;; each element of command is seperated with NULL characters.
+  ;; This enables (mapcar #'read-from-string (wm-command window))
+  ;; to recover a lisp command.
+  (declare (type window window)
+	   (type list command))
+  (set-string-property window :WM_COMMAND
+		       (with-output-to-string (stream)
+			 (let ((*print-length* nil)
+			       (*print-level* nil)
+			       (*print-radix* nil)
+			       (*print-base* 10.)
+			       (*print-array* t)
+			       (*package* (find-package 'lisp))
+			       #+ti (ticl:*print-structure* t))
+			   (dolist (c command)
+			     (prin1 c stream)
+			     (write-char #.(card8->char 0) stream)))))
+  command)
+
+;;-----------------------------------------------------------------------------
+;; WM_HINTS
+
+(def-clx-class (wm-hints)
+  (input nil :type (or null (member :off :on)))
+  (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
+  (icon-pixmap nil :type (or null pixmap))
+  (icon-window nil :type (or null window))
+  (icon-x nil :type (or null card16))
+  (icon-y nil :type (or null card16))
+  (icon-mask nil :type (or null pixmap))
+  (window-group nil :type (or null resource-id))
+  (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
+  ;; may be extended in the future
+  )
+
+(defun wm-hints (window)
+  (declare (type window window))
+  (declare (values wm-hints))
+  (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
+    (when prop
+      (decode-wm-hints prop (window-display window)))))
+
+(defsetf wm-hints set-wm-hints)
+(defun set-wm-hints (window wm-hints)
+  (declare (type window window)
+	   (type wm-hints wm-hints))
+  (declare (values wm-hints))
+  (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
+  wm-hints)
+
+(defun decode-wm-hints (vector display)
+  (declare (type (simple-vector 9) vector)
+	   (type display display))
+  (declare (values wm-hints))
+  (let ((input-hint 0)
+	(state-hint 1)
+	(icon-pixmap-hint 2)
+	(icon-window-hint 3)
+	(icon-position-hint 4)
+	(icon-mask-hint 5)
+	(window-group-hint 6))
+    (let ((flags (aref vector 0))
+	  (hints (make-wm-hints))
+	  (%buffer display))
+      (declare (type card32 flags)
+	       (type wm-hints hints)
+	       (type display %buffer))
+      (setf (wm-hints-flags hints) flags)
+      (when (logbitp input-hint flags)
+	(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
+      (when (logbitp state-hint flags)
+	(setf (wm-hints-initial-state hints)
+	      (decode-type (member :dont-care :normal :zoom :iconic :inactive)
+			   (aref vector 2))))
+      (when (logbitp icon-pixmap-hint flags)
+	(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
+      (when (logbitp icon-window-hint flags)
+	(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
+      (when (logbitp icon-position-hint flags)
+	(setf (wm-hints-icon-x hints) (aref vector 5)
+	      (wm-hints-icon-y hints) (aref vector 6)))
+      (when (logbitp icon-mask-hint flags)
+	(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
+      (when (and (logbitp window-group-hint flags) (> (length vector) 7))
+	(setf (wm-hints-window-group hints) (aref vector 8)))
+      hints)))
+
+
+(defun encode-wm-hints (wm-hints)
+  (declare (type wm-hints wm-hints))
+  (declare (values simple-vector))
+  (let ((input-hint         #b1)
+	(state-hint         #b10)
+	(icon-pixmap-hint   #b100)
+	(icon-window-hint   #b1000)
+	(icon-position-hint #b10000)
+	(icon-mask-hint     #b100000)
+	(window-group-hint  #b1000000)
+	(mask               #b1111111)
+	)
+    (let ((vector (make-array 9 :initial-element 0))
+	  (flags 0))
+      (declare (type (simple-vector 9) vector)
+	       (type card16 flags))
+      (when (wm-hints-input wm-hints)
+	(setf flags input-hint
+	      (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
+      (when (wm-hints-initial-state wm-hints)
+	(setf flags (logior flags state-hint)
+	      (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
+					   (wm-hints-initial-state wm-hints))))
+      (when (wm-hints-icon-pixmap wm-hints)
+	(setf flags (logior flags icon-pixmap-hint)
+	      (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
+      (when (wm-hints-icon-window wm-hints)
+	(setf flags (logior flags icon-window-hint)
+	      (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
+      (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
+	(setf flags (logior flags icon-position-hint)
+	      (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
+	      (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
+      (when (wm-hints-icon-mask wm-hints)
+	(setf flags (logior flags icon-mask-hint)
+	      (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
+      (when (wm-hints-window-group wm-hints)
+	(setf flags (logior flags window-group-hint)
+	      (aref vector 8) (wm-hints-window-group wm-hints)))
+      (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
+      vector)))
+
+;;-----------------------------------------------------------------------------
+;; WM_SIZE_HINTS
+
+(def-clx-class (wm-size-hints)
+  ;; Defaulted T to put the burden of remembering these on widget programmers.
+  (user-specified-position-p nil :type boolean) ;; True when user specified x y
+  (user-specified-size-p nil :type boolean)     ;; True when user specified width height
+  (x nil :type (or null int16))			;; Obsolete
+  (y nil :type (or null int16))			;; Obsolete
+  (width nil :type (or null card16))		;; Obsolete
+  (height nil :type (or null card16))		;; Obsolete
+  (min-width nil :type (or null card16))
+  (min-height nil :type (or null card16))
+  (max-width nil :type (or null card16))
+  (max-height nil :type (or null card16))
+  (width-inc nil :type (or null card16))
+  (height-inc nil :type (or null card16))
+  (min-aspect nil :type (or null number))
+  (max-aspect nil :type (or null number))
+  (base-width nil :type (or null card16))
+  (base-height nil :type (or null card16))
+  (win-gravity nil :type (or null win-gravity)))
+
+
+(defun wm-normal-hints (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
+
+(defsetf wm-normal-hints set-wm-normal-hints)
+(defun set-wm-normal-hints (window hints)
+  (declare (type window window)
+	   (type wm-size-hints hints))
+  (declare (values wm-size-hints))
+  (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
+  hints)
+
+;;; OBSOLETE
+(defun wm-zoom-hints (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
+
+;;; OBSOLETE
+(defsetf wm-zoom-hints set-wm-zoom-hints)
+;;; OBSOLETE
+(defun set-wm-zoom-hints (window hints)
+  (declare (type window window)
+	   (type wm-size-hints hints))
+  (declare (values wm-size-hints))
+  (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
+  hints)
+
+(defun decode-wm-size-hints (vector)
+  (declare (type (or null (simple-vector *)) vector))
+  (declare (values (or null wm-size-hints)))
+  (when vector
+    (let ((usposition 0)		;User Specified position
+	  (ussize 1)			;User Specified size
+	  (pposition 2)			;Program specified position
+	  (psize 3)			;Program specified size
+	  (pminsize 4)			;Program specified minimum size
+	  (pmaxsize 5)			;Program specified maximum size
+	  (presizeinc 6)		;Program specified resize increments
+	  (paspect 7)			;Program specfied min and max aspect ratios
+	  (pbasesize 8)			;Program specified base size
+	  (pwingravity 9)		;Program specified window gravity
+	  )
+      (let ((flags (aref vector 0))
+	    (hints (make-wm-size-hints)))
+	(declare (type card16 flags)
+		 (type wm-size-hints hints))
+	(when (or (logbitp usposition flags)
+		  (logbitp pposition flags))
+	  (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags)
+		(wm-size-hints-x hints) (aref vector 1)
+		(wm-size-hints-y hints) (aref vector 2)))
+	(when (or (logbitp ussize flags)
+		  (logbitp psize flags))
+	  (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags)
+		(wm-size-hints-width hints) (aref vector 3)
+		(wm-size-hints-height hints) (aref vector 4)))
+	(when (logbitp pminsize flags)
+	  (setf (wm-size-hints-min-width hints) (aref vector 5)
+		(wm-size-hints-min-height hints) (aref vector 6)))
+	(when (logbitp pmaxsize flags)
+	  (setf (wm-size-hints-max-width hints) (aref vector 7)
+		(wm-size-hints-max-height hints) (aref vector 8)))
+	(when (logbitp presizeinc flags)
+	  (setf (wm-size-hints-width-inc hints) (aref vector 9)
+		(wm-size-hints-height-inc hints) (aref vector 10)))
+  	(when (logbitp paspect flags)
+ 	  (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
+ 		(wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
+ 	(when (> (length vector) 15)
+ 	  ;; This test is for backwards compatibility since old Xlib programs
+ 	  ;; can set a size-hints structure that is too small.  See ICCCM.
+  	  (when (logbitp pbasesize flags)
+  	    (setf (wm-size-hints-base-width hints) (aref vector 15)
+  		  (wm-size-hints-base-height hints) (aref vector 16)))
+  	  (when (logbitp pwingravity flags)
+  	    (setf (wm-size-hints-win-gravity hints)
+ 	      (decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
+	hints))))
+
+(defun encode-wm-size-hints (hints)
+  (declare (type wm-size-hints hints))
+  (declare (values simple-vector))
+  (let ((usposition  #b1)		;User Specified position
+	(ussize      #b10)		;User Specified size
+	(pposition   #b100)		;Program specified position
+	(psize       #b1000)		;Program specified size
+	(pminsize    #b10000)		;Program specified minimum size
+	(pmaxsize    #b100000)		;Program specified maximum size
+	(presizeinc  #b1000000)		;Program specified resize increments
+	(paspect     #b10000000)	;Program specfied min and max aspect ratios
+	(pbasesize   #b100000000)	;Program specfied base size
+	(pwingravity #b1000000000)	;Program specfied window gravity
+	)
+    (let ((vector (make-array 18 :initial-element 0))
+	  (flags 0))
+      (declare (type (simple-vector 18) vector)
+	       (type card16 flags))
+      (when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
+	(setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition))
+	(setf (aref vector 1) (wm-size-hints-x hints)
+	      (aref vector 2) (wm-size-hints-y hints)))
+      (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
+	(setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize))
+	      (aref vector 3) (wm-size-hints-width hints)
+	      (aref vector 4) (wm-size-hints-height hints)))
+      
+      (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
+	(setf flags (logior flags pminsize)
+	      (aref vector 5) (wm-size-hints-min-width hints)
+	      (aref vector 6) (wm-size-hints-min-height hints)))
+      (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
+	(setf flags (logior flags pmaxsize)
+	      (aref vector 7) (wm-size-hints-max-width hints)
+	      (aref vector 8) (wm-size-hints-max-height hints)))
+      (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
+	(setf flags (logior flags presizeinc)
+	      (aref vector 9) (wm-size-hints-width-inc hints)
+	      (aref vector 10) (wm-size-hints-height-inc hints)))
+      (let ((min-aspect (wm-size-hints-min-aspect hints))
+	    (max-aspect (wm-size-hints-max-aspect hints)))
+	(when (and min-aspect max-aspect)
+	  (setf flags (logior flags paspect)
+		min-aspect (rationalize min-aspect)
+		max-aspect (rationalize max-aspect)
+		(aref vector 11) (numerator min-aspect)
+		(aref vector 12) (denominator min-aspect)
+		(aref vector 13) (numerator max-aspect)
+		(aref vector 14) (denominator max-aspect))))
+      (when (and (wm-size-hints-base-width hints)
+		 (wm-size-hints-base-height hints))
+	(setf flags (logior flags pbasesize)
+	      (aref vector 15) (wm-size-hints-base-width hints)
+	      (aref vector 16) (wm-size-hints-base-height hints)))
+      (when (wm-size-hints-win-gravity hints)
+	(setf flags (logior flags pwingravity)
+	      (aref vector 17) (encode-type
+				(member-vector *win-gravity-vector*)
+				(wm-size-hints-win-gravity hints))))
+      (setf (aref vector 0) flags)
+      vector)))
+
+;;-----------------------------------------------------------------------------
+;; Icon_Size
+
+;; Use the same intermediate structure as WM_SIZE_HINTS
+
+(defun icon-sizes (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
+    (declare (type (or null (simple-vector 6)) vector))
+    (when vector
+      (make-wm-size-hints
+	:min-width (aref vector 0)
+	:min-height (aref vector 1)
+	:max-width (aref vector 2)
+	:max-height (aref vector 3)
+	:width-inc (aref vector 4)
+	:height-inc (aref vector 5)))))
+  
+(defsetf icon-sizes set-icon-sizes)
+(defun set-icon-sizes (window wm-size-hints)
+  (declare (type window window)
+	   (type wm-size-hints wm-size-hints))
+  (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
+			(wm-size-hints-min-height wm-size-hints)
+			(wm-size-hints-max-width wm-size-hints)
+			(wm-size-hints-max-height wm-size-hints)
+			(wm-size-hints-width-inc wm-size-hints)
+			(wm-size-hints-height-inc wm-size-hints))))
+    (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
+    wm-size-hints))
+
+;;-----------------------------------------------------------------------------
+;; WM-Protocols
+
+(defun wm-protocols (window)
+  (map 'list #'(lambda (id) (atom-name (window-display window) id))
+       (get-property window :WM_PROTOCOLS :type :ATOM)))
+
+(defsetf wm-protocols set-wm-protocols)
+(defun set-wm-protocols (window protocols)
+  (change-property window :WM_PROTOCOLS
+		   (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
+			protocols)
+		   :ATOM 32)
+  protocols)
+
+;;-----------------------------------------------------------------------------
+;; WM-Colormap-windows
+
+(defun wm-colormap-windows (window)
+  (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
+			:transform #'(lambda (id)
+				       (lookup-window (window-display window) id)))))
+
+(defsetf wm-colormap-windows set-wm-colormap-windows)
+(defun set-wm-colormap-windows (window colormap-windows)
+  (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
+		   :transform #'window-id)
+  colormap-windows)
+
+;;-----------------------------------------------------------------------------
+;; Transient-For
+
+(defun transient-for (window)
+  (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
+    (and prop (lookup-window (window-display window) (car prop)))))
+
+(defsetf transient-for set-transient-for)
+(defun set-transient-for (window transient)
+  (declare (type window window transient))
+  (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
+  transient)
+
+;;-----------------------------------------------------------------------------
+;; Set-WM-Properties
+
+(defun set-wm-properties (window &rest options &key 
+			  name icon-name resource-name resource-class command
+			  client-machine hints normal-hints zoom-hints
+			  ;; the following are used for wm-normal-hints
+			  user-specified-position-p
+			  user-specified-size-p
+			  x y width height min-width min-height max-width max-height
+			  width-inc height-inc min-aspect max-aspect
+			  base-width base-height win-gravity
+			  ;; the following are used for wm-hints
+			  input initial-state icon-pixmap icon-window
+			  icon-x icon-y icon-mask window-group)
+  ;; Set properties for WINDOW.
+  (declare (arglist window &rest options &key 
+		   name icon-name resource-name resource-class command
+		   client-machine hints normal-hints
+		   ;; the following are used for wm-normal-hints
+		   user-specified-position-p user-specified-size-p
+		   min-width min-height max-width max-height
+		   width-inc height-inc min-aspect max-aspect
+		   base-width base-height win-gravity
+		   ;; the following are used for wm-hints
+		   input initial-state icon-pixmap icon-window
+		   icon-x icon-y icon-mask window-group))
+  (declare (type window window)
+	   (type (or null stringable) name icon-name resource-name resource-class client-machine)
+	   (type (or null list) command)
+	   (type (or null wm-hints) hints)
+	   (type (or null wm-size-hints) normal-hints zoom-hints)
+	   (type (or null boolean) user-specified-position-p user-specified-size-p)
+	   (type (or null int16) x y)
+	   (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
+	   (type (or null win-gravity) win-gravity)
+	   (type (or null number) min-aspect max-aspect)
+	   (type (or null (member :off :on)) input)
+	   (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
+	   (type (or null pixmap) icon-pixmap icon-mask)
+	   (type (or null window) icon-window)
+	   (type (or null card16) icon-x icon-y)
+	   (type (or null resource-id) window-group)
+	   (dynamic-extent options))
+  (when name (setf (wm-name window) name))
+  (when icon-name (setf (wm-icon-name window) icon-name))
+  (when client-machine (setf (wm-client-machine window) client-machine))
+  (when (or resource-name resource-class)
+    (set-wm-class window resource-name resource-class))
+  (when command (setf (wm-command window) command))
+  ;; WM-HINTS
+  (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
+			    :icon-x :icon-y :icon-mask :window-group))
+	(when (getf options arg) (return t)))
+      (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
+	(when input (setf (wm-hints-input wm-hints) input))
+	(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
+	(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
+	(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
+	(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
+	(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
+	(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
+	(when window-group (setf (wm-hints-input wm-hints) window-group))
+	(setf (wm-hints window) wm-hints))
+      (when hints (setf (wm-hints window) hints)))
+  ;; WM-NORMAL-HINTS
+  (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
+			:width-inc :height-inc :min-aspect :max-aspect
+			:user-specified-position-p :user-specified-size-p
+			:base-width :base-height :win-gravity))
+	(when (getf options arg) (return t)))
+      (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
+	(when x (setf (wm-size-hints-x size) x))
+	(when y (setf (wm-size-hints-y size) y))
+	(when width (setf (wm-size-hints-width size) width))
+	(when height (setf (wm-size-hints-height size) height))
+	(when min-width (setf (wm-size-hints-min-width size) min-width))
+	(when min-height (setf (wm-size-hints-min-height size) min-height))
+	(when max-width (setf (wm-size-hints-max-width size) max-width))
+	(when max-height (setf (wm-size-hints-max-height size) max-height))
+	(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
+	(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
+	(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
+	(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
+	(when base-width (setf (wm-size-hints-base-width size) base-width))
+	(when base-height (setf (wm-size-hints-base-height size) base-height))
+	(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
+	(when user-specified-position-p (setf (wm-size-hints-user-specified-position-p size)
+					      user-specified-position-p))
+	(when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size)
+					  user-specified-size-p))
+	(setf (wm-normal-hints window) size))
+      (when normal-hints (setf (wm-normal-hints window) normal-hints)))
+  (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
+  )
+
+;;; OBSOLETE
+(defun set-standard-properties (window &rest options)
+  (declare (dynamic-extent options))
+  (apply #'set-wm-properties window options))
+
+;;-----------------------------------------------------------------------------
+;; WM Control
+
+(defun iconify-window (window screen)
+  (declare (type window window)
+	   (type screen screen))
+  (let ((root (screen-root screen)))
+    (declare (type window root))
+    (send-event root :client-message '(:substructure-redirect :substructure-notify)
+		:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
+
+(defun withdraw-window (window screen)
+  (declare (type window window)
+	   (type screen screen))
+  (unmap-window window)
+  (let ((root (screen-root screen)))
+    (declare (type window root))
+    (send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
+		:window window :event-window root :configure-p nil)))
+
+
+;;-----------------------------------------------------------------------------
+;; Colormaps
+
+(def-clx-class (standard-colormap (:copier nil) (:predicate nil))
+  (colormap nil :type (or null colormap))
+  (base-pixel 0 :type pixel)
+  (max-color nil :type (or null color))
+  (mult-color nil :type (or null color))
+  (visual nil :type (or null visual-info))
+  (kill nil :type (or (member nil :release-by-freeing-colormap)
+		      drawable gcontext cursor colormap font)))
+
+(defun rgb-colormaps (window property)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
+    (declare (type (or null simple-vector) prop))
+    (when prop
+      (list (make-standard-colormap
+	      :colormap (lookup-colormap (window-display window) (aref prop 0))
+	      :base-pixel (aref prop 7)
+	      :max-color (make-color :red   (card16->rgb-val (aref prop 1))
+				     :green (card16->rgb-val (aref prop 3))
+				     :blue  (card16->rgb-val (aref prop 5)))
+	      :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
+				      :green (card16->rgb-val (aref prop 4))
+				      :blue  (card16->rgb-val (aref prop 6)))
+	      :visual (and (<= 9 (length prop))
+			   (visual-info (window-display window) (aref prop 8)))
+	      :kill (and (<= 10 (length prop))
+			 (let ((killid (aref prop 9)))
+			   (if (= killid 1)
+			       :release-by-freeing-colormap
+			       (lookup-resource-id (window-display window) killid)))))))))
+
+(defsetf rgb-colormaps set-rgb-colormaps)
+(defun set-rgb-colormaps (window property maps)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
+	   (type list maps))
+  (let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
+	(index -1))
+    (dolist (map maps)
+      (setf (aref prop (incf index))
+	    (encode-type colormap (standard-colormap-colormap map)))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-red (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-green (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (standard-colormap-base-pixel map))
+      (setf (aref prop (incf index))
+	    (visual-info-id (standard-colormap-visual map)))
+      (setf (aref prop (incf index))
+	    (let ((kill (standard-colormap-kill map)))
+	      (etypecase kill
+		(symbol
+		  (ecase kill
+		    ((nil) 0)
+		    ((:release-by-freeing-colormap) 1)))
+		(drawable (drawable-id kill))
+		(gcontext (gcontext-id kill))
+		(cursor (cursor-id kill))
+		(colormap (colormap-id kill))
+		(font (font-id kill))))))
+    (change-property window property prop :RGB_COLOR_MAP 32)))
+
+;;; OBSOLETE
+(defun get-standard-colormap (window property)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+  (declare (values colormap base-pixel max-color mult-color))
+  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
+    (declare (type (or null simple-vector) prop))
+    (when prop
+      (values (lookup-colormap (window-display window) (aref prop 0))
+	      (aref prop 7)			;Base Pixel
+	      (make-color :red   (card16->rgb-val (aref prop 1))	;Max Color
+			  :green (card16->rgb-val (aref prop 3))
+			  :blue  (card16->rgb-val (aref prop 5)))
+	      (make-color :red   (card16->rgb-val (aref prop 2))	;Mult color
+			  :green (card16->rgb-val (aref prop 4))
+			  :blue  (card16->rgb-val (aref prop 6)))))))
+
+;;; OBSOLETE
+(defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
+	   (type colormap colormap)
+	   (type pixel base-pixel)
+	   (type color max-color mult-color))
+  (let ((prop (apply #'vector (encode-type colormap colormap)
+		     (encode-type rgb-val (color-red max-color))
+		     (encode-type rgb-val (color-red mult-color))
+		     (encode-type rgb-val (color-green max-color))
+		     (encode-type rgb-val (color-green mult-color))
+		     (encode-type rgb-val (color-blue max-color))
+		     (encode-type rgb-val (color-blue mult-color))
+		     base-pixel)))
+    (change-property window property prop :RGB_COLOR_MAP 32)))
+
+;;-----------------------------------------------------------------------------
+;; Cut-Buffers
+
+(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
+		   (transform #'card8->char) (start 0) end)
+  ;; Return the contents of cut-buffer BUFFER
+  (declare (type display display)
+	   (type (integer 0 7) buffer)
+	   (type xatom type)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type t result-type)			;a sequence type
+	   (type (or null (function (integer) t)) transform))
+  (declare (values sequence type format bytes-after))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+			 buffer)))
+    (get-property root property :type type :result-type result-type
+		  :start start :end end :transform transform)))
+
+;; Implement the following:
+;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
+;;			        (transform #'char->card8) (start 0) end) (data)
+;; In order to avoid having to pass positional parameters to set-cut-buffer,
+;; We've got to do the following.  WHAT A PAIN...
+(define-setf-method cut-buffer (display &rest option-list)
+  (declare (dynamic-extent option-list))
+  (do* ((options (copy-list option-list))
+	(option options (cddr option))
+	(store (gensym))
+	(dtemp (gensym))
+	(temps (list dtemp))
+	(values (list display)))
+       ((endp option)
+	(values (nreverse temps)
+		(nreverse values)
+		(list store)
+		`(set-cut-buffer ,store ,dtemp ,@options)
+		`(cut-buffer ,@options)))
+    (unless (member (car option) '(:buffer :type :format :start :end :transform))
+      (error "Keyword arg ~s isn't recognized" (car option)))
+    (let ((x (gensym)))
+      (push x temps)
+      (push (cadr option) values)
+      (setf (cadr option) x))))
+
+(defun set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8)
+		       (start 0) end (transform #'char->card8))
+  (declare (type sequence data)
+	   (type display display)
+	   (type (integer 0 7) buffer)
+	   (type xatom type)
+	   (type (member 8 16 32) format)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type (or null (function (integer) t)) transform))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+			 buffer)))
+    (change-property root property data type format :transform transform :start start :end end)
+    data))
+
+(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
+  ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
+  ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
+  (declare (type display display)
+	   (type int16 delta)
+	   (type boolean careful-p))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
+		     :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
+    (when careful-p
+      (let ((props (list-properties root)))
+	(dotimes (i 8)
+	  (unless (member (aref buffers i) props)
+	    (setf (cut-buffer display :buffer i) "")))))
+    (rotate-properties root buffers delta)))
+
diff --git a/clx/ms-patch.uu b/clx/ms-patch.uu
new file mode 100644
index 000000000..b84726c5c
--- /dev/null
+++ b/clx/ms-patch.uu
@@ -0,0 +1,57 @@
+begin 666 make-sequence-patch.lbin
+M1D%33"!&24Q%.@I&05-,('9E<G-I;VX@,"XP,#4@*&]F(#@V,3$Q,BDL($Q/
+M5U1!1R V.# P,"X*1DE,12!)1#H@(B]M;V1S+W!A=&-H97,O8G5G+3(S-C@N
+M;&)I;B([('9E<G-I;VX@3D5715-4.PIA=71H;W(@<F]G97([(&-R96%T960@
+M.#<P.#(V(#$W.C(T.C W+@I4:&ES(&9I;&4@:7,@=&AE(&]U='!U="!O9B!T
+M:&4@3%5#240L($E.0RX@0V]M;6]N($QI<W @0V]M<&EL97(N"DEN=&5R;F%L
+M(&9A<VP@<F5L96%S92!D871E($IU;F4@,C4L(#$Y.#8N"E-/55)#15,Z"B(O
+M;6]D<R]P871C:&5S+V)U9RTR,S8X+FQI<W B.R!V97)S:6]N($Y%5T535#L*
+M875T:&]R(')O9V5R.R!W<FET=&5N(#@W,#@R-B Q-SHR,SHU,BX*1DQ/050@
+M4$%204U%5$524SH@4F%D:7@Z(#(@4')E8VES:6]N<SH@," P(# @." R,R Q
+M-C @," P(# @," P(# *1D5!5%5215,Z( I"24Y!4ED@1$%402!&3TQ,3U=3
+M.@H]* I)3BU004-+04=% 2@%3%5#240Z3"@A5D%,241!5$4M4T51545.0T4M
+M4D5354Q4+5194$534$5#.Q@\_0*'#$8  F<0#$8  6<()&P XTZJ  4O#"!N
+M__0B;0 18 0B:0 #( D"   '#    6<$)$Q@"+'I  =FYB1)N<IG$"U(  0J
+M;O_\3^[_^"973M-/[O_PL>T %682+6T &0 $*F[__$_N__@F5T[3L>T '6<&
+ML>T (682+6T )0 $*F[__$_N__@F5T[3L>T *682+6T +0 $*F[__$_N__@F
+M5T[3(&[_]+G(9PX@" (   <,   !9@ #^B!N__0O*  '0J<O#B\-2'H &B\(
+M? $D;0 Q*FH $]S\_^0@;0 !3N@ !4Y>)&T -;7N_^QF  &X("[_Z R     
+M#&<L0J<O#B\-2'H ("\M #DO+O_T? (D;0 ]*FH $]S\_^ @;0 !3N@ !4Y>
+M6(\@;O_T(F@  R1M $&UZ0 '9P  @B!N__0B:  #(FD  R1M $&UZ0 '9RQ"
+MIR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_X"!M  %.Z  %3EY8CR)N
+M__0B:0 #(&D !R)N__0B:0 #(FD  R\I  <B;O_T(FD  R-N_^0 !R)N__0B
+M:0 #(FD  R-(  =/[O_H0J<O#B\-2'H +"!N__0B:  #(FD  R\I  <O+O_P
+M? (D;0!%*FH $]S\_^ @;0 !3N@ !4Y>(&[_Y")M $E@!")I  ,@"0(   <,
+M   !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN<AG$" ( @  !PP 
+M  %G!"\,8!(D;0 UM>@ !R1,9P0D;  W+PJY[O_<9P)@*D*G+PXO#4AZ " O
+M+0 Y+R[_]'P")&T /2IJ !/<_/_4(&T  4[H  5.7D_N_^0@;O_T(F@  R)I
+M  ,C;O_D  <M2  $*F[__$_N__@F5T[3)&T 3;7N_^QF>B N_^@,@     1F
+M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@     AG*@R     #&<B+6[_]/_P
+M+6T .?_T? (D;0 ]*FH $R!M  %/[O_P3N@ !2!N__0B:  #(&D !RU(__1\
+M 21M %$J:@ 3(&T  4_N__1.Z  %(&[_[+'M %5G!K'M %EF7B N_^@,@   
+M  QG+$*G+PXO#4AZ " O+0 Y+R[_]'P")&T /2IJ !/<_/_@(&T  4[H  5.
+M7EB/(&[_]")H  ,@:0 '+4C_]'P!)&T 42IJ !,@;0 !3^[_]$[H  4O+0!)
+M(&[_[")N_^1@!")I  ,@"0(   <,   !9P0D3& (L>D !V;F)$FYRF<  (0@
+M+O_H#(     (9RQ"IR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_W"!M
+M  %.Z  %3EY8CR!N_^RQ[0 59A(M;0 9  0J;O_\3^[_^"973M.Q[0 =9Q:Q
+M[0 A9Q M2  $*F[__$_N__@F5T[3+6T )0 $*F[__$_N__@F5T[33^[_Z+GN
+M__!G F X0J<O#B\-2'H '"\N__1\ 21M %TJ:@ 3W/S_X"!M  %.Z  %3EXM
+M7__T+6P -__P3^[_\&  ^XHM;O_T__ M;0 Y__1\ B1M #TJ:@ 3(&T  4_N
+M__!.Z  %N>[_\&<"8#1"IR\.+PU(>@ <+R[_]'P!)&T 72IJ !/<_/_H(&T 
+M 4[H  5.7BU?__0M;  W__!@ /LL+6[_]/_P+6T .?_T? (D;0 ]*FH $R!M
+M  %/[O_P3N@ !?X"!20N* A465!%4U!%0R@))D]05$E/3D%,* M.3U)-04Q)
+M6D5$4#A,* 1,25-4* 1.54Q,3"@&5D5#5$]23 $U#"@-4TE-4$Q%+59%0U1/
+M4DPH#5-)35!,12U35%))3D=,*!)324U03$4M,4))5"U614-43U(H$E-)35!,
+M12TR0DE4+59%0U1/4B@24TE-4$Q%+31"250M5D5#5$]2*!)324U03$4M.$))
+M5"U614-43U(H$U-)35!,12TQ-D))5"U614-43U(H$U-)35!,12TS,D))5"U6
+M14-43U(H&5-)35!,12U324=.140M.$))5"U614-43U(H&E-)35!,12U324=.
+M140M,39"250M5D5#5$]2*!I324U03$4M4TE'3D5$+3,R0DE4+59%0U1/4B@:
+M4TE-4$Q%+5-)3D=,12U&3$]!5"U614-43U),* 935%))3D?^"TPH"D))5"U6
+M14-43U),*!%324U03$4M0DE4+59%0U1/4OX,* A315%514Y#12Y,* )/4OX&
+M_@@H"TQ)4U0M3$5.1U1(_AHB.7Y3(&ES(&%N(&EN=F%L:60@;W(@=6YR97-O
+M;'9A8FQE(')E<W5L="!S97%U96YC92!T>7!E<W!E8R@%15)23U+^!OX".07^
+M"/X6_A?^&/X)_@@H'5-)35!,12U614-43U(M5%E012U&4D]-+45465!%* 5!
+M4E)!62@,4TE-4$Q%+4%24D%9* Y.3U)-04Q)6D4M5%E014$*14Y$($]&($9!
+(4TP@1$%400I-
+ 
+end
diff --git a/clx/provide.lisp b/clx/provide.lisp
new file mode 100644
index 000000000..d6c9066c7
--- /dev/null
+++ b/clx/provide.lisp
@@ -0,0 +1,41 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER;  -*-
+
+;;;; Module definition for CLX
+
+;;; This file is a Common Lisp Module description, but you will have to edit
+;;; it to meet the needs of your site.
+
+;;; Ideally, this file (or a file that loads this file) should be
+;;; located in the system directory that REQUIRE searches.  Thus a user
+;;; would say
+;;;			(require :clx)
+;;; to load CLX.  If there is no such registry, then the user must
+;;; put in a site specific
+;;;			(require :clx <pathname-of-this-file>)
+;;;
+
+(in-package :user)
+
+(provide :clx)
+
+;;; Load the defsystem file from the source directory.  You may
+;;; want to include an explicit extension (such as ".l" or ".lisp").
+;;;
+(load "/src/local/clx/defsystem.l")
+
+;;; The binary files for a particular lisp implementation and architecture.
+;;;
+(let ((lisp
+	(or #+lucid "lucid"
+            #+excl  "franz"
+	    #+akcl  "akcl"
+	    #+kcl   "kcl"
+            #+ibcl  "ibcl"
+	    (error "Can't figure out what lisp vendor this lisp is from.")))
+      (computer
+	(or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3"
+	    #+(or sun4 sparc) "sparc"
+	    #+(and hp (or mc68000 mc68020)) "hp9000-300"
+	    #+vax "vax"
+	    (error "Can't figure out what computer vendor this computer is from."))))
+  (xlib:load-clx (format nil "/src/local/clx/~A.~A/" lisp computer)))
diff --git a/clx/requests.lisp b/clx/requests.lisp
new file mode 100644
index 000000000..5f6ce462d
--- /dev/null
+++ b/clx/requests.lisp
@@ -0,0 +1,1590 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(create-window
+	  destroy-window
+	  destroy-subwindows
+	  add-to-save-set
+	  remove-from-save-set
+	  reparent-window
+	  map-window
+	  map-subwindows
+	  unmap-window
+	  unmap-subwindows
+	  circulate-window-up
+	  circulate-window-down
+	  query-tree
+	  intern-atom
+	  find-atom
+	  atom-name
+	  change-property
+	  delete-property
+	  get-property
+	  rotate-properties
+	  list-properties
+	  set-selection-owner
+	  selection-owner
+	  selection-owner
+	  convert-selection
+	  send-event
+	  grab-pointer
+	  ungrab-pointer
+	  grab-button
+	  ungrab-button
+	  change-active-pointer-grab
+	  grab-keyboard
+	  ungrab-keyboard
+	  grab-key
+	  ungrab-key
+	  allow-events
+	  grab-server
+	  ungrab-server
+	  with-server-grabbed
+	  query-pointer
+	  pointer-position
+	  global-pointer-position
+	  motion-events
+	  translate-coordinates
+	  warp-pointer
+	  warp-pointer-relative
+	  warp-pointer-if-inside
+	  warp-pointer-relative-if-inside
+	  set-input-focus
+	  input-focus
+	  query-keymap
+	  create-pixmap
+	  free-pixmap
+	  clear-area
+	  copy-area
+	  copy-plane
+	  create-colormap
+	  free-colormap
+	  copy-colormap-and-free
+	  install-colormap
+	  uninstall-colormap
+	  installed-colormaps
+	  alloc-color
+	  alloc-color-cells
+	  alloc-color-planes
+	  free-colors
+	  store-color
+	  store-colors
+	  query-colors
+	  lookup-color
+	  create-cursor
+	  create-glyph-cursor
+	  free-cursor
+	  recolor-cursor
+	  query-best-cursor
+	  query-best-tile
+	  query-best-stipple
+	  query-extension
+	  list-extensions
+	  change-keyboard-control
+	  keyboard-control
+	  bell
+	  pointer-mapping
+	  set-pointer-mapping
+	  pointer-mapping
+	  change-pointer-control
+	  pointer-control
+	  set-screen-saver
+	  screen-saver
+	  activate-screen-saver
+	  reset-screen-saver
+	  add-access-host
+	  remove-access-host
+	  access-hosts
+	  access-control
+	  set-access-control
+	  access-control
+	  close-down-mode
+	  set-close-down-mode
+	  kill-client
+	  kill-temporary-clients
+	  no-operation
+	  ))
+
+(defun create-window (&key
+		      (parent (required-arg parent))
+		      (x (required-arg x))
+		      (y (required-arg y))
+		      (width (required-arg width))
+		      (height (required-arg height))
+		      (depth 0) (border-width 0)
+		      (class :copy) (visual :copy)
+		      background border
+		      bit-gravity gravity
+		      backing-store backing-planes backing-pixel save-under
+		      event-mask do-not-propagate-mask override-redirect
+		      colormap cursor)
+  ;; Display is obtained from parent.  Only non-nil attributes are passed on in
+  ;; the request: the function makes no assumptions about what the actual protocol
+  ;; defaults are.  Width and height are the inside size, excluding border.
+  (declare (type window parent) ; required
+	   (type int16 x y) ;required
+	   (type card16 width height) ;required
+	   (type card16 depth border-width)
+	   (type (member :copy :input-output :input-only) class)
+	   (type (or (member :copy) visual-info resource-id) visual)
+	   (type (or null (member :none :parent-relative) pixel pixmap) background)
+	   (type (or null (member :copy) pixel pixmap) border)
+	   (type (or null bit-gravity) bit-gravity)
+	   (type (or null win-gravity) gravity)
+	   (type (or null (member :not-useful :when-mapped :always)) backing-store)
+	   (type (or null pixel) backing-planes backing-pixel)
+	   (type (or null event-mask) event-mask)
+	   (type (or null device-event-mask) do-not-propagate-mask)
+	   (type (or null (member :on :off)) save-under override-redirect)
+	   (type (or null (member :copy) colormap) colormap)
+	   (type (or null (member :none) cursor) cursor))
+  (declare (values window))
+  (let* ((display (window-display parent))
+	 (window (make-window :display display))
+	 (wid (allocate-resource-id display window 'window))
+	 back-pixmap back-pixel
+	 border-pixmap border-pixel)
+    (declare (type display display)
+	     (type window window)
+	     (type resource-id wid)
+	     (type (or null resource-id) back-pixmap border-pixmap)
+	     (type (or null pixel) back-pixel border-pixel))
+    (setf (window-id window) wid)
+    (case background
+      ((nil) nil)
+      (:none (setq back-pixmap 0))
+      (:parent-relative (setq back-pixmap 1))
+      (otherwise
+       (if (type? background 'pixmap)
+	   (setq back-pixmap (pixmap-id background))
+	 (if (integerp background)
+	     (setq back-pixel background)
+	   (x-type-error background
+			 '(or null (member :none :parent-relative) integer pixmap))))))
+    (case border
+      ((nil) nil)
+      (:copy (setq border-pixmap 0))
+      (otherwise
+       (if (type? border 'pixmap)
+	   (setq border-pixmap (pixmap-id border))
+	 (if (integerp border)
+	     (setq border-pixel border)
+	   (x-type-error border '(or null (member :copy) integer pixmap))))))
+    (when event-mask
+      (setq event-mask (encode-event-mask event-mask)))
+    (when do-not-propagate-mask
+      (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
+
+						;Make the request
+    (with-buffer-request (display *x-createwindow*)
+      (data depth)
+      (resource-id wid)
+      (window parent)
+      (int16 x y)
+      (card16 width height border-width)
+      ((member16 :copy :input-output :input-only) class)
+      (resource-id (cond ((eq visual :copy)
+			  0)
+			 ((typep visual 'resource-id)
+			  visual)
+			 (t
+			  (visual-info-id visual))))
+      (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)
+	    ((member-vector *bit-gravity-vector*) bit-gravity)
+	    ((member-vector *win-gravity-vector*) gravity)
+	    ((member :not-useful :when-mapped :always) backing-store)
+	    (card32  backing-planes backing-pixel)
+	    ((member :off :on) override-redirect save-under)
+	    (card32 event-mask do-not-propagate-mask)
+	    ((or (member :copy) colormap) colormap)
+	    ((or (member :none) cursor) cursor)))
+    window))
+
+(defun destroy-window (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-destroywindow*)
+    (window window)))
+
+(defun destroy-subwindows (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-destroysubwindows*)
+    (window window)))
+
+(defun add-to-save-set (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-changesaveset*)
+    (data 0)
+    (window window)))
+
+(defun remove-from-save-set (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-changesaveset*)
+    (data 1)
+    (window window)))
+
+(defun reparent-window (window parent x y)
+  (declare (type window window parent)
+	   (type int16 x y))
+  (with-buffer-request ((window-display window) *x-reparentwindow*)
+    (window window parent)
+    (int16 x y)))
+
+(defun map-window (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-mapwindow*)
+    (window window)))
+
+(defun map-subwindows (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-mapsubwindows*)
+    (window window)))
+
+(defun unmap-window (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-unmapwindow*)
+    (window window)))
+
+(defun unmap-subwindows (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-unmapsubwindows*)
+    (window window)))
+
+(defun circulate-window-up (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-circulatewindow*)
+    (data 0)
+    (window window)))
+
+(defun circulate-window-down (window)
+  (declare (type window window))
+  (with-buffer-request ((window-display window) *x-circulatewindow*)
+    (data 1)
+    (window window)))
+
+(defun query-tree (window &key (result-type 'list))
+  (declare (type window window)
+	   (type t result-type)) ;;type specifier
+  (declare (values (sequence window) parent root))
+  (let ((display (window-display window)))
+    (multiple-value-bind (root parent sequence)
+	(with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32))
+	     ((window window))
+	  (values
+	    (window-get 8)
+	    (resource-id-get 12)
+	    (sequence-get :length (card16-get 16) :result-type result-type
+			  :index *replysize*)))
+      ;; Parent is NIL for root window
+      (setq parent (and (plusp parent) (lookup-window display parent)))
+      (dotimes (i (length sequence))		; Convert ID's to window's
+	(setf (elt sequence i) (lookup-window display (elt sequence i))))
+      (values sequence parent root))))
+
+;; Although atom-ids are not visible in the normal user interface, atom-ids might
+;; appear in window properties and other user data, so conversion hooks are needed.
+
+(defun intern-atom (display name)
+  (declare (type display display)
+	   (type xatom name))
+  (declare (values resource-id))
+  (let ((keyword (if (keywordp name) name (kintern (string name)))))
+    (declare (type keyword keyword))
+    (or (atom-id keyword display)
+	(let ((string (symbol-name keyword)))
+	  (declare (type string string))
+	  (multiple-value-bind (id)
+	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
+		   ((data 0)
+		    (card16 (length string))
+		    (pad16 nil)
+		    (string string))
+		(values
+		  (resource-id-get 8)))
+	    (declare (type resource-id id))
+	    (setf (atom-id keyword display) id)
+	    id)))))
+
+(defun find-atom (display name)
+  ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
+  (declare (type display display)
+	   (type xatom name))
+  (declare (values (or null resource-id)))
+  (let ((keyword (if (keywordp name) name (kintern (string name)))))
+    (declare (type keyword keyword))
+    (or (atom-id keyword display)
+	(let ((string (symbol-name keyword)))
+	  (declare (type string string))
+	  (multiple-value-bind (id)
+	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
+		   ((data 1)
+		    (card16 (length string))
+		    (pad16 nil)
+		    (string string))
+		(values
+		  (or-get 8 null resource-id)))
+	    (declare (type (or null resource-id) id))
+	    (when id 
+	      (setf (atom-id keyword display) id))
+	    id)))))
+
+(defun atom-name (display atom-id)
+  (declare (type display display)
+	   (type resource-id atom-id))
+  (declare (values keyword))
+  (or (id-atom atom-id display)
+      (let ((keyword
+	      (kintern
+		(with-buffer-request-and-reply (display *x-getatomname* nil :sizes (16))
+		     ((resource-id atom-id))
+		  (values
+		    (string-get (card16-get 8) *replysize*))))))
+	(declare (type keyword keyword))
+	(setf (atom-id keyword display) atom-id)
+	keyword)))
+
+;;; For binary compatibility with older code
+(defun lookup-xatom (display atom-id)
+  (declare (type display display)
+	   (type resource-id atom-id))
+  (atom-name display atom-id))
+
+(defun change-property (window property data type format
+		       &key (mode :replace) (start 0) end transform)
+  ; Start and end affect sub-sequence extracted from data.
+  ; Transform is applied to each extracted element.
+  (declare (type window window)
+	   (type xatom property type)
+	   (type (member 8 16 32) format)
+	   (type sequence data)
+	   (type (member :replace :prepend :append) mode)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type t transform))			;(or null (function (t) integer))
+  (unless end (setq end (length data)))
+  (let* ((display (window-display window))
+	 (length (index- end start))
+	 (property-id (intern-atom display property))
+	 (type-id (intern-atom display type)))
+    (declare (type display display)
+	     (type array-index length)
+	     (type resource-id property-id type-id))
+    (with-buffer-request (display *x-changeproperty*)
+      ((data (member :replace :prepend :append)) mode)
+      (window window)
+      (resource-id property-id type-id)
+      (card8 format)
+      (card32 length)
+      (progn
+	(ecase format
+	  (8  (sequence-put 24 data :format card8
+			    :start start :end end :transform transform))
+	  (16 (sequence-put 24 data :format card16
+			    :start start :end end :transform transform))
+	  (32 (sequence-put 24 data :format card32
+			    :start start :end end :transform transform)))))))
+
+(defun delete-property (window property)
+  (declare (type window window)
+	   (type xatom property))
+  (let* ((display (window-display window))
+	 (property-id (intern-atom display property)))
+    (declare (type display display)
+	     (type resource-id property-id))
+    (with-buffer-request (display *x-deleteproperty*)
+      (window window)
+      (resource-id property-id))))
+
+(defun get-property (window property
+		     &key type (start 0) end delete-p (result-type 'list) transform)
+  ;; Transform is applied to each integer retrieved.
+  (declare (type window window)
+	   (type xatom property)
+	   (type (or null xatom) type)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type boolean delete-p)
+	   (type t result-type)			;a sequence type
+	   (type t transform))			;(or null (function (integer) t))
+  (declare (values data (or null type) format bytes-after))
+  (let* ((display (window-display window))
+	 (property-id (intern-atom display property))
+	 (type-id (and type (intern-atom display type))))
+    (declare (type display display)
+	     (type resource-id property-id)
+	     (type (or null resource-id) type-id))
+    (multiple-value-bind (reply-format reply-type bytes-after data)
+	(with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32))
+	     (((data boolean) delete-p)
+	      (window window)
+	      (resource-id property-id)
+	      ((or null resource-id) type-id)
+	      (card32 start)
+	      (card32 (index- (or end 64000) start)))
+	  (let ((reply-format (card8-get 1))
+		(reply-type (card32-get 8))
+		(bytes-after (card32-get 12))
+		(nitems (card32-get 16)))
+	    (values
+	      reply-format
+	      reply-type
+	      bytes-after
+	      (and (plusp nitems)
+		   (ecase reply-format
+		     (0  nil) ;; (make-sequence result-type 0) ;; Property not found.
+		     (8  (sequence-get :result-type result-type :format card8
+				       :length nitems :transform transform
+				       :index *replysize*))
+		     (16 (sequence-get :result-type result-type :format card16
+				       :length nitems :transform transform
+				       :index *replysize*))
+		     (32 (sequence-get :result-type result-type :format card32
+				       :length nitems :transform transform
+				       :index *replysize*)))))))
+      (values data
+	      (and (plusp reply-type) (atom-name display reply-type))
+	      reply-format
+	      bytes-after))))
+
+(defun rotate-properties (window properties &optional (delta 1))
+  ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
+  (declare (type window window)
+	   (type sequence properties) ;; sequence of xatom
+	   (type int16 delta))
+  (let* ((display (window-display window))
+	 (length (length properties))
+	 (sequence (make-array length)))
+    (declare (type display display)
+	     (type array-index length))
+    (with-vector (sequence vector)
+      ;; Atoms must be interned before the RotateProperties request
+      ;; is started to allow InternAtom requests to be made.
+      (dotimes (i length)
+	(setf (aref sequence i) (intern-atom display (elt properties i))))
+      (with-buffer-request (display *x-rotateproperties*)
+	(window window)
+	(card16 length)
+	(int16 (- delta))
+	((sequence :end length) sequence))))
+  nil)
+
+(defun list-properties (window &key (result-type 'list))
+  (declare (type window window)
+	   (type t result-type)) ;; a sequence type
+  (declare (values (sequence keyword)))
+  (let ((display (window-display window)))
+    (multiple-value-bind (seq)
+	(with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16)
+	     ((window window))
+	  (values
+	    (sequence-get :result-type result-type :length (card16-get 8)
+			  :index *replysize*)))
+      ;; lookup the atoms in the sequence
+      (if (listp seq)
+	  (do ((elt seq (cdr elt)))
+	      ((endp elt) seq)
+	    (setf (car elt) (atom-name display (car elt))))
+	(dotimes (i (length seq) seq)
+	  (setf (aref seq i) (atom-name display (aref seq i))))))))
+
+(defun selection-owner (display selection)
+  (declare (type display display)
+	   (type xatom selection))
+  (declare (values (or null window)))
+  (let ((selection-id (intern-atom display selection)))
+    (declare (type resource-id selection-id))
+    (multiple-value-bind (window)
+	(with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32)
+	     ((resource-id selection-id))
+	  (values
+	    (resource-id-or-nil-get 8)))
+      (and window (lookup-window display window)))))
+
+(defun set-selection-owner (display selection owner &optional time)
+  (declare (type display display)
+	   (type xatom selection)
+	   (type (or null window) owner)
+	   (type timestamp time))
+  (let ((selection-id (intern-atom display selection)))
+    (declare (type resource-id selection-id))
+    (with-buffer-request (display *x-setselectionowner*)
+      ((or null window) owner)
+      (resource-id selection-id)
+      ((or null card32) time))
+    owner))
+
+(defsetf selection-owner (display selection &optional time) (owner)
+  ;; A bit strange, but retains setf form.
+  `(set-selection-owner ,display ,selection ,owner ,time))
+
+(defun convert-selection (selection type requestor &optional property time)
+  (declare (type xatom selection type)
+	   (type window requestor)
+	   (type (or null xatom) property)
+	   (type timestamp time))
+  (let* ((display (window-display requestor))
+	 (selection-id (intern-atom display selection))
+	 (type-id (intern-atom display type))
+	 (property-id (and property (intern-atom display property))))
+    (declare (type display display)
+	     (type resource-id selection-id type-id)
+	     (type (or null resource-id) property-id))
+    (with-buffer-request (display *x-convertselection*)
+      (window requestor)
+      (resource-id selection-id type-id)
+      ((or null resource-id) property-id)
+      ((or null card32) time))))
+
+(defun send-event (window event-key event-mask &rest args
+		   &key propagate-p display &allow-other-keys)
+  ;; Additional arguments depend on event-key, and are as specified further below
+  ;; with declare-event, except that both resource-ids and resource objects are
+  ;; accepted in the event components.  The display argument is only required if the
+  ;; window is :pointer-window or :input-focus.
+  (declare (type (or window (member :pointer-window :input-focus)) window)
+	   (type event-key event-key)
+	   (type (or null event-mask) event-mask)
+	   (type boolean propagate-p)
+	   (type (or null display) display)
+	   (dynamic-extent args))
+  (unless event-mask (setq event-mask 0))
+  (unless display (setq display (window-display window)))
+  (let ((internal-event-code (get-event-code event-key))
+	(external-event-code (get-external-event-code display event-key)))
+    (declare (type card8 internal-event-code external-event-code))
+    ;; Ensure keyword atom-id's are cached
+    (dolist (arg (cdr (assoc event-key '((:property-notify :atom)
+					 (:selection-clear :selection)
+					 (:selection-request :selection :target :property)
+					 (:selection-notify :selection :target :property)
+					 (:client-message :type))
+			     :test #'eq)))
+      (let ((keyword (getf args arg)))
+	(intern-atom display keyword)))
+    ;; Make the sendevent request
+    (with-buffer-request (display *x-sendevent*)
+      ((data boolean) propagate-p)
+      (length 11) ;; 3 word request + 8 words for event = 11
+      ((or (member :pointer-window :input-focus) window) window)
+      (card32 (encode-event-mask event-mask))
+      (card8 external-event-code)
+      (progn
+	(apply (svref *event-send-vector* internal-event-code) display args)
+	(setf (buffer-boffset display) (index+ buffer-boffset 44))))))
+
+(defun grab-pointer (window event-mask
+		     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
+  (declare (type window window)
+	   (type pointer-event-mask event-mask)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or null window) confine-to)
+	   (type (or null cursor) cursor)
+	   (type timestamp time))
+  (declare (values grab-status))
+  (let ((display (window-display window)))
+    (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8)
+	 (((data boolean) owner-p)
+	  (window window)
+	  (card16 (encode-pointer-event-mask event-mask))
+	  (boolean (not sync-pointer-p) (not sync-keyboard-p))
+	  ((or null window) confine-to)
+	  ((or null cursor) cursor)
+	  ((or null card32) time))
+      (values
+	(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
+
+(defun ungrab-pointer (display &key time)
+  (declare (type timestamp time))
+  (with-buffer-request (display *x-ungrabpointer*)
+    ((or null card32) time)))
+
+(defun grab-button (window button event-mask
+		    &key (modifiers 0)
+			 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
+  (declare (type window window)
+	   (type (or (member :any) card8) button)
+	   (type modifier-mask modifiers)
+	   (type pointer-event-mask event-mask)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or null window) confine-to)
+	   (type (or null cursor) cursor))
+  (with-buffer-request ((window-display window) *x-grabbutton*)
+    ((data boolean) owner-p)
+    (window window)
+    (card16 (encode-pointer-event-mask event-mask))
+    (boolean (not sync-pointer-p) (not sync-keyboard-p))
+    ((or null window) confine-to)
+    ((or null cursor) cursor)
+    (card8 (if (eq button :any) 0 button))
+    (pad8 1)
+    (card16 (encode-modifier-mask modifiers))))
+
+(defun ungrab-button (window button &key (modifiers 0))
+  (declare (type window window)
+	   (type (or (member :any) card8) button)
+	   (type modifier-mask modifiers))
+  (with-buffer-request ((window-display window) *x-ungrabbutton*)
+    (data (if (eq button :any) 0 button))
+    (window window)
+    (card16 (encode-modifier-mask modifiers))))
+
+(defun change-active-pointer-grab (display event-mask &optional cursor time)
+  (declare (type display display)
+	   (type pointer-event-mask event-mask)
+	   (type (or null cursor) cursor)
+	   (type timestamp time))
+  (with-buffer-request (display *x-changeactivepointergrab*)
+    ((or null cursor) cursor)
+    ((or null card32) time)
+    (card16 (encode-pointer-event-mask event-mask))))
+
+(defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
+  (declare (type window window)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type timestamp time))
+  (declare (values grab-status))
+  (let ((display (window-display window)))
+    (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8)
+	 (((data boolean) owner-p)
+	  (window window)
+	  ((or null card32) time)
+	  (boolean (not sync-pointer-p) (not sync-keyboard-p)))
+      (values
+	(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
+
+(defun ungrab-keyboard (display &key time)
+  (declare (type display display)
+	   (type timestamp time))
+  (with-buffer-request (display *x-ungrabkeyboard*)
+    ((or null card32) time)))
+
+(defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
+  (declare (type window window)
+	   (type boolean owner-p sync-pointer-p sync-keyboard-p)
+	   (type (or (member :any) card8) key)
+	   (type modifier-mask modifiers))
+  (with-buffer-request ((window-display window) *x-grabkey*)
+    ((data boolean) owner-p)
+    (window window)
+    (card16 (encode-modifier-mask modifiers))
+    (card8 (if (eq key :any) 0 key))
+    (boolean (not sync-pointer-p) (not sync-keyboard-p))))
+
+(defun ungrab-key (window key &key (modifiers 0))
+  (declare (type window window)
+	   (type (or (member :any) card8) key)
+	   (type modifier-mask modifiers))
+  (with-buffer-request ((window-display window) *x-ungrabkey*)
+    (data (if (eq key :any) 0 key))
+    (window window)
+    (card16 (encode-modifier-mask modifiers))))
+
+(defun allow-events (display mode &optional time)
+  (declare (type display display)
+	   (type (member :async-pointer :sync-pointer :replay-pointer
+			 :async-keyboard :sync-keyboard :replay-keyboard
+			 :async-both :sync-both)
+		 mode)
+	   (type timestamp time))
+  (with-buffer-request (display *x-allowevents*)
+    ((data (member :async-pointer :sync-pointer :replay-pointer
+		   :async-keyboard :sync-keyboard :replay-keyboard
+		   :async-both :sync-both))
+     mode)
+    ((or null card32) time)))
+
+(defun grab-server (display)
+  (declare (type display display))
+  (with-buffer-request (display *x-grabserver*)))
+
+(defun ungrab-server (display)
+  (with-buffer-request (display *x-ungrabserver*)))
+
+(defmacro with-server-grabbed ((display) &body body)
+  ;; The body is not surrounded by a with-display.
+  (let ((disp (if (symbolp display) display (gensym))))
+    `(let ((,disp ,display))
+       (declare (type display ,disp))
+       (unwind-protect
+	   (progn
+	     (grab-server ,disp)
+	     ,@body)
+	 (ungrab-server ,disp)))))
+
+(defun query-pointer (window)
+  (declare (type window window))
+  (declare (values x y same-screen-p child mask root-x root-y root))
+  (let ((display (window-display window)))
+    (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32))
+	 ((window window))
+      (values
+	(int16-get 20)
+	(int16-get 22)
+	(boolean-get 1)
+	(or-get 12 null window)
+	(card16-get 24)
+	(int16-get 16)
+	(int16-get 18)
+	(window-get 8)))))
+
+(defun pointer-position (window)
+  (declare (type window window))
+  (declare (values x y same-screen-p))
+  (let ((display (window-display window)))
+    (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16))
+	 ((window window))
+      (values
+	(int16-get 20)
+	(int16-get 22)
+	(boolean-get 1)))))
+
+(defun global-pointer-position (display)
+  (declare (type display display))
+  (declare (values root-x root-y root))
+  (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32))
+       ((window (screen-root (first (display-roots display)))))
+    (values
+      (int16-get 16)
+      (int16-get 18)
+      (window-get 8))))
+
+(defun motion-events (window &key start stop (result-type 'list))
+  (declare (type window window)
+	   (type timestamp start stop)
+	   (type t result-type)) ;; a type specifier
+  (declare (values (repeat-seq (integer x) (integer y) (timestamp time))))
+  (let ((display (window-display window)))
+    (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32)
+	 ((window window)
+	  ((or null card32) start stop))
+      (values
+	(sequence-get :result-type result-type :length (index* (card32-get 8) 3)
+		      :index *replysize*)))))
+
+(defun translate-coordinates (src src-x src-y dst)
+  ;; Returns NIL when not on the same screen
+  (declare (type window src)
+	   (type int16 src-x src-y)
+	   (type window dst))
+  (declare (values dst-x dst-y child))
+  (let ((display (window-display src)))
+    (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32))
+	 ((window src dst)
+	  (int16 src-x src-y))
+      (and (boolean-get 1)
+	   (values
+	     (int16-get 12)
+	     (int16-get 14)
+	     (or-get 8 null window))))))
+
+(defun warp-pointer (dst dst-x dst-y)
+  (declare (type window dst)
+	   (type int16 dst-x dst-y))
+  (with-buffer-request ((window-display dst) *x-warppointer*)
+    (resource-id 0) ;; None
+    (window dst)
+    (int16 0 0)
+    (card16 0 0)
+    (int16 dst-x dst-y)))
+
+(defun warp-pointer-relative (display x-off y-off)
+  (declare (type display display)
+	   (type int16 x-off y-off))
+  (with-buffer-request (display *x-warppointer*)
+    (resource-id 0) ;; None
+    (resource-id 0) ;; None
+    (int16 0 0)
+    (card16 0 0)
+    (int16 x-off y-off)))
+
+(defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
+			       &optional src-width src-height)
+  ;; Passing in a zero src-width or src-height is a no-op.
+  ;; A null src-width or src-height translates into a zero value in the protocol request.
+  (declare (type window dst src)
+	   (type int16 dst-x dst-y src-x src-y)
+	   (type (or null card16) src-width src-height))
+  (unless (or (eql src-width 0) (eql src-height 0))
+    (with-buffer-request ((window-display dst) *x-warppointer*)
+      (window src dst)
+      (int16 src-x src-y)
+      (card16 (or src-width 0) (or src-height 0))
+      (int16 dst-x dst-y))))
+
+(defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
+					&optional src-width src-height)
+  ;; Passing in a zero src-width or src-height is a no-op.
+  ;; A null src-width or src-height translates into a zero value in the protocol request.
+  (declare (type window src)
+	   (type int16 x-off y-off src-x src-y)
+	   (type (or null card16) src-width src-height))
+  (unless (or (eql src-width 0) (eql src-height 0))
+    (with-buffer-request ((window-display src) *x-warppointer*)
+      (window src)
+      (resource-id 0) ;; None
+      (int16 src-x src-y)
+      (card16 (or src-width 0) (or src-height 0))
+      (int16 x-off y-off))))
+
+(defun set-input-focus (display focus revert-to &optional time)
+  (declare (type display display)
+	   (type (or (member :none :pointer-root) window) focus)
+	   (type (member :none :parent :pointer-root) revert-to)
+	   (type timestamp time))
+  (with-buffer-request (display *x-setinputfocus*)
+    ((data (member :none :parent :pointer-root)) revert-to)
+    ((or window (member :none :pointer-root)) focus)
+    ((or null card32) time)))
+
+(defun input-focus (display)
+  (declare (type display display))
+  (declare (values focus revert-to))
+  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
+       ()
+    (values
+      (or-get 8 (member :none :pointer-root) window)
+      (member8-get 1 :none :pointer-root :parent))))
+
+(defun query-keymap (display &optional bit-vector)
+  (declare (type display display)
+	   (type (or null (bit-vector 256)) bit-vector))
+  (declare (values (bit-vector 256)))
+  (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8)
+       ()
+    (values
+      (bit-vector256-get 8 8 bit-vector))))
+
+(defun create-pixmap (&key
+		      (width (required-arg width))
+		      (height (required-arg height))
+		      (depth (required-arg depth))
+		      (drawable (required-arg drawable)))
+  (declare (type card8 depth) ;; required
+	   (type card16 width height) ;; required
+	   (type drawable drawable)) ;; required
+  (declare (values pixmap))
+  (let* ((display (drawable-display drawable))
+	 (pixmap (make-pixmap :display display))
+	 (pid (allocate-resource-id display pixmap 'pixmap)))
+    (setf (pixmap-id pixmap) pid)
+    (with-buffer-request (display *x-createpixmap*)
+      (data depth)
+      (resource-id pid)
+      (drawable drawable)
+      (card16 width height))
+    pixmap))
+
+(defun free-pixmap (pixmap)
+  (declare (type pixmap pixmap))
+  (let ((display (pixmap-display pixmap)))
+    (with-buffer-request (display *x-freepixmap*)
+      (pixmap pixmap))
+    (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
+
+(defun clear-area (window &key (x 0) (y 0) width height exposures-p)
+  ;; Passing in a zero width or height is a no-op.
+  ;; A null width or height translates into a zero value in the protocol request.
+  (declare (type window window)
+	   (type int16 x y)
+	   (type (or null card16) width height)
+	   (type boolean exposures-p))
+  (unless (or (eql width 0) (eql height 0))
+    (with-buffer-request ((window-display window) *x-cleartobackground*)
+      ((data boolean) exposures-p)
+      (window window)
+      (int16 x y)
+      (card16 (or width 0) (or height 0)))))
+
+(defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
+  (declare (type drawable src dst)
+	   (type gcontext gcontext)
+	   (type int16 src-x src-y dst-x dst-y)
+	   (type card16 width height))
+  (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext)
+    (drawable src dst)
+    (gcontext gcontext)
+    (int16 src-x src-y dst-x dst-y)
+    (card16 width height)))
+
+(defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
+  (declare (type drawable src dst)
+	   (type gcontext gcontext)
+	   (type pixel plane)
+	   (type int16 src-x src-y dst-x dst-y)
+	   (type card16 width height))
+  (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext)
+    (drawable src dst)
+    (gcontext gcontext)
+    (int16 src-x src-y dst-x dst-y)
+    (card16 width height)
+    (card32 plane)))
+
+(defun create-colormap (visual-info window &optional alloc-p)
+  (declare (type (or visual-info resource-id) visual-info)
+	   (type window window)
+	   (type boolean alloc-p))
+  (declare (values colormap))
+  (let ((display (window-display window)))
+    (when (typep visual-info 'resource-id)
+      (setf visual-info (visual-info display visual-info)))
+    (let* ((colormap (make-colormap :display display :visual-info visual-info))
+	   (id (allocate-resource-id display colormap 'colormap)))
+      (setf (colormap-id colormap) id)
+      (with-buffer-request (display *x-createcolormap*)
+	((data boolean) alloc-p)
+	(card29 id)
+	(window window)
+	(card29 (visual-info-id visual-info)))
+      colormap)))
+
+(defun free-colormap (colormap)
+  (declare (type colormap colormap))
+  (let ((display (colormap-display colormap)))
+    (with-buffer-request (display *x-freecolormap*)
+      (colormap colormap))
+    (deallocate-resource-id display (colormap-id colormap) 'colormap)))
+
+(defun copy-colormap-and-free (colormap)
+  (declare (type colormap colormap))
+  (declare (values colormap))
+  (let* ((display (colormap-display colormap))
+	 (new-colormap (make-colormap :display display
+				      :visual-info (colormap-visual-info colormap)))
+	 (id (allocate-resource-id display new-colormap 'colormap)))
+    (setf (colormap-id new-colormap) id)
+    (with-buffer-request (display *x-copycolormapandfree*)
+      (resource-id id)
+      (colormap colormap))
+    new-colormap))
+
+(defun install-colormap (colormap)
+  (declare (type colormap colormap))
+  (with-buffer-request ((colormap-display colormap) *x-installcolormap*)
+    (colormap colormap)))
+
+(defun uninstall-colormap (colormap)
+  (declare (type colormap colormap))
+  (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*)
+    (colormap colormap)))
+
+(defun installed-colormaps (window &key (result-type 'list))
+  (declare (type window window)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence colormap)))
+  (let ((display (window-display window)))
+    (flet ((get-colormap (id)
+	     (lookup-colormap display id)))
+      (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16)
+	   ((window window))
+	(values
+	  (sequence-get :result-type result-type :length (card16-get 8)
+			:transform #'get-colormap :index *replysize*))))))
+
+(defun alloc-color (colormap color)
+  (declare (type colormap colormap)
+	   (type (or stringable color) color))
+  (declare (values pixel screen-color exact-color))
+  (let ((display (colormap-display colormap)))
+    (etypecase color
+      (color
+	(with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32))
+	     ((colormap colormap)
+	      (rgb-val (color-red color)
+		       (color-green color)
+		       (color-blue color))
+	      (pad16 nil))
+	  (values
+	    (card32-get 16)
+	    (make-color :red (rgb-val-get 8)
+			:green (rgb-val-get 10)
+			:blue (rgb-val-get 12))
+	    color)))
+      (stringable
+	(let* ((string (string color))
+	       (length (length string)))
+	  (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32))
+	       ((colormap colormap)
+		(card16 length)
+		(pad16 nil)
+		(string string))
+	    (values
+	      (card32-get 8)
+	      (make-color :red (rgb-val-get 12)
+			  :green (rgb-val-get 14)
+			  :blue (rgb-val-get 16)) 
+	      (make-color :red (rgb-val-get 18)
+			  :green (rgb-val-get 20)
+			  :blue (rgb-val-get 22)))))))))
+
+(defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
+  (declare (type colormap colormap)
+	   (type card16 colors planes)
+	   (type boolean contiguous-p)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence pixel) (sequence mask)))
+  (let ((display (colormap-display colormap)))
+    (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16)
+	 (((data boolean) contiguous-p)
+	  (colormap colormap)
+	  (card16 colors planes))
+      (let ((pixel-length (card16-get 8))
+	    (mask-length (card16-get 10)))
+	(values
+	  (sequence-get :result-type result-type :length pixel-length :index *replysize*)
+	  (sequence-get :result-type result-type :length mask-length
+			:index (index+ *replysize* (index* pixel-length 4))))))))
+
+(defun alloc-color-planes (colormap colors
+			   &key (reds 0) (greens 0) (blues 0)
+			   contiguous-p (result-type 'list))
+  (declare (type colormap colormap)
+	   (type card16 colors reds greens blues)
+	   (type boolean contiguous-p)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence pixel) red-mask green-mask blue-mask))
+  (let ((display (colormap-display colormap)))
+    (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32))
+	 (((data boolean) contiguous-p)
+	  (colormap colormap)
+	  (card16 colors reds greens blues))
+      (let ((red-mask (card32-get 12))
+	    (green-mask (card32-get 16))
+	    (blue-mask (card32-get 20)))
+	(values
+	  (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*)
+	  red-mask green-mask blue-mask)))))
+
+(defun free-colors (colormap pixels &optional (plane-mask 0))
+  (declare (type colormap colormap)
+	   (type sequence pixels) ;; Sequence of integers
+	   (type pixel plane-mask))
+  (with-buffer-request ((colormap-display colormap) *x-freecolors*)
+    (colormap colormap)
+    (card32 plane-mask)
+    (sequence pixels)))
+
+(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
+  (declare (type colormap colormap)
+	   (type pixel pixel)
+	   (type (or stringable color) spec)
+	   (type boolean red-p green-p blue-p))
+  (let ((display (colormap-display colormap))
+	(flags 0))
+    (declare (type display display)
+	     (type card8 flags))
+    (when red-p (setq flags 1))
+    (when green-p (incf flags 2))
+    (when blue-p (incf flags 4))
+    (etypecase spec
+      (color
+	(with-buffer-request (display *x-storecolors*)
+	  (colormap colormap)
+	  (card32 pixel)
+	  (rgb-val (color-red spec)
+		   (color-green spec)
+		   (color-blue spec))
+	  (card8 flags)
+	  (pad8 nil)))
+      (stringable
+	(let* ((string (string spec))
+	       (length (length string)))
+	  (with-buffer-request (display *x-storenamedcolor*)
+	    ((data card8) flags)
+	    (colormap colormap)
+	    (card32 pixel)
+	    (card16 length)
+	    (pad16 nil)
+	    (string string)))))))
+
+(defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
+  ;; If stringables are specified for colors, it is unspecified whether all
+  ;; stringables are first resolved and then a single StoreColors protocol request is
+  ;; issued, or whether multiple StoreColors protocol requests are issued.
+  (declare (type colormap colormap)
+	   (type sequence specs)
+	   (type boolean red-p green-p blue-p))
+  (etypecase specs
+    (list
+     (do* ((spec specs (cddr spec))
+	   (pixel (car spec) (car spec))
+	   (color (cadr spec) (cadr spec)))
+	  ((endp spec))
+       (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p)))
+    (vector
+     (do* ((i 0 (+ i 2))
+	   (len (length specs))
+	   (pixel (aref specs i) (aref specs i))
+	   (color (aref specs (1+ i)) (aref specs (1+ i))))
+	  ((>= i len))
+       (store-color colormap pixel color :red-p red-p :green-p green-p :blue-p blue-p)))))
+
+(defun query-colors (colormap pixels &key (result-type 'list))
+  (declare (type colormap colormap)
+	   (type sequence pixels) ;; sequence of integer
+	   (type t result-type))   ;; a type specifier
+  (declare (values (sequence color)))
+  (let ((display (colormap-display colormap)))
+    (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16))
+	 ((colormap colormap)
+	  (sequence pixels))
+      (let ((sequence (make-sequence result-type (card16-get 8))))
+	(advance-buffer-offset *replysize*)
+	(dotimes (i (length sequence) sequence)
+	  (setf (elt sequence i)
+		(make-color :red (rgb-val-get 0)
+			    :green (rgb-val-get 2)
+			    :blue (rgb-val-get 4)))
+	  (advance-buffer-offset 8))))))
+
+(defun lookup-color (colormap name)
+  (declare (type colormap colormap)
+	   (type stringable name))
+  (declare (values screen-color true-color))
+  (let* ((display (colormap-display colormap))
+	 (string (string name))
+	 (length (length string)))
+    (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16)
+	 ((colormap colormap)
+	  (card16 length)
+	  (pad16 nil)
+	  (string string))
+      (values
+	(make-color :red (rgb-val-get 14)
+		    :green (rgb-val-get 16)
+		    :blue (rgb-val-get 18))
+	(make-color :red (rgb-val-get 8)
+		    :green (rgb-val-get 10)
+		    :blue (rgb-val-get 12))))))
+
+(defun create-cursor (&key
+		      (source (required-arg source))
+		      mask
+		      (x (required-arg x))
+		      (y (required-arg y))
+		      (foreground (required-arg foreground))
+		      (background (required-arg background)))
+  (declare (type pixmap source) ;; required
+	   (type (or null pixmap) mask)
+	   (type card16 x y) ;; required
+	   (type (or null color) foreground background)) ;; required
+  (declare (values cursor))
+  (let* ((display (pixmap-display source))
+	 (cursor (make-cursor :display display))
+	 (cid (allocate-resource-id display cursor 'cursor)))
+    (setf (cursor-id cursor) cid)
+    (with-buffer-request (display *x-createcursor*)
+      (resource-id cid)
+      (pixmap source)
+      ((or null pixmap) mask)
+      (rgb-val (color-red foreground)
+	       (color-green foreground)
+	       (color-blue foreground))
+      (rgb-val (color-red background)
+	       (color-green background)
+	       (color-blue background))
+      (card16 x y))
+    cursor))
+
+(defun create-glyph-cursor (&key
+			    (source-font (required-arg source-font))
+			    (source-char (required-arg source-char))
+			    mask-font
+			    mask-char
+			    (foreground (required-arg foreground))
+			    (background (required-arg background)))
+  (declare (type font source-font) ;; Required
+	   (type card16 source-char) ;; Required
+	   (type (or null font) mask-font)
+	   (type (or null card16) mask-char)
+	   (type color foreground background)) ;; required
+  (declare (values cursor))
+  (let* ((display (font-display source-font))
+	 (cursor (make-cursor :display display))
+	 (cid (allocate-resource-id display cursor 'cursor))
+	 (source-font-id (font-id source-font))
+	 (mask-font-id (if mask-font (font-id mask-font) 0)))
+    (setf (cursor-id cursor) cid)
+    (unless mask-char (setq mask-char 0))
+    (with-buffer-request (display *x-createglyphcursor*)
+      (resource-id cid source-font-id mask-font-id)
+      (card16 source-char)
+      (card16 mask-char)
+      (rgb-val (color-red foreground)
+	       (color-green foreground)
+	       (color-blue foreground))
+      (rgb-val (color-red background)
+	       (color-green background)
+	       (color-blue background)))
+    cursor))
+
+(defun free-cursor (cursor)
+  (declare (type cursor cursor))
+  (let ((display (cursor-display cursor)))
+    (with-buffer-request (display *x-freecursor*)
+      (cursor cursor))
+    (deallocate-resource-id display (cursor-id cursor) 'cursor)))
+
+(defun recolor-cursor (cursor foreground background)
+  (declare (type cursor cursor)
+	   (type color foreground background))
+  (with-buffer-request ((cursor-display cursor) *x-recolorcursor*)
+    (cursor cursor)
+    (rgb-val (color-red foreground)
+	     (color-green foreground)
+	     (color-blue foreground))
+    (rgb-val (color-red background)
+	     (color-green background)
+	     (color-blue background))
+    ))
+
+(defun query-best-cursor (width height drawable)
+  (declare (type card16 width height)
+	   (type (or drawable display) drawable))	
+  (declare (values width height))
+  ;; Drawable can be a display for compatibility.
+  (multiple-value-bind (display drawable)
+      (if (type? drawable 'drawable)
+	  (values (drawable-display drawable) drawable)
+	(values drawable (screen-root (display-default-screen drawable))))
+    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
+	 ((data 0)
+	  (window drawable)
+	  (card16 width height))
+      (values
+	(card16-get 8)
+	(card16-get 10)))))
+
+(defun query-best-tile (width height drawable)
+  (declare (type card16 width height)
+	   (type drawable drawable))
+  (declare (values width height))
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
+	 ((data 1)
+	  (drawable drawable)
+	  (card16 width height))
+      (values
+	(card16-get 8)
+	(card16-get 10)))))
+
+(defun query-best-stipple (width height drawable)
+  (declare (type card16 width height)
+	   (type drawable drawable))
+  (declare (values width height))
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
+	 ((data 2)
+	  (drawable drawable)
+	  (card16 width height))
+      (values
+	(card16-get 8)
+	(card16-get 10)))))
+
+(defun query-extension (display name)
+  (declare (type display display)
+	   (type stringable name))
+  (declare (values major-opcode first-event first-error))
+  (let ((string (string name)))
+    (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8)
+	 ((card16 (length string))
+	  (pad16 nil)
+	  (string string))
+      (and (boolean-get 8)    ;; If present
+	   (values
+	     (card8-get 9)
+	     (card8-get 10)
+	     (card8-get 11))))))
+
+(defun list-extensions (display &key (result-type 'list))
+  (declare (type display display)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence string)))
+  (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8)
+       ()
+    (values
+      (read-sequence-string
+	buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*))))
+
+(defun change-keyboard-control (display &key key-click-percent
+				bell-percent bell-pitch bell-duration
+				led led-mode key auto-repeat-mode)
+  (declare (type display display)
+	   (type (or null (member :default) int16) key-click-percent
+						   bell-percent bell-pitch bell-duration)
+	   (type (or null card8) led key)
+	   (type (or null (member :on :off)) led-mode)
+	   (type (or null (member :on :off :default)) auto-repeat-mode))
+  (when (eq key-click-percent :default) (setq key-click-percent -1))
+  (when (eq bell-percent :default) (setq bell-percent -1))
+  (when (eq bell-pitch :default) (setq bell-pitch -1))
+  (when (eq bell-duration :default) (setq bell-duration -1))
+  (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32))
+    (mask
+      (integer key-click-percent bell-percent bell-pitch bell-duration)
+      (card32 led)
+      ((member :off :on) led-mode)
+      (card32 key)
+      ((member :off :on :default) auto-repeat-mode))))
+
+(defun keyboard-control (display)
+  (declare (type display display))
+  (declare (values key-click-percent bell-percent bell-pitch bell-duration
+		  led-mask global-auto-repeat auto-repeats))
+  (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32))
+       ()
+    (values
+      (card8-get 12)
+      (card8-get 13)
+      (card16-get 14)
+      (card16-get 16)
+      (card32-get 8)
+      (member8-get 1 :off :on)
+      (bit-vector256-get 32))))
+
+;;  The base volume should
+;; be considered to be the "desired" volume in the normal case; that is, a
+;; typical application should call XBell with 0 as the percent.  Rather
+;; than using a simple sum, the percent argument is instead used as the
+;; percentage of the remaining range to alter the base volume by.  That is,
+;; the actual volume is:
+;;	 if percent>=0:    base - [(base * percent) / 100] + percent
+;;	 if percent<0:     base + [(base * percent) / 100]
+
+(defun bell (display &optional (percent-from-normal 0))
+  ;; It is assumed that an eventual audio extension to X will provide more complete control.
+  (declare (type display display)
+	   (type int8 percent-from-normal))
+  (with-buffer-request (display *x-bell*)
+    (data (int8->card8 percent-from-normal))))
+
+(defun pointer-mapping (display &key (result-type 'list))
+  (declare (type display display)
+	   (type t result-type)) ;; CL type
+  (declare (values sequence)) ;; Sequence of card
+  (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8)
+       ()
+    (values
+      (sequence-get :length (card8-get 1) :result-type result-type :format card8
+		    :index *replysize*))))
+
+(defun set-pointer-mapping (display map)
+  ;; Can signal device-busy.
+  (declare (type display display)
+	   (type sequence map)) ;; Sequence of card8
+  (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8)
+	     ((data (length map))
+	      ((sequence :format card8) map))
+	  (values
+	    (boolean-get 1)))
+    (x-error 'device-busy :display display))
+  map)
+
+(defsetf pointer-mapping set-pointer-mapping)
+
+(defun change-pointer-control (display &key acceleration threshold)
+  ;; Acceleration is rationalized if necessary.
+  (declare (type display display)
+	   (type (or null (member :default) number) acceleration)
+	   (type (or null (member :default) integer) threshold)
+	   (inline rationalize16))
+  (flet ((rationalize16 (number)
+	   ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers
+	   (declare (type number number)
+		    (inline rationalize16))
+	   (declare (values numerator denominator))
+	   (do* ((rational (rationalize number))
+		 (numerator (numerator rational) (ash numerator -1))
+		 (denominator (denominator rational) (ash denominator -1)))
+		((or (= numerator 1)
+		     (and (< (abs numerator) #x8000)
+			  (< denominator #x8000)))
+		 (values
+		   numerator (min denominator #x7fff))))))
+
+    (let ((acceleration-p 1)
+	  (threshold-p 1)
+	  (numerator 0)
+	  (denominator 1))
+      (declare (type card8 acceleration-p threshold-p)
+	       (type int16 numerator denominator))
+      (cond ((eq acceleration :default) (setq numerator -1))
+	    (acceleration (multiple-value-setq (numerator denominator)
+			    (rationalize16 acceleration)))
+	    (t (setq acceleration-p 0)))
+      (cond ((eq threshold :default) (setq threshold -1))
+	    ((null threshold) (setq threshold -1
+				    threshold-p 0)))
+      (with-buffer-request (display *x-changepointercontrol*)
+	(int16 numerator denominator threshold)
+	(card8 acceleration-p threshold-p)))))
+
+(defun pointer-control (display)
+  (declare (type display display))
+  (declare (values acceleration threshold))
+  (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16)
+       ()
+    (values
+      (/ (card16-get 8) (card16-get 10)		; Should we float this?
+	 (card16-get 12)))))
+
+(defun set-screen-saver (display timeout interval blanking exposures)
+  ;; Timeout and interval are in seconds, will be rounded to minutes.
+  (declare (type display display)
+	   (type (or (member :default) int16) timeout interval)
+	   (type (member :on :off :default :yes :no) blanking exposures))
+  (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off)))
+  (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))
+  (when (eq timeout :default) (setq timeout -1))
+  (when (eq interval :default) (setq interval -1))
+  (with-buffer-request (display *x-setscreensaver*)
+    (int16 timeout interval)
+    ((member8 :on :off :default) blanking exposures)))
+
+(defun screen-saver (display)
+  ;; Returns timeout and interval in seconds.
+  (declare (type display display))
+  (declare (values timeout interval blanking exposures))
+  (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16))
+       ()
+    (values
+      (card16-get 8)
+      (card16-get 10)
+      (member8-get 12 :on :off :default)
+      (member8-get 13 :on :off :default))))
+
+(defun activate-screen-saver (display)
+  (declare (type display display))
+  (with-buffer-request (display *x-forcescreensaver*)
+    (data 1)))
+
+(defun reset-screen-saver (display)
+  (declare (type display display))
+  (with-buffer-request (display *x-forcescreensaver*)
+    (data 0)))
+
+(defun add-access-host (display host &optional (family :internet))
+  ;; A string must be acceptable as a host, but otherwise the possible types for
+  ;; host are not constrained, and will likely be very system dependent.
+  ;; This implementation uses a list whose car is the family keyword
+  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
+  (declare (type display display)
+	   (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (change-access-host display host family nil))
+
+(defun remove-access-host (display host &optional (family :internet))
+  ;; A string must be acceptable as a host, but otherwise the possible types for
+  ;; host are not constrained, and will likely be very system dependent.
+  ;; This implementation uses a list whose car is the family keyword
+  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
+  (declare (type display display)
+	   (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (change-access-host display host family t))
+
+(defun change-access-host (display host family remove-p)
+  (declare (type display display)
+	   (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (unless (consp host)
+    (setq host (host-address host family)))
+  (let ((family (car host))
+	(address (cdr host)))
+    (with-buffer-request (display *x-changehosts*)
+      ((data boolean) remove-p)
+      (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
+      (card16 (length address))
+      ((sequence :format card8) address))))
+
+(defun access-hosts (display &optional (result-type 'list))
+  ;; The type of host objects returned is not constrained, except that the hosts must
+  ;; be acceptable to add-access-host and remove-access-host.
+  ;; This implementation uses a list whose car is the family keyword
+  ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
+  (declare (type display display)
+	   (type t result-type)) ;; CL type
+  (declare (values (sequence host) enabled-p))
+  (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16))
+       ()
+    (let* ((enabled-p (boolean-get 1))
+	   (nhosts (card16-get 8))
+	   (sequence (make-sequence result-type nhosts)))
+      (advance-buffer-offset *replysize*)
+      (dotimes (i nhosts)
+	(let ((family (card8-get 0))
+	      (len (card16-get 2)))
+	  (setf (elt sequence i)
+		(cons (if (< family 3)
+			  (svref '#(:internet :decnet :chaos) family)
+			family)
+		      (sequence-get :length len :format card8 :result-type 'list
+				    :index (+ buffer-boffset 4))))
+	  (advance-buffer-offset (+ 4 (* 4 (ceiling len 4))))))
+      (values
+	sequence
+	enabled-p))))
+
+(defun access-control (display)
+  (declare (type display display))
+  (declare (values boolean)) ;; True when access-control is ENABLED
+  (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8)
+       ()
+    (boolean-get 1)))
+  
+(defun set-access-control (display enabled-p)
+  (declare (type display display)
+	   (type boolean enabled-p))
+  (with-buffer-request (display *x-changeaccesscontrol*)
+    ((data boolean) enabled-p))
+  enabled-p)
+
+(defsetf access-control set-access-control)
+
+(defun close-down-mode (display)
+  ;; setf'able
+  ;; Cached locally in display object.
+  (declare (type display display))
+  (declare (values (member :destroy :retain-permanent :retain-temporary nil)))
+  (display-close-down-mode display))
+
+(defun set-close-down-mode (display mode)
+  ;; Cached locally in display object.
+  (declare (type display display)
+	   (type (member :destroy :retain-permanent :retain-temporary) mode))
+  (setf (display-close-down-mode display) mode)
+  (with-buffer-request (display *x-changeclosedownmode* :sizes (32))
+    ((data (member :destroy :retain-permanent :retain-temporary)) mode))
+  mode)
+
+(defsetf close-down-mode set-close-down-mode)
+
+(defun kill-client (display resource-id)
+  (declare (type display display)
+	   (type resource-id resource-id))
+  (with-buffer-request (display *x-killclient*)
+    (resource-id resource-id)))
+
+(defun kill-temporary-clients (display)
+  (declare (type display display))
+  (with-buffer-request (display *x-killclient*)
+    (resource-id 0)))
+
+(defun no-operation (display)
+  (declare (type display display))
+  (with-buffer-request (display *x-nooperation*)))
diff --git a/clx/resource.lisp b/clx/resource.lisp
new file mode 100644
index 000000000..743c14f46
--- /dev/null
+++ b/clx/resource.lisp
@@ -0,0 +1,713 @@
+;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;; RESOURCE - Lisp version of XLIB's Xrm resource manager
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(resource-database
+	   resource-database-timestamp
+	   make-resource-database
+	   resource-key
+	   get-resource
+	   get-search-table
+	   get-search-resource
+	   add-resource
+	   delete-resource 
+	   map-resource 
+	   merge-resources
+	   read-resources
+	   write-resources
+	   wm-resources
+	   set-wm-resources
+	   root-resources))
+
+#+clue ;; for CLUE only
+(defparameter *resource-subclassp* nil
+  "When non-nil and no match found, search superclasses.")
+
+;; The C version of this uses a 64 entry hash table at each entry.
+;; Small hash tables lose in Lisp, so we do linear searches on lists.
+
+(defstruct (resource-database (:copier nil) (:predicate nil)
+			      (:print-function print-resource-database)
+			      (:constructor make-resource-database-internal)
+			      #+explorer (:callable-constructors nil)
+			      )
+  (name nil :type stringable :read-only t)
+  (value nil)
+  (tight nil :type list) ;; List of resource-database
+  (loose nil :type list) ;; List of resource-database
+  )
+
+(defun print-resource-database (database stream depth)
+  (declare (type resource-database database)
+	   (ignore depth))
+  (print-unreadable-object (database stream :type t)
+    (princ (resource-database-name database) stream)
+    (when (resource-database-value database)
+      (princ " " stream)
+      (prin1 (resource-database-value database) stream))))
+
+;; The value slot of the top-level resource-database structure is used for a
+;; time-stamp.
+
+(defun make-resource-database ()
+  ;; Make a resource-database with initial timestamp of 0
+  (make-resource-database-internal :name "Top-Level" :value 0))
+
+(defun resource-database-timestamp (database)
+  (declare (type resource-database database))
+  (resource-database-value database))
+
+(defun incf-resource-database-timestamp (database)
+  ;; Increment the timestamp
+  (declare (type resource-database database))
+  (let ((timestamp (resource-database-value database)))
+    (setf (resource-database-value database)
+	  (if (= timestamp most-positive-fixnum)
+	      most-negative-fixnum
+	    (1+ timestamp)))))
+
+;; DEBUG FUNCTION  (not exported)
+(defun print-db (entry &optional (level 0) type)
+  ;; Debug function to print a resource database
+  (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
+	  level
+	  (resource-database-name entry)
+	  (eq type 'loose)
+	  (resource-database-value entry))
+  (when (resource-database-tight entry)
+    (dolist (tight (resource-database-tight entry))
+      (print-db tight (+ 2 level) 'tight)))
+  (when (resource-database-loose entry)
+    (dolist (loose (resource-database-loose entry))
+      (print-db loose (+ 2 level) 'loose))))
+
+;; DEBUG FUNCTION
+#+comment
+(defun print-search-table (table)
+  (terpri)
+  (dolist (dbase-list table)
+    (format t "~%~s" dbase-list)
+    (dolist (db dbase-list)
+      (print-db db)
+      (dolist (dblist table)
+	(unless (eq dblist dbase-list)
+	  (when (member db dblist)
+	    (format t "  duplicate at ~s" db))))
+      )))
+
+(defun resource-key (stringable)
+  ;; Ensure STRINGABLE is a keyword.
+  (declare (type stringable stringable))
+  (if (symbolp stringable)
+      (if (keywordp (the symbol stringable))
+	  stringable
+	(kintern (symbol-name (the symbol stringable))))
+    (kintern (#-excl string-upcase
+	      #+excl correct-case
+	      (the string stringable)))))
+
+(defun stringable-equal (a b)
+  ;; Compare two stringables.
+  ;; Ignore case when comparing to a symbol.
+  (declare (type stringable a b))
+  (declare (values boolean))
+  (if (symbolp a)
+      (if (symbolp b)
+	  (string= (the string (symbol-name (the symbol a)))
+		   (the string (symbol-name (the symbol b))))
+	(string-equal (the string (symbol-name (the symbol a)))
+		      (the string b)))
+    (if (symbolp b)
+	(string-equal (the string a)
+		      (the string (symbol-name (the symbol b))))
+      (string= (the string a)
+	       (the string b)))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Add/delete resource
+
+(defun add-resource (database name-list value)
+  ;; name-list is a list of either strings or symbols. If a symbol, 
+  ;; case-insensitive comparisons will be used, if a string,
+  ;; case-sensitive comparisons will be used.  The symbol '* or
+  ;; string "*" are used as wildcards, matching anything or nothing.
+  (declare (type resource-database database)
+	   (type list name-list) ;; (list stringable)
+	   (type t value))
+  (unless value (error "Null resource values are ignored"))
+  (incf-resource-database-timestamp database)
+  (do* ((list name-list (cdr list))
+	(name (car list) (car list))
+	(node database)
+	(loose-p nil))
+       ((endp list)
+	(setf (resource-database-value node) value))
+    ;; Key is the first name that isn't *
+    (if (stringable-equal name "*")
+	(setq loose-p t)
+      ;; find the entry associated with name
+      (progn
+	(do ((entry (if loose-p
+			(resource-database-loose node)
+		      (resource-database-tight node))
+		    (cdr entry)))
+	    ((endp entry)
+	     ;; Entry not found - create a new one
+	     (setq entry (make-resource-database-internal :name name))
+	     (if loose-p
+		 (push entry (resource-database-loose node))
+	       (push entry (resource-database-tight node)))
+	     (setq node entry))
+	  (when (stringable-equal name (resource-database-name (car entry)))
+	    ;; Found entry - use it
+	    (return (setq node (car entry)))))
+	(setq loose-p nil)))))
+
+
+(defun delete-resource (database name-list)
+  (declare (type resource-database database)
+	   (type list name-list))
+  (incf-resource-database-timestamp database)
+  (delete-resource-internal database name-list))
+
+(defun delete-resource-internal (database name-list)
+  (declare (type resource-database database)
+	   (type list name-list)) ;; (list stringable)
+  (do* ((list name-list (cdr list))
+	(string (car list) (car list))
+	(node database)
+	(loose-p nil))
+       ((endp list) nil)
+    ;; Key is the first name that isn't *
+    (if (stringable-equal string "*")
+	(setq loose-p t)
+      ;; find the entry associated with name
+      (progn 
+	(do* ((first-entry (if loose-p
+			       (resource-database-loose node)
+			     (resource-database-tight node)))
+	      (entry-list first-entry (cdr entry-list))
+	      (entry (car entry-list) (car entry-list)))
+	     ((endp entry-list)
+	      ;; Entry not found - exit
+	      (return-from delete-resource-internal nil))
+	  (when (stringable-equal string (resource-database-name entry))
+	    (when (cdr list) (delete-resource-internal entry (cdr list)))
+	    (when (and (null (resource-database-loose entry))
+		       (null (resource-database-tight entry)))
+	      (if loose-p
+		  (setf (resource-database-loose node)
+			(delete entry (resource-database-loose node)
+				:test #'eq :count 1))
+		(setf (resource-database-tight node)
+		      (delete entry (resource-database-tight node)
+			      :test #'eq :count 1))))
+	    (return-from delete-resource-internal t)))
+	(setq loose-p nil)))))
+
+;;;-----------------------------------------------------------------------------
+;;; Get Resource
+
+(defun get-resource (database value-name value-class full-name full-class)
+  ;; Return the value of the resource in DATABASE whose partial name
+  ;; most closely matches (append full-name (list value-name)) and
+  ;;                      (append full-class (list value-class)).
+  (declare (type resource-database database)
+	   (type stringable value-name value-class)
+	   (type list full-name full-class)) ;; (list stringable)
+  (declare (values value))
+  (let ((names (append full-name (list value-name)))
+	(classes (append full-class (list value-class))))
+    (let* ((result (get-entry (resource-database-tight database)
+			      (resource-database-loose database)
+			      names classes)))
+      (when result
+	(resource-database-value result)))))
+
+(defun get-entry-lookup (table name names classes)
+  (declare (type list table names classes)
+	   (symbol name))
+  (dolist (entry table)
+    (declare (type resource-database entry))
+    (when (stringable-equal name (resource-database-name entry))
+      (if (null (cdr names))
+	  (return entry)
+	(let ((result (get-entry (resource-database-tight entry)
+				 (resource-database-loose entry)
+				 (cdr names) (cdr classes))))
+	  (declare (type (or null resource-database) result))
+	  (when result
+	    (return result)
+	    ))))))
+
+(defun get-entry (tight loose names classes &aux result)
+  (declare (type list tight loose names classes))
+  (let ((name (car names))
+	(class (car classes)))
+    (declare (type symbol name class))
+    (cond ((and tight
+		(get-entry-lookup tight name names classes)))
+	  ((and loose
+		(get-entry-lookup loose name names classes)))
+	  ((and tight
+		(not (stringable-equal name class))
+		(get-entry-lookup tight class names classes)))
+	  ((and loose
+		(not (stringable-equal name class))
+		(get-entry-lookup loose class names classes)))
+	  #+clue ;; for CLUE only
+	  ((and *resource-subclassp*
+		(or loose tight)
+		(dolist (class (cluei::class-all-superclasses class))
+		  (when tight
+		    (when (setq result
+				(get-entry-lookup tight class names classes))
+		      (return result)))
+		  (when loose
+		    (when (setq result
+				(get-entry-lookup loose class names classes))
+		      (return result))))))	
+	  (loose
+	   (loop
+	     (pop names) (pop classes)
+	     (unless (and names classes) (return nil))
+	     (setq name (car names)
+		   class (car classes))
+	     (when (setq result (get-entry-lookup loose name names classes))
+	       (return result))
+	     (when (and (not (stringable-equal name class))
+			(setq result
+			      (get-entry-lookup loose class names classes)))
+	       (return result))
+	     #+clue ;; for CLUE only
+	     (when *resource-subclassp*
+	       (dolist (class (cluei::class-all-superclasses class))
+		 (when (setq result
+			     (get-entry-lookup loose class names classes))
+		   (return-from get-entry result))))
+	     )))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Get-resource with search-table
+
+(defun get-search-resource (table name class)
+  ;; (get-search-resource (get-search-table database full-name full-class) 
+  ;;                      value-name value-class)
+  ;; is equivalent to 
+  ;; (get-resource database value-name value-class full-name full-class)
+  ;; But since most of the work is done by get-search-table,
+  ;; get-search-resource is MUCH faster when getting several resources with
+  ;; the same full-name/full-class
+  (declare (type list table)
+	   (type stringable name class))
+  (let ((do-class (and class (not (stringable-equal name class)))))
+    (dolist (dbase-list table)
+      (declare (type list dbase-list))
+      (dolist (dbase dbase-list)
+	(declare (type resource-database dbase))
+	(when (stringable-equal name (resource-database-name dbase))
+	  (return-from get-search-resource
+	    (resource-database-value dbase))))
+      (when do-class
+	(dolist (dbase dbase-list)
+	  (declare (type resource-database dbase))
+	  (when (stringable-equal class (resource-database-name dbase))
+	    (return-from get-search-resource
+	      (resource-database-value dbase))))))))
+
+(defvar *get-table-result*)
+
+(defun get-search-table (database full-name full-class)
+  ;; Return a search table for use with get-search-resource.
+  (declare (type resource-database database)
+	   (type list full-name full-class)) ;; (list stringable)
+  (declare (values value))
+  (let* ((tight (resource-database-tight database))
+	 (loose (resource-database-loose database))
+	 (result (cons nil nil))
+	 (*get-table-result* result))
+    (declare (type list tight loose)
+	     (type cons result))
+    (when (or tight loose)
+      (when full-name
+	(get-tables tight loose full-name full-class))
+
+      ;; Pick up bindings of the form (* name). These are the elements of
+      ;; top-level loose without further tight/loose databases.
+      ;;
+      ;; (Hack: these bindings belong in ANY search table, so recomputing them
+      ;; is a drag.  True fix involves redesigning entire lookup
+      ;; data-structure/algorithm.)
+      ;;
+      (let ((universal-bindings
+	      (remove nil loose :test-not #'eq
+		      :key #'(lambda (database)
+			       (or (resource-database-tight database)
+				   (resource-database-loose database))))))
+	(when universal-bindings
+	  (setf (cdr *get-table-result*) (list universal-bindings)))))
+    (cdr result)))
+
+(defun get-tables-lookup (dbase name names classes)
+  (declare (type list dbase names classes)
+	   (type symbol name))
+  (declare (optimize speed))
+  (dolist (entry dbase)
+    (declare (type resource-database entry))
+    (when (stringable-equal name (resource-database-name entry))
+      (let ((tight (resource-database-tight entry))
+	    (loose (resource-database-loose entry)))
+	(declare (type list tight loose))
+	(when (or tight loose)
+	  (if (cdr names)
+	      (get-tables tight loose (cdr names) (cdr classes))
+	    (when tight
+	      (let ((result *get-table-result*))
+		;; Put tight at end of *get-table-result*
+		(setf (cdr result)
+		      (setq *get-table-result* (cons tight nil))))))
+	  (when loose
+	    (let ((result *get-table-result*))
+	      ;; Put loose at end of *get-table-result*
+	      (setf (cdr result)
+		    (setq *get-table-result* (cons loose nil))))))))))
+
+(defun get-tables (tight loose names classes)
+  (declare (type list tight loose names classes))
+  (let ((name (car names))
+	(class (car classes)))
+    (declare (type symbol name class))
+    (when tight
+      (get-tables-lookup tight name names classes))
+    (when loose
+      (get-tables-lookup loose name names classes))
+    (when (and tight (not (stringable-equal name class)))
+      (get-tables-lookup tight class names classes))
+    (when (and loose (not (stringable-equal name class)))
+      (get-tables-lookup loose class names classes))
+    #+clue ;; for CLUE only
+    (when *resource-subclassp*
+      (dolist (class (cluei::class-all-superclasses class))
+	(declare (type symbol class))
+	(setq class class)
+	(when tight
+	  (get-tables-lookup tight class names classes))
+	(when loose
+	  (get-tables-lookup loose class names classes))))
+    (when loose
+      (loop
+	(pop names) (pop classes)
+	(unless (and names classes) (return nil))
+	(setq name (car names)
+	      class (car classes))
+	(get-tables-lookup loose name names classes)
+	(unless (stringable-equal name class)
+	  (get-tables-lookup loose class names classes))
+	#+clue ;; for CLUE only
+	(when *resource-subclassp*
+	  (dolist (class (cluei::class-all-superclasses class))
+	    (get-tables-lookup loose class names classes)))
+	))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Utility functions
+
+(defun map-resource (database function &rest args)
+  ;; Call FUNCTION on each resource in DATABASE.
+  ;; FUNCTION is called with arguments (name-list value . args)
+  (declare (type resource-database database)
+	   (type (function (list t &rest t) t) function)
+	   (downward-funarg function)
+	   (dynamic-extent args))
+  (declare (values nil))
+  (labels ((map-resource-internal (database function args name)
+	     (declare (type resource-database database)
+		      (type (function (list t &rest t) t) function)
+		      (type list name)
+		      (downward-funarg function))		      
+	     (let ((tight (resource-database-tight database))
+		   (loose (resource-database-loose database)))
+	       (declare (type list tight loose))
+	       (dolist (resource tight)
+		 (declare (type resource-database resource))
+		 (let ((value (resource-database-value resource))
+		       (name (append
+			       name
+			       (list (resource-database-name resource)))))
+		   (if value
+		       (apply function name value args)
+		     (map-resource-internal resource function args name))))
+	       (dolist (resource loose)
+		 (declare (type resource-database resource))
+		 (let ((value (resource-database-value resource))
+		       (name (append
+			       name
+			       (list "*" (resource-database-name resource)))))
+		   (if value
+		       (apply function name value args)
+		     (map-resource-internal resource function args name)))))))
+    (map-resource-internal database function args nil)))
+
+(defun merge-resources (database with-database)
+  (declare (type resource-database database with-database))
+  (declare (values resource-database))
+  (map-resource #'add-resource database with-database)
+  with-database)
+
+(defun char-memq (key char)
+  ;; Used as a test function for POSITION
+  (declare (type string-char char))
+  (member char key))
+
+(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
+  ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
+  ;; stream
+  (let ((abortp (gensym))
+	(streamp (gensym)))
+    `(let* ((,abortp t)
+	    (,streamp (streamp pathname))
+	    (,stream (if ,streamp pathname (open ,pathname ,@options))))
+       (unwind-protect
+	   (progn
+	     ,@body
+	     (setq ,abortp nil))
+	 (unless ,streamp
+	   (close stream :abort ,abortp))))))
+
+(defun read-resources (database pathname &key key test test-not)
+  ;; Merges resources from a file in standard X11 format with DATABASE.
+  ;; KEY is a function used for converting value-strings, the default is
+  ;; identity.  TEST and TEST-NOT are predicates used for filtering
+  ;; which resources to include in the database.  They are called with
+  ;; the name and results of the KEY function.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (declare (values resource-database))
+  (resource-with-open-file (stream pathname)
+    (loop
+      (let ((string (read-line stream nil :eof)))
+	(declare (type string string))
+	(when (eq string :eof) (return database))
+	(let* ((end (length string))
+	       (i (position '(#\tab #\space) string
+			    :test-not #'char-memq :end end))
+	       (term nil))
+	  (declare (type array-index end)
+		   (type (or null array-index) i term))
+	  (when i ;; else blank line
+	    (case (char string i)
+	      (#\! nil)  ;; Comment - skip
+	      (#.(card8->char 0) nil) ;; terminator for C strings - skip
+	      (#\#       ;; Include
+	       (setq term (position '(#\tab #\space) string :test #'char-memq
+				    :start i :end end))
+	       (if (not (string-equal string "#INCLUDE" :start1 i :end1 term))
+		   (format t "~%Resource File error. Ignoring: ~a" string)
+		 (let ((path (merge-pathnames
+			       (subseq string (1+ term)) (truename stream))))
+		   (read-resources database path
+				   :key key :test test :test-not test-not))))
+	      (otherwise
+	       (multiple-value-bind (name-list value)
+		   (parse-resource string i end)
+		 (when key (setq value (funcall key value)))
+		 (when
+		   (cond (test (funcall test name-list value))
+			 (test-not (not (funcall test-not name-list value)))
+			 (t t))
+		   (add-resource database name-list value)))))))))))
+
+(defun parse-resource (string &optional (start 0) end)
+  ;; Parse a resource specfication string into a list of names and a value
+  ;; string
+  (declare (type string string)
+	   (type array-index start)
+	   (type (or null array-index) end))
+  (declare (values name-list value))
+  (do ((i start)
+       (end (or end (length string)))
+       (term)
+       (name-list))
+      ((>= i end))
+    (declare (type array-index end)
+	     (type (or null array-index) i term))
+    (setq term (position '(#\. #\* #\:) string
+			 :test #'char-memq :start i :end end))
+    (case (and term (char string term))
+      ;; Name seperator
+      (#\. (when (> term i)
+	     (push (subseq string i term) name-list)))
+      ;; Wildcard seperator
+      (#\* (when (> term i)
+	     (push (subseq string i term) name-list))
+	   (push '* name-list))
+      ;; Value separator
+      (#\:
+       (push (subseq string i term) name-list)
+       (return
+	 (values
+	   (nreverse name-list)
+	   (string-trim '(#\tab #\space) (subseq string (1+ term)))))))
+    (setq i (1+ term))))
+
+(defun write-resources (database pathname &key write test test-not)
+  ;; Write resources to PATHNAME in the standard X11 format.
+  ;; WRITE is a function used for writing values, the default is #'princ
+  ;; TEST and TEST-NOT are predicates used for filtering which resources
+  ;; to include in the database.  They are called with the name and value.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string stream) t)) write)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (resource-with-open-file (stream pathname :direction :output)
+    (map-resource
+      database
+      #'(lambda (name-list value stream write test test-not)
+	  (when
+	    (cond (test (funcall test name-list value))
+		  (test-not (not (funcall test-not name-list value)))
+		  (t t))
+	    (let ((previous (car name-list)))
+	      (princ previous stream)
+	      (dolist (name (cdr name-list))
+		(unless (or (stringable-equal name "*")
+			    (stringable-equal previous "*"))
+		  (write-char #\. stream))
+		(setq previous name)
+		(princ name stream)))
+	    (write-string ":	" stream)
+	    (funcall write value stream)
+	    (terpri stream)))
+      stream (or write #'princ) test test-not))
+  database)
+
+(defun wm-resources (database window &key key test test-not)
+  ;; Takes the resources associated with the RESOURCE_MANAGER property
+  ;; of WINDOW (if any) and merges them with DATABASE.
+  ;; KEY is a function used for converting value-strings, the default is
+  ;; identity.  TEST and TEST-NOT are predicates used for filtering
+  ;; which resources to include in the database.  They are called with
+  ;; the name and results of the KEY function.
+  (declare (type resource-database database)
+	   (type window window)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (declare (values resource-database))
+  (let ((string (get-property window :RESOURCE_MANAGER :type :STRING
+			      :result-type 'string
+			      :transform #'xlib::card8->char)))
+    (when string
+      (with-input-from-string (stream string)
+	(read-resources database stream
+			:key key :test test :test-not test-not)))))
+
+(defun set-wm-resources (database window &key write test test-not)
+  ;; Sets the resources associated with the RESOURCE_MANAGER property
+  ;; of WINDOW.
+  ;; WRITE is a function used for writing values, the default is #'princ
+  ;; TEST and TEST-NOT are predicates used for filtering which resources
+  ;; to include in the database.  They are called with the name and value.
+  (declare (type resource-database database)
+	   (type window window)
+	   (type (or null (function (string stream) t)) write)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (xlib::set-string-property
+    window :RESOURCE_MANAGER
+    (with-output-to-string (stream)
+      (write-resources database stream :write write
+		       :test test :test-not test-not))))
+
+(defun root-resources (screen &key database key test test-not)
+  "Returns a resource database containing the contents of the root window
+   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
+   then its default screen is used. If an existing DATABASE is given, then
+   resource values are merged with the DATABASE and the modified DATABASE is
+   returned.
+
+   TEST and TEST-NOT are predicates for selecting which resources are
+   read.  Arguments are a resource name list and a resource value. The KEY
+   function, if given, is called to convert a resource value string to the
+   value given to TEST or TEST-NOT."
+
+  (declare (type (or screen display) screen)
+	   (type (or null resource-database) database)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean)) test test-not)
+	   (values resource-database))
+  (let* ((screen (if (type? screen 'display)
+		     (display-default-screen screen)
+		   screen))
+	 (window (screen-root screen))
+	 (database (or database (make-resource-database))))
+    (wm-resources database window :key key :test test :test-not test-not)
+    database))
+
+(defun set-root-resources (screen &key test test-not (write 'princ) database)
+  "Changes the contents of the root window RESOURCE_MANAGER property for the
+   given SCREEN. If SCREEN is a display, then its default screen is used. 
+
+   TEST and TEST-NOT are predicates for selecting which resources from the
+   DATABASE are written.  Arguments are a resource name list and a resource
+   value.  The WRITE function is used to convert a resource value into a
+   string stored in the property."
+
+  (declare (type (or screen display) screen)
+	(type (or null resource-database) database)
+	(type (or null (function (list t) boolean)) test test-not)
+	(type (or null (function (string stream) t)) write)
+	(values resource-database))
+  (let* ((screen (if (type? screen 'display)
+		     (display-default-screen screen)
+		   screen))
+	 (window (screen-root screen)))
+    (set-wm-resources database window
+		      :write write :test test :test-not test-not)
+    database))
+
+(defsetf root-resources set-root-resources)
+
+(defun initialize-resource-database (display)
+  ;; This function is (supposed to be) equivalent to the Xlib initialization
+  ;; code.
+  (declare (type display display))
+  (let ((rdb (make-resource-database))
+	(rootwin (screen-root (car (display-roots display)))))
+    ;; First read the server defaults if present, otherwise from the default
+    ;; resource file
+    (if (get-property rootwin :RESOURCE_MANAGER)
+	(xlib:wm-resources rdb rootwin)
+      (let ((path (default-resources-pathname)))
+	(when (and path (probe-file path))
+	  (read-resources rdb path))))
+    ;; Next read from the resources file 
+    (let ((path (resources-pathname)))
+      (when (and path (probe-file path))
+	(read-resources rdb path)))
+    (setf (display-xdefaults display) rdb)))
diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp
new file mode 100644
index 000000000..26c0eda34
--- /dev/null
+++ b/clx/sockcl.lisp
@@ -0,0 +1,163 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;;; Server Connection for kcl and ibcl
+
+;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology 
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.
+;;;
+;;; Massachussetts Institute of Technology provides this software "as is"
+;;; without express or implied warranty.
+;;;
+
+;;; Adapted from code by Roman Budzianowski - Project Athena/MIT
+
+;;; make-two-way-stream is probably not a reasonable thing to do.
+;;; A close on a two way stream probably does not close the substreams.
+;;; I presume an :io will not work (maybe because it uses 1 buffer?).
+;;; There should be some fast io (writes and reads...).
+
+;;; Compile this file with compile-file.
+;;; Load it with (si:faslink "sockcl.o" "socket.o -lc")
+
+(in-package :xlib)
+
+;;; The cmpinclude.h file does not have this type definition from
+;;; <kcldistribution>/h/object.h.  We include it here so the
+;;; compile-file will work without figuring out where the distribution
+;;; directory is located.
+;;;
+(CLINES "
+enum smmode {			/*  stream mode  */
+	smm_input,		/*  input  */
+	smm_output,		/*  output  */
+	smm_io,			/*  input-output  */
+	smm_probe,		/*  probe  */
+	smm_synonym,		/*  synonym  */
+	smm_broadcast,		/*  broadcast  */
+	smm_concatenated,	/*  concatenated  */
+	smm_two_way,		/*  two way  */
+	smm_echo,		/*  echo  */
+	smm_string_input,	/*  string input  */
+	smm_string_output,	/*  string output  */
+	smm_user_defined        /*  for user defined */ 
+};
+")
+
+#-akcl
+(CLINES "
+struct stream {
+	short	t, m;
+	FILE	*sm_fp;		/*  file pointer  */
+	object	sm_object0;	/*  some object  */
+	object	sm_object1;	/*  some object */
+	int	sm_int0;	/*  some int  */
+	int	sm_int1;	/*  some int  */
+	short	sm_mode;	/*  stream mode  */
+				/*  of enum smmode  */
+};
+")
+
+
+;;;; Connect to the server.
+
+;;; A lisp string is not a reasonable type for C, so copy the characters
+;;; out and then call connect_to_server routine defined in socket.o
+
+(CLINES "
+int
+konnect_to_server(host,display)
+     object host;		/* host name */
+     int    display;		/* display number */
+{
+   int fd;			/* file descriptor */
+   int i;
+   char hname[BUFSIZ];
+   FILE *fout, *fin;
+
+   if (host->st.st_fillp > BUFSIZ - 1)
+     too_long_file_name(host);
+   for (i = 0;  i < host->st.st_fillp;  i++)
+     hname[i] = host->st.st_self[i];
+   hname[i] = '\\0';            /* doubled backslash for lisp */
+
+   fd = connect_to_server(hname,display);
+
+   return(fd);
+}
+")
+
+(defentry konnect-to-server (object int) (int "konnect_to_server"))
+
+
+;;;; Make a one-way stream from a file descriptor.
+
+(CLINES "
+object
+konnect_stream(host,fd,flag,elem)
+     object host;		/* not really used */
+     int fd;			/* file descriptor */
+     int flag;			/* 0 input, 1 output */
+     object elem;		/* 'string-char */
+{
+   struct stream *stream;
+   char *mode;			/* file open mode */
+   FILE *fp;			/* file pointer */
+   enum smmode smm;		/* lisp mode (a short) */
+   vs_mark;
+
+   switch(flag){
+    case 0:
+      smm = smm_input;
+      mode = \"r\";
+      break;
+    case 1:
+      smm = smm_output;
+      mode = \"w\";
+      break;
+    default:
+      FEerror(\"konnect_stream : wrong mode\");
+   }
+   
+   fp = fdopen(fd,mode);
+
+   if (fp == NULL) {
+     stream = Cnil;
+     vs_push(stream);
+   } else {
+     stream = alloc_object(t_stream);
+     stream->sm_mode = (short)smm;
+     stream->sm_fp = fp;
+     stream->sm_object0 = elem;
+     stream->sm_object1 = host;
+     stream->sm_int0 = stream->sm.sm_int1 = 0;
+     vs_push(stream);
+     setbuf(fp, alloc_contblock(BUFSIZ));
+   }
+   vs_reset;
+   return(stream);
+}
+")
+
+(defentry konnect-stream (object int int object) (object "konnect_stream"))
+
+
+;;;; Open an X stream
+
+(defun open-socket-stream (host display)
+  (when (not (and (typep host    'string)	; sanity check the arguments
+		  (typep display 'fixnum)))
+    (error "Host ~s or display ~s are bad." host display))
+
+  (let ((fd (konnect-to-server host display)))	; get a file discriptor
+    (if (< fd 0)
+	NIL
+	(let ((stream-in  (konnect-stream host fd 0 'string-char))	; input
+	      (stream-out (konnect-stream host fd 1 'string-char)))	; output
+	  (if (or (null stream-in) (null stream-out))
+	      (error "Could not make i/o streams for fd ~d." fd))
+	  (make-two-way-stream stream-in stream-out))
+	)))
diff --git a/clx/socket.c b/clx/socket.c
new file mode 100644
index 000000000..f8c843ebc
--- /dev/null
+++ b/clx/socket.c
@@ -0,0 +1,144 @@
+/* Copyright    Massachusetts Institute of Technology    1988	*/
+/*
+ * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived
+ * systems.  VMS and System V should plan to have their own version.
+ *
+ * This code was cribbed from lib/X/XConnDis.c.
+ * Compile using   
+ *                    % cc -c socket.c -DUNIXCONN
+ */
+
+#include <stdio.h>
+#include <X11/Xos.h>
+#include <X11/Xproto.h>
+#include <errno.h>
+#include <netinet/in.h>
+#include <sys/ioctl.h>
+#include <netdb.h> 
+#include <sys/socket.h>
+#ifndef hpux
+#include <netinet/tcp.h>
+#endif
+
+extern int errno;		/* Certain (broken) OS's don't have this */
+				/* decl in errno.h */
+
+#ifdef UNIXCONN
+#include <sys/un.h>
+#ifndef X_UNIX_PATH
+#ifdef hpux
+#define X_UNIX_PATH "/usr/spool/sockets/X11/"
+#define OLD_UNIX_PATH "/tmp/.X11-unix/X"
+#else /* hpux */
+#define X_UNIX_PATH "/tmp/.X11-unix/X"
+#endif /* hpux */
+#endif /* X_UNIX_PATH */
+#endif /* UNIXCONN */
+void bcopy();
+
+/* 
+ * Attempts to connect to server, given host and display. Returns file 
+ * descriptor (network socket) or 0 if connection fails.
+ */
+
+int connect_to_server (host, display)
+     char *host;
+     int display;
+{
+  struct sockaddr_in inaddr;	/* INET socket address. */
+  struct sockaddr *addr;		/* address to connect to */
+  struct hostent *host_ptr;
+  int addrlen;			/* length of address */
+#ifdef UNIXCONN
+  struct sockaddr_un unaddr;	/* UNIX socket address. */
+#endif
+  extern char *getenv();
+  extern struct hostent *gethostbyname();
+  int fd;				/* Network socket */
+  {
+#ifdef UNIXCONN
+    if ((host[0] == '\0') || (strcmp("unix", host) == 0)) {
+	/* Connect locally using Unix domain. */
+	unaddr.sun_family = AF_UNIX;
+	(void) strcpy(unaddr.sun_path, X_UNIX_PATH);
+	sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display);
+	addr = (struct sockaddr *) &unaddr;
+	addrlen = strlen(unaddr.sun_path) + 2;
+	/*
+	 * Open the network connection.
+	 */
+	if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) {
+#ifdef hpux /* this is disgusting */  /* cribbed from X11R4 xlib source */
+  	    if (errno == ENOENT) {  /* No such file or directory */
+	      sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display);
+              addrlen = strlen(unaddr.sun_path) + 2;
+              if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0)
+                return(-1);     /* errno set by most recent system call. */
+	    } else 
+#endif /* hpux */
+	    return(-1);	    /* errno set by system call. */
+        }
+    } else 
+#endif /* UNIXCONN */
+    {
+      /* Get the statistics on the specified host. */
+      if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) 
+	{
+	  if ((host_ptr = gethostbyname(host)) == NULL) 
+	    {
+	      /* No such host! */
+	      errno = EINVAL;
+	      return(-1);
+	    }
+	  /* Check the address type for an internet host. */
+	  if (host_ptr->h_addrtype != AF_INET) 
+	    {
+	      /* Not an Internet host! */
+	      errno = EPROTOTYPE;
+	      return(-1);
+	    }
+	  /* Set up the socket data. */
+	  inaddr.sin_family = host_ptr->h_addrtype;
+	  bcopy((char *)host_ptr->h_addr, 
+		(char *)&inaddr.sin_addr, 
+		sizeof(inaddr.sin_addr));
+	} 
+      else 
+	{
+	  inaddr.sin_family = AF_INET;
+	}
+      addr = (struct sockaddr *) &inaddr;
+      addrlen = sizeof (struct sockaddr_in);
+      inaddr.sin_port = display + X_TCP_PORT;
+      inaddr.sin_port = htons(inaddr.sin_port);
+      /*
+       * Open the network connection.
+       */
+      if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){
+	return(-1);	    /* errno set by system call. */}
+      /* make sure to turn off TCP coalescence */
+#ifdef TCP_NODELAY
+      {
+	int mi = 1;
+	setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int));
+      }
+#endif
+    }
+
+    /*
+     * Changed 9/89 to retry connection if system call was interrupted.  This
+     * is necessary for multiprocessing implementations that use timers,
+     * since the timer results in a SIGALRM.	-- jdi
+     */
+    while (connect(fd, addr, addrlen) == -1) {
+	if (errno != EINTR) {
+  	    (void) close (fd);
+  	    return(-1); 	    /* errno set by system call. */
+	}
+      }
+  }
+  /*
+   * Return the id if the connection succeeded.
+   */
+  return(fd);
+}
diff --git a/clx/text.lisp b/clx/text.lisp
new file mode 100644
index 000000000..59415101c
--- /dev/null
+++ b/clx/text.lisp
@@ -0,0 +1,1083 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; CLX text keyboard and pointer requests
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  translation-function
+	  translate-default
+	  text-extents
+	  text-width
+	  draw-glyph
+	  draw-glyphs
+	  draw-image-glyph
+	  draw-image-glyphs
+	  display-keycode-range
+	  set-modifier-mapping
+	  modifier-mapping
+	  keysym
+	  change-keyboard-mapping
+	  keyboard-mapping
+	  keyboard-mapping
+	  ))
+
+;; Strings are broken up into chunks of this size
+(defparameter *max-string-size* 254)
+
+;; In the functions below, the transform is used to convert an element of the
+;; sequence into a font index.  The transform is applied to each element of the
+;; (sub)sequence, until either the transform returns nil or the end of the
+;; (sub)sequence is reached.  If transform returns nil for an element, the
+;; index of that element in the sequence is returned, otherwise nil is
+;; returned.
+
+(deftype translation-function ()
+  #+explorer t
+  #-explorer
+  '(function (sequence array-index array-index (or null font) vector array-index)
+	     (values array-index (or null int16 font) (or null int32))))
+
+;; In the functions below, if width is specified, it is assumed to be the pixel
+;; width of whatever string of glyphs is actually drawn.  Specifying width will
+;; allow for appending the output of subsequent calls to the same protocol
+;; request, provided gcontext has not been modified in the interim.  If width
+;; is not specified, appending of subsequent output might not occur.
+;; Specifying width is simply a hint, for performance.  Note that specifying
+;; width may be difficult if transform can return nil.
+
+(defun translate-default (src src-start src-end font dst dst-start)
+  ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
+  ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
+  ;; on context.  font is the current font, if known.  The function should
+  ;; translate as many elements of src as possible into indexes in the current
+  ;; font, and store them into dst.
+  ;;
+  ;; The first return value should be the src index of the first untranslated
+  ;; element.  If no further elements need to be translated, the second return
+  ;; value should be nil.  If a horizontal motion is required before further
+  ;; translation, the second return value should be the delta in x coordinate.
+  ;; If a font change is required for further translation, the second return
+  ;; value should be the new font.  If known, the pixel width of the translated
+  ;; text can be returned as the third value; this can allow for appending of
+  ;; subsequent output to the same protocol request, if no overall width has
+  ;; been specified at the higher level.
+  ;; (returns values: ending-index
+  ;;                  (OR null horizontal-motion font)
+  ;;                  (OR null translated-width))
+  (declare (type sequence src)
+	   (type array-index src-start src-end dst-start)
+	   (type (or null font) font)
+	   (type vector dst)
+	   (inline graphic-char-p))
+  (declare (values integer (or null integer font) (or null integer)))
+  font ;;not used
+  (if (stringp src)
+      (do ((i src-start (index+ i 1))
+	   (j dst-start (index+ j 1))
+	   (char))
+	  ((index>= i src-end)
+	   i)
+	(declare (type array-index i j))
+	(if (graphic-char-p (setq char (char src i)))
+	    (setf (aref dst j) (char->card8 char))
+	  (return i)))
+      (do ((i src-start (index+ i 1))
+	   (j dst-start (index+ j 1))
+	   (elt))
+	  ((index>= i src-end)
+	   i)
+	(declare (type array-index i j))
+	(setq elt (elt src i))
+	(cond ((and (characterp elt) (graphic-char-p elt))
+	       (setf (aref dst j) (char->card8 elt)))
+	      ((integerp elt)
+	       (setf (aref dst j) elt))
+	      (t
+	       (return i))))))
+
+;; There is a question below of whether translate should always be required, or
+;; if not, what the default should be or where it should come from.  For
+;; example, the default could be something that expected a string as src and
+;; translated the CL standard character set to ASCII indexes, and ignored fonts
+;; and bits.  Or the default could expect a string but otherwise be "system
+;; dependent".  Or the default could be something that expected a vector of
+;; integers and did no translation.  Or the default could come from the
+;; gcontext (but what about text-extents and text-width?).
+
+(defun text-extents (font sequence &key (start 0) end translate)
+  ;; If multiple fonts are involved, font-ascent and font-descent will be the
+  ;; maximums.  If multiple directions are involved, the direction will be nil.
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values width ascent descent left right
+		  font-ascent font-descent direction
+		  (or null array-index)))
+  (when (type? font 'gcontext)
+    (force-gcontext-changes font)
+    (setq font (gcontext-font font t)))
+  (check-type font font)
+  (let* ((left-bearing 0)
+	 (right-bearing 0)
+	 ;; Sum of widths
+	 (width 0)
+	 (ascent 0)
+	 (descent 0)
+	 (overall-ascent (font-ascent font))
+	 (overall-descent (font-descent font))
+	 (overall-direction (font-direction font))	 
+	 (next-start nil)
+	 (display (font-display font)))
+    (declare (type int16 ascent descent overall-ascent overall-descent)
+	     (type int32 left-bearing right-bearing width)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-display (display)
+      (do* ((wbuf (display-tbuf16 display))
+	    (src-end (or end (length sequence)))
+	    (src-start start end)
+	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
+		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (buf-end 0)
+	    (new-font)
+	    (font-ascent 0)
+	    (font-descent 0)
+	    (font-direction)
+	    (stop-p nil))
+	   ((or stop-p (index>= src-start src-end))
+	    (when (index< src-start src-end)
+	      (setq next-start src-start)))
+	(declare (type buffer-text16 wbuf)
+		 (type array-index src-start src-end end buf-end)
+		 (type int16 font-ascent font-descent)
+		 (type boolean stop-p))
+	;; Translate the text
+	(multiple-value-setq (buf-end new-font)
+	  (funcall (or translate #'translate-default)
+		   sequence src-start end font wbuf 0))
+	(setq buf-end (- buf-end src-start))
+	(cond ((null new-font) (setq stop-p t))
+	      ((integerp new-font) (incf width (the int32 new-font)))
+	      ((type? new-font 'font) (setq font new-font)))
+	
+	(let (w a d l r)
+	  (if (or (font-char-infos-internal font) (font-local-only-p font))
+	      ;; Calculate text extents locally
+	      (progn
+		(multiple-value-setq (w a d l r)
+		  (text-extents-local font wbuf 0 buf-end nil))
+		(setq font-ascent (the int16 (font-ascent font))
+		      font-descent (the int16 (font-descent font))
+		      font-direction (font-direction font)))
+	    ;; Let the server calculate text extents
+	    (multiple-value-setq
+	      (w a d l r font-ascent font-descent font-direction)
+	      (text-extents-server font wbuf 0 buf-end)))
+	  (incf width (the int32 w))
+	  (cond ((index= src-start start)
+		 (setq left-bearing (the int32 l))
+		 (setq right-bearing (the int32 r))
+		 (setq ascent (the int16 a))
+		 (setq descent (the int16 d)))
+		(t
+		 (setq left-bearing (the int32 (min left-bearing (the int32 l))))
+		 (setq right-bearing (the int32 (max right-bearing (the int32 r))))
+		 (setq ascent (the int16 (max ascent (the int16 a))))
+		 (setq descent (the int16 (max descent (the int16 d)))))))
+	
+	(setq overall-ascent (the int16 (max overall-ascent font-ascent)))
+	(setq overall-descent (the int16 (max overall-descent font-descent)))
+	(case overall-direction
+	  (:unknown (setq overall-direction font-direction))
+	  (:left-to-right (unless (eq font-direction :left-to-right)
+			    (setq overall-direction nil)))
+	  (:right-to-left (unless (eq font-direction :right-to-left)
+			    (setq overall-direction nil))))))
+    
+    (values width
+	    ascent
+	    descent
+	    left-bearing
+	    right-bearing
+	    overall-ascent
+	    overall-descent
+	    overall-direction
+	    next-start)))
+
+(defun text-width (font sequence &key (start 0) end translate)
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font)
+	   (type array-index start)
+	   (type (or null array-index) end))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values integer (or null integer)))
+  (when (type? font 'gcontext)
+    (force-gcontext-changes font)
+    (setq font (gcontext-font font t)))
+  (check-type font font)
+  (let* ((width 0)
+	 (next-start nil)
+	 (display (font-display font)))
+    (declare (type int32 width)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-display (display)
+      (do* ((wbuf (display-tbuf16 display))
+	    (src-end (or end (length sequence)))
+	    (src-start start end)
+	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
+		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (buf-end 0)
+	    (new-font)
+	    (stop-p nil))
+	   ((or stop-p (index>= src-start src-end))
+	    (when (index< src-start src-end)
+	      (setq next-start src-start)))
+	(declare (type buffer-text16 wbuf)
+		 (type array-index src-start src-end end buf-end)
+		 (type boolean stop-p))
+	;; Translate the text
+	(multiple-value-setq (buf-end new-font)
+	  (funcall (or translate #'translate-default)
+		   sequence src-start end font wbuf 0))
+	(setq buf-end (- buf-end src-start))
+	(cond ((null new-font) (setq stop-p t))
+	      ((integerp new-font) (incf width (the int32 new-font)))
+	      ((type? new-font 'font) (setq font new-font)))
+	
+	(incf width
+	      (if (or (font-char-infos-internal font) (font-local-only-p font))
+		  (text-extents-local font wbuf 0 buf-end :width-only)
+		(text-width-server font wbuf 0 buf-end)))))
+    (values width next-start)))
+
+#+clx-little-endian
+(defun byte-swap-card16 (card16)
+  (declare (type card16 card16))
+  (declare (values card16))
+  (dpb card16 (byte 8 8) (ash card16 -8)))  
+
+(defun text-extents-server (font string start end)
+  (declare (type font font)
+	   (type string string)
+	   (type array-index start end))
+  (declare (values width ascent descent left right font-ascent font-descent direction))
+  (let ((display (font-display font))
+	(length (index- end start))
+	(font-id (font-id font)))
+    (declare (type display display)
+	     (type array-index length)
+	     (type resource-id font-id))
+    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32))
+	 (((data boolean) (oddp length))
+	  (length (index+ (index-ceiling length 2) 2))
+	  (resource-id font-id)
+	  ((sequence :format card16 :start start :end end :appending t
+		     #+clx-little-endian :transform
+		     #+clx-little-endian ;; Byte swap for little-endian
+		     #'byte-swap-card16)
+	   string))
+      (values
+	(integer-get 16)
+	(int16-get 12)
+	(int16-get 14)
+	(integer-get 20)
+	(integer-get 24)
+	(int16-get 8)
+	(int16-get 10)
+	(member8-get 1 :left-to-right :right-to-left)))))
+
+(defun text-width-server (font string start end)
+  (declare (type (or font gcontext) font)
+	   (type string string)
+	   (type array-index start end))
+  (declare (values integer))
+  (let ((display (font-display font))
+	(length (index- end start))
+	(font-id (font-id font)))
+    (declare (type display display)
+	     (type array-index length)
+	     (type resource-id font-id))
+    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)
+	 (((data boolean) (oddp length))
+	  (length (index+ (index-ceiling length 2) 2))
+	  (resource-id font-id)
+	  ((sequence :format card16 :start start :end end :appending t
+		     #+clx-little-endian :transform
+		     #+clx-little-endian ;; Byte swap for little-endian
+		     #'byte-swap-card16)
+	   string))
+      (values (integer-get 16)))))
+
+(defun text-extents-local (font sequence start end width-only-p)
+  (declare (type font font)
+	   (type sequence sequence)
+	   (type integer start end)
+	   (type boolean width-only-p))
+  (declare (values width ascent descent overall-left overall-right))
+  (let* ((char-infos (font-char-infos font))
+	 (font-info (font-font-info font)))
+    (declare (type font-info font-info))
+    (declare (type (simple-array int16 (*)) char-infos)
+	     (array-register char-infos))
+    (if (zerop (length char-infos))
+	;; Fixed width font
+	(let* ((font-width (max-char-width font))
+	       (font-ascent (max-char-ascent font))
+	       (font-descent (max-char-descent font))
+	       (width (* (index- end start) font-width)))
+	  (declare (type int16 font-width font-ascent font-descent)
+		   (type int32 width))
+	  (if width-only-p
+	      width
+	    (values width
+		    font-ascent
+		    font-descent
+		    (max-char-left-bearing font)
+		    (+ width (- font-width) (max-char-right-bearing font)))))
+      
+      ;; Variable-width font
+      (let* ((first-col (font-info-min-byte2 font-info))
+	     (num-cols (1+ (- (font-info-max-byte2 font-info) first-col)))
+	     (first-row (font-info-min-byte1 font-info))
+	     (last-row (font-info-max-byte1 font-info))
+	     (num-rows (1+ (- last-row first-row))))
+	(declare (type card8 first-col first-row last-row)
+		 (type card16 num-cols num-rows))
+	(if (or (plusp first-row) (plusp last-row))
+	    
+	    ;; Matrix (16 bit) font
+	    (macrolet ((char-info-elt (sequence elt)
+			 `(let* ((char (the card16 (elt ,sequence ,elt)))
+				 (row (- (ash char -8) first-row))
+				 (col (- (logand char #xff) first-col)))
+			    (declare (type card16 char)
+				     (type int16 row col))
+			    (if (and (< -1 row num-rows) (< -1 col num-cols))
+				(index* 6 (index+ (index* row num-cols) col))
+			      -1))))
+	      (if width-only-p
+		  (do ((i start (index1+ i))
+		       (width 0))
+		      ((index>= i end) width)
+		    (declare (type array-index i)
+			     (type int32 width))
+		    (let ((n (char-info-elt sequence i)))
+		      (declare (type fixnum n))
+		      (unless (minusp n)  ;; Ignore characters not in the font
+			(incf width (the int16 (aref char-infos (index+ 2 n)))))))
+		;; extents
+		(do ((i start (index1+ i))
+		     (width 0)
+		     (ascent 0)
+		     (descent 0)
+		     (left #x7fff)
+		     (right 0))
+		    ((index>= i end)
+		     (values width ascent descent left right))
+		  (declare (type array-index i)
+			   (type int16 ascent descent)
+			   (type int32 width left right))
+		  (let ((n (char-info-elt sequence i)))
+		    (declare (type fixnum n))
+		    (unless (minusp n) ;; Ignore characters not in the font
+		      (setq left (min left (+ width (aref char-infos n))))
+		      (setq right (max right (+ width (aref char-infos (index1+ n)))))
+		      (incf width (aref char-infos (index+ 2 n)))
+		      (setq ascent (max ascent (aref char-infos (index+ 3 n))))
+		      (setq descent (max descent (aref char-infos (index+ 4 n)))))))))
+	  
+	  ;; Non-matrix (8 bit) font
+	  ;; The code here is identical to the above, except for the following macro:
+	  (macrolet ((char-info-elt (sequence elt)
+		       `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col)))
+			  (declare (type int16 col))
+			  (if (< -1 col num-cols)
+			      (index* 6 col)
+			    -1))))
+	    (if width-only-p
+		(do ((i start (index1+ i))
+		     (width 0))
+		    ((index>= i end) width)
+		  (declare (type array-index i)
+			   (type int32 width))
+		  (let ((n (char-info-elt sequence i)))
+		    (declare (type fixnum n))
+		    (unless (minusp n) ;; Ignore characters not in the font
+		      (incf width (the int16 (aref char-infos (index+ 2 n)))))))
+	      ;; extents
+	      (do ((i start (index1+ i))
+		   (width 0)
+		   (ascent 0)
+		   (descent 0)
+		   (left #x7fff)
+		   (right 0))
+		  ((index>= i end)
+		   (values width ascent descent left right))
+		(declare (type array-index i)
+			 (type int16 ascent descent)
+			 (type int32 width left right))
+		(let ((n (char-info-elt sequence i)))
+		  (declare (type fixnum n))
+		  (unless (minusp n) ;; Ignore characters not in the font
+		    (setq left (min left (+ width (aref char-infos n))))
+		    (setq right (max right (+ width (aref char-infos (index1+ n)))))
+		    (incf width (aref char-infos (index+ 2 n)))
+		    (setq ascent (max ascent (aref char-infos (index+ 3 n))))
+		    (setq descent (max descent (aref char-infos (index+ 4 n)))))
+		  ))))
+	  )))))
+
+;;-----------------------------------------------------------------------------
+
+;; This controls the element size of the dst buffer given to translate.  If
+;; :default is specified, the size will be based on the current font, if known,
+;; and otherwise 16 will be used.  [An alternative would be to pass the buffer
+;; size to translate, and allow it to return the desired size if it doesn't
+;; like the current size.  The problem is that the protocol doesn't allow
+;; switching within a single request, so to allow switching would require
+;; knowing the width of text, which isn't necessarily known.  We could call
+;; text-width to compute it, but perhaps that is doing too many favors?]  [An
+;; additional possibility is to allow an index-size of :two-byte, in which case
+;; translate would be given a double-length 8-bit array, and translate would be
+;; expected to store first-byte/second-byte instead of 16-bit integers.]
+
+(deftype index-size () '(member :default 8 16))
+
+;; In the functions below, if width is specified, it is assumed to be the total
+;; pixel width of whatever string of glyphs is actually drawn.  Specifying
+;; width will allow for appending the output of subsequent calls to the same
+;; protocol request, provided gcontext has not been modified in the interim.
+;; If width is not specified, appending of subsequent output might not occur
+;; (unless translate returns the width).  Specifying width is simply a hint,
+;; for performance.
+
+(defun draw-glyph (drawable gcontext x y elt
+		   &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values boolean (or null int32)))
+  (let* ((display (gcontext-display gcontext))
+	 (result t)
+	 (opcode *x-polytext8*))
+    (declare (type display display))
+    (let ((vector (allocate-gcontext-state)))
+      (declare (type gcontext-state vector))
+      (setf (aref vector 0) elt)
+      (multiple-value-bind (new-start new-font translate-width)
+	  (funcall (or translate #'translate-default)
+		   vector 0 1 (gcontext-font gcontext t) vector 1)
+	;; Allow translate to set a new font
+	(when (type? new-font 'font) 
+	  (setf (gcontext-font gcontext) new-font)
+	  (multiple-value-setq (new-start new-font translate-width)
+	    (funcall translate vector 0 1 new-font vector 1)))
+	;; If new-start is zero, translate refuses to output it
+	(setq result (index-plusp new-start)
+	      elt (aref vector 1))
+	(deallocate-gcontext-state vector)
+	(when translate-width (setq width translate-width))))
+    (when result
+      (when (eql size 16)
+	(setq opcode *x-polytext16*)
+	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
+      (with-buffer-request (display opcode :gc-force gcontext)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(card8 1 0)
+	(card8 (ldb (byte 8 0) elt))
+	(card8 (ldb (byte 8 8) elt)))
+      (values t width))))
+  
+(defun draw-glyphs (drawable gcontext x y sequence
+		    &key (start 0) end translate width (size :default))
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values (or null array-index) (or null int32)))
+  (unless end (setq end (length sequence)))
+  (ecase size
+    ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end
+				(or translate #'translate-default) width))
+    (16 (draw-glyphs16 drawable gcontext x y sequence start end
+		       (or translate #'translate-default) width))))
+
+(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width)
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int32 x y width)
+	   (type array-index start end)
+	   (type sequence sequence))
+  (declare (values (or null array-index) (or null int32)))
+  (declare (type translation-function translate)
+	   (downward-funarg translate)) 
+  (let* ((src-start start)
+	 (src-end (or end (length sequence)))
+	 (next-start nil)
+	 (length (index- src-end src-start))
+	 (request-length (* length 2))		; Leave lots of room for font shifts.
+	 (display (gcontext-display gcontext))
+	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	 (font (gcontext-font gcontext t)))
+    (declare (type array-index src-start src-end length)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)
+      (drawable drawable)
+      (gcontext gcontext)
+      (int16 x y)
+      (progn
+	;; Don't let any flushes happen since we manually set the request
+	;; length when we're done.
+	(with-buffer-flush-inhibited (display)
+	  (do* ((boffset (index+ buffer-boffset 16))
+		(src-chunk 0)
+		(dst-chunk 0)
+		(offset 0)
+		(overall-width 0)
+		(stop-p nil))
+	       ((or stop-p (zerop length))
+		;; Ensure terminated with zero bytes
+		(do ((end (the array-index (lround boffset))))
+		    ((index>= boffset end))
+		  (setf (aref buffer-bbuf boffset) 0)
+		  (index-incf boffset))
+		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
+		(setf (buffer-boffset display) boffset)
+		(unless (index-zerop length) (setq next-start src-start))
+		(when overall-width (setq width overall-width)))
+
+	    (declare (type array-index src-chunk dst-chunk offset)
+		     (type (or null int32) overall-width)
+		     (type boolean stop-p))
+	    (setq src-chunk (index-min length *max-string-size*))
+	    (multiple-value-bind (new-start new-font translated-width)
+		(funcall translate
+			 sequence src-start (index+ src-start src-chunk)
+			 font buffer-bbuf (index+ boffset 2))
+	      (setq dst-chunk (index- new-start src-start)
+		    length (index- length dst-chunk)
+		    src-start new-start)
+	      (if translated-width
+		  (when overall-width (incf overall-width translated-width))
+		(setq overall-width nil))
+	      (when (index-plusp dst-chunk)
+		(setf (aref buffer-bbuf boffset) dst-chunk)
+		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
+		(incf boffset (index+ dst-chunk 2)))
+	      (setq offset 0)
+	      (cond ((null new-font)
+		     ;; Don't stop if translate copied whole chunk
+		     (unless (index= src-chunk dst-chunk)
+		       (setq stop-p t)))
+		    ((integerp new-font) (setq offset new-font))
+		    ((type? new-font 'font)
+		     (setq font new-font)
+		     (let ((font-id (font-id font))
+			   (buffer-boffset boffset))
+		       (declare (type resource-id font-id)
+				(type array-index buffer-boffset))
+		       ;; This changes the gcontext font in the server
+		       ;; Update the gcontext cache (both local and server state)
+		       (let ((local-state (gcontext-local-state gcontext))
+			     (server-state (gcontext-server-state gcontext)))
+			 (declare (type gcontext-state local-state server-state))
+			 (setf (gcontext-internal-font-obj server-state) font
+			       (gcontext-internal-font server-state) font-id)
+			 (without-interrupts
+			   (setf (gcontext-internal-font-obj local-state) font
+				 (gcontext-internal-font local-state) font-id)))
+		       (card8-put 0 #xff)
+		       (card8-put 1 (ldb (byte 8 24) font-id))
+		       (card8-put 2 (ldb (byte 8 16) font-id))
+		       (card8-put 3 (ldb (byte 8 8) font-id))
+		       (card8-put 4 (ldb (byte 8 0) font-id)))
+		     (index-incf boffset 5)))
+	      )))))
+    (values next-start width)))
+
+;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
+;;       on 16bit boundaries and this function garbles the bytes.
+(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start end)
+	   (type int32 width)
+	   (type sequence sequence))
+  (declare (values (or null array-index) (or null int32)))
+  (declare (type translation-function translate)
+	   (downward-funarg translate))
+  (let* ((src-start start)
+	 (src-end (or end (length sequence)))
+	 (next-start nil)
+	 (length (index- src-end src-start))
+	 (request-length (* length 3))		; Leave lots of room for font shifts.
+	 (display (gcontext-display gcontext))
+	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	 (font (gcontext-font gcontext t))
+	 (buffer (display-tbuf16 display)))
+    (declare (type array-index src-start src-end length)
+	     (type (or null array-index) next-start)
+	     (type display display)
+	     (type buffer-text16 buffer))
+    (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)
+      (drawable drawable)
+      (gcontext gcontext)
+      (int16 x y)
+      (progn
+	;; Don't let any flushes happen since we manually set the request
+	;; length when we're done.
+	(with-buffer-flush-inhibited (display)
+	  (do* ((boffset (index+ buffer-boffset 16))
+		(src-chunk 0)
+		(dst-chunk 0)
+		(offset 0)
+		(overall-width 0)
+		(stop-p nil))
+	       ((or stop-p (zerop length))
+		;; Ensure terminated with zero bytes
+		(do ((end (lround boffset)))
+		    ((index>= boffset end))
+		  (setf (aref buffer-bbuf boffset) 0)
+		  (index-incf boffset))
+		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
+		(setf (buffer-boffset display) boffset)
+		(unless (zerop length) (setq next-start src-start))
+		(when overall-width (setq width overall-width)))
+
+	    (declare (type array-index boffset src-chunk dst-chunk offset)
+		     (type (or null int32) overall-width)
+		     (type boolean stop-p))
+	    (setq src-chunk (index-min length *max-string-size*))
+	    (multiple-value-bind (new-start new-font translated-width)
+		(funcall translate
+			 sequence src-start (index+ src-start src-chunk)
+			 font buffer 0)
+	      (setq dst-chunk (index- new-start src-start)
+		    length (index- length dst-chunk)
+		    src-start new-start)
+	      (write-sequence-card16 display (index+ boffset 2) buffer 0 dst-chunk
+				     #+clx-little-endian ;; Byte swap for little-endian
+				     #'byte-swap-card16)
+	      (if translated-width
+		  (when overall-width (incf overall-width translated-width))
+		(setq overall-width nil))
+	      (when (index-plusp dst-chunk)
+		(setf (aref buffer-bbuf boffset) dst-chunk)
+		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
+		(index-incf boffset (index+ dst-chunk dst-chunk 2)))
+	      (setq offset 0)
+	      (cond ((null new-font)
+		     ;; Don't stop if translate copied whole chunk
+		     (unless (index= src-chunk dst-chunk) 
+		       (setq stop-p t)))
+		    ((integerp new-font) (setq offset new-font))
+		    ((type? new-font 'font)
+		     (setq font new-font)
+		     (let ((font-id (font-id font))
+			   (buffer-boffset boffset))
+		       (declare (type resource-id font-id)
+				(type array-index buffer-boffset))
+		       ;; This changes the gcontext font in the SERVER
+		       ;; Update the gcontext cache (both local and server state)
+		       (let ((local-state (gcontext-local-state gcontext))
+			     (server-state (gcontext-server-state gcontext)))
+			 (declare (type gcontext-state local-state server-state))
+			 (setf (gcontext-internal-font-obj server-state) font
+			       (gcontext-internal-font server-state) font-id)
+			 (without-interrupts
+			   (setf (gcontext-internal-font-obj local-state) font
+				 (gcontext-internal-font local-state) font-id)))
+		       (card8-put 0 #xff)
+		       (card8-put 1 (ldb (byte 8 24) font-id))
+		       (card8-put 2 (ldb (byte 8 16) font-id))
+		       (card8-put 3 (ldb (byte 8 8) font-id))
+		       (card8-put 4 (ldb (byte 8 0) font-id)))
+		     (index-incf boffset 5)))
+	      )))))
+    (values next-start width)))
+
+(defun draw-image-glyph (drawable gcontext x y elt
+			 &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is overall width, if known.  An initial font change is
+  ;; allowed from translate.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values boolean (or null int32)))
+  (let* ((display (gcontext-display gcontext))
+	 (result t)
+	 (opcode *x-imagetext8*))
+    (declare (type display display))
+    (let ((vector (allocate-gcontext-state)))
+      (declare (type gcontext-state vector))
+      (setf (aref vector 0) elt)
+      (multiple-value-bind (new-start new-font translate-width)
+	  (funcall (or translate #'translate-default)
+		   vector 0 1 (gcontext-font gcontext t) vector 1)
+	;; Allow translate to set a new font
+	(when (type? new-font 'font) 
+	  (setf (gcontext-font gcontext) new-font)
+	  (multiple-value-setq (new-start new-font translate-width)
+	    (funcall translate vector 0 1 new-font vector 1)))
+	;; If new-start is zero, translate refuses to output it
+	(setq result (index-plusp new-start)
+	      elt (aref vector 1))
+	(deallocate-gcontext-state vector)
+	(when translate-width (setq width translate-width))))
+    (when result
+      (when (eql size 16)
+	(setq opcode *x-imagetext16*)
+	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
+      (with-buffer-request (display opcode :gc-force gcontext)
+	(drawable drawable)
+	(gcontext gcontext)
+	(data 1) ;; 1 character
+	(int16 x y)
+	(card8 (ldb (byte 8 0) elt))
+	(card8 (ldb (byte 8 8) elt)))
+      (values t width))))
+
+(defun draw-image-glyphs (drawable gcontext x y sequence
+			  &key (start 0) end width translate (size :default))
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type sequence sequence)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values (or null array-index) (or null int32)))
+  (unless end (setq end (length sequence)))
+  (ecase size
+    ((:default 8)
+     (draw-image-glyphs8 drawable gcontext x y sequence start end width translate))
+    (16
+     (draw-image-glyphs16 drawable gcontext x y sequence start end width translate))))
+
+(defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate)
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)) 
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg translate))
+  (declare (values (or null array-index) (or null int32)))
+  (do* ((display (gcontext-display gcontext))
+	(length (index- end start))
+	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	(font (gcontext-font gcontext t))
+	(font-change nil)
+	(new-start) (translated-width) (chunk))
+       (nil) ;; forever
+    (declare (type display display)
+	     (type array-index length)
+	     (type (or null array-index) new-start chunk))
+    
+    (when font-change
+      (setf (gcontext-font gcontext) font))
+    (block change-font
+      (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(progn
+	  ;; Don't let any flushes happen since we manually set the request
+	  ;; length when we're done.
+	  (with-buffer-flush-inhibited (display)
+	    ;; Translate the sequence into the buffer
+	    (multiple-value-setq (new-start font translated-width)
+	      (funcall (or translate #'translate-default) sequence start end
+		       font buffer-bbuf (index+ buffer-boffset 16)))
+	    ;; Number of glyphs translated
+	    (setq chunk (index- new-start start))		
+	    ;; Check for initial font change
+	    (when (and (index-zerop chunk) (type? font 'font))
+	      (setq font-change t) ;; Loop around changing font
+	      (return-from change-font))
+	    ;; Quit when nothing translated
+	    (when (index-zerop chunk)
+	      (return-from draw-image-glyphs8 new-start))
+	    ;; Update buffer pointers
+	    (data-put 1 chunk)
+	    (let ((blen (lround (index+ 16 chunk))))
+	      (length-put 2 (index-ash blen -2))
+	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
+      ;; Normal exit
+      (return-from draw-image-glyphs8
+	(values (if (index= chunk length) nil new-start)
+		(or translated-width width))))))
+
+(defun draw-image-glyphs16 (drawable gcontext x y sequence start end width translate)
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg translate))
+  (declare (values (or null array-index) (or null int32)))
+  (do* ((display (gcontext-display gcontext))
+	(length (index- end start))
+	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	(font (gcontext-font gcontext t)) 
+	(font-change nil)
+	(new-start) (translated-width) (chunk)
+	(buffer (buffer-tbuf16 display)))
+       (nil) ;; forever
+    
+    (declare (type display display)
+	     (type array-index length)
+	     (type (or null array-index) new-start chunk)
+	     (type buffer-text16 buffer))
+    (when font-change
+      (setf (gcontext-font gcontext) font))
+
+    (block change-font
+      (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(progn
+	  ;; Don't let any flushes happen since we manually set the request
+	  ;; length when we're done.
+	  (with-buffer-flush-inhibited (display)
+	    ;; Translate the sequence into the buffer
+	    (multiple-value-setq (new-start font translated-width)
+	      (funcall (or translate #'translate-default) sequence start end
+		       font buffer 0))
+	    ;; Number of glyphs translated
+	    (setq chunk (index- new-start start))
+	    ;; Check for initial font change
+	    (when (and (index-zerop chunk) (type? font 'font))
+	      (setq font-change t) ;; Loop around changing font
+	      (return-from change-font))
+	    ;; Quit when nothing translated
+	    (when (index-zerop chunk)
+	      (return-from draw-image-glyphs16 new-start))
+	    (write-sequence-card16 display (index+ buffer-boffset 16) buffer 0 chunk
+				   #+clx-little-endian ;; Byte swap for little-endian
+				   #'byte-swap-card16)
+	    ;; Update buffer pointers
+	    (data-put 1 chunk)
+	    (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
+	      (length-put 2 (index-ash blen -2))
+	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
+      ;; Normal exit
+      (return-from draw-image-glyphs16
+	(values (if (index= chunk length) nil new-start)
+		(or translated-width width))))))
+
+
+;;-----------------------------------------------------------------------------
+
+(defun display-keycode-range (display)
+  (declare (type display display))
+  (declare (values min max))
+  (values (display-min-keycode display)
+	  (display-max-keycode display)))
+
+;; Should this signal device-busy like the pointer-mapping setf, and return a
+;; boolean instead (true for success)?  Alternatively, should the
+;; pointer-mapping setf be changed to set-pointer-mapping with a (member
+;; :success :busy) result?
+
+(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
+  ;; Setf ought to allow multiple values.
+  (declare (type display display)
+	   (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
+  (declare (values (member :success :busy :failed)))
+  (let* ((keycodes-per-modifier (index-max (length shift)
+					   (length lock)
+					   (length control)
+					   (length mod1)
+					   (length mod2)
+					   (length mod3)
+					   (length mod4)
+					   (length mod5)))
+	 (data (make-array (index* 8 keycodes-per-modifier)
+			   :element-type 'card8
+			   :initial-element 0)))
+    (replace data shift)
+    (replace data lock :start1 keycodes-per-modifier)
+    (replace data control :start1 (index* 2 keycodes-per-modifier))
+    (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
+    (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
+    (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
+    (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
+    (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
+    (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)
+	 ((data keycodes-per-modifier)
+	  ((sequence :format card8) data))
+      (values (member8-get 1 :success :busy :failed)))))
+
+(defun modifier-mapping (display)
+  ;; each value is a list of integers
+  (declare (type display display))
+  (declare (values shift lock control mod1 mod2 mod3 mod4 mod5))
+  (let ((lists nil))
+    (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
+	 ()
+      (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 (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)
diff --git a/clx/translate.lisp b/clx/translate.lisp
new file mode 100644
index 000000000..18434e4ba
--- /dev/null
+++ b/clx/translate.lisp
@@ -0,0 +1,619 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(define-keysym-set
+	  keysym-set
+	  define-keysym
+	  undefine-keysym
+	  default-keysym-translate
+	  keysym
+	  character->keysyms
+	  keycode->keysym 
+	  keysym->character
+	  default-keysym-index
+	  keycode->character
+	  state-keysym-p
+	  mapping-notify
+	  keysym-in-map-p
+	  character-in-map-p
+	  keysym->keycodes
+	  ))
+
+(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
+
+(defun define-keysym-set (set first-keysym last-keysym)
+  ;; Define all keysyms from first-keysym up to and including
+  ;; last-keysym to be in SET (returned from the keysym-set function).
+  ;; Signals an error if the keysym range overlaps an existing set.
+ (declare (type keyword set)
+	  (type keysym first-keysym last-keysym))
+  (when (> first-keysym last-keysym)
+    (rotatef first-keysym last-keysym))
+  (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
+  (dolist (set *keysym-sets*)
+    (let ((first (second set))
+	  (last (third set)))
+      (when (or (<= first first-keysym last)
+		(<= first last-keysym last))
+	(error "Keysym range overlaps existing set ~s" set))))
+  (push (list set first-keysym last-keysym) *keysym-sets*)
+  set)
+
+(defun keysym-set (keysym)
+  ;; Return the character code set name of keysym
+  (declare (type keysym keysym)
+	   (values keyword))
+  (dolist (set *keysym-sets*)
+    (let ((first (second set))
+	  (last (third set)))
+      (when (<= first keysym last)
+	(return (first set))))))
+
+(eval-when (compile eval load) ;; Required for Vaxlisp ...
+(defmacro keysym (keysym &rest bytes)
+  ;; Build a keysym.
+  ;; If KEYSYM is an integer, it is used as the most significant bits of
+  ;; the keysym, and BYTES are used to specify low order bytes. The last
+  ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
+  ;; integer, the keysym associated with KEYSYM is returned.
+  ;;
+  ;; This is a macro and not a function macro to promote compile-time
+  ;; lookup. All arguments are evaluated.
+  (declare (type t keysym)
+	   (type list bytes)
+	   (values keysym))
+  (typecase keysym
+    ((integer 0)
+     (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
+    (otherwise
+     (or (car (character->keysyms keysym))
+	 (error "~s Isn't the name of a keysym" keysym)))))
+)
+
+(defvar *keysym->character-map*
+	(make-hash-table :test (keysym->character-map-test) :size 400))
+
+;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
+;; With the following accessor macros. Everything after OBJECT is optional.
+
+(defmacro keysym-mapping-object (keysym-mapping)
+  ;; Parameter to translate
+  `(first ,keysym-mapping))
+
+(defmacro keysym-mapping-translate (keysym-mapping)
+  ;; Function to be called with parameters (display state OBJECT)
+  ;; when translating KEYSYM and modifiers and mask are satisfied.
+  `(second ,keysym-mapping))
+
+(defmacro keysym-mapping-lowercase (keysym-mapping)
+  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
+  ;; is the associated lowercase keysym.
+  `(third ,keysym-mapping))
+
+(defmacro keysym-mapping-modifiers (keysym-mapping)
+  ;; MODIFIERS is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying when to use this
+  ;; keysym-translation.
+  `(fourth ,keysym-mapping))
+
+(defmacro keysym-mapping-mask (keysym-mapping)
+  ;; MASK is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying which modifiers to look at
+  ;; (i.e.  modifiers not specified are don't-cares)
+  `(fifth ,keysym-mapping))
+
+(defvar *default-keysym-translate-mask*
+	(the (or (member :modifiers) mask16 list)	; (list (or keysym state-mask-key))
+	     (logand #xff (lognot (make-state-mask :lock))))
+  "Default keysym state mask to use during keysym-translation.")
+
+(defun define-keysym (object keysym &key lowercase translate modifiers mask display)	              
+  ;; Define the translation from keysym/modifiers to a (usually
+  ;; character) object.  ANy previous keysym definition with
+  ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
+  ;;
+  ;; MODIFIERS is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying when to use this
+  ;; keysym-translation.  The default is NIL.
+  ;;
+  ;; MASK is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying which modifiers to look at
+  ;; (i.e.  modifiers not specified are don't-cares).
+  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
+  ;; (i.e.  modifiers not specified by modifiers are don't cares)
+  ;; The default mask is *default-keysym-translate-mask*
+  ;;
+  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
+  ;; otherwise it will be the default translation for all displays.
+  ;;
+  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
+  ;; is the associated lowercase keysym.  This information is used
+  ;; by the keysym-both-case-p predicate (for caps-lock computations)
+  ;; and by the keysym-downcase function.
+  ;;
+  ;; TRANSLATE will be called with parameters (display state OBJECT)
+  ;; when translating KEYSYM and modifiers and mask are satisfied.
+  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
+  ;;                     (or modifiers 0)))
+  ;;      when mask and modifiers aren't lists of keysyms]
+  ;; The default is #'default-keysym-translate
+  ;;
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key))
+	         mask)
+	   (type (or null display) display)
+           (type (or null keysym) lowercase)
+	   (type (function (display card16 t) t) translate))
+  (flet ((merge-keysym-mappings (new old)
+	   ;; Merge new keysym-mapping with list of old mappings.
+	   ;; Ensure that the mapping with no modifiers or mask comes first.
+	   (let* ((key (keysym-mapping-modifiers new))
+		  (merge (delete key old :key #'cadddr :test #'equal)))
+	     (if key
+		 (nconc merge (list new))
+	       (cons new merge))))
+	 (mask-check (mask)
+	   (unless (or (numberp mask)
+		       (dolist (element mask t)
+			 (unless (or (find element *state-mask-vector*)
+				     (gethash element *keysym->character-map*))
+			   (return nil))))
+	     (x-type-error mask '(or mask16 (list (or modifier-key modifier-keysym)))))))
+    (let ((entry
+	    ;; Create with a single LIST call, to ensure cdr-coding
+	    (cond
+	      (mask
+	       (unless (eq mask :modifiers)
+		 (mask-check mask))
+	       (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
+		 (error "Mask with no modifiers"))
+	       (list object translate lowercase modifiers mask))
+	      (modifiers (mask-check modifiers)
+			 (list object translate lowercase modifiers))
+	      (lowercase	(list object translate lowercase))
+	      (translate	(list object translate))
+	      (t	(list object)))))
+      (if display
+	  (let ((previous (assoc keysym (display-keysym-translation display))))
+	    (if previous
+		(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
+	      (push (list keysym entry) (display-keysym-translation display))))
+	(setf (gethash keysym *keysym->character-map*)
+	      (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
+    object))
+
+(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
+  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
+  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null display) display))
+  (flet ((match (key entry)
+	   (let ((object (car key))
+		 (modifiers (cdr key)))
+	     (or (eql object (keysym-mapping-object entry))
+		 (equal modifiers (keysym-mapping-modifiers entry))))))
+    (let* (entry
+	   (previous (if display
+			 (cdr (setq entry (assoc keysym (display-keysym-translation display))))
+		       (gethash keysym *keysym->character-map*)))
+	   (key (cons object modifiers)))
+      (when (and previous (find key previous :test #'match))
+	(setq previous (delete key previous :test #'match))
+	(if display
+	    (setf (cdr entry) previous)
+	  (setf (gethash keysym *keysym->character-map*) previous))))))
+
+(defun keysym-downcase (keysym)
+  ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
+  (declare (type keysym keysym))
+  (declare (values keysym))
+  (let ((translations (gethash keysym *keysym->character-map*)))
+    (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
+
+(defun keysym-uppercase-alphabetic-p (keysym)
+  ;; Returns T if keysym is uppercase-alphabetic.
+  ;; I.E. If it has a lowercase equivalent.
+  (declare (type keysym keysym))
+  (declare (values (or null keysym)))
+  (let ((translations (gethash keysym *keysym->character-map*)))
+    (and translations
+	 (keysym-mapping-lowercase (first translations)))))
+
+(defun character->keysyms (character &optional display)
+  ;; Given a character, return a list of all matching keysyms.
+  ;; If DISPLAY is given, translations specific to DISPLAY are used,
+  ;; otherwise only global translations are used.
+  ;; Implementation dependent function.
+  ;; May be slow [i.e. do a linear search over all known keysyms]
+  (declare (type t character)
+	   (type (or null display) display)
+	   (values (list keysym)))
+  (let ((result nil))
+    (when display
+      (dolist (mapping (display-keysym-translation display))
+	(when (eql character (second mapping))
+	  (push (first mapping) result))))
+    (maphash #'(lambda (keysym mappings)
+		 (dolist (mapping mappings)
+		   (when (eql (keysym-mapping-object mapping) character)
+		     (pushnew keysym result))))
+	     *keysym->character-map*)
+    result))
+
+(eval-when (compile eval load) ;; Required for Symbolics...
+(defconstant character-set-switch-keysym (keysym 255 126))
+(defconstant left-shift-keysym (keysym 255 225))
+(defconstant right-shift-keysym (keysym 255 226))
+(defconstant left-control-keysym (keysym 255 227))
+(defconstant right-control-keysym (keysym 255 228))
+(defconstant caps-lock-keysym (keysym 255 229))
+(defconstant shift-lock-keysym (keysym 255 230))
+(defconstant left-meta-keysym (keysym 255 231))
+(defconstant right-meta-keysym (keysym 255 232))
+(defconstant left-alt-keysym (keysym 255 233))
+(defconstant right-alt-keysym (keysym 255 234))
+(defconstant left-super-keysym (keysym 255 235))
+(defconstant right-super-keysym (keysym 255 236))
+(defconstant left-hyper-keysym (keysym 255 237))
+(defconstant right-hyper-keysym (keysym 255 238))
+) ;; end eval-when
+
+
+;;-----------------------------------------------------------------------------
+;; Keysym mapping functions
+
+(defun display-keyboard-mapping (display)
+  (declare (type display display))
+  (declare (values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
+  (or (display-keysym-mapping display)
+      (setf (display-keysym-mapping display) (keyboard-mapping display))))
+
+(defun keycode->keysym (display keycode keysym-index)
+  (declare (type display display)
+	   (type card8 keycode)
+	   (type card8 keysym-index)
+	   (values keysym))
+  (let* ((mapping (display-keyboard-mapping display))
+	 (keysym (aref mapping keycode keysym-index)))
+    (declare (type (simple-array keysym (* *)) mapping)
+	     (type keysym keysym))
+    ;; The keysym-mapping is brain dammaged.
+    ;; Mappings for both-case alphabetic characters have the
+    ;; entry for keysym-index zero set to the uppercase keysym
+    ;; (this is normally where the lowercase keysym goes), and the
+    ;; entry for keysym-index one is zero.
+    (cond ((zerop keysym-index)			; Lowercase alphabetic keysyms
+	   (keysym-downcase keysym))
+	  ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
+	   (aref mapping keycode 0))
+	  (t keysym))))
+
+(defun keysym->character (display keysym &optional (state 0))
+  ;; Find the character associated with a keysym.
+  ;; STATE is used for adding char-bits to character as follows:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type card16 state))
+  (declare (values (or null character)))
+  (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
+	 (mapping (or ;; Find the matching display mapping
+		      (dolist (mapping display-mappings)
+			(when (mapping-matches-p display state mapping)
+			  (return mapping)))
+		      ;; Find the matching static mapping
+		      (dolist (mapping (gethash keysym *keysym->character-map*))
+			(when (mapping-matches-p display state mapping)
+			  (return mapping))))))
+    (when mapping
+      (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
+	       display state (keysym-mapping-object mapping)))))
+
+(defun mapping-matches-p (display state mapping)
+  ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
+  (declare (type display display)
+	   (type mask16 state)
+	   (type list mapping))
+  (declare (values boolean))
+  (flet
+    ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
+       ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
+       ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
+       ;; otherwise ignore unknown modifiers.
+       (declare (type list display-mapping)	; Alist of (keysym . mask)
+		(type (or mask16 list) modifiers)
+		(type mask16 mask))
+       (declare (values (or null mask16)))
+       (if (numberp modifiers)
+	   modifiers
+	 (dolist (modifier modifiers mask)
+	   (declare (type symbol modifier))
+	   (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
+	     (setq mask
+		   (logior mask
+			   (if bit
+			       (ash 1 bit)
+			     (or (cdr (assoc modifier display-mapping))
+				 ;; bad modifier
+				 (if errorp
+				     (return-from modifiers->mask nil)
+				   0))))))))))
+
+    (let* ((display-mapping (get-display-modifier-mapping display))
+	   (mapping-modifiers (keysym-mapping-modifiers mapping))
+	   (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
+			  (return-from mapping-matches-p nil)))
+	   (mapping-mask (or (keysym-mapping-mask mapping)	; If no mask, use the default.
+			     (if mapping-modifiers	        ; If no modifiers, match anything.
+				 *default-keysym-translate-mask*
+			       0)))
+	   (mask (if (eq mapping-mask :modifiers)
+		     modifiers
+		   (modifiers->mask display-mapping mapping-mask nil))))
+      (declare (type mask16 modifiers mask))
+      (= (logand state mask) modifiers))))
+
+(defun default-keysym-translate (display state object)
+  ;; If object is a character, char-bits are set from state.
+  ;;
+  ;; [the following isn't implemented (should it be?)]
+  ;; If object is a list, it is an alist with entries:
+  ;; (string-char [modifiers] [mask-modifiers])
+  ;; When MODIFIERS are specified, this character translation
+  ;; will only take effect when the specified modifiers are pressed.
+  ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
+  ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
+  ;; In ambiguous cases, the most specific translation is used.
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object))
+  (declare (values t)) ;; Object returned by keycode->character
+  (macrolet ((keystate-p (state keyword)
+			 `(the boolean
+			       (logbitp ,(position keyword *state-mask-vector*)
+					,state))))
+    (when (characterp object)
+      (when (keystate-p state :control)
+	(setf (char-bit object :control) 1))
+      (when (state-keysymp display state left-meta-keysym)
+	(setf (char-bit object :meta) 1))
+      (when (state-keysymp display state left-super-keysym)
+	(setf (char-bit object :super) 1))
+      (when (state-keysymp display state left-hyper-keysym)
+	(setf (char-bit object :hyper) 1))))
+  object)
+
+(defun default-keysym-index (display keycode state)
+  ;; Returns a keysym-index for use with keycode->character
+  (declare (values card8))
+  (macrolet ((keystate-p (state keyword)
+	       `(the boolean
+		     (logbitp ,(position keyword *state-mask-vector*)
+			      ,state))))
+    (let* ((mapping (display-keyboard-mapping display))
+	   (keysyms-per-keycode (array-dimension mapping 1))
+	   (symbolp (and (> keysyms-per-keycode 2)
+			 (state-keysymp display state character-set-switch-keysym)))
+	   (result (if symbolp 2 0)))
+      (declare (type (simple-array keysym (* *)) mapping)
+	       (type boolean symbolp)
+	       (type card8 keysyms-per-keycode result))
+      (when (and (< result keysyms-per-keycode)
+		 (keysym-shift-p display state (keysym-uppercase-alphabetic-p
+						 (aref mapping keycode 0))))
+	(incf result))
+      result)))
+
+(defun keysym-shift-p (display state uppercase-alphabetic-p &key
+		       shift-lock-xors
+		       (control-modifiers
+			 '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
+  (declare (type display display)
+	   (type card16 state)
+	   (type boolean uppercase-alphabetic-p)
+	   (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
+	                                  ;;; as neither if the character is alphabetic.
+  (declare (values boolean))
+  (macrolet ((keystate-p (state keyword)
+	       `(the boolean
+		     (logbitp ,(position keyword *state-mask-vector*)
+			      ,state))))
+    (let* ((controlp (or (keystate-p state :control)
+			 (dolist (modifier control-modifiers)
+			   (when (state-keysymp display state modifier)
+			     (return t)))))
+	   (shiftp (keystate-p state :shift))
+	   (lockp  (keystate-p state :lock))
+	   (alphap (or uppercase-alphabetic-p
+		       (not (state-keysymp display #.(make-state-mask :lock)
+					   caps-lock-keysym)))))
+      (declare (type boolean controlp shiftp lockp alphap))
+      ;; Control keys aren't affected by lock
+      (unless controlp
+	;; Not a control character - check state of lock modifier
+	(when (and lockp
+		   alphap
+		   (or (not shiftp) shift-lock-xors))	; Lock doesn't unshift unless shift-lock-xors
+	  (setq shiftp (not shiftp))))
+      shiftp)))
+
+;;; default-keysym-index implements the following tables:
+;;;
+;;; control shift caps-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\8
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\*
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-8
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-*
+;;;
+;;; control shift shift-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\*
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\8
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-*
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-8
+
+(defun keycode->character (display keycode state &key keysym-index
+	                   (keysym-index-function #'default-keysym-index))
+  ;; keysym-index defaults to the result of keysym-index-function which
+  ;; is called with the following parameters:
+  ;; (char0 state caps-lock-p keysyms-per-keycode)
+  ;; where char0 is the "character" object associated with keysym-index 0 and
+  ;; caps-lock-p is non-nil when the keysym associated with the lock
+  ;; modifier is for caps-lock.
+  ;; STATE is also used for setting char-bits:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type card8 keycode)
+	   (type card16 state)
+	   (type (or null card8) keysym-index)
+	   (type (or null (function (string-char card16 boolean card8) card8))
+		 keysym-index-function))
+  (declare (values (or null character)))
+  (let* ((index (or keysym-index
+		    (funcall keysym-index-function display keycode state)))
+	 (keysym (if index (keycode->keysym display keycode index) 0)))
+    (declare (type (or null card8) index)
+	     (type keysym keysym))
+    (when (plusp keysym)
+      (keysym->character display keysym state))))
+
+(defun get-display-modifier-mapping (display)
+  (labels ((keysym-replace (display modifiers mask &aux result)
+	     (dolist (modifier modifiers result)
+	       (push (cons (keycode->keysym display modifier 0) mask) result))))
+    (or (display-modifier-mapping display)
+	(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
+	    (modifier-mapping display)
+	  (setf (display-modifier-mapping display)
+		(nconc (keysym-replace display shift #.(make-state-mask :shift))
+		       (keysym-replace display lock #.(make-state-mask :lock))
+		       (keysym-replace display control #.(make-state-mask :control))
+		       (keysym-replace display mod1 #.(make-state-mask :mod-1))
+		       (keysym-replace display mod2 #.(make-state-mask :mod-2))
+		       (keysym-replace display mod3 #.(make-state-mask :mod-3))
+		       (keysym-replace display mod4 #.(make-state-mask :mod-4))
+		       (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
+
+(defun state-keysymp (display state keysym)
+  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
+  (declare (type display display)
+	   (type card16 state)
+	   (type keysym keysym))
+  (declare (values boolean))
+  (let* ((mapping (get-display-modifier-mapping display))
+	 (mask (assoc keysym mapping)))
+    (and mask (plusp (logand state (cdr mask))))))
+
+(defun mapping-notify (display request start count)
+  ;; Called on a mapping-notify event to update
+  ;; the keyboard-mapping cache in DISPLAY
+  (declare (type display display)
+	   (type (member :modifier :keyboard :pointer) request)
+	   (type card8 start count)
+	   (ignore count start))
+  ;; Invalidate the keyboard mapping to force the next key translation to get it
+  (case request
+    (:modifier 
+     (setf (display-modifier-mapping display) nil))
+    (:keyboard
+     (setf (display-keysym-mapping display) nil))))
+
+(defun keysym-in-map-p (display keysym keymap)
+  ;; Returns T if keysym is found in keymap
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type (bit-vector 256) keymap))
+  (declare (values boolean))
+  ;; The keysym may appear in the keymap more than once,
+  ;; So we have to search the entire keysym map.
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(map (display-keyboard-mapping display))
+	(jmax (min 2 (array-dimension map 1)))
+	(i min (1+ i)))
+      ((> i max))
+    (declare (type card8 min max jmax)
+	     (type (simple-array keysym (* *)) map))
+    (when (and (plusp (aref keymap i))
+	       (dotimes (j jmax)
+		 (when (= keysym (aref map i j)) (return t))))
+      (return t))))
+
+(defun character-in-map-p (display character keymap)
+  ;; Implementation dependent function.
+  ;; Returns T if character is found in keymap
+  (declare (type display display)
+	   (type character character)
+	   (type (bit-vector 256) keymap))
+  (declare (values boolean))
+  ;; Check all one bits in keymap
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(jmax (array-dimension (display-keyboard-mapping display) 1))
+	(i min (1+ i)))
+      ((> i max))
+    (declare (type card8 min max jmax))
+    (when (and (plusp (aref keymap i))
+	       ;; Match when character is in mapping for this keycode
+	       (dotimes (j jmax)
+		 (when (eql character (keycode->character display i 0 :keysym-index j))
+		   (return t))))
+      (return t))))
+
+(defun keysym->keycodes (display keysym)
+  ;; Return keycodes for keysym, as multiple values
+  (declare (type display display)
+	   (type keysym keysym))
+  (declare (values (or null keycode) (or null keycode) (or null keycode)))
+  ;; The keysym may appear in the keymap more than once,
+  ;; So we have to search the entire keysym map.
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(map (display-keyboard-mapping display))
+	(jmax (min 2 (array-dimension map 1)))
+	(i min (1+ i))
+	(result nil))
+      ((> i max) (values-list result))
+    (declare (type card8 min max jmax)
+	     (type (simple-array keysym (* *)) map))
+    (dotimes (j jmax)
+      (when (= keysym (aref map i j))
+	(push i result)))))
-- 
GitLab