From 89a67b6472cd4d2f1d2211b4b3c511f1b137ea25 Mon Sep 17 00:00:00 2001
From: fgilham <fgilham>
Date: Tue, 21 Aug 2007 15:49:30 +0000
Subject: [PATCH] Telent CLX import

---
 clx/CHANGES               |   57 +
 clx/NEWS                  |  165 ++
 clx/README                |  113 ++
 clx/README-CMUCL          |   39 +
 clx/README-R5             |   52 +
 clx/attributes.lisp       |   46 +-
 clx/big-requests.lisp     |   34 +
 clx/buffer.lisp           |  993 +++++-----
 clx/bufmac.lisp           |    4 +-
 clx/build-clx.lisp        |   36 +
 clx/clx-module.lisp       |    9 +
 clx/clx.lisp              |  211 ++-
 clx/cmudep.lisp           |   19 +
 clx/debug/debug.lisp      |    3 +
 clx/debug/describe.lisp   |    5 +-
 clx/debug/event-test.lisp |   11 +-
 clx/debug/keytrans.lisp   |   15 +-
 clx/debug/trace.lisp      |    3 +
 clx/debug/util.lisp       |    8 +-
 clx/defsystem.lisp        |  393 +++-
 clx/demo/README           |   30 +
 clx/demo/bezier.lisp      |    3 +
 clx/demo/beziertest.lisp  |    3 +
 clx/demo/clclock.lisp     |   81 +
 clx/demo/clipboard.lisp   |  203 ++
 clx/demo/clx-demos.lisp   | 1065 +++++++++++
 clx/demo/gl-test.lisp     |  480 +++++
 clx/demo/hello.lisp       |    3 +
 clx/demo/mandel.lisp      |  561 ++++++
 clx/demo/menu.lisp        |    9 +-
 clx/demo/zoid.lisp        |    3 +
 clx/dep-allegro.lisp      | 2213 ++++++++++++++++++++++
 clx/dep-openmcl.lisp      | 1127 +++++++++++
 clx/depdefs.lisp          |  360 +++-
 clx/dependent.lisp        | 3082 ++++++++++++++++++++++++++++---
 clx/display.lisp          |  551 +++---
 clx/dpms.lisp             |  171 ++
 clx/exclMakefile          |  170 ++
 clx/exclREADME            |   58 +
 clx/excldefsys.lisp       |  189 ++
 clx/excldep.c             |   77 +
 clx/excldep.lisp          |  438 +++++
 clx/fonts.lisp            |   26 +-
 clx/gcontext.lisp         |   88 +-
 clx/generalock.lisp       |   75 +
 clx/gl.lisp               | 3695 +++++++++++++++++++++++++++++++++++++
 clx/glx.lisp              |  635 +++++++
 clx/graphics.lisp         |   44 +-
 clx/image.lisp            |  211 ++-
 clx/input.lisp            |  162 +-
 clx/keysyms.lisp          |  278 ++-
 clx/macros.lisp           |  318 ++--
 clx/manager.lisp          |   39 +-
 clx/package.lisp          |  239 ++-
 clx/provide.lisp          |   67 +
 clx/requests.lisp         |  234 +--
 clx/resource.lisp         |   23 +-
 clx/shape.lisp            |  195 ++
 clx/sockcl.lisp           |  166 ++
 clx/socket.c              |  155 ++
 clx/test/README           |    9 +
 clx/text.lisp             |  159 +-
 clx/translate.lisp        |   88 +-
 clx/xrender.lisp          | 1131 ++++++++++++
 clx/xvidmode.lisp         |  733 ++++++++
 65 files changed, 19989 insertions(+), 1874 deletions(-)
 create mode 100644 clx/CHANGES
 create mode 100644 clx/NEWS
 create mode 100644 clx/README
 create mode 100644 clx/README-CMUCL
 create mode 100644 clx/README-R5
 create mode 100644 clx/big-requests.lisp
 create mode 100644 clx/build-clx.lisp
 create mode 100644 clx/clx-module.lisp
 create mode 100644 clx/cmudep.lisp
 create mode 100644 clx/demo/README
 create mode 100644 clx/demo/clclock.lisp
 create mode 100644 clx/demo/clipboard.lisp
 create mode 100644 clx/demo/clx-demos.lisp
 create mode 100644 clx/demo/gl-test.lisp
 create mode 100644 clx/demo/mandel.lisp
 create mode 100644 clx/dep-allegro.lisp
 create mode 100644 clx/dep-openmcl.lisp
 create mode 100644 clx/dpms.lisp
 create mode 100644 clx/exclMakefile
 create mode 100644 clx/exclREADME
 create mode 100644 clx/excldefsys.lisp
 create mode 100644 clx/excldep.c
 create mode 100644 clx/excldep.lisp
 create mode 100644 clx/generalock.lisp
 create mode 100644 clx/gl.lisp
 create mode 100644 clx/glx.lisp
 create mode 100644 clx/provide.lisp
 create mode 100644 clx/shape.lisp
 create mode 100644 clx/sockcl.lisp
 create mode 100644 clx/socket.c
 create mode 100644 clx/test/README
 create mode 100644 clx/xrender.lisp
 create mode 100644 clx/xvidmode.lisp

diff --git a/clx/CHANGES b/clx/CHANGES
new file mode 100644
index 000000000..f666fdff8
--- /dev/null
+++ b/clx/CHANGES
@@ -0,0 +1,57 @@
+$Id: CHANGES,v 1.6 2007/08/21 15:49:27 fgilham Exp $
+
+Details of changes since R5:
+
+NOTE: this file is not updated any more.  Changes since checking into
+version control can be found from darcs in some way shape or form.
+There may however be some Dark Ages between when this file was last
+updated and the version that was the initial version control checkin.
+
+
+Changes in CLX 5.02:
+
+Replace LCL:ENVIRONMENT-VALUE with LCL:ENVIRONMENT-VARIABLE.
+
+Fix a declaration in the DEFINE-ERROR macro.
+
+Quote type argument to TYPE-CHECK consistently.
+
+
+Changes in CLX 5.01:
+
+Support for MIT-MAGIC-COOKIE-1 authorization has been added.
+
+All VALUES declarations have been changed to CLX-VALUES declarations.
+VALUES is a CL type name and cannot be used as a declaration name.
+
+All ARRAY-REGISTER declarations have been removed as Genera no longer
+needs them.
+
+Many type declarations have been corrected or tightened up now that some
+Lisps look at them.
+
+Print functions have been defined for bitmap and pixmap formats.
+
+The DISPLAY-PLIST slot will be initialized to NIL.
+
+When debugging, don't optimize SPEED in the buffer macros.
+
+Make the CARD8<->CHAR and the window manager code work for sparse
+character sets (where some codes do not have corresponding characters).
+
+The default gcontext extension set and copy functions will take the
+correct number of arguments.
+
+PUT-IMAGE will now work for 24-bit images.
+
+The buffer accessors for MEMBER8, etc., will use the standard mechanisms
+for reporting type errors.
+
+Typographical errors in SET-WM-PROPERTIES, SET-STANDARD-COLORMAP, and
+POINTER-CONTROL have been fixed.
+
+Symbolics systems will do lazy macroexpansion in the buffer macros.
+
+A variety of changes for Symbolics Minima systems have been made.
+
+Some system-dependent code has been added for CMU Common Lisp.
diff --git a/clx/NEWS b/clx/NEWS
new file mode 100644
index 000000000..8c2358f37
--- /dev/null
+++ b/clx/NEWS
@@ -0,0 +1,165 @@
+-*- Text -*-
+$Id: NEWS,v 1.1 2007/08/21 15:49:27 fgilham Exp $
+-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 ---
+
+Support for Allegro CL (6.2 and later) (Mikel Evins)
+Latin 1 keysyms (Christophe Rhodes)
+Some protocol fixes (Douglas Crosher)
+Define a RENDER-OP typ (Douglas Crosher)
+
+---  Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 ---
+
+OpenMCL fixes
+DPMS extension support
+Xauthority ipv6 parsing fixes
+
+Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes
+
+---  Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 ---
+
+Works in SBCL 0.9.2 and newer.
+
+---  Changes in SBCL CLX 0.7.0, Sun May 1 2005 ---
+
+The SBCL support now depends on version 0.9.0 or greater.
+
+---  Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 ---
+
+experimental GLX extension support (from Janis Dzerins)
+
+The ICCCM-compliant selection handling in demo/clipboard.lisp is now
+more ICCCM-compliant.
+
+The implementation of the RENDER client protocol has been
+enhanced. (Gilbert Baumann)
+
+Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input
+event descriptions have been fixed.
+
+---  Changes in SBCL CLX 0.6, Tue Nov 16 2004  ---
+
+A port to ECL has been merged (Juan Jose Garcia Ripoll)
+
+With the addition of an implementation of DYNAMIC-EXTENT &REST lists
+to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX
+should cons less.
+
+A Texinfo version of the CLX manual has been added (in manual/), thanks
+to the work of Gilbert Baumann and Shawn Betts.  
+
+The portable-clx mailing list has been created for development discussion
+and bug reports.  See 
+http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
+
+A demonstration of ICCCM-compliant selection handling for select and paste
+has been included in demo/clipboard.lisp
+
+Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32
+bits wide, as per the ICCCM specifications. Fixes a problem seen with
+the MacOS X11 window manger, that uses very large hint values.
+(Patch from Eric Marsden)
+
+Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of
+keywords.  It wasn't, but it is now. (Milan Zamazal)
+
+Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS*
+(Milan again)
+
+---  Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003   ---
+
+A change in the implementation of PROCESS-BLOCK and PROCESS-WAKEUP
+under multithreaded SBCL.  Previous versions used queues and condition
+variables, but this seems to have undesireable performance
+characteristics; the newer version uses a polling loop calling
+sched_yield() inside, which greatly improves responsiveness, but is
+more CPU-hungry (as perceived by top(1), at least; in theory it
+only hogs the CPU when nobody else wants it).
+
+
+---  Changes in SBCL CLX 0.5.3, Sat Sep  6 12:14:39 UTC 2003 ---
+
+We allow a PIXMAP-DEPTH of 12 in clx.lisp, despite not having any
+image routines for it, to allow clx to load when running under eXceed.
+Image routines are unlikely to work in such circumstances.
+
+Bug fixes
+
+ * ERROR idiom (xvidmode.lisp)
+ * Add timestamp in NEWS file
+
+---  Changes in SBCL CLX 0.5.2, about twenty minutes before 0.5.3  ---
+
+OPEN-DEFAULT-DISPLAY now takes an optional argument for the display
+name, which has the same "protocol/host:display.screen" format as used
+by the C libX11 (XOpenDisplay).  OPEN-DISPLAY is not actively
+deprecated, but is much less useful by comparison
+
+Inclusion of two new tests/demos (from Ingvar Mattson):
+ * demo/clclock: a simple clock application;
+ * demo/mandel: a Mandelbrot set viewer.
+
+Bug fixes
+
+ * Fix bad type declarations in TEXT-EXTENTS-SERVER and
+   TEXT-WIDTH-SERVER (text.lisp)
+ * Fix FORMAT argument mismatch error in WRITE-BITMAP-FILE (image.lisp)
+
+---  Changes in SBCL CLX 0.5.1, Wed Jun 25 14:20:31 BST 2003  ---
+
+experimental RENDER extension support (from Gilbert Baumann)
+  note: the API to this is as yet unfinalized, as indeed the protocol
+        and specification appear to be in flux.  Nevertheless,
+        feedback is welcome to the portable-clx-devel mailing list.
+
+Bug fixes
+
+ * fix bugs in the image test: always draw glyphs in white on black
+   (not 1 on 0 -- i.e. dark red/blue on black in 24 bit truecolour);
+   don't abuse the X-HOT and Y-HOT slots for communicating persistent
+   information any more.  
+
+ * Disable the "optimized" pixarray read/write routines, on the basis
+   that the newly fixed image test reveals that they are broken.
+
+ * fix type bugs in DEFINE-GCONTEXT-ACCESSOR, which previously
+   signalled a type error if :COPY-FUNCTION was not provided, and a
+   different type error if it was.
+
+Other notes
+
+ * we use the SBCL extensions to the condition system to customize
+   compiler behaviour.  As such, the system will only build without
+   breaking into the debugger using the supplied .asd, as we inhibit
+   error signalling from DEFCONSTANT; the benefits of this are easier
+   code sharing, as we minimize divergence within the clx source
+   proper from other implementations.
+
+ * we also use an SBCL extension to maximize efficiency: we set
+   SB-EXT:*DERIVE-FUNCTION-TYPES* to true for the duration of the
+   compilation of the clx library.  Should functions in CLX be
+   redefined in a type-incompatible way, their callers in CLX (but not
+   outside) will need to be recompiled.
+
+---  Changes in SBCL CLX 0.5, Fri May 30 01:16:34 BST 2003  ---
+
+XFree86-VidModeExtension extension support (courtesy of Iban Hatchondo)
+
+OPEN-DEFAULT-DISPLAY (opens display in $DISPLAY environment variable) exported
+
+Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc
+
+Many bug fixes
+
+ * asking for text extents on unchached fonts could potentially deadlock
+   http://article.gmane.org/gmane.lisp.clx.devel/16
+
+ * lots of compiler warnings, style-warnings, notes cleared up
+
+
+Style and ANSI cleanups
+
+ * Much renaming of constants from *foo* to +foo+
+
+ *  Change old-style COMPILE LOAD EVAL to new-style :COMPILE-TOPLEVEL
+     :LOAD-TOPLEVEL :EXECUTE in EVAL-WHENs.
+
diff --git a/clx/README b/clx/README
new file mode 100644
index 000000000..08ac72b4a
--- /dev/null
+++ b/clx/README
@@ -0,0 +1,113 @@
+$Id: README,v 1.4 2007/08/21 15:49:27 fgilham Exp $
+This directory contains CLX, an X11 client library for Common
+Lisp. The code was originally taken from a CMUCL distribution, was
+modified somewhat in order to make it compile and run under SBCL, then
+a selection of patches were added from other CLXes around the net.
+
+= Features
+
+ - SHAPE extension support (Gilbert Baumann)
+ - XFREE86-VIDMODE extension support (Iban Hatchondo)
+ - experimental RENDER extension support 
+     (Gilbert Baumann and Christian Sunesson)
+ - X authority support that works with ssh forwarding (Eric Marsden via CMUCL)
+ - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan)
+ - various bug fixes (Iban Hatchondo and a cast of several)
+ - a manual in texinfo format (Shawn Betts, Gilbert Baumann)
+
+= Compatibility
+
+This CLX distribution is intended to work under the latest released
+version of SBCL - please report the bug if it doesn't.  It should
+usually also work with earlier versions back to 0.9.0, and possibly
+earlier still, but may need manual adjustment to the clx.asd file (to
+remove use of newly-introduced features).
+
+It has also been used as a basis for CLX ports on other Lisp 
+implementations, but these instructions are only good for SBCL.  If
+you're running something else, you need to know (a) that it builds
+with asdf (and asdf-install, if the planets are in alignment) and
+(b) what asdf is anyway.  http://www.weitz.de/asdf-install/ might help
+you there.  If you've installed this using some non-SBCL Lisp, please
+send mail describing the process so that future versions can incorporate
+your instructions.
+
+If you are following SBCL CVS and this CLX does not run in it, please
+check the darcs repositor{y,ies} for this CLX distribution to see if
+your bug has been fixed already.
+
+darcs get http://verisons.telent.net/clx # version from which releases are made
+          http://common-lisp.net/~crhodes/clx # patches merged by Christophe
+          http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor?
+
+= Building using asdf-install
+
+* (require 'asdf)
+* (require 'asdf-install)
+* (asdf-install:install 'clx) ; download and install automatically, or
+* (asdf-install:install "clx-x.y.z.tar.gz") ; if you've downloaded already
+
+= Building by hand
+
+If you don't trust asdf-install, here's how to do it manually -
+
+1. Untar this tree somewhere
+
+2. Add a symlink to clx.asd from one of the directories listed in your
+   asdf:*central-registry*
+
+   If that makes no sense to you yet, choose one of -
+
+   2a. personal installation:
+
+     $ cd $HOME/.sbcl/systems # you may have to create this directory
+     $ ln -s /path/to/clx/source/clx.asd .
+
+   2b. systemwide installations: you need to ask SBCL where it lives
+
+     $ sbcl --noinform --eval '(format t "~A~%" (posix-getenv "SBCL_HOME"))' </dev/null
+     /usr/local/lib/sbcl/
+     * 
+     $ cd /usr/local/lib/sbcl/site-systems
+     $ ln -s /path/to/clx/source/clx.asd .
+
+3. 
+   * (require 'asdf)
+   * (require 'clx)
+
+This will load all the files, after compiling anything that needs compiling
+
+4. To test CLX (and get a small amount of Lisp advocacy), try loading
+the file "demo/menu", and then executing the function
+xlib::just-say-lisp.
+
+   * (load "clx/demo/menu")
+   * (xlib::just-say-lisp)
+
+5. If you're new to Lisp, be advised that despite the examples in
+demo/, it's generally /not/ considered good style to switch to the
+:xlib package and write your code in it.  Spend some time with a
+language reference to familiarize yourself with USE-PACKAGE, or 
+better yet, the USE option to DEFPACKAGE.
+
+
+= Known problems:
+
+(none reported)
+
+ 
+= Bug reports, new features, patches
+
+Please send bug reports to the portable-clx list:
+
+http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
+
+Note that your post will be held for approval if you are not subscribed.
+
+
+-dan
+
+-- 
+Heavy lifting by <Raymond.Wiker at fast.no>
+ASDFized version and ongoing by Daniel Barlow <dan at metacircles.com> 
+and (mostly, these days) Christophe Rhodes <csr21 at cam.ac.uk>
diff --git a/clx/README-CMUCL b/clx/README-CMUCL
new file mode 100644
index 000000000..b3baed054
--- /dev/null
+++ b/clx/README-CMUCL
@@ -0,0 +1,39 @@
+$Id: README-CMUCL,v 1.1 2007/08/21 15:49:27 fgilham Exp $
+
+This is an import of Telent-CLX as of 0.7.3.
+
+All files are included.  A few changes to fix bugs related to CMUCL have been added, as well as
+the CVS id.  I've tried to make few changes so it will be easy to merge again when desired.
+
+The following files from this directory are compiled and loaded by CMUCL when it builds
+utilities:
+
+clx-library.lisp
+package.lisp
+depdefs.lisp
+clx.lisp
+dependent.lisp
+macros.lisp
+bufmac.lisp
+buffer.lisp
+display.lisp
+gcontext.lisp
+input.lisp
+requests.lisp
+fonts.lisp
+graphics.lisp
+text.lisp
+attributes.lisp
+translate.lisp
+keysyms.lisp
+manager.lisp
+image.lisp
+resource.lisp
+shape.lisp
+big-requests.lisp
+xvidmode.lisp
+xrender.lisp
+glx.lisp
+gl.lisp
+dpms.lisp
+provide.lisp
diff --git a/clx/README-R5 b/clx/README-R5
new file mode 100644
index 000000000..d6e7b895f
--- /dev/null
+++ b/clx/README-R5
@@ -0,0 +1,52 @@
+$Id: README-R5,v 1.1 2007/08/21 15:49:27 fgilham Exp $
+Original CLX README, retained for historical information
+
+--- 
+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 (compile-clx) function and loaded with the
+(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 (compile-clx) function and loaded with the (load-clx) form.
+
+
+
+For more information, see defsystem.l and provide.l.
+
diff --git a/clx/attributes.lisp b/clx/attributes.lisp
index 0b3b67229..ae0420139 100644
--- a/clx/attributes.lisp
+++ b/clx/attributes.lisp
@@ -17,9 +17,6 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/attributes.lisp,v 1.6 1999/03/16 23:37:36 pw Exp $")
 
 ;;;	The special variable *window-attributes* is an alist containg:
 ;;;	(drawable attributes attribute-changes geometry geometry-changes)
@@ -43,12 +40,15 @@
 ;;;	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.
 
+#+cmu
+(ext:file-comment "$Id: attributes.lisp,v 1.7 2007/08/21 15:49:27 fgilham Exp $")
+
 (in-package :xlib)
 
-(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))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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
 
@@ -57,7 +57,7 @@
 
 (defun allocate-context ()
   (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
-      (make-reply-buffer *context-size*)))
+      (make-reply-buffer +context-size+)))
 
 (defun deallocate-context (context)
   (declare (type reply-buffer context))
@@ -69,12 +69,12 @@
 (defmacro state-geometry-changes (state) `(fifth ,state))
  
 (defmacro drawable-equal-function ()
-  (if (member 'drawable *clx-cached-types*)
+  (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*)
+  (if (member 'window +clx-cached-types+)
       ''eq
     ''drawable-equal))
 
@@ -158,7 +158,7 @@
 	  (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*)
+      (with-buffer-request ((window-display window) +x-changewindowattributes+)
 	(window window)
 	(card32 (ash 1 number) value)))))
 ;;
@@ -185,7 +185,7 @@
 	  (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*)
+      (with-buffer-request ((drawable-display drawable) +x-configurewindow+)
 	(drawable drawable)
 	(card16 (ash 1 number))
 	(card29 value)))))
@@ -207,7 +207,7 @@
 	      (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))
+	    (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))
@@ -237,7 +237,7 @@
 	      (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))
+	    (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))
@@ -255,7 +255,7 @@
 	 (mask (aref changes 0)))
     (declare (type display display)
 	     (type mask32 mask))
-    (with-buffer-request (display *x-changewindowattributes*)
+    (with-buffer-request (display +x-changewindowattributes+)
       (window window)
       (card32 mask)
       (progn ;; Insert a word in the request for each one bit in the mask
@@ -282,7 +282,7 @@
 	 (mask (aref changes 0)))
     (declare (type display display)
 	     (type mask16 mask))
-    (with-buffer-request (display *x-configurewindow*)
+    (with-buffer-request (display +x-configurewindow+)
       (window window)
       (card16 mask)
       (progn ;; Insert a word in the request for each one bit in the mask
@@ -352,6 +352,8 @@
 	(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)
@@ -365,6 +367,8 @@
 	(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)
@@ -372,11 +376,11 @@
   (declare (type window window))
   (declare (clx-values bit-gravity))
   (with-attributes (window :sizes 8)
-    (member8-vector-get 14 *bit-gravity-vector*)))
+    (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))
+    window 4 (encode-type (member-vector +bit-gravity-vector+) gravity))
   gravity)
 
 (defsetf window-bit-gravity set-window-bit-gravity)
@@ -386,11 +390,11 @@
   (declare (type window window))
   (declare (clx-values win-gravity))
   (with-attributes (window :sizes 8)
-    (member8-vector-get 15 *win-gravity-vector*)))
+    (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))
+    window 5 (encode-type (member-vector +win-gravity-vector+) gravity))
   gravity)
 
 (defsetf window-gravity set-window-gravity)
@@ -630,6 +634,8 @@
       (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/big-requests.lisp b/clx/big-requests.lisp
new file mode 100644
index 000000000..882691e6a
--- /dev/null
+++ b/clx/big-requests.lisp
@@ -0,0 +1,34 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;;
+;;; (c) copyright 2006 Richard Kreuter
+;;; (c) copyright 2007 by Christophe Rhodes
+;;;
+;;; 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.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+#+cmu
+(ext:file-comment "$Id: big-requests.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $")
+
+(in-package "XLIB")
+
+;;; No new events or errors are defined by this extension.  (Big
+;;; Requests Extension, section 3)
+;;;
+;;; The name of this extension is "BIG-REQUESTS" (Big Requests
+;;; Extension, section 4)
+(define-extension "BIG-REQUESTS")
+
+(defun enable-big-requests (display)
+  (declare (type display display))
+  (let ((opcode (extension-opcode display "BIG-REQUESTS")))
+    (with-buffer-request-and-reply (display opcode nil)
+	((data 0))
+      (let ((maximum-request-length (card32-get 8)))
+	(setf (display-extended-max-request-length display) 
+	      maximum-request-length)))))
diff --git a/clx/buffer.lisp b/clx/buffer.lisp
index 8a3d38cf5..f79f2b5cb 100644
--- a/clx/buffer.lisp
+++ b/clx/buffer.lisp
@@ -18,9 +18,6 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/buffer.lisp,v 1.8 1999/03/16 23:37:36 pw Exp $")
 
 ;; A few notes:
 ;;
@@ -52,9 +49,12 @@
 ;;     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).
 
+#+cmu
+(ext:file-comment "$Id: buffer.lisp,v 1.9 2007/08/21 15:49:27 fgilham Exp $")
+
 (in-package :xlib)
 
-(defconstant *requestsize* 160) ;; Max request size (excluding variable length requests)
+(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.
@@ -71,6 +71,7 @@
 		   ,@body)))
      ,(if (and (null inline) (macroexpand '(use-closures) env))
 	  `(flet ((.with-buffer-body. () ,@body))
+	     #+clx-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))
@@ -89,7 +90,13 @@
   (declare (type display buffer)
 	   (type (or null number) timeout)
 	   (type function function)
-	   (dynamic-extent function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent function)
+	   ;; FIXME: This is probably more a bug in SBCL (logged as
+	   ;; bug #243)
+	   (ignorable timeout)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg function))
   (with-buffer (buffer :timeout timeout :inline t)
     (funcall function)))
 
@@ -103,18 +110,33 @@
   `(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)
@@ -143,10 +165,43 @@
      ,(declare-bufmac)
      ,@(and display '(%buffer))
      (let* ((buffer-boffset (the array-index ,(or index 0)))
-	    (buffer-bbuf (reply-ibuf8 %reply-buffer)))
-       (declare (type array-index buffer-boffset)
-		(type buffer-bytes buffer-bbuf)
-		(ignorable buffer-boffset buffer-bbuf))
+	    #-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))
+       #+clx-overlapping-arrays
+       ,@(append
+	   (when (member 8 sizes)
+	     '((declare (type buffer-bytes buffer-bbuf))))
+	   (when (member 16 sizes)
+	     '((declare (type array-index buffer-woffset))
+	       (declare (type buffer-words buffer-wbuf))))
+	   (when (member 32 sizes)
+	     '((declare (type array-index buffer-loffset))
+	       (declare (type buffer-longs 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)))
+       #+clx-overlapping-arrays
+       (macrolet ((%buffer-sizes () ',sizes))
+	 ,@body)
+       #-clx-overlapping-arrays
        ,@body)))
 
 (defun make-buffer (output-size constructor &rest options)
@@ -157,6 +212,18 @@
     (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)
@@ -165,7 +232,19 @@
 				:initial-element 0)))
     (make-reply-buffer-internal
       :size size
-      :ibuf8 byte-input)))
+      :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)
@@ -176,7 +255,16 @@
       (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)))))
+	(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)
@@ -200,7 +288,10 @@
   (declare (type display display)
 	   (type (or null gcontext) gc-force))
   (declare (type function request-function)
-	   (dynamic-extent request-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent request-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg request-function))
   (with-buffer (display :inline t)
     (multiple-value-prog1
       (progn
@@ -212,7 +303,10 @@
   (declare (type display display)
 	   (type (or null gcontext) gc-force))
   (declare (type function request-function)
-	   (dynamic-extent request-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent request-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg request-function))
   (multiple-value-prog1
     (progn
       (when gc-force (force-gcontext-changes-internal gc-force))
@@ -223,14 +317,17 @@
   (sequence 0 :type card16)
   (reply-buffer nil :type (or null reply-buffer))
   (process nil)
-  (next nil :type (or null pending-command)))
+  (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 generalized-boolean multiple-reply))
   (declare (type function request-function reply-function)
-	   (dynamic-extent request-function reply-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent request-function reply-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg request-function reply-function))
   (let ((pending-command nil)
 	(reply-buffer nil))
     (declare (type (or null pending-command) pending-command)
@@ -392,56 +489,60 @@
 
 ;;; 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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((card8->char->transform (v)
-	       (declare (type card8 v))
-	       (funcall transform (card8->char v))))
-	(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)))
+(defmacro define-transformed-sequence-reader (name totype transformer reader)
+  (let ((ntrans (gensym)))
+    `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
+      (declare 
+       (type reply-buffer reply-buffer)
+       (type t result-type)
+       (type array-index nitems start index)
+       (type (or null sequence) data)
+       (type (or null (function (,totype) t)) transform)
+       #+clx-ansi-common-lisp (dynamic-extent transform)
+       #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+      (if transform
+	  (flet ((,ntrans (v) (funcall transform (,transformer v))))
+	    #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
+	    (,reader reply-buffer result-type nitems #',ntrans data start index))
+	  (,reader reply-buffer result-type nitems #',transformer data start index)))))
 
-;;; Reading sequences of card8's
+(define-transformed-sequence-reader read-sequence-char character 
+  card8->char read-sequence-card8)
 
-(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)
-	       (list 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)
-	   (dynamic-extent 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)
-	       (list lst))
-      (setf (car lst) (funcall transform (read-card8 index))))))
+;;; Reading sequences of card8's
 
+(defmacro define-list-readers ((name tname) type size step reader)
+  `(progn 
+    (defun ,name (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 (,size) :index index)
+	(do* ((j nitems (index- j 1))
+	      (list (nthcdr start data) (cdr list))
+	      (index 0 (index+ index ,step)))
+	     ((index-zerop j))
+	  (declare (type array-index index j) (type list list))
+	  (setf (car list) (,reader index)))))
+    (defun ,tname (reply-buffer nitems data transform start index)
+      (declare (type reply-buffer reply-buffer)
+	       (type array-index nitems start index)
+	       (type list data)
+	       (type (function (,type) t) transform)
+	       #+clx-ansi-common-lisp (dynamic-extent transform)
+	       #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+      (with-buffer-input (reply-buffer :sizes (,size) :index index)
+	(do* ((j nitems (index- j 1))
+	      (list (nthcdr start data) (cdr list))
+	      (index 0 (index+ index ,step)))
+	     ((index-zerop j))
+	  (declare (type array-index index j) (type list list))
+	  (setf (car list) (funcall transform (,reader index))))))))
+
+(define-list-readers (read-list-card8 read-list-card8-with-transform) card8
+  8 1 read-card8)
+
+#-lispm
 (defun read-simple-array-card8 (reply-buffer nitems data start index)
   (declare (type reply-buffer reply-buffer)
 	   (type array-index nitems start index)
@@ -450,12 +551,16 @@
     (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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card8 (*)))
     (with-buffer-input (reply-buffer :sizes (8) :index index)
       (do* ((j start (index+ j 1))
@@ -485,7 +590,10 @@
 	   (type vector data)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (card8) t) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (with-buffer-input (reply-buffer :sizes (8) :index index)
       (do* ((j start (index+ j 1))
@@ -495,105 +603,74 @@
 	(declare (type array-index j end 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)
-	   (dynamic-extent 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)))
-      ((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))
+(defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec))
+  `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
+    (declare
+     (type reply-buffer reply-buffer)
+     (type t result-type)
+     (type array-index nitems start index)
+     (type (or null sequence) data)
+     (type (or null (function (,type) t)) transform)
+     #+clx-ansi-common-lisp (dynamic-extent transform)
+     #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+    (let ((result (or data (make-sequence result-type nitems))))
+      (typecase result
+	(list
+	 (if transform
+	     (,tlist reply-buffer nitems result transform start index)
+	     (,list reply-buffer nitems result start index)))
+	#-lispm
+	((simple-array ,type (*))
+	 (if transform
+	     (,tsa reply-buffer nitems result transform start index)
+	     (,sa reply-buffer nitems result start index)))
+	;; FIXME: general sequences
+	(t 
+	 (if transform
+	     (,tvec reply-buffer nitems result transform start index)
+	     (,vec reply-buffer nitems result start index))))
+      result)))
 
-;;; For now, perhaps performance it isn't worth doing better?
+(define-sequence-reader read-sequence-card8 card8 
+  (read-list-card8 read-list-card8-with-transform)
+  (read-simple-array-card8 read-simple-array-card8-with-transform)
+  (read-vector-card8 read-vector-card8-with-transform))
 
-(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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((card8->int8->transform (v)
-	       (declare (type card8 v))
-	       (funcall transform (card8->int8 v))))
-	(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)))
+(define-transformed-sequence-reader read-sequence-int8 int8
+  card8->int8 read-sequence-card8)
 
 ;;; 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)
-	       (list 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)
-	   (dynamic-extent 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)
-	       (list lst))
-      (setf (car lst) (funcall transform (read-card16 index))))))
-
+(define-list-readers (read-list-card16 read-list-card16-with-transform) card16
+  16 2 read-card16)
 
+#-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 end index))
-	(setf (aref data j) (the card16 (read-card16 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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card16 (*)))
     (with-buffer-input (reply-buffer :sizes (16) :index index)
       (do* ((j start (index+ j 1))
@@ -610,12 +687,15 @@
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (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 end index))
-	(setf (aref data j) (read-card16 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)
@@ -623,7 +703,10 @@
 	   (type vector data)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (card16) t) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (with-buffer-input (reply-buffer :sizes (16) :index index)
       (do* ((j start (index+ j 1))
@@ -633,103 +716,46 @@
 	(declare (type array-index j end 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)
-	   (dynamic-extent 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)))
-      ((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?
+(define-sequence-reader read-sequence-card16 card16
+  (read-list-card16 read-list-card16-with-transform)
+  (read-simple-array-card16 read-simple-array-card16-with-transform)
+  (read-vector-card16 read-vector-card16-with-transform))
 
-(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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((card16->int16->transform (v)
-	       (declare (type card16 v))
-	       (funcall transform (card16->int16 v))))
-	(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)))
+(define-transformed-sequence-reader read-sequence-int16 int16
+  card16->int16 read-sequence-card16)
 
 ;;; 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)
-	       (list 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)
-	   (dynamic-extent 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)
-	       (list lst))
-      (setf (car lst) (funcall transform (read-card32 index))))))
+(define-list-readers (read-list-card32 read-list-card32-with-transform) card32
+  32 4 read-card32)
 
+#-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 end index))
-	(setf (aref data j) (the card32 (read-card32 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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card32 (*)))
     (with-buffer-input (reply-buffer :sizes (32) :index index)
       (do* ((j start (index+ j 1))
@@ -746,12 +772,15 @@
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (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 end index))
-	(setf (aref data j) (read-card32 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)
@@ -759,7 +788,10 @@
 	   (type vector data)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (card32) t) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (with-buffer-input (reply-buffer :sizes (32) :index index)
       (do* ((j start (index+ j 1))
@@ -769,101 +801,90 @@
 	(declare (type array-index j end 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)
-	   (dynamic-extent 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)))
-      ((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))
+(define-sequence-reader read-sequence-card32 card32
+  (read-list-card32 read-list-card32-with-transform)
+  (read-simple-array-card32 read-simple-array-card32-with-transform)
+  (read-vector-card32 read-vector-card32-with-transform))
 
-;;; 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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((card32->int32->transform (v)
-	       (declare (type card32 v))
-	       (funcall transform (card32->int32 v))))
-	(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)))
+(define-transformed-sequence-reader read-sequence-int32 int32 
+  card32->int32 read-sequence-card32)
 
 ;;; 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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((transform->char->card8 (x)
-	       (char->card8 (the character (funcall transform x)))))
-	(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)))
+(defmacro define-transformed-sequence-writer (name fromtype transformer writer)
+  (let ((ntrans (gensym)))
+    `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
+      (declare 
+       (type buffer buffer)
+       (type sequence data)
+       (type array-index boffset start end)
+       (type (or null (function (t) ,fromtype)) transform)
+       #+clx-ansi-common-lisp (dynamic-extent transform)
+       #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+      (if transform
+	  (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x)))))
+	    #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
+	    (,writer buffer boffset data start end #',ntrans))
+	  (,writer buffer boffset data start end #',transformer)))))
+
+(define-transformed-sequence-writer write-sequence-char character 
+  char->card8 write-sequence-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))
-      (write-card8 j (pop lst))
-      ))
-  nil)
+(defmacro define-list-writers ((name tname) type step writer)
+  `(progn
+    (defun ,name (buffer boffset data start end)
+      (declare 
+       (type buffer buffer)
+       (type list data)
+       (type array-index boffset start end))
+      (writing-buffer-chunks ,type
+	  ((list (nthcdr start data)))
+	  ((type list list))
+	(do ((j 0 (index+ j ,step)))
+	    ((index>= j chunk))
+	  (declare (type array-index j))
+	  (,writer j (pop list)))))
+    (defun ,tname (buffer boffset data start end transform)
+      (declare 
+       (type buffer buffer)
+       (type list data)
+       (type array-index boffset start end)
+       (type (function (t) ,type) transform)
+       #+clx-ansi-common-lisp (dynamic-extent transform)
+       #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+      (writing-buffer-chunks ,type
+	  ((list (nthcdr start data)))
+	  ((type list list))
+	(do ((j 0 (index+ j ,step)))
+	    ((index>= j chunk))
+	  (declare (type array-index j))
+	  (,writer j (funcall transform (pop list))))))))
+
+;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8
+#+ti
+(progn
+  (defun write-list-card8 (buffer boffset data start end)
+    (writing-buffer-chunks card8
+	((list (nthcdr start data)))
+	((type list list))
+      (dotimes (j chunk)
+	(setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list)))))
+  (defun write-list-card8-with-transform (buffer boffset data start end transform)
+    (writing-buffer-chunks card8
+	((list (nthcdr start data)))
+	((type list lst))
+      (dotimes (j chunk)
+	(declare (type array-index j))
+	(write-card8 j (funcall transform (pop lst)))))))
 
-(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)
-	   (dynamic-extent 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)
+#-ti
+(define-list-writers (write-list-card8 write-list-card8-with-transform) card8
+  1 write-card8)
 
 ;;; 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)
@@ -878,12 +899,16 @@
 		      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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card8 (*)))
     (writing-buffer-chunks card8
 			   ((index start))
@@ -914,7 +939,10 @@
 	   (type vector data)
 	   (type array-index boffset start end))
   (declare (type (function (t) card8) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (writing-buffer-chunks card8
 			   ((index start))
@@ -925,76 +953,44 @@
 	(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)
-	   (dynamic-extent 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)))
-    ((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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((transform->int8->card8 (x)
-	       (int8->card8 (the int8 (funcall transform x)))))
-	(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)))
+(defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec))
+  `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
+    (declare
+     (type buffer buffer)
+     (type sequence data)
+     (type array-index boffset start end)
+     (type (or null (function (t) ,type)) transform)
+     #+clx-ansi-common-lisp (dynamic-extent transform)
+     #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
+    (typecase data
+      (list
+       (if transform
+	   (,tlist buffer boffset data start end transform)
+	   (,list buffer boffset data start end)))
+      #-lispm
+      ((simple-array ,type (*))
+       (if transform
+	   (,tsa buffer boffset data start end transform)
+	   (,sa buffer boffset data start end)))
+      (t ; FIXME: general sequences
+       (if transform
+	   (,tvec buffer boffset data start end transform)
+	   (,vec buffer boffset data start end))))))
+
+(define-sequence-writer write-sequence-card8 card8
+  (write-list-card8 write-list-card8-with-transform)
+  (write-simple-array-card8 write-simple-array-card8-with-transform)
+  (write-vector-card8 write-vector-card8-with-transform))
+
+(define-transformed-sequence-writer write-sequence-int8 int8 
+  int8->card8 write-sequence-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)
-	   (dynamic-extent 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)
+(define-list-writers (write-list-card16 write-list-card16-with-transform) card16
+  2 write-card16)
 
+#-lispm
 (defun write-simple-array-card16 (buffer boffset data start end)
   (declare (type buffer buffer)
 	   (type (simple-array card16 (*)) data)
@@ -1018,12 +1014,16 @@
 	(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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card16 (*)))
     (writing-buffer-chunks card16
 			   ((index start))
@@ -1066,7 +1066,10 @@
 	   (type array-index boffset start end)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (t) card16) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (writing-buffer-chunks card16
 			   ((index start))
@@ -1079,59 +1082,17 @@
 	(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)
-	   (dynamic-extent 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)))
-    ((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)))))
+(define-sequence-writer write-sequence-card16 card16
+  (write-list-card16 write-list-card16-with-transform)
+  (write-simple-array-card16 write-simple-array-card16-with-transform)
+  (write-vector-card16 write-vector-card16-with-transform))
 
 ;;; 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)
-	   (dynamic-extent 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)
+(define-list-writers (write-list-int16 write-list-int16-with-transform) int16
+  2 write-int16)
 
+#-lispm
 (defun write-simple-array-int16 (buffer boffset data start end)
   (declare (type buffer buffer)
 	   (type (simple-array int16 (*)) data)
@@ -1155,12 +1116,16 @@
 	(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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array int16 (*)))
     (writing-buffer-chunks int16
 			   ((index start))
@@ -1203,7 +1168,10 @@
 	   (type array-index boffset start end)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (t) int16) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (writing-buffer-chunks int16
 			   ((index start))
@@ -1216,59 +1184,17 @@
 	(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)
-	   (dynamic-extent 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)))
-    ((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)))))
+(define-sequence-writer write-sequence-int16 int16
+  (write-list-int16 write-list-int16-with-transform)
+  (write-simple-array-int16 write-simple-array-int16-with-transform)
+  (write-vector-int16 write-vector-int16-with-transform))
 
 ;;; 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)
-	   (dynamic-extent 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)
+(define-list-writers (write-list-card32 write-list-card32-with-transform) card32
+  4 write-card32)
 
+#-lispm
 (defun write-simple-array-card32 (buffer boffset data start end)
   (declare (type buffer buffer)
 	   (type (simple-array card32 (*)) data)
@@ -1292,12 +1218,16 @@
 	(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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card32 (*)))
     (writing-buffer-chunks card32
 			   ((index start))
@@ -1340,7 +1270,10 @@
 	   (type array-index boffset start end)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (t) card32) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (writing-buffer-chunks card32
 			   ((index start))
@@ -1353,43 +1286,13 @@
 	(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)
-	   (dynamic-extent 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)))
-    ((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?
+(define-sequence-writer write-sequence-card32 card32
+  (write-list-card32 write-list-card32-with-transform)
+  (write-simple-array-card32 write-simple-array-card32-with-transform)
+  (write-vector-card32 write-vector-card32-with-transform))
 
-(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)
-	   (dynamic-extent transform))
-  (if transform 
-      (flet ((transform->int32->card32 (x)
-	       (int32->card32 (the int32 (funcall transform x)))))
-	(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)))
+(define-transformed-sequence-writer write-sequence-int32 int32 
+  int32->card32 write-sequence-card32)
 
 (defun read-bitvector256 (buffer-bbuf boffset data)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1434,34 +1337,10 @@
 
 ;;; Writing sequences of char2b's
 
-(defun write-list-char2b (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))
-    (do ((j 0 (index+ j 2)))
-	((index>= j (1- chunk)) (setf chunk j))
-      (declare (type array-index j))
-      (write-char2b j (pop lst))))
-  nil)
-
-(defun write-list-char2b-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)
-	   (dynamic-extent transform))
-  (writing-buffer-chunks card16
-			 ((lst (nthcdr start data)))
-			 ((type list lst))
-    (do ((j 0 (index+ j 2)))
-	((index>= j (1- chunk)) (setf chunk j))
-      (declare (type array-index j))
-      (write-char2b j (funcall transform (pop lst)))))
-  nil)
+(define-list-writers (write-list-char2b write-list-char2b-with-transform) card16
+  2 write-char2b)
 
+#-lispm
 (defun write-simple-array-char2b (buffer boffset data start end)
   (declare (type buffer buffer)
 	   (type (simple-array card16 (*)) data)
@@ -1477,12 +1356,16 @@
 	(setq index (index+ index 1)))))
   nil)
 
+#-lispm
 (defun write-simple-array-char2b-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)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data (simple-array card16 (*)))
     (writing-buffer-chunks card16
 			   ((index start))
@@ -1516,7 +1399,10 @@
 	   (type array-index boffset start end)
 	   (optimize #+cmu(ext:inhibit-warnings 3)))
   (declare (type (function (t) card16) transform)
-	   (dynamic-extent transform))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent transform)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg transform))
   (with-vector (data vector)
     (writing-buffer-chunks card16
 			   ((index start))
@@ -1528,24 +1414,7 @@
 	(setq index (index+ index 1)))))
   nil)
 
-(defun write-sequence-char2b
-       (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)
-	   (dynamic-extent transform))
-  (typecase data
-    (list
-      (if transform
-	  (write-list-char2b-with-transform buffer boffset data start end transform)
-	  (write-list-char2b buffer boffset data start end)))
-    ((simple-array card16 (*))
-     (if transform
-	 (write-simple-array-char2b-with-transform buffer boffset data start end transform)
-	 (write-simple-array-char2b buffer boffset data start end)))
-    (t
-      (if transform
-	  (write-vector-char2b-with-transform buffer boffset data start end transform)
-	  (write-vector-char2b buffer boffset data start end)))))
-
+(define-sequence-writer write-sequence-char2b card16
+  (write-list-char2b write-list-char2b-with-transform)
+  (write-simple-array-char2b write-simple-array-char2b-with-transform)
+  (write-vector-char2b write-vector-char2b-with-transform))
diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp
index 65a659888..471fe8ebe 100644
--- a/clx/bufmac.lisp
+++ b/clx/bufmac.lisp
@@ -18,9 +18,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/bufmac.lisp,v 1.4 1998/12/19 15:21:15 dtc Exp $")
+(ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $")
 
 (in-package :xlib)
 
diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp
new file mode 100644
index 000000000..a280963f9
--- /dev/null
+++ b/clx/build-clx.lisp
@@ -0,0 +1,36 @@
+;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
+
+#+cmu
+(ext:file-comment "$Id: build-clx.lisp,v 1.4 2007/08/21 15:49:27 fgilham Exp $")
+
+;;; Load this file if you want to compile CLX in its entirety.
+(proclaim '(optimize (speed 3) (safety 1) (space 1)
+		     (compilation-speed 0)))
+
+
+;;; Hide CLOS from CLX, so objects stay implemented as structures.
+;;;
+#||
+(when (find-package "CLOS")
+  (rename-package (find-package "CLOS") "NO-CLOS-HERE"))
+(when (find-package "PCL")
+  (rename-package (find-package "PCL") "NO-PCL-HERE"))
+(when (find-package "SB-PCL")
+  (rename-package (find-package "SB-PCL") "NO-SB-PCL-HERE"))
+||#
+
+(when (find-package "XLIB")
+  (delete-package "XLIB"))
+
+(unless (find-package "XLIB")
+  (make-package "XLIB" :use '("COMMON-LISP")))
+
+#-sbcl
+(compile-file "clx:defsystem.lisp" :error-file nil :load t)
+
+#+sbcl
+(progn (compile-file "clx:defsystem.lisp")
+       (load "clx:defsystem"))
+
+(with-compilation-unit ()
+  (#+cmu xlib:compile-clx #-cmu compile-clx (pathname "CLX:")))
diff --git a/clx/clx-module.lisp b/clx/clx-module.lisp
new file mode 100644
index 000000000..da96ee216
--- /dev/null
+++ b/clx/clx-module.lisp
@@ -0,0 +1,9 @@
+;;;(in-package :xlib)
+;;;(common-lisp:use-package (list :common-lisp))
+
+#+cmu
+(ext:file-comment "$Id: clx-module.lisp,v 1.1 2007/08/21 15:49:27 fgilham Exp $")
+
+(provide :clx)
+(load "clx:defsystem.lisp")
+(load-clx (translate-logical-pathname "CLX:"))
diff --git a/clx/clx.lisp b/clx/clx.lisp
index d256aa03b..3cde49313 100644
--- a/clx/clx.lisp
+++ b/clx/clx.lisp
@@ -15,9 +15,6 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/clx.lisp,v 1.14 2003/08/08 07:35:56 emarsden Exp $")
 
 ;; Primary Interface Author:
 ;;	Robert W. Scheifler
@@ -79,6 +76,9 @@
 ;;; 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.
 
+#+cmu
+(ext:file-comment "$Id: clx.lisp,v 1.15 2007/08/21 15:49:27 fgilham Exp $")
+
 ;; Note: all of the following is in the package XLIB.
 
 (in-package :xlib)
@@ -86,12 +86,10 @@
 (pushnew :clx *features*)
 (pushnew :xlib *features*)
 
-(defparameter *version* "MIT R5.02")
+(defparameter *version* "Telent CLX 0.7.3 + CMUCL mods, based on MIT R5.02")
 (pushnew :clx-mit-r4 *features*)
 (pushnew :clx-mit-r5 *features*)
 
-(provide :clx)
-
 (defparameter *protocol-major-version* 11.)
 (defparameter *protocol-minor-version* 0)
 
@@ -164,6 +162,20 @@
 
 (deftype card4 () '(unsigned-byte 4))
 
+#-clx-ansi-common-lisp
+(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)))))
+
+#-clx-ansi-common-lisp
+(deftype base-char ()
+  'string-char)
+
 ; Note that we are explicitly using a different rgb representation than what
 ; is actually transmitted in the protocol.
 
@@ -334,12 +346,14 @@
   (atom-id-map (make-hash-table :test (resource-id-map-test)
 				:size *atom-cache-size*)
 	       :type hash-table)
+  (extended-max-request-length 0 :type card32)
   )
 
 (defun print-display-name (display stream)
   (declare (type (or null display) display))
   (cond (display
-	 (princ (display-host display) stream)
+	 #-allegro (princ (display-host display) stream)
+	 #+allegro (write-string (string (display-host display)) stream)
 	 (write-string ":" stream)
 	 (princ (display-display display) stream))
 	(t
@@ -371,7 +385,7 @@
   (print-unreadable-object (drawable stream :type t)
     (print-display-name (drawable-display drawable) stream)
     (write-string " " stream)
-    (prin1 (drawable-id drawable) stream)))
+    (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream))))
 
 (def-clx-class (window (:include drawable) (:copier nil)
 		       (:print-function print-drawable))
@@ -441,27 +455,27 @@
 
 (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))
+(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))
 
@@ -471,19 +485,31 @@
 
 (deftype timestamp () '(or null card32))
 
-(defconstant *bit-gravity-vector*
-	     '#(:forget :north-west :north :north-east :west
-		:center :east :south-west :south
-		:south-east :static))
+(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))
+(defconstant +win-gravity-vector+
+ '#(:unmap :north-west :north :north-east :west
+    :center :east :south-west :south :south-east
+    :static))
+
+(defparameter *protocol-families*
+  '(;; X11/X.h, Family*
+    (:internet . 0)
+    (:decnet . 1)
+    (:chaos . 2)
+    ;; X11/Xauth.h "not part of X standard"
+    (:Local . 256)
+    (:Wild . 65535)
+    (:Netname . 254)
+    (:Krb5Principal . 253)
+    (:LocalHost . 252)))
 
 (deftype win-gravity ()
   '(member :unmap :north-west :north :north-east :west
@@ -527,7 +553,7 @@
   (server-state (allocate-gcontext-state) :type gcontext-state)
   (local-state (allocate-gcontext-state) :type gcontext-state)
   (plist nil :type list)			; Extension hook
-  (next nil :type (or null gcontext))
+  (next nil #-explorer :type #-explorer (or null gcontext))
   )
 
 (defun print-gcontext (gcontext stream depth)
@@ -538,13 +564,13 @@
     (write-string " " 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))
+(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
@@ -557,11 +583,14 @@
 (deftype event-mask ()
   '(or mask32 (clx-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))
+(defconstant +pointer-event-mask-vector+
+  ;; the first two elements used to be '%error '%error (i.e. symbols, 
+  ;; and not keywords) but the vector is supposed to contain 
+  ;; keywords, so I renamed them -dan 2004.11.13
+  '#(:%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
@@ -572,10 +601,10 @@
 (deftype pointer-event-mask ()
   '(or mask32 (clx-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))
+(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
@@ -585,9 +614,9 @@
 (deftype device-event-mask ()
   '(or mask32 (clx-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))
+(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))
@@ -598,12 +627,12 @@
 (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))
+(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
@@ -613,14 +642,16 @@
 	   :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))
+  '(or (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)
+       (satisfies extension-event-key-p)))
 
 (deftype error-key ()
   '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
@@ -629,11 +660,11 @@
 (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))
+(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
@@ -802,7 +833,7 @@
 	     (let ((predicate (xintern type '-equal))
 		   (id (xintern type '-id))
 		   (dpy (xintern type '-display)))
-	       (if (member type *clx-cached-types*)
+	       (if (member type +clx-cached-types+)
 		   `(within-definition (,type make-mumble-equal)
 		      (declaim (inline ,predicate))
 		      (defun ,predicate (a b) (eq a b)))
@@ -824,10 +855,10 @@
 ;;;    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.
+  ;; 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 (clx-values (or mask32 null)))
@@ -858,7 +889,7 @@
 (defun encode-event-mask (event-mask)
   (declare (type event-mask event-mask))
   (declare (clx-values mask32))
-  (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
+  (or (encode-mask +event-mask-vector+ event-mask 'event-mask-class)
       (x-type-error event-mask 'event-mask)))
 
 (defun make-event-mask (&rest keys)
@@ -866,18 +897,18 @@
   ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
   (declare (type (clx-list event-mask-class) keys))
   (declare (clx-values mask32))
-  (encode-mask *event-mask-vector* keys 'event-mask-class))
+  (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 (clx-values (clx-list event-mask-class)))
-  (decode-mask *event-mask-vector* event-mask))
+  (decode-mask +event-mask-vector+ event-mask))
 
 (defun encode-device-event-mask (device-event-mask)
   (declare (type device-event-mask device-event-mask))
   (declare (clx-values mask32))
-  (or (encode-mask *device-event-mask-vector* device-event-mask
+  (or (encode-mask +device-event-mask-vector+ device-event-mask
 		   'device-event-mask-class)
       (x-type-error device-event-mask 'device-event-mask)))
 
@@ -885,29 +916,29 @@
   (declare (type modifier-mask modifier-mask))
   (declare (clx-values mask16))
   (or (and (eq modifier-mask :any) #x8000)
-      (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
+      (encode-mask +state-mask-vector+ modifier-mask 'modifier-key)
       (x-type-error modifier-mask 'modifier-mask)))
 
 (defun encode-state-mask (state-mask)
   (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
   (declare (clx-values mask16))
-  (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
+  (or (encode-mask +state-mask-vector+ state-mask 'state-mask-key)
       (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
 
 (defun make-state-mask (&rest keys)
   ;; Useful for constructing modifier-mask, state-mask.
   (declare (type (clx-list state-mask-key) keys))
   (declare (clx-values mask16))
-  (encode-mask *state-mask-vector* keys 'state-mask-key))
+  (encode-mask +state-mask-vector+ keys 'state-mask-key))
 
 (defun make-state-keys (state-mask)
   (declare (type mask16 state-mask))
   (declare (clx-values (clx-list state-mask-key)))
-  (decode-mask *state-mask-vector* state-mask))
+  (decode-mask +state-mask-vector+ state-mask))
 
 (defun encode-pointer-event-mask (pointer-event-mask)
   (declare (type pointer-event-mask pointer-event-mask))
   (declare (clx-values mask32))
-  (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
+  (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/cmudep.lisp b/clx/cmudep.lisp
new file mode 100644
index 000000000..24a9a837b
--- /dev/null
+++ b/clx/cmudep.lisp
@@ -0,0 +1,19 @@
+;;; -*- Package: XLIB -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/cmudep.lisp,v 1.3 2007/08/21 15:49:27 fgilham Rel $")
+;;;
+;;; **********************************************************************
+;;;
+(in-package "XLIB")
+
+(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
+			 c-call:int
+  (host c-call:c-string)
+  (port c-call:int))
diff --git a/clx/debug/debug.lisp b/clx/debug/debug.lisp
index 69f3dd636..82e4e38c5 100644
--- a/clx/debug/debug.lisp
+++ b/clx/debug/debug.lisp
@@ -20,6 +20,9 @@
 
 ;;; Created 04/09/87 14:30:41 by LaMott G. OREN
 
+#+cmu
+(ext:file-comment "$Id: debug.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (export '(display-listen
diff --git a/clx/debug/describe.lisp b/clx/debug/describe.lisp
index 00371fc95..404786f99 100644
--- a/clx/debug/describe.lisp
+++ b/clx/debug/describe.lisp
@@ -20,6 +20,9 @@
 
 ;;; Created 07/15/87 by LaMott G. OREN
 
+#cmu
+(ext:file-comment "$Id: describe.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (defparameter *request-parameters* (make-array (length *request-names*)))
@@ -76,7 +79,7 @@
 		(string8
 		 (format t " Bytes:~%~v@t" margin)
 		 (dotimes (k (- length (- j start)))
-		   (format t "~a" (int-char (card8-get j)))
+		   (format t "~a" (code-char (card8-get j)))
 		   (incf j)))
 		(otherwise
 		 (format t " Bytes:~%~v@t" margin)
diff --git a/clx/debug/event-test.lisp b/clx/debug/event-test.lisp
index 5ded127ab..8d6320873 100644
--- a/clx/debug/event-test.lisp
+++ b/clx/debug/event-test.lisp
@@ -1,6 +1,15 @@
 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*-
 
-(in-package :xtest :use '(:xlib :lisp))
+;;; This code was intended for CLUE.  --FMG
+
+#+cmu
+(ext:file-comment "$Id: event-test.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage "XTEST"
+  (:use :xlib :common-lisp)
+  )
+
+(in-package "XTEST")
 
 (defstruct event
   key					   ; Event key
diff --git a/clx/debug/keytrans.lisp b/clx/debug/keytrans.lisp
index 333c1efa7..44db61c76 100644
--- a/clx/debug/keytrans.lisp
+++ b/clx/debug/keytrans.lisp
@@ -18,20 +18,23 @@
 ;;; express or implied warranty.
 ;;;
 
+#+cmu
+(ext:file-comment "$Id: keytrans.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (defun list-missing-keysyms ()
   ;; Lists explorer characters which have no keysyms
   (dotimes (i 256)
-    (unless (character->keysyms (int-char i))
-      (format t "~%(define-keysym ~@c ~d)" (int-char i) i))))
+    (unless (character->keysyms (code-char i))
+      (format t "~%(define-keysym ~@c ~d)" (code-char i) i))))
 
 (defun list-multiple-keysyms ()
   ;; Lists characters with more than one keysym
   (dotimes (i 256)
-    (when (cdr (character->keysyms (int-char i)))
-      (format t "~%Character ~@c [~d] has keysyms" (int-char i) i)
-      (dolist (keysym (character->keysyms (int-char i)))
+    (when (cdr (character->keysyms (code-char i)))
+      (format t "~%Character ~@c [~d] has keysyms" (code-char i) i)
+      (dolist (keysym (character->keysyms (code-char i)))
 	(format t "  ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
 
 (defun check-lowercase-keysyms ()
@@ -52,7 +55,7 @@
 				 char
 				 (and lowercase (ldb (byte 8 8) lowercase))
 				 (and lowercase (ldb (byte 8 0) lowercase))
-				 (int-char lowercase)
+				 (code-char lowercase)
 				 (ldb (byte 8 8) (char-int should-be))
 				 (ldb (byte 8 0) (char-int should-be))
 				 should-be)))
diff --git a/clx/debug/trace.lisp b/clx/debug/trace.lisp
index 276e2f56b..364a3f0f9 100644
--- a/clx/debug/trace.lisp
+++ b/clx/debug/trace.lisp
@@ -32,6 +32,9 @@
 
 ;;; Created 09/14/87 by LaMott G. OREN
 
+#+cmu
+(ext:file-comment "$Id: trace.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (eval-when (load eval)
diff --git a/clx/debug/util.lisp b/clx/debug/util.lisp
index 7db6be640..471be6d4e 100644
--- a/clx/debug/util.lisp
+++ b/clx/debug/util.lisp
@@ -20,6 +20,9 @@
 
 ;;; Created 04/09/87 14:30:41 by LaMott G. OREN
 
+#+cmu
+(ext:file-comment "$Id: util.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (export '(display-root
@@ -145,12 +148,13 @@
   ;; Returns a list of windows in the order that they are printed.
   (declare (arglist window)
 	   (type window window)
-	   (values (list window)))
+	   (clx-values (list window)))
   (let ((props (mapcar #'(lambda (prop)
 			   (multiple-value-bind (data type format)
 			       (get-property window prop)
 			     (case type
-			       (:string (setq data (coerce data 'string))))
+			       (:string (setq data (map 'string #'code-char data)))
+			       (:utf8_string (setq data (map 'string #'code-char data))))
 			     (list prop format type data)))
 		       (list-properties window)))
 	(result (list window)))
diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp
index 82fb9e52c..ce67e3f5c 100644
--- a/clx/defsystem.lisp
+++ b/clx/defsystem.lisp
@@ -18,19 +18,275 @@
 ;;;
 ;;; Franz Incorporated provides this software "as is" without express or
 ;;; implied warranty.
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/defsystem.lisp,v 1.7 2003/07/20 15:55:23 emarsden Exp $")
 
 ;;; #+ features used in this file
+;;;   clx-ansi-common-lisp
+;;;   lispm
+;;;   genera
+;;;   minima
+;;;   lucid
+;;;   lcl3.0
+;;;   apollo
+;;;   kcl
+;;;   ibcl
+;;;   excl
 ;;;   CMU
+;;;   sbcl
+
+#+cmu
+(ext:file-comment "$Id: defsystem.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
+
+#+(or Genera Minima sbcl ecl)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*))
+
+#+(and Genera clx-ansi-common-lisp)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* si:*ansi-common-lisp-readtable*))
 
-(cl:in-package "XLIB")
+#-(or clx-ansi-common-lisp cmu)
+(lisp:in-package :user)
+
+#+cmu
+(lisp:in-package "XLIB")
+#+cmu 
 (export 'load-clx)
 
+#+clx-ansi-common-lisp
 (common-lisp:in-package :common-lisp-user)
 
 
+;;;; Lisp Machines
+
+#+(and lispm (not genera))
+(global:defsystem CLX
+  (:pathname-default "clx:clx;")
+  (:patchable "clx:patch;" clx-ti)
+  (:initial-status :experimental)
+
+  (:module package "package")
+  (: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 package)
+  (:compile-load depdefs
+   (:fasload package))
+  (:compile-load clx
+   (:fasload package depdefs))
+  (:compile-load dependent
+   (:fasload package depdefs clx))
+  ;; Macros only needed for compilation
+  (:skip :compile-load macros
+   (:fasload package depdefs clx dependent))
+  ;; Bufmac only needed for compilation
+  (:skip :compile-load bufmac
+   (:fasload package depdefs clx dependent macros))
+  (:compile-load buffer
+   (:fasload package depdefs clx dependent macros bufmac))
+  (:compile-load display
+   (:fasload package depdefs clx dependent macros bufmac buffer))
+  (:compile-load gcontext
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load input
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load requests
+   (:fasload package depdefs clx dependent macros bufmac buffer display input))
+  (:compile-load fonts
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load graphics
+   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
+	     fonts))
+  (:compile-load text
+   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
+	     gcontext fonts))
+  (:compile-load-init attributes
+   (dependent)
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load translate
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load keysyms
+   (:fasload package depdefs clx dependent macros bufmac buffer display
+	     translate))
+  (:compile-load manager
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load image
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:compile-load resource
+   (:fasload package depdefs clx dependent macros bufmac buffer display))
+  (:auxiliary doc)
+  )
+
+
+;;; Symbolics Lisp Machines
+#+Genera
+(scl:defsystem CLX
+    (:default-pathname "SYS:X11;CLX;"
+     :pretty-name "CLX"
+     :maintaining-sites (:scrc)
+     :distribute-sources t
+     :distribute-binaries t
+     :source-category :basic)
+  (:module doc ("doc")
+	   (:type :lisp-example))
+  (:serial
+    "package" "depdefs" "generalock" "clx" "dependent" "macros" "bufmac"
+    "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
+    "text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
+
+#+Minima
+(zl:::scl:defsystem Minima-CLX
+    (:default-pathname "SYS:X11;CLX;"
+     :pretty-name "Minima CLX"
+     :maintain-journals nil
+     :maintaining-sites (:scrc)
+     :distribute-sources t
+     :distribute-binaries t
+     :source-category :basic
+     :default-module-type :minima-lisp)
+  (:module doc ("doc")
+	   (:type :lisp-example))
+  (:serial
+    "package" "depdefs" "clx" "dependent" "macros" "bufmac"
+    "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
+    "text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
+
+
+;;; Franz
+
+;;
+;; 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.
+;;
+#+excl
+(setq compiler::generate-interrupt-checks-switch
+      (compile nil
+	       '(lambda (safety size speed &optional debug)
+		  (declare (ignore size debug))
+		  (or (< speed 3) (> safety 0)))))
+
+
+;;; Allegro
+
+#+allegro
+(excl:defsystem :clx 
+  ()
+  |package|
+  (|excldep|
+    :load-before-compile (|package|)
+    :recompile-on (|package|))
+  (|depdefs|
+    :load-before-compile (|package| |excldep|)
+    :recompile-on (|excldep|))
+  (|clx|
+    :load-before-compile (|package| |excldep| |depdefs|)
+    :recompile-on (|package| |excldep| |depdefs|))
+  (|dependent|
+    :load-before-compile (|package| |excldep| |depdefs| |clx|)
+    :recompile-on (|clx|))
+  (|exclcmac|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|)
+    :recompile-on (|dependent|))
+  (|macros|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac|)
+    :recompile-on (|exclcmac|))
+  (|bufmac|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros|)
+    :recompile-on (|macros|))
+  (|buffer|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac|)
+    :recompile-on (|bufmac|))
+  (|display|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer|)
+    :recompile-on (|buffer|))
+  (|gcontext|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|)
+    :recompile-on (|display|))
+  (|input|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|)
+    :recompile-on (|display|))
+  (|requests|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|
+			  |input|)
+    :recompile-on (|display|))
+  (|fonts|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|)
+    :recompile-on (|display|))
+  (|graphics|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|
+			  |fonts|)
+    :recompile-on (|fonts|))
+  (|text|
+    :load-before-compile (|package| |excldep| |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 (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|)
+    :recompile-on (|display|))
+  (|translate|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|
+			  |text|)
+    :recompile-on (|display|))
+  (|keysyms|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|
+			  |translate|)
+    :recompile-on (|translate|))
+  (|manager|
+    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
+			  |exclcmac| |macros| |bufmac| |buffer| |display|)
+    :recompile-on (|display|))
+  (|image|
+    :load-before-compile (|package| |excldep| |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 (|package| |excldep| |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|)
 
 
 ;;;; Compile CLX
@@ -54,6 +310,54 @@
 ;;; 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/hp9000s300
+;;;     must uudecode the file make-sequence-patch.uu
+
+#+(or lucid kcl ibcl cmu)
+(defun clx-foreign-files (binary-path)
+
+  #+(and lucid (not lcl3.0) (or mc68000 mc68020))
+  (load (merge-pathnames "make-sequence-patch" binary-path))
+
+  #+(and lucid apollo)
+  (lucid::load-foreign-file
+    (namestring (merge-pathnames "socket" binary-path))
+    :preserve-pathname t)
+
+  #+(and lucid (not apollo))
+  (lucid::load-foreign-files
+    (list (namestring (merge-pathnames "socket.o" binary-path)))
+    '("-lc"))
+
+  #+cmu
+  (declare (ignore binary-path))
+  #+(or cmu sbcl)
+  (alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
+			   c-call:int
+    (host c-call:c-string)
+    (port c-call:int))
+
+  #+(or kcl ibcl)
+  (progn
+    (let ((pathname (merge-pathnames "sockcl.o" binary-path))
+	  (options
+	    (concatenate
+	      'string
+	      (namestring (merge-pathnames "socket.o" binary-path))
+	      " -lc")))
+      (format t "~&Faslinking ~A with ~A.~%" pathname options)
+      (si:faslink (namestring pathname) options)
+      (format t "~&Finished faslinking ~A.~%" pathname)))
+  )
+
+#-(or lispm allegro Minima)
 (defun compile-clx (&optional
 		    (source-pathname-defaults "")
 		    (binary-pathname-defaults "")
@@ -74,6 +378,7 @@
 			:version   (pathname-version   source-path)))
 	 (binary-path (merge-pathnames binary-pathname-defaults
 				       path))
+	 #+clx-ansi-common-lisp (*compile-verbose* t)
 	 (*load-verbose* t))
 				       
     ;; Make sure source-path and binary-path file types are distinct so
@@ -87,28 +392,76 @@
 
     (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
+      (unless (member :pqc *features*)
+	(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))))
+
     (labels ((compile-lisp (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))
 		 binary))
 	     (compile-and-load (filename)
-	       (load (compile-lisp filename))))
+	       (load (compile-lisp filename)))
+	     #+(or lucid kcl ibcl)
+	     (compile-c (filename)
+	       (let* ((c-filename (concatenate 'string filename ".c"))
+		      (o-filename (concatenate 'string filename ".o"))
+		      (src (merge-pathnames c-filename source-path))
+		      (obj  (merge-pathnames o-filename binary-path))
+		      (args (list "-c" (namestring src)
+				  "-o" (namestring obj)
+				  #+mips "-G 0"
+				  #+(or hp sysv) "-DSYSV"
+				  #+(and mips (not dec)) "-I/usr/include/bsd"
+				  #-(and mips (not dec)) "-DUNIXCONN"
+				  #+(and lucid pa) "-DHPUX -DHPUX7.0"
+				  )))
+		 (format t ";;; cc~{ ~A~}~%" args)
+		 (unless
+		   (zerop 
+		     #+lucid
+		     (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))
+		       exitstatus)
+		     #+(or kcl ibcl)
+		     (system (format nil "cc~{ ~A~}" args)))
+		   (error "Compile of ~A failed." src)))))
 
       ;; Now compile and load all the files.
       ;; Defer compiler warnings until everything's compiled, if possible.
-      (with-compilation-unit
+      (#+(or clx-ansi-common-lisp CMU) with-compilation-unit
+       #+lcl3.0 lucid::with-deferred-warnings
+       #-(or lcl3.0 clx-ansi-common-lisp CMU) progn
        ()
        
        (compile-and-load "package")
+       #+(or lucid kcl ibcl) (when compile-c (compile-c "socket"))
+       #+(or kcl ibcl) (compile-lisp "sockcl")
+       #+(or lucid kcl ibcl) (clx-foreign-files binary-path)
+       #+excl (compile-and-load "excldep")
        (compile-and-load "depdefs")
        (compile-and-load "clx")
        (compile-and-load "dependent")
+       #+excl (compile-and-load "exclcmac")	; these are just macros
        (compile-and-load "macros")		; these are just macros
        (compile-and-load "bufmac")		; these are just macros
        (compile-and-load "buffer")
@@ -147,6 +500,7 @@
 ;;;		(LOAD <clx-defsystem-file>)
 ;;;		(LOAD-CLX <binary-specific-clx-directory>)
 
+#-(or lispm allegro Minima)
 (defun load-clx (&optional (binary-pathname-defaults "")
 		 &key (macrosp nil))
 
@@ -167,10 +521,13 @@
 	       (load binary))))
 
       (load-binary "package")
+      #+(or lucid kcl ibcl cmu) (clx-foreign-files binary-path)
+      #+excl (load-binary "excldep")
       (load-binary "depdefs")
       (load-binary "clx")
       (load-binary "dependent")
       (when macrosp
+	#+excl (load-binary "exclcmac")
 	(load-binary "macros")
 	(load-binary "bufmac"))
       (load-binary "buffer")
@@ -188,3 +545,27 @@
       (load-binary "image")
       (load-binary "resource")
       )))
+
+;;;
+;;; ECL likes to combine several files into a single dynamically loadable
+;;; library.
+;;;
+#+ecl
+(defconstant +clx-modules+
+  '("package" "depdefs" "clx" "dependent" "macros" "bufmac" "buffer"
+    "display" "gcontext" "input" "requests" "fonts" "graphics" "text"
+    "attributes" "translate" "keysyms" "manager" "image" "resource"))
+
+#+(or) ;ecl
+(flet ((compile-if-old (destdir sources &rest options)
+	 (mapcar #'(lambda (source)
+		     (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object))))
+		       (unless (and (probe-file object)
+				    (>= (file-write-date object) (file-write-date source)))
+			 (apply #'compile-file source :output-file object options))
+		       object))
+		 sources)))
+  (let ((clx-objects (compile-if-old "./" +clx-modules+ :system-p t)))
+    (c::build-fasl "clx" :lisp-files clx-objects)))
+
+(mapcar #'load +clx-modules+)
diff --git a/clx/demo/README b/clx/demo/README
new file mode 100644
index 000000000..d67dd3cb7
--- /dev/null
+++ b/clx/demo/README
@@ -0,0 +1,30 @@
+$Id: README,v 1.1 2007/08/21 15:49:29 fgilham Rel $
+
+A brief description of the files in this directory, as best I (FMG) can figure.
+
+bezier.lisp: An example of how to define an extension.  As far as I know, there's no bezier
+extension in most X servers, so this won't do much.
+
+beziertest.lisp: An example of how to invoke the bezier extension.
+
+Both the above files are obsolete.
+
+clclock.lisp: Display a clock using Roman numerals.  Works.
+
+clipboard.lisp: Shows how to manage cut-and-paste (the X clipboard).  Works.
+
+clx-demos.lisp: Some old graphics demos.  Works.  Many of them have been updated in the cmucl
+src/contrib/demos directory.
+
+gl-test.lisp: A test and demonstration of the GL interface.  Seems to mostly work on my system.
+
+hello.lisp: A hello-world X program that gives a kind of skeleton for X programs.  Works.
+
+mandel.lisp: A Mandelbrot set generator that I couldn't get to work, even by hacking quite a
+bit on it.  There are some obvious problems in the code that I tried fixing and some less
+obvious ones that I couldn't fix.  The code here is as I originally found it.
+
+menu.lisp: An old menu demonstration program.  Works.
+
+zoid.lisp: Another program for interfacing with extensions.  Again this extension (the "zoid
+extension") doesn't exist in any X server I know of.  This is another obsolete file.
diff --git a/clx/demo/bezier.lisp b/clx/demo/bezier.lisp
index fca439b00..6028679f3 100644
--- a/clx/demo/bezier.lisp
+++ b/clx/demo/bezier.lisp
@@ -18,6 +18,9 @@
 ;;; express or implied warranty.
 ;;;
 
+#+cmu
+(ext:file-comment "$Id: bezier.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (export 'draw-curves)
diff --git a/clx/demo/beziertest.lisp b/clx/demo/beziertest.lisp
index dc5bb91a2..6569fc2b9 100644
--- a/clx/demo/beziertest.lisp
+++ b/clx/demo/beziertest.lisp
@@ -18,6 +18,9 @@
 ;;; express or implied warranty.
 ;;;
 
+#+cmu
+(ext:file-comment "$Id: beziertest.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile"))
diff --git a/clx/demo/clclock.lisp b/clx/demo/clclock.lisp
new file mode 100644
index 000000000..9ad9a8b7a
--- /dev/null
+++ b/clx/demo/clclock.lisp
@@ -0,0 +1,81 @@
+#+cmu
+(ext:file-comment "$Id: clclock.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage "XCLCLOCK"
+  (:use "CL")
+  (:export "CLOCK"))
+
+(in-package "XCLCLOCK")
+
+(defvar *display* (xlib:open-default-display))
+(defvar *screen* (xlib:display-default-screen *display*))
+(defvar *colormap* (xlib:screen-default-colormap *screen*))
+
+(defvar *font* (xlib:open-font *display* "fixed"))
+(defvar *win*)
+
+(multiple-value-bind (width ascent)
+    (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII")
+  (setq *win*
+    (xlib:create-window
+     :parent (xlib:screen-root *screen*)
+     :x 512
+     :y 512
+     :width (+ 20 width) 
+     :height (+ 20 ascent)
+     :background (xlib:alloc-color *colormap*
+				   (xlib:lookup-color *colormap*
+						      "midnightblue")))))
+
+(defvar *gcontext* (xlib:create-gcontext
+                    :drawable *win*
+		    :fill-style :solid
+                    :background (xlib:screen-white-pixel *screen*)
+                    :foreground (xlib:alloc-color *colormap*
+						  (xlib:lookup-color
+						   *colormap*
+						   "yellow"))
+		    :font *font*))
+
+(defvar *background* (xlib:create-gcontext
+		      :drawable *win*
+		      :fill-style :solid
+		      :background (xlib:screen-white-pixel *screen*)
+		      :foreground (xlib:alloc-color *colormap*
+				   (xlib:lookup-color *colormap*
+						      "midnightblue"))
+		      :font *font*))
+(defvar *palette* nil)
+(defvar *black* (xlib:screen-black-pixel *screen*))
+
+(defun romanize (arg)
+  (if (zerop arg)
+      "O"
+      (format nil "~@R" arg)))
+
+(defun clock-string ()
+  (multiple-value-bind (s m h) (decode-universal-time (get-universal-time))
+    (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s))))
+
+(defun update-clockface ()
+  (let ((string (clock-string)))
+    (let ((string-width (xlib:text-width *gcontext* string)))
+      (xlib:draw-rectangle *win* *background*
+			   0 0
+			   (xlib:drawable-width *win*)
+			   (xlib:drawable-height *win*)
+			   :fill-p)
+      (xlib:draw-glyphs *win* *gcontext*
+			(- (truncate
+			    (- (xlib:drawable-width *win*) string-width)
+			    2)
+			   10)
+			(- (xlib:drawable-height *win*) 10)
+			string)))
+  (xlib:display-force-output *display*))
+
+(defun clock ()
+  (xlib:map-window *win*)
+  (loop
+   (update-clockface)
+   (sleep 1)))
diff --git a/clx/demo/clipboard.lisp b/clx/demo/clipboard.lisp
new file mode 100644
index 000000000..19c505812
--- /dev/null
+++ b/clx/demo/clipboard.lisp
@@ -0,0 +1,203 @@
+;;; This is a pretty direct translation of the Xlib selection test
+;;; program by Tor Andersson found at
+;;; <http://ghostscript.com/~tor/repos/Klipp/x11clipboard.c>, with
+;;; minor enhancements:
+;;;
+;;; * gdk requestors apparently unconditionally request UTF8_STRING
+;;;   selections without checking the TARGETS list of the selection
+;;;   owner -- and apparently even never request anything else.  This
+;;;   seems to be in contradiction with the freedesktop.org draft
+;;;   specification at
+;;;   <http://www.pps.jussieu.fr/~jch/software/UTF8_STRING/UTF8_STRING.text>
+;;;   (linked from <http://freedesktop.org/Standards>), but this is
+;;;   the real world and we have to live in it.  It would be nice if
+;;;   someone in the freedesktop community could resolve this.
+;;;
+;;; * the original C code, in the XSendEvent call, has an event mask
+;;;   of SelectionNotify.  SelectionNotify is not an event mask at
+;;;   all, however: but the code works "by accident" because
+;;;   SelectionNotify happens to have value 31, which has enough bits
+;;;   flipped on that most clients select on at least one of those
+;;;   events.  This bug is fixed below.
+;;;
+;;; * [ Update 2004-11-29, superseding to some extent the above ] in
+;;;   fact, these two things are related.  ICCCM says that the event
+;;;   disclaiming the ability to send in a given format should be sent
+;;;   with an empty event mask ("2.2 Responsibilities of the Selection
+;;;   Owner").
+;;;
+;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets
+;;;
+;;; As ever with these things, the divisions in intellectual property
+;;; between the writer of the original C program, Tor Andersson
+;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the
+;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk)
+;;; are murky, probably depend on jurisdiction, and in addition for
+;;; such a small work are essentially trivial.  To set peoples' minds
+;;; at ease, Tor wishes this information to be disseminated as widely
+;;; as possible.
+
+;;; Copyright (c) 2004, Christophe Rhodes
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+#+cmu
+(ext:file-comment "$Id: clipboard.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage "CLIPBOARD"
+  (:use "CL" "XLIB")
+  (:export "MAIN"))
+
+(in-package "CLIPBOARD")
+
+;;; This is "traditional" XLIB style; I don't really know if it's the
+;;; best way -- in developing this program, style of XLIB programming
+;;; was secondary to achieving First Paste.
+(defvar *window*)
+(defvar *time*)
+(defvar *display*)
+
+(defun ownselect ()
+  (format t "~&> set-selection-owner~%") (finish-output)
+  (set-selection-owner *display* :primary *window* *time*)
+  (unless (eq *window* (selection-owner *display* :primary))
+    (write-string "failed to own primary")))
+
+(defun deselect ()
+  (format t "~&> unset-selection-owner~%") (finish-output)
+  (set-selection-owner *display* :primary nil *time*)
+  (unless (eq nil (selection-owner *display* :primary))
+    (write-string "failed to disown primary")))
+
+(defun ask-paste ()
+  (format t "~&! deleting properties on window~%") (finish-output)
+  (delete-property *window* :aeclip-target)
+  (delete-property *window* :aeclip-string)
+  (delete-property *window* :aeclip-utf8_string)
+  (delete-property *window* :aeclip-text)
+  (format t "~&> convert-selection TARGETS~%") (finish-output)
+  (convert-selection :primary :targets *window* :aeclip-target)
+  (format t "~&> convert-selection STRING~%")  (finish-output)
+  (convert-selection :primary :string *window* :aeclip-string)
+  (format t "~&> convert-selection UTF8_STRING~%") (finish-output)
+  (convert-selection :primary :utf8_string *window* :aeclip-utf8_string)
+  (format t "~&> convert-selection TEXT~%") (finish-output)
+  (convert-selection :primary :text *window* :aeclip-text)
+  nil)
+
+(defun recv-paste (property)
+  (multiple-value-bind (data name format)
+      (get-property *window* property)
+    (format t "~&< get-prop ~S " name)
+    (case format
+      (32 (format t "[~{~S~^,~}]"
+                  (mapcar (lambda (x) (atom-name *display* x)) data)))
+      (8 (format t "~S" (map 'string 'code-char data)))
+      (t (format t "format=~S data=~S" format data)))
+    (format t "~%") (finish-output)
+    (delete-property *window* property)))
+
+(defun send-copy (selection target property requestor time)
+  (flet ((send (target property)
+	   (case target
+	     ((:string)
+	      (format t "~&> sending text data~%") (finish-output)
+	      (change-property requestor property
+			       "Hello, World (from the CLX clipboard)!"
+			       target 8
+			       :transform #'char-code)
+	      property)
+	     (:targets
+	      (format t "~&> sending targets list~%") (finish-output)
+	      ;; ARGH.  Can't use :TRANSFORM as we scribble over CLX's buffer.
+	      (let ((targets
+		     (mapcar (lambda (x) (intern-atom *display* x))
+			     '(:targets :timestamp :multiple :string))))
+		(change-property requestor property targets target 32))
+	      property)
+	     (:timestamp
+	      (format t "~&> sending timestamp~%") (finish-output)
+	      (change-property requestor property (list *time*) target 32)
+	      property)
+	     (t
+	      (format t "~&> sending none~%") (finish-output)
+	      nil))))
+    (case target
+      ;; WARNING: this is untested.  I don't know of any clients which
+      ;; use the :MULTIPLE target.
+      (:multiple
+       (let* ((list (get-property requestor property))
+	      (plist (mapcar (lambda (x) (atom-name *display* x)) list)))
+	 (loop for (ptarget pproperty) on plist by #'cddr
+	    with all-succeeded = t
+	    if (send ptarget pproperty)
+	    collect ptarget into result
+	    and collect pproperty into result
+	    else
+	    collect nil into result
+	    and collect pproperty into result
+	    and do (setf all-succeeded nil)
+	    finally (unless all-succeeded
+		      (let ((new-list
+			     (mapcar (lambda (x) (intern-atom *display* x))
+				     result)))
+			(change-property requestor property new-list
+					 target 32))))))
+      (t (setf property (send target property))))
+    (send-event requestor :selection-notify (make-event-mask)
+		:selection selection :target target
+		:property property :time time
+		:event-window requestor :window requestor)))
+
+(defun main ()
+  (let* ((*display* (open-default-display))
+         (screen (display-default-screen *display*))
+         (*window*
+          (create-window
+           :parent (screen-root screen)
+           :x 10 :y 10 :width 200 :height 200
+           :event-mask (make-event-mask :button-press :property-change))))
+    (map-window *window*)
+    (display-finish-output *display*)
+    (event-case (*display*)
+      (:button-press (code time)
+        (format t "~&ButtonPress~%") (finish-output)
+        (case code
+          (1 (setf *time* time) (ownselect))
+          (2 (ask-paste))
+          (3 (deselect))))
+      (:client-message ()
+        (format t "~&ClientMessage~%") (finish-output))
+      (:selection-clear (selection)
+        (format t "~&SelectionClear ~S~%" selection) (finish-output))
+      (:selection-notify (selection target property)
+        (format t "~&SelectionNotify ~S ~S ~S~%" selection target property)
+        (finish-output)
+        (unless (eq property nil)
+          (recv-paste property))
+        (display-finish-output *display*))
+      (:selection-request (selection target property requestor time)
+        (format t "~&SelectionRequest ~S ~S ~S~%" selection target property)
+        (finish-output)
+        (send-copy selection target property requestor time)
+        (display-finish-output *display*))
+      (:property-notify (atom state)
+        (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output)))))
diff --git a/clx/demo/clx-demos.lisp b/clx/demo/clx-demos.lisp
new file mode 100644
index 000000000..442b82e7a
--- /dev/null
+++ b/clx/demo/clx-demos.lisp
@@ -0,0 +1,1065 @@
+;;; -*- Mode: Lisp; Package: Demos -*-
+;;;
+;;; This file contains various graphics hacks written and ported over the
+;;; years by various and numerous persons.
+;;;
+;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
+;;;
+
+#+cmu
+(ext:file-comment "$Id: clx-demos.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage :demos (:use :common-lisp)
+  (:export do-all-demos demo))
+
+(in-package :demos)
+
+
+;;;; Graphic demos wrapper macro.
+
+;;; This wrapper macro should be reconsidered with respect to its property
+;;; list usage.  Possibly a demo structure should be used with *demos*
+;;; pointing to these instead of function names.  Also, something should
+;;; be done about a title window that displays the name of the demo while
+;;; it is running.
+
+(defparameter *demos* nil)
+
+(defvar *display* nil)
+(defvar *screen* nil)
+(defvar *root* nil)
+(defvar *black-pixel* nil)
+(defvar *white-pixel* nil)
+(defvar *window* nil)
+
+(defvar *delay* .01) ; This is necessary on current hardware to make the demos run slow enough
+		     ; to actually see something.
+
+(defmacro defdemo (fun-name demo-name args x y width height doc &rest forms)
+  `(progn
+     (defun ,fun-name ,args
+       ,doc
+       (unless *display*
+;;	 #+:cmu
+;;	 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
+	 #+(or cmu sbcl allegro)
+	 (progn
+	   (setf *display* (xlib::open-default-display))
+	   (setf *screen* (xlib:display-default-screen *display*)))
+	 #-(or cmu sbcl allegro clisp)
+	 (progn
+	   ;; Portable method
+	   (setf *display* (xlib:open-display (machine-instance)))
+	   (setf *screen* (xlib:display-default-screen *display*)))
+	 (setf *root* (xlib:screen-root *screen*))
+	 (setf *black-pixel* (xlib:screen-black-pixel *screen*))
+	 (setf *white-pixel* (xlib:screen-white-pixel *screen*)))
+       (let ((*window* (xlib:create-window :parent *root*
+					   :x ,x :y ,y
+					   :event-mask nil
+					   :width ,width :height ,height
+					   :background *white-pixel*
+					   :border *black-pixel*
+					   :border-width 2
+					   :override-redirect :on)))
+	 (xlib:map-window *window*)
+	 ;; 
+	 ;; I hate to do this since this is not something any normal
+	 ;; program should do ...
+	 (setf (xlib:window-priority *window*) :above)
+	 (xlib:display-finish-output *display*)
+	 (unwind-protect
+	      (progn ,@forms)
+	   (xlib:unmap-window *window*)
+	   (xlib:display-finish-output *display*))))
+    (setf (get ',fun-name 'demo-name) ',demo-name)
+    (setf (get ',fun-name 'demo-doc) ',doc)
+    (export ',fun-name)
+    (pushnew ',fun-name *demos*)
+    ',fun-name))
+
+
+;;;; Main entry points.
+
+(defun do-all-demos ()
+  (loop
+   (dolist (demo *demos*)
+     (funcall demo)
+     (sleep 3))))
+
+;;; DEMO is a hack to get by.  It should be based on creating a menu.  At
+;;; that time, *name-to-function* should be deleted, since this mapping will
+;;; be manifested in the menu slot name cross its action.  Also the
+;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for
+;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi".
+;;;
+
+(defvar *name-to-function* (make-hash-table :test #'eq))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+(defun demo ()
+  (macrolet ((read-demo ()
+	       `(let ((*package* *keyword-package*))
+		  (read))))
+    (dolist (d *demos*)
+      (setf (gethash (intern (string-upcase (get d 'demo-name))
+			     *keyword-package*)
+		     *name-to-function*)
+	    d))
+    (loop
+      (fresh-line)
+      (dolist (d *demos*)
+	(write-string "   ")
+	(write-line (get d 'demo-name)))
+      (write-string "   ")
+      (write-line "Help <demo name>")
+      (write-string "   ")
+      (write-line "Quit")
+      (write-string "Enter demo name: ")
+      (let ((demo (read-demo)))
+	(case demo
+	  (:help
+	   (let* ((demo (read-demo))
+		  (fun (gethash demo *name-to-function*)))
+	     (fresh-line)
+	     (if fun
+		 (format t "~&~%~A~&~%" (get fun 'demo-doc))
+		 (format t "Unknown demo name -- ~A." demo))))
+	  (:quit (return t))
+	  (t
+	   (let ((fun (gethash demo *name-to-function*)))
+	     (if fun
+		 #+mp
+		 (mp:make-process #'(lambda ()
+				      (loop
+				       (funcall fun)
+				       (sleep 2)))
+				  :name (format nil "~S" demo))
+		 #-mp
+		 (funcall fun)
+		 (format t "~&~%Unknown demo name -- ~A.~&~%" demo)))))))))
+
+
+;;;; Shared demo utilities.
+
+(defun full-window-state (w)
+  (xlib:with-state (w)
+    (values (xlib:drawable-width w) (xlib:drawable-height w)
+	    (xlib:drawable-x w) (xlib:drawable-y w)
+	    (xlib:window-map-state w))))
+
+
+;;;; Greynetic.
+
+;;; GREYNETIC displays random sized and shaded boxes in a window.  This is
+;;; real slow.  It needs work.
+;;; 
+(defun greynetic (window duration)
+  (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1
+				     :drawable window))
+	 (gcontext (xlib:create-gcontext :drawable window
+					 :background *white-pixel*
+					 :foreground *black-pixel*
+					 :tile pixmap
+					 :fill-style :tiled)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (dotimes (i duration)
+	(let* ((pixmap-data (greynetic-pixmapper))
+	       (image (xlib:create-image :width 32 :height 32
+					 :depth 1 :data pixmap-data)))
+	  (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32)
+	  (xlib:draw-rectangle window gcontext
+			       (- (random width) 5)
+			       (- (random height) 5)
+			       (+ 4 (random (truncate width 3)))
+			       (+ 4 (random (truncate height 3)))
+			       t))
+	(xlib:display-force-output *display*)
+	(sleep *delay*)))
+    (xlib:free-gcontext gcontext)
+    (xlib:free-pixmap pixmap)))
+
+(defvar *greynetic-pixmap-array*
+  (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel))
+
+(defun greynetic-pixmapper ()
+  (let ((pixmap-data *greynetic-pixmap-array*))
+    (dotimes (i 4)
+      (declare (fixnum i))
+      (let ((nibble (random 16)))
+	(setf nibble (logior nibble (ash nibble 4))
+	      nibble (logior nibble (ash nibble 8))
+	      nibble (logior nibble (ash nibble 12))
+	      nibble (logior nibble (ash nibble 16)))
+	(dotimes (j 32)
+	  (let ((bit (if (logbitp j nibble) 1 0)))
+	    (setf (aref pixmap-data i j) bit
+		  (aref pixmap-data (+ 4 i) j) bit
+		  (aref pixmap-data (+ 8 i) j) bit
+		  (aref pixmap-data (+ 12 i) j) bit
+		  (aref pixmap-data (+ 16 i) j) bit
+		  (aref pixmap-data (+ 20 i) j) bit
+		  (aref pixmap-data (+ 24 i) j) bit
+		  (aref pixmap-data (+ 28 i) j) bit)))))
+    pixmap-data))
+
+#+nil
+(defdemo greynetic-demo "Greynetic" (&optional (duration 300))
+  100 100 600 600
+  "Displays random grey rectangles."
+  (greynetic *window* duration))
+
+
+;;;; Qix.
+
+(defstruct qix
+  buffer
+  (dx1 5)
+  (dy1 10)
+  (dx2 10)
+  (dy2 5))
+
+(defun construct-qix (length)
+  (let ((qix (make-qix)))
+    (setf (qix-buffer qix) (make-circular-list length))
+    qix))
+
+(defun make-circular-list (length)
+  (let ((l (make-list length)))
+    (rplacd (last l) l)))
+
+
+(defun qix (window lengths duration)
+  "Each length is the number of lines to put in a qix, and that many qix
+  (of the correct size) are put up on the screen.  Lets the qix wander around
+  the screen for Duration steps."
+  (let ((histories (mapcar #'construct-qix lengths)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (declare (fixnum width height))
+      (xlib:clear-area window)
+      (xlib:display-force-output *display*)
+      (do ((h histories (cdr h))
+	   (l lengths (cdr l)))
+	  ((null h))
+	(do ((x (qix-buffer (car h)) (cdr x))
+	     (i 0 (1+ i)))
+	    ((= i (car l)))
+	  (rplaca x (make-array 4))))
+      ;; Start each qix at a random spot on the screen.
+      (dolist (h histories)
+	(let ((x (random width))
+	      (y (random height)))
+	  (rplaca (qix-buffer h)
+		  (make-array 4 :initial-contents (list x y x y)))))
+      (rplacd (last histories) histories)
+      (let ((x1 0) (y1 0) (x2 0) (y2 0)
+	    (dx1 0) (dy1 0) (dx2 0) (dy2 0)
+	    tem line next-line qix
+	    (gc (xlib:create-gcontext :drawable window
+				      :foreground *white-pixel*
+				      :background *black-pixel*
+				      :line-width 0 :line-style :solid
+				      :function boole-c2)))
+	(declare (fixnum x1 y1 x2 y2 dx1 dy1 dx2 dy2))
+	(dotimes (i duration)
+	  ;; Line is the next line in the next qix. Rotate this qix and
+	  ;; the qix ring.
+	  (setq qix (car histories))
+	  (setq line (car (qix-buffer qix)))
+	  (setq next-line (cadr (qix-buffer qix)))
+	  (setf (qix-buffer qix) (cdr (qix-buffer qix)))
+	  (setq histories (cdr histories))
+	  (setf x1 (svref line 0))
+	  (setf y1 (svref line 1))
+	  (setf x2 (svref line 2))
+	  (setf y2 (svref line 3))
+	  (xlib:draw-line window gc x1 y1 x2 y2)
+	  (setq dx1 (- (+ (qix-dx1 qix) (random 3)) 1))
+	  (setq dy1 (- (+ (qix-dy1 qix) (random 3)) 1))
+	  (setq dx2 (- (+ (qix-dx2 qix) (random 3)) 1))
+	  (setq dy2 (- (+ (qix-dy2 qix) (random 3)) 1))
+	  (cond ((> dx1 10) (setq dx1 10))
+		((< dx1 -10) (setq dx1 -10)))
+	  (cond ((> dy1 10) (setq dy1 10))
+		((< dy1 -10) (setq dy1 -10)))
+	  (cond ((> dx2 10) (setq dx2 10))
+		((< dx2 -10) (setq dx2 -10)))
+	  (cond ((> dy2 10) (setq dy2 10))
+		((< dy2 -10) (setq dy2 -10)))
+	  (cond ((or (>= (setq tem (+ x1 dx1)) width) (minusp tem))
+		 (setq dx1 (- dx1))))
+	  (cond ((or (>= (setq tem (+ x2 dx2)) width) (minusp tem))
+		 (setq dx2 (- dx2))))
+	  (cond ((or (>= (setq tem (+ y1 dy1)) height) (minusp tem))
+		 (setq dy1 (- dy1))))
+	  (cond ((or (>= (setq tem (+ y2 dy2)) height) (minusp tem))
+		 (setq dy2 (- dy2))))
+	  (setf (qix-dy2 qix) dy2)
+	  (setf (qix-dx2 qix) dx2)
+	  (setf (qix-dy1 qix) dy1)
+	  (setf (qix-dx1 qix) dx1)
+`	  (when (svref next-line 0)
+	    (xlib:draw-line window gc
+			    (svref next-line 0) (svref next-line 1)
+			    (svref next-line 2) (svref next-line 3)))
+	  (setf (svref next-line 0) (+ x1 dx1))
+	  (setf (svref next-line 1) (+ y1 dy1))
+	  (setf (svref next-line 2) (+ x2 dx2))
+	  (setf (svref next-line 3) (+ y2 dy2))
+	  (xlib:display-force-output *display*)
+	  (sleep *delay*))))))
+
+
+(defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000))
+  0 0 700 700
+  "Hypnotic wandering lines."
+  (qix *window* lengths duration))
+
+
+
+;;;; Petal.
+
+;;; Fast sine constants:
+
+(defconstant d360 #o5500)
+(defconstant d270 #o4160)
+(defconstant d180 #o2640)
+(defconstant d90 #o1320)
+(defconstant vecmax 2880)
+
+(defparameter sin-array
+  '#(#o0 #o435 #o1073 #o1531 #o2166 #o2623 #o3260 
+     #o3714 #o4350 #o5003 #o5435 #o6066 #o6516 #o7145
+     #o7573 #o10220 #o10644 #o11266 #o11706 #o12326 
+     #o12743 #o13357 #o13771 #o14401 #o15007 #o15414
+     #o16016 #o16416 #o17013 #o17407 #o20000 #o20366
+     #o20752 #o21333 #o21711 #o22265 #o22636 #o23204
+     #o23546 #o24106 #o24443 #o24774 #o25323 #o25645
+     #o26165 #o26501 #o27011 #o27316 #o27617 #o30115
+     #o30406 #o30674 #o31156 #o31434 #o31706 #o32154
+     #o32416 #o32654 #o33106 #o33333 #o33554 #o33771
+     #o34202 #o34406 #o34605 #o35000 #o35167 #o35351
+     #o35526 #o35677 #o36043 #o36203 #o36336 #o36464
+     #o36605 #o36721 #o37031 #o37134 #o37231 #o37322
+     #o37407 #o37466 #o37540 #o37605 #o37646 #o37701
+     #o37730 #o37751 #o37766 #o37775 #o40000))
+
+(defmacro psin (val)
+  `(let* ((val ,val)
+	  neg
+	  frac
+	  sinlo)
+     (if (>= val d180)
+	 (setq neg t
+	       val (- val d180)))
+     (if (>= val d90)
+	 (setq val (- d180 val)))
+     (setq frac (logand val 7))
+     (setq val (ash val -3))
+     ;; 
+     (setq sinlo (if (>= val 90)
+		     (svref sin-array 90)
+		     (svref sin-array val)))
+     ;; 
+     (if (< val 90)
+	 (setq sinlo
+	       (+ sinlo (ash (* frac (- (svref sin-array (1+ val)) sinlo))
+			     -3))))
+     ;; 
+     (if neg
+	 (- sinlo)
+	 sinlo)))
+
+(defmacro pcos (x)
+  `(let ((tmp (- ,x d270)))
+     (psin (if (minusp tmp) (+ tmp d360) tmp))))
+
+
+;;;; Miscellaneous petal hackery.
+
+(defmacro high-16bits-* (a b)
+  `(let ((a-h (ash ,a -8))
+	 (b-h (ash ,b -8)))
+     (+ (* a-h b-h)
+	(ash (* a-h (logand ,b 255)) -8)
+	(ash (* b-h (logand ,a 255)) -8))))
+
+(defun complete (style petal)
+  (let ((repnum 1)
+	factor cntval needed)
+    (dotimes (i 3)
+      (case i
+	(0 (setq factor 2 cntval 6)) 
+	(1 (setq factor 3 cntval 2))
+	(2 (setq factor 5 cntval 1)))
+      (do ()
+	  ((or (minusp cntval) (not (zerop (rem style factor)))))
+	(setq repnum (* repnum factor))
+	(setq cntval (1- cntval))
+	(setq style (floor style factor))))
+    (setq needed (floor vecmax repnum))
+    (if (and (not (oddp needed)) (oddp petal)) (floor needed 2) needed)))
+
+
+;;;; Petal Parameters and Petal itself
+
+(defparameter continuous t)
+(defparameter styinc 2)
+(defparameter petinc 1)
+(defparameter scalfac-fac 8192)
+
+(defun petal (petal-window &optional (how-many 10) (style 0) (petal 0))
+  (let ((width 512)
+	(height 512))
+    (xlib:clear-area petal-window)
+    (xlib:display-force-output *display*)
+    (let ((veccnt 0)
+	  (nustyle 722)
+	  (nupetal 3)
+	  (scalfac (1+ (floor scalfac-fac (min width height))))
+	  (ctrx (floor width 2))
+	  (ctry (floor height 2))
+	  (tt 0)
+	  (s 0)
+	  (lststyle 0)
+	  (lstpetal 0)
+	  (petstyle 0)
+	  (vectors 0)
+	  (r 0)
+	  (x1 0)
+	  (y1 0)
+	  (x2 0)
+	  (y2 0)
+	  (i 0)
+	  (gc (xlib:create-gcontext :drawable petal-window
+				    :foreground *black-pixel*
+				    :background *white-pixel*
+				    :line-width 0 :line-style :solid)))
+      (loop
+	(when (zerop veccnt)
+	  (setq tt 0 s 0 lststyle style lstpetal petal petal nupetal
+		style nustyle petstyle (rem (* petal style) d360)
+		vectors (complete style petal))
+	  (when continuous
+	    (setq nupetal  (+ nupetal petinc)
+		  nustyle (+ nustyle styinc)))
+	  (when (or (/= lststyle style) (/= lstpetal petal))
+	    (xlib:clear-area petal-window)
+	    (xlib:display-force-output *display*)))
+	(when (or (/= lststyle style) (/= lstpetal petal))
+	  (setq veccnt (1+ veccnt) i veccnt x1 x2 y1 y2
+		tt (rem (+ tt style) d360)
+		s (rem (+ s petstyle) d360)
+		r (pcos s))
+	  (setq x2 (+ ctrx (floor (high-16bits-* (pcos tt) r) scalfac))
+		y2 (+ ctry (floor (high-16bits-* (psin tt) r) scalfac)))
+	  (when (/= i 1)
+	    (xlib:draw-line petal-window gc x1 y1 x2 y2)
+	    (xlib:display-force-output *display*)))
+	(when (> veccnt vectors)
+	  (setq veccnt 0)
+	  (setq how-many (1- how-many))
+	  (sleep 2)
+	  (when (zerop how-many) (return)))))))
+
+(defdemo petal-demo "Petal" (&optional (how-many 10) (style 0) (petal 0))
+  100 100 512 512
+  "Flower-like display."
+  (petal *window* how-many style petal))
+
+
+;;;; Hanoi.
+
+;;; Random parameters:
+
+(defparameter disk-thickness 15 "The thickness of a disk in pixels.")
+(defparameter disk-spacing (+ disk-thickness 3)
+  "The amount of vertical space used by a disk on a needle.")
+(defvar *horizontal-velocity* 20 "The speed at which disks slide sideways.")
+(defvar *vertical-velocity* 12 "The speed at which disks move up and down.")
+
+;;; These variables are bound by the main function.
+
+(defvar *hanoi-window* () "The window that Hanoi is happening on.")
+(defvar *hanoi-window-height* () "The height of the viewport Hanoi is happening on.")
+(defvar *transfer-height* () "The height at which disks are transferred.")
+(defvar *hanoi-gcontext* () "The graphics context for Hanoi under X11.")
+
+;;; Needle Functions
+
+(defstruct disk
+  size)
+
+(defstruct needle
+  position
+  disk-stack)
+
+;;; Needle-Top-Height returns the height of the top disk on NEEDLE.
+
+(defun needle-top-height (needle)
+  (- *hanoi-window-height*
+     (* disk-spacing (length (the list (needle-disk-stack needle))))))
+
+(defvar available-disks
+  (do ((i 10 (+ i 10))
+       (dlist () (cons (make-disk :size i) dlist)))
+      ((> i 80) dlist)))
+
+(defvar needle-1 (make-needle :position 184))
+(defvar needle-2 (make-needle :position 382))
+(defvar needle-3 (make-needle :position 584))
+
+;;; Graphic interface abstraction:
+
+;;; Invert-Rectangle calls the CLX function draw-rectangle with "fill-p"
+;;; set to T.  Update-Screen forces the display output.
+;;; 
+(defmacro invert-rectangle (x y height width)
+  `(xlib:draw-rectangle *hanoi-window* *hanoi-gcontext*
+			,x ,y ,width ,height t))
+
+(defmacro update-screen ()
+  `(progn
+     (xlib:display-force-output *display*)
+     (sleep *delay*)))
+
+
+;;;; Moving disks up and down
+
+;;; Slide-Up slides the image of a disk up from the coordinates X,
+;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
+;;; move.  START-Y must be greater than END-Y
+
+(defun slide-up (start-y end-y x disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- start-y end-y) *vertical-velocity*)
+    (do ((x (- x disk-size))
+	 (width (* disk-size 2))
+	 (old-y start-y (- old-y *vertical-velocity*))
+	 (new-y (- start-y *vertical-velocity*) (- new-y *vertical-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle x (- old-y pixels-left) disk-thickness width)
+	   (invert-rectangle x old-y disk-thickness width)
+	   (update-screen)))
+      ;; Loop body writes disk at new height & erases at old height.
+      (invert-rectangle x old-y disk-thickness width)
+      (invert-rectangle x new-y disk-thickness width)
+      (update-screen))))
+
+;;; Slide-Down slides the image of a disk down from the coordinates X,
+;;; START-Y to the point X, END-Y.  DISK-SIZE is the size of the disk to
+;;; move.  START-Y must be less than END-Y.
+
+(defun slide-down (start-y end-y x disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- end-y start-y) *vertical-velocity*)
+    (do ((x (- x disk-size))
+	 (width (* disk-size 2))
+	 (old-y start-y (+ old-y *vertical-velocity*))
+	 (new-y (+ start-y *vertical-velocity*) (+ new-y *vertical-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle x (+ old-y pixels-left) disk-thickness width)
+	   (invert-rectangle x old-y disk-thickness width)
+	   (update-screen)))
+      ;; Loop body writes disk at new height & erases at old height.
+      (invert-rectangle X old-y disk-thickness width)
+      (invert-rectangle X new-y disk-thickness width)
+      (update-screen))))
+
+
+;;;; Lifting and Droping Disks
+
+;;; Lift-disk pops the top disk off of needle and raises it up to the
+;;; transfer height.  The disk is returned.
+
+(defun lift-disk (needle)
+  "Pops the top disk off of NEEDLE, Lifts it above the needle, & returns it."
+  (let* ((height (needle-top-height needle))
+	 (disk (pop (needle-disk-stack needle))))
+    (slide-up height
+	      *transfer-height*
+	      (needle-position needle)
+	      (disk-size disk))
+    disk))
+
+;;; Drop-disk drops a disk positioned over needle at the transfer height
+;;; onto needle.  The disk is pushed onto needle.
+
+(defun drop-disk (disk needle)
+  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
+  (push disk (needle-disk-stack needle))
+  (slide-down *transfer-height*
+	      (needle-top-height needle)
+	      (needle-position needle)
+	      (disk-size disk))
+  t)
+
+
+;;; Drop-initial-disk is the same as drop-disk except that the disk is
+;;; drawn once before dropping.
+
+(defun drop-initial-disk (disk needle)
+  "DISK must be positioned above NEEDLE.  It is dropped onto NEEDLE."
+  (let* ((size (disk-size disk))
+	 (lx (- (needle-position needle) size)))
+    (invert-rectangle lx *transfer-height* disk-thickness (* size 2))
+    (push disk (needle-disk-stack needle))
+    (slide-down *transfer-height*
+		(needle-top-height needle)
+		(needle-position needle)
+		(disk-size disk))
+    t))
+
+
+;;;; Sliding Disks Right and Left
+
+;;; Slide-Right slides the image of a disk located at START-X, Y to the
+;;; position END-X, Y.  DISK-SIZE is the size of the disk.  START-X is
+;;; less than END-X.
+
+(defun slide-right (start-x end-x Y disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- end-x start-x) *horizontal-velocity*)
+    (do ((right-x (+ start-x disk-size) (+ right-x *horizontal-velocity*))
+	 (left-x  (- start-x disk-size) (+ left-x  *horizontal-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (invert-rectangle right-x Y disk-thickness pixels-left)
+	   (invert-rectangle left-x  Y disk-thickness pixels-left)
+	   (update-screen)))
+      ;; Loop body adds chunk *horizontal-velocity* pixels wide to right
+      ;; side of disk, then chops off left side.
+      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
+      (invert-rectangle left-x Y disk-thickness *horizontal-velocity*)
+      (update-screen))))
+
+;;; Slide-Left is the same as Slide-Right except that START-X is greater
+;;; than END-X.
+
+(defun slide-left (start-x end-x Y disk-size)
+  (multiple-value-bind (number-moves pixels-left)
+		       (truncate (- start-x end-x) *horizontal-velocity*)
+    (do ((right-x (- (+ start-x disk-size) *horizontal-velocity*)
+		  (- right-x *horizontal-velocity*))
+	 (left-x  (- (- start-x disk-size) *horizontal-velocity*)
+		  (- left-x  *horizontal-velocity*))
+	 (number-moves number-moves (1- number-moves)))
+	((zerop number-moves)
+	 (when (plusp pixels-left)
+	   (setq left-x  (- (+ left-x  *horizontal-velocity*) pixels-left))
+	   (setq right-x (- (+ right-x *horizontal-velocity*) pixels-left))
+	   (invert-rectangle left-x  Y disk-thickness pixels-left)
+	   (invert-rectangle right-x Y disk-thickness pixels-left)
+	   (update-screen)))
+      ;; Loop body adds chunk *horizontal-velocity* pixels wide to left
+      ;; side of disk, then chops off right side.
+      (invert-rectangle left-x  Y disk-thickness *horizontal-velocity*)
+      (invert-rectangle right-x Y disk-thickness *horizontal-velocity*)
+      (update-screen))))
+
+
+;;;; Transferring Disks
+
+;;; Transfer disk slides a disk at the transfer height from a position
+;;; over START-NEEDLE to a position over END-NEEDLE.  Modified disk is
+;;; returned.
+
+(defun transfer-disk (disk start-needle end-needle)
+  "Moves DISK from a position over START-NEEDLE to a position over END-NEEDLE."
+  (let ((start (needle-position start-needle))
+	(end (needle-position end-needle)))
+    (if (< start end)
+	(slide-right start end *transfer-height* (disk-size disk))
+	(slide-left start end *transfer-height* (disk-size disk)))
+    disk))
+
+
+;;; Move-One-Disk moves the top disk from START-NEEDLE to END-NEEDLE.
+
+(defun move-one-disk (start-needle end-needle)
+  "Moves the disk on top of START-NEEDLE to the top of END-NEEDLE."
+  (drop-disk (transfer-disk (lift-disk start-needle)
+			    start-needle
+			    end-needle)
+	     end-needle)
+  t)
+
+;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
+;;; obeying the rules of the towers of hannoi problem.  To move the
+;;; disks, a third needle, TEMP-NEEDLE, is needed for temporary storage.
+
+(defun move-n-disks (n start-needle end-needle temp-needle)
+  "Moves the top N disks from START-NEEDLE to END-NEEDLE.  
+   Uses TEMP-NEEDLE for temporary storage."
+  (cond ((= n 1)
+	 (move-one-disk start-needle end-needle))
+	(t
+	 (move-n-disks (1- n) start-needle temp-needle end-needle)
+	 (move-one-disk start-needle end-needle)
+	 (move-n-disks (1- n) temp-needle end-needle start-needle)))
+  t)
+
+
+;;;; Hanoi itself.
+
+(defun hanoi (window n)
+  (multiple-value-bind (width height) (full-window-state window)
+    (declare (ignore width))
+    (let* ((*hanoi-window* window)
+	   (*hanoi-window-height* height)
+	   (*transfer-height* (- height (* disk-spacing n)))
+	   (*hanoi-gcontext* (xlib:create-gcontext :drawable *hanoi-window*
+						   :foreground *white-pixel*
+						   :background *black-pixel*
+						   :fill-style :solid
+						   :function boole-c2)))
+      (xlib:clear-area *hanoi-window*)
+      (xlib:display-force-output *display*)
+      (let ((needle-1 (make-needle :position 184))
+	    (needle-2 (make-needle :position 382))
+	    (needle-3 (make-needle :position 584)))
+	(setf (needle-disk-stack needle-1) ())
+	(setf (needle-disk-stack needle-2) ())
+	(setf (needle-disk-stack needle-3) ())
+	(do ((n n (1- n))
+	     (available-disks available-disks (cdr available-disks)))
+	    ((zerop n))
+	  (drop-initial-disk (car available-disks) needle-1))
+	(move-n-disks n needle-1 needle-3 needle-2)
+	t))))
+
+;;; Change the names of these when the DEMO loop isn't so stupid.
+;;; 
+(defdemo slow-hanoi-demo "Slow-towers-of-Hanoi" (&optional (how-many 4))
+  0 100 768 300
+  "Solves the Towers of Hanoi problem before your very eyes."
+  (let ((*horizontal-velocity* 3)
+	(*vertical-velocity* 1))
+    (hanoi *window* how-many)))
+;;;
+(defdemo fast-hanoi-demo "Fast-towers-of-Hanoi" (&optional (how-many 7))
+  0 100 768 300
+  "Solves the Towers of Hanoi problem before your very eyes."
+  (hanoi *window* how-many))
+
+
+
+;;;; Bounce window.
+
+;;; BOUNCE-WINDOW takes a window and seemingly drops it to the bottom of
+;;; the screen.  Optionally, the window can have an initial x velocity,
+;;; screen border elasticity, and gravity value.  The outer loop is
+;;; entered the first time with the window at its initial height, but
+;;; each iteration after this, the loop starts with the window at the
+;;; bottom of the screen heading upward.  The inner loop, except for the
+;;; first execution, carries the window up until the negative velocity
+;;; becomes positive, carrying the window down to bottom when the
+;;; velocity is positive.  Due to number lossage, ROUND'ing and
+;;; TRUNC'ing when the velocity gets so small will cause the window to
+;;; head upward with the same velocity over two iterations which will
+;;; cause the window to bounce forever, so we have prev-neg-velocity and
+;;; number-problems to check for this.  This is not crucial with the x
+;;; velocity since the loop terminates as a function of the y velocity.
+;;; 
+(defun bounce-window (window &optional
+		      (x-velocity 0) (elasticity 0.85) (gravity 2))
+  (unless (< 0 elasticity 1)
+    (error "Elasticity must be between 0 and 1."))
+  (unless (plusp gravity)
+    (error "Gravity must be positive."))
+  (multiple-value-bind (width height x y mapped) (full-window-state window)
+    (when (eq mapped :viewable)
+      (let ((top-of-window-at-bottom (- (xlib:drawable-height *root*) height))
+	    (left-of-window-at-right (- (xlib:drawable-width *root*) width))
+	    (y-velocity 0)
+	    (prev-neg-velocity most-negative-fixnum)
+	    (number-problems nil))
+	(declare (fixnum top-of-window-at-bottom left-of-window-at-right
+			 y-velocity))
+	(loop
+	   (when (= prev-neg-velocity 0) (return t))
+	   (let ((negative-velocity (minusp y-velocity)))
+	     (loop
+		(let ((next-y (+ y y-velocity))
+		      (next-y-velocity (+ y-velocity gravity)))
+		  (declare (fixnum next-y next-y-velocity))
+		  (when (> next-y top-of-window-at-bottom)
+		    (cond
+		      (number-problems
+		       (setf y-velocity (incf prev-neg-velocity)))
+		      (t
+		       (setq y-velocity
+			     (- (truncate (* elasticity y-velocity))))
+		       (when (= y-velocity prev-neg-velocity)
+			 (incf y-velocity)
+			 (setf number-problems t))
+		       (setf prev-neg-velocity y-velocity)))
+		    (setf y top-of-window-at-bottom)
+		    (setf (xlib:drawable-x window) x
+			  (xlib:drawable-y window) y)
+		    (xlib:display-force-output *display*)
+		    (sleep *delay*)
+		    (return))
+		  (setq y-velocity next-y-velocity)
+		  (setq y next-y))
+		(when (and negative-velocity (>= y-velocity 0))
+		  (setf negative-velocity nil))
+		(let ((next-x (+ x x-velocity)))
+		  (declare (fixnum next-x))
+		  (when (or (> next-x left-of-window-at-right)
+			    (< next-x 0))
+		    (setq x-velocity (- (truncate (* elasticity x-velocity)))))
+		  (setq x next-x))
+		(setf (xlib:drawable-x window) x
+		      (xlib:drawable-y window) y)
+		(xlib:display-force-output *display*)
+		(sleep *delay*))))))))
+
+;;; Change the name of this when DEMO is not so stupid.
+;;; 
+(defdemo shove-bounce-demo "Shove-bounce" ()
+  100 100 300 300
+  "Drops the demo window with an inital X velocity which bounces off
+  screen borders."
+  (bounce-window *window* 30))
+
+(defdemo bounce-demo "Bounce" ()
+  100 100 300 300
+  "Drops the demo window which bounces off screen borders."
+  (bounce-window *window*))
+
+
+;;;; Recurrence Demo
+
+;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu)
+
+;;; 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.  
+
+;;; The author provides this software "as is" without express or
+;;; implied warranty.
+
+;;; This routine plots the recurrence 
+;;;      x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
+;;;      y <- .21 - x
+;;; As described in a ?? 1983 issue of the Mathematical Intelligencer
+
+(defun recurrence (display window &optional (point-count 10000))
+  (let ((gc (xlib:create-gcontext :drawable window
+				  :background *white-pixel*
+				  :foreground *black-pixel*)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (xlib:clear-area window)
+      (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
+      (xlib:display-force-output display)
+      (sleep 4))
+    (xlib:free-gcontext gc)))
+
+;;; Draw points.  X assumes points are in the range of width x height,
+;;; with 0,0 being upper left and 0,H being lower left.
+;;; hw and hh are half-width and half-height of screen
+
+(defun draw-ppict (win gc count x y hw hh)
+  "Recursively draw pretty picture"
+  (unless (zerop count)
+    (let ((xf (floor (* (+ 1.0 x) hw ))) ;These lines center the picture
+          (yf (floor (* (+ 0.7 y) hh ))))
+      (xlib:draw-point win gc xf yf)
+      (draw-ppict win gc (1- count) 
+                  (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
+                  (- 0.21 x)
+                  hw
+                  hh))))
+
+(defdemo recurrence-demo "Recurrence" ()
+  10 10 700 700
+  "Plots a cool recurrence relation."
+  (recurrence *display* *window*))
+
+
+;;;; Plaid
+
+;;; 
+;;; Translated from the X11 Plaid Demo written in C by Christopher Hoover.
+;;; 
+
+(defmacro rect-x (rects n)
+  `(svref ,rects (ash ,n 2)))
+(defmacro rect-y (rects n)
+  `(svref ,rects (+ (ash ,n 2) 1)))
+(defmacro rect-width (rects n)
+  `(svref ,rects (+ (ash ,n 2) 2)))
+(defmacro rect-height (rects n)
+  `(svref ,rects (+ (ash ,n 2) 3)))
+
+(defun plaid (display window &optional (num-iterations 10000) (num-rectangles 10))
+  (let ((gcontext (xlib:create-gcontext :drawable window
+					:function boole-c2
+					:plane-mask (logxor *white-pixel*
+							    *black-pixel*)
+					:background *white-pixel*
+					:foreground *black-pixel*
+					:fill-style :solid))
+	(rectangles (make-array (* 4 num-rectangles)
+				:element-type 'number
+				:initial-element 0)))
+    (multiple-value-bind (width height) (full-window-state window)
+      (let ((center-x (ash width -1))
+	    (center-y (ash height -1))
+	    (x-dir -2)
+	    (y-dir -2)
+	    (x-off 2)
+	    (y-off 2))
+	(dotimes (iter (truncate num-iterations num-rectangles))
+	  (dotimes (i num-rectangles)
+	    (setf (rect-x rectangles i) (- center-x x-off))
+	    (setf (rect-y rectangles i) (- center-y y-off))
+	    (setf (rect-width rectangles i) (ash x-off 1))
+	    (setf (rect-height rectangles i) (ash y-off 1))
+	    (incf x-off x-dir)
+	    (incf y-off y-dir)
+	    (when (or (<= x-off 0) (>= x-off center-x))
+	      (decf x-off (ash x-dir 1))
+	      (setf x-dir (- x-dir)))
+	    (when (or (<= y-off 0) (>= y-off center-y))
+	      (decf y-off (ash y-dir 1))
+	      (setf y-dir (- y-dir))))
+	  (xlib:draw-rectangles window gcontext rectangles t)
+	  (sleep *delay*)
+	  (xlib:display-force-output display))))
+    (xlib:free-gcontext gcontext)))
+
+(defdemo plaid-demo "Plaid" (&optional (iterations 10000) (num-rectangles 10))
+  10 10 101 201
+  "Plaid, man."
+  (plaid *display* *window* iterations num-rectangles))
+
+
+;;;; Bball demo
+
+;;; 
+;;; Ported to CLX by Blaine Burks
+;;; 
+
+(defvar *ball-size-x* 38)
+(defvar *ball-size-y* 34)
+
+(defmacro xor-ball (pixmap window gcontext x y)
+  `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y*
+		   ,window ,x ,y))
+
+(defconstant bball-gravity 1)
+(defconstant maximum-x-drift 7)
+
+(defvar *max-bball-x*)
+(defvar *max-bball-y*)
+
+(defstruct ball
+  (x (random (- *max-bball-x* *ball-size-x*)))
+  (y (random (- *max-bball-y* *ball-size-y*)))
+  (dx (if (zerop (random 2)) (random maximum-x-drift)
+	  (- (random maximum-x-drift))))
+  (dy 0))
+
+(defun get-bounce-image ()
+  "Returns the pixmap to be bounced around the screen."
+  (xlib::bitmap-image   #*000000000000000000000000000000000000
+			#*000000000000000000000000000000000000
+			#*000000000000000000001000000010000000
+			#*000000000000000000000000000100000000
+			#*000000000000000000000100001000000000
+			#*000000000000000010000000010000000000
+			#*000000000000000000100010000000000000
+			#*000000000000000000001000000000000000
+			#*000000000001111100000000000101010000
+			#*000000000010000011000111000000000000
+			#*000000000100000000111000000000000000
+			#*000000000100000000000000000100000000
+			#*000000000100000000001000100010000000
+			#*000000111111100000010000000001000000
+			#*000000111111100000100000100000100000
+			#*000011111111111000000000000000000000
+			#*001111111111111110000000100000000000
+			#*001111111111111110000000000000000000
+			#*011111111111111111000000000000000000
+			#*011111111111111111000000000000000000
+			#*111111111111110111100000000000000000
+			#*111111111111111111100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111101100000000000000000
+			#*111111111111111111100000000000000000
+			#*111111111111110111100000000000000000
+			#*011111111111111111000000000000000000
+			#*011111111111011111000000000000000000
+			#*001111111111111110000000000000000000
+			#*001111111111111110000000000000000000
+			#*000011111111111000000000000000000000
+			#*000000111111100000000000000000000000
+			#*000000000000000000000000000000000000))
+
+
+(defun bounce-1-ball (pixmap window gcontext ball)
+  (let ((x (ball-x ball))
+	(y (ball-y ball))
+	(dx (ball-dx ball))
+	(dy (ball-dy ball)))
+    (xor-ball pixmap window gcontext x y)
+    (setq x (+ x dx))
+    (setq y (+ y dy))
+    (if (or (< x 0) (> x (- *max-bball-x* *ball-size-x*)))
+	(setq x (- x dx)
+	      dx (- dx)))
+    (if (> y (- *max-bball-y* *ball-size-y*))
+	(setq y (- y dy)
+	      dy (- dy)))
+    (setq dy (+ dy bball-gravity))
+    (setf (ball-x ball) x)
+    (setf (ball-y ball) y)
+    (setf (ball-dx ball) dx)
+    (setf (ball-dy ball) dy)
+    (xor-ball pixmap window gcontext x y)))
+
+(defun bounce-balls (display window how-many duration)
+  (xlib:clear-area window)
+  (xlib:display-force-output display)
+  (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
+    (let* ((balls (do ((i 0 (1+ i))
+		       (list () (cons (make-ball) list)))
+		      ((= i how-many) list)))
+	   (gcontext (xlib:create-gcontext :drawable window
+					   :foreground *white-pixel*
+					   :background *black-pixel*
+					   :function boole-xor
+					   :exposures :off))
+	   (bounce-pixmap (xlib:create-pixmap :width 38 :height 34 :depth 1
+					      :drawable window))
+	   (pixmap-gc (xlib:create-gcontext :drawable bounce-pixmap
+					    :foreground *white-pixel*
+					    :background *black-pixel*)))
+      (xlib:put-image bounce-pixmap pixmap-gc (get-bounce-image)
+		      :x 0 :y 0 :width 38 :height 34)
+      (xlib:free-gcontext pixmap-gc)
+      (dolist (ball balls)
+	(xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
+      (xlib:display-force-output display)
+      (dotimes (i duration)
+	(dolist (ball balls)
+	  (bounce-1-ball bounce-pixmap window gcontext ball))
+	(xlib:display-force-output display)
+	(sleep *delay*))
+      (xlib:free-pixmap bounce-pixmap)
+      (xlib:free-gcontext gcontext))))
+
+#+nil
+(defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
+  34 34 700 500
+  "Bouncing balls in space."
+  (bounce-balls *display*  *window* how-many duration))
diff --git a/clx/demo/gl-test.lisp b/clx/demo/gl-test.lisp
new file mode 100644
index 000000000..453433ded
--- /dev/null
+++ b/clx/demo/gl-test.lisp
@@ -0,0 +1,480 @@
+#+cmu
+(ext:file-comment "$Id: gl-test.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage :gl-test
+  (:use :common-lisp :xlib)
+  (:export "TEST" "CLX-TEST"))
+
+(in-package :gl-test)
+
+
+(defun test (function &key (host "") (display 0) (width 200) (height 200))
+  (let* ((display (open-display host :display display))
+         (screen (display-default-screen display))
+         (root (screen-root screen))
+         ctx)
+    (unwind-protect
+         (progn
+           ;;; Inform the server about us.
+           (glx::client-info display)
+           (let* ((visual (glx:choose-visual screen '(:glx-rgba
+                                                      (:glx-red-size 1)
+                                                      (:glx-green-size 1)
+                                                      (:glx-blue-size 1)
+                                                      :glx-double-buffer)))
+                  (colormap (create-colormap (glx:visual-id visual) root))
+                  (window (create-window :parent root
+                                         :x 10 :y 10 :width width :height height
+                                         :class :input-output
+                                         :background (screen-black-pixel screen)
+                                         :border (screen-black-pixel screen)
+                                         :visual (glx:visual-id visual)
+                                         :depth 24
+                                         :colormap colormap
+                                         :event-mask '(:structure-notify :exposure)))
+                  (gc (create-gcontext :foreground (screen-white-pixel screen)
+                                       :background (screen-black-pixel screen)
+                                       :drawable window
+                                       :font (open-font display "fixed"))))
+             (set-wm-properties window
+                                :name "glx-test"
+                                :resource-class "glx-test"
+                                :command (list "glx-test")
+                                :x 10 :y 10 :width width :height height
+                                :min-width width :min-height height
+                                :initial-state :normal)
+
+             (setf ctx (glx:create-context screen (glx:visual-id visual)))
+             (map-window window)
+             (glx:make-current window ctx)
+
+             (funcall function display window)
+
+             (unmap-window window)
+             (free-gcontext gc)))
+      
+      (when ctx (glx:destroy-context ctx))
+      (close-display display))))
+
+
+;;; Tests
+
+
+(defun no-floats (display window)
+  (declare (ignore display window))
+  (gl:color-3s #x7fff #x7fff 0)
+  (gl:begin gl:+polygon+)
+  (gl:vertex-2s 0 0)
+  (gl:vertex-2s 1 0)
+  (gl:vertex-2s 1 1)
+  (gl:vertex-2s 0 1)
+  (gl:end)
+  (glx:swap-buffers)
+  (sleep 5))
+
+
+(defun anim (display window)
+  (declare (ignore display window))
+  (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0)
+  (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0)
+  (gl:line-width 2.0s0)
+  (loop
+     repeat 361
+     for angle upfrom 0.0s0 by 1.0s0
+     do (progn
+          (gl:clear gl:+color-buffer-bit+)
+          (gl:push-matrix)
+          (gl:translate-f 0.5s0 0.5s0 0.0s0)
+          (gl:rotate-f angle 0.0s0 0.0s0 1.0s0)
+          (gl:translate-f -0.5s0 -0.5s0 0.0s0)
+          (gl:begin gl:+polygon+ #-(and) gl:+line-loop+)
+          (gl:color-3ub 255 0 0)
+          (gl:vertex-2f 0.25s0 0.25s0)
+          (gl:color-3ub 0 255 0)
+          (gl:vertex-2f 0.75s0 0.25s0)
+          (gl:color-3ub 0 0 255)
+          (gl:vertex-2f 0.75s0 0.75s0)
+          (gl:color-3ub 255 255 255)
+          (gl:vertex-2f 0.25s0 0.75s0)
+          (gl:end)
+          (gl:pop-matrix)
+          (glx:swap-buffers)
+          (sleep 0.02)))
+  (sleep 3))
+
+
+(defun anim/list (display window)
+  (declare (ignore display window))
+  (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0)
+  (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0)
+  (let ((list (gl:gen-lists 1)))
+    (gl:new-list list gl:+compile+)
+    (gl:begin gl:+polygon+)
+    (gl:color-3ub 255 0 0)
+    (gl:vertex-2f 0.25s0 0.25s0)
+    (gl:color-3ub 0 255 0)
+    (gl:vertex-2f 0.75s0 0.25s0)
+    (gl:color-3ub 0 0 255)
+    (gl:vertex-2f 0.75s0 0.75s0)
+    (gl:color-3ub 255 255 255)
+    (gl:vertex-2f 0.25s0 0.75s0)
+    (gl:end)
+    (glx:render)
+    (gl:end-list)
+
+    (loop
+       repeat 361
+       for angle upfrom 0.0s0 by 1.0s0
+       do (progn
+            (gl:clear gl:+color-buffer-bit+)
+            (gl:push-matrix)
+            (gl:rotate-f angle 0.0s0 0.0s0 1.0s0)
+            (gl:call-list list)
+            (gl:pop-matrix)
+            (glx:swap-buffers)
+            (sleep 0.02))))
+  
+  (sleep 3))
+
+
+;;; glxgears
+
+(defconstant +pi+ (coerce pi 'single-float))
+(declaim (type single-float +pi+))
+
+
+(defun gear (inner-radius outer-radius width teeth tooth-depth)
+  (let ((r0 inner-radius)
+        (r1 (/ (- outer-radius tooth-depth) 2.0s0))
+        (r2 (/ (+ outer-radius tooth-depth) 2.0s0))
+        (da (/ (* 2.0s0 +pi+) teeth 4.0s0)))
+    (gl:shade-model gl:+flat+)
+    (gl:normal-3f 0.0s0 0.0s0 1.0s0)
+
+    ;; Front face.
+    (gl:begin gl:+quad-strip+)
+    (dotimes (i (1+ teeth))
+      (let ((angle (/ (* i 2.0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:vertex-3f (* r0 (cos angle))
+                      (* r0 (sin angle))
+                      (* width 0.5s0))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width 0.5s0))
+        (when (< i teeth)
+          (gl:vertex-3f (* r0 (cos angle))
+                        (* r0 (sin angle))
+                        (* width 0.5s0))
+          (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                        (* r1 (sin (+ angle (* 3 da))))
+                        (* width 0.5s0)))))
+    (gl:end)
+
+
+    ;; Draw front sides of teeth.
+    (gl:begin gl:+quads+)
+    (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0))
+    (dotimes (i teeth)
+      (let ((angle (/ (* i 2.0s0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width 0.5s0))
+        (gl:vertex-3f (* r2 (cos (+ angle da)))
+                      (* r2 (sin (+ angle da)))
+                      (* width 0.5s0))
+        (gl:vertex-3f (* r2 (cos (+ angle (* 2 da))))
+                      (* r2 (sin (+ angle (* 2 da))))
+                      (* width 0.5s0))
+        (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                      (* r1 (sin (+ angle (* 3 da))))
+                      (* width 0.5s0))))
+    (gl:end)
+
+    (gl:normal-3f 0.0s0 0.0s0 -1.0s0)
+                 
+    ;; Draw back face.
+    (gl:begin gl:+quad-strip+)
+    (dotimes (i (1+ teeth))
+      (let ((angle (/ (* i 2.0s0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width -0.5s0))
+        (gl:vertex-3f (* r0 (cos angle))
+                      (* r0 (sin angle))
+                      (* width -0.5s0))
+        (when (< i teeth)
+          (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                        (* r1 (sin (+ angle (* 3 da))))
+                        (* width -0.5s0))
+          (gl:vertex-3f (* r0 (cos angle))
+                        (* r0 (sin angle))
+                        (* width 0.5s0)))))
+    (gl:end)
+
+    ;; Draw back sides of teeth.
+    (gl:begin gl:+quads+)
+    (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0))
+    (dotimes (i teeth)
+      (let ((angle (/ (* i 2.0s0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                      (* r1 (sin (+ angle (* 3 da))))
+                      (* width -0.5s0))
+        (gl:vertex-3f (* r2 (cos (+ angle (* 2 da))))
+                      (* r2 (sin (+ angle (* 2 da))))
+                      (* width -0.5s0))
+        (gl:vertex-3f (* r2 (cos (+ angle da)))
+                      (* r2 (sin (+ angle da)))
+                      (* width -0.5s0))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width -0.5s0))))
+    (gl:end)
+
+    ;; Draw outward faces of teeth.
+    (gl:begin gl:+quad-strip+)
+    (dotimes (i teeth)
+      (let ((angle (/ (* i 2.0s0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width 0.5s0))
+        (gl:vertex-3f (* r1 (cos angle))
+                      (* r1 (sin angle))
+                      (* width -0.5s0))
+        (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
+               (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
+               (len (sqrt (+ (* u u) (* v v)))))
+          (setf u (/ u len)
+                v (/ v len))
+          (gl:normal-3f v u 0.0s0)
+          (gl:vertex-3f (* r2 (cos (+ angle da)))
+                        (* r2 (sin (+ angle da)))
+                        (* width 0.5s0))
+          (gl:vertex-3f (* r2 (cos (+ angle da)))
+                        (* r2 (sin (+ angle da)))
+                        (* width -0.5s0))
+          (gl:normal-3f (cos angle) (sin angle) 0.0s0)
+          (gl:vertex-3f (* r2 (cos (+ angle (* 2 da))))
+                        (* r2 (sin (+ angle (* 2 da))))
+                        (* width 0.5s0))
+          (gl:vertex-3f (* r2 (cos (+ angle (* 2 da))))
+                        (* r2 (sin (+ angle (* 2 da))))
+                        (* width -0.5s0))
+          (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))
+                v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da))))))
+          (gl:normal-3f v (- u) 0.0s0)
+          (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                        (* r1 (sin (+ angle (* 3 da))))
+                        (* width 0.5s0))
+          (gl:vertex-3f (* r1 (cos (+ angle (* 3 da))))
+                        (* r1 (sin (+ angle (* 3 da))))
+                        (* width -0.5s0))
+          (gl:normal-3f (cos angle) (sin angle) 0.0s0))))
+
+    (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0))
+    (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0))
+
+    (gl:end)
+
+    (gl:shade-model gl:+smooth+)
+                 
+    ;; Draw inside radius cylinder.
+    (gl:begin gl:+quad-strip+)
+    (dotimes (i (1+ teeth))
+      (let ((angle (/ (* i 2.0s0 +pi+) teeth)))
+        (declare (type single-float angle))
+        (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0)
+        (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0))
+        (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))
+    (gl:end)))
+
+
+(defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle)
+  (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+))
+
+  (gl:push-matrix)
+  (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0)
+  (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0)
+  (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0)
+
+  (gl:push-matrix)
+  (gl:translate-f -3.0s0 -2.0s0 0.0s0)
+  (gl:rotate-f angle 0.0s0 0.0s0 1.0s0)
+  (gl:call-list gear-1)
+  (gl:pop-matrix)
+
+  (gl:push-matrix)
+  (gl:translate-f 3.1s0 -2.0s0 0.0s0)
+  (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0)
+  (gl:call-list gear-2)
+  (gl:pop-matrix)
+
+  (gl:push-matrix)
+  (gl:translate-f -3.1s0 4.2s0 0.0s0)
+  (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0)
+  (gl:call-list gear-3)
+  (gl:pop-matrix)
+
+  (gl:pop-matrix))
+
+
+(defun reshape (width height)
+  (gl:viewport 0 0 width height)
+  (let ((h (coerce (/ height width) 'double-float)))
+    (gl:matrix-mode gl:+projection+)
+    (gl:load-identity)
+    (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0))
+
+  (gl:matrix-mode gl:+modelview+)
+  (gl:load-identity)
+  (gl:translate-f 0.0s0 0.0s0 -40.0s0))
+
+             
+(defun init ()
+  (let (gear-1 gear-2 gear-3)
+    ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0))
+    ;;(gl:enable gl:+cull-face+)
+    ;;(gl:enable gl:+lighting+)
+    ;;(gl:enable gl:+light0+)
+    ;;(gl:enable gl:+depth-test+)
+
+    ;; Make the gears.
+    (setf gear-1 (gl:gen-lists 1))
+    (gl:new-list gear-1 gl:+compile+)
+    (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0))
+    (gear 1.0s0 4.0s0 1.0s0 20 0.7s0)
+    (gl:end-list)
+
+    (setf gear-2 (gl:gen-lists 1))
+    (gl:new-list gear-2 gl:+compile+)
+    (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0))
+    (gear 0.5s0 2.0s0 2.0s0 10 0.7s0)
+    (gl:end-list)
+
+    (setf gear-3 (gl:gen-lists 1))
+    (gl:new-list gear-3 gl:+compile+)
+    (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0))
+    (gear 1.3s0 2.0s0 0.5s0 10 0.7s0)
+    (gl:end-list)
+
+    ;;(gl:enable gl:+normalize+)
+
+    (values gear-1 gear-2 gear-3)))
+
+
+(defun gears* (display window)
+  (declare (ignore display window))
+
+  (gl:enable gl:+cull-face+)
+  (gl:enable gl:+lighting+)
+  (gl:enable gl:+light0+)
+  (gl:enable gl:+normalize+)
+  (gl:enable gl:+depth-test+)
+
+  (reshape 300 300)
+
+  ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0))
+
+  (let (list)
+    (declare (ignore list))
+    #-(and)
+    (progn
+      (setf list (gl:gen-lists 1))
+      (gl:new-list list gl:+compile+)
+      ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0))
+      (gear 1.0s0 4.0s0 1.0s0 20 0.7s0)
+      (glx:render)
+      (gl:end-list))
+
+
+    (loop
+       ;;for angle from 0.0s0 below 361.0s0 by 1.0s0
+       with angle single-float = 0.0s0
+       with dt = 0.004s0
+       repeat 2500
+       do (progn
+
+            (incf angle (* 70.0s0 dt))       ; 70 degrees per second
+            (when (< 3600.0s0 angle)
+              (decf angle 3600.0s0))
+
+            (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+))
+
+            (gl:push-matrix)
+            (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0)
+
+
+            (gl:push-matrix)
+            (gl:translate-f -3.0s0 -2.0s0 0.0s0)
+            (gl:rotate-f angle 0.0s0 0.0s0 1.0s0)
+            (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0))
+            (gear 1.0s0 4.0s0 1.0s0 20 0.7s0)
+            (gl:pop-matrix)
+
+            
+            (gl:push-matrix)
+            (gl:translate-f 3.1s0 -2.0s0 0.0s0)
+            (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0)
+            (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0))
+            (gear 0.5s0 2.0s0 2.0s0 10 0.7s0)
+            (gl:pop-matrix)
+
+
+            (gl:push-matrix)
+            (gl:translate-f -3.1s0 4.2s0 0.0s0)
+            (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0)
+            (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0))
+            (gear 1.3s0 2.0s0 0.5s0 10 0.7s0)
+            (gl:pop-matrix)
+
+
+            (gl:pop-matrix)
+
+            (glx:swap-buffers)
+            ;;(sleep 0.025)
+            )))
+  
+
+  ;;(sleep 3)
+  )
+
+
+(defun gears (display window)
+  (declare (ignore window))
+  (let ((view-rotx 20.0s0)
+        (view-roty 30.0s0)
+        (view-rotz 0.0s0)
+        (angle 0.0s0)
+        (frames 0)
+        (dt 0.004s0)                ; *** This is dynamically adjusted
+        ;;(t-rot-0 -1.0d0)
+        ;;(t-rate-0 -1.d0)
+        gear-1 gear-2 gear-3)
+
+    (multiple-value-setq (gear-1 gear-2 gear-3)
+      (init))
+
+    (loop
+       (event-case (display :timeout 0.01 :force-output-p t)
+         (configure-notify (width height)
+                           (reshape width height)
+                           t)
+         (key-press (code)
+                    (format t "Key pressed: ~S~%" code)
+                    (return-from gears t)))
+
+       (incf angle (* 70.0s0 dt))       ; 70 degrees per second
+       (when (< 3600.0s0 angle)
+         (decf angle 3600.0s0))
+
+       (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle)
+       (glx:swap-buffers)
+       
+       (incf frames)
+
+       ;; FPS calculation goes here
+       )))
diff --git a/clx/demo/hello.lisp b/clx/demo/hello.lisp
index a3fbd88d8..b2a273db5 100644
--- a/clx/demo/hello.lisp
+++ b/clx/demo/hello.lisp
@@ -1,5 +1,8 @@
 ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
 
+#+cmu
+(ext:file-comment "$Id: hello.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+
 (in-package :xlib)
 
 (defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
diff --git a/clx/demo/mandel.lisp b/clx/demo/mandel.lisp
new file mode 100644
index 000000000..a877191f4
--- /dev/null
+++ b/clx/demo/mandel.lisp
@@ -0,0 +1,561 @@
+#+cmu
+(ext:file-comment "$Id: mandel.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+
+(defpackage "XMANDEL"
+  (:use "CL")
+  (:export "NEW-WINDOW" "EVENT-LOOP"))
+
+(in-package "XMANDEL")
+
+(defvar *display* (xlib:open-default-display))
+(defvar *screen* (xlib:display-default-screen *display*))
+
+(defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id")
+(defvar *colmap* nil)
+(defvar *helpwin* nil)
+(defvar *zoom-table* (make-hash-table))
+(defvar *zoomcolmap* (xlib:create-gcontext
+		      :drawable (xlib:screen-root *screen*)
+		      :foreground (xlib:screen-white-pixel *screen*)
+		      :function boole-xor))
+(defvar *white* (xlib:create-gcontext
+		 :drawable (xlib:screen-root *screen*)
+		 :foreground (xlib:screen-white-pixel *screen*)
+		 ))
+(defvar *winmap* (make-hash-table))
+(defvar *textmap* (xlib:create-gcontext
+		   :drawable (xlib:screen-root *screen*)
+		   :foreground (xlib:screen-black-pixel *screen*)
+		   :background (xlib:screen-white-pixel *screen*)))
+
+;;; OK, this is an ugly hack to make sure we can handle
+;;; shift and modstate in a sane way, alas we can't 100% rely
+;;; on "current state of keyboard", since we only process events
+;;; with a noticeable delay, at eth best of times, so a fast keyboarder
+;;; can fool us, we are, however, IIRC, guaranteed that all events are
+;;; serialised, so...
+(defvar *modstate* nil)
+(declaim (list *modstate*))
+(defun make-shift-foo ()
+  (let ((rv 0))
+    (if (member :shift *modstate*)
+	(setf rv 1))
+    (if (member :character-set-switch *modstate*)
+	(setf rv (+ rv 2)))
+    rv))
+
+(defstruct (mandel-square (:conc-name ms-))
+  (x 0 :type fixnum)
+  (y 0 :type fixnum)
+  (s 512 :type fixnum)
+  (base-r 0.0d0 :type double-float)
+  (base-i 0.0d0 :type double-float)
+  (maxiter 1024 :type fixnum)
+  (dr 0.0d0 :type double-float)
+  (di 0.0d0 :type double-float)
+  win
+  )
+
+(defun make-queue (&rest args)
+  (apply #'make-instance 'queue args))
+
+(defclass queue ()
+  ((head :initform nil :accessor q-head)
+   (tail :initform nil :accessor q-tail)))
+(defclass out-queue ()
+  ((win-queues :accessor win-queues :initarg :xyzzy-1)
+   (seen-windows :accessor windows :initform nil)
+   (win-list :accessor win-list :initarg :xyzzy-2)
+   (last-window :accessor last-window :initform nil))
+  (:default-initargs :xyzzy-1 (make-hash-table)
+		     :xyzzy-2 (make-instance 'queue)))
+
+(defvar *sysqueue* (make-instance 'out-queue))
+
+(defgeneric empty-p (queue))
+(defgeneric empty (queue))
+(defgeneric empty-win (queue win))
+(defgeneric enqueue (queue item))
+(defgeneric queue-push (queue item))
+(defgeneric dequeue (queue))
+
+(defmethod empty-p ((q null))
+  t)
+(defmethod empty-p ((q queue))
+  (null (q-head q)))
+(defmethod empty-p ((q out-queue))
+  (let ((coll nil))
+    (maphash #'(lambda (key val)
+		 (declare (ignore key))
+		 (push (empty-p val) coll))
+	     (win-queues q))
+    (every #'identity coll)))
+
+(defmethod empty ((q null))
+  nil)
+(defmethod empty ((q queue))
+  (setf (q-head q) nil)
+  (setf (q-tail q) nil))
+(defmethod empty ((q out-queue))
+  (maphash #'(lambda (key val) (declare (ignore key)) (empty val))
+	   (win-queues q)))
+(defmethod empty-win ((q out-queue) win)
+  (let ((temp-queue (gethash win (win-queues q))))
+    (empty temp-queue)))
+  
+(defmethod enqueue ((q queue) item)
+  (cond ((empty-p q)
+	 (setf (q-head q) (cons item nil))
+	 (setf (q-tail q) (q-head q)))
+	(t (setf (cdr (q-tail q)) (cons item nil))
+	   (setf (q-tail q) (cdr (q-tail q))))))
+(defmethod enqueue ((q out-queue) item)
+  (let ((windows (q-head (win-list q)))
+	(win (ms-win item)))
+    (declare (type xlib:window win))
+    (unless (member win windows)
+      (enqueue (win-list q) win))
+    (unless (member win (windows q))
+      (push win (windows q)))
+    (let ((temp-queue (gethash win (win-queues q))))
+      (if (null temp-queue)
+	  (let ((new (make-queue)))
+	    (setf (gethash win (win-queues q)) new)
+	    (enqueue new item))
+	(enqueue temp-queue item)))))
+
+(defmethod queue-push ((q queue) item)
+  (cond ((empty-p q)
+	 (setf (q-head q) (cons item nil))
+	 (setf (q-tail q) (q-head q)))
+	(t (setf (q-head q) (cons item (q-head q))))))
+(defmethod queue-push ((q out-queue) item)
+  (let ((windows (q-head (win-list q)))
+	(win (ms-win item)))
+    (declare (type xlib:window win))
+    (unless (member win windows)
+      (enqueue (win-list q) win))
+    (unless (member win (windows q))
+      (push win (windows q)))
+    (let ((temp-queue (gethash win (win-queues q))))
+      (if (null temp-queue)
+	  (let ((new (make-queue)))
+	    (setf (gethash win (win-queues q)) new)
+	    (queue-push new item))
+	(queue-push temp-queue item)))))
+
+(defmethod dequeue ((q out-queue))
+  (if (empty-p q)
+      nil
+      (let ((windows (win-list q)))
+	(do* ((next (dequeue windows))
+	      (finished nil)
+	      (val nil)
+	      (temp-queue (gethash next (win-queues q))
+			  (gethash next (win-queues q))))
+	     (finished val) 
+	  (cond ((empty-p temp-queue)
+		 (setf next (dequeue windows)))
+		(t (setf val (dequeue temp-queue))
+		   (unless (empty-p temp-queue)
+		     (enqueue windows next))
+		   (setf finished t)))))))
+(defmethod dequeue ((q queue))
+  (prog1
+    (car (q-head q))
+    (if (not (empty-p q))
+	(setf (q-head q) (cdr (q-head q))))
+    (if (null (q-head q))
+	(progn
+	  (setf (q-head q) nil)
+	  (setf (q-tail q) nil)))))
+
+(defun iter (rc ic max)
+  (declare (double-float rc ic)
+	   (fixnum max))
+  (do ((x 0.0d0 (the double-float (+ (- (* x x) (* y y)) rc)))
+       (y 0.0d0 (the double-float (+ (* 2.0d0 x y) ic)))
+       (n 1 (the fixnum (1+ n))))
+      ((or (>= n max) (>= (+ (* x x) (* y y)) 4.0d0))
+       n)))
+;;; (a+bi)^2        -->
+;;; (a+bi)(a+bi)    -->
+;;; a^2+2abi+(bi)^2 -->
+;;; a^2+2abi-b^2
+
+(defclass zoomer ()
+  ((zoom-type :initarg :type :reader zoom-type :type fixnum)
+   (start-x :initarg :x :reader start-x :type fixnum)
+   (start-y :initarg :y :reader start-y :type fixnum)
+   (stop-x :accessor stop-x :initform -1 :type fixnum)
+   (stop-y :accessor stop-y :initform -1 :type fixnum)
+   (win :reader win :initarg :win)))
+
+;;;(defmethod print-object ((object zoomer) stream)
+;;;  (format stream "<zoomer [type ~a] [~a ~a] -> [~a ~a]>~%"
+;;;	  (zoom-type object) (start-x object) (start-y object)
+;;;	  (stop-x object) (stop-y object)))
+
+(defun init-colours ()
+  (unless *colmap*
+    (setf *colmap* (make-array 256 :element-type 'xlib:gcontext :initial-element *zoomcolmap*))
+    (setf (aref *colmap* 0) (xlib:create-gcontext
+		    :drawable (xlib:screen-root *screen*)
+		    :foreground (xlib:alloc-color
+				 (xlib:screen-default-colormap *screen*)
+				 (xlib:make-color :red 0
+						  :green 0
+						  :blue 0))))
+    (loop for index from 1 to 255
+	  do (setf (aref *colmap* index)
+		   (xlib:create-gcontext
+		    :drawable (xlib:screen-root *screen*)
+		    :foreground (xlib:alloc-color
+				 (xlib:screen-default-colormap *screen*)
+				 (xlib:make-color :red (random 1.0)
+						  :green (random 1.0)
+						  :blue (random 1.0))))))))
+(defmacro modcol (col max)
+  `(if (= ,col ,max) 0 (1+ (mod ,col 255))))
+
+(defun plot (win col x y max)
+  (declare (fixnum col x y max))
+  (let ((col (modcol col max)))
+    (xlib:draw-point win (aref *colmap* col) x y)
+    (setf (aref (the (simple-array (integer 0 255) (512 512))
+		  (gethash win *backing-store*)) x y) col)))
+
+(defun display-help ()
+  (unless *helpwin*
+    (setf *helpwin* (xlib:create-window
+		     :parent (xlib:screen-root *screen*)
+		     :x 512
+		     :y 512
+		     :width 310
+		     :height 180
+		     :event-mask (xlib:make-event-mask :exposure)
+		     :backing-store :always
+		     :background (xlib:screen-white-pixel *screen*)))
+    (xlib:map-window *helpwin*)
+    (xlib:display-force-output *display*))
+  (unless (xlib:gcontext-font *textmap*)
+    (let ((fixed (xlib:list-fonts *display* "fixed"))
+	  font)
+      (if fixed
+	  (setf font (xlib:open-font *display* "fixed"))
+	(error "Could not open suitable font"))
+      (setf (xlib:gcontext-font *textmap*) (if (consp fixed)
+					       (car fixed)
+					     fixed))))
+  (xlib:draw-rectangle *helpwin* *white* 0 0 (xlib:drawable-width *helpwin*) (xlib:drawable-height *helpwin*) t)
+  (xlib:draw-glyphs *helpwin* *textmap* 10 13 "Button 1: Zoom same")
+  (xlib:draw-glyphs *helpwin* *textmap* 10 33 "Button 2: Zoom new")
+  (xlib:draw-glyphs *helpwin* *textmap* 10 53 "Button 3: Zoom out, same")
+  (xlib:draw-glyphs *helpwin* *textmap* 10 93 "In general, click to zoom centred on mouse,")
+  (xlib:draw-glyphs *helpwin* *textmap* 10 113 "drag to zoom a region.")
+  (xlib:draw-glyphs *helpwin* *textmap* 10 153 "Q: quit")
+  (xlib:display-force-output *display*))
+
+(defun repaint-window (win x-low y-low x-high y-high)
+  (declare (fixnum x-low y-low x-high y-high))
+  (if (eq win *helpwin*)
+      (display-help)
+    (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*))))
+      (loop for y of-type fixnum from y-low to y-high
+	    do
+	    (loop for x of-type fixnum from x-low to x-high
+		  do (xlib:draw-point win (aref *colmap* (aref bs x y)) x y))))))
+
+(defun fill-square (win col x y s max)
+  (declare (fixnum col x y s max))
+  (let ((col (modcol col max)))
+    (xlib:draw-rectangle win (aref *colmap* col) x y s s t)
+    (let ((bs (the (simple-array (integer 0 255) (512 512)) (gethash win *backing-store*))))
+      (loop for px of-type fixnum from x to (1- (+ x s))
+	    do (loop for py of-type fixnum from y to (1- (+ y s))
+		     do (setf (aref bs px py) col))))))
+
+(defun make-square (win x y side bx by dx dy &optional (maxiter 1024))
+  (declare (xlib:window win)
+	   (fixnum x y side maxiter)
+	   (double-float bx by dx dy))
+  (let ((sq (make-mandel-square
+	     :x x :y y :s side
+	     :base-r bx :base-i by
+	     :dr dx :di dy
+	     :maxiter maxiter
+	     :win win)))
+    (queue-push *sysqueue* sq)))
+
+(defun mandel-win (win lx ly hx hy &optional (maxiter 1024))
+  (declare (xlib:window win)
+	   (double-float lx ly hx hy)
+	   (fixnum maxiter))
+  (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float))
+	(dy (coerce (/ (- hy ly) 512.0d0) 'double-float)))	    
+    (setf (gethash win *winmap*)
+	  (make-mandel-square :x 0 :y 0 :s 512
+			      :base-r lx :base-i ly
+			      :dr dx :di dy :maxiter maxiter))
+    (make-square win 0 256   256 lx ly dx dy maxiter)
+    (make-square win 256 256 256 lx ly dx dy maxiter)
+    (make-square win 256 0   256 lx ly dx dy maxiter)
+    (make-square win 0 0     256 lx ly dx dy maxiter)))
+
+(defun new-window (lx ly hx hy &optional (maxiter 1024))
+  (let ((win (xlib:create-window
+	      :parent (xlib:screen-root *screen*)
+	      :x (+ 100 (random 50)) :y (+ 100 (random 50))
+	      :width 512 :height 512
+	      :bit-gravity :center
+	      :event-mask (xlib:make-event-mask
+			   :button-motion :button-press :button-release
+			   :key-press :exposure)))
+	(ar (make-array '(512 512)
+			:element-type '(integer 0 255) :initial-element 0))
+	)
+    (setf (gethash win *backing-store*) ar)
+    (xlib:map-window win)
+    (mandel-win win
+		(coerce lx 'double-float) (coerce ly 'double-float)
+		(coerce hx 'double-float) (coerce hy 'double-float) maxiter)))
+
+(defun fill-square-p (ix iy s bx by dx dy max win)
+  (declare (fixnum ix iy s max)
+	   (double-float bx by dx dy))
+  (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) 
+    (and
+     (loop for px from ix below (+ ix s)
+	   for x of-type double-float = (+ bx (* px dx))
+	   with y = (+ by (* iy dy))
+	   for i = (iter x y max)
+	   do (plot win i px iy max)
+	   while (= i norm)
+	   finally (return t))
+     (loop for py from iy below (+ s iy)
+	   for y of-type double-float = (+ by (* py dy))
+	   with x = (+ bx (* ix dx))
+	   for i = (iter x y max)
+	   do (plot win i ix py max)
+	   while (= i norm)
+	   finally (return t))
+     (loop for px from (1- (+ s ix)) downto ix
+	   for x of-type double-float = (+ bx (* px dx))
+	   with y = (+ by (* dy (1- (+ s iy))))
+	   for i = (iter x y max)
+	   do (plot win i px iy max)
+	   if (/= i norm) return nil
+	   finally (return t))
+     (loop for py from (1- (+ s iy)) downto iy
+	   for y of-type double-float = (+ by (* py dy))
+	   with x = (+ bx (* dx (1- (+ s ix))))
+	   for i = (iter x y max)
+	   do (plot win i ix py max)
+	   if (/= i norm) return nil
+	   finally (return t)))))
+
+(defmacro z (base delta int)
+  `(+ ,base (* ,delta ,int)))
+(defun draw-square (square)
+  (declare (mandel-square square))
+  (let ((dx (ms-dr square))
+	(dy (ms-di square))
+	(base-x (ms-base-r square))
+	(base-y (ms-base-i square))
+	(maxiter (ms-maxiter square))
+	(win (ms-win square))
+	(x (ms-x square))
+	(y (ms-y square))
+	(s (ms-s square))
+	)
+    (declare (double-float dx dy base-x base-y)
+	     (fixnum x y s maxiter))
+          (cond
+	    ((= s 2)
+	     (plot win
+		   (iter (z base-x dx (1+ x)) (z base-y dy (1+ y)) maxiter)
+		   (1+ x) (1+ y) maxiter)
+	     (plot win
+		   (iter (z base-x dx (1+ x)) (z base-y dy y) maxiter)
+		   (1+ x) y maxiter)
+	     (plot win
+		   (iter (z base-x dx x) (z base-y dy (1+ y)) maxiter)
+		   x (1+ y) maxiter)
+	     (plot win
+		   (iter (z base-x dx x) (z base-y dy y) maxiter)
+		   x y maxiter))
+	    ((fill-square-p x y s base-x base-y dx dy maxiter win)
+	     (fill-square win
+			  (iter (z base-x dx x) (z base-y dy y) maxiter)
+			  x y s maxiter))
+	    (t (let ((new-s (/ s 2)))
+		 (make-square win
+			      x      y new-s
+			      base-x base-y
+			      dx dy
+			      maxiter)
+		 (make-square win
+			      x (+ y new-s)  new-s
+			      base-x base-y
+			      dx dy
+			      maxiter)
+		 (make-square win
+			      (+ x new-s) y  new-s
+			      base-x base-y
+			      dx dy
+			      maxiter)
+		 (make-square win
+			      (+ x new-s)  (+ y new-s)  new-s
+			      base-x base-y
+			      dx dy
+			      maxiter))))))
+
+(defun create-zoom (win x y button)
+  (setf (gethash win *zoom-table*)
+	(make-instance 'zoomer
+			 :x x :y y
+			 :win win
+			 :type (case button
+				      (1 :zoom-same)
+				      (2 :zoom-new)
+				      (3 :zoom-out)))))
+
+(defun update-zoom (win x y code)
+  (declare (ignore code)
+	   (fixnum x y))
+  (let ((zoomer (gethash win *zoom-table*)))
+    (when zoomer
+      (let ((new-side (max 0
+			   (- (the fixnum x) (the fixnum (start-x zoomer)))
+			   (- (the fixnum y) (the fixnum (start-y zoomer))))))
+	(let ((old-side (max 0
+			     (- (the fixnum (stop-x zoomer))
+				(the fixnum (start-x zoomer)))
+			     (- (the fixnum (stop-y zoomer))
+				(the fixnum (start-y zoomer))))))
+	  (xlib:draw-rectangle win *zoomcolmap*
+			       (the fixnum (start-x zoomer))
+			       (the fixnum (start-y zoomer)) 
+			       old-side old-side))
+	(setf (stop-x zoomer) (max (the fixnum (start-x zoomer))
+				   (the fixnum x)
+				   ))
+	(setf (stop-y zoomer) (max (the fixnum (start-y zoomer))
+				   (the fixnum y)
+				   ))
+	(xlib:draw-rectangle win *zoomcolmap*
+			     (the fixnum (start-x zoomer))
+			     (the fixnum (start-y zoomer)) 
+			     new-side new-side)
+	(xlib:display-force-output *display*)))))
+
+(defun finish-zoom (win x y code)
+  (declare (ignore code))
+  (let ((zoomer (gethash win *zoom-table*)))
+    (setf (stop-x zoomer) x)
+    (setf (stop-y zoomer) y)))
+
+(defun do-zoom (win)
+  (let ((zoomer (gethash win *zoom-table*)))
+    (declare (zoomer zoomer))
+    (setf (gethash win *zoom-table*) nil)
+    (let ((dx (- (the fixnum (stop-x zoomer)) (the fixnum (start-x zoomer))))
+	  (dy (- (the fixnum (stop-y zoomer)) (the fixnum (start-y zoomer))))
+	  (sq (gethash win *winmap*)))
+      (let ((side (max dx dy))
+	    (x (the fixnum (start-x zoomer)))
+	    (y (the fixnum (start-y zoomer)))
+	    lx hx ly hy
+	    )
+	(if (< side 5)
+	    (setf lx (+ (ms-base-r sq)
+			(* (- x 128) (ms-dr sq)))
+		  ly (+ (ms-base-i sq)
+			(* (- y 128) (ms-di sq)))
+		  hx (+ (ms-base-r sq)
+			(* (+ x 128) (ms-dr sq)))
+		  hy (+ (ms-base-i sq)
+			(* (+ y 128) (ms-di sq))))
+	    (setf lx (+ (ms-base-r sq)
+			(* x (ms-dr sq)))
+		  ly (+ (ms-base-i sq)
+			(* y (ms-dr sq))) 
+		  hx (+ (ms-base-r sq)
+			(* (+ side x) (ms-dr sq)))
+		  hy (+ (ms-base-i sq)
+			(* (+ side y) (ms-dr sq)))))
+;;;	(format t "DEBUG: zoomer is ~a~%~%" zoomer)
+	(case (zoom-type zoomer)
+	  (:zoom-new (new-window lx ly hx hy (ms-maxiter sq)))
+	  (:zoom-same (empty-win *sysqueue* win)
+		      (mandel-win win lx ly hx hy (ms-maxiter sq)))
+	  (:zoom-out (empty-win *sysqueue* win)
+		     (let ((br (ms-base-r sq))
+			   (bi (ms-base-i sq))
+			   (dr (ms-dr sq))
+			   (di (ms-di sq)))
+		       (mandel-win win
+				   (- br (* 512 dr)) (- bi (* 512 di))
+				   (+ (* 1024 dr) br) (+ (* 1024 di) bi)
+				   (ms-maxiter sq))))
+				 
+	  (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer))))))))
+
+(defun quit-window (window)
+  (let ((temp (gethash window (win-queues *sysqueue*))))
+    (when temp
+      (empty temp))))
+
+(defun event-loop ()
+  (init-colours)
+  (do ((quit nil)
+       (redisplay nil t))
+      ((eq quit 'quit))
+    (xlib:event-case (*display* :timeout 0)
+       (:button-press (window x y code)
+		      (create-zoom window x y code)
+		      t)
+       (:button-release (window x y code)
+			(finish-zoom window x y code)
+			(do-zoom window)
+			t)
+       (:motion-notify (window x y code)
+		       (update-zoom window x y code)
+		       t)
+       (:exposure (window  x y width height count)
+	    (let ((count count))
+	      (declare (ignore count)
+		      (fixnum x y width height))
+	     (when redisplay
+	       (repaint-window window x y (1- (+ x width)) (1- (+ y height)))))
+	    t)
+       (:key-press (window code)
+	  (case (xlib:keysym->character
+		 *display*
+		 (xlib:keycode->keysym *display* code (make-shift-foo)))
+	       (#\q (quit-window window))
+	       (#\? (display-help))
+	       ((:left-shift :right-shift)
+		(push :shift *modstate*))
+	       ((:left-control :right-control)
+		(push :ctrl *modstate*))
+	       (:character-set-switch
+		(push :character-set-switch *modstate*)))
+	  t)
+       (:key-release (window code)
+	  (let ((window window))
+	    (declare (ignore window))
+	    (case (xlib:keysym->character
+		   *display*
+		   (xlib:keycode->keysym *display* code 0))
+	      (:character-set-switch
+	       (setf *modstate* (delete :character-set-switch *modstate*)))
+	      ((:left-control :right-control)
+	       (setf *modstate* (delete :ctrl *modstate*)))
+	      ((:left-shift :right-shift)
+	       (setf *modstate* (delete :shift *modstate*)))))
+	  t))
+    (cond ((empty-p *sysqueue*)
+	   nil)
+	  (t (let ((square (dequeue *sysqueue*)))
+	       (draw-square square))))))
diff --git a/clx/demo/menu.lisp b/clx/demo/menu.lisp
index 80bc08eee..821635610 100644
--- a/clx/demo/menu.lisp
+++ b/clx/demo/menu.lisp
@@ -16,6 +16,9 @@
 ;;; express or implied warranty.  
 ;;;
 
+#+cmu
+(ext:file-comment "$Id")
+
 (in-package :xlib)
 
 
@@ -273,8 +276,8 @@
     ;; Make menu visible
     (MAP-WINDOW menu-window)))
 
-(defun just-say-lisp (host &optional (font-name "fixed"))
-  (let* ((display   (OPEN-DISPLAY host))
+(defun just-say-lisp (&optional (font-name "fixed"))
+  (let* ((display   (open-default-display))
 	 (screen    (first (DISPLAY-ROOTS display)))
 	 (fg-color  (SCREEN-BLACK-PIXEL screen))
 	 (bg-color  (SCREEN-WHITE-PIXEL screen))
@@ -303,7 +306,7 @@
 	 (parent-width 400)
 	 (parent-height 400)
 	 (parent    (CREATE-WINDOW :parent (SCREEN-ROOT screen)
-				   :override-redirect :on
+;;				   :override-redirect :on
 				   :x 100 :y 100
 				   :width parent-width :height parent-height
 				   :background bg-color
diff --git a/clx/demo/zoid.lisp b/clx/demo/zoid.lisp
index 0a313059f..a3bf4cef2 100644
--- a/clx/demo/zoid.lisp
+++ b/clx/demo/zoid.lisp
@@ -18,6 +18,9 @@
 ;;; express or implied warranty.
 ;;;
 
+#+cmu
+(ext:file-comment "$Id")
+
 (in-package :xlib)
 
 (export '(draw-filled-trapezoids
diff --git a/clx/dep-allegro.lisp b/clx/dep-allegro.lisp
new file mode 100644
index 000000000..ffc26a696
--- /dev/null
+++ b/clx/dep-allegro.lisp
@@ -0,0 +1,2213 @@
+;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
+
+;; 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.
+;;;
+
+#+cmu
+(ext:file-comment "$Id: dep-allegro.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+
+(in-package :xlib)
+
+(proclaim '(declaration array-register))
+
+;;; The size of the output buffer.  Must be a multiple of 4.
+(defparameter *output-buffer-size* 8192)
+
+;;; 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 (:compile-toplevel :load-toplevel :execute)
+  (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
+    "Speed compiler option for buffer code.")
+  (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
+    "Safety compiler option for buffer code.")
+  (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
+    "Debug compiler option for buffer code>")
+  (defun declare-bufmac ()
+    `(declare (optimize
+	       (speed ,+buffer-speed+)
+	       (safety ,+buffer-safety+)
+	       (debug ,+buffer-debug+))))
+  ;; 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+)
+	       (debug ,+buffer-debug+)))))
+
+(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 (clx-values int8))
+  #.(declare-buffun)
+  (the int8 (if (logbitp 7 x)
+		(the int8 (- x #x100))
+	      x)))
+
+(defun int8->card8 (x)
+  (declare (type int8 x))
+  (declare (clx-values card8))
+  #.(declare-buffun)
+  (the card8 (ldb (byte 8 0) x)))
+
+(defun card16->int16 (x)
+  (declare (type card16 x))
+  (declare (clx-values int16))
+  #.(declare-buffun)
+  (the int16 (if (logbitp 15 x)
+		 (the int16 (- x #x10000))
+		 x)))
+
+(defun int16->card16 (x)
+  (declare (type int16 x))
+  (declare (clx-values card16))
+  #.(declare-buffun)
+  (the card16 (ldb (byte 16 0) x)))
+
+(defun card32->int32 (x)
+  (declare (type card32 x))
+  (declare (clx-values int32))
+  #.(declare-buffun)
+  (the int32 (if (logbitp 31 x)
+		 (the int32 (- x #x100000000))
+		 x)))
+
+(defun int32->card32 (x)
+  (declare (type int32 x))
+  (declare (clx-values card32))
+  #.(declare-buffun)
+  (the card32 (ldb (byte 32 0) x)))
+
+)
+
+(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
+
+#+(or excl lcl3.0 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 (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-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values card8))
+  #.(declare-buffun)
+  (the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+			 :unsigned-byte)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :unsigned-byte) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values int8))
+  #.(declare-buffun)
+  (the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+			:signed-byte)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :signed-byte) v))
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values card16))
+  #.(declare-buffun)
+  (the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) 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 #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :unsigned-word) v))
+  
+(defun aref-int16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values int16))
+  #.(declare-buffun)
+  (the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) 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 #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :signed-word) v))
+  
+(defun aref-card32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values card32))
+  #.(declare-buffun)
+  (the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) 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 #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :unsigned-long) v))
+
+(defun aref-int32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values int32))
+  #.(declare-buffun)
+  (the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) 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 #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :signed-long) v))
+
+(defun aref-card29 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values card29))
+  #.(declare-buffun)
+  (the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) 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 #.(sys::mdparam 'comp::md-lvector-data0-norm) i
+		    :unsigned-long) 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 (clx-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 (clx-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 (clx-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 (clx-values short-float))
+  #.(declare-buffun)
+  (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
+
+
+#+(or cmu sbcl) (progn
+
+;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
+;;; is irrational, there can't be a precise rational representation.  In
+;;; particular, the different float approximations will always be /=.  This
+;;; causes problems with type checking, because people might compute an
+;;; argument in any precision.  What we do is discard all the excess precision
+;;; in the value, and see if the protocol encoding falls in the desired range
+;;; (64'ths of a degree.)
+;;;
+(deftype angle () '(satisfies anglep))
+
+(defun anglep (x)
+  (and (typep x 'real)
+       (<= (* -360 64) (radians->int16 x) (* 360 64))))
+
+)
+
+
+;;-----------------------------------------------------------------------------
+;; 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-array 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 base-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 base-char
+				  (or (aref (the simple-vector *card8-to-char-translation-table*)
+					    card8)
+				      (error "Invalid CHAR code ~D." 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))
+			   )
+			 #-Minima
+			 (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)))
+			 #-Minima
+			 (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 base-char char))
+			   #.(declare-buffun)
+			   (the card8 (char-code char)))
+			 (defun card8->char (card8)
+			   (declare (type card8 card8))
+			   #.(declare-buffun)
+			   (the base-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.
+
+#+excl
+(defun make-process-lock (name)
+  (mp:make-process-lock :name name))
+
+;;; 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
+
+;;; HOLDING-LOCK for CMU Common Lisp.
+;;;
+;;; We are not multi-processing, but we use this macro to try to protect
+;;; against re-entering request functions.  This can happen if an interrupt
+;;; occurs and the handler attempts to use X over the same display connection.
+;;; This can happen if the GC hooks are used to notify the user over the same
+;;; display connection.  We inhibit GC notifications since display of them
+;;; could cause recursive entry into CLX.
+;;;
+
+;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
+;;;
+#+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 (sys:scheduler-running-p) ; 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))))
+	       ;; There is an apparent race condition here.  However, there is
+	       ;; no actual race condition -- our implementation of mp:process-
+	       ;; lock guarantees that the lock will still be held when it
+	       ;; returns, and no interrupt can happen between that and the
+	       ;; execution of the next form.  -- jdi 2/27/91
+	       (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.
+
+#+excl
+(defmacro without-aborts (&body body)
+  `(without-interrupts ,@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.
+
+#+excl
+(defun process-block (whostate predicate &rest predicate-args)
+  (if (sys:scheduler-running-p)
+      (apply #'mp::process-wait whostate predicate predicate-args)
+      (or (apply predicate predicate-args)
+	  (error "Program tried to wait with no scheduler."))))
+
+;;; PROCESS-WAKEUP: Check some other process' wait function.
+
+(declaim (inline process-wakeup))
+
+#+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)))))
+
+
+;;; 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.
+
+#+excl
+(defun current-process ()
+  (and (sys:scheduler-running-p)
+       mp::*current-process*))
+
+;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
+
+;;; 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.
+#-sbcl
+(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-input ((buffer) &body body)
+  (declare (ignore buffer))
+  ;; Error recovery wrapper
+  `(progn ,@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
+
+
+;;
+;; 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).
+;;
+#+excl
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol)) ;; assume TCP
+  (let ((stream (socket:make-socket :remote-host (string host)
+				    :remote-port (+ *x-tcp-port* display)
+				    :format :binary)))
+    (if (streamp stream)
+	stream
+      (error "Cannot connect to server: ~A:~D" host display))))
+
+
+;;; BUFFER-READ-DEFAULT - read data from the X stream
+
+
+;;
+;; Rewritten 10/89 to not use foreign function interface to do I/O.
+;;
+#+excl
+(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 (real 0 *)) timeout))
+  #.(declare-buffun)
+    
+  (let* ((howmany (- end start))
+	 (fd (display-input-stream display)))
+    (declare (type array-index howmany))
+    (or (cond ((fd-char-avail-p fd) nil)
+	      ((and timeout (= timeout 0)) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(fd-read-bytes fd vector start howmany))))
+
+
+;;; 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.
+
+
+;;; BUFFER-WRITE-DEFAULT - write data to the X stream
+
+#+excl
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (unless (null stream)
+      (write-sequence vector stream :start start :end 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.
+
+;;; buffer-force-output-default - force output to the X stream
+
+#+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))
+  #.(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
+
+
+;;
+;; 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.
+;;
+#+excl
+(defparameter *read-whostate* "waiting for input 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 (real 0 *)) timeout))
+  (declare (clx-values timeout))
+  (let ((fd (display-input-stream display)))
+    (when (streamp fd)
+      (cond ((fd-char-avail-p fd)
+	     nil)
+	    
+	    ;; Otherwise no bytes were available on the socket
+	    ((and timeout (= timeout 0))
+	     ;; If there aren't enough and timeout == 0, timeout.
+	     :timeout)
+	  
+	    ;; If the scheduler is running let it do timeouts.
+	    ((sys:scheduler-running-p)
+	     (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))
+	     )
+	    
+	    ;; 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
+	     #+mswindows
+	     (error "scheduler must be running to use CLX on MS Windows")
+	     #-mswindows
+	     (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.
+			)))))))))
+
+	   
+;;; 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 
+#+(and excl clx-use-allegro-streams)
+(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))))
+
+#+(and excl (not clx-use-allegro-streams))
+(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)
+  ;; 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)))
+     (declare (type cons ,var)
+	      #+clx-ansi-common-lisp (dynamic-extent ,var))
+     ,@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)))
+     (declare (type cons ,var)
+	      #+clx-ansi-common-lisp (dynamic-extent ,var))
+     ,@body))
+
+(declaim (inline buffer-replace))
+
+#+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))
+    
+    (excl: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))))))
+
+#-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 much 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?+
+  #+(or Genera Minima CMU sbcl) nil
+  #-(or Genera Minima CMU sbcl) 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.
+
+;;
+;; ### This comment is a lie!  TYPE? is really also used for run-time type
+;; dispatching, not just type checking.  -- Ram.
+
+(defmacro type? (object type)
+  #+(or cmu sbcl)
+  `(typep ,object ,type)
+  #-(or cmu sbcl)
+  (if (not (constantp type))
+      `(typep ,object ,type)
+    (progn
+      (setq type (eval type))
+      #+(or Genera explorer Minima)
+      (if +type-check?+
+	  `(locally (declare (optimize safety)) (typep ,object ',type))
+	`(typep ,object ',type))
+      #-(or Genera explorer Minima)
+      (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 'generalized-boolean)
+	       't)			; Everything is a generalized-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
+	   :type-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 generalized-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)))
+
+#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))
+(defun x-error (condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'error condition keyargs))
+
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'cerror proceed-format-string condition keyargs))
+
+;;; X-ERROR for CMU Common Lisp
+;;;
+;;; We detect a couple condition types for which we disable event handling in
+;;; our system.  This prevents going into the debugger or returning to a
+;;; command prompt with CLX repeatedly seeing the same condition.  This occurs
+;;; because CMU Common Lisp provides for all events (that is, X, input on file
+;;; descriptors, Mach messages, etc.) to come through one routine anyone can
+;;; use to wait for input.
+;;;
+#+(and CMU (not mp)) 
+(defun x-error (condition &rest keyargs)
+  (let ((condx (apply #'make-condition condition keyargs)))
+    (when (eq condition 'closed-display)
+      (let ((disp (closed-display-display condx)))
+	(warn "Disabled event handling on ~S." disp)
+	(ext::disable-clx-event-handling disp)))
+    (error condx)))
+
+#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl)
+(defun x-error (condition &rest keyargs)
+  (error "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
+
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+(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 excl (not clx-ansi-common-lisp))
+(defmacro define-condition (name parent-types &optional slots &rest args)
+  `(excl::define-condition
+     ,name (,(first parent-types))
+     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+	      slots)
+     ,@args))
+
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+(define-condition x-error (error) ())
+
+
+
+;;-----------------------------------------------------------------------------
+;;  HOST hacking
+;;-----------------------------------------------------------------------------
+
+#+(and allegro-version>= (version>= 5 0))
+(eval-when (compile eval load)
+  #+(version>= 6 0)
+  (progn
+    (require :sock)
+    #-(version>= 7 0)
+    (require :gray-compat))
+  #-(version>= 6 0)
+  (require :sock))
+
+#+(and allegro-version>= (version>= 5 0))
+(defun host-address (host &optional (family :internet))
+  (ecase family
+    (:internet
+     (cons :internet
+	   (multiple-value-list
+	    (socket::ipaddr-to-dotted (socket::lookup-hostname host)
+				      :values t))))))
+
+#+(and allegro-version>= (not (version>= 5 0)))
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (labels ((no-host-error ()
+	     (error "Unknown host ~S" host))
+	   (no-address-error ()
+	     (error "Host ~S has no ~S address" host family)))
+    (let ((hostent 0))
+      (unwind-protect
+	   (progn
+	     (setf hostent (ipc::gethostbyname (string host)))
+	     (when (zerop hostent)
+	       (no-host-error))
+	     (ecase family
+	       ((:internet nil 0)
+		(unless (= (ipc::hostent-addrtype hostent) 2)
+		  (no-address-error))
+		(assert (= (ipc::hostent-length hostent) 4))
+		(let ((addr (ipc::hostent-addr hostent)))
+		   (when (or (member comp::.target.
+				     '(:hp :sgi4d :sony :dec3100)
+				     :test #'eq)
+			     (probe-file "/lib/ld.so"))
+		     ;; BSD 4.3 based systems require an extra indirection
+		     (setq addr (si:memref-int addr 0 0 :unsigned-long)))
+		  (list :internet
+			(si:memref-int addr 0 0 :unsigned-byte)
+			(si:memref-int addr 1 0 :unsigned-byte)
+			(si:memref-int addr 2 0 :unsigned-byte)
+			(si:memref-int addr 3 0 :unsigned-byte))))))
+	(ff:free-cstruct hostent)))))
+
+
+;;-----------------------------------------------------------------------------
+;; 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 ()
+  #+(or lispm Minima) t
+  #-(or lispm Minima) nil)
+
+#-(or Genera Minima)
+(defun clx-macroexpand (form env)
+  (macroexpand form env))
+
+
+;;-----------------------------------------------------------------------------
+;; Resource stuff
+;;-----------------------------------------------------------------------------
+
+
+;;; Utilities 
+
+(defun getenv (name)
+  #+excl (sys:getenv name)
+  )
+
+(defun get-host-name ()
+  "Return the same hostname as gethostname(3) would"
+  ;; resources-pathname was using short-site-name for this purpose
+  #+excl (short-site-name)
+  )
+
+(defun homedir-file-pathname (name)
+  (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
+       (merge-pathnames (user-homedir-pathname) (pathname name))))
+
+;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
+;;; a resource manager isn't running.
+
+(defun default-resources-pathname ()
+  (homedir-file-pathname ".Xdefaults"))
+
+;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
+;;; defaults have been loaded.
+
+(defun resources-pathname ()
+  (or (let ((string (getenv "XENVIRONMENT")))
+	(and string
+	     (pathname string)))
+      (homedir-file-pathname
+       (concatenate 'string ".Xdefaults-" (get-host-name)))))
+
+;;; AUTHORITY-PATHNAME - The pathname of the authority file.
+
+(defun authority-pathname ()
+  (or (let ((xauthority (getenv "XAUTHORITY")))
+	(and xauthority
+	     (pathname xauthority)))
+      (homedir-file-pathname ".Xauthority")))
+
+;;; this particular defaulting behaviour is typical to most Unices, I think
+#+unix
+(defun get-default-display (&optional display-name)
+  "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
+if it is NIL.  Display names have the format
+
+  [protocol/] [hostname] : [:] displaynumber [.screennumber]
+
+There are two special cases in parsing, to match that done in the Xlib
+C language bindings
+
+ - If the hostname is ``unix'' or the empty string, any supplied
+   protocol is ignored and a connection is made using the :local
+   transport.
+
+ - If a double colon separates hostname from displaynumber, the
+   protocol is assumed to be decnet.
+
+Returns a list of (host display-number screen protocol)."
+  (let* ((name (or display-name
+		   (getenv "DISPLAY")
+		   (error "DISPLAY environment variable is not set")))
+	 (slash-i (or (position #\/ name) -1))
+	 (colon-i (position #\: name :start (1+ slash-i)))
+	 (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
+	 (host (subseq name (1+ slash-i) colon-i))
+	 (dot-i (and colon-i (position #\. name :start colon-i)))
+	 (display (when colon-i
+		    (parse-integer name
+				   :start (if decnet-colon-p
+					      (+ colon-i 2)
+					      (1+ colon-i))
+				   :end dot-i)))
+	 (screen (when dot-i
+		   (parse-integer name :start (1+ dot-i))))
+	 (protocol
+	  (cond ((or (string= host "") (string-equal host "unix")) :local)
+		(decnet-colon-p :decnet)
+		((> slash-i -1) (intern
+				 (string-upcase (subseq name 0 slash-i))
+				 :keyword))
+		(t :internet))))
+    (list host (or display 0) (or screen 0) protocol)))
+
+
+;;-----------------------------------------------------------------------------
+;; GC stuff
+;;-----------------------------------------------------------------------------
+
+(defun gc-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)
+  (when (boundp '*reply-buffer-free-lists*)
+    (fill *reply-buffer-free-lists* nil))
+  (setq *gcontext-local-state-cache* nil)
+  (setq *temp-gcontext-cache* nil)
+  nil)
+
+
+
+;;-----------------------------------------------------------------------------
+;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
+;;-----------------------------------------------------------------------------
+
+#-(or clx-ansi-common-lisp Genera CMU sbcl)
+(defun with-standard-io-syntax-function (function)
+  (declare #+lispm
+	   (sys:downward-funarg function))
+  (let ((*package* (find-package :user))
+	(*print-array* t)
+	(*print-base* 10)
+	(*print-case* :upcase)
+	(*print-circle* nil)
+	(*print-escape* t)
+	(*print-gensym* t)
+	(*print-length* nil)
+	(*print-level* nil)
+	(*print-pretty* nil)
+	(*print-radix* nil)
+	(*read-base* 10)
+	(*read-default-float-format* 'single-float)
+	(*read-suppress* nil)
+	)
+    (funcall function)))
+
+#-(or clx-ansi-common-lisp Genera CMU sbcl)
+(defmacro with-standard-io-syntax (&body body)
+  `(flet ((.with-standard-io-syntax-body. () ,@body))
+     (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
+
+
+;;-----------------------------------------------------------------------------
+;; DEFAULT-KEYSYM-TRANSLATE
+;;-----------------------------------------------------------------------------
+
+;;; 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:
+;;; (base-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.
+
+#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
+(defun default-keysym-translate (display state object)
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object)
+	   (clx-values t)
+	   (special left-meta-keysym right-meta-keysym
+		    left-super-keysym right-super-keysym
+		    left-hyper-keysym right-hyper-keysym))
+  (when (characterp object)
+    (when (logbitp (position :control +state-mask-vector+) state)
+      (setf (char-bit object :control) 1))
+    (when (or (state-keysymp display state left-meta-keysym)
+	      (state-keysymp display state right-meta-keysym))
+      (setf (char-bit object :meta) 1))
+    (when (or (state-keysymp display state left-super-keysym)
+	      (state-keysymp display state right-super-keysym))
+      (setf (char-bit object :super) 1))
+    (when (or (state-keysymp display state left-hyper-keysym)
+	      (state-keysymp display state right-hyper-keysym))
+      (setf (char-bit object :hyper) 1)))
+  object)
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+;;; Types
+
+(deftype pixarray-1-element-type ()
+  'bit)
+
+(deftype pixarray-4-element-type ()
+  '(unsigned-byte 4))
+
+(deftype pixarray-8-element-type ()
+  '(unsigned-byte 8))
+
+(deftype pixarray-16-element-type ()
+  '(unsigned-byte 16))
+
+(deftype pixarray-24-element-type ()
+  '(unsigned-byte 24))
+
+(deftype pixarray-32-element-type ()
+  #-(or Genera Minima) '(unsigned-byte 32)
+  #+(or Genera Minima) 'fixnum)
+
+(deftype pixarray-1  ()
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-1-element-type (* *)))
+
+(deftype pixarray-4  ()
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-4-element-type (* *)))
+
+(deftype pixarray-8  ()
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-8-element-type (* *)))
+
+(deftype pixarray-16 ()
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-16-element-type (* *)))
+
+(deftype pixarray-24 ()
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-24-element-type (* *)))
+
+(deftype pixarray-32 ()
+  '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *)))
+
+(deftype pixarray ()
+  '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
+
+(deftype bitmap ()
+  'pixarray-1)
+
+;;; WITH-UNDERLYING-SIMPLE-VECTOR 
+
+#+excl
+(defmacro with-underlying-simple-vector
+	  ((variable element-type pixarray) &body body)
+  `(let ((,variable (cdr (excl::ah_data ,pixarray))))
+     (declare (type (simple-array ,element-type (*)) ,variable))
+     ,@body))
+
+;;; 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)
+  (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
+  `(the (unsigned-byte ,size)
+	(#-Genera ldb #+Genera sys:%logldb
+	 (byte ,size ,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)
+  (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
+  (let ((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
+  (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
+  `(the card8
+	(#-Genera ldb #+Genera sys:%logldb
+	 (byte 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)
+  (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
+  (let ((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)))
+
+#+(or Genera lcl3.0 excl)
+(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+)
+
+#+(or Genera lcl3.0 excl)
+(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+)
+
+;;; 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
+
+#+(or Genera lcl3.0 excl) 
+(defconstant
+  *image-bit-ordering-table*
+  '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((1 (07 00) (15 08) (23 16) (31 24)) (nil t))
+    ((2 (15 08) (07 00) (31 24) (23 16)) (nil t))
+    ((4 (31 24) (23 16) (15 08) (07 00)) (nil t))
+    ((1 (00 07) (08 15) (16 23) (24 31)) (t   nil))
+    ((2 (08 15) (00 07) (24 31) (16 23)) (t   nil))
+    ((4 (24 31) (16 23) (08 15) (00 07)) (t   nil))
+    ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))
+    ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))
+    ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))
+  
+#+(or Genera lcl3.0 excl) 
+(defun compute-image-byte-and-bit-ordering ()
+  (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))
+  ;; First compute the ordering 
+  (let ((ordering nil)
+	(a (make-array '(1 32) :element-type 'bit :initial-element 0)))
+    (dotimes (i 4)
+      (push (flet ((bitpos (a i n)
+		     (declare (optimize (speed 3) (safety 0) (space 0)))
+		     (declare (type (simple-array bit (* *)) a)
+			      (type fixnum i n))
+		     (with-underlying-simple-vector (v (unsigned-byte 8) a)
+		       (prog2
+			 (setf (aref v i) n)
+			 (dotimes (i 32)
+			   (unless (zerop (aref a 0 i))
+			     (return i)))
+			 (setf (aref v i) 0)))))
+	      (list (bitpos a i #b10000000)
+		    (bitpos a i #b00000001)))
+	    ordering))
+    (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering)))
+    ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p
+    (let ((byte-and-bit-ordering
+	    (second (assoc ordering *image-bit-ordering-table*
+			   :test #'equal))))
+      (unless byte-and-bit-ordering
+	(error "Couldn't determine image byte and bit ordering~@
+                measured image ordering = ~A"
+	       ordering))
+      (values-list byte-and-bit-ordering))))
+
+#+(or Genera lcl3.0 excl) 
+(multiple-value-setq
+  (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+  (compute-image-byte-and-bit-ordering))
+
+;;; 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.
+
+;;; FIXME: though we have some #+sbcl -conditionalized routines in
+;;; here, they would appear not to work, and so are commented out in
+;;; the the FAST-xxx-PIXARRAY routines themseleves.  Investigate
+;;; whether the unoptimized routines are often used, and also whether
+;;; speeding them up while maintaining correctness is possible.
+
+;;; 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 bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-1-element-type array)
+      (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 (the array-index (mod (the fixnum (- x)) 8)))
+	    (right-bits (index-mod (index- width left-bits) 8))
+	    (middle-bits (the fixnum (- (the fixnum (- 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-bytes)
+		 (fixnum middle-bits))
+	(cond ((< 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 bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-4-element-type array)
+      (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 (the array-index (mod (the fixnum (- (the fixnum 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 (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 Genera lcl3.0 excl CMU sbcl)
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-24-element-type array)
+      (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 (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)
+
+;;; COPY-BIT-RECT  --  Internal
+;;;
+;;;    This is the classic BITBLT operation, copying a rectangular subarray
+;;; from one array to another (but source and destination must not overlap.)
+;;; Widths are specified in bits.  Neither array can have a non-zero
+;;; displacement.  We allow extra random bit-offset to be thrown into the X.
+;;;
+#+(or Genera lcl3.0 excl)
+(defun fast-read-pixarray-with-swap
+       (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (unless (index= bits-per-pixel 24)
+    (let ((pixarray-padded-bits-per-line
+	    (if (index= height 1) 0
+	      (index* (index- (array-row-major-index pixarray 1 0)
+			      (array-row-major-index pixarray 0 0))
+		      bits-per-pixel)))
+	  (x-bits (index* x bits-per-pixel)))
+      (declare (type array-index pixarray-padded-bits-per-line x-bits))
+      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		     (index-zerop (index-mod x-bits 8)))
+	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		   (index-zerop (index-mod x-bits +image-unit+))))
+	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
+	    (image-swap-function
+	      bits-per-pixel 
+	      unit byte-lsb-first-p bit-lsb-first-p
+	      +image-unit+ *computed-image-byte-lsb-first-p*
+	      *computed-image-bit-lsb-first-p*)
+	  (declare (type symbol image-swap-function)
+		   (type generalized-boolean image-swap-lsb-first-p))
+	  (with-underlying-simple-vector (dst card8 pixarray)
+	    (funcall
+	      (symbol-function image-swap-function) bbuf dst
+	      (index+ boffset
+		      (index* y padded-bytes-per-line)
+		      (index-floor x-bits 8))
+	      0 (index-ceiling (index* width bits-per-pixel) 8)
+	      padded-bytes-per-line
+	      (index-floor pixarray-padded-bits-per-line 8)
+	      height image-swap-lsb-first-p)))
+	t))))
+
+(defun fast-read-pixarray (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+  (or
+    #+(or Genera lcl3.0 excl)
+    (fast-read-pixarray-with-swap
+      bbuf boffset pixarray x y width height padded-bytes-per-line
+      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+    (let ((function
+	    (or #+lispm
+		(and (= (sys:array-element-size pixarray) bits-per-pixel)
+		     (zerop (index-mod padded-bytes-per-line 4))
+		     (zerop (index-mod
+			      (* #+Genera (sys:array-row-span pixarray)
+				 #-Genera (array-dimension pixarray 1)
+				 bits-per-pixel)
+			      32))
+		     #'fast-read-pixarray-using-bitblt)
+		#+(or CMU)
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
+		     #'fast-read-pixarray-using-bitblt)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 1)
+		     #'fast-read-pixarray-1)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 4)
+		     #'fast-read-pixarray-4)
+		#+(or Genera lcl3.0 excl CMU)
+		(and (index= bits-per-pixel 24)
+		     #'fast-read-pixarray-24))))
+      (when function
+	(read-pixarray-internal
+	  bbuf boffset pixarray x y width height padded-bytes-per-line
+	  bits-per-pixel function
+	  unit byte-lsb-first-p bit-lsb-first-p
+	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))))
+
+;;; 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 bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-1-element-type array)
+      (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 (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 bits-per-pixel)
+  (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)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-4-element-type array)
+      (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 (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 Genera lcl3.0 excl CMU sbcl)
+(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line bits-per-pixel)
+  (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)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-24-element-type array)
+      (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 (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 Genera lcl3.0 excl)
+(defun fast-write-pixarray-with-swap
+       (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (unless (index= bits-per-pixel 24)
+    (let ((pixarray-padded-bits-per-line
+	    (if (index= height 1) 0
+	      (index* (index- (array-row-major-index pixarray 1 0)
+			      (array-row-major-index pixarray 0 0))
+		      bits-per-pixel)))
+	  (pixarray-start-bit-offset
+	    (index* (array-row-major-index pixarray y x)
+		    bits-per-pixel)))
+      (declare (type array-index pixarray-padded-bits-per-line
+		     pixarray-start-bit-offset))
+      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		     (index-zerop (index-mod pixarray-start-bit-offset 8)))
+	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		   (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
+	    (image-swap-function
+	      bits-per-pixel
+	      +image-unit+ *computed-image-byte-lsb-first-p*
+	      *computed-image-bit-lsb-first-p*
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	  (declare (type symbol image-swap-function)
+		   (type generalized-boolean image-swap-lsb-first-p))
+	  (with-underlying-simple-vector (src card8 pixarray)
+	    (funcall
+	      (symbol-function image-swap-function)
+	      src bbuf (index-floor pixarray-start-bit-offset 8) boffset
+	      (index-ceiling (index* width bits-per-pixel) 8)
+	      (index-floor pixarray-padded-bits-per-line 8)
+	      padded-bytes-per-line height image-swap-lsb-first-p))
+	  t)))))
+
+(defun fast-write-pixarray (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+  (or
+    #+(or Genera lcl3.0 excl)
+    (fast-write-pixarray-with-swap
+      bbuf boffset pixarray x y width height padded-bytes-per-line
+      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+    (let ((function
+	    (or #+lispm
+		(and (= (sys:array-element-size pixarray) bits-per-pixel)
+		     (zerop (index-mod padded-bytes-per-line 4))
+		     (zerop (index-mod
+			      (* #+Genera (sys:array-row-span pixarray)
+				 #-Genera (array-dimension pixarray 1)
+				 bits-per-pixel)
+			      32))
+		     #'fast-write-pixarray-using-bitblt)
+		#+(or CMU)
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
+		     #'fast-write-pixarray-using-bitblt)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 1)
+		     #'fast-write-pixarray-1)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 4)
+		     #'fast-write-pixarray-4)
+		#+(or Genera lcl3.0 excl CMU)
+		(and (index= bits-per-pixel 24)
+		     #'fast-write-pixarray-24))))
+      (when function
+	(write-pixarray-internal
+	  bbuf boffset pixarray x y width height padded-bytes-per-line
+	  bits-per-pixel function
+	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
+	  unit byte-lsb-first-p bit-lsb-first-p)))))
+
+;;; 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 nil)
+  (or
+    #+(or lispm CMU)
+    (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)))
+      #-(or CMU)
+      (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)
+      #+(or CMU)
+      (when (index= (pixarray-element-size pixarray)
+		    (pixarray-element-size copy)
+		    bits-per-pixel)
+	(copy-bit-rect pixarray pixarray-padded-bits-per-line x y
+		       copy copy-padded-bits-per-line 0 0
+		       height
+		       (index* width bits-per-pixel))
+	t))
+	
+    #+(or lcl3.0 excl)
+    (unless (index= bits-per-pixel 24)
+      (let ((pixarray-padded-bits-per-line
+	      (if (index= height 1) 0
+		(index* (index- (array-row-major-index pixarray 1 0)
+				(array-row-major-index pixarray 0 0))
+			bits-per-pixel)))
+	    (copy-padded-bits-per-line
+	      (if (index= height 1) 0
+		(index* (index- (array-row-major-index copy 1 0)
+				(array-row-major-index copy 0 0))
+			bits-per-pixel)))
+	    (pixarray-start-bit-offset
+	      (index* (array-row-major-index pixarray y x)
+		      bits-per-pixel)))
+	(declare (type array-index pixarray-padded-bits-per-line
+		       copy-padded-bits-per-line pixarray-start-bit-offset))
+	(when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		  (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		       (index-zerop (index-mod copy-padded-bits-per-line 8))
+		       (index-zerop (index-mod pixarray-start-bit-offset 8)))
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod copy-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+	  (with-underlying-simple-vector (src card8 pixarray)
+	    (with-underlying-simple-vector (dst card8 copy)
+	      (image-noswap
+		src dst
+		(index-floor pixarray-start-bit-offset 8) 0
+		(index-ceiling (index* width bits-per-pixel) 8)
+		(index-floor pixarray-padded-bits-per-line 8)
+		(index-floor copy-padded-bits-per-line 8)
+		height nil)))
+	  t)))
+    #+(or lcl3.0 excl)
+    (macrolet
+      ((copy (type element-type)
+	 `(let ((pixarray pixarray)
+		(copy copy))
+	    (declare (type ,type pixarray copy))
+	    #.(declare-buffun)
+	    (with-underlying-simple-vector (src ,element-type pixarray)
+	      (with-underlying-simple-vector (dst ,element-type 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-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/dep-openmcl.lisp b/clx/dep-openmcl.lisp
new file mode 100644
index 000000000..c9b994a0c
--- /dev/null
+++ b/clx/dep-openmcl.lisp
@@ -0,0 +1,1127 @@
+;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
+
+;; 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.
+;;;
+
+#+cmu
+(ext:file-comment "$Id: dep-openmcl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+
+(in-package :xlib)
+
+(proclaim '(declaration array-register))
+
+
+;;; The size of the output buffer.  Must be a multiple of 4.
+(defparameter *output-buffer-size* 8192)
+
+;;; Number of seconds to wait for a reply to a server request
+(defparameter *reply-timeout* nil) 
+
+(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 (:compile-toplevel :load-toplevel :execute)
+  (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
+    "Speed compiler option for buffer code.")
+  (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
+    "Safety compiler option for buffer code.")
+  (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
+    "Debug compiler option for buffer code>")
+  (defun declare-bufmac ()
+    `(declare (optimize
+	       (speed ,+buffer-speed+)
+	       (safety ,+buffer-safety+)
+	       (debug ,+buffer-debug+))))
+  ;; 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+)
+	       (debug ,+buffer-debug+)))))
+
+(declaim (inline card8->int8 int8->card8
+		 card16->int16 int16->card16
+		 card32->int32 int32->card32))
+
+(progn
+
+(defun card8->int8 (x)
+  (declare (type card8 x))
+  (declare (clx-values int8))
+  #.(declare-buffun)
+  (the int8 (if (logbitp 7 x)
+		(the int8 (- x #x100))
+	      x)))
+
+(defun int8->card8 (x)
+  (declare (type int8 x))
+  (declare (clx-values card8))
+  #.(declare-buffun)
+  (the card8 (ldb (byte 8 0) x)))
+
+(defun card16->int16 (x)
+  (declare (type card16 x))
+  (declare (clx-values int16))
+  #.(declare-buffun)
+  (the int16 (if (logbitp 15 x)
+		 (the int16 (- x #x10000))
+		 x)))
+
+(defun int16->card16 (x)
+  (declare (type int16 x))
+  (declare (clx-values card16))
+  #.(declare-buffun)
+  (the card16 (ldb (byte 16 0) x)))
+
+(defun card32->int32 (x)
+  (declare (type card32 x))
+  (declare (clx-values int32))
+  #.(declare-buffun)
+  (the int32 (if (logbitp 31 x)
+		 (the int32 (- x #x100000000))
+		 x)))
+
+(defun int32->card32 (x)
+  (declare (type int32 x))
+  (declare (clx-values card32))
+  #.(declare-buffun)
+  (the card32 (ldb (byte 32 0) x)))
+
+)
+
+(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
+
+(progn
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-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 (clx-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)))
+
+)
+
+(progn
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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 (clx-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
+		     `(
+		       ;; The normal ascii codes for the control characters.
+		       ,@`((#\Return . 13)
+			   (#\Linefeed . 10)
+			   (#\Rubout . 127)
+			   (#\Page . 12)
+			   (#\Tab . 9)
+			   (#\Backspace . 8)
+			   (#\Newline . 10)
+			   (#\Space . 32))
+		       
+		       ;; 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-array 256)))
+					  (dotimes (i (length array))
+					    (setf (aref array i) (code-char i)))
+					  (dolist (pair alist)
+					    (setf (aref array (cdr pair)) (car pair)))
+					  array))
+			 (progn
+  			   (defun char->card8 (char)
+			     (declare (type base-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 base-char
+				  (or (aref (the simple-vector *card8-to-char-translation-table*)
+					    card8)
+				      (error "Invalid CHAR code ~D." 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 base-char char))
+			   #.(declare-buffun)
+			   (the card8 (char-code char)))
+			 (defun card8->char (card8)
+			   (declare (type card8 card8))
+			   #.(declare-buffun)
+			   (the base-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.
+
+(defun make-process-lock (name)
+  (ccl:make-lock name))
+
+;;; 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.
+
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore timeout display))
+  `(ccl:with-lock-grabbed (,locator ,whostate)
+    ,@body))
+
+;;; 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.
+
+(defmacro without-aborts (&body body)
+  `(ccl:without-interrupts ,@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.
+
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (dynamic-extern predicate-args))
+  (apply #'ccl:process-wait whostate predicate predicate-args))
+
+;;; PROCESS-WAKEUP: Check some other process' wait function.
+
+(declaim (inline process-wakeup))
+
+(defun process-wakeup (process)
+  (declare (ignore process))
+  nil)
+
+;;; 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.
+
+(defun current-process ()
+  ccl::*current-process*)
+
+;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
+
+(defmacro without-interrupts (&body body)
+  `(ccl:without-interrupts ,@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)
+  `(ccl::conditional-store ,place ,old-value ,new-value))
+
+;;;----------------------------------------------------------------------------
+;;; IO Error Recovery
+;;;	All I/O operations are done within a WRAP-BUF-OUTPUT macro.
+;;;	It prevents multiple mindless errors when the network craters.
+;;;
+;;;----------------------------------------------------------------------------
+
+(defmacro wrap-buf-output ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(unless (buffer-dead ,buffer)
+     ,@body))
+
+(defmacro wrap-buf-input ((buffer) &body body)
+  (declare (ignore buffer))
+  ;; Error recovery wrapper
+  `(progn ,@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
+
+(defparameter ccl::*x-server-unix-socket-format-string* "/tmp/.X11-unix/X~d")
+
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol))
+  (if (or (string= host "") (string= host "unix"))
+    (ccl::make-socket :connect :active
+                      :address-family  :file
+                      :remote-filename (format nil ccl::*x-server-unix-socket-format-string* display))
+    (ccl::make-socket :connect :active
+                      :remote-host host
+                      :remote-port (+ 6000 display))))
+
+;;; BUFFER-READ-DEFAULT - read data from the X stream
+
+(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 (real 0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((and timeout (= timeout 0)) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(progn
+	  (ccl:stream-read-ivector stream vector start (- end start))
+	  nil))))
+
+;;; BUFFER-WRITE-DEFAULT - write data to the X stream
+
+(defun buffer-write-default (vector display start end)
+  (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)
+      (ccl:stream-write-ivector stream vector start (- end start)))
+    nil))
+
+;;; buffer-force-output-default - force output to the X stream
+
+(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
+
+(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.
+
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((eql timeout 0) :timeout)
+	  (t
+	   (let* ((fd (ccl::stream-device stream :input))
+		  (ticks (and timeout (floor (* timeout ccl::*ticks-per-second*)))))
+	     (if (ccl::process-input-wait fd ticks)
+                 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.
+
+(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))))
+
+
+;;;----------------------------------------------------------------------------
+;;; 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.
+;;
+
+(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)))
+     (declare (type cons ,var)
+	      #+clx-ansi-common-lisp (dynamic-extent ,var))
+     ,@body))
+
+(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)))
+     (declare (type cons ,var)
+              (dynamic-extent ,var))
+     ,@body))
+
+(declaim (inline buffer-replace))
+
+(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))
+
+(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 much 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?+ nil)
+
+;; 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.
+
+;;
+;; ### This comment is a lie!  TYPE? is really also used for run-time type
+;; dispatching, not just type checking.  -- Ram.
+
+(defmacro type? (object type)
+  (if (not (constantp type))
+      `(typep ,object ,type)
+    (progn
+      (setq type (eval type))
+      (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 'generalized-boolean)
+	       't)			; Everything is a generalized-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
+	   :type-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 generalized-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)))
+
+(defun x-error (condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'error condition keyargs))
+
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'cerror proceed-format-string 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)
+
+(define-condition x-error (error) ())
+
+
+;;-----------------------------------------------------------------------------
+;;  HOST hacking
+;;-----------------------------------------------------------------------------
+
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (ecase family
+    ((:internet nil 0)
+     (let* ((addr (ccl::host-as-inet-host host)))
+       (cons :internet (list
+                        (ldb (byte 8 24) addr)
+                        (ldb (byte 8 16) addr)
+                        (ldb (byte 8 8) addr)
+                        (ldb (byte 8 0) addr)))))))
+
+
+;;-----------------------------------------------------------------------------
+;; 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 () nil)
+
+(defun clx-macroexpand (form env)
+  (macroexpand form env))
+
+
+;;-----------------------------------------------------------------------------
+;; Resource stuff
+;;-----------------------------------------------------------------------------
+
+
+;;; Utilities 
+
+(defun getenv (name)
+  (ccl::getenv name))
+
+(defun get-host-name ()
+  "Return the same hostname as gethostname(3) would"
+  (machine-instance))
+
+(defun homedir-file-pathname (name)
+  (merge-pathnames (user-homedir-pathname) (pathname name)))
+
+;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
+;;; a resource manager isn't running.
+
+(defun default-resources-pathname ()
+  (homedir-file-pathname ".Xdefaults"))
+
+;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
+;;; defaults have been loaded.
+
+(defun resources-pathname ()
+  (or (let ((string (getenv "XENVIRONMENT")))
+	(and string
+	     (pathname string)))
+      (homedir-file-pathname
+       (concatenate 'string ".Xdefaults-" (get-host-name)))))
+
+;;; AUTHORITY-PATHNAME - The pathname of the authority file.
+
+(defun authority-pathname ()
+  (or (let ((xauthority (getenv "XAUTHORITY")))
+	(and xauthority
+	     (pathname xauthority)))
+      (homedir-file-pathname ".Xauthority")))
+
+;;; this particular defaulting behaviour is typical to most Unices, I think
+
+(defun get-default-display (&optional display-name)
+  "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
+if it is NIL.  Display names have the format
+
+  [protocol/] [hostname] : [:] displaynumber [.screennumber]
+
+There are two special cases in parsing, to match that done in the Xlib
+C language bindings
+
+ - If the hostname is ``unix'' or the empty string, any supplied
+   protocol is ignored and a connection is made using the :local
+   transport.
+
+ - If a double colon separates hostname from displaynumber, the
+   protocol is assumed to be decnet.
+
+Returns a list of (host display-number screen protocol)."
+  (let* ((name (or display-name
+		   (getenv "DISPLAY")
+		   (error "DISPLAY environment variable is not set")))
+	 (slash-i (or (position #\/ name) -1))
+	 (colon-i (position #\: name :start (1+ slash-i)))
+	 (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
+	 (host (subseq name (1+ slash-i) colon-i))
+	 (dot-i (and colon-i (position #\. name :start colon-i)))
+	 (display (when colon-i
+		    (parse-integer name
+				   :start (if decnet-colon-p
+					      (+ colon-i 2)
+					      (1+ colon-i))
+				   :end dot-i)))
+	 (screen (when dot-i
+		   (parse-integer name :start (1+ dot-i))))
+	 (protocol
+	  (cond ((or (string= host "") (string-equal host "unix")) :local)
+		(decnet-colon-p :decnet)
+		((> slash-i -1) (intern
+				 (string-upcase (subseq name 0 slash-i))
+				 :keyword))
+		(t :internet))))
+    (list host (or display 0) (or screen 0) protocol)))
+
+
+;;-----------------------------------------------------------------------------
+;; GC stuff
+;;-----------------------------------------------------------------------------
+
+(defun gc-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)
+  (when (boundp '*reply-buffer-free-lists*)
+    (fill *reply-buffer-free-lists* nil))
+  (setq *gcontext-local-state-cache* nil)
+  (setq *temp-gcontext-cache* nil)
+  nil)
+
+
+;;-----------------------------------------------------------------------------
+;; DEFAULT-KEYSYM-TRANSLATE
+;;-----------------------------------------------------------------------------
+
+;;; 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:
+;;; (base-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.
+
+(defun default-keysym-translate (display state object)
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object)
+	   (ignore display state)
+	   (clx-values t))
+  object)
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+;;; Types
+
+(deftype pixarray-1-element-type ()
+  'bit)
+
+(deftype pixarray-4-element-type ()
+  '(unsigned-byte 4))
+
+(deftype pixarray-8-element-type ()
+  '(unsigned-byte 8))
+
+(deftype pixarray-16-element-type ()
+  '(unsigned-byte 16))
+
+(deftype pixarray-24-element-type ()
+  '(unsigned-byte 24))
+
+(deftype pixarray-32-element-type ()
+  '(unsigned-byte 32))
+
+(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)
+
+;;; WITH-UNDERLYING-SIMPLE-VECTOR 
+
+(defmacro with-underlying-simple-vector ((variable element-type pixarray)
+                                         &body body)
+  (declare (ignore element-type))
+  `(let* ((,variable (ccl::array-data-and-offset ,pixarray)))
+     ,@body))
+
+;;; 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)
+  (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
+  `(the (unsigned-byte ,size)
+     (ldb 
+      (byte ,size ,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)
+  (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
+  (let ((it (first bytes))
+	(count 0))
+    (dolist (byte (rest bytes))
+      (setq it
+	    `(dpb
+	      (the card8 ,byte)
+	      (byte 8 ,(incf count 8))
+	      (the (unsigned-byte ,count) ,it))))
+    `(the (unsigned-byte ,(* (length bytes) 8)) ,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
+  (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
+  `(the card8
+     (ldb
+      (byte 8 ,position)
+      (the (unsigned-byte ,integer-size) ,integer))))
+
+;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
+;;; pixels.
+
+(defmacro write-image-assemble-bytes (&rest bytes)
+  (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
+  (let ((size (floor 8 (length bytes)))
+	(it (first bytes))
+	(count 0))
+    (dolist (byte (rest bytes))
+      (setq it `(dpb
+                 (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
+
+(defun fast-read-pixarray (bbuf boffset pixarray
+			   x y width height padded-bytes-per-line
+			   bits-per-pixel
+			   unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (ignore bbuf boffset pixarray x y width height
+                   padded-bytes-per-line bits-per-pixel unit
+                   byte-lsb-first-p bit-lsb-first-p))
+  nil)
+
+;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
+
+(defun fast-write-pixarray (bbuf boffset pixarray x y width height
+			    padded-bytes-per-line bits-per-pixel
+			    unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (ignore bbuf boffset pixarray x y width height
+                   padded-bytes-per-line bits-per-pixel unit
+                   byte-lsb-first-p bit-lsp-first-p))
+  nil)
+
+;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
+
+(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
+  (declare (ignore pixarray copy x y width height bits-per-pixel))
+  nil)
diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp
index 3d9db38e7..dc95556ce 100644
--- a/clx/depdefs.lisp
+++ b/clx/depdefs.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/depdefs.lisp,v 1.6 1999/03/16 23:37:38 pw Exp $")
+(ext:file-comment "$Id")
 
 (in-package :xlib)
 
@@ -27,19 +27,58 @@
 ;;; Declarations
 ;;;-------------------------------------------------------------------------
 
+;;; fix a bug in kcl's RATIONAL...
+;;;   redefine both the function and the type.
+
+#+(or kcl ibcl)
+(progn
+  (defun rational (x)
+    (if (rationalp x)
+	x
+	(lisp:rational x)))
+  (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
+
+;;; DECLAIM
+
+#-clx-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))))
+
 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
 
+#-Genera
 (declaim (declaration clx-values))
 
+#+Genera
+(setf (get 'clx-values 'si:declaration-alias) 'scl:values)
+
 ;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
 ;;; the documentation that might get generated by the real arglist of the
 ;;; function.
 
+#-(or lispm lcl3.0)
 (declaim (declaration arglist))
 
+;;; 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.
+
+#-(or clx-ansi-common-lisp lcl3.0)
+(declaim (declaration dynamic-extent))
+
+;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
+
+#-clx-ansi-common-lisp
+(declaim (declaration ignorable))
+
 ;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
 ;;; indent calls to the function or macro containing the declaration.  
 
+#-genera
 (declaim (declaration indentation))
 
 ;;;-------------------------------------------------------------------------
@@ -56,6 +95,14 @@
 ;;; 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))
@@ -73,35 +120,94 @@
 ;;; 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))
+(defconstant +clx-cached-types+
+ '(drawable
+   window
+   pixmap
+   ;;		gcontext
+   cursor
+   colormap
+   font))
 
 (defmacro resource-id-map-test ()
-  '#'eql)
+  #+excl '#'equal
+  #-excl '#'eql)
 					; (eq fixnum fixnum) is not guaranteed.
 (defmacro atom-cache-map-test ()
-  '#'eq)
+  #+excl '#'equal
+  #-excl '#'eq)
 
 (defmacro keysym->character-map-test ()
-  '#'eql)
+  #+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 Minima)
+(eval-when (eval compile load)
+  (pushnew :clx-little-endian *features*))
+
+#+lcl3.0
+(eval-when (compile eval load)
+  (ecase lucid::machine-endian
+    (:big nil)
+    (:little (pushnew :clx-little-endian *features*))))
+
 #+cmu
 (eval-when (compile eval load)
   (ecase #.(c:backend-byte-order c:*backend*)
     (:big-endian)
     (:little-endian (pushnew :clx-little-endian *features*))))
 
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; FIXME: Ideally, we shouldn't end up with the internal
+  ;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists.
+  ;; This probably wants to be split up into :compile-toplevel
+  ;; :execute and :load-toplevel clauses, so that loading the compiled
+  ;; code doesn't push the feature.
+  (ecase sb-c:*backend-byte-order*
+    (:big-endian)
+    (:little-endian (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.
+
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless system::*big-endian* (pushnew :clx-little-endian *features*)))
+
+#+(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.
@@ -111,7 +217,7 @@
 
 ;; this is the best place to define these?
 
-
+#-Genera
 (progn
 
 (defun make-index-typed (form)
@@ -180,14 +286,91 @@
 
 )
 
+#+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)
+  (when (symbolp x)
+    (multiple-value-bind (constantp value) (lt:named-constant-p x)
+      (when constantp (setq x value))))
+  (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.)
+(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))
@@ -195,12 +378,17 @@
   ;; Byte (8 bit) input buffer
   (ibuf8 *empty-bytes* :type buffer-bytes)
   ;; Word (16bit) input buffer
-  (next nil :type (or null reply-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*)))
+(defconstant +buffer-text16-size+ 256)
+(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
 
 ;; These are here because.
 
@@ -216,22 +404,32 @@
 
 ;;; Pseudo-class mechanism.
 
-(eval-when (eval compile load)
-(defvar *def-clx-class-use-defclass*
-  #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
-  #+(and cmu (not pcl)) nil
-  #-(or  cmu) nil
-  "Controls whether DEF-CLX-CLASS uses DEFCLASS.  
-   If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of type names
-   for which DEFCLASS should be used. 
-   If it is not a list, then DEFCLASS is always used.
-   If it is NIL, then DEFCLASS is never used, since NIL is the empty list.")
-)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; FIXME: maybe we should reevaluate this?
+  (defvar *def-clx-class-use-defclass*
+    #+(or Genera allegro) t
+    #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
+    #+(and cmu (not pcl)) nil
+    #-(or Genera cmu allegro) nil
+    "Controls whether DEF-CLX-CLASS uses DEFCLASS.
+
+If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
+type names for which DEFCLASS should be used.  If it is not a list,
+then DEFCLASS is always used.  If it is NIL, then DEFCLASS is never
+used, since NIL is the empty list.")
+  )
 
 (defmacro def-clx-class ((name &rest options) &body slots)
   (if (or (not (listp *def-clx-class-use-defclass*))
 	  (member name *def-clx-class-use-defclass*))
-      (let ((clos-package (find-package :common-lisp))
+      (let ((clos-package #+clx-ansi-common-lisp
+			  (find-package :common-lisp)
+			  #-clx-ansi-common-lisp
+			  (or (find-package :clos)
+			      (find-package :pcl)
+			      (let ((lisp-pkg (find-package :lisp)))
+				(and (find-symbol (string 'defclass) lisp-pkg)
+				     lisp-pkg))))
 	    (constructor t)
 	    (constructor-args t)
 	    (include nil)
@@ -278,7 +476,7 @@
 		(setf (elt slot-types i) (getf slot :type t))))
 	    `(progn
 
-	       (eval-when (compile load eval)
+	       (eval-when (:compile-toplevel :load-toplevel :execute)
 		 (setf (get ',name 'def-clx-class) ',slots))
 
 	       ;; From here down are the system-specific expansions:
@@ -310,6 +508,14 @@
 					       `(,(kintern slot-name) ,slot-name)))
 				      constructor-args)))))
 		 ,(when predicate
+		    #+allegro
+		    `(progn
+		       (,(closintern 'defmethod) ,predicate (object)
+			 (declare (ignore object))
+			 nil)
+		       (,(closintern 'defmethod) ,predicate ((object ,name))
+			 t))
+		    #-allegro
 		    `(defun ,predicate (object)
 		       (typep object ',name)))
 		 ,(when copier
@@ -328,6 +534,13 @@
 	 (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.
@@ -337,7 +550,8 @@
 (def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
   ;; Lock for multi-processing systems
   (lock (make-process-lock "CLX Buffer Lock"))
-  (output-stream nil :type (or null stream))
+  #-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))
@@ -350,11 +564,17 @@
   (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))
+  (tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
   ;; Probably EQ to Output-Stream
-  (input-stream nil :type (or null 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.
@@ -374,21 +594,83 @@
   ;; Function to call to listen for input data
   (listen-function 'buffer-listen-default)
 
+  #+Genera (debug-io nil :type (or null stream))
   ) 
 
 ;;-----------------------------------------------------------------------------
+;; Printing routines.
+;;-----------------------------------------------------------------------------
+
+#-(or clx-ansi-common-lisp Genera)
+(defun print-unreadable-object-function (object stream type identity function)
+  (declare #+lispm
+	   (sys:downward-funarg 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 clx-ansi-common-lisp Genera)
+(defmacro print-unreadable-object
+	  ((object stream &key type identity) &body body)
+  (if body
+      `(flet ((.print-unreadable-object-body. () ,@body))
+	 (print-unreadable-object-function
+	   ,object ,stream ,type ,identity #'.print-unreadable-object-body.))
+    `(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
+
+
+;;-----------------------------------------------------------------------------
 ;; Image stuff
 ;;-----------------------------------------------------------------------------
 
-(defconstant *image-bit-lsb-first-p*
+(defconstant +image-bit-lsb-first-p+
 	     #+clx-little-endian t
 	     #-clx-little-endian nil)
 
-(defconstant *image-byte-lsb-first-p*
+(defconstant +image-byte-lsb-first-p+
 	     #+clx-little-endian t
 	     #-clx-little-endian nil)
 
-(defconstant *image-unit* 32)
+(defconstant +image-unit+ 32)
 
-(defconstant *image-pad* 32)
+(defconstant +image-pad+ 32)
+
+
+;;-----------------------------------------------------------------------------
+;; Foreign Functions
+;;-----------------------------------------------------------------------------
 
+#+(and lucid apollo (not lcl3.0))
+(lucid::define-foreign-function '(connect-to-server "connect_to_server")
+  '((:val host    :string)
+    (:val display :integer32))
+  :integer32)
+
+#+(and lucid (not apollo) (not lcl3.0))
+(lucid::define-c-function connect-to-server (host display)
+  :result-type :integer)
+
+#+lcl3.0
+(lucid::def-foreign-function
+    (connect-to-server 
+      (:language :c)
+      (:return-type :signed-32bit))
+  (host :simple-string)
+  (display :signed-32bit))
diff --git a/clx/dependent.lisp b/clx/dependent.lisp
index aa80fe78e..87aeb751f 100644
--- a/clx/dependent.lisp
+++ b/clx/dependent.lisp
@@ -17,72 +17,79 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/dependent.lisp,v 1.16 2005/06/17 13:06:18 rtoy Exp $")
+
+#+cmu
+(ext:file-comment "$Id: dependent.lisp,v 1.17 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
 (proclaim '(declaration array-register))
 
+#+cmu
 (setf (getf ext:*herald-items* :xlib)
       `("    CLX X Library " ,*version*))
 
+
 ;;; The size of the output buffer.  Must be a multiple of 4.
 (defparameter *output-buffer-size* 8192)
 
+#+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 (not clx-little-endian))
+#-(or clx-overlapping-arrays (not clx-little-endian))
 (progn
-  (defconstant *word-0* 0)
-  (defconstant *word-1* 1)
+  (defconstant +word-0+ 0)
+  (defconstant +word-1+ 1)
 
-  (defconstant *long-0* 0)
-  (defconstant *long-1* 1)
-  (defconstant *long-2* 2)
-  (defconstant *long-3* 3))
+  (defconstant +long-0+ 0)
+  (defconstant +long-1+ 1)
+  (defconstant +long-2+ 2)
+  (defconstant +long-3+ 3))
 
-#-(or clx-little-endian)
+#-(or clx-overlapping-arrays clx-little-endian)
 (progn
-  (defconstant *word-0* 1)
-  (defconstant *word-1* 0)
+  (defconstant +word-0+ 1)
+  (defconstant +word-1+ 0)
 
-  (defconstant *long-0* 3)
-  (defconstant *long-1* 2)
-  (defconstant *long-2* 1)
-  (defconstant *long-3* 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 (:compile-toplevel :load-toplevel :execute)
-
-(defconstant *buffer-speed* #+clx-debugging 1 #-clx-debugging 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 ()
-  #+clx-debugging
-  '(declare (optimize (speed 1) (safety 1)))
-  #-clx-debugging
-  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
-
-)
+  (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
+    "Speed compiler option for buffer code.")
+  (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
+    "Safety compiler option for buffer code.")
+  (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
+    "Debug compiler option for buffer code>")
+  (defun declare-bufmac ()
+    `(declare (optimize
+	       (speed ,+buffer-speed+)
+	       (safety ,+buffer-safety+)
+	       (debug ,+buffer-debug+))))
+  ;; 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+)
+	       (debug ,+buffer-debug+)))))
 
 (declaim (inline card8->int8 int8->card8
 		 card16->int16 int16->card16
 		 card32->int32 int32->card32))
 
-
+#-Genera
 (progn
 
 (defun card8->int8 (x)
@@ -129,9 +136,38 @@
 
 )
 
-(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
+#+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 excl)
 (progn
 
 (defun aref-card8 (a i)
@@ -164,7 +200,322 @@
 
 )
 
+#+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))
+
+)
+
+#+(or excl lcl3.0 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-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values card8))
+  #.(declare-buffun)
+  (the card8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			 :unsigned-byte)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		    :unsigned-byte) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-values int8))
+  #.(declare-buffun)
+  (the int8 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			:signed-byte)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		    :signed-byte) v))
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-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 (clx-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 (clx-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 (clx-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)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (clx-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
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values card8))
+  #.(declare-buffun)
+  (the card8 (lucid::%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 (lucid::%svref-8bit a i) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values int8))
+  #.(declare-buffun)
+  (the int8 (lucid::%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 (lucid::%svref-signed-8bit a i) v))
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values card16))
+  #.(declare-buffun)
+  (the card16 (lucid::%svref-16bit a (index-ash i -1))))
+  
+(defun aset-card16 (v a i)
+  (declare (type card16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (lucid::%svref-16bit a (index-ash i -1)) v))
+  
+(defun aref-int16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values int16))
+  #.(declare-buffun)
+  (the int16 (lucid::%svref-signed-16bit a (index-ash i -1))))
+  
+(defun aset-int16 (v a i)
+  (declare (type int16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (lucid::%svref-signed-16bit a (index-ash i -1)) v))
+
+(defun aref-card32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values card32))
+  #.(declare-buffun)
+  (the card32 (lucid::%svref-32bit a (index-ash i -2))))
+    
+(defun aset-card32 (v a i)
+  (declare (type card32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (lucid::%svref-32bit a (index-ash i -2)) v))
+
+(defun aref-int32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values int32))
+  #.(declare-buffun)
+  (the int32 (lucid::%svref-signed-32bit a (index-ash i -2))))
+    
+(defun aset-int32 (v a i)
+  (declare (type int32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (lucid::%svref-signed-32bit a (index-ash i -2)) v))
+
+(defun aref-card29 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i)
+	   (clx-values card29))
+  #.(declare-buffun)
+  (the card29 (lucid::%svref-32bit a (index-ash i -2))))
+
+(defun aset-card29 (v a i)
+  (declare (type card29 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (lucid::%svref-32bit a (index-ash i -2)) v))
+
+)
+
+
 
+#-(or excl lcl3.0 clx-overlapping-arrays)
 (progn
 
 (defun aref-card16 (a i)
@@ -174,17 +525,17 @@
   #.(declare-buffun)
   (the card16
        (logior (the card16
-		    (ash (the card8 (aref a (index+ i *word-1*))) 8))
+		    (ash (the card8 (aref a (index+ i +word-1+))) 8))
 	       (the card8
-		    (aref a (index+ i *word-0*))))))
+		    (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)))
+  (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)
@@ -194,17 +545,17 @@
   #.(declare-buffun)
   (the int16
        (logior (the int16
-		    (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
+		    (ash (the int8 (aref-int8 a (index+ i +word-1+))) 8))
 	       (the card8
-		    (aref a (index+ i *word-0*))))))
+		    (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)))
+  (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)
@@ -214,23 +565,23 @@
   #.(declare-buffun)
   (the card32
        (logior (the card32
-		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+		    (ash (the card8 (aref a (index+ i +long-3+))) 24))
 	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+		    (ash (the card8 (aref a (index+ i +long-2+))) 16))
 	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+		    (ash (the card8 (aref a (index+ i +long-1+))) 8))
 	       (the card8
-		    (aref a (index+ i *long-0*))))))
+		    (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)))
+  (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)
@@ -240,23 +591,23 @@
   #.(declare-buffun)
   (the int32
        (logior (the int32
-		    (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
+		    (ash (the int8 (aref-int8 a (index+ i +long-3+))) 24))
 	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+		    (ash (the card8 (aref a (index+ i +long-2+))) 16))
 	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+		    (ash (the card8 (aref a (index+ i +long-1+))) 8))
 	       (the card8
-		    (aref a (index+ i *long-0*))))))
+		    (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)))
+  (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)
@@ -266,23 +617,23 @@
   #.(declare-buffun)
   (the card29
        (logior (the card29
-		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+		    (ash (the card8 (aref a (index+ i +long-3+))) 24))
 	       (the card29
-		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+		    (ash (the card8 (aref a (index+ i +long-2+))) 16))
 	       (the card16
-		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+		    (ash (the card8 (aref a (index+ i +long-1+))) 8))
 	       (the card8
-		    (aref a (index+ i *long-0*))))))
+		    (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)))
+  (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)
 
 )
@@ -341,15 +692,14 @@
   (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
 
 
-#+cmu
-(progn
+#+(or cmu sbcl clisp) (progn
 
 ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
 ;;; is irrational, there can't be a precise rational representation.  In
 ;;; particular, the different float approximations will always be /=.  This
 ;;; causes problems with type checking, because people might compute an
 ;;; argument in any precision.  What we do is discard all the excess precision
-;;; in the value, and see if the protocal encoding falls in the desired range
+;;; in the value, and see if the protocol encoding falls in the desired range
 ;;; (64'ths of a degree.)
 ;;;
 (deftype angle () '(satisfies anglep))
@@ -373,7 +723,8 @@
 
 (macrolet ((char-translators ()
 	     (let ((alist
-		     `(;; The normal ascii codes for the control characters.
+		     `(#-lispm
+		       ;; The normal ascii codes for the control characters.
 		       ,@`((#\Return . 13)
 			   (#\Linefeed . 10)
 			   (#\Rubout . 127)
@@ -382,7 +733,21 @@
 			   (#\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)
@@ -435,6 +800,7 @@
 					  (dolist (pair alist)
 					    (setf (aref array (cdr pair)) (car pair)))
 					  array))
+			 #-Genera
 			 (progn
   			   (defun char->card8 (char)
 			     (declare (type base-char char))
@@ -450,6 +816,16 @@
 					    card8)
 				      (error "Invalid CHAR code ~D." 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))
+			   )
+			 #-Minima
 			 (dotimes (i 256)
 			   (unless (= i (char->card8 (card8->char i)))
 			     (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
@@ -457,6 +833,7 @@
 					 (card8->char i)
 					 (char->card8 (card8->char i))))
 			     (return nil)))
+			 #-Minima
 			 (dotimes (i (length *char-to-card8-translation-table*))
 			   (let ((char (code-char i)))
 			     (unless (eql char (card8->char (char->card8 char)))
@@ -489,15 +866,35 @@
 
 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
 
-#-mp
+#-(or LispM excl Minima sbcl (and cmu mp))
 (defun make-process-lock (name)
   (declare (ignore name))
   nil)
 
-#+mp
+#+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))
+
+#+Minima
+(defun make-process-lock (name)
+  (minima:make-lock name :recursive t))
+
+#+(and cmu mp)
 (defun make-process-lock (name)
   (mp:make-lock name))
 
+#+sbcl
+(defun make-process-lock (name)
+  (sb-thread:make-mutex :name name))
+
 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
 
 ;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
@@ -506,7 +903,7 @@
 
 ;; If you're not sharing DISPLAY objects within a multi-processing
 ;; shared-memory environment, this is sufficient
-#-cmu
+#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) )
 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
   (declare (ignore locator display whostate timeout))
   `(progn ,@body))
@@ -520,19 +917,20 @@
 ;;; display connection.  We inhibit GC notifications since display of them
 ;;; could cause recursive entry into CLX.
 ;;;
-#-mp
+#+(and CMU (not mp))
 (defmacro holding-lock ((locator display &optional whostate &key timeout)
 			&body body)
-  `(let ((ext:*gc-verbose* nil)
-	 (ext:*gc-inhibit-hook* nil)
-	 (ext:*before-gc-hooks* nil)
-	 (ext:*after-gc-hooks* nil))
+  `(let #+cmu((ext:*gc-verbose* nil)
+	      (ext:*gc-inhibit-hook* nil)
+	      (ext:*before-gc-hooks* nil)
+	      (ext:*after-gc-hooks* nil))
+	#+sbcl()
      ,locator ,display ,whostate ,timeout
      (system:without-interrupts (progn ,@body))))
 
 ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
 ;;;
-#+mp
+#+(and cmu mp)
 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
 			      &key timeout)
 			&body body)
@@ -540,6 +938,152 @@
   `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
     ,@body))
 
+#+clisp
+(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
+                              &key timeout)
+                        &body body)
+  (declare (ignore lock display whostate timeout))
+  `(progn
+     ,@body))
+
+#+sbcl
+(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
+			      &key timeout)
+			&body body)
+  ;; This macro is used by WITH-DISPLAY, which claims to be callable
+  ;; recursively.  So, had better use a recursive lock.
+  ;;
+  ;; FIXME: This is hideously ugly.  If WITH-TIMEOUT handled NIL
+  ;; timeouts...
+  (declare (ignore display whostate))
+  (if timeout
+      `(if ,timeout
+	   (handler-case
+	       (sb-ext:with-timeout ,timeout
+		 (sb-thread:with-recursive-lock (,lock)
+		   ,@body))
+	     (sb-ext:timeout () nil))
+	   (sb-thread:with-recursive-lock (,lock)
+	     ,@body))
+      `(sb-thread:with-recursive-lock (,lock)
+	 ,@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*))))
+			 ;; abort the PROCESS-UNLOCK if actually timing out
+			 (t
+			  (setf .have-lock. :abort)
+			  nil))
+	       ,@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))))
+	       ;; There is an apparent race condition here.  However, there is
+	       ;; no actual race condition -- our implementation of mp:process-
+	       ;; lock guarantees that the lock will still be held when it
+	       ;; returns, and no interrupt can happen between that and the
+	       ;; execution of the next form.  -- jdi 2/27/91
+	       (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.)))))
+
+#+Minima
+(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
+  `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
+		   ,@(and whostate `(:whostate ,whostate))
+		   ,@(and timeout `(:timeout ,timeout))))
+
+#+Minima
+(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
+  (declare (dynamic-extent continuation))
+  (declare (ignore display whostate timeout))
+  (minima:with-lock (lock)
+    (funcall continuation)))
 
 ;;; WITHOUT-ABORTS
 
@@ -548,38 +1092,174 @@
 ;;; 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.
-#-mp
+
+#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp))
 (defun process-block (whostate predicate &rest predicate-args)
   (declare (ignore whostate))
   (or (apply predicate predicate-args)
       (error "Program tried to wait with no scheduler.")))
 
-#+mp
+#+Genera
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent predicate)
+	   #-clx-ansi-common-lisp
+	   (sys: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)
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent predicate)
+	   #-clx-ansi-common-lisp 
+	   (sys: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))
+
+#+Minima
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   (dynamic-extent predicate))
+  (apply #'minima:process-wait whostate predicate predicate-args))
+
+#+(and cmu mp)
 (defun process-block (whostate predicate &rest predicate-args)
   (declare (type function predicate))
   (mp:process-wait whostate #'(lambda ()
 				(apply predicate predicate-args))))
 
+#+(and sbcl sb-thread)
+(progn
+  (declaim (inline yield))
+  (defun yield ()
+    (declare (optimize speed (safety 0)))
+    (sb-alien:alien-funcall
+     (sb-alien:extern-alien "sched_yield" (function sb-alien:int)))
+    (values)))
+
+#+(and sbcl sb-thread)
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (ignore whostate))
+  (declare (type function predicate))
+  (loop
+   (when (apply predicate predicate-args)
+     (return))
+   (yield)))
+
+
+;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
+;;; queues and condition variables might seem better, but in fact it
+;;; turns out to make performance extremely suboptimal, at least as
+;;; measured by McCLIM on linux 2.4 kernels.  -- CSR, 2003-11-10
+#+(or)
+(defvar *process-conditions* (make-hash-table))
+
+#+(or)
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (ignore whostate))
+  (declare (type function predicate))
+  (let* ((pid (sb-thread:current-thread-id))
+	 (last (gethash  pid *process-conditions*))
+	 (lock
+	  (or (car last)
+	      (sb-thread:make-mutex :name (format nil "lock ~A" pid))))
+	 (queue
+	  (or (cdr last)
+	      (sb-thread:make-waitqueue :name (format nil "queue ~A" pid)))))
+    (unless last
+      (setf (gethash pid *process-conditions*) (cons lock queue)))
+    (sb-thread:with-mutex (lock)
+      (loop
+       (when (apply predicate predicate-args) (return))
+       (handler-case
+	   (sb-ext:with-timeout .5
+	     (sb-thread:condition-wait queue lock))
+	 (sb-ext:timeout ()
+	   (format *trace-output* "thread ~A, process-block timed out~%"
+		   (sb-thread:current-thread-id) )))))))
+
 ;;; PROCESS-WAKEUP: Check some other process' wait function.
 
 (declaim (inline process-wakeup))
 
-#-mp
+#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp))
 (defun process-wakeup (process)
   (declare (ignore process))
   nil)
 
-#+mp
+#+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))
+
+#+Minima
+(defun process-wakeup (process)
+  (when process
+    (minima:process-wakeup process)))
+
+#+(and cmu mp)
 (defun process-wakeup (process)
   (declare (ignore process))
   (mp:process-yield))
 
+#+(and sb-thread sbcl)
+(defun process-wakeup (process)
+  (declare (ignore process))
+  (yield))
+#+(or)
+(defun process-wakeup (process)
+  (declare (ignore process))
+  (destructuring-bind (lock . queue)
+      (gethash (sb-thread:current-thread-id) *process-conditions*
+	       (cons nil nil))
+    (declare (ignore lock))
+    (when queue
+      (sb-thread:condition-notify queue))))
+
+
 ;;; CURRENT-PROCESS: Return the current process object for input locking and
 ;;; for calling PROCESS-WAKEUP.
 
@@ -587,29 +1267,90 @@
 
 ;;; Default return NIL, which is acceptable even if there is a scheduler.
 
-#-mp
+#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
 (defun current-process ()
   nil)
 
-#+mp
+#+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*)
+
+#+Minima
+(defun current-process ()
+  (minima:current-process))
+
+#+(and cmu mp)
 (defun current-process ()
   mp:*current-process*)
 
+#+sbcl
+(defun current-process ()
+  sb-thread:*current-thread*)
+
 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
-;;
+
+#-(or lispm excl lcl3.0 Minima cmu)
+(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))
+
+#+Minima
+(defmacro without-interrupts (&body body)
+  `(minima:with-no-other-processes ,@body))
+
+#+cmu
+(defmacro without-interrupts (&body body)
+  `(system:without-interrupts ,@body))
+
+#+sbcl
+(defvar *without-interrupts-sic-lock*
+  (sb-thread:make-mutex :name "lock simulating *without-interrupts*"))
+#+sbcl
+(defmacro without-interrupts (&body body)
+  `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*)
+    ,@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.
+#-sbcl
 (defmacro conditional-store (place old-value new-value)
   `(without-interrupts
      (cond ((eq ,place ,old-value)
 	    (setf ,place ,new-value)
 	    t))))
 
+#+sbcl
+(progn
+  (defvar *conditional-store-lock*
+    (sb-thread:make-mutex :name "conditional store"))
+  (defmacro conditional-store (place old-value new-value)
+    `(sb-thread:with-mutex (*conditional-store-lock*)
+       (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.
@@ -617,16 +1358,51 @@
 ;;;
 ;;;----------------------------------------------------------------------------
 
+#-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
@@ -634,53 +1410,311 @@
 ;;;	the stream to the server.
 ;;;----------------------------------------------------------------------------
 
-;;; OPEN-X-STREAM - create a stream for communicating to the
-;;; appropriate X server.
+;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
+;;; server
+
+#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
 (defun open-x-stream (host display protocol)
-  (ecase protocol
-    ;; establish a TCP connection to the X11 server, which is
-    ;; listening on port 6000 + display-number
-    ((:internet :tcp nil)
-     (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))
-       (unless (plusp fd)
-         (error 'connection-failure
-                :major-version *protocol-major-version*
-                :minor-version *protocol-minor-version*
-                :host host
-                :display display
-                :reason (format nil "Cannot connect to internet socket: ~S"
-                                (unix:get-unix-error-msg))))
-       (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8))))
-     ;; establish a connection to the X11 server over a Unix socket
-    (:unix
-     (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix")
-                                :name (format nil "X~D" display))))
-       (unless (probe-file path)
-         (error 'connection-failure
-                :major-version *protocol-major-version*
-                :minor-version *protocol-minor-version*
-                :host host
-                :display display
-                :reason (format nil "Unix socket ~s does not exist" path)))
-       (let ((fd (ext:connect-to-unix-socket (namestring path))))
-         (unless (plusp fd)
-           (error 'connection-failure
-                :major-version *protocol-major-version*
-                :minor-version *protocol-minor-version*
-                :host host
-                :display display
-                :reason (format nil "Can't connect to unix socket: ~S"
-                                (unix:get-unix-error-msg))))
-         (system:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8)))))))
+  host display protocol ;; unused
+  (error "OPEN-X-STREAM not implemented yet."))
 
+#+clisp
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol)
+           (type (integer 0) display))
+  (let ((socket
+         ;; are we dealing with a localhost?
+         (when (or (string= host "")
+                   (string= host "unix"))
+           ;; ok, try to connect to a AF_UNIX domain socket
+           (sys::make-socket-stream "" display))))
+    (if socket
+        socket
+        ;; try to connect by hand
+        (let ((host (host-address host)))
+          (when host
+            ;; Fixme: get a descent ip standard in CLX: a vector!
+            (let ((ip (format nil
+                              "~{~D~^.~}"
+                              (rest host))))
+              (socket:socket-connect (+ 6000 display) ip
+                                     :element-type '(unsigned-byte 8))))))))
+
+
+;;; 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))
+
+#+Minima
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol));; unused
+  (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
+						  (cdr (host-address host)))
+			  :foreign-port (+ *x-tcp-port* display)))
+
+
+#+CMU
+(defun open-x-stream (host display protocol)
+  (let ((stream-fd
+         (ecase protocol
+           ;; establish a TCP connection to the X11 server, which is
+           ;; listening on port 6000 + display-number
+           ((:internet :tcp nil)
+            (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))
+              (unless (plusp fd)
+                (error 'connection-failure
+                       :major-version *protocol-major-version*
+                       :minor-version *protocol-minor-version*
+                       :host host
+                       :display display
+                       :reason (format nil "Cannot connect to internet socket: ~S"
+                                       (unix:get-unix-error-msg))))
+              fd))
+           ;; establish a connection to the X11 server over a Unix socket
+           ((:unix :local)
+            (let ((path (make-pathname :directory '(:absolute "tmp" ".X11-unix")
+                                       :name (format nil "X~D" display))))
+              (unless (probe-file path)
+                (error 'connection-failure
+                       :major-version *protocol-major-version*
+                       :minor-version *protocol-minor-version*
+                       :host host
+                       :display display
+                       :reason (format nil "Unix socket ~s does not exist" path)))
+              (let ((fd (ext:connect-to-unix-socket (namestring path))))
+                (unless (plusp fd)
+                  (error 'connection-failure
+                         :major-version *protocol-major-version*
+                         :minor-version *protocol-minor-version*
+                         :host host
+                         :display display
+                         :reason (format nil "Can't connect to unix socket: ~S"
+                                         (unix:get-unix-error-msg))))
+                fd))))))
+    (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8))))
+
+
+
+#+(or sbcl ecl)
+(defconstant +X-unix-socket-path+
+  "/tmp/.X11-unix/X"
+  "The location of the X socket")
+
+#+sbcl
+(defun open-x-stream (host display protocol)  
+  (declare (ignore protocol)
+           (type (integer 0) display))
+  (socket-make-stream 
+   (if (or (string= host "") (string= host "unix")) ; AF_LOCAL domain socket
+       (let ((s (make-instance 'local-socket :type :stream)))
+	 (socket-connect s (format nil "~A~D" +X-unix-socket-path+ display))
+	 s)
+       (let ((host (car (host-ent-addresses (get-host-by-name host)))))
+	 (when host
+	   (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+	     (socket-connect s host (+ 6000 display))
+	     s))))
+   :element-type '(unsigned-byte 8)
+   :input t :output t :buffering :none))
+
+#+ecl
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol)
+	   (type (integer 0) display))
+  (let (socket)
+    (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket
+	(sys::open-unix-socket-stream
+	 (format nil "~A~D" +X-unix-socket-path+ display))
+	(si::open-client-stream host (+ 6000 display)))))
 
 ;;; 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 (real 0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (or (cond ((null stream))
+	      ((funcall stream :listen) nil)
+	      ((and timeout (= 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 (real 0 *)) 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)
+	      ((and timeout (= timeout 0)) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(fd-read-bytes fd vector start howmany))))
+
+
+#+lcl3.0
+(defmacro with-underlying-stream ((variable stream display direction) &body body)
+  `(let ((,variable
+	  (or (getf (display-plist ,display) ',direction)
+	      (setf (getf (display-plist ,display) ',direction)
+		    (lucid::underlying-stream
+		      ,stream ,(if (eq direction 'input) :input :output))))))
+     ,@body))
+
+#+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
+  ;;lcl:read-array.
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null (real 0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((and timeout (= timeout 0)) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(with-underlying-stream (stream stream display input)
+	  (eq (lcl:read-array stream vector start end nil :eof) :eof)))))
+
+#+Minima
+(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 (real 0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((and timeout (= timeout 0)) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(eq :eof (minima:read-vector vector stream nil start end)))))
+
+;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
 ;;;
 ;;;    If timeout is 0, then we call LISTEN to see if there is any input.
 ;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without
 ;;; first calling BUFFER-INPUT-WAIT-DEFAULT.
 ;;;
-#+CMU
+#+(or CMU sbcl)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
 	   (type buffer-bytes vector)
@@ -691,17 +1725,35 @@
 	      (not (listen (display-input-stream display))))
 	 :timeout)
 	(t
-	 (system:read-n-bytes (display-input-stream display)
-			      vector start (- end start))
+	 (#+cmu system:read-n-bytes
+	  #+sbcl sb-sys:read-n-bytes
+	  (display-input-stream display)
+	  vector start (- end start))
 	 nil)))
 
+#+(or ecl clisp)
+(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 fixnum) timeout))
+  #.(declare-buffun)
+  (cond ((and (eql timeout 0)
+	      (not (listen (display-input-stream display))))
+	 :timeout)
+	(t
+	 (read-sequence vector
+			(display-input-stream display)
+                        :start start
+                        :end end)
+	 nil)))
 
 ;;; 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 CMU)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
 	   (type buffer-bytes vector)
@@ -725,6 +1777,55 @@
 
 ;;; 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 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
+  ;;lcl:write-array.
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream) 
+      (with-underlying-stream (stream stream display output)
+	(lcl:write-array stream vector start end)))))
+
+#+Minima
+(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) 
+      (minima:write-vector vector stream start end))))
+
 #+CMU
 (defun buffer-write-default (vector display start end)
   (declare (type buffer-bytes vector)
@@ -734,13 +1835,34 @@
   (system:output-raw-bytes (display-output-stream display) vector start end)
   nil)
 
+#+sbcl
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (sb-impl::output-raw-bytes (display-output-stream display) vector start end)
+  nil)
+
+#+(or ecl clisp)
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (write-sequence vector
+                  (display-output-stream display)
+                  :start start
+                  :end end)
+  nil)
+
 ;;; 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 CMU)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
 (defun buffer-write-default (vector display start end)
   ;; The default buffer write function for use with common-lisp streams
   (declare (type buffer-bytes vector)
@@ -756,17 +1878,14 @@
 	  (declare (type array-index index))
 	  (write-byte (aref vector index) stream))))))
 
-#+CMU
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (system:output-raw-bytes (display-output-stream display) vector start end)
-  nil)
-
 ;;; 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)))
+
+#-(or excl)
 (defun buffer-force-output-default (display)
   ;; The default buffer force-output function for use with common-lisp streams
   (declare (type display display))
@@ -777,6 +1896,15 @@
 
 ;;; 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)))
+
+#-(or excl)
 (defun buffer-close-default (display &key abort)
   ;; The default buffer close function for use with common-lisp streams
   (declare (type display display))
@@ -794,10 +1922,10 @@
 ;;; The default implementation
 
 ;; Poll for input every *buffer-read-polling-time* SECONDS.
-#-(or CMU)
+#-(or Genera explorer excl lcl3.0 CMU sbcl)
 (defparameter *buffer-read-polling-time* 0.5)
 
-#-(or CMU)
+#-(or Genera explorer excl lcl3.0 CMU sbcl clisp)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null (real 0 *)) timeout))
@@ -821,7 +1949,7 @@
 		 (return-from buffer-input-wait-default nil)))
 	     :timeout)))))
 
-#+CMU
+#+(or CMU sbcl clisp)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null number) timeout))
@@ -831,19 +1959,142 @@
 	  ((listen stream) nil)
 	  ((eql timeout 0) :timeout)
 	  (t
-	   (if #-mp (system:wait-until-fd-usable (system:fd-stream-fd stream)
-						 :input timeout)
+	   (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
+						   :input timeout)
 	       #+mp (mp:process-wait-until-fd-usable
 		     (system:fd-stream-fd stream) :input timeout)
+               #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
+                         (ext:socket-status stream (and timeout sec)
+                                            (round usec 1d-6)))
+	       #-(or sbcl mp clisp) (system:wait-until-fd-usable
+			       (system:fd-stream-fd stream) :input timeout)
 	       nil
 	       :timeout)))))
 
+#+Genera
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null (real 0 *)) timeout))
+  (declare (clx-values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((scl:send stream :listen) nil)
+	  ((and timeout (= 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 (real 0 *)) timeout))
+  (declare (clx-values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((zl:send stream :listen) nil)
+	  ((and timeout (= 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* "waiting for input 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 (real 0 *)) timeout))
+  (declare (clx-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 (= timeout 0))
+	     ;; 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 (real 0 *)) timeout)
+	   (clx-values timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((and timeout (= timeout 0)) :timeout)
+	  ((with-underlying-stream (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.
-
+#-(or excl)
 (defun buffer-listen-default (display)
   (declare (type display display))
   (let ((stream (display-input-stream display)))
@@ -852,6 +2103,15 @@
 	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
@@ -863,6 +2123,7 @@
 ;; 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)
   ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
   ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
@@ -870,9 +2131,10 @@
   ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
   `(let ((,var (list ,@elements)))
      (declare (type cons ,var)
-	      (dynamic-extent ,var))
+	      #+clx-ansi-common-lisp (dynamic-extent ,var))
      ,@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)
@@ -880,29 +2142,131 @@
   ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
   `(let ((,var (list* ,@elements)))
      (declare (type cons ,var)
-	      (dynamic-extent ,var))
+	      #+clx-ansi-common-lisp (dynamic-extent ,var))
      ,@body))
 
 (declaim (inline buffer-replace))
 
-#+cmu
+#+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))
+    
+    (excl: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))))))
+
+#+cmu 
 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
   (declare (type buffer-bytes buf1 buf2)
 	   (type array-index start1 end1 start2))
   #.(declare-buffun)
   (kernel:bit-bash-copy
-   buf2 (+ (* start2 vm:byte-bits)
-	   (* vm:vector-data-offset vm:word-bits))
-   buf1 (+ (* start1 vm:byte-bits)
-	   (* vm:vector-data-offset vm:word-bits))
-   (* (- end1 start1) vm:byte-bits)))
+   buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
+	   (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
+   buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
+	   (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
+   (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)))
+
+#+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))
 
-#-CMU
+#-(or lispm lucid excl CMU 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))
@@ -945,7 +2309,7 @@
 ;;; should it also check for non-negative and less than 65536?
 ;;;----------------------------------------------------------------------------
  
-;; The *TYPE-CHECK?* constant controls how much error checking is done.
+;; 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
@@ -954,7 +2318,9 @@
 ;;; 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?* #+clx-debugging t #-clx-debugging nil)
+(defconstant +type-check?+
+  #+(or Genera Minima CMU sbcl) nil
+  #-(or Genera Minima CMU sbcl) 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
@@ -967,7 +2333,32 @@
 ;; dispatching, not just type checking.  -- Ram.
 
 (defmacro type? (object type)
-  `(typep ,object ,type))
+  #+(or cmu sbcl clisp)
+  `(typep ,object ,type)
+  #-(or cmu sbcl clisp)
+  (if (not (constantp type))
+      `(typep ,object ,type)
+    (progn
+      (setq type (eval type))
+      #+(or Genera explorer Minima)
+      (if +type-check?+
+	  `(locally (declare (optimize safety)) (typep ,object ',type))
+	`(typep ,object ',type))
+      #-(or Genera explorer Minima)
+      (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 'generalized-boolean)
+	       't)			; Everything is a generalized-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,
@@ -996,10 +2387,31 @@
       (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 clx-ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (apply #'sys:signal condition keyargs))
+
+#+(and lispm (not Genera) (not clx-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 clx-ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (declare (dbg:error-reporter))
+  (apply #'sys:signal condition keyargs))
+
+#+(and Genera (not clx-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 clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp))
 (defun x-error (condition &rest keyargs)
   (declare (dynamic-extent keyargs))
   (apply #'error condition keyargs))
 
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp)
 (defun x-cerror (proceed-format-string condition &rest keyargs)
   (declare (dynamic-extent keyargs))
   (apply #'cerror proceed-format-string condition keyargs))
@@ -1013,7 +2425,7 @@
 ;;; descriptors, Mach messages, etc.) to come through one routine anyone can
 ;;; use to wait for input.
 ;;;
-#+(and CMU (not mp))
+#+(and CMU (not mp)) 
 (defun x-error (condition &rest keyargs)
   (let ((condx (apply #'make-condition condition keyargs)))
     (when (eq condition 'closed-display)
@@ -1022,15 +2434,332 @@
 	(ext::disable-clx-event-handling disp)))
     (error condx)))
 
+#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
+(defun x-error (condition &rest keyargs)
+  (error "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
 
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
+(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)
+
+#+lcl3.0 
+(defmacro define-condition (name parent-types &optional slots &rest args)
+  `(lcl:define-condition
+     ,name (,(first parent-types))
+     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+	      slots)
+     ,@args))
+
+#+(and excl (not clx-ansi-common-lisp))
+(defmacro define-condition (name parent-types &optional slots &rest args)
+  `(excl::define-condition
+     ,name (,(first parent-types))
+     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+	      slots)
+     ,@args))
+
+#+(and CMU (not clx-ansi-common-lisp))
+(defmacro define-condition (name parent-types &optional slots &rest args)
+  `(common-lisp:define-condition
+     ,name (,(first parent-types))
+     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+	      slots)
+     ,@args))
+
+#+(and lispm (not clx-ansi-common-lisp))
+(defmacro define-condition (name parent-types &body options)
+  (let ((slot-names
+	  (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+		  (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 ,slot-names ,parent-types
+	 :initable-instance-variables
+	 #-Genera
+	 (:accessor-prefix ,conc-name)
+	 #+Genera
+	 (:conc-name ,conc-name)
+	 #-Genera
+	 (:outside-accessible-instance-variables ,@slot-names)
+	 #+Genera
+	 (:readable-instance-variables ,@slot-names))
+       ,(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 clx-ansi-common-lisp))
+(zl:defflavor x-error () (global:error))
+
+#+(and Genera (not clx-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 clx-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 clx-ansi-common-lisp))
+(scl:defmethod (dbg:proceed x-error :continue) ()
+  :continue)
+
+#+(and Genera (not clx-ansi-common-lisp))
+(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
+  (format stream continue-format-string))
+
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
 (define-condition x-error (error) ())
 
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+(defstruct x-error
+  report-function)
+
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+(defmacro define-condition (name parent-types &body options)
+  ;; Define a structure that when printed displays an error message
+  (flet ((reporter-for-condition (name)
+	   (xintern "." name '-reporter.)))
+    (let ((slot-names
+	    (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
+		    (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 (first parent-types))))
+      `(within-definition (,name define-condition)
+	 (defstruct (,name (:conc-name ,(intern conc-name))
+		     (:print-function condition-print)
+		     (:include ,(first parent-types)
+		      (report-function ',report-function)))
+	   ,@slot-names)
+	 ,(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 clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
+(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 clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
+(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 clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
+(define-condition type-error (x-error)
+  ((datum :reader type-error-datum :initarg :datum)
+   (expected-type :reader type-error-expected-type :initarg :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 Minima Allegro CMU sbcl ecl clisp)
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  host family
+  (error "HOST-ADDRESS not implemented yet."))
+
+#+clisp
+(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 stringable host)
+           (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (labels ((no-host-error ()
+             (error "Unknown host ~S" host))
+           (no-address-error ()
+             (error "Host ~S has no ~S address" host family)))
+
+    (let ((hostent (posix::resolve-host-ipaddr (string host))))
+      (when (not (posix::hostent-addr-list hostent))
+        (no-host-error))
+      (ecase family
+        ((:internet nil 0)
+         (unless (= (posix::hostent-addrtype hostent) 2)
+           (no-address-error))
+         (let ((addr (first (posix::hostent-addr-list hostent))))
+           (etypecase addr
+             (integer
+              (list :internet
+                    (ldb (byte 8 24) addr)
+                    (ldb (byte 8 16) addr)
+                    (ldb (byte 8  8) addr)
+                    (ldb (byte 8  0) addr)))
+             (string
+              (let ((parts (read-from-string
+                            (nsubstitute #\Space #\. (ext:string-concat
+                                                      "(" addr ")")))))
+                (check-type parts (cons (unsigned-byte 8)
+                                        (cons (unsigned-byte 8)
+                                              (cons (unsigned-byte 8)
+                                                    (cons (unsigned-byte 8)
+                                                          NULL)))))
+                (cons :internet parts))))))))))
+
+
+#+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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (ecase family
+    ((:internet nil 0)
+     (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 2)
+     (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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (setf host (string host))
+  (let ((net-type (ecase family
+		    ((:internet nil 0) :internet)
+		    ((:DECnet 1) :dna)
+		    ((:chaos 2) :chaos))))
+    (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 nil 0)
+		     (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
+		       (list :internet a b c d)))
+		    ((:DECnet 1)
+		     (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))
+		    ((:chaos 2)
+		     (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
+
+#+Minima
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (etypecase family
+    ((:internet nil 0)
+      (list* :internet
+	     (multiple-value-list
+	       (minima:ip-address-components (minima:parse-ip-address (string host))))))))
+
+#+Allegro
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (labels ((no-host-error ()
+	     (error "Unknown host ~S" host))
+	   (no-address-error ()
+	     (error "Host ~S has no ~S address" host family)))
+    (let ((hostent 0))
+      (unwind-protect
+	   (progn
+	     (setf hostent (ipc::gethostbyname (string host)))
+	     (when (zerop hostent)
+	       (no-host-error))
+	     (ecase family
+	       ((:internet nil 0)
+		(unless (= (ipc::hostent-addrtype hostent) 2)
+		  (no-address-error))
+		(assert (= (ipc::hostent-length hostent) 4))
+		(let ((addr (ipc::hostent-addr hostent)))
+		   (when (or (member comp::.target.
+				     '(:hp :sgi4d :sony :dec3100)
+				     :test #'eq)
+			     (probe-file "/lib/ld.so"))
+		     ;; BSD 4.3 based systems require an extra indirection
+		     (setq addr (si:memref-int addr 0 0 :unsigned-long)))
+		  (list :internet
+			(si:memref-int addr 0 0 :unsigned-byte)
+			(si:memref-int addr 1 0 :unsigned-byte)
+			(si:memref-int addr 2 0 :unsigned-byte)
+			(si:memref-int addr 3 0 :unsigned-byte))))))
+	(ff:free-cstruct hostent)))))
+
+;#+sbcl
+;(require :sockets)
+
+#+CMU
 (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.
@@ -1048,12 +2777,98 @@
 	((:internet nil 0)
 	 (unless (= (ext::host-entry-addr-type hostent) 2)
 	   (no-address-error))
-	 (let ((addr (first (ext::host-entry-addr-list hostent))))
-	   (list :internet
-		 (ldb (byte 8 24) addr)
-		 (ldb (byte 8 16) addr)
-		 (ldb (byte 8  8) addr)
-		 (ldb (byte 8  0) addr))))))))
+	 (append (list :internet)
+		 (let ((addr (first (ext::host-entry-addr-list hostent))))
+			(list (ldb (byte 8 24) addr)
+			      (ldb (byte 8 16) addr)
+			      (ldb (byte 8  8) addr)
+			      (ldb (byte 8  0) addr)))))))))
+
+#+sbcl
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (let ((hostent (get-host-by-name (string host))))
+    (ecase family
+      ((:internet nil 0)
+       (cons :internet (coerce (host-ent-address hostent) 'list))))))
+
+#+ecl
+(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 stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (labels ((no-host-error ()
+	     (error "Unknown host ~S" host)))
+    (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host))))))
+      (unless addr
+	(no-host-error))
+      (list :internet
+	    (ldb (byte 8 24) addr)
+	    (ldb (byte 8 16) addr)
+	    (ldb (byte 8  8) addr)
+	    (ldb (byte 8  0) addr)))))
+
+#+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 (clx-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 (clx-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)))
+
+;;; This isn't required, but it helps make sense of the results from access-hosts
+#+Minima
+(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 (clx-values string family))
+  (let ((family (first host-object)))
+    (values (ecase family
+	      (:internet
+		(minima:ip-address-string
+		  (apply #'minima:make-ip-address (rest host-object)))))
+	    family)))
 
 
 ;;-----------------------------------------------------------------------------
@@ -1067,8 +2882,15 @@
 ;;; want to make this expand to T, as it makes the code more compact.
 
 (defmacro use-closures ()
-  t) ;; emarsden2003-06-04 was NIL
+  #+(or lispm Minima) t
+  #-(or lispm Minima) nil)
+
+#+(or Genera Minima)
+(defun clx-macroexpand (form env)
+  (declare (ignore env))
+  form)
 
+#-(or Genera Minima)
 (defun clx-macroexpand (form env)
   (macroexpand form env))
 
@@ -1081,7 +2903,24 @@
 ;;; Utilities 
 
 (defun getenv (name)
-  (cdr (assoc name ext:*environment-list* :test #'string=)))
+  #+excl (sys:getenv name)
+  #+lcl3.0 (lcl:environment-variable name)
+  #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
+  #+sbcl (sb-ext:posix-getenv name)
+  #+ecl (si:getenv name)
+  #+clisp (ext:getenv name)
+  #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil))
+
+(defun get-host-name ()
+  "Return the same hostname as gethostname(3) would"
+  ;; machine-instance probably works on a lot of lisps, but clisp is not
+  ;; one of them
+  #+(or cmu sbcl) (machine-instance)
+  ;; resources-pathname was using short-site-name for this purpose
+  #+excl (short-site-name)
+  #+ecl (si:getenv "HOST")
+  #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
+  #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented"))
 
 (defun homedir-file-pathname (name)
   (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
@@ -1100,7 +2939,8 @@
   (or (let ((string (getenv "XENVIRONMENT")))
 	(and string
 	     (pathname string)))
-      (homedir-file-pathname (concatenate 'string ".Xdefaults-" (machine-instance)))))
+      (homedir-file-pathname
+       (concatenate 'string ".Xdefaults-" (get-host-name)))))
 
 ;;; AUTHORITY-PATHNAME - The pathname of the authority file.
 
@@ -1110,6 +2950,50 @@
 	     (pathname xauthority)))
       (homedir-file-pathname ".Xauthority")))
 
+;;; this particular defaulting behaviour is typical to most Unices, I think
+#+unix
+(defun get-default-display (&optional display-name)
+  "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
+if it is NIL.  Display names have the format
+
+  [protocol/] [hostname] : [:] displaynumber [.screennumber]
+
+There are two special cases in parsing, to match that done in the Xlib
+C language bindings
+
+ - If the hostname is ``unix'' or the empty string, any supplied
+   protocol is ignored and a connection is made using the :local
+   transport.
+
+ - If a double colon separates hostname from displaynumber, the
+   protocol is assumed to be decnet.
+
+Returns a list of (host display-number screen protocol)."
+  (let* ((name (or display-name
+		   (getenv "DISPLAY")
+		   (error "DISPLAY environment variable is not set")))
+	 (slash-i (or (position #\/ name) -1))
+	 (colon-i (position #\: name :start (1+ slash-i)))
+	 (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
+	 (host (subseq name (1+ slash-i) colon-i))
+	 (dot-i (and colon-i (position #\. name :start colon-i)))
+	 (display (when colon-i
+		    (parse-integer name
+				   :start (if decnet-colon-p
+					      (+ colon-i 2)
+					      (1+ colon-i))
+				   :end dot-i)))
+	 (screen (when dot-i
+		   (parse-integer name :start (1+ dot-i))))
+	 (protocol
+	  (cond ((or (string= host "") (string-equal host "unix")) :local)
+		(decnet-colon-p :decnet)
+		((> slash-i -1) (intern
+				 (string-upcase (subseq name 0 slash-i))
+				 :keyword))
+		(t :internet))))
+    (list host (or display 0) (or screen 0) protocol)))
+
 
 ;;-----------------------------------------------------------------------------
 ;; GC stuff
@@ -1129,6 +3013,41 @@
   (setq *temp-gcontext-cache* nil)
   nil)
 
+#+Genera
+(si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
+  (gc-cleanup))
+
+
+;;-----------------------------------------------------------------------------
+;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
+;;-----------------------------------------------------------------------------
+
+#-(or clx-ansi-common-lisp Genera CMU sbcl)
+(defun with-standard-io-syntax-function (function)
+  (declare #+lispm
+	   (sys:downward-funarg function))
+  (let ((*package* (find-package :user))
+	(*print-array* t)
+	(*print-base* 10)
+	(*print-case* :upcase)
+	(*print-circle* nil)
+	(*print-escape* t)
+	(*print-gensym* t)
+	(*print-length* nil)
+	(*print-level* nil)
+	(*print-pretty* nil)
+	(*print-radix* nil)
+	(*read-base* 10)
+	(*read-default-float-format* 'single-float)
+	(*read-suppress* nil)
+	#+ticl (ticl:*print-structure* t)
+	#+lucid (lucid::*print-structure* t))
+    (funcall function)))
+
+#-(or clx-ansi-common-lisp Genera CMU sbcl)
+(defmacro with-standard-io-syntax (&body body)
+  `(flet ((.with-standard-io-syntax-body. () ,@body))
+     (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
 
 
 ;;-----------------------------------------------------------------------------
@@ -1146,7 +3065,30 @@
 ;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
 ;;; In ambiguous cases, the most specific translation is used.
 
+#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
+(defun default-keysym-translate (display state object)
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object)
+	   (clx-values t)
+	   (special left-meta-keysym right-meta-keysym
+		    left-super-keysym right-super-keysym
+		    left-hyper-keysym right-hyper-keysym))
+  (when (characterp object)
+    (when (logbitp (position :control +state-mask-vector+) state)
+      (setf (char-bit object :control) 1))
+    (when (or (state-keysymp display state left-meta-keysym)
+	      (state-keysymp display state right-meta-keysym))
+      (setf (char-bit object :meta) 1))
+    (when (or (state-keysymp display state left-super-keysym)
+	      (state-keysymp display state right-super-keysym))
+      (setf (char-bit object :super) 1))
+    (when (or (state-keysymp display state left-hyper-keysym)
+	      (state-keysymp display state right-hyper-keysym))
+      (setf (char-bit object :hyper) 1)))
+  object)
 
+#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp)
 (defun default-keysym-translate (display state object)
   (declare (type display display)
 	   (type card16 state)
@@ -1178,25 +3120,31 @@
   '(unsigned-byte 24))
 
 (deftype pixarray-32-element-type ()
- '(unsigned-byte 32))
+  #-(or Genera Minima) '(unsigned-byte 32)
+  #+(or Genera Minima) 'fixnum)
 
 (deftype pixarray-1  ()
-  '(simple-array pixarray-1-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-1-element-type (* *)))
 
 (deftype pixarray-4  ()
-  '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-4-element-type (* *)))
 
 (deftype pixarray-8  ()
-  '(simple-array pixarray-8-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-8-element-type (* *)))
 
 (deftype pixarray-16 ()
-  '(simple-array pixarray-16-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-16-element-type (* *)))
 
 (deftype pixarray-24 ()
-  '(simple-array pixarray-24-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array
+    #-(or cmu sbcl) array pixarray-24-element-type (* *)))
 
 (deftype pixarray-32 ()
-  '(simple-array pixarray-32-element-type (* *)))
+  '(#+(or cmu sbcl) simple-array #-(or cmu sbcl) array pixarray-32-element-type (* *)))
 
 (deftype pixarray ()
   '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
@@ -1206,70 +3154,110 @@
 
 ;;; WITH-UNDERLYING-SIMPLE-VECTOR 
 
-#+CMU
+#+Genera
+(defmacro with-underlying-simple-vector
+	  ((variable element-type pixarray) &body body)
+  (let ((bits-per-element
+	  (sys:array-bits-per-element
+	    (symbol-value (sys:type-array-element-type element-type)))))
+    `(scl:stack-let ((,variable
+		      (make-array
+			(index-ceiling
+			  (index* (array-total-size ,pixarray)
+				  (sys:array-element-size ,pixarray))
+			  ,bits-per-element)
+			:element-type ',element-type
+			:displaced-to ,pixarray)))
+       (declare (type (vector ,element-type) ,variable))
+       ,@body)))
+
+#+lcl3.0
+(defmacro with-underlying-simple-vector
+	  ((variable element-type pixarray) &body body)
+  `(let ((,variable (sys:underlying-simple-vector ,pixarray)))
+     (declare (type (simple-array ,element-type (*)) ,variable))
+     ,@body))
+
+#+excl
+(defmacro with-underlying-simple-vector
+	  ((variable element-type pixarray) &body body)
+  `(let ((,variable (cdr (excl::ah_data ,pixarray))))
+     (declare (type (simple-array ,element-type (*)) ,variable))
+     ,@body))
+
+#+(or CMU sbcl)
 ;;; We do *NOT* support viewing an array as having a different element type.
 ;;; Element-type is ignored.
 ;;;
 (defmacro with-underlying-simple-vector 
-	  ((variable element-type pixarray) &body body)
+    ((variable element-type pixarray) &body body)
   (declare (ignore element-type))
-  `(lisp::with-array-data ((,variable ,pixarray)
-			   (start)
-			   (end))
-      (declare (ignore start end))
-      ,@body))
+  `(#+cmu lisp::with-array-data #+sbcl sb-kernel:with-array-data
+    ((,variable ,pixarray) (start) (end))
+    (declare (ignore start end))
+    ,@body))
 
 ;;; 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)
-  (unless *image-bit-lsb-first-p* (setq position (- 7 position)))
+  (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
   `(the (unsigned-byte ,size)
-	(ldb (byte ,size ,position)(the card8 ,integer))))
+	(#-Genera ldb #+Genera sys:%logldb
+	 (byte ,size ,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)
-  (unless *image-byte-lsb-first-p* (setq bytes (reverse bytes)))
+  (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
   (let ((it (first bytes))
 	(count 0))
     (dolist (byte (rest bytes))
       (setq it
-	    `(dpb
+	    `(#-Genera dpb #+Genera sys:%logdpb 
 	      (the card8 ,byte)
 	      (byte 8 ,(incf count 8))
 	      (the (unsigned-byte ,count) ,it))))
-    `(the (unsigned-byte ,(* (length bytes) 8)) ,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
-  (unless *image-byte-lsb-first-p* (setq position (- integer-size 8 position)))
+  (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
   `(the card8
-	(ldb
+	(#-Genera ldb #+Genera sys:%logldb
 	 (byte 8 ,position)
-	 (the (unsigned-byte ,integer-size) ,integer))))
+	 #-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)
-  (unless *image-bit-lsb-first-p* (setq bytes (reverse bytes)))
+  (unless +image-bit-lsb-first-p+ (setq bytes (reverse bytes)))
   (let ((size (floor 8 (length bytes)))
 	(it (first bytes))
 	(count 0))
     (dolist (byte (rest bytes))
-      (setq it `(dpb
+      (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)))
 
+#+(or Genera lcl3.0 excl)
+(defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+)
+
+#+(or Genera lcl3.0 excl)
+(defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+)
+
 ;;; 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
@@ -1301,15 +3289,256 @@
 ;;; 2Ll	07-00 15-08 23-16 31-24
 ;;; 4Ll	07-00 15-08 23-16 31-24
 
+#+(or Genera lcl3.0 excl) 
+(defconstant
+  *image-bit-ordering-table*
+  '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))
+    ((1 (07 00) (15 08) (23 16) (31 24)) (nil t))
+    ((2 (15 08) (07 00) (31 24) (23 16)) (nil t))
+    ((4 (31 24) (23 16) (15 08) (07 00)) (nil t))
+    ((1 (00 07) (08 15) (16 23) (24 31)) (t   nil))
+    ((2 (08 15) (00 07) (24 31) (16 23)) (t   nil))
+    ((4 (24 31) (16 23) (08 15) (00 07)) (t   nil))
+    ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))
+    ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))
+    ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))
+  
+#+(or Genera lcl3.0 excl) 
+(defun compute-image-byte-and-bit-ordering ()
+  (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))
+  ;; First compute the ordering 
+  (let ((ordering nil)
+	(a (make-array '(1 32) :element-type 'bit :initial-element 0)))
+    (dotimes (i 4)
+      (push (flet ((bitpos (a i n)
+		     (declare (optimize (speed 3) (safety 0) (space 0)))
+		     (declare (type (simple-array bit (* *)) a)
+			      (type fixnum i n))
+		     (with-underlying-simple-vector (v (unsigned-byte 8) a)
+		       (prog2
+			 (setf (aref v i) n)
+			 (dotimes (i 32)
+			   (unless (zerop (aref a 0 i))
+			     (return i)))
+			 (setf (aref v i) 0)))))
+	      (list (bitpos a i #b10000000)
+		    (bitpos a i #b00000001)))
+	    ordering))
+    (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering)))
+    ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p
+    (let ((byte-and-bit-ordering
+	    (second (assoc ordering *image-bit-ordering-table*
+			   :test #'equal))))
+      (unless byte-and-bit-ordering
+	(error "Couldn't determine image byte and bit ordering~@
+                measured image ordering = ~A"
+	       ordering))
+      (values-list byte-and-bit-ordering))))
+
+#+(or Genera lcl3.0 excl) 
+(multiple-value-setq
+  (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+  (compute-image-byte-and-bit-ordering))
 
 ;;; 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.
 
+;;; FIXME: though we have some #+sbcl -conditionalized routines in
+;;; here, they would appear not to work, and so are commented out in
+;;; the the FAST-xxx-PIXARRAY routines themseleves.  Investigate
+;;; whether the unoptimized routines are often used, and also whether
+;;; speeding them up while maintaining correctness is possible.
+
 ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
 
-#+(or CMU)
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
+			     padded-bytes-per-line bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-1-element-type array)
+      (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 (the array-index (mod (the fixnum (- x)) 8)))
+	    (right-bits (index-mod (index- width left-bits) 8))
+	    (middle-bits (the fixnum (- (the fixnum (- 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-bytes)
+		 (fixnum middle-bits))
+	(cond ((< 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 bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-4-element-type array)
+      (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 (the array-index (mod (the fixnum (- (the fixnum 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 (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 Genera lcl3.0 excl CMU sbcl)
 (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
 			      padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1340,7 +3569,22 @@
 		  (aref buffer-bbuf (index+ i 2))))))))
   t)
 
-#+CMU
+#+lispm
+(defun fast-read-pixarray-using-bitblt
+       (bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel)
+  (#+Genera sys:stack-let* #-Genera let*
+   ((dimensions (list (+ y height)
+		      (floor (* padded-bytes-per-line 8) bits-per-pixel)))
+    (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)
+
+#+(or CMU sbcl)
 (defun pixarray-element-size (pixarray)
   (let ((eltype (array-element-type pixarray)))
     (cond ((eq eltype 'bit) 1)
@@ -1360,36 +3604,58 @@
 (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
 			     height width)
   (declare (type array-index source-width sx sy dest-width dx dy height width))
-   #.(declare-buffun)
-   (lisp::with-array-data ((sdata source)
-			   (sstart)
-			   (send))
-     (declare (ignore send))
-     (lisp::with-array-data ((ddata dest)
-			     (dstart)
-			     (dend))
-       (declare (ignore dend))
-       (assert (and (zerop sstart) (zerop dstart)))
-       (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
-			     sx (index* sy source-width))
-		     (index+ src-idx source-width))
-	    (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
-			      dx (index* dy dest-width))
-		      (index+ dest-idx dest-width))
-	    (count height (1- count)))
-	   ((zerop count))
-	 (declare (type array-index src-idx dest-idx count))
-	 (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
-
-#+CMU
+  #.(declare-buffun)
+  (lisp::with-array-data ((sdata source)
+                          (sstart)
+                          (send))
+    (declare (ignore send))
+    (lisp::with-array-data ((ddata dest)
+                            (dstart)
+                            (dend))
+      (declare (ignore dend))
+      (assert (and (zerop sstart) (zerop dstart)))
+      (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
+			    sx (index* sy source-width))
+		    (index+ src-idx source-width))
+	   (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
+			     dx (index* dy dest-width))
+		     (index+ dest-idx dest-width))
+	   (count height (1- count)))
+	  ((zerop count))
+	(declare (type array-index src-idx dest-idx count))
+	(kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
+
+
+#+sbcl
+(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
+			     height width)
+  (declare (type array-index source-width sx sy dest-width dx dy height width))
+  #.(declare-buffun)
+  (sb-kernel:with-array-data ((sdata source) (sstart) (send))
+    (declare (ignore send))
+    (sb-kernel:with-array-data ((ddata dest) (dstart) (dend))
+      (declare (ignore dend))
+      (assert (and (zerop sstart) (zerop dstart)))
+      (do ((src-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+			    sx (index* sy source-width))
+		    (index+ src-idx source-width))
+	   (dest-idx (index+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+			     dx (index* dy dest-width))
+		     (index+ dest-idx dest-width))
+	   (count height (1- count)))
+	  ((zerop count))
+	(declare (type array-index src-idx dest-idx count))
+	(sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width)))))
+
+#+(or CMU sbcl)
 (defun fast-read-pixarray-using-bitblt
        (bbuf boffset pixarray x y width height padded-bytes-per-line
 	bits-per-pixel)
   (declare (type (array * 2) pixarray))
   #.(declare-buffun)
   (copy-bit-rect bbuf
-		 (index* padded-bytes-per-line vm:byte-bits)
-		 (index* boffset vm:byte-bits) 0
+		 (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
+		 (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
 		 pixarray
 		 (index* (array-dimension pixarray 1) bits-per-pixel)
 		 x y
@@ -1397,6 +3663,51 @@
 		 (index* width bits-per-pixel))
   t)
 
+#+(or Genera lcl3.0 excl)
+(defun fast-read-pixarray-with-swap
+       (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (unless (index= bits-per-pixel 24)
+    (let ((pixarray-padded-bits-per-line
+	    (if (index= height 1) 0
+	      (index* (index- (array-row-major-index pixarray 1 0)
+			      (array-row-major-index pixarray 0 0))
+		      bits-per-pixel)))
+	  (x-bits (index* x bits-per-pixel)))
+      (declare (type array-index pixarray-padded-bits-per-line x-bits))
+      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		     (index-zerop (index-mod x-bits 8)))
+	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		   (index-zerop (index-mod x-bits +image-unit+))))
+	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
+	    (image-swap-function
+	      bits-per-pixel 
+	      unit byte-lsb-first-p bit-lsb-first-p
+	      +image-unit+ *computed-image-byte-lsb-first-p*
+	      *computed-image-bit-lsb-first-p*)
+	  (declare (type symbol image-swap-function)
+		   (type generalized-boolean image-swap-lsb-first-p))
+	  (with-underlying-simple-vector (dst card8 pixarray)
+	    (funcall
+	      (symbol-function image-swap-function) bbuf dst
+	      (index+ boffset
+		      (index* y padded-bytes-per-line)
+		      (index-floor x-bits 8))
+	      0 (index-ceiling (index* width bits-per-pixel) 8)
+	      padded-bytes-per-line
+	      (index-floor pixarray-padded-bits-per-line 8)
+	      height image-swap-lsb-first-p)))
+	t))))
+
 (defun fast-read-pixarray (bbuf boffset pixarray
 			   x y width height padded-bytes-per-line
 			   bits-per-pixel
@@ -1412,9 +3723,30 @@
   (progn bbuf boffset pixarray x y width height padded-bytes-per-line
 	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (or
+    #+(or Genera lcl3.0 excl)
+    (fast-read-pixarray-with-swap
+      bbuf boffset pixarray x y width height padded-bytes-per-line
+      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
     (let ((function
-	    (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
+	    (or #+lispm
+		(and (= (sys:array-element-size pixarray) bits-per-pixel)
+		     (zerop (index-mod padded-bytes-per-line 4))
+		     (zerop (index-mod
+			      (* #+Genera (sys:array-row-span pixarray)
+				 #-Genera (array-dimension pixarray 1)
+				 bits-per-pixel)
+			      32))
+		     #'fast-read-pixarray-using-bitblt)
+		#+(or CMU)
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
 		     #'fast-read-pixarray-using-bitblt)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 1)
+		     #'fast-read-pixarray-1)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 4)
+		     #'fast-read-pixarray-4)
+		#+(or Genera lcl3.0 excl CMU)
 		(and (index= bits-per-pixel 24)
 		     #'fast-read-pixarray-24))))
       (when function
@@ -1422,11 +3754,115 @@
 	  bbuf boffset pixarray x y width height padded-bytes-per-line
 	  bits-per-pixel function
 	  unit byte-lsb-first-p bit-lsb-first-p
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))))
+	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))))
 
 ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
 
-#+(or CMU)
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-1-element-type array)
+      (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 (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 bits-per-pixel)
+  (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)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (ignore bits-per-pixel))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (with-underlying-simple-vector (vector pixarray-4-element-type array)
+      (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 (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 Genera lcl3.0 excl CMU sbcl)
 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
 			       padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1459,7 +3895,22 @@
 		  (write-image-load-byte 16 pixel 24)))))))
   t)
 
-#+CMU
+#+lispm
+(defun fast-write-pixarray-using-bitblt
+       (bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel)
+  (#+Genera sys:stack-let* #-Genera let*
+   ((dimensions (list (+ y height)
+		      (floor (* padded-bytes-per-line 8) bits-per-pixel)))
+    (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)
+
+#+(or CMU sbcl)
 (defun fast-write-pixarray-using-bitblt
        (bbuf boffset pixarray x y width height padded-bytes-per-line
 	bits-per-pixel)
@@ -1468,12 +3919,56 @@
 		 (index* (array-dimension pixarray 1) bits-per-pixel)
 		 x y
 		 bbuf
-		 (index* padded-bytes-per-line vm:byte-bits)
-		 (index* boffset vm:byte-bits) 0
+		 (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
+		 (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
 		 height
 		 (index* width bits-per-pixel))
   t)
 
+#+(or Genera lcl3.0 excl)
+(defun fast-write-pixarray-with-swap
+       (bbuf 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 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)
+	   (type (member 8 16 32) unit)
+	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
+  (unless (index= bits-per-pixel 24)
+    (let ((pixarray-padded-bits-per-line
+	    (if (index= height 1) 0
+	      (index* (index- (array-row-major-index pixarray 1 0)
+			      (array-row-major-index pixarray 0 0))
+		      bits-per-pixel)))
+	  (pixarray-start-bit-offset
+	    (index* (array-row-major-index pixarray y x)
+		    bits-per-pixel)))
+      (declare (type array-index pixarray-padded-bits-per-line
+		     pixarray-start-bit-offset))
+      (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		     (index-zerop (index-mod pixarray-start-bit-offset 8)))
+	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		   (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
+	    (image-swap-function
+	      bits-per-pixel
+	      +image-unit+ *computed-image-byte-lsb-first-p*
+	      *computed-image-bit-lsb-first-p*
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	  (declare (type symbol image-swap-function)
+		   (type generalized-boolean image-swap-lsb-first-p))
+	  (with-underlying-simple-vector (src card8 pixarray)
+	    (funcall
+	      (symbol-function image-swap-function)
+	      src bbuf (index-floor pixarray-start-bit-offset 8) boffset
+	      (index-ceiling (index* width bits-per-pixel) 8)
+	      (index-floor pixarray-padded-bits-per-line 8)
+	      padded-bytes-per-line height image-swap-lsb-first-p))
+	  t)))))
+
 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
 			    padded-bytes-per-line bits-per-pixel
 			    unit byte-lsb-first-p bit-lsb-first-p)
@@ -1487,16 +3982,37 @@
   (progn bbuf boffset pixarray x y width height padded-bytes-per-line
 	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (or
+    #+(or Genera lcl3.0 excl)
+    (fast-write-pixarray-with-swap
+      bbuf boffset pixarray x y width height padded-bytes-per-line
+      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
     (let ((function
-	    (or (and (index= (pixarray-element-size pixarray) bits-per-pixel)
+	    (or #+lispm
+		(and (= (sys:array-element-size pixarray) bits-per-pixel)
+		     (zerop (index-mod padded-bytes-per-line 4))
+		     (zerop (index-mod
+			      (* #+Genera (sys:array-row-span pixarray)
+				 #-Genera (array-dimension pixarray 1)
+				 bits-per-pixel)
+			      32))
 		     #'fast-write-pixarray-using-bitblt)
+		#+(or CMU)
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
+		     #'fast-write-pixarray-using-bitblt)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 1)
+		     #'fast-write-pixarray-1)
+		#+(or lcl3.0 excl)
+		(and (index= bits-per-pixel 4)
+		     #'fast-write-pixarray-4)
+		#+(or Genera lcl3.0 excl CMU)
 		(and (index= bits-per-pixel 24)
 		     #'fast-write-pixarray-24))))
       (when function
 	(write-pixarray-internal
 	  bbuf boffset pixarray x y width height padded-bytes-per-line
 	  bits-per-pixel function
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
+	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
 	  unit byte-lsb-first-p bit-lsb-first-p)))))
 
 ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
@@ -1506,19 +4022,95 @@
 	   (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 nil)
-  (let* ((pixarray-padded-pixels-per-line
-	  (array-dimension pixarray 1))
-	 (pixarray-padded-bits-per-line
-	  (* pixarray-padded-pixels-per-line bits-per-pixel))
-	 (copy-padded-pixels-per-line
-	  (array-dimension copy 1))
-	 (copy-padded-bits-per-line
-	  (* copy-padded-pixels-per-line bits-per-pixel)))
-    (when (index= (pixarray-element-size pixarray)
-		  (pixarray-element-size copy)
-		  bits-per-pixel)
-      (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
-		     copy copy-padded-bits-per-line 0 0
-		     height
-		     (index* width bits-per-pixel))
+  (or
+    #+(or lispm CMU)
+    (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)))
+      #-(or CMU)
+      (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)
+      #+(or CMU)
+      (when (index= (pixarray-element-size pixarray)
+		    (pixarray-element-size copy)
+		    bits-per-pixel)
+	(copy-bit-rect pixarray pixarray-padded-bits-per-line x y
+		       copy copy-padded-bits-per-line 0 0
+		       height
+		       (index* width bits-per-pixel))
+	t))
+	
+    #+(or lcl3.0 excl)
+    (unless (index= bits-per-pixel 24)
+      (let ((pixarray-padded-bits-per-line
+	      (if (index= height 1) 0
+		(index* (index- (array-row-major-index pixarray 1 0)
+				(array-row-major-index pixarray 0 0))
+			bits-per-pixel)))
+	    (copy-padded-bits-per-line
+	      (if (index= height 1) 0
+		(index* (index- (array-row-major-index copy 1 0)
+				(array-row-major-index copy 0 0))
+			bits-per-pixel)))
+	    (pixarray-start-bit-offset
+	      (index* (array-row-major-index pixarray y x)
+		      bits-per-pixel)))
+	(declare (type array-index pixarray-padded-bits-per-line
+		       copy-padded-bits-per-line pixarray-start-bit-offset))
+	(when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		  (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		       (index-zerop (index-mod copy-padded-bits-per-line 8))
+		       (index-zerop (index-mod pixarray-start-bit-offset 8)))
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod copy-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+	  (with-underlying-simple-vector (src card8 pixarray)
+	    (with-underlying-simple-vector (dst card8 copy)
+	      (image-noswap
+		src dst
+		(index-floor pixarray-start-bit-offset 8) 0
+		(index-ceiling (index* width bits-per-pixel) 8)
+		(index-floor pixarray-padded-bits-per-line 8)
+		(index-floor copy-padded-bits-per-line 8)
+		height nil)))
+	  t)))
+    #+(or lcl3.0 excl)
+    (macrolet
+      ((copy (type element-type)
+	 `(let ((pixarray pixarray)
+		(copy copy))
+	    (declare (type ,type pixarray copy))
+	    #.(declare-buffun)
+	    (with-underlying-simple-vector (src ,element-type pixarray)
+	      (with-underlying-simple-vector (dst ,element-type 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-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
index 4a2937ee8..5cf54a991 100644
--- a/clx/display.lisp
+++ b/clx/display.lisp
@@ -17,101 +17,121 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/display.lisp,v 1.12 2004/08/13 12:24:30 emarsden Exp $")
+(ext:file-comment "$Id: display.lisp,v 1.13 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
-;;; X11 Authorization: to prevent malicious users from snooping on an
+;;; Authorizaton
+
+(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
+
+;;; X11 Authorization: to prevent malicious users from snooping on a
 ;;; display, X servers may require connection requests to be
 ;;; authorized. The X server (or display manager) will create a random
 ;;; key on startup, and store it as an entry in a file generally named
-;;; $HOME/.Xauthority (see the function AUTHORITY-PATHNAME). Clients
-;;; must extract from this file the "magic cookie" that corresponds to
-;;; the server they wish to connect to, and send it as authorization
-;;; data when opening the display.
-;;;
-;;; Users can manipulate the contents of their .Xauthority file using
-;;; the xauth command. 
-;;;
-;;; The function GET-BEST-AUTHORIZATION is responsible for parsing the
-;;; .Xauthority file and extracting the cookie for DISPLAY on HOST.
-;;; The HOST argument is the hostname of the target display as a
-;;; string, and DISPLAY is a number. The PROTOCOL argument determines
-;;; whether the server connection is using an Internet protocol
-;;; (values of :tcp or :internet) or a non-network protocol such as
-;;; Unix domain sockets (value of :unix). GET-BEST-AUTHORITY returns
-;;; two strings: an authorization name (very likely the string
-;;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
-;;; fixnums in a vector. If the function fails to find an appropriate
-;;; cookie, it returns two empty strings.
-;;;
+;;; $HOME/.Xauthority (see xauth(1) and the AUTHORITY-PATHNAME
+;;; function). Clients must extract from this file the "magic cookie"
+;;; that corresponds to the server they wish to connect to, and send
+;;; it as authorization data when opening the display.
+
 ;;; The format of the .Xauthority file is documented in the XFree
 ;;; sources, in the file xc/lib/Xau/README.
 
-(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
+;;; Stolen from the cmucl sources, with patches by Hannu Rummukainen and
+;;; Scott Fahlman.
 
-(defun get-best-authorization (host display protocol)
+(defun read-xauth-entry (stream)
   (labels ((read-short (stream &optional (eof-errorp t))
-	     (let ((high-byte (read-byte stream eof-errorp)))
-	       (and high-byte
-		    (dpb high-byte (byte 8 8) (read-byte stream)))))
-	   (read-short-length-string (stream)
-	     (let ((length (read-short stream)))
-	       (let ((string (make-string length)))
-		 (dotimes (k length)
-		   (setf (schar string k) (card8->char (read-byte stream))))
-		 string)))
-	   (read-short-length-vector (stream)
-	     (let ((length (read-short stream)))
-	       (let ((vector (make-array length :element-type '(unsigned-byte 8))))
-		 (dotimes (k length)
-		   (setf (aref vector k) (read-byte stream)))
-		 vector))))
-    (let ((pathname (authority-pathname)))
-      (when pathname
-	(with-open-file (stream pathname :element-type '(unsigned-byte 8)
-				:if-does-not-exist nil)
-	  (when stream
-	    (let* ((host-family (ecase protocol
-				  ((:tcp :internet nil) 0)
-				  ((:dna :DECnet) 1)
-				  ((:chaos) 2)
-				  ((:unix) 256)))
-		   (host-address (if (eq protocol :unix)
-				     (map 'list #'char-int (machine-instance))
-				     (rest (host-address host host-family))))
-		   (best-name nil)
-		   (best-data nil))
-	      ;; Check for the localhost address, in which case we're
-	      ;; really FamilyLocal.
-	      (when (and (= host-family 0)
-			 (equal host-address '(127 0 0 1)))
-		(setq host-address (map 'list #'char-int (machine-instance)))
-		(setq host-family 256))
-	      (loop
-	       (let ((family (read-short stream nil)))
-		 (when (null family)
-		   (return))
-		 (let* ((address (read-short-length-vector stream))
-			(number (parse-integer (read-short-length-string stream)))
-			(name (read-short-length-string stream))
-			(data (read-short-length-vector stream)))
-		   (when (and (= family host-family)
-			      (equal host-address (coerce address 'list))
-			      (= number display)
-			      (let ((pos1 (position name *known-authorizations* :test #'string=)))
-				(and pos1
-				     (or (null best-name)
-					 (< pos1 (position best-name *known-authorizations*
-							   :test #'string=))))))
-		     (setf best-name name)
-		     (setf best-data data)))))
-	      (when best-name
-		(return-from get-best-authorization
-		  (values best-name best-data)))))))))
-  (values "" ""))
+             (let ((high-byte (read-byte stream eof-errorp)))
+               (and high-byte
+                    (dpb high-byte (byte 8 8) (read-byte stream)))))
+           (read-short-length-string (stream)
+             (let ((length (read-short stream)))
+               (let ((string (make-string length)))
+                 (dotimes (k length)
+                   (setf (schar string k) (card8->char (read-byte stream))))
+                 string)))
+           (read-short-length-vector (stream)
+             (let ((length (read-short stream)))
+               (let ((vector (make-array length 
+                                         :element-type '(unsigned-byte 8))))
+                 (dotimes (k length)
+                   (setf (aref vector k) (read-byte stream)))
+                 vector))))
+    (let ((family-id (read-short stream nil)))
+      (if (null family-id)
+          (list nil nil nil nil nil)
+          (let* ((address-data (read-short-length-vector stream))
+                 (number (parse-integer (read-short-length-string stream)))
+                 (name (read-short-length-string stream))
+                 (data (read-short-length-vector stream))
+                 (family (car (rassoc family-id *protocol-families*))))
+            (unless family
+              (return-from read-xauth-entry
+                ;; we return FAMILY-ID to signal to
+                ;; GET-BEST-AUTHORIZATION that we haven't finished
+                ;; with the stream.
+                (list family-id nil nil nil nil)))
+            (let ((address 
+                   (case family
+                     (:local (map 'string #'code-char address-data))
+                     (:internet (coerce address-data 'list))
+                     ;; FIXME: we can probably afford not to support
+                     ;; :DECNET or :CHAOSNET in this modern age, but
+                     ;; :INTERNET6 probably deserve support.  -- CSR,
+                     ;; 2005-08-07
+                     (t nil))))
+              ;; if ADDRESS is NIL by this time, we will never match
+              ;; the address of DISPLAY.
+              (list family address number name data)))))))
+
+(defun get-best-authorization (host display protocol)
+  ;; parse .Xauthority, extract the cookie for DISPLAY on HOST.
+  ;; PROTOCOL determines whether the server connection is using an
+  ;; Internet protocol (value of :internet) or a non-network
+  ;; protocol such as Unix domain sockets (value of :local).  Returns
+  ;; two strings: an authorization name (very likely the string
+  ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as
+  ;; fixnums in a vector.  If we fail to find an appropriate cookie,
+  ;; return two empty strings.
+  (let ((pathname (authority-pathname)))
+    (when pathname
+      (with-open-file (stream pathname :element-type '(unsigned-byte 8)
+			      :if-does-not-exist nil)
+	(when stream
+	  (let* ((host-address (and (eql protocol :internet)
+				    (rest (host-address host protocol))))
+		 (best-name nil) (best-pos nil)
+		 (best-data nil))
+	    ;; Check for the localhost address, in which case we're
+	    ;; really FamilyLocal.
+	    (when (or (eql protocol :local)
+		      (and (eql protocol :internet)
+			   (equal host-address '(127 0 0 1))))
+	      (setq host-address (get-host-name))
+	      (setq protocol :local))
+	    (loop
+	     (destructuring-bind (family address number name data)
+		 (read-xauth-entry stream)
+	       (unless family (return))
+	       (when (and (eql family protocol)
+			  (equal host-address address)
+			  (= number display)
+			  (let ((pos1 (position name *known-authorizations*
+						:test #'string=)))
+			    (and pos1
+				 (or (null best-pos)
+				     (< pos1 best-pos)))))
+		 (setf best-name name
+		       best-pos (position name *known-authorizations*
+					  :test #'string=)
+		       best-data data))))
+	    (when best-name
+	      (return-from get-best-authorization
+		(values best-name best-data)))))))
+    (values "" "")))
 
 ;;
 ;; Resource id management
@@ -138,7 +158,7 @@
 
 (defmacro allocate-resource-id (display object type)
   ;; Allocate a resource-id for OBJECT in DISPLAY
-  (if (member (eval type) *clx-cached-types*)
+  (if (member (eval type) +clx-cached-types+)
       `(let ((id (funcall (display-xid ,display) ,display)))
 	 (save-id ,display id ,object)
 	 id)
@@ -146,7 +166,7 @@
 
 (defmacro deallocate-resource-id (display id type)
   ;; Deallocate a resource-id for OBJECT in DISPLAY
-  (when (member (eval type) *clx-cached-types*)
+  (when (member (eval type) +clx-cached-types+)
     `(deallocate-resource-id-internal ,display ,id)))
 
 (defun deallocate-resource-id-internal (display id)
@@ -175,19 +195,19 @@
 			  (declare (type display display)
 				   (type resource-id id))
 			  (declare (clx-values ,type))
-			  ,(if (member type *clx-cached-types*)
+			  ,(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?*)
+					,(cond ((null +type-check?+)
 						`(t ,type))
 					       ((member type '(window pixmap))
 						`((type? ,type 'drawable) ,type))
 					       (t `((type? ,type ',type) ,type)))
-					,@(when *type-check?*
+					,@(when +type-check?+
 					    `((t (x-error 'lookup-error
 							  :id id
 							  :display display
@@ -235,9 +255,9 @@
 (defsetf atom-id set-atom-id)
 
 (defun initialize-predefined-atoms (display)
-  (dotimes (i (length *predefined-atoms*))
+  (dotimes (i (length +predefined-atoms+))
     (declare (type resource-id i))
-    (setf (atom-id (svref *predefined-atoms* i) display) i)))
+    (setf (atom-id (svref +predefined-atoms+ i) display) i)))
 
 (defun visual-info (display visual-id)
   (declare (type display display)
@@ -261,15 +281,17 @@
 ;;
 (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.
+  ;; 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)))
@@ -285,6 +307,7 @@
 		   ,@body)))
      ,(if (and (null inline) (macroexpand '(use-closures) env))
 	  `(flet ((.with-event-queue-body. () ,@body))
+	     #+clx-ansi-common-lisp
 	     (declare (dynamic-extent #'.with-event-queue-body.))
 	     (with-event-queue-function
 	       ,display ,timeout #'.with-event-queue-body.))
@@ -300,7 +323,12 @@
   (declare (type display display)
 	   (type (or null number) timeout)
 	   (type function function)
-	   (dynamic-extent function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent function)
+	   ;; FIXME: see SBCL bug #243
+	   (ignorable display timeout)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg function))
   (with-event-queue (display :timeout timeout :inline t)
     (funcall function)))
 
@@ -312,37 +340,49 @@
 		      ,@(and timeout `(:timeout ,timeout)))
 	 ,@body))))
 
-(defun open-display (host &key (display 0) (protocol :tcp) authorization-name authorization-data)
-  ;; 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 network when displaying on the local host.
+(defun open-default-display (&optional display-name)
+  "Open a connection to DISPLAY-NAME if supplied, or to the appropriate
+default display as given by GET-DEFAULT-DISPLAY otherwise.
+
+OPEN-DISPLAY-NAME always attempts to do display authorization.  The
+hostname is resolved to an address, then authorization data for the
+(protocol, host-address, displaynumber) triple is looked up in the
+file given by AUTHORITY_PATHNAME (typically $HOME/.Xauthority).  If
+the protocol is :local, or if the hostname resolves to the local host,
+authority data for the local machine's actual hostname - as returned by
+gethostname(3) - is used instead."
+  (destructuring-bind (host display screen protocol)
+      (get-default-display display-name)
+    (let ((display (open-display host :display display :protocol protocol)))
+      (setf (display-default-screen display) (nth screen (display-roots display)))
+      display)))
+
+(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
+  ;; 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.
+  ;; system dependent.  The default protocol is system specific.  Authorization,
+  ;; if any, is assumed to come from the environment somehow.
   (declare (type integer display))
   (declare (clx-values display))
-  ;; If the HOST argument is empty (for instance the $DISPLAY environment variable was
-  ;; ":0") or if it is the special case of "unix", we connect to the X server using
-  ;; the :unix protocol. This is the most efficient transport to the local host, most
-  ;; often a Unix-domain socket. In this case, X11 does not store authorization data
-  ;; under the name "localhost", since that would make it impossible to store
-  ;; authorization data for concurrent X11 sessions on different hosts in the same
-  ;; $XAUTHORITY file. Rather, the authorization data is stored under the local host's
-  ;; hostname.
-  (let ((auth-host host))
-    (when (or (equal host "") (equal host "unix"))
-      (setf protocol :unix)
-      (setf auth-host (machine-instance)))
-    ;; If no authorization data was specified by the user, attempt to extract
-    ;; authorization data from the environment.
+
+  (let ((protocol
+	 (if (member host '("" "unix") :test #'equal)
+	     :local
+	     protocol)))
+    ;; Get the authorization mechanism from the environment.  Handle the
+    ;; special case of a host name of "" and "unix" which means the
+    ;; protocol is :local
     (when (null authorization-name)
       (multiple-value-setq (authorization-name authorization-data)
-        (get-best-authorization auth-host display protocol)))
-    ;; PROTOCOL is the network protocol used to connect to the server
-    ;; (either :TCP or :UNIX).
+	(get-best-authorization host display protocol)))
+    ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
     (let* ((stream (open-x-stream host display protocol))
-           (disp (make-buffer *output-buffer-size* #'make-display-internal
+	   (disp (make-buffer *output-buffer-size* #'make-display-internal
 			      :host host :display display
 			      :output-stream stream :input-stream stream))
 	   (ok-p nil))
@@ -356,9 +396,14 @@
 	     (initialize-resource-allocator disp)
 	     (initialize-predefined-atoms disp)
 	     (initialize-extensions disp)
+	     (when (assoc "BIG-REQUESTS" (display-extension-alist disp)
+			  :test #'string=)
+	       (enable-big-requests disp))
 	     (setq ok-p t))
 	(unless ok-p (close-display disp :abort t)))
-      disp)))
+      disp))
+  )
+
 
 (defun display-force-output (display)
   ; Output is normally buffered, this forces any buffered output to the server.
@@ -374,10 +419,10 @@
 (defun display-connect (display &key authorization-name 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
+     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))
@@ -392,112 +437,112 @@
   (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
-		(declare (ignorable i))
-		(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)
-		(declare (ignorable i))
-		(buffer-input display buffer-bbuf 0 40)
-		(let* ((root-id (card32-get 0))
-		       (root (make-window :id root-id :display display))
-		       (root-visual (card32-get 32))
-		       (default-colormap-id (card32-get 4))
-		       (default-colormap
+	 (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
+		 (declare (ignorable i))
+		 (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)
+		 (declare (ignorable i))
+		 (buffer-input display buffer-bbuf 0 40)
+		 (let* ((root-id (card32-get 0))
+			(root (make-window :id root-id :display display))
+			(root-visual (card32-get 32))
+			(default-colormap-id (card32-get 4))
+			(default-colormap
 			 (make-colormap :id default-colormap-id :display display))
-		       (screen
+			(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 root-id root)
-		  (save-id display default-colormap-id default-colormap)
-		  ;; Create the depth AList for a screen, (depth . visual-infos)
-		  (dotimes (j num-depths)
-		    (declare (ignorable j))
-		    (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)
-			(declare (ignorable k))
-			(buffer-input display buffer-bbuf 0 24)
-			(let* ((visual (card32-get 0))
-			       (visual-info (make-visual-info
+			  :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 root-id root)
+		   (save-id display default-colormap-id default-colormap)
+		   ;; Create the depth AList for a screen, (depth . visual-infos)
+		   (dotimes (j num-depths)
+		     (declare (ignorable j))
+		     (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)
+			 (declare (ignorable k))
+			 (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)
+										 :static-color :pseudo-color
+										 :true-color :direct-color)
 					      :bits-per-rgb (card8-get 5)
 					      :colormap-entries (card16-get 6)
 					      :red-mask (card32-get 8)
@@ -505,16 +550,16 @@
 					      :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))))))
+			   (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)
@@ -537,13 +582,14 @@
 
 #+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:
+  ;; 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
@@ -560,11 +606,12 @@
   )
 
   ;; 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.
+  ;; 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)
 
@@ -580,7 +627,7 @@
   ;; 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))
+  (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
        ()
     )
   ;; Report asynchronous errors here if the user wants us to.
diff --git a/clx/dpms.lisp b/clx/dpms.lisp
new file mode 100644
index 000000000..1413b7ddb
--- /dev/null
+++ b/clx/dpms.lisp
@@ -0,0 +1,171 @@
+
+;;;; Original Author: Matthew Kennedy <mkennedy@gentoo.org>
+;;;;
+;;;; Documentation strings derived from DPMS.txt distributed with the Xorg X11
+;;;; server implementation.  DPMS.txt contains the following copyright:
+;;;;
+;;;;  Copyright (C) Digital Equipment Corporation, 1996
+;;;;
+;;;;  Permission to use, copy, modify, distribute, and sell this documentation
+;;;;  for any purpose is hereby granted without fee, provided that the above
+;;;;  copyright notice and this permission notice appear in all copies.  Digital
+;;;;  Equipment Corporation makes no representations about the suitability for
+;;;;  any purpose of the information in this document.  This documentation is
+;;;;  provided ``as is'' without express or implied warranty.
+
+#+cmu
+(ext:file-comment "$Id")
+
+(defpackage :dpms
+  (:use :common-lisp)
+  (:import-from :xlib
+                "DEFINE-EXTENSION"
+                "DISPLAY"
+                "WITH-BUFFER-REQUEST-AND-REPLY"
+                "WITH-BUFFER-REQUEST"
+                "EXTENSION-OPCODE"
+                "CARD8-GET"
+                "CARD16-GET"
+                "BOOLEAN-GET"
+                "CARD8"
+                "CARD16"
+                "DATA")
+  (:export "DPMS-GET-VERSION"
+           "DPMS-CAPABLE"
+           "DPMS-GET-TIMEOUTS"
+           "DPMS-SET-TIMEOUTS"
+           "DPMS-ENABLE"
+           "DPMS-DISABLE"
+           "DPMS-FORCE-LEVEL"
+           "DPMS-INFO"))
+
+(in-package :dpms)
+
+(define-extension "DPMS")
+
+(defmacro dpms-opcode (display)
+  `(extension-opcode ,display "DPMS"))
+
+(defconstant +get-version+  0)
+(defconstant +capable+      1)
+(defconstant +get-timeouts+ 2)
+(defconstant +set-timeouts+ 3)
+(defconstant +enable+       4)
+(defconstant +disable+      5)
+(defconstant +force-level+  6)
+(defconstant +info+         7)
+
+(defun dpms-get-version (display &optional (major-version 1) (minor-version 1))
+  "Return two values: the major and minor version of the DPMS
+implementation the server supports.
+
+If supplied, the MAJOR-VERSION and MINOR-VERSION indicate what
+version of the protocol the client wants the server to implement."
+  (declare (type display display))
+  (with-buffer-request-and-reply (display (dpms-opcode display) nil)
+      ((data +get-version+)
+       (card16 major-version)
+       (card16 minor-version))
+    (values (card16-get 8)
+            (card16-get 10))))
+
+(defun dpms-capable (display)
+  "True if the currently running server's devices are capable of
+DPMS operations.  
+
+The truth value of this request is implementation defined, but is
+generally based on the capabilities of the graphic card and
+monitor combination.  Also, the return value in the case of
+heterogeneous multi-head servers is implementation defined."
+  (declare (type display display))
+  (with-buffer-request-and-reply (display (dpms-opcode display) nil)
+      ((data +capable+))
+    (boolean-get 8)))
+
+(defun dpms-get-timeouts (display)
+  "Return three values: the current values of the DPMS timeout
+values.  The timeout values are (in order returned): standby,
+suspend and off.  All values are in units of seconds.  A value of
+zero for any timeout value indicates that the mode is disabled."
+  (declare (type display display))
+  (with-buffer-request-and-reply (display (dpms-opcode display) nil)
+      ((data +get-timeouts+))
+    (values (card16-get 8)
+            (card16-get 10)
+            (card16-get 12))))
+
+(defun dpms-set-timeouts (display standby suspend off)
+  "Set the values of the DPMS timeouts.  All values are in units
+of seconds.  A value of zero for any timeout value disables that
+mode."
+  (declare (type display display))
+  (with-buffer-request (display (dpms-opcode display))
+    (data +set-timeouts+)
+    (card16 standby)
+    (card16 suspend)
+    (card16 off)
+    (card16 0))                         ;unused
+  (values))
+
+(defun dpms-enable (display)
+  "Enable the DPMS characteristics of the server using the
+server's currently stored timeouts.  If DPMS is already enabled,
+no change is affected."
+  (declare (type display display))
+  (with-buffer-request (display (dpms-opcode display))
+    (data +enable+))
+  (values))
+
+(defun dpms-disable (display)
+  "Disable the DPMS characteristics of the server.  It does not
+affect the core or extension screen savers.  If DPMS is already
+disabled, no change is effected.
+
+This request is provided so that DPMS may be disabled without
+damaging the server's stored timeout values."
+  (declare (type display display))
+  (with-buffer-request (display (dpms-opcode display))
+    ((data +disable+)))
+  (values))
+
+(defun dpms-force-level (display power-level)
+  "Forces a specific DPMS level on the server.  Valid keyword
+values for POWER-LEVEL are: DPMS-MODE-ON, DPMS-MODE-STANDBY,
+DPMS-MODE-SUSPEND and DPMS-MODE-OFF."
+  (declare (type display display))
+  (with-buffer-request (display (dpms-opcode display))
+    (data +force-level+)
+    (card16 (ecase power-level
+              (:dpms-mode-on 0)
+              (:dpms-mode-standby 1)
+              (:dpms-mode-suspend 2)
+              (:dpms-mode-off 3)))
+    (card16 0))                         ;unused
+  (values))
+
+(defun dpms-info (display)
+  "Returns two valus: the DPMS power-level and state value for the display.
+
+State is one of the keywords DPMS-ENABLED or DPMS-DISABLED.
+
+If state is DPMS-ENABLED, then power level is returned as one of
+the keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND
+or DPMS-MODE-OFF.  If state is DPMS-DISABLED, then power-level is
+undefined and returned as NIL."
+  (declare (type display display))
+  (with-buffer-request-and-reply (display (dpms-opcode display) nil)
+      ((data +info+))
+    (let ((state (if (boolean-get 10)
+                     :dpms-enabled
+                     :dpms-disabled)))
+      (values (unless (eq state :dpms-disabled)
+                (ecase (card16-get 8)
+                  (0 :dpms-mode-on)
+                  (1 :dpms-mode-standby)
+                  (2 :dpms-mode-suspend)
+                  (3 :dpms-mode-off)))
+              state))))
+
+;;; Local Variables:
+;;; indent-tabs-mode: nil
+;;; End:
diff --git a/clx/exclMakefile b/clx/exclMakefile
new file mode 100644
index 000000000..3890d23a4
--- /dev/null
+++ b/clx/exclMakefile
@@ -0,0 +1,170 @@
+# 
+#  Makefile for CLX
+#  (X11 R4.4 release, Franz Allegro Common Lisp version)
+#
+# $Id: exclMakefile,v 1.4 2007/08/21 15:49:28 fgilham Exp $
+#
+
+# *************************************************************************
+# * 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	= defsystem.fasl package.fasl excldep.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	= package.fasl 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 package.cl excldep.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
+
+# default and aliases
+all:	no-clos
+# all:	partial-clos
+compile-CLX-for-CLUE:	compile-partial-clos-CLX
+clue:	partial-clos
+
+#
+# Three build rules are provided: no-clos, partial-clos, and full-clos.
+# The first is no-clos, which results in a CLX whose datastructures are
+# all defstructs.  partial-clos results in xlib:window, xlib:pixmap, and
+# xlib:drawable being CLOS instances, all others defstructs.  full-clos
+# makes all CLX complex datatypes into CLOS instances.
+#
+# (note that the :clos feature implies native CLOS *not* PCL).
+#
+
+no-clos:	$(C_OBJS) compile-no-clos-CLX cat
+
+#
+# This rule is used to compile CLX to be used with XCW version 2, or CLUE.
+#
+partial-clos:	$(C_OBJS) compile-partial-clos-CLX cat
+
+full-clos:	$(C_OBJS) compile-full-clos-CLX cat
+
+
+c:	$(C_OBJS)
+
+
+compile-no-clos-CLX:	$(C_OBJS)
+	$(ECHO) " \
+	(set-case-mode :case-sensitive-lower) \
+	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
+	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
+	(load \"defsystem\") \
+	#+allegro (compile-system :clx) \
+	#-allegro (compile-clx) \
+	#+allegro (compile-system :clx-debug)" \
+	| $(CL) $(CLOPTS) -batch
+
+compile-partial-clos-CLX:	$(C_OBJS)
+	$(ECHO) " \
+	#+clos (set-case-mode :case-sensitive-lower) \
+	#-clos (setq excl::*print-nickname* t) \
+	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
+	(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))) \
+	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
+	(load \"defsystem\") \
+	(load \"package\") \
+	(setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \
+	#+allegro (compile-system :clx) \
+	#-allegro (compile-clx \"\" \"\" :for-clue t) \
+	#+allegro (compile-system :clx-debug)" \
+	| $(CL) $(CLOPTS) -batch
+
+compile-full-clos-CLX:	$(C_OBJS)
+	$(ECHO) " \
+	#+clos (set-case-mode :case-sensitive-lower) \
+	#-clos (setq excl::*print-nickname* t) \
+	(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \
+	(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))) \
+	#+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \
+	(load \"defsystem\") \
+	(load \"package\") \
+	(setq xlib::*def-clx-class-use-defclass* t) \
+	#+allegro (compile-system :clx) \
+	#-allegro (compile-clx \"\" \"\" :for-clue t) \
+	#+allegro (compile-system :clx-debug)" \
+	| $(CL) $(CLOPTS) -batch
+
+
+cat:
+	-cat $(L_NOMACROS_OBJS) > CLX.fasl
+
+
+load-CLX:
+	$(ECHO) " \
+	(let ((spread (sys:gsgc-parameter :generation-spread))) \
+	  (setf (sys:gsgc-parameter :generation-spread) 1) \
+	  (load \"defsystem\") \
+	  #+allegro (load-system :clx) \
+	  #-allegro (load-clx) \
+	  (gc :tenure) \
+	  (setf (sys:gsgc-parameter :generation-spread) spread)) \
+	(gc t)" \
+	'(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \
+	"(exit)" | $(CL) $(CLOPTS)
+
+clean:
+	$(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out
+
+
+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..2ecd2b9b0
--- /dev/null
+++ b/clx/exclREADME
@@ -0,0 +1,58 @@
+$Id: exclREADME,v 1.4 2007/08/21 15:49:28 fgilham Exp $
+
+     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,
+3.1, and 4.0.
+
+     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
+% 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/excldefsys.lisp b/clx/excldefsys.lisp
new file mode 100644
index 000000000..379c4f971
--- /dev/null
+++ b/clx/excldefsys.lisp
@@ -0,0 +1,189 @@
+;;; -*- 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.
+;;;
+
+#+cmu
+(ext:file-comment "$Id")
+
+(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..5b96a44d2
--- /dev/null
+++ b/clx/excldep.c
@@ -0,0 +1,77 @@
+/*
+ * Allegro CL dependent C helper routines for CLX
+ */
+
+/* 
+ * $Id: excldep.c,v 1.3 2007/08/21 15:49:28 fgilham Exp $
+ */
+
+/*
+ * 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..93ee776bc
--- /dev/null
+++ b/clx/excldep.lisp
@@ -0,0 +1,438 @@
+;;; -*- 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.
+;;;
+
+#+cmu
+(ext:file-comment "$Id: excldep.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+
+(in-package :xlib)
+
+(eval-when (compile load eval)
+  (require :foreign)
+  (require :process)			; Needed even if scheduler is not
+					; running.  (Must be able to make
+					; a process-lock.)
+  )
+
+(eval-when (load)
+  (provide :clx))
+
+
+#-(or little-endian big-endian)
+(eval-when (eval compile load)
+  (let ((x '#(1)))
+    (if (not (eq 0 (sys::memref x
+				#.(sys::mdparam 'comp::md-lvector-data0-norm)
+				0 :unsigned-byte)))
+	(pushnew :little-endian *features*)
+      (pushnew :big-endian *features*))))
+
+
+(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)))))
+
+
+(defconstant type-pred-alist
+    '(#-(version>= 4 1 devel 16)
+      (card8  . card8p)
+      #-(version>= 4 1 devel 16)
+      (card16 . card16p)
+      #-(version>= 4 1 devel 16)
+      (card29 . card29p)
+      #-(version>= 4 1 devel 16)
+      (card32 . card32p)
+      #-(version>= 4 1 devel 16)
+      (int8   . int8p)
+      #-(version>= 4 1 devel 16)
+      (int16  . int16p)
+      #-(version>= 4 1 devel 16)
+      (int32  . int32p)
+      #-(version>= 4 1 devel 16)
+      (mask16 . card16p)
+      #-(version>= 4 1 devel 16)
+      (mask32 . card32p)
+      #-(version>= 4 1 devel 16)
+      (pixel  . card32p)
+      #-(version>= 4 1 devel 16)
+      (resource-id . card29p)
+      #-(version>= 4 1 devel 16)
+      (keysym . card32p)
+      (angle  . anglep)
+      (color  . color-p)
+      (bitmap-format . bitmap-format-p)
+      (pixmap-format . pixmap-format-p)
+      (display  . display-p)
+      (drawable . drawable-p)
+      (window   . window-p)
+      (pixmap   . pixmap-p)
+      (visual-info . visual-info-p)
+      (colormap . colormap-p)
+      (cursor . cursor-p)
+      (gcontext .  gcontext-p)
+      (screen . screen-p)
+      (font . font-p)
+      (image-x . image-x-p)
+      (image-xy . image-xy-p)
+      (image-z . image-z-p)
+      (wm-hints . wm-hints-p)
+      (wm-size-hints . wm-size-hints-p)
+      ))
+
+;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 
+;; sun4 compiler opencode the `and'.
+
+#-(version>= 4 1 devel 16)
+(defun card8p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun card16p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun card29p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
+	  (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
+	       (>= (the bignum x) 0)))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun card32p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
+	  (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
+	       (>= (the bignum x) 0)))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun int8p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun int16p (x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum x))
+  (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
+      t
+    nil))
+
+#-(version>= 4 1 devel 16)
+(defun int32p (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (excl:fixnump x)
+	  (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
+	       (>= (the bignum x) #.(expt -2 31))))
+      t
+    nil))
+
+;; This one can be handled better by knowing a little about what we're
+;; testing for.  Plus this version can handle (single-float pi), which
+;; is otherwise larger than pi!
+(defun anglep (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
+	       (<= (the fixnum x) #.(truncate (* 2 pi))))
+	  (and (excl::single-float-p x)
+	       (>= (the single-float x) #.(float (* -2 pi) 0.0s0))
+	       (<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
+	  (and (excl::double-float-p x)
+	       (>= (the double-float x) #.(float (* -2 pi) 0.0d0))
+	       (<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
+      t
+    nil))
+
+(eval-when (load eval)
+  #+(version>= 4 1 devel 16)
+  (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
+	  type-pred-alist)
+  #-(version>= 4 1 devel 16)
+  (nconc excl::type-pred-alist type-pred-alist))
+
+
+;; Return t if there is a character available for reading or on error,
+;; otherwise return nil.
+#-(version>= 6 0)
+(progn
+
+#-(or (version>= 4 2) mswindows)
+(defun fd-char-avail-p (fd)
+  (multiple-value-bind (available-p errcode)
+      (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
+    (excl:if* errcode
+       then t
+       else available-p)))
+
+#+(and (version>= 4 2) (not mswindows))
+(defun fd-char-avail-p (fd)
+  (excl::filesys-character-available-p fd))
+
+#+mswindows
+(defun fd-char-avail-p (socket-stream)
+  (listen socket-stream))
+)
+
+#+(version>= 6 0)
+(defun fd-char-avail-p (socket-stream)
+  (excl::read-no-hang-p socket-stream))
+
+(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)
+  ;; Read from the given stream 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.
+  (declare (fixnum next-index start-index length))
+  (with-interrupt-checking-on
+      (let ((end-index (+ start-index length)))
+	(loop
+	  (let ((next-index (excl:read-vector vector fd 
+					      :start start-index
+					      :end end-index)))
+	    (excl:if* (eq next-index start-index)
+	       then			; end of file before was all filled up
+		    (return t)
+	     elseif (eq next-index end-index)
+	       then			; we're all done
+		    (return nil)
+	       else (setq start-index next-index)))))))
+
+
+;; special patch for CLX (various process fixes)
+;; patch1000.2
+
+(eval-when (compile load eval)
+  (unless (find-package :patch)
+    (make-package :patch :use '(:lisp :excl))))
+
+(in-package :patch)
+
+(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
+		      (< 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 (excl: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)))))
+       (excl: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
+   (excl:if* (null (process-lock-locker lock))
+      then (setf (process-lock-locker lock) lock-value)
+      else (excl:if* timeout
+	      then (excl: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.
+  (excl: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 (excl:if* (excl: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)
+	      (excl: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))
+      (excl: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
index d8403ae53..5a84b6698 100644
--- a/clx/fonts.lisp
+++ b/clx/fonts.lisp
@@ -15,9 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/fonts.lisp,v 1.5 1998/12/19 15:21:17 dtc Exp $")
+(ext:file-comment "$Id: fonts.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -159,13 +159,15 @@
       (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*)
+      (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))
+    (unless (font-font-info-internal font)
+      (query-font font))
     font))
 
 (defun open-font-internal (font)
@@ -176,7 +178,7 @@
 	 (display (font-display font))
 	 (id (allocate-resource-id display font 'font)))
     (setf (font-id-internal font) id)
-    (with-buffer-request (display *x-openfont*)
+    (with-buffer-request (display +x-openfont+)
       (resource-id id)
       (card16 (length name-string))
       (pad16 nil)
@@ -201,7 +203,7 @@
 	font-info
 	props)
     (setq font-id (font-id font)) ;; May issue an open-font request
-    (with-buffer-request-and-reply (display *x-queryfont* 60)
+    (with-buffer-request-and-reply (display +x-queryfont+ 60)
 	 ((resource-id font-id))
       (let* ((min-byte2 (card16-get 40))
 	     (max-byte2 (card16-get 42))
@@ -252,7 +254,7 @@
       ;; Remove font from cache
       (setf (display-font-cache display) (delete font (display-font-cache display)))
       ;; Close the font
-      (with-buffer-request (display *x-closefont*)
+      (with-buffer-request (display +x-closefont+)
 	(resource-id id)))))
 
 (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
@@ -262,12 +264,12 @@
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-sequence string)))
   (let ((string (string pattern)))
-    (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
+    (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*)))))
+	  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.
@@ -283,7 +285,7 @@
   (declare (clx-values (clx-sequence font)))
   (let ((string (string pattern))
 	(result nil))
-    (with-buffer-request-and-reply (display *x-listfontswithinfo* 60
+    (with-buffer-request-and-reply (display +x-listfontswithinfo+ 60
 					    :sizes (8 16) :multiple-reply t)
 	 ((card16 max-fonts (length string))
 	  (string string))
@@ -334,11 +336,11 @@
   (declare (type display display)
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-sequence (or string pathname))))
-  (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))
+  (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*))))
+	buffer-bbuf (index- size +replysize+) (card16-get 8) result-type +replysize+))))
 
 (defun set-font-path (display paths)
   (declare (type display display)
@@ -350,7 +352,7 @@
       (let* ((string (string (elt paths i)))
 	     (len (length string)))
 	(incf request-length (1+ len))))
-    (with-buffer-request (display *x-setfontpath* :length request-length)
+    (with-buffer-request (display +x-setfontpath+ :length request-length)
       (length (ceiling request-length 4))
       (card16 path-length)
       (pad16 nil)
diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp
index f4f6134b5..5039ae3fc 100644
--- a/clx/gcontext.lisp
+++ b/clx/gcontext.lisp
@@ -41,25 +41,24 @@
 ;;;	lisps will have problems.  Fortunately, most other lisps don't care,
 ;;;	because they don't run in a multi-processing shared-address space
 ;;;	environment.
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/gcontext.lisp,v 1.7 2004/03/24 13:35:04 emarsden Exp $")
+(ext:file-comment "$Id: gcontext.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
 ;; 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*))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(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*)
+	      (dolist (name +gcontext-components+)
 		(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
 			 `(svref ,state ,,index))
 		      macros)
@@ -75,37 +74,40 @@
 		  (setf (getf indexes (or (second extra) (first extra))) index))
 		(push (logior (ash 1 index)
 			      (if (second extra)
-				  (ash 1 (position (second extra) *gcontext-components*))
+				  (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)))))))
+		 (eval-when (:compile-toplevel :load-toplevel :execute)
+		   (defvar *gcontext-data-length* ,index)
+		   (defvar *gcontext-indexes* ',indexes)
+		   (defvar *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 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)
+  ;; FIXME: these used to have glorious, but wrong, type declarations.
+  ;; See if we can't return them to their former glory.
   (set-function #'(lambda (gcontext value)
 		    (declare (ignore gcontext))
 		    value)
-		:type (function (gcontext t) t) :read-only t)
+		:type (or function symbol) :read-only t)
   (copy-function #'(lambda (from-gc to-gc value)
 		     (declare (ignore from-gc to-gc))
 		     value)
-		 :type (function (gcontext gcontext t) t) :read-only t))
+		 :type (or function symbol) :read-only t))
 
 (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
 
@@ -164,7 +166,7 @@
 ;; Generate all the accessors and defsetf's for GContext
 
 (defmacro xgcmask->gcmask (mask)
-  `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
+  `(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)))
@@ -321,15 +323,12 @@
   (declare (type gcontext gcontext)
 	   (type (or card8 sequence) dashes))
   (multiple-value-bind (dashes dash)
-      (cond ((type? dashes 'sequence)
-             (if (zerop (length dashes))
-                 (x-type-error dashes '(or card8 sequence) "non-empty sequence")
-                 (values nil (or (copy-seq dashes) (vector)))))
-            ((eql dashes 0)
-             (x-type-error dashes '(or card8 sequence) "non-zero card8"))
-            (t
-             (values (encode-type card8 dashes) nil)))
-   (modify-gcontext (gcontext local-state)
+      (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
@@ -409,7 +408,7 @@
 
 	(block no-changes
 	  (let ((last-request (buffer-last-request display)))
-	    (with-buffer-request (display *x-changegc*)
+	    (with-buffer-request (display +x-changegc+)
 	      (gcontext gcontext)
 	      (progn
 		(do ((i 0 (index+ i 1))
@@ -417,7 +416,7 @@
 		     (nbyte 12)
 		     (mask 0)
 		     (local 0))
-		    ((index>= i *gcontext-fast-change-length*)
+		    ((index>= i +gcontext-fast-change-length+)
 		     (when (zerop mask)
 		       ;; If nothing changed, restore last-request and quit
 		       (setf (buffer-last-request display)
@@ -457,7 +456,7 @@
 	  (unless (equalp local-clip server-clip)
 	    (setf (gcontext-internal-clip server-state) nil)
 	    (unless (null local-clip)
-	      (with-buffer-request (display *x-setcliprectangles*)
+	      (with-buffer-request (display +x-setcliprectangles+)
 		(data (first local-clip))
 		(gcontext gcontext)
 		;; XXX treat nil correctly
@@ -475,7 +474,7 @@
 	  (unless (equalp local-dash server-dash)
 	    (setf (gcontext-internal-dash server-state) nil)
 	    (unless (null local-dash)
-	      (with-buffer-request (display *x-setdashes*)
+	      (with-buffer-request (display +x-setdashes+)
 		(gcontext gcontext)
 		;; XXX treat nil correctly
 		(card16 (or (gcontext-internal-dash-offset local-state) 0)
@@ -607,13 +606,13 @@
 		  (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*)
+	    (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*)
+	      (with-buffer-request (display +x-copygc+)
 		(gcontext gcontext)
 		(gcontext temp-gc)
 		(card29 (xgcmask->gcmask temp-mask))))
@@ -636,7 +635,7 @@
   (let ((display (gcontext-display gcontext)))
     (declare (type display display))
     (with-display (display)
-      (with-buffer-request (display *x-copygc*)
+      (with-buffer-request (display +x-copygc+)
 	(gcontext temp-gc)
 	(gcontext gcontext)
 	(card29 (xgcmask->gcmask temp-mask)))
@@ -649,7 +648,7 @@
 	(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*)
+      (with-buffer-request (display +x-freegc+)
 	(gcontext temp-gc))
       (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
       (deallocate-temp-gcontext temp-gc)
@@ -776,7 +775,7 @@
 	    ;; No, mark local state "unmodified"
 	    1))
     
-    (with-buffer-request (display *x-creategc*)
+    (with-buffer-request (display +x-creategc+)
       (resource-id gcontextid)
       (drawable drawable)
       (progn (do* ((i 0 (index+ i 1))
@@ -784,7 +783,7 @@
 		   (nbyte 16)
 		   (mask 0)
 		   (local (svref local-state i) (svref local-state i)))
-		 ((index>= i *gcontext-fast-change-length*)
+		 ((index>= i +gcontext-fast-change-length+)
 		  (card29-put 12 mask)
 		  (card16-put 2 (index-ash nbyte -2))
 		  (index-incf (buffer-boffset display) nbyte))
@@ -846,12 +845,11 @@
 	    (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)
+	      (let ((extension (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*)))
+					    (index+ (position extension *gcontext-extensions*) *gcontext-data-length*)))
 		  (x-type-error key 'gcontext-key))))))
 	
 	(when (plusp mask)
@@ -869,14 +867,14 @@
 	    (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*)
+	  (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*)
+  (apply #'copy-gcontext-components src dst +gcontext-components+)
   (do ((extensions *gcontext-extensions* (cdr extensions))
        (i *gcontext-data-length* (index+ i 1)))
       ((endp extensions))
@@ -886,7 +884,7 @@
 (defun free-gcontext (gcontext)
   (declare (type gcontext gcontext))
   (let ((display (gcontext-display gcontext)))
-    (with-buffer-request (display *x-freegc*)
+    (with-buffer-request (display +x-freegc+)
       (gcontext gcontext))
     (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
     (deallocate-gcontext-state (gcontext-server-state gcontext))
@@ -911,7 +909,7 @@
   (declare (type symbol name)
 	   (type t default)
 	   (type symbol set-function) ;; required
-	   (type symbol copy-function))
+	   (type (or symbol list) copy-function))
   (let* ((gc-name (intern (concatenate 'string
 				       (string 'gcontext-)
 				       (string name)))) ;; in current package
@@ -928,7 +926,7 @@
 		   (,set-function dst-gc value)
 		 (error "Can't copy unknown GContext component ~a" ',name)))))
     `(progn
-       (eval-when (compile load eval)
+       (eval-when (:compile-toplevel :load-toplevel :execute)
 	 (defparameter ,internal-state-index
 		       (add-gcontext-extension ',key-name ,default ',internal-set-function
 					       ',internal-copy-function))
@@ -964,8 +962,8 @@
 (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))
+	   (type (or function symbol) set-function)
+	   (type (or function symbol) copy-function))
   (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
 		    (prog1 (length *gcontext-extensions*)
 			   (push nil *gcontext-extensions*)))))
diff --git a/clx/generalock.lisp b/clx/generalock.lisp
new file mode 100644
index 000000000..aa1a6fbe9
--- /dev/null
+++ b/clx/generalock.lisp
@@ -0,0 +1,75 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*-
+
+;;; Copyright (C) 1990 Symbolics, Inc.
+;;;
+;;; 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.
+;;;
+;;; Symbolics, Inc. provides this software "as is" without
+;;; express or implied warranty.
+
+#+cmu
+(ext:file-comment "$Id: generalock.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+
+(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/gl.lisp b/clx/gl.lisp
new file mode 100644
index 000000000..391af3f21
--- /dev/null
+++ b/clx/gl.lisp
@@ -0,0 +1,3695 @@
+#+cmu
+(ext:file-comment "$Id: gl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+
+(defpackage :gl
+  (:use :common-lisp :xlib)
+  (:import-from :glx
+                "*CURRENT-CONTEXT*"
+                "CONTEXT"
+                "CONTEXT-P"
+                "CONTEXT-DISPLAY"
+                "CONTEXT-TAG"
+                "CONTEXT-RBUF"
+                "CONTEXT-INDEX"
+                )
+  (:import-from :xlib
+                "DATA"
+                "WITH-BUFFER-REQUEST"
+                "WITH-BUFFER-REQUEST-AND-REPLY"
+                "CARD32-GET"
+                "SEQUENCE-GET"
+
+                "WITH-DISPLAY"
+                "DISPLAY-FORCE-OUTPUT"
+
+                "INT8" "INT16" "INT32" "INTEGER"
+                "CARD8" "CARD16" "CARD32"
+
+                "ASET-CARD8"
+                "ASET-CARD16"
+                "ASET-CARD32"
+                "ASET-INT8"
+                "ASET-INT16"
+                "ASET-INT32"
+
+                "DECLARE-BUFFUN"
+
+                ;; Types
+                "ARRAY-INDEX"
+                "BUFFER-BYTES"
+                )
+
+  (:export "GET-STRING"
+
+           ;; Rendering commands (alphabetical order)
+
+           "ACCUM"
+           "ACTIVE-TEXTURE-ARB"
+           "ALPHA-FUNC"
+           "BEGIN"
+           "BIND-TEXTURE"
+           "BLEND-COLOR"
+           "BLEND-EQUOTION"
+           "BLEND-FUNC"
+           "CALL-LIST"
+           "CLEAR"
+           "CLEAR-ACCUM"
+           "CLEAR-COLOR"
+           "CLEAR-DEPTH"
+           "CLEAR-INDEX"
+           "CLEAR-STENCIL"
+           "CLIP-PLANE"
+           "COLOR-3B"
+           "COLOR-3D"
+           "COLOR-3F"
+           "COLOR-3I"
+           "COLOR-3S"
+           "COLOR-3UB"
+           "COLOR-3UI"
+           "COLOR-3US"
+           "COLOR-4B"
+           "COLOR-4D"
+           "COLOR-4F"
+           "COLOR-4I"
+           "COLOR-4S"
+           "COLOR-4UB"
+           "COLOR-4UI"
+           "COLOR-4US"
+           "COLOR-MASK"
+           "COLOR-MATERIAL"
+           "CONVOLUTION-PARAMETER-F"
+           "CONVOLUTION-PARAMETER-I"
+           "COPY-COLOR-SUB-TABLE"
+           "COPY-COLOR-TABLE"
+           "COPY-CONVOLUTION-FILTER-ID"
+           "COPY-CONVOLUTION-FILTER-2D"
+           "COPY-PIXELS"
+           "COPY-TEX-IMAGE-1D"
+           "COPY-TEX-IMAGE-2D"
+           "COPY-TEX-SUB-IMAGE-1D"
+           "COPY-TEX-SUB-IMAGE-2D"
+           "COPY-TEX-SUB-IMAGE-3D"
+           "CULL-FACE"
+           "DEPTH-FUNC"
+           "DEPTH-MASK"
+           "DEPTH-RANGE"
+           "DRAW-BUFFER"
+           "EDGE-FLAG-V"
+           "END"
+           "EVAL-COORD-1D"
+           "EVAL-COORD-1F"
+           "EVAL-COORD-2D"
+           "EVAL-COORD-2F"
+           "EVAL-MESH-1"
+           "EVAL-MESH-2"
+           "EVAL-POINT-1"
+           "EVAL-POINT-2"
+           "FOG-F"
+           "FOG-I"
+           "FRONT-FACE"
+           "FRUSTUM"
+           "HINT"
+           "HISTOGRAM"
+           "INDEX-MASK"
+           "INDEX-D"
+           "INDEX-F"
+           "INDEX-I"
+           "INDEX-S"
+           "INDEX-UB"
+           "INIT-NAMES"
+           "LIGHT-MODEL-F"
+           "LIGHT-MODEL-I"
+           "LIGHT-F"
+           "LIGHT-FV"
+           "LIGHT-I"
+           "LIGHT-IV"
+           "LINE-STIPPLE"
+           "LINE-WIDTH"
+           "LIST-BASE"
+           "LOAD-IDENTITY"
+           "LOAD-NAME"
+           "LOGIC-OP"
+           "MAP-GRID-1D"
+           "MAP-GRID-1F"
+           "MAP-GRID-2D"
+           "MAP-GRID-2F"
+           "MATERIAL-F"
+           "MATERIAL-FV"
+           "MATERIAL-I"
+           "MATERIAL-IV"
+           "MATRIX-MODE"
+           "MINMAX"
+           "MULTI-TEX-COORD-1D-ARB"
+           "MULTI-TEX-COORD-1F-ARB"
+           "MULTI-TEX-COORD-1I-ARB"
+           "MULTI-TEX-COORD-1S-ARB"
+           "MULTI-TEX-COORD-2D-ARB"
+           "MULTI-TEX-COORD-2F-ARB"
+           "MULTI-TEX-COORD-2I-ARB"
+           "MULTI-TEX-COORD-2S-ARB"
+           "MULTI-TEX-COORD-3D-ARB"
+           "MULTI-TEX-COORD-3F-ARB"
+           "MULTI-TEX-COORD-3I-ARB"
+           "MULTI-TEX-COORD-3S-ARB"
+           "MULTI-TEX-COORD-4D-ARB"
+           "MULTI-TEX-COORD-4F-ARB"
+           "MULTI-TEX-COORD-4I-ARB"
+           "MULTI-TEX-COORD-4S-ARB"
+           "NORMAL-3B"
+           "NORMAL-3D"
+           "NORMAL-3F"
+           "NORMAL-3I"
+           "NORMAL-3S"
+           "ORTHO"
+           "PASS-THROUGH"
+           "PIXEL-TRANSFER-F"
+           "PIXEL-TRANSFER-I"
+           "PIXEL-ZOOM"
+           "POINT-SIZE"
+           "POLYGON-MODE"
+           "POLYGON-OFFSET"
+           "POP-ATTRIB"
+           "POP-MATRIX"
+           "POP-NAME"
+           "PUSH-ATTRIB"
+           "PUSH-MATRIX"
+           "PUSH-NAME"
+           "RASTER-POS-2D"
+           "RASTER-POS-2F"
+           "RASTER-POS-2I"
+           "RASTER-POS-2S"
+           "RASTER-POS-3D"
+           "RASTER-POS-3F"
+           "RASTER-POS-3I"
+           "RASTER-POS-3S"
+           "RASTER-POS-4D"
+           "RASTER-POS-4F"
+           "RASTER-POS-4I"
+           "RASTER-POS-4S"
+           "READ-BUFFER"
+           "RECT-D"
+           "RECT-F"
+           "RECT-I"
+           "RECT-S"
+           "RESET-HISTOGRAM"
+           "RESET-MINMAX"
+           "ROTATE-D"
+           "ROTATE-F"
+           "SCALE-D"
+           "SCALE-F"
+           "SCISSOR"
+           "SHADE-MODEL"
+           "STENCIL-FUNC"
+           "STENCIL-MASK"
+           "STENCIL-OP"
+           "TEX-ENV-F"
+           "TEX-ENV-I"
+           "TEX-GEN-D"
+           "TEX-GEN-F"
+           "TEX-GEN-I"
+           "TEX-PARAMETER-F"
+           "TEX-PARAMETER-I"
+           "TRANSLATE-D"
+           "TRANSLATE-F"
+           "VERTEX-2D"
+           "VERTEX-2F"
+           "VERTEX-2I"
+           "VERTEX-2S"
+           "VERTEX-3D"
+           "VERTEX-3F"
+           "VERTEX-3I"
+           "VERTEX-3S"
+           "VERTEX-4D"
+           "VERTEX-4F"
+           "VERTEX-4I"
+           "VERTEX-4S"
+           "VIEWPORT"
+
+           ;; * Where did this come from?
+           ;;"NO-FLOATS"
+
+           ;; Non-rendering commands
+           "NEW-LIST"
+           "END-LIST"
+           "GEN-LISTS"
+           "ENABLE"
+           "DISABLE"
+           "FLUSH"
+           "FINISH"
+
+           ;; Constants
+
+           ;; Boolean
+
+           "+FALSE+"
+           "+TRUE+"
+
+           ;; Types
+
+           "+BYTE+"
+           "+UNSIGNED-BYTE+"
+           "+SHORT+"
+           "+UNSIGNED-SHORT+"
+           "+INT+"
+           "+UNSIGNED-INT+"
+           "+FLOAT+"
+           "+DOUBLE+"
+           "+2-BYTES+"
+           "+3-BYTES+"
+           "+4-BYTES+"
+
+           ;; Primitives
+
+           "+POINTS+"
+           "+LINES+"
+           "+LINE-LOOP+"
+           "+LINE-STRIP+"
+           "+TRIANGLES+"
+           "+TRIANGLE-STRIP+"
+           "+triangle-fan+"
+           "+QUADS+"
+           "+QUAD-STRIP+"
+           "+POLYGON+"
+
+           ;; Arrays
+
+           "+VERTEX-ARRAY+"
+           "+NORMAL-ARRAY+"
+           "+COLOR-ARRAY+"
+           "+INDEX-ARRAY+"
+           "+TEXTURE-COORD-ARRAY+"
+           "+EDGE-FLAG-ARRAY+"
+           "+VERTEX-ARRAY-SIZE+"
+           "+VERTEX-ARRAY-TYPE+"
+           "+VERTEX-ARRAY-STRIDE+"
+           "+NORMAL-ARRAY-TYPE+"
+           "+NORMAL-ARRAY-STRIDE+"
+           "+COLOR-ARRAY-SIZE+"
+           "+COLOR-ARRAY-TYPE+"
+           "+COLOR-ARRAY-STRIDE+"
+           "+INDEX-ARRAY-TYPE+"
+           "+INDEX-ARRAY-STRIDE+"
+           "+TEXTURE-COORD-ARRAY-SIZE+"
+           "+TEXTURE-COORD-ARRAY-TYPE+"
+           "+TEXTURE-COORD-ARRAY-STRIDE+"
+           "+EDGE-FLAG-ARRAY-STRIDE+"
+           "+VERTEX-ARRAY-POINTER+"
+           "+NORMAL-ARRAY-POINTER+"
+           "+COLOR-ARRAY-POINTER+"
+           "+INDEX-ARRAY-POINTER+"
+           "+TEXTURE-COORD-ARRAY-POINTER+"
+           "+EDGE-FLAG-ARRAY-POINTER+"
+
+           ;; Array formats
+
+           "+V2F+"
+           "+V3F+"
+           "+C4UB-V2F+"
+           "+C4UB-V3F+"
+           "+C3F-V3F+"
+           "+N3F-V3F+"
+           "+C4F-N3F-V3F+"
+           "+T2F-V3F+"
+           "+T4F-V4F+"
+           "+T2F-C4UB-V3F+"
+           "+T2F-C3F-V3F+"
+           "+T2F-N3F-V3F+"
+           "+T2F-C4F-N3F-V3F+"
+           "+T4F-C4F-N3F-V4F+"
+
+           ;; Matrices
+
+           "+MATRIX-MODE+"
+           "+MODELVIEW+"
+           "+PROJECTION+"
+           "+TEXTURE+"
+
+           ;; Points
+
+           "+POINT-SMOOTH+"
+           "+POINT-SIZE+"
+           "+POINT-SIZE-GRANULARITY+"
+           "+POINT-SIZE-RANGE+"
+
+           ;; Lines
+
+           "+LINE-SMOOTH+"
+           "+LINE-STIPPLE+"
+           "+LINE-STIPPLE-PATTERN+"
+           "+LINE-STIPPLE-REPEAT+"
+           "+LINE-WIDTH+"
+           "+LINE-WIDTH-GRANULARITY+"
+           "+LINE-WIDTH-RANGE+"
+
+           ;; Polygons
+
+           "+POINT+"
+           "+LINE+"
+           "+FILL+"
+           "+CW+"
+           "+CCW+"
+           "+FRONT+"
+           "+BACK+"
+           "+POLYGON-MODE+"
+           "+POLYGON-SMOOTH+"
+           "+POLYGON-STIPPLE+"
+           "+EDGE-FLAG+"
+           "+CULL-FACE+"
+           "+CULL-FACE-MODE+"
+           "+FRONT-FACE+"
+           "+POLYGON-OFFSET-FACTOR+"
+           "+POLYGON-OFFSET-UNITS+"
+           "+POLYGON-OFFSET-POINT+"
+           "+POLYGON-OFFSET-LINE+"
+           "+POLYGON-OFFSET-FILL+"
+
+           ;; Display Lists
+
+           "+COMPILE+"
+           "+COMPILE-AND-EXECUTE+"
+           "+LIST-BASE+"
+           "+LIST-INDEX+"
+           "+LIST-MODE+"
+
+           ;; Depth Buffer
+
+           "+NEVER+"
+           "+LESS+"
+           "+EQUAL+"
+           "+LEQUAL+"
+           "+GREATER+"
+           "+NOTEQUAL+"
+           "+GEQUAL+"
+           "+ALWAYS+"
+           "+DEPTH-TEST+"
+           "+DEPTH-BITS+"
+           "+DEPTH-CLEAR-VALUE+"
+           "+DEPTH-FUNC+"
+           "+DEPTH-RANGE+"
+           "+DEPTH-WRITEMASK+"
+           "+DEPTH-COMPONENT+"
+
+           ;; Lighting
+
+           "+LIGHTING+"
+           "+LIGHT0+"
+           "+LIGHT1+"
+           "+LIGHT2+"
+           "+LIGHT3+"
+           "+LIGHT4+"
+           "+LIGHT5+"
+           "+LIGHT6+"
+           "+LIGHT7+"
+           "+SPOT-EXPONENT+"
+           "+SPOT-CUTOFF+"
+           "+CONSTANT-ATTENUATION+"
+           "+LINEAR-ATTENUATION+"
+           "+QUADRATIC-ATTENUATION+"
+           "+AMBIENT+"
+           "+DIFFUSE+"
+           "+SPECULAR+"
+           "+SHININESS+"
+           "+EMISSION+"
+           "+POSITION+"
+           "+SPOT-DIRECTION+"
+           "+AMBIENT-AND-DIFFUSE+"
+           "+COLOR-INDEXES+"
+           "+LIGHT-MODEL-TWO-SIDE+"
+           "+LIGHT-MODEL-LOCAL-VIEWER+"
+           "+LIGHT-MODEL-AMBIENT+"
+           "+FRONT-AND-BACK+"
+           "+SHADE-MODEL+"
+           "+FLAT+"
+           "+SMOOTH+"
+           "+COLOR-MATERIAL+"
+           "+COLOR-MATERIAL-FACE+"
+           "+COLOR-MATERIAL-PARAMETER+"
+           "+NORMALIZE+"
+
+           ;; Clipping planes
+
+           "+CLIP-PLANE0+"
+           "+CLIP-PLANE1+"
+           "+CLIP-PLANE2+"
+           "+CLIP-PLANE3+"
+           "+CLIP-PLANE4+"
+           "+CLIP-PLANE5+"
+
+           ;; Accumulation buffer
+
+           "+ACCUM-RED-BITS+"
+           "+ACCUM-GREEN-BITS+"
+           "+ACCUM-BLUE-BITS+"
+           "+ACCUM-ALPHA-BITS+"
+           "+ACCUM-CLEAR-VALUE+"
+           "+ACCUM+"
+           "+ADD+"
+           "+LOAD+"
+           "+MULT+"
+           "+RETURN+"
+
+           ;; Alpha Testing
+
+           "+ALPHA-TEST+"
+           "+ALPHA-TEST-REF+"
+           "+ALPHA-TEST-FUNC+"
+
+           ;; Blending
+
+           "+BLEND+"
+           "+BLEND-SRC+"
+           "+BLEND-DST+"
+           "+ZERO+"
+           "+ONE+"
+           "+SRC-COLOR+"
+           "+ONE-MINUS-SRC-COLOR+"
+           "+DST-COLOR+"
+           "+ONE-MINUS-DST-COLOR+"
+           "+SRC-ALPHA+"
+           "+ONE-MINUS-SRC-ALPHA+"
+           "+DST-ALPHA+"
+           "+ONE-MINUS-DST-ALPHA+"
+           "+SRC-ALPHA-SATURATE+"
+           "+CONSTANT-COLOR+"
+           "+ONE-MINUS-CONSTANT-COLOR+"
+           "+CONSTANT-ALPHA+"
+           "+ONE-MINUS-CONSTANT-ALPHA+"
+
+           ;; Render mode
+
+           "+FEEDBACK+"
+           "+RENDER+"
+           "+SELECT+"
+
+           ;; Feedback
+
+           "+2D+"
+           "+3D+"
+           "+3D-COLOR+"
+           "+3D-COLOR-TEXTURE+"
+           "+4D-COLOR-TEXTURE+"
+           "+POINT-TOKEN+"
+           "+LINE-TOKEN+"
+           "+LINE-RESET-TOKEN+"
+           "+POLYGON-TOKEN+"
+           "+BITMAP-TOKEN+"
+           "+DRAW-PIXEL-TOKEN+"
+           "+COPY-PIXEL-TOKEN+"
+           "+PASS-THROUGH-TOKEN+"
+           "+FEEDBACK-BUFFER-POINTER+"
+           "+FEEDBACK-BUFFER-SIZE+"
+           "+FEEDBACK-BUFFER-TYPE+"
+
+           ;; Selection
+
+           "+SELECTION-BUFFER-POINTER+"
+           "+SELECTION-BUFFER-SIZE+"
+
+           ;; Fog
+
+           "+FOG+"
+           "+FOG-MODE+"
+           "+FOG-DENSITY+"
+           "+FOG-COLOR+"
+           "+FOG-INDEX+"
+           "+FOG-START+"
+           "+FOG-END+"
+           "+LINEAR+"
+           "+EXP+"
+           "+EXP2+"
+
+           ;; Logic operations
+
+           "+LOGIC-OP+"
+           "+INDEX-LOGIC-OP+"
+           "+COLOR-LOGIC-OP+"
+           "+LOGIC-OP-MODE+"
+           "+CLEAR+"
+           "+SET+"
+           "+COPY+"
+           "+COPY-INVERTED+"
+           "+NOOP+"
+           "+INVERT+"
+           "+AND+"
+           "+NAND+"
+           "+OR+"
+           "+NOR+"
+           "+XOR+"
+           "+EQUIV+"
+           "+AND-REVERSE+"
+           "+AND-INVERTED+"
+           "+OR-REVERSE+"
+           "+OR-INVERTED+"
+
+           ;; Stencil
+
+           "+STENCIL-TEST+"
+           "+STENCIL-WRITEMASK+"
+           "+STENCIL-BITS+"
+           "+STENCIL-FUNC+"
+           "+STENCIL-VALUE-MASK+"
+           "+STENCIL-REF+"
+           "+STENCIL-FAIL+"
+           "+STENCIL-PASS-DEPTH-PASS+"
+           "+STENCIL-PASS-DEPTH-FAIL+"
+           "+STENCIL-CLEAR-VALUE+"
+           "+STENCIL-INDEX+"
+           "+KEEP+"
+           "+REPLACE+"
+           "+INCR+"
+           "+DECR+"
+
+           ;; Buffers, Pixel Drawing/Reading
+
+           "+NONE+"
+           "+LEFT+"
+           "+RIGHT+"
+           "+FRONT-LEFT+"
+           "+FRONT-RIGHT+"
+           "+BACK-LEFT+"
+           "+BACK-RIGHT+"
+           "+AUX0+"
+           "+AUX1+"
+           "+AUX2+"
+           "+AUX3+"
+           "+COLOR-INDEX+"
+           "+RED+"
+           "+GREEN+"
+           "+BLUE+"
+           "+ALPHA+"
+           "+LUMINANCE+"
+           "+LUMINANCE-ALPHA+"
+           "+ALPHA-BITS+"
+           "+RED-BITS+"
+           "+GREEN-BITS+"
+           "+BLUE-BITS+"
+           "+INDEX-BITS+"
+           "+SUBPIXEL-BITS+"
+           "+AUX-BUFFERS+"
+           "+READ-BUFFER+"
+           "+DRAW-BUFFER+"
+           "+DOUBLEBUFFER+"
+           "+STEREO+"
+           "+BITMAP+"
+           "+COLOR+"
+           "+DEPTH+"
+           "+STENCIL+"
+           "+DITHER+"
+           "+RGB+"
+           "+RGBA+"
+
+           ;; Implementation Limits
+
+           "+MAX-LIST-NESTING+"
+           "+MAX-ATTRIB-STACK-DEPTH+"
+           "+MAX-MODELVIEW-STACK-DEPTH+"
+           "+MAX-NAME-STACK-DEPTH+"
+           "+MAX-PROJECTION-STACK-DEPTH+"
+           "+MAX-TEXTURE-STACK-DEPTH+"
+           "+MAX-EVAL-ORDER+"
+           "+MAX-LIGHTS+"
+           "+MAX-CLIP-PLANES+"
+           "+MAX-TEXTURE-SIZE+"
+           "+MAX-PIXEL-MAP-TABLE+"
+           "+MAX-VIEWPORT-DIMS+"
+           "+MAX-CLIENT-ATTRIB-STACK-DEPTH+"
+
+           ;; Gets
+
+           "+ATTRIB-STACK-DEPTH+"
+           "+CLIENT-ATTRIB-STACK-DEPTH+"
+           "+COLOR-CLEAR-VALUE+"
+           "+COLOR-WRITEMASK+"
+           "+CURRENT-INDEX+"
+           "+CURRENT-COLOR+"
+           "+CURRENT-NORMAL+"
+           "+CURRENT-RASTER-COLOR+"
+           "+CURRENT-RASTER-DISTANCE+"
+           "+current-raster-index+"
+           "+CURRENT-RASTER-POSITION+"
+           "+CURRENT-RASTER-TEXTURE-COORDS+"
+           "+CURRENT-RASTER-POSITION-VALID+"
+           "+CURRENT-TEXTURE-COORDS+"
+           "+INDEX-CLEAR-VALUE+"
+           "+INDEX-MODE+"
+           "+INDEX-WRITEMASK+"
+           "+MODELVIEW-MATRIX+"
+           "+MODELVIEW-STACK-DEPTH+"
+           "+NAME-STACK-DEPTH+"
+           "+PROJECTION-MATRIX+"
+           "+PROJECTION-STACK-DEPTH+"
+           "+RENDER-MODE+"
+           "+RGBA-MODE+"
+           "+TEXTURE-MATRIX+"
+           "+TEXTURE-STACK-DEPTH+"
+           "+VIEWPORT+"
+
+           ;; GL Evaluators
+
+           "+AUTO-NORMAL+"
+           "+MAP1-COLOR-4+"
+           "+MAP1-GRID-DOMAIN+"
+           "+MAP1-GRID-SEGMENTS+"
+           "+MAP1-INDEX+"
+           "+MAP1-NORMAL+"
+           "+MAP1-TEXTURE-COORD-1+"
+           "+MAP1-TEXTURE-COORD-2+"
+           "+MAP1-TEXTURE-COORD-3+"
+           "+MAP1-TEXTURE-COORD-4+"
+           "+MAP1-VERTEX-3+"
+           "+MAP1-VERTEX-4+"
+           "+MAP2-COLOR-4+"
+           "+MAP2-GRID-DOMAIN+"
+           "+MAP2-GRID-SEGMENTS+"
+           "+MAP2-INDEX+"
+           "+MAP2-NORMAL+"
+           "+MAP2-TEXTURE-COORD-1+"
+           "+MAP2-TEXTURE-COORD-2+"
+           "+MAP2-TEXTURE-COORD-3+"
+           "+MAP2-TEXTURE-COORD-4+"
+           "+MAP2-VERTEX-3+"
+           "+MAP2-VERTEX-4+"
+           "+COEFF+"
+           "+DOMAIN+"
+           "+ORDER+"
+
+           ;; Hints
+
+           "+FOG-HINT+"
+           "+LINE-SMOOTH-HINT+"
+           "+PERSPECTIVE-CORRECTION-HINT+"
+           "+POINT-SMOOTH-HINT+"
+           "+POLYGON-SMOOTH-HINT+"
+           "+DONT-CARE+"
+           "+FASTEST+"
+           "+NICEST+"
+
+           ;; Scissor box
+
+           "+SCISSOR-TEST+"
+           "+SCISSOR-BOX+"
+
+           ;; Pixel Mode / Transfer
+
+           "+MAP-COLOR+"
+           "+MAP-STENCIL+"
+           "+INDEX-SHIFT+"
+           "+INDEX-OFFSET+"
+           "+RED-SCALE+"
+           "+RED-BIAS+"
+           "+GREEN-SCALE+"
+           "+GREEN-BIAS+"
+           "+BLUE-SCALE+"
+           "+BLUE-BIAS+"
+           "+ALPHA-SCALE+"
+           "+ALPHA-BIAS+"
+           "+DEPTH-SCALE+"
+           "+DEPTH-BIAS+"
+           "+PIXEL-MAP-S-TO-S-SIZE+"
+           "+PIXEL-MAP-I-TO-I-SIZE+"
+           "+PIXEL-MAP-I-TO-R-SIZE+"
+           "+PIXEL-MAP-I-TO-G-SIZE+"
+           "+PIXEL-MAP-I-TO-B-SIZE+"
+           "+PIXEL-MAP-I-TO-A-SIZE+"
+           "+PIXEL-MAP-R-TO-R-SIZE+"
+           "+PIXEL-MAP-G-TO-G-SIZE+"
+           "+PIXEL-MAP-B-TO-B-SIZE+"
+           "+PIXEL-MAP-A-TO-A-SIZE+"
+           "+PIXEL-MAP-S-TO-S+"
+           "+PIXEL-MAP-I-TO-I+"
+           "+PIXEL-MAP-I-TO-R+"
+           "+PIXEL-MAP-I-TO-G+"
+           "+PIXEL-MAP-I-TO-B+"
+           "+PIXEL-MAP-I-TO-A+"
+           "+PIXEL-MAP-R-TO-R+"
+           "+PIXEL-MAP-G-TO-G+"
+           "+PIXEL-MAP-B-TO-B+"
+           "+PIXEL-MAP-A-TO-A+"
+           "+PACK-ALIGNMENT+"
+           "+PACK-LSB-FIRST+"
+           "+PACK-ROW-LENGTH+"
+           "+PACK-SKIP-PIXELS+"
+           "+PACK-SKIP-ROWS+"
+           "+PACK-SWAP-BYTES+"
+           "+UNPACK-ALIGNMENT+"
+           "+UNPACK-LSB-FIRST+"
+           "+UNPACK-ROW-LENGTH+"
+           "+UNPACK-SKIP-PIXELS+"
+           "+UNPACK-SKIP-ROWS+"
+           "+UNPACK-SWAP-BYTES+"
+           "+ZOOM-X+"
+           "+ZOOM-Y+"
+
+           ;; Texture Mapping
+
+           "+TEXTURE-ENV+"
+           "+TEXTURE-ENV-MODE+"
+           "+TEXTURE-1D+"
+           "+TEXTURE-2D+"
+           "+TEXTURE-WRAP-S+"
+           "+TEXTURE-WRAP-T+"
+           "+TEXTURE-MAG-FILTER+"
+           "+TEXTURE-MIN-FILTER+"
+           "+TEXTURE-ENV-COLOR+"
+           "+TEXTURE-GEN-S+"
+           "+TEXTURE-GEN-T+"
+           "+TEXTURE-GEN-MODE+"
+           "+TEXTURE-BORDER-COLOR+"
+           "+TEXTURE-WIDTH+"
+           "+TEXTURE-HEIGHT+"
+           "+TEXTURE-BORDER+"
+           "+TEXTURE-COMPONENTS+"
+           "+TEXTURE-RED-SIZE+"
+           "+TEXTURE-GREEN-SIZE+"
+           "+TEXTURE-BLUE-SIZE+"
+           "+TEXTURE-ALPHA-SIZE+"
+           "+TEXTURE-LUMINANCE-SIZE+"
+           "+TEXTURE-INTENSITY-SIZE+"
+           "+NEAREST-MIPMAP-NEAREST+"
+           "+NEAREST-MIPMAP-LINEAR+"
+           "+LINEAR-MIPMAP-NEAREST+"
+           "+LINEAR-MIPMAP-LINEAR+"
+           "+OBJECT-LINEAR+"
+           "+OBJECT-PLANE+"
+           "+EYE-LINEAR+"
+           "+EYE-PLANE+"
+           "+SPHERE-MAP+"
+           "+DECAL+"
+           "+MODULATE+"
+           "+NEAREST+"
+           "+REPEAT+"
+           "+CLAMP+"
+           "+S+"
+           "+T+"
+           "+R+"
+           "+Q+"
+           "+TEXTURE-GEN-R+"
+           "+TEXTURE-GEN-Q+"
+
+           ;; GL 1.1 Texturing
+
+           "+PROXY-TEXTURE-1D+"
+           "+PROXY-TEXTURE-2D+"
+           "+TEXTURE-PRIORITY+"
+           "+TEXTURE-RESIDENT+"
+           "+TEXTURE-BINDING-1D+"
+           "+TEXTURE-BINDING-2D+"
+           "+TEXTURE-INTERNAL-FORMAT+"
+           "+PACK-SKIP-IMAGES+"
+           "+PACK-IMAGE-HEIGHT+"
+           "+UNPACK-SKIP-IMAGES+"
+           "+UNPACK-IMAGE-HEIGHT+"
+           "+TEXTURE-3D+"
+           "+PROXY-TEXTURE-3D+"
+           "+TEXTURE-DEPTH+"
+           "+TEXTURE-WRAP-R+"
+           "+MAX-3D-TEXTURE-SIZE+"
+           "+TEXTURE-BINDING-3D+"
+
+           ;; Internal texture formats (GL 1.1)
+           "+ALPHA4+"
+           "+ALPHA8+"
+           "+ALPHA12+"
+           "+ALPHA16+"
+           "+LUMINANCE4+"
+           "+LUMINANCE8+"
+           "+LUMINANCE12+"
+           "+LUMINANCE16+"
+           "+LUMINANCE4-ALPHA4+"
+           "+LUMINANCE6-ALPHA2+"
+           "+LUMINANCE8-ALPHA8+"
+           "+LUMINANCE12-ALPHA4+"
+           "+LUMINANCE12-ALPHA12+"
+           "+LUMINANCE16-ALPHA16+"
+           "+INTENSITY+"
+           "+INTENSITY4+"
+           "+INTENSITY8+"
+           "+INTENSITY12+"
+           "+INTENSITY16+"
+           "+R3-G3-B2+"
+           "+RGB4+"
+           "+RGB5+"
+           "+RGB8+"
+           "+RGB10+"
+           "+RGB12+"
+           "+RGB16+"
+           "+RGBA2+"
+           "+RGBA4+"
+           "+RGB5-A1+"
+           "+RGBA8+"
+           "+rgb10-a2+"
+           "+RGBA12+"
+           "+RGBA16+"
+
+           ;; Utility
+
+           "+VENDOR+"
+           "+RENDERER+"
+           "+VERSION+"
+           "+EXTENSIONS+"
+
+           ;; Errors
+
+           "+NO-ERROR+"
+           "+INVALID-VALUE+"
+           "+INVALID-ENUM+"
+           "+INVALID-OPERATION+"
+           "+STACK-OVERFLOW+"
+           "+STACK-UNDERFLOW+"
+           "+OUT-OF-MEMORY+"
+
+           ;; OpenGL 1.2
+
+           "+RESCALE-NORMAL+"
+           "+CLAMP-TO-EDGE+"
+           "+MAX-ELEMENTS-VERTICES+"
+           "+MAX-ELEMENTS-INDICES+"
+           "+BGR+"
+           "+BGRA+"
+           "+UNSIGNED-BYTE-3-3-2+"
+           "+UNSIGNED-BYTE-2-3-3-REV+"
+           "+UNSIGNED-SHORT-5-6-5+"
+           "+UNSIGNED-SHORT-5-6-5-REV+"
+           "+UNSIGNED-SHORT-4-4-4-4+"
+           "+UNSIGNED-SHORT-4-4-4-4-REV+"
+           "+UNSIGNED-SHORT-5-5-5-1+"
+           "+UNSIGNED-SHORT-1-5-5-5-REV+"
+           "+UNSIGNED-INT-8-8-8-8+"
+           "+UNSIGNED-INT-8-8-8-8-REV+"
+           "+UNSIGNED-INT-10-10-10-2+"
+           "+UNSIGNED-INT-2-10-10-10-REV+"
+           "+LIGHT-MODEL-COLOR-CONTROL+"
+           "+SINGLE-COLOR+"
+           "+SEPARATE-SPECULAR-COLOR+"
+           "+TEXTURE-MIN-LOD+"
+           "+TEXTURE-MAX-LOD+"
+           "+TEXTURE-BASE-LEVEL+"
+           "+TEXTURE-MAX-LEVEL+"
+           "+SMOOTH-POINT-SIZE-RANGE+"
+           "+SMOOTH-POINT-SIZE-GRANULARITY+"
+           "+SMOOTH-LINE-WIDTH-RANGE+"
+           "+SMOOTH-LINE-WIDTH-GRANULARITY+"
+           "+ALIASED-POINT-SIZE-RANGE+"
+           "+ALIASED-LINE-WIDTH-RANGE+"
+
+           ;; OpenGL 1.2 Imaging subset
+           ;; GL_EXT_color_table
+           "+COLOR-TABLE+"
+           "+POST-CONVOLUTION-COLOR-TABLE+"
+           "+POST-COLOR-MATRIX-COLOR-TABLE+"
+           "+PROXY-COLOR-TABLE+"
+           "+PROXY-POST-CONVOLUTION-COLOR-TABLE+"
+           "+PROXY-POST-COLOR-MATRIX-COLOR-TABLE+"
+           "+COLOR-TABLE-SCALE+"
+           "+COLOR-TABLE-BIAS+"
+           "+COLOR-TABLE-FORMAT+"
+           "+COLOR-TABLE-WIDTH+"
+           "+COLOR-TABLE-RED-SIZE+"
+           "+COLOR-TABLE-GREEN-SIZE+"
+           "+COLOR-TABLE-BLUE-SIZE+"
+           "+COLOR-TABLE-ALPHA-SIZE+"
+           "+COLOR-TABLE-LUMINANCE-SIZE+"
+           "+COLOR-TABLE-INTENSITY-SIZE+"
+           ;; GL_EXT_convolution and GL_HP_convolution
+           "+CONVOLUTION-1D+"
+           "+CONVOLUTION-2D+"
+           "+SEPARABLE-2D+"
+           "+CONVOLUTION-BORDER-MODE+"
+           "+CONVOLUTION-FILTER-SCALE+"
+           "+CONVOLUTION-FILTER-BIAS+"
+           "+REDUCE+"
+           "+CONVOLUTION-FORMAT+"
+           "+CONVOLUTION-WIDTH+"
+           "+CONVOLUTION-HEIGHT+"
+           "+MAX-CONVOLUTION-WIDTH+"
+           "+MAX-CONVOLUTION-HEIGHT+"
+           "+POST-CONVOLUTION-RED-SCALE+"
+           "+POST-CONVOLUTION-GREEN-SCALE+"
+           "+POST-CONVOLUTION-BLUE-SCALE+"
+           "+POST-CONVOLUTION-ALPHA-SCALE+"
+           "+POST-CONVOLUTION-RED-BIAS+"
+           "+POST-CONVOLUTION-GREEN-BIAS+"
+           "+POST-CONVOLUTION-BLUE-BIAS+"
+           "+POST-CONVOLUTION-ALPHA-BIAS+"
+           "+CONSTANT-BORDER+"
+           "+REPLICATE-BORDER+"
+           "+CONVOLUTION-BORDER-COLOR+"
+           ;; GL_SGI_color_matrix
+           "+COLOR-MATRIX+"
+           "+COLOR-MATRIX-STACK-DEPTH+"
+           "+MAX-COLOR-MATRIX-STACK-DEPTH+"
+           "+POST-COLOR-MATRIX-RED-SCALE+"
+           "+POST-COLOR-MATRIX-GREEN-SCALE+"
+           "+POST-COLOR-MATRIX-BLUE-SCALE+"
+           "+POST-COLOR-MATRIX-ALPHA-SCALE+"
+           "+POST-COLOR-MATRIX-RED-BIAS+"
+           "+POST-COLOR-MATRIX-GREEN-BIAS+"
+           "+POST-COLOR-MATRIX-BLUE-BIAS+"
+           "+POST-COLOR-MATRIX-ALPHA-BIAS+"
+           ;; GL_EXT_histogram
+           "+HISTOGRAM+"
+           "+PROXY-HISTOGRAM+"
+           "+HISTOGRAM-WIDTH+"
+           "+HISTOGRAM-FORMAT+"
+           "+HISTOGRAM-RED-SIZE+"
+           "+HISTOGRAM-GREEN-SIZE+"
+           "+HISTOGRAM-BLUE-SIZE+"
+           "+HISTOGRAM-ALPHA-SIZE+"
+           "+HISTOGRAM-LUMINANCE-SIZE+"
+           "+HISTOGRAM-SINK+"
+           "+MINMAX+"
+           "+MINMAX-FORMAT+"
+           "+MINMAX-SINK+"
+           "+TABLE-TOO-LARGE+"
+           ;; GL_EXT_blend_color, GL_EXT_blend_minmax
+           "+BLEND-EQUATION+"
+           "+MIN+"
+           "+MAX+"
+           "+FUNC-ADD+"
+           "+FUNC-SUBTRACT+"
+           "+FUNC-REVERSE-SUBTRACT+"
+
+           ;; glPush/PopAttrib bits
+
+           "+CURRENT-BIT+"
+           "+POINT-BIT+"
+           "+LINE-BIT+"
+           "+POLYGON-BIT+"
+           "+POLYGON-STIPPLE-BIT+"
+           "+PIXEL-MODE-BIT+"
+           "+LIGHTING-BIT+"
+           "+FOG-BIT+"
+           "+DEPTH-BUFFER-BIT+"
+           "+ACCUM-BUFFER-BIT+"
+           "+STENCIL-BUFFER-BIT+"
+           "+VIEWPORT-BIT+"
+           "+TRANSFORM-BIT+"
+           "+ENABLE-BIT+"
+           "+COLOR-BUFFER-BIT+"
+           "+HINT-BIT+"
+           "+EVAL-BIT+"
+           "+LIST-BIT+"
+           "+TEXTURE-BIT+"
+           "+SCISSOR-BIT+"
+           "+ALL-ATTRIB-BITS+"
+           "+CLIENT-PIXEL-STORE-BIT+"
+           "+CLIENT-VERTEX-ARRAY-BIT+"
+           "+CLIENT-ALL-ATTRIB-BITS+"
+
+           ;; ARB Multitexturing extension
+
+           "+ARB-MULTITEXTURE+"
+           "+TEXTURE0-ARB+"
+           "+TEXTURE1-ARB+"
+           "+TEXTURE2-ARB+"
+           "+TEXTURE3-ARB+"
+           "+TEXTURE4-ARB+"
+           "+TEXTURE5-ARB+"
+           "+TEXTURE6-ARB+"
+           "+TEXTURE7-ARB+"
+           "+TEXTURE8-ARB+"
+           "+TEXTURE9-ARB+"
+           "+TEXTURE10-ARB+"
+           "+TEXTURE11-ARB+"
+           "+TEXTURE12-ARB+"
+           "+TEXTURE13-ARB+"
+           "+TEXTURE14-ARB+"
+           "+TEXTURE15-ARB+"
+           "+TEXTURE16-ARB+"
+           "+TEXTURE17-ARB+"
+           "+TEXTURE18-ARB+"
+           "+TEXTURE19-ARB+"
+           "+TEXTURE20-ARB+"
+           "+TEXTURE21-ARB+"
+           "+TEXTURE22-ARB+"
+           "+TEXTURE23-ARB+"
+           "+TEXTURE24-ARB+"
+           "+TEXTURE25-ARB+"
+           "+TEXTURE26-ARB+"
+           "+TEXTURE27-ARB+"
+           "+TEXTURE28-ARB+"
+           "+TEXTURE29-ARB+"
+           "+TEXTURE30-ARB+"
+           "+TEXTURE31-ARB+"
+           "+ACTIVE-TEXTURE-ARB+"
+           "+CLIENT-ACTIVE-TEXTURE-ARB+"
+           "+MAX-TEXTURE-UNITS-ARB+"
+
+;;; Misc extensions
+
+           "+EXT-ABGR+"
+           "+ABGR-EXT+"
+           "+EXT-BLEND-COLOR+"
+           "+CONSTANT-COLOR-EXT+"
+           "+ONE-MINUS-CONSTANT-COLOR-EXT+"
+           "+CONSTANT-ALPHA-EXT+"
+           "+ONE-MINUS-CONSTANT-ALPHA-EXT+"
+           "+blend-color-ext+"
+           "+EXT-POLYGON-OFFSET+"
+           "+POLYGON-OFFSET-EXT+"
+           "+POLYGON-OFFSET-FACTOR-EXT+"
+           "+POLYGON-OFFSET-BIAS-EXT+"
+           "+EXT-TEXTURE3D+"
+           "+PACK-SKIP-IMAGES-EXT+"
+           "+PACK-IMAGE-HEIGHT-EXT+"
+           "+UNPACK-SKIP-IMAGES-EXT+"
+           "+UNPACK-IMAGE-HEIGHT-EXT+"
+           "+TEXTURE-3D-EXT+"
+           "+PROXY-TEXTURE-3D-EXT+"
+           "+TEXTURE-DEPTH-EXT+"
+           "+TEXTURE-WRAP-R-EXT+"
+           "+MAX-3D-TEXTURE-SIZE-EXT+"
+           "+TEXTURE-3D-BINDING-EXT+"
+           "+EXT-TEXTURE-OBJECT+"
+           "+TEXTURE-PRIORITY-EXT+"
+           "+TEXTURE-RESIDENT-EXT+"
+           "+TEXTURE-1D-BINDING-EXT+"
+           "+TEXTURE-2D-BINDING-EXT+"
+           "+EXT-RESCALE-NORMAL+"
+           "+RESCALE-NORMAL-EXT+"
+           "+EXT-VERTEX-ARRAY+"
+           "+VERTEX-ARRAY-EXT+"
+           "+NORMAL-ARRAY-EXT+"
+           "+COLOR-ARRAY-EXT+"
+           "+INDEX-ARRAY-EXT+"
+           "+TEXTURE-COORD-ARRAY-EXT+"
+           "+EDGE-FLAG-ARRAY-EXT+"
+           "+VERTEX-ARRAY-SIZE-EXT+"
+           "+VERTEX-ARRAY-TYPE-EXT+"
+           "+VERTEX-ARRAY-STRIDE-EXT+"
+           "+VERTEX-ARRAY-COUNT-EXT+"
+           "+NORMAL-ARRAY-TYPE-EXT+"
+           "+NORMAL-ARRAY-STRIDE-EXT+"
+           "+NORMAL-ARRAY-COUNT-EXT+"
+           "+COLOR-ARRAY-SIZE-EXT+"
+           "+COLOR-ARRAY-TYPE-EXT+"
+           "+COLOR-ARRAY-STRIDE-EXT+"
+           "+COLOR-ARRAY-COUNT-EXT+"
+           "+INDEX-ARRAY-TYPE-EXT+"
+           "+INDEX-ARRAY-STRIDE-EXT+"
+           "+INDEX-ARRAY-COUNT-EXT+"
+           "+TEXTURE-COORD-ARRAY-SIZE-EXT+"
+           "+TEXTURE-COORD-ARRAY-TYPE-EXT+"
+           "+TEXTURE-COORD-ARRAY-STRIDE-EXT+"
+           "+TEXTURE-COORD-ARRAY-COUNT-EXT+"
+           "+EDGE-FLAG-ARRAY-STRIDE-EXT+"
+           "+EDGE-FLAG-ARRAY-COUNT-EXT+"
+           "+VERTEX-ARRAY-POINTER-EXT+"
+           "+NORMAL-ARRAY-POINTER-EXT+"
+           "+COLOR-ARRAY-POINTER-EXT+"
+           "+INDEX-ARRAY-POINTER-EXT+"
+           "+TEXTURE-COORD-ARRAY-POINTER-EXT+"
+           "+EDGE-FLAG-ARRAY-POINTER-EXT+"
+           "+SGIS-TEXTURE-EDGE-CLAMP+"
+           "+CLAMP-TO-EDGE-SGIS+"
+           "+EXT-BLEND-MINMAX+"
+           "+FUNC-ADD-EXT+"
+           "+MIN-EXT+"
+           "+MAX-EXT+"
+           "+BLEND-EQUATION-EXT+"
+           "+EXT-BLEND-SUBTRACT+"
+           "+FUNC-SUBTRACT-EXT+"
+           "+FUNC-REVERSE-SUBTRACT-EXT+"
+           "+EXT-BLEND-LOGIC-OP+"
+           "+EXT-POINT-PARAMETERS+"
+           "+POINT-SIZE-MIN-EXT+"
+           "+POINT-SIZE-MAX-EXT+"
+           "+POINT-FADE-THRESHOLD-SIZE-EXT+"
+           "+DISTANCE-ATTENUATION-EXT+"
+           "+EXT-PALETTED-TEXTURE+"
+           "+TABLE-TOO-LARGE-EXT+"
+           "+COLOR-TABLE-FORMAT-EXT+"
+           "+COLOR-TABLE-WIDTH-EXT+"
+           "+COLOR-TABLE-RED-SIZE-EXT+"
+           "+COLOR-TABLE-GREEN-SIZE-EXT+"
+           "+COLOR-TABLE-BLUE-SIZE-EXT+"
+           "+COLOR-TABLE-ALPHA-SIZE-EXT+"
+           "+COLOR-TABLE-LUMINANCE-SIZE-EXT+"
+           "+COLOR-TABLE-INTENSITY-SIZE-EXT+"
+           "+TEXTURE-INDEX-SIZE-EXT+"
+           "+COLOR-INDEX1-EXT+"
+           "+COLOR-INDEX2-EXT+"
+           "+COLOR-INDEX4-EXT+"
+           "+COLOR-INDEX8-EXT+"
+           "+COLOR-INDEX12-EXT+"
+           "+COLOR-INDEX16-EXT+"
+           "+EXT-CLIP-VOLUME-HINT+"
+           "+CLIP-VOLUME-CLIPPING-HINT-EXT+"
+           "+EXT-COMPILED-VERTEX-ARRAY+"
+           "+ARRAY-ELEMENT-LOCK-FIRST-EXT+"
+           "+ARRAY-ELEMENT-LOCK-COUNT-EXT+"
+           "+HP-OCCLUSION-TEST+"
+           "+OCCLUSION-TEST-HP+"
+           "+OCCLUSION-TEST-RESULT-HP+"
+           "+EXT-SHARED-TEXTURE-PALETTE+"
+           "+SHARED-TEXTURE-PALETTE-EXT+"
+           "+EXT-STENCIL-WRAP+"
+           "+INCR-WRAP-EXT+"
+           "+DECR-WRAP-EXT+"
+           "+NV-TEXGEN-REFLECTION+"
+           "+NORMAL-MAP-NV+"
+           "+REFLECTION-MAP-NV+"
+           "+EXT-TEXTURE-ENV-ADD+"
+           "+MESA-WINDOW-POS+"
+           "+MESA-RESIZE-BUFFERS+"
+           
+           ))
+
+
+(in-package :gl)
+
+
+
+;;; Opcodes.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant +get-string+       129)
+(defconstant +new-list+         101)
+(defconstant +end-list+         102)
+(defconstant +gen-lists+        104)
+(defconstant +finish+           108)
+(defconstant +disable+          138)
+(defconstant +enable+           139)
+(defconstant +flush+            142)
+
+
+
+;;; Constants.
+;;; Shamelessly taken from CL-SDL.
+
+;; Boolean
+
+(defconstant +false+                            #x0) 
+(defconstant +true+                             #x1) 
+
+;; Types
+
+(defconstant +byte+                          #x1400) 
+(defconstant +unsigned-byte+                 #x1401) 
+(defconstant +short+                         #x1402) 
+(defconstant +unsigned-short+                #x1403) 
+(defconstant +int+                           #x1404) 
+(defconstant +unsigned-int+                  #x1405) 
+(defconstant +float+                         #x1406) 
+(defconstant +double+                        #x140a) 
+(defconstant +2-bytes+                       #x1407) 
+(defconstant +3-bytes+                       #x1408) 
+(defconstant +4-bytes+                       #x1409) 
+
+;; Primitives
+
+(defconstant +points+                        #x0000) 
+(defconstant +lines+                         #x0001) 
+(defconstant +line-loop+                     #x0002) 
+(defconstant +line-strip+                    #x0003) 
+(defconstant +triangles+                     #x0004) 
+(defconstant +triangle-strip+                #x0005) 
+(defconstant +triangle-fan+                  #x0006) 
+(defconstant +quads+                         #x0007) 
+(defconstant +quad-strip+                    #x0008) 
+(defconstant +polygon+                       #x0009) 
+
+;; Arrays
+
+(defconstant +vertex-array+                  #x8074) 
+(defconstant +normal-array+                  #x8075) 
+(defconstant +color-array+                   #x8076) 
+(defconstant +index-array+                   #x8077) 
+(defconstant +texture-coord-array+           #x8078) 
+(defconstant +edge-flag-array+               #x8079) 
+(defconstant +vertex-array-size+             #x807a) 
+(defconstant +vertex-array-type+             #x807b) 
+(defconstant +vertex-array-stride+           #x807c) 
+(defconstant +normal-array-type+             #x807e) 
+(defconstant +normal-array-stride+           #x807f) 
+(defconstant +color-array-size+              #x8081) 
+(defconstant +color-array-type+              #x8082) 
+(defconstant +color-array-stride+            #x8083) 
+(defconstant +index-array-type+              #x8085) 
+(defconstant +index-array-stride+            #x8086) 
+(defconstant +texture-coord-array-size+      #x8088) 
+(defconstant +texture-coord-array-type+      #x8089) 
+(defconstant +texture-coord-array-stride+    #x808a) 
+(defconstant +edge-flag-array-stride+        #x808c) 
+(defconstant +vertex-array-pointer+          #x808e) 
+(defconstant +normal-array-pointer+          #x808f) 
+(defconstant +color-array-pointer+           #x8090) 
+(defconstant +index-array-pointer+           #x8091) 
+(defconstant +texture-coord-array-pointer+   #x8092) 
+(defconstant +edge-flag-array-pointer+       #x8093) 
+
+;; Array formats
+
+(defconstant +v2f+                           #x2a20) 
+(defconstant +v3f+                           #x2a21) 
+(defconstant +c4ub-v2f+                      #x2a22) 
+(defconstant +c4ub-v3f+                      #x2a23) 
+(defconstant +c3f-v3f+                       #x2a24) 
+(defconstant +n3f-v3f+                       #x2a25) 
+(defconstant +c4f-n3f-v3f+                   #x2a26) 
+(defconstant +t2f-v3f+                       #x2a27) 
+(defconstant +t4f-v4f+                       #x2a28) 
+(defconstant +t2f-c4ub-v3f+                  #x2a29) 
+(defconstant +t2f-c3f-v3f+                   #x2a2a) 
+(defconstant +t2f-n3f-v3f+                   #x2a2b) 
+(defconstant +t2f-c4f-n3f-v3f+               #x2a2c) 
+(defconstant +t4f-c4f-n3f-v4f+               #x2a2d) 
+
+;; Matrices
+
+(defconstant +matrix-mode+                   #x0ba0) 
+(defconstant +modelview+                     #x1700) 
+(defconstant +projection+                    #x1701) 
+(defconstant +texture+                       #x1702) 
+
+;; Points
+
+(defconstant +point-smooth+                  #x0b10) 
+(defconstant +point-size+                    #x0b11) 
+(defconstant +point-size-granularity+        #x0b13) 
+(defconstant +point-size-range+              #x0b12) 
+
+;; Lines
+
+(defconstant +line-smooth+                   #x0b20) 
+(defconstant +line-stipple+                  #x0b24) 
+(defconstant +line-stipple-pattern+          #x0b25) 
+(defconstant +line-stipple-repeat+           #x0b26) 
+(defconstant +line-width+                    #x0b21) 
+(defconstant +line-width-granularity+        #x0b23) 
+(defconstant +line-width-range+              #x0b22) 
+
+;; Polygons
+
+(defconstant +point+                         #x1b00) 
+(defconstant +line+                          #x1b01) 
+(defconstant +fill+                          #x1b02) 
+(defconstant +cw+                            #x0900) 
+(defconstant +ccw+                           #x0901) 
+(defconstant +front+                         #x0404) 
+(defconstant +back+                          #x0405) 
+(defconstant +polygon-mode+                  #x0b40) 
+(defconstant +polygon-smooth+                #x0b41) 
+(defconstant +polygon-stipple+               #x0b42) 
+(defconstant +edge-flag+                     #x0b43) 
+(defconstant +cull-face+                     #x0b44) 
+(defconstant +cull-face-mode+                #x0b45) 
+(defconstant +front-face+                    #x0b46) 
+(defconstant +polygon-offset-factor+         #x8038) 
+(defconstant +polygon-offset-units+          #x2a00) 
+(defconstant +polygon-offset-point+          #x2a01) 
+(defconstant +polygon-offset-line+           #x2a02) 
+(defconstant +polygon-offset-fill+           #x8037) 
+
+;; Display Lists
+
+(defconstant +compile+                       #x1300) 
+(defconstant +compile-and-execute+           #x1301) 
+(defconstant +list-base+                     #x0b32) 
+(defconstant +list-index+                    #x0b33) 
+(defconstant +list-mode+                     #x0b30) 
+
+;; Depth Buffer
+
+(defconstant +never+                         #x0200) 
+(defconstant +less+                          #x0201) 
+(defconstant +equal+                         #x0202) 
+(defconstant +lequal+                        #x0203) 
+(defconstant +greater+                       #x0204) 
+(defconstant +notequal+                      #x0205) 
+(defconstant +gequal+                        #x0206) 
+(defconstant +always+                        #x0207) 
+(defconstant +depth-test+                    #x0b71) 
+(defconstant +depth-bits+                    #x0d56) 
+(defconstant +depth-clear-value+             #x0b73) 
+(defconstant +depth-func+                    #x0b74) 
+(defconstant +depth-range+                   #x0b70) 
+(defconstant +depth-writemask+               #x0b72) 
+(defconstant +depth-component+               #x1902) 
+
+;; Lighting
+
+(defconstant +lighting+                      #x0b50) 
+(defconstant +light0+                        #x4000) 
+(defconstant +light1+                        #x4001) 
+(defconstant +light2+                        #x4002) 
+(defconstant +light3+                        #x4003) 
+(defconstant +light4+                        #x4004) 
+(defconstant +light5+                        #x4005) 
+(defconstant +light6+                        #x4006) 
+(defconstant +light7+                        #x4007) 
+(defconstant +spot-exponent+                 #x1205) 
+(defconstant +spot-cutoff+                   #x1206) 
+(defconstant +constant-attenuation+          #x1207) 
+(defconstant +linear-attenuation+            #x1208) 
+(defconstant +quadratic-attenuation+         #x1209) 
+(defconstant +ambient+                       #x1200) 
+(defconstant +diffuse+                       #x1201) 
+(defconstant +specular+                      #x1202) 
+(defconstant +shininess+                     #x1601) 
+(defconstant +emission+                      #x1600) 
+(defconstant +position+                      #x1203) 
+(defconstant +spot-direction+                #x1204) 
+(defconstant +ambient-and-diffuse+           #x1602) 
+(defconstant +color-indexes+                 #x1603) 
+(defconstant +light-model-two-side+          #x0b52) 
+(defconstant +light-model-local-viewer+      #x0b51) 
+(defconstant +light-model-ambient+           #x0b53) 
+(defconstant +front-and-back+                #x0408) 
+(defconstant +shade-model+                   #x0b54) 
+(defconstant +flat+                          #x1d00) 
+(defconstant +smooth+                        #x1d01) 
+(defconstant +color-material+                #x0b57) 
+(defconstant +color-material-face+           #x0b55) 
+(defconstant +color-material-parameter+      #x0b56) 
+(defconstant +normalize+                     #x0ba1) 
+
+;; Clipping planes
+
+(defconstant +clip-plane0+                   #x3000) 
+(defconstant +clip-plane1+                   #x3001) 
+(defconstant +clip-plane2+                   #x3002) 
+(defconstant +clip-plane3+                   #x3003) 
+(defconstant +clip-plane4+                   #x3004) 
+(defconstant +clip-plane5+                   #x3005) 
+
+;; Accumulation buffer
+
+(defconstant +accum-red-bits+                #x0d58) 
+(defconstant +accum-green-bits+              #x0d59) 
+(defconstant +accum-blue-bits+               #x0d5a) 
+(defconstant +accum-alpha-bits+              #x0d5b) 
+(defconstant +accum-clear-value+             #x0b80) 
+(defconstant +accum+                         #x0100) 
+(defconstant +add+                           #x0104) 
+(defconstant +load+                          #x0101) 
+(defconstant +mult+                          #x0103) 
+(defconstant +return+                        #x0102) 
+
+;; Alpha Testing
+
+(defconstant +alpha-test+                    #x0bc0) 
+(defconstant +alpha-test-ref+                #x0bc2) 
+(defconstant +alpha-test-func+               #x0bc1) 
+
+;; Blending
+
+(defconstant +blend+                         #x0be2) 
+(defconstant +blend-src+                     #x0be1) 
+(defconstant +blend-dst+                     #x0be0) 
+(defconstant +zero+                             #x0) 
+(defconstant +one+                              #x1) 
+(defconstant +src-color+                     #x0300) 
+(defconstant +one-minus-src-color+           #x0301) 
+(defconstant +dst-color+                     #x0306) 
+(defconstant +one-minus-dst-color+           #x0307) 
+(defconstant +src-alpha+                     #x0302) 
+(defconstant +one-minus-src-alpha+           #x0303) 
+(defconstant +dst-alpha+                     #x0304) 
+(defconstant +one-minus-dst-alpha+           #x0305) 
+(defconstant +src-alpha-saturate+            #x0308) 
+(defconstant +constant-color+                #x8001) 
+(defconstant +one-minus-constant-color+      #x8002) 
+(defconstant +constant-alpha+                #x8003) 
+(defconstant +one-minus-constant-alpha+      #x8004) 
+
+;; Render mode
+
+(defconstant +feedback+                      #x1c01) 
+(defconstant +render+                        #x1c00) 
+(defconstant +select+                        #x1c02) 
+
+;; Feedback
+
+(defconstant +2d+                            #x0600) 
+(defconstant +3d+                            #x0601) 
+(defconstant +3d-color+                      #x0602) 
+(defconstant +3d-color-texture+              #x0603) 
+(defconstant +4d-color-texture+              #x0604) 
+(defconstant +point-token+                   #x0701) 
+(defconstant +line-token+                    #x0702) 
+(defconstant +line-reset-token+              #x0707) 
+(defconstant +polygon-token+                 #x0703) 
+(defconstant +bitmap-token+                  #x0704) 
+(defconstant +draw-pixel-token+              #x0705) 
+(defconstant +copy-pixel-token+              #x0706) 
+(defconstant +pass-through-token+            #x0700) 
+(defconstant +feedback-buffer-pointer+       #x0df0) 
+(defconstant +feedback-buffer-size+          #x0df1) 
+(defconstant +feedback-buffer-type+          #x0df2) 
+
+;; Selection
+
+(defconstant +selection-buffer-pointer+      #x0df3) 
+(defconstant +selection-buffer-size+         #x0df4) 
+
+;; Fog
+
+(defconstant +fog+                           #x0b60) 
+(defconstant +fog-mode+                      #x0b65) 
+(defconstant +fog-density+                   #x0b62) 
+(defconstant +fog-color+                     #x0b66) 
+(defconstant +fog-index+                     #x0b61) 
+(defconstant +fog-start+                     #x0b63) 
+(defconstant +fog-end+                       #x0b64) 
+(defconstant +linear+                        #x2601) 
+(defconstant +exp+                           #x0800) 
+(defconstant +exp2+                          #x0801) 
+
+;; Logic operations
+
+(defconstant +logic-op+                      #x0bf1) 
+(defconstant +index-logic-op+                #x0bf1) 
+(defconstant +color-logic-op+                #x0bf2) 
+(defconstant +logic-op-mode+                 #x0bf0) 
+(defconstant +clear+                         #x1500) 
+(defconstant +set+                           #x150f) 
+(defconstant +copy+                          #x1503) 
+(defconstant +copy-inverted+                 #x150c) 
+(defconstant +noop+                          #x1505) 
+(defconstant +invert+                        #x150a) 
+(defconstant +and+                           #x1501) 
+(defconstant +nand+                          #x150e) 
+(defconstant +or+                            #x1507) 
+(defconstant +nor+                           #x1508) 
+(defconstant +xor+                           #x1506) 
+(defconstant +equiv+                         #x1509) 
+(defconstant +and-reverse+                   #x1502) 
+(defconstant +and-inverted+                  #x1504) 
+(defconstant +or-reverse+                    #x150b) 
+(defconstant +or-inverted+                   #x150d) 
+
+;; Stencil
+
+(defconstant +stencil-test+                  #x0b90) 
+(defconstant +stencil-writemask+             #x0b98) 
+(defconstant +stencil-bits+                  #x0d57) 
+(defconstant +stencil-func+                  #x0b92) 
+(defconstant +stencil-value-mask+            #x0b93) 
+(defconstant +stencil-ref+                   #x0b97) 
+(defconstant +stencil-fail+                  #x0b94) 
+(defconstant +stencil-pass-depth-pass+       #x0b96) 
+(defconstant +stencil-pass-depth-fail+       #x0b95) 
+(defconstant +stencil-clear-value+           #x0b91) 
+(defconstant +stencil-index+                 #x1901) 
+(defconstant +keep+                          #x1e00) 
+(defconstant +replace+                       #x1e01) 
+(defconstant +incr+                          #x1e02) 
+(defconstant +decr+                          #x1e03) 
+
+;; Buffers, Pixel Drawing/Reading
+
+(defconstant +none+                             #x0) 
+(defconstant +left+                          #x0406) 
+(defconstant +right+                         #x0407) 
+(defconstant +front-left+                    #x0400) 
+(defconstant +front-right+                   #x0401) 
+(defconstant +back-left+                     #x0402) 
+(defconstant +back-right+                    #x0403) 
+(defconstant +aux0+                          #x0409) 
+(defconstant +aux1+                          #x040a) 
+(defconstant +aux2+                          #x040b) 
+(defconstant +aux3+                          #x040c) 
+(defconstant +color-index+                   #x1900) 
+(defconstant +red+                           #x1903) 
+(defconstant +green+                         #x1904) 
+(defconstant +blue+                          #x1905) 
+(defconstant +alpha+                         #x1906) 
+(defconstant +luminance+                     #x1909) 
+(defconstant +luminance-alpha+               #x190a) 
+(defconstant +alpha-bits+                    #x0d55) 
+(defconstant +red-bits+                      #x0d52) 
+(defconstant +green-bits+                    #x0d53) 
+(defconstant +blue-bits+                     #x0d54) 
+(defconstant +index-bits+                    #x0d51) 
+(defconstant +subpixel-bits+                 #x0d50) 
+(defconstant +aux-buffers+                   #x0c00) 
+(defconstant +read-buffer+                   #x0c02) 
+(defconstant +draw-buffer+                   #x0c01) 
+(defconstant +doublebuffer+                  #x0c32) 
+(defconstant +stereo+                        #x0c33) 
+(defconstant +bitmap+                        #x1a00) 
+(defconstant +color+                         #x1800) 
+(defconstant +depth+                         #x1801) 
+(defconstant +stencil+                       #x1802) 
+(defconstant +dither+                        #x0bd0) 
+(defconstant +rgb+                           #x1907) 
+(defconstant +rgba+                          #x1908) 
+
+;; Implementation Limits
+
+(defconstant +max-list-nesting+              #x0b31) 
+(defconstant +max-attrib-stack-depth+        #x0d35) 
+(defconstant +max-modelview-stack-depth+     #x0d36) 
+(defconstant +max-name-stack-depth+          #x0d37) 
+(defconstant +max-projection-stack-depth+    #x0d38) 
+(defconstant +max-texture-stack-depth+       #x0d39) 
+(defconstant +max-eval-order+                #x0d30) 
+(defconstant +max-lights+                    #x0d31) 
+(defconstant +max-clip-planes+               #x0d32) 
+(defconstant +max-texture-size+              #x0d33) 
+(defconstant +max-pixel-map-table+           #x0d34) 
+(defconstant +max-viewport-dims+             #x0d3a) 
+(defconstant +max-client-attrib-stack-depth+ #x0d3b) 
+
+;; Gets
+
+(defconstant +attrib-stack-depth+            #x0bb0) 
+(defconstant +client-attrib-stack-depth+     #x0bb1) 
+(defconstant +color-clear-value+             #x0c22) 
+(defconstant +color-writemask+               #x0c23) 
+(defconstant +current-index+                 #x0b01) 
+(defconstant +current-color+                 #x0b00) 
+(defconstant +current-normal+                #x0b02) 
+(defconstant +current-raster-color+          #x0b04) 
+(defconstant +current-raster-distance+       #x0b09) 
+(defconstant +current-raster-index+          #x0b05) 
+(defconstant +current-raster-position+       #x0b07) 
+(defconstant +current-raster-texture-coords+ #x0b06) 
+(defconstant +current-raster-position-valid+ #x0b08) 
+(defconstant +current-texture-coords+        #x0b03) 
+(defconstant +index-clear-value+             #x0c20) 
+(defconstant +index-mode+                    #x0c30) 
+(defconstant +index-writemask+               #x0c21) 
+(defconstant +modelview-matrix+              #x0ba6) 
+(defconstant +modelview-stack-depth+         #x0ba3) 
+(defconstant +name-stack-depth+              #x0d70) 
+(defconstant +projection-matrix+             #x0ba7) 
+(defconstant +projection-stack-depth+        #x0ba4) 
+(defconstant +render-mode+                   #x0c40) 
+(defconstant +rgba-mode+                     #x0c31) 
+(defconstant +texture-matrix+                #x0ba8) 
+(defconstant +texture-stack-depth+           #x0ba5) 
+(defconstant +viewport+                      #x0ba2) 
+
+;; GL Evaluators
+
+(defconstant +auto-normal+                   #x0d80) 
+(defconstant +map1-color-4+                  #x0d90) 
+(defconstant +map1-grid-domain+              #x0dd0) 
+(defconstant +map1-grid-segments+            #x0dd1) 
+(defconstant +map1-index+                    #x0d91) 
+(defconstant +map1-normal+                   #x0d92) 
+(defconstant +map1-texture-coord-1+          #x0d93) 
+(defconstant +map1-texture-coord-2+          #x0d94) 
+(defconstant +map1-texture-coord-3+          #x0d95) 
+(defconstant +map1-texture-coord-4+          #x0d96) 
+(defconstant +map1-vertex-3+                 #x0d97) 
+(defconstant +map1-vertex-4+                 #x0d98) 
+(defconstant +map2-color-4+                  #x0db0) 
+(defconstant +map2-grid-domain+              #x0dd2) 
+(defconstant +map2-grid-segments+            #x0dd3) 
+(defconstant +map2-index+                    #x0db1) 
+(defconstant +map2-normal+                   #x0db2) 
+(defconstant +map2-texture-coord-1+          #x0db3) 
+(defconstant +map2-texture-coord-2+          #x0db4) 
+(defconstant +map2-texture-coord-3+          #x0db5) 
+(defconstant +map2-texture-coord-4+          #x0db6) 
+(defconstant +map2-vertex-3+                 #x0db7) 
+(defconstant +map2-vertex-4+                 #x0db8) 
+(defconstant +coeff+                         #x0a00) 
+(defconstant +domain+                        #x0a02) 
+(defconstant +order+                         #x0a01) 
+
+;; Hints
+
+(defconstant +fog-hint+                      #x0c54) 
+(defconstant +line-smooth-hint+              #x0c52) 
+(defconstant +perspective-correction-hint+   #x0c50) 
+(defconstant +point-smooth-hint+             #x0c51) 
+(defconstant +polygon-smooth-hint+           #x0c53) 
+(defconstant +dont-care+                     #x1100) 
+(defconstant +fastest+                       #x1101) 
+(defconstant +nicest+                        #x1102) 
+
+;; Scissor box
+
+(defconstant +scissor-test+                  #x0c11) 
+(defconstant +scissor-box+                   #x0c10) 
+
+;; Pixel Mode / Transfer
+
+(defconstant +map-color+                     #x0d10) 
+(defconstant +map-stencil+                   #x0d11) 
+(defconstant +index-shift+                   #x0d12) 
+(defconstant +index-offset+                  #x0d13) 
+(defconstant +red-scale+                     #x0d14) 
+(defconstant +red-bias+                      #x0d15) 
+(defconstant +green-scale+                   #x0d18) 
+(defconstant +green-bias+                    #x0d19) 
+(defconstant +blue-scale+                    #x0d1a) 
+(defconstant +blue-bias+                     #x0d1b) 
+(defconstant +alpha-scale+                   #x0d1c) 
+(defconstant +alpha-bias+                    #x0d1d) 
+(defconstant +depth-scale+                   #x0d1e) 
+(defconstant +depth-bias+                    #x0d1f) 
+(defconstant +pixel-map-s-to-s-size+         #x0cb1) 
+(defconstant +pixel-map-i-to-i-size+         #x0cb0) 
+(defconstant +pixel-map-i-to-r-size+         #x0cb2) 
+(defconstant +pixel-map-i-to-g-size+         #x0cb3) 
+(defconstant +pixel-map-i-to-b-size+         #x0cb4) 
+(defconstant +pixel-map-i-to-a-size+         #x0cb5) 
+(defconstant +pixel-map-r-to-r-size+         #x0cb6) 
+(defconstant +pixel-map-g-to-g-size+         #x0cb7) 
+(defconstant +pixel-map-b-to-b-size+         #x0cb8) 
+(defconstant +pixel-map-a-to-a-size+         #x0cb9) 
+(defconstant +pixel-map-s-to-s+              #x0c71) 
+(defconstant +pixel-map-i-to-i+              #x0c70) 
+(defconstant +pixel-map-i-to-r+              #x0c72) 
+(defconstant +pixel-map-i-to-g+              #x0c73) 
+(defconstant +pixel-map-i-to-b+              #x0c74) 
+(defconstant +pixel-map-i-to-a+              #x0c75) 
+(defconstant +pixel-map-r-to-r+              #x0c76) 
+(defconstant +pixel-map-g-to-g+              #x0c77) 
+(defconstant +pixel-map-b-to-b+              #x0c78) 
+(defconstant +pixel-map-a-to-a+              #x0c79) 
+(defconstant +pack-alignment+                #x0d05) 
+(defconstant +pack-lsb-first+                #x0d01) 
+(defconstant +pack-row-length+               #x0d02) 
+(defconstant +pack-skip-pixels+              #x0d04) 
+(defconstant +pack-skip-rows+                #x0d03) 
+(defconstant +pack-swap-bytes+               #x0d00) 
+(defconstant +unpack-alignment+              #x0cf5) 
+(defconstant +unpack-lsb-first+              #x0cf1) 
+(defconstant +unpack-row-length+             #x0cf2) 
+(defconstant +unpack-skip-pixels+            #x0cf4) 
+(defconstant +unpack-skip-rows+              #x0cf3) 
+(defconstant +unpack-swap-bytes+             #x0cf0) 
+(defconstant +zoom-x+                        #x0d16) 
+(defconstant +zoom-y+                        #x0d17) 
+
+;; Texture Mapping
+
+(defconstant +texture-env+                   #x2300) 
+(defconstant +texture-env-mode+              #x2200) 
+(defconstant +texture-1d+                    #x0de0) 
+(defconstant +texture-2d+                    #x0de1) 
+(defconstant +texture-wrap-s+                #x2802) 
+(defconstant +texture-wrap-t+                #x2803) 
+(defconstant +texture-mag-filter+            #x2800) 
+(defconstant +texture-min-filter+            #x2801) 
+(defconstant +texture-env-color+             #x2201) 
+(defconstant +texture-gen-s+                 #x0c60) 
+(defconstant +texture-gen-t+                 #x0c61) 
+(defconstant +texture-gen-mode+              #x2500) 
+(defconstant +texture-border-color+          #x1004) 
+(defconstant +texture-width+                 #x1000) 
+(defconstant +texture-height+                #x1001) 
+(defconstant +texture-border+                #x1005) 
+(defconstant +texture-components+            #x1003) 
+(defconstant +texture-red-size+              #x805c) 
+(defconstant +texture-green-size+            #x805d) 
+(defconstant +texture-blue-size+             #x805e) 
+(defconstant +texture-alpha-size+            #x805f) 
+(defconstant +texture-luminance-size+        #x8060) 
+(defconstant +texture-intensity-size+        #x8061) 
+(defconstant +nearest-mipmap-nearest+        #x2700) 
+(defconstant +nearest-mipmap-linear+         #x2702) 
+(defconstant +linear-mipmap-nearest+         #x2701) 
+(defconstant +linear-mipmap-linear+          #x2703) 
+(defconstant +object-linear+                 #x2401) 
+(defconstant +object-plane+                  #x2501) 
+(defconstant +eye-linear+                    #x2400) 
+(defconstant +eye-plane+                     #x2502) 
+(defconstant +sphere-map+                    #x2402) 
+(defconstant +decal+                         #x2101) 
+(defconstant +modulate+                      #x2100) 
+(defconstant +nearest+                       #x2600) 
+(defconstant +repeat+                        #x2901) 
+(defconstant +clamp+                         #x2900) 
+(defconstant +s+                             #x2000) 
+(defconstant +t+                             #x2001) 
+(defconstant +r+                             #x2002) 
+(defconstant +q+                             #x2003) 
+(defconstant +texture-gen-r+                 #x0c62) 
+(defconstant +texture-gen-q+                 #x0c63) 
+
+;; GL 1.1 Texturing
+
+(defconstant +proxy-texture-1d+              #x8063) 
+(defconstant +proxy-texture-2d+              #x8064) 
+(defconstant +texture-priority+              #x8066) 
+(defconstant +texture-resident+              #x8067) 
+(defconstant +texture-binding-1d+            #x8068) 
+(defconstant +texture-binding-2d+            #x8069) 
+(defconstant +texture-internal-format+       #x1003) 
+(defconstant +pack-skip-images+              #x806b) 
+(defconstant +pack-image-height+             #x806c) 
+(defconstant +unpack-skip-images+            #x806d) 
+(defconstant +unpack-image-height+           #x806e) 
+(defconstant +texture-3d+                    #x806f) 
+(defconstant +proxy-texture-3d+              #x8070) 
+(defconstant +texture-depth+                 #x8071) 
+(defconstant +texture-wrap-r+                #x8072) 
+(defconstant +max-3d-texture-size+           #x8073) 
+(defconstant +texture-binding-3d+            #x806a) 
+
+;; Internal texture formats (GL 1.1)
+(defconstant +alpha4+                        #x803b) 
+(defconstant +alpha8+                        #x803c) 
+(defconstant +alpha12+                       #x803d) 
+(defconstant +alpha16+                       #x803e) 
+(defconstant +luminance4+                    #x803f) 
+(defconstant +luminance8+                    #x8040) 
+(defconstant +luminance12+                   #x8041) 
+(defconstant +luminance16+                   #x8042) 
+(defconstant +luminance4-alpha4+             #x8043) 
+(defconstant +luminance6-alpha2+             #x8044) 
+(defconstant +luminance8-alpha8+             #x8045) 
+(defconstant +luminance12-alpha4+            #x8046) 
+(defconstant +luminance12-alpha12+           #x8047) 
+(defconstant +luminance16-alpha16+           #x8048) 
+(defconstant +intensity+                     #x8049) 
+(defconstant +intensity4+                    #x804a) 
+(defconstant +intensity8+                    #x804b) 
+(defconstant +intensity12+                   #x804c) 
+(defconstant +intensity16+                   #x804d) 
+(defconstant +r3-g3-b2+                      #x2a10) 
+(defconstant +rgb4+                          #x804f) 
+(defconstant +rgb5+                          #x8050) 
+(defconstant +rgb8+                          #x8051) 
+(defconstant +rgb10+                         #x8052) 
+(defconstant +rgb12+                         #x8053) 
+(defconstant +rgb16+                         #x8054) 
+(defconstant +rgba2+                         #x8055) 
+(defconstant +rgba4+                         #x8056) 
+(defconstant +rgb5-a1+                       #x8057) 
+(defconstant +rgba8+                         #x8058) 
+(defconstant +rgb10-a2+                      #x8059) 
+(defconstant +rgba12+                        #x805a) 
+(defconstant +rgba16+                        #x805b) 
+
+;; Utility
+
+(defconstant +vendor+                        #x1f00) 
+(defconstant +renderer+                      #x1f01) 
+(defconstant +version+                       #x1f02) 
+(defconstant +extensions+                    #x1f03) 
+
+;; Errors
+
+(defconstant +no-error+                         #x0) 
+(defconstant +invalid-value+                 #x0501) 
+(defconstant +invalid-enum+                  #x0500) 
+(defconstant +invalid-operation+             #x0502) 
+(defconstant +stack-overflow+                #x0503) 
+(defconstant +stack-underflow+               #x0504) 
+(defconstant +out-of-memory+                 #x0505) 
+
+;; OpenGL 1.2
+
+(defconstant +rescale-normal+                #x803a) 
+(defconstant +clamp-to-edge+                 #x812f) 
+(defconstant +max-elements-vertices+         #x80e8) 
+(defconstant +max-elements-indices+          #x80e9) 
+(defconstant +bgr+                           #x80e0) 
+(defconstant +bgra+                          #x80e1) 
+(defconstant +unsigned-byte-3-3-2+           #x8032) 
+(defconstant +unsigned-byte-2-3-3-rev+       #x8362) 
+(defconstant +unsigned-short-5-6-5+          #x8363) 
+(defconstant +unsigned-short-5-6-5-rev+      #x8364) 
+(defconstant +unsigned-short-4-4-4-4+        #x8033) 
+(defconstant +unsigned-short-4-4-4-4-rev+    #x8365) 
+(defconstant +unsigned-short-5-5-5-1+        #x8034) 
+(defconstant +unsigned-short-1-5-5-5-rev+    #x8366) 
+(defconstant +unsigned-int-8-8-8-8+          #x8035) 
+(defconstant +unsigned-int-8-8-8-8-rev+      #x8367) 
+(defconstant +unsigned-int-10-10-10-2+       #x8036) 
+(defconstant +unsigned-int-2-10-10-10-rev+   #x8368) 
+(defconstant +light-model-color-control+     #x81f8) 
+(defconstant +single-color+                  #x81f9) 
+(defconstant +separate-specular-color+       #x81fa) 
+(defconstant +texture-min-lod+               #x813a) 
+(defconstant +texture-max-lod+               #x813b) 
+(defconstant +texture-base-level+            #x813c) 
+(defconstant +texture-max-level+             #x813d) 
+(defconstant +smooth-point-size-range+       #x0b12) 
+(defconstant +smooth-point-size-granularity+ #x0b13) 
+(defconstant +smooth-line-width-range+       #x0b22) 
+(defconstant +smooth-line-width-granularity+ #x0b23) 
+(defconstant +aliased-point-size-range+      #x846d) 
+(defconstant +aliased-line-width-range+      #x846e) 
+
+;; OpenGL 1.2 Imaging subset
+;; GL_EXT_color_table
+(defconstant +color-table+                   #x80d0) 
+(defconstant +post-convolution-color-table+  #x80d1) 
+(defconstant +post-color-matrix-color-table+ #x80d2) 
+(defconstant +proxy-color-table+             #x80d3) 
+(defconstant +proxy-post-convolution-color-table+  #x80d4) 
+(defconstant +proxy-post-color-matrix-color-table+ #x80d5) 
+(defconstant +color-table-scale+             #x80d6) 
+(defconstant +color-table-bias+              #x80d7) 
+(defconstant +color-table-format+            #x80d8) 
+(defconstant +color-table-width+             #x80d9) 
+(defconstant +color-table-red-size+          #x80da) 
+(defconstant +color-table-green-size+        #x80db) 
+(defconstant +color-table-blue-size+         #x80dc) 
+(defconstant +color-table-alpha-size+        #x80dd) 
+(defconstant +color-table-luminance-size+    #x80de) 
+(defconstant +color-table-intensity-size+    #x80df) 
+;; GL_EXT_convolution and GL_HP_convolution
+(defconstant +convolution-1d+                #x8010) 
+(defconstant +convolution-2d+                #x8011) 
+(defconstant +separable-2d+                  #x8012) 
+(defconstant +convolution-border-mode+       #x8013) 
+(defconstant +convolution-filter-scale+      #x8014) 
+(defconstant +convolution-filter-bias+       #x8015) 
+(defconstant +reduce+                        #x8016) 
+(defconstant +convolution-format+            #x8017) 
+(defconstant +convolution-width+             #x8018) 
+(defconstant +convolution-height+            #x8019) 
+(defconstant +max-convolution-width+         #x801a) 
+(defconstant +max-convolution-height+        #x801b) 
+(defconstant +post-convolution-red-scale+    #x801c) 
+(defconstant +post-convolution-green-scale+  #x801d) 
+(defconstant +post-convolution-blue-scale+   #x801e) 
+(defconstant +post-convolution-alpha-scale+  #x801f) 
+(defconstant +post-convolution-red-bias+     #x8020) 
+(defconstant +post-convolution-green-bias+   #x8021) 
+(defconstant +post-convolution-blue-bias+    #x8022) 
+(defconstant +post-convolution-alpha-bias+   #x8023) 
+(defconstant +constant-border+               #x8151) 
+(defconstant +replicate-border+              #x8153) 
+(defconstant +convolution-border-color+      #x8154) 
+;; GL_SGI_color_matrix
+(defconstant +color-matrix+                  #x80b1) 
+(defconstant +color-matrix-stack-depth+      #x80b2) 
+(defconstant +max-color-matrix-stack-depth+  #x80b3) 
+(defconstant +post-color-matrix-red-scale+   #x80b4) 
+(defconstant +post-color-matrix-green-scale+ #x80b5) 
+(defconstant +post-color-matrix-blue-scale+  #x80b6) 
+(defconstant +post-color-matrix-alpha-scale+ #x80b7) 
+(defconstant +post-color-matrix-red-bias+    #x80b8) 
+(defconstant +post-color-matrix-green-bias+  #x80b9) 
+(defconstant +post-color-matrix-blue-bias+   #x80ba) 
+(defconstant +post-color-matrix-alpha-bias+  #x80bb) 
+;; GL_EXT_histogram
+(defconstant +histogram+                     #x8024) 
+(defconstant +proxy-histogram+               #x8025) 
+(defconstant +histogram-width+               #x8026) 
+(defconstant +histogram-format+              #x8027) 
+(defconstant +histogram-red-size+            #x8028) 
+(defconstant +histogram-green-size+          #x8029) 
+(defconstant +histogram-blue-size+           #x802a) 
+(defconstant +histogram-alpha-size+          #x802b) 
+(defconstant +histogram-luminance-size+      #x802c) 
+(defconstant +histogram-sink+                #x802d) 
+(defconstant +minmax+                        #x802e) 
+(defconstant +minmax-format+                 #x802f) 
+(defconstant +minmax-sink+                   #x8030) 
+(defconstant +table-too-large+               #x8031) 
+;; GL_EXT_blend_color, GL_EXT_blend_minmax
+(defconstant +blend-equation+                #x8009) 
+(defconstant +min+                           #x8007) 
+(defconstant +max+                           #x8008) 
+(defconstant +func-add+                      #x8006) 
+(defconstant +func-subtract+                 #x800a) 
+(defconstant +func-reverse-subtract+         #x800b) 
+
+;; glPush/PopAttrib bits
+
+(defconstant +current-bit+               #x00000001) 
+(defconstant +point-bit+                 #x00000002) 
+(defconstant +line-bit+                  #x00000004) 
+(defconstant +polygon-bit+               #x00000008) 
+(defconstant +polygon-stipple-bit+       #x00000010) 
+(defconstant +pixel-mode-bit+            #x00000020) 
+(defconstant +lighting-bit+              #x00000040) 
+(defconstant +fog-bit+                   #x00000080) 
+(defconstant +depth-buffer-bit+          #x00000100) 
+(defconstant +accum-buffer-bit+          #x00000200) 
+(defconstant +stencil-buffer-bit+        #x00000400) 
+(defconstant +viewport-bit+              #x00000800) 
+(defconstant +transform-bit+             #x00001000) 
+(defconstant +enable-bit+                #x00002000) 
+(defconstant +color-buffer-bit+          #x00004000) 
+(defconstant +hint-bit+                  #x00008000) 
+(defconstant +eval-bit+                  #x00010000) 
+(defconstant +list-bit+                  #x00020000) 
+(defconstant +texture-bit+               #x00040000) 
+(defconstant +scissor-bit+               #x00080000) 
+(defconstant +all-attrib-bits+           #x000fffff) 
+(defconstant +client-pixel-store-bit+    #x00000001) 
+(defconstant +client-vertex-array-bit+   #x00000002) 
+(defconstant +client-all-attrib-bits+    #xffffffff) 
+
+;; ARB Multitexturing extension
+
+(defconstant +arb-multitexture+                   1) 
+(defconstant +texture0-arb+                  #x84c0) 
+(defconstant +texture1-arb+                  #x84c1) 
+(defconstant +texture2-arb+                  #x84c2) 
+(defconstant +texture3-arb+                  #x84c3) 
+(defconstant +texture4-arb+                  #x84c4) 
+(defconstant +texture5-arb+                  #x84c5) 
+(defconstant +texture6-arb+                  #x84c6) 
+(defconstant +texture7-arb+                  #x84c7) 
+(defconstant +texture8-arb+                  #x84c8) 
+(defconstant +texture9-arb+                  #x84c9) 
+(defconstant +texture10-arb+                 #x84ca) 
+(defconstant +texture11-arb+                 #x84cb) 
+(defconstant +texture12-arb+                 #x84cc) 
+(defconstant +texture13-arb+                 #x84cd) 
+(defconstant +texture14-arb+                 #x84ce) 
+(defconstant +texture15-arb+                 #x84cf) 
+(defconstant +texture16-arb+                 #x84d0) 
+(defconstant +texture17-arb+                 #x84d1) 
+(defconstant +texture18-arb+                 #x84d2) 
+(defconstant +texture19-arb+                 #x84d3) 
+(defconstant +texture20-arb+                 #x84d4) 
+(defconstant +texture21-arb+                 #x84d5) 
+(defconstant +texture22-arb+                 #x84d6) 
+(defconstant +texture23-arb+                 #x84d7) 
+(defconstant +texture24-arb+                 #x84d8) 
+(defconstant +texture25-arb+                 #x84d9) 
+(defconstant +texture26-arb+                 #x84da) 
+(defconstant +texture27-arb+                 #x84db) 
+(defconstant +texture28-arb+                 #x84dc) 
+(defconstant +texture29-arb+                 #x84dd) 
+(defconstant +texture30-arb+                 #x84de) 
+(defconstant +texture31-arb+                 #x84df) 
+(defconstant +active-texture-arb+            #x84e0) 
+(defconstant +client-active-texture-arb+     #x84e1) 
+(defconstant +max-texture-units-arb+         #x84e2) 
+
+;;; Misc extensions
+
+(defconstant +ext-abgr+                           1) 
+(defconstant +abgr-ext+                      #x8000) 
+(defconstant +ext-blend-color+                    1) 
+(defconstant +constant-color-ext+            #x8001) 
+(defconstant +one-minus-constant-color-ext+  #x8002) 
+(defconstant +constant-alpha-ext+            #x8003) 
+(defconstant +one-minus-constant-alpha-ext+  #x8004) 
+(defconstant +blend-color-ext+               #x8005) 
+(defconstant +ext-polygon-offset+                 1) 
+(defconstant +polygon-offset-ext+            #x8037) 
+(defconstant +polygon-offset-factor-ext+     #x8038) 
+(defconstant +polygon-offset-bias-ext+       #x8039) 
+(defconstant +ext-texture3d+                      1) 
+(defconstant +pack-skip-images-ext+          #x806b) 
+(defconstant +pack-image-height-ext+         #x806c) 
+(defconstant +unpack-skip-images-ext+        #x806d) 
+(defconstant +unpack-image-height-ext+       #x806e) 
+(defconstant +texture-3d-ext+                #x806f) 
+(defconstant +proxy-texture-3d-ext+          #x8070) 
+(defconstant +texture-depth-ext+             #x8071) 
+(defconstant +texture-wrap-r-ext+            #x8072) 
+(defconstant +max-3d-texture-size-ext+       #x8073) 
+(defconstant +texture-3d-binding-ext+        #x806a) 
+(defconstant +ext-texture-object+                 1) 
+(defconstant +texture-priority-ext+          #x8066) 
+(defconstant +texture-resident-ext+          #x8067) 
+(defconstant +texture-1d-binding-ext+        #x8068) 
+(defconstant +texture-2d-binding-ext+        #x8069) 
+(defconstant +ext-rescale-normal+                 1) 
+(defconstant +rescale-normal-ext+            #x803a) 
+(defconstant +ext-vertex-array+                   1) 
+(defconstant +vertex-array-ext+              #x8074) 
+(defconstant +normal-array-ext+              #x8075) 
+(defconstant +color-array-ext+               #x8076) 
+(defconstant +index-array-ext+               #x8077) 
+(defconstant +texture-coord-array-ext+       #x8078) 
+(defconstant +edge-flag-array-ext+           #x8079) 
+(defconstant +vertex-array-size-ext+         #x807a) 
+(defconstant +vertex-array-type-ext+         #x807b) 
+(defconstant +vertex-array-stride-ext+       #x807c) 
+(defconstant +vertex-array-count-ext+        #x807d) 
+(defconstant +normal-array-type-ext+         #x807e) 
+(defconstant +normal-array-stride-ext+       #x807f) 
+(defconstant +normal-array-count-ext+        #x8080) 
+(defconstant +color-array-size-ext+          #x8081) 
+(defconstant +color-array-type-ext+          #x8082) 
+(defconstant +color-array-stride-ext+        #x8083) 
+(defconstant +color-array-count-ext+         #x8084) 
+(defconstant +index-array-type-ext+          #x8085) 
+(defconstant +index-array-stride-ext+        #x8086) 
+(defconstant +index-array-count-ext+         #x8087) 
+(defconstant +texture-coord-array-size-ext+  #x8088) 
+(defconstant +texture-coord-array-type-ext+  #x8089) 
+(defconstant +texture-coord-array-stride-ext+ #x808a) 
+(defconstant +texture-coord-array-count-ext+ #x808b) 
+(defconstant +edge-flag-array-stride-ext+    #x808c) 
+(defconstant +edge-flag-array-count-ext+     #x808d) 
+(defconstant +vertex-array-pointer-ext+      #x808e) 
+(defconstant +normal-array-pointer-ext+      #x808f) 
+(defconstant +color-array-pointer-ext+       #x8090) 
+(defconstant +index-array-pointer-ext+       #x8091) 
+(defconstant +texture-coord-array-pointer-ext+ #x8092) 
+(defconstant +edge-flag-array-pointer-ext+   #x8093) 
+(defconstant +sgis-texture-edge-clamp+            1) 
+(defconstant +clamp-to-edge-sgis+            #x812f) 
+(defconstant +ext-blend-minmax+                   1) 
+(defconstant +func-add-ext+                  #x8006) 
+(defconstant +min-ext+                       #x8007) 
+(defconstant +max-ext+                       #x8008) 
+(defconstant +blend-equation-ext+            #x8009) 
+(defconstant +ext-blend-subtract+                 1) 
+(defconstant +func-subtract-ext+             #x800a) 
+(defconstant +func-reverse-subtract-ext+     #x800b) 
+(defconstant +ext-blend-logic-op+                 1) 
+(defconstant +ext-point-parameters+               1) 
+(defconstant +point-size-min-ext+            #x8126) 
+(defconstant +point-size-max-ext+            #x8127) 
+(defconstant +point-fade-threshold-size-ext+ #x8128) 
+(defconstant +distance-attenuation-ext+      #x8129) 
+(defconstant +ext-paletted-texture+               1) 
+(defconstant +table-too-large-ext+           #x8031) 
+(defconstant +color-table-format-ext+        #x80d8) 
+(defconstant +color-table-width-ext+         #x80d9) 
+(defconstant +color-table-red-size-ext+      #x80da) 
+(defconstant +color-table-green-size-ext+    #x80db) 
+(defconstant +color-table-blue-size-ext+     #x80dc) 
+(defconstant +color-table-alpha-size-ext+    #x80dd) 
+(defconstant +color-table-luminance-size-ext+ #x80de) 
+(defconstant +color-table-intensity-size-ext+ #x80df) 
+(defconstant +texture-index-size-ext+        #x80ed) 
+(defconstant +color-index1-ext+              #x80e2) 
+(defconstant +color-index2-ext+              #x80e3) 
+(defconstant +color-index4-ext+              #x80e4) 
+(defconstant +color-index8-ext+              #x80e5) 
+(defconstant +color-index12-ext+             #x80e6) 
+(defconstant +color-index16-ext+             #x80e7) 
+(defconstant +ext-clip-volume-hint+               1) 
+(defconstant +clip-volume-clipping-hint-ext+ #x80f0) 
+(defconstant +ext-compiled-vertex-array+          1) 
+(defconstant +array-element-lock-first-ext+  #x81a8) 
+(defconstant +array-element-lock-count-ext+  #x81a9) 
+(defconstant +hp-occlusion-test+                  1) 
+(defconstant +occlusion-test-hp+             #x8165) 
+(defconstant +occlusion-test-result-hp+      #x8166) 
+(defconstant +ext-shared-texture-palette+         1) 
+(defconstant +shared-texture-palette-ext+    #x81fb) 
+(defconstant +ext-stencil-wrap+                   1) 
+(defconstant +incr-wrap-ext+                 #x8507) 
+(defconstant +decr-wrap-ext+                 #x8508) 
+(defconstant +nv-texgen-reflection+               1) 
+(defconstant +normal-map-nv+                 #x8511) 
+(defconstant +reflection-map-nv+             #x8512) 
+(defconstant +ext-texture-env-add+                1) 
+(defconstant +mesa-window-pos+                    1) 
+(defconstant +mesa-resize-buffers+                1)
+)
+
+
+
+;;; Utility stuff
+
+(deftype bool () 'card8)
+(deftype float32 () 'single-float)
+(deftype float64 () 'double-float)
+
+(declaim (inline aset-float32 aset-float64))
+
+#+sbcl
+(defun aset-float32 (value array index)
+  (declare (type single-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (let ((bits (sb-kernel:single-float-bits value)))
+    (declare (type (unsigned-byte 32) bits))
+    (aset-card32 bits array index))
+  value)
+
+
+#+cmu
+(defun aset-float32 (value array index)
+  (declare (type single-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (let ((bits (kernel:single-float-bits  value)))
+    (declare (type (unsigned-byte 32) bits))
+    (aset-card32 bits array index))
+  value)
+
+
+#+openmcl
+(defun aset-float32 (value array index)
+  (declare (type single-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (let ((bits (ccl::single-float-bits value)))
+    (declare (type (unsigned-byte 32) bits))
+    (aset-card32 bits array index))
+  value)
+
+
+#+sbcl
+(defun aset-float64 (value array index)
+  (declare (type double-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (let ((low (sb-kernel:double-float-low-bits value))
+        (high (sb-kernel:double-float-high-bits value)))
+    (declare (type (unsigned-byte 32) low high))
+    (aset-card32 low array index)
+    (aset-card32 high array (the array-index (+ index 4))))
+  value)
+
+
+#+cmu
+(defun aset-float64 (value array index)
+  (declare (type double-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (let ((low (kernel:double-float-low-bits value))
+        (high (kernel:double-float-high-bits value)))
+    (declare (type (unsigned-byte 32) low high))
+    (aset-card32 low array index)
+    (aset-card32 high array (+ index 4)))
+  value)
+
+
+#+openmcl
+(defun aset-float64 (value array index)
+  (declare (type double-float value)
+           (type buffer-bytes array)
+           (type array-index index))
+  #.(declare-buffun)
+  (multiple-value-bind (low high)
+      (ccl::double-float-bits value)
+    (declare (type (unsigned-byte 32) low high))
+    (aset-card32 low array index)
+    (aset-card32 high array (the array-index (+ index 4))))
+  value)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun byte-width (type)
+  (ecase type
+    ((int8 card8 bool)          1)
+    ((int16 card16)             2)
+    ((int32 card32 float32)     4)
+    ((float64)                  8)))
+
+
+(defun setter (type)
+  (ecase type
+    (int8       'aset-int8)
+    (int16      'aset-int16)
+    (int32      'aset-int32)
+    (bool       'aset-card8)
+    (card8      'aset-card8)
+    (card16     'aset-card16)
+    (card32     'aset-card32)
+    (float32    'aset-float32)
+    (float64    'aset-float64)))
+
+
+(defun sequence-setter (type)
+  (ecase type
+    (int8       'sset-int8)
+    (int16      'sset-int16)
+    (int32      'sset-int32)
+    (bool       'sset-card8)
+    (card8      'sset-card8)
+    (card16     'sset-card16)
+    (card32     'sset-card32)
+    (float32    'sset-float32)
+    (float64    'sset-float64)))
+
+
+(defmacro define-sequence-setter (type)
+  `(defun ,(intern (format nil "~A-~A" 'sset type)) (seq buffer start length)
+     (declare (type sequence seq)
+              (type buffer-bytes buffer)
+              (type array-index start)
+              (type fixnum length))
+     #.(declare-buffun)
+     (assert (= length (length seq))
+             (length seq)
+             "SEQUENCE length should be ~D, not ~D." length (length seq))
+     (typecase seq
+       (list
+        (let ((offset 0))
+          (declare (type fixnum offset))
+          (dolist (n seq)
+            (declare (type ,type n))
+            (,(setter type) n buffer (the array-index (+ start offset)))
+            (incf offset ,(byte-width type)))))
+       ((simple-array ,type)
+        (dotimes (i ,(byte-width type))
+          (,(setter type)
+            (aref seq i)
+            buffer
+            (the array-index (+ start (* i ,(byte-width type)))))))
+       (vector
+        (dotimes (i ,(byte-width type))
+          (,(setter type)
+            (svref seq i)
+            buffer
+            (the array-index (+ start (* i ,(byte-width type))))))))))
+
+
+(define-sequence-setter int8)
+(define-sequence-setter int16)
+(define-sequence-setter int32)
+(define-sequence-setter bool)
+(define-sequence-setter card8)
+(define-sequence-setter card16)
+(define-sequence-setter card32)
+(define-sequence-setter float32)
+(define-sequence-setter float64)
+
+
+
+(defun make-argspecs (list)
+  (destructuring-bind (name type)
+      list
+    (etypecase type
+      (symbol `(,name ,type 1 nil))
+      (list
+       `(,name
+         ,(second type)
+         ,(third type)
+         ,(if (consp (third type))
+              (make-symbol (format nil "~A-~A" name 'length))
+              nil))))))
+
+
+(defun byte-width-calculation (argspecs)
+  (let ((constant 0)
+        (calculated ()))
+    (loop
+       for (name type length length-var) in argspecs
+       do (let ((byte-width (byte-width type)))
+            (typecase length
+              (number (incf constant (* byte-width length)))
+              (symbol (push `(* ,byte-width ,length) calculated))
+              (cons  (push `(* ,byte-width ,length-var) calculated)))))
+    (if (null calculated)
+        constant
+        (list* '+ constant calculated))))
+
+
+(defun composite-args (argspecs)
+  (loop
+     for (name type length length-var) in argspecs
+     when (consp length)
+     collect (list length-var length)))
+
+
+(defun make-setter-forms (argspecs)
+  (loop
+     for (name type length length-var) in argspecs
+     collecting `(progn
+                   ,(if (and (numberp length)
+                             (= 1 length))
+                        `(,(setter type) ,name .rbuf. .index.)
+                        `(,(sequence-setter type) ,name .rbuf. .index.
+                           ,(if length-var length-var length)))
+                   (setf .index. (the array-index
+                                   (+ .index.
+                                      (the fixnum (* ,(byte-width type)
+                                                     ,(if length-var length-var length)))))))))
+
+
+(defmacro define-rendering-command (name opcode &rest args)
+  ;; FIXME: Must heavily type-annotate.
+  (labels ((expand-args (list)
+             (loop
+                for (arg type) in list
+                if (consp arg)
+                append (loop
+                          for name in arg
+                          collecting (list name type))
+                else
+                collect (list arg type))))
+
+    (let* ((args (expand-args args))
+           (argspecs (mapcar 'make-argspecs args))
+           (total-byte-width (byte-width-calculation argspecs))
+           (composite-args (composite-args argspecs)))
+      
+      `(defun ,name ,(mapcar #'first argspecs)
+         (declare ,@(mapcar #'(lambda (list)
+                                (if (symbolp (second list))
+                                    (list* 'type (reverse list))
+                                    `(type sequence ,(first list))))
+                            args))
+         #.(declare-buffun)
+         (assert (context-p *current-context*)
+                 (*current-context*)
+                 "*CURRENT-CONTEXT* is not set (~S)." *current-context*)
+         (let* ((.ctx. *current-context*)
+                (.index0. (context-index .ctx.))
+                (.index. (+ .index0. 4))
+                (.rbuf. (context-rbuf .ctx.))
+                ,@composite-args
+                (.length. (+ 4 (* 4 (ceiling ,total-byte-width 4)))))
+
+           (declare (type context .ctx.)
+                    (type array-index .index. .index0.)
+                    (type buffer-bytes .rbuf.)
+                    ,@(mapcar #'(lambda (list)
+                                  `(type fixnum ,(first list)))
+                              composite-args)
+                    (type fixnum .length.))
+
+           (when (< (- (length .rbuf.) 8)
+                    (+ .index. .length.))
+             (error "Rendering command sequence too long.  Implement automatic buffer flushing."))
+
+           (aset-card16 .length. .rbuf. (the array-index .index0.))
+           (aset-card16 ,opcode .rbuf. (the array-index (+ .index0. 2)))
+           ,@(make-setter-forms argspecs)
+           (setf (context-index .ctx.) (the array-index (+ .index0. .length.))))))))
+
+) ;; eval-when
+
+
+;;; Command implementation.
+
+
+(defun get-string (name)
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "*CURRENT-CONTEXT* is not set (~S)." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +get-string+)
+         ;; *** This is CONTEXT-TAG
+         (card32 (context-tag ctx))
+         ;; *** This is ENUM.
+         (card32 name))
+      (let* ((length (card32-get 12))
+             (bytes (sequence-get :format card8
+                                  :result-type '(simple-array card8 (*))
+                                  :index 32
+                                  :length length)))
+        (declare (type (simple-array card8 (*)) bytes)
+                 (type fixnum length))
+        ;; FIXME: How does this interact with unicode?
+        (map-into (make-string (1- length)) #'code-char bytes)))))
+
+
+
+
+;;; Rendering commands (in alphabetical order).
+
+
+(define-rendering-command accum 137
+  ;; *** ENUM
+  (op           card32)
+  (value        float32))
+
+
+(define-rendering-command active-texture-arb 197
+  ;; *** ENUM
+  (texture      card32))
+
+
+(define-rendering-command alpha-func 159
+  ;; *** ENUM
+  (func         card32)
+  (ref          float32))
+
+
+(define-rendering-command begin 4
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command bind-texture 4117
+  ;; *** ENUM
+  (target       card32)
+  (texture      card32))
+
+
+(define-rendering-command blend-color 4096
+  (red          float32)
+  (green        float32)
+  (blue         float32)
+  (alpha        float32))
+
+
+(define-rendering-command blend-equotion 4097
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command blend-func 160
+  ;; *** ENUM
+  (sfactor      card32)
+  ;; *** ENUM
+  (dfactor      card32))
+
+
+(define-rendering-command call-list 1
+  (list         card32))
+
+
+(define-rendering-command clear 127
+  ;; *** BITFIELD
+  (mask         card32))
+
+
+(define-rendering-command clear-accum 128
+  (red          float32)
+  (green        float32)
+  (blue         float32)
+  (alpha        float32))
+
+
+(define-rendering-command clear-color 130 
+  (red          float32)
+  (green        float32)
+  (blue         float32)
+  (alpha        float32))
+
+
+(define-rendering-command clear-depth 132
+  (depth        float64))
+
+
+(define-rendering-command clear-index 129
+  (c            float32))
+
+
+(define-rendering-command clear-stencil 131
+  (s            int32))
+
+
+(define-rendering-command clip-plane 77
+  (equotion-0   float64)
+  (equotion-1   float64)
+  (equotion-2   float64)
+  (equotion-3   float64)
+  ;; *** ENUM
+  (plane        card32))
+
+
+(define-rendering-command color-3b 6
+  ((r g b)      int8))
+
+(define-rendering-command color-3d 7
+  ((r g b)      float64))
+
+(define-rendering-command color-3f 8
+  ((r g b)      float32))
+
+(define-rendering-command color-3i 9
+  ((r g b)      int32))
+
+(define-rendering-command color-3s 10
+  ((r g b)      int16))
+
+(define-rendering-command color-3ub 11
+  ((r g b)      card8))
+
+(define-rendering-command color-3ui 12
+  ((r g b)      card32))
+
+(define-rendering-command color-3us 13
+  ((r g b)      card16))
+
+
+(define-rendering-command color-4b 14
+  ((r g b a)    int8))
+
+(define-rendering-command color-4d 15
+  ((r g b a)    float64))
+
+(define-rendering-command color-4f 16
+  ((r g b a)    float32))
+
+(define-rendering-command color-4i 17
+  ((r g b a)    int32))
+
+(define-rendering-command color-4s 18
+  ((r g b a)    int16))
+
+(define-rendering-command color-4ub 19
+  ((r g b a)    card8))
+
+(define-rendering-command color-4ui 20
+  ((r g b a)    card32))
+
+(define-rendering-command color-4us 21
+  ((r g b a)    card16))
+
+
+(define-rendering-command color-mask 134
+  (red          bool)
+  (green        bool)
+  (blue         bool)
+  (alpha        bool))
+
+
+(define-rendering-command color-material 78
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command color-table-parameter-fv 2054
+  ;; *** ENUM
+  (target       card32)
+  ;; TODO:
+  ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4
+  ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4
+  ;; else (length params) = 0 (command is erronous)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 4)))
+
+
+(define-rendering-command color-table-parameter-iv 2055
+  ;; *** ENUM
+  (target       card32)
+  ;; TODO:
+  ;; +GL-COLOR-TABLE-SCALE+ (#x80D6) => (length params) = 4
+  ;; +GL-COLOR-TABLE-BIAS+ (#x80d7) => (length params) = 4
+  ;; else (length params) = 0 (command is erronous)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 4)))
+
+
+(define-rendering-command convolution-parameter-f 4103
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       float32))
+
+
+(define-rendering-command convolution-parameter-fv 4104
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+convolution-border-mode+
+                                  #.+convolution-format+
+                                  #.+convolution-width+
+                                  #.+convolution-height+
+                                  #.+max-convolution-width+
+                                  #.+max-convolution-width+)
+                                 1)
+                                ((#.+convolution-filter-scale+
+                                  #.+convolution-filter-bias+)
+                                 4)))))
+
+
+(define-rendering-command convolution-parameter-i 4105
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       int32))
+
+
+(define-rendering-command convolution-parameter-iv 4106
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+convolution-border-mode+
+                                #.+convolution-format+
+                                #.+convolution-width+
+                                #.+convolution-height+
+                                #.+max-convolution-width+
+                                #.+max-convolution-width+)
+                               1)
+                              ((#.+convolution-filter-scale+
+                                #.+convolution-filter-bias+)
+                               4)))))
+
+
+(define-rendering-command copy-color-sub-table 196
+  ;; *** ENUM
+  (target       card32)
+  (start        int32)
+  (x            int32)
+  (y            int32)
+  (width        int32))
+
+
+(define-rendering-command copy-color-table 2056
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (internalformat card32)
+  (x            int32)
+  (y            int32)
+  (width        int32))
+
+
+(define-rendering-command copy-convolution-filter-id 4107
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (internalformat card32)
+  (x            int32)
+  (y            int32)
+  (width        int32))
+
+
+(define-rendering-command copy-convolution-filter-2d 4108
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (internalformat card32)
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (height       int32))
+
+
+(define-rendering-command copy-pixels 172
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (height       int32)
+  ;; *** ENUM
+  (type         card32))
+
+
+(define-rendering-command copy-tex-image-1d 4119
+  ;; *** ENUM
+  (target       card32)
+  (level        int32)
+  ;; *** ENUM
+  (internalformat card32)
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (border       int32))
+
+
+(define-rendering-command copy-tex-image-2d 4120
+  ;; *** ENUM
+  (target       card32)
+  (level        int32)
+  ;; *** ENUM
+  (internalformat card32)
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (height       int32)
+  (border       int32))
+
+
+(define-rendering-command copy-tex-sub-image-1d 4121
+  ;; *** ENUM
+  (target       card32)
+  (level        int32)
+  (xoffset      int32)
+  (x            int32)
+  (y            int32)
+  (width        int32))
+
+
+(define-rendering-command copy-tex-sub-image-2d 4122
+  ;; *** ENUM
+  (target       card32)
+  (level        int32)
+  (xoffset      int32)
+  (yoffset      int32)
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (height       int32))
+
+
+(define-rendering-command copy-tex-sub-image-3d 4123
+  ;; *** ENUM
+  (target       card32)
+  (level        int32)
+  (xoffset      int32)
+  (yoffset      int32)
+  (zoffset      int32)
+  (x            int32)
+  (y            int32)
+  (width        int32)
+  (height       int32))
+
+
+(define-rendering-command cull-face 79
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command depth-func 164
+  ;; *** ENUM
+  (func         card32))
+
+
+(define-rendering-command depth-mask 135
+  (mask         bool))
+
+
+(define-rendering-command depth-range 174
+  (z-near       float64)
+  (z-far        float64))
+
+
+(define-rendering-command draw-buffer 126
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command edge-flag-v 22
+  (flag-0       bool))
+
+
+(define-rendering-command end 23)
+
+
+(define-rendering-command eval-coord-1d 151
+  (u-0          float64))
+
+(define-rendering-command eval-coord-1f 152
+  (u-0          float32))
+
+
+(define-rendering-command eval-coord-2d 153
+  ((u-0 u-1)    float64))
+
+(define-rendering-command eval-coord-2f 154
+  ((u-0 u-1)    float32))
+
+
+(define-rendering-command eval-mesh-1 155
+  ;; *** ENUM
+  (mode         card32)
+  ((i1 i2)      int32))
+
+
+(define-rendering-command eval-mesh-2 157
+  ;; *** ENUM
+  (mode         card32)
+  ((i1 i2 j1 j2) int32))
+
+
+(define-rendering-command eval-point-1 156
+  (i            int32))
+
+
+(define-rendering-command eval-point-2 158
+  (i            int32)
+  (j            int32))
+
+
+(define-rendering-command fog-f 80
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command fog-fv 81
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+fog-index+
+                                  #.+fog-density+
+                                  #.+fog-start+
+                                  #.+fog-end+
+                                  #.+fog-mode+)
+                                 1)
+                                ((#.+fog-color+)
+                                 4)))))
+
+
+
+(define-rendering-command fog-i 82
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command fog-iv 83
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+fog-index+
+                                #.+fog-density+
+                                #.+fog-start+
+                                #.+fog-end+
+                                #.+fog-mode+)
+                               1)
+                              ((#.+fog-color+)
+                               4)))))
+
+
+(define-rendering-command front-face 84
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command frustum 175
+  (left         float64)
+  (right        float64)
+  (bottom       float64)
+  (top          float64)
+  (z-near       float64)
+  (z-far        float64))
+
+
+(define-rendering-command hint 85
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command histogram 4110
+  ;; *** ENUM
+  (target       card32)
+  (width        int32)
+  ;; *** ENUM
+  (internalformat card32)
+  (sink         bool))
+
+
+(define-rendering-command index-mask 136
+  (mask         card32))
+
+
+(define-rendering-command index-d 24
+  (c-0          float64))
+
+(define-rendering-command index-f 25
+  (c-0          float32))
+
+(define-rendering-command index-i 26
+  (c-0          int32))
+
+(define-rendering-command index-s 27
+  (c-0          int16))
+
+(define-rendering-command index-ub 194
+  (c-0          card8))
+
+
+(define-rendering-command init-names 121)
+
+
+(define-rendering-command light-model-f 90
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command light-model-fv 91
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+light-model-color-control+
+                                  #.+light-model-local-viewer+
+                                  #.+light-model-two-side+)
+                                 1)
+                                ((#.+light-model-ambient+)
+                                 4)))))
+
+(define-rendering-command light-model-i 92
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command light-model-iv 93
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+light-model-color-control+
+                                #.+light-model-local-viewer+
+                                #.+light-model-two-side+)
+                               1)
+                              ((#.+light-model-ambient+)
+                               4)))))
+
+
+(define-rendering-command light-f 86
+  ;; *** ENUM
+  (light        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command light-fv 87
+  ;; *** ENUM
+  (light        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+ambient+
+                                  #.+diffuse+
+                                  #.+specular+
+                                  #.+position+)
+                                 4)
+                                ((#.+spot-direction+)
+                                 3)
+                                ((#.+spot-exponent+
+                                  #.+spot-cutoff+
+                                  #.+constant-attenuation+
+                                  #.+linear-attenuation+
+                                  #.+quadratic-attenuation+)
+                                 1)))))
+
+
+(define-rendering-command light-i 88
+  ;; *** ENUM
+  (light        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command light-iv 89
+  ;; *** ENUM
+  (light        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+ambient+
+                                #.+diffuse+
+                                #.+specular+
+                                #.+position+)
+                               4)
+                              ((#.+spot-direction+)
+                               3)
+                              ((#.+spot-exponent+
+                                #.+spot-cutoff+
+                                #.+constant-attenuation+
+                                #.+linear-attenuation+
+                                #.+quadratic-attenuation+)
+                               1)))))
+
+
+(define-rendering-command line-stipple 94
+  (factor       int32)
+  (pattern      card16))
+
+
+(define-rendering-command line-width 95
+  (width        float32))
+
+
+(define-rendering-command list-base 3
+  (base         card32))
+
+
+(define-rendering-command load-identity 176)
+
+
+(define-rendering-command load-matrix-d 178
+  (m            (list float64 16)))
+
+
+(define-rendering-command load-matrix-f 177
+  (m            (list float32 16)))
+
+
+(define-rendering-command load-name 122
+  (name         card32))
+
+
+(define-rendering-command logic-op 161
+  ;; *** ENUM
+  (name         card32))
+
+
+(define-rendering-command map-grid-1d 147
+  (u1           float64)
+  (u2           float64)
+  (un           int32))
+
+(define-rendering-command map-grid-1f 148
+  (un           int32)
+  (u1           float32)
+  (u2           float32))
+
+
+(define-rendering-command map-grid-2d 149
+  (u1           float64)
+  (u2           float64)
+  (v1           float64)
+  (v2           float64)
+  (un           int32)
+  (vn           int32))
+
+
+(define-rendering-command map-grid-2f 150
+  (un           int32)
+  (u1           float32)
+  (u2           float32)
+  (vn           int32)
+  (v1           float32)
+  (v2           float32))
+
+
+(define-rendering-command material-f 96
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command material-fv 97
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+ambient+
+                                  #.+diffuse+
+                                  #.+specular+
+                                  #.+emission+
+                                  #.+ambient-and-diffuse+)
+                                 4)
+                                ((#.+shininess+)
+                                 1)
+                                ((#.+color-index+)
+                                 3)))))
+
+
+(define-rendering-command material-i 98
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command material-iv 99
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+ambient+
+                                #.+diffuse+
+                                #.+specular+
+                                #.+emission+
+                                #.+ambient-and-diffuse+)
+                               4)
+                              ((#.+shininess+)
+                               1)
+                              ((#.+color-index+)
+                               3)))))
+
+
+(define-rendering-command matrix-mode 179
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command minmax 4111
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (internalformat card32)
+  (sink         bool))
+
+
+(define-rendering-command mult-matrix-d 181
+  (m            (list float64 16)))
+
+
+(define-rendering-command mult-matrix-f 180
+  (m            (list float32 16)))
+
+
+;;; *** Note that TARGET is placed last for FLOAT64 versions.
+(define-rendering-command multi-tex-coord-1d-arb 198
+  (v-0          float64)
+  ;; *** ENUM
+  (target       card32))
+
+(define-rendering-command multi-tex-coord-1f-arb 199
+  ;; *** ENUM
+  (target       card32)
+  (v-0          float32))
+
+(define-rendering-command multi-tex-coord-1i-arb 200
+  ;; *** ENUM
+  (target       card32)
+  (v-0          int32))
+
+(define-rendering-command multi-tex-coord-1s-arb 201
+  ;; *** ENUM
+  (target       card32)
+  (v-0          int16))
+
+
+(define-rendering-command multi-tex-coord-2d-arb 202
+  ((v-0 v-1)    float64)
+  ;; *** ENUM
+  (target       card32))
+
+(define-rendering-command multi-tex-coord-2f-arb 203
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1)    float32))
+
+(define-rendering-command multi-tex-coord-2i-arb 204
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1)    int32))
+
+(define-rendering-command multi-tex-coord-2s-arb 205
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1)    int16))
+
+
+(define-rendering-command multi-tex-coord-3d-arb 206
+  ((v-0 v-1 v-2) float64)
+  ;; *** ENUM
+  (target       card32))
+
+(define-rendering-command multi-tex-coord-3f-arb 207
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2) float32))
+
+(define-rendering-command multi-tex-coord-3i-arb 208
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2) int32))
+
+(define-rendering-command multi-tex-coord-3s-arb 209
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2) int16))
+
+
+(define-rendering-command multi-tex-coord-4d-arb 210
+  ((v-0 v-1 v-2 v-3) float64)
+  ;; *** ENUM
+  (target       card32))
+
+(define-rendering-command multi-tex-coord-4f-arb 211
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2 v-3) float32))
+
+(define-rendering-command multi-tex-coord-4i-arb 212
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2 v-3) int32))
+
+(define-rendering-command multi-tex-coord-4s-arb 213
+  ;; *** ENUM
+  (target       card32)
+  ((v-0 v-1 v-2 v-3) int16))
+
+
+(define-rendering-command normal-3b 28
+  ((v-0 v-1 v-2) int8))
+
+(define-rendering-command normal-3d 29
+  ((v-0 v-1 v-2) float64))
+
+(define-rendering-command normal-3f 30
+  ((v-0 v-1 v-2) float32))
+
+(define-rendering-command normal-3i 31
+  ((v-0 v-1 v-2) int32))
+
+(define-rendering-command normal-3s 32
+  ((v-0 v-1 v-2) int16))
+
+
+(define-rendering-command ortho 182
+  (left         float64)
+  (right        float64)
+  (bottom       float64)
+  (top          float64)
+  (z-near       float64)
+  (z-far        float64))
+
+
+(define-rendering-command pass-through 123
+  (token        float32))
+
+
+(define-rendering-command pixel-transfer-f 166
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command pixel-transfer-i 167
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command pixel-zoom 165
+  (xfactor      float32)
+  (yfactor      float32))
+
+
+(define-rendering-command point-size 100
+  (size         float32))
+
+
+(define-rendering-command polygon-mode 101
+  ;; *** ENUM
+  (face         card32)
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command polygon-offset 192
+  (factor       float32)
+  (units        float32))
+
+
+(define-rendering-command pop-attrib 141)
+
+
+(define-rendering-command pop-matrix 183)
+
+
+(define-rendering-command pop-name 124)
+
+
+(define-rendering-command prioritize-textures 4118
+  (n            int32)
+  (textures     (list card32 n))
+  (priorities   (list float32 n)))
+
+
+(define-rendering-command push-attrib 142
+  ;; *** BITFIELD
+  (mask         card32))
+
+
+(define-rendering-command push-matrix 184)
+
+
+(define-rendering-command push-name 125
+  (name         card32))
+
+
+(define-rendering-command raster-pos-2d 33
+  ((v-0 v-1)    float64))
+
+(define-rendering-command raster-pos-2f 34
+  ((v-0 v-1)    float32))
+
+(define-rendering-command raster-pos-2i 35
+  ((v-0 v-1)    int32))
+
+(define-rendering-command raster-pos-2s 36
+  ((v-0 v-1)    int16))
+
+
+(define-rendering-command raster-pos-3d 37
+  ((v-0 v-1 v-2) float64))
+
+(define-rendering-command raster-pos-3f 38
+  ((v-0 v-1 v-2) float32))
+
+(define-rendering-command raster-pos-3i 39
+  ((v-0 v-1 v-2) int32))
+
+(define-rendering-command raster-pos-3s 40
+  ((v-0 v-1 v-2) int16))
+
+
+(define-rendering-command raster-pos-4d 41
+  ((v-0 v-1 v-2 v-3) float64))
+
+(define-rendering-command raster-pos-4f 42
+  ((v-0 v-1 v-2 v-3) float32))
+
+(define-rendering-command raster-pos-4i 43
+  ((v-0 v-1 v-2 v-3) int32))
+
+(define-rendering-command raster-pos-4s 44
+  ((v-0 v-1 v-2 v-3) int16))
+
+
+(define-rendering-command read-buffer 171
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command rect-d 45
+  ((v1-0 v1-1 v2-0 v2-1) float64))
+
+(define-rendering-command rect-f 46
+  ((v1-0 v1-1 v2-0 v2-1) float32))
+
+(define-rendering-command rect-i 47
+  ((v1-0 v1-1 v2-0 v2-1) int32))
+
+(define-rendering-command rect-s 48
+  ((v1-0 v1-1 v2-0 v2-1) int16))
+
+
+(define-rendering-command reset-histogram 4112
+  ;; *** ENUM
+  (target       card32))
+
+
+(define-rendering-command reset-minmax 4113
+  ;; *** ENUM
+  (target       card32))
+
+
+(define-rendering-command rotate-d 185
+  ((angle x y z) float64))
+
+
+(define-rendering-command rotate-f 186
+  ((angle x y z) float32))
+
+
+(define-rendering-command scale-d 187
+  ((x y z)      float64))
+
+
+(define-rendering-command scale-f 188
+  ((x y z)      float32))
+
+
+(define-rendering-command scissor 103
+  ((x y width height) int32))
+
+
+(define-rendering-command shade-model 104
+  ;; *** ENUM
+  (mode         card32))
+
+
+(define-rendering-command stencil-func 162
+  ;; *** ENUM
+  (func         card32)
+  (ref          int32)
+  (mask         card32))
+
+
+(define-rendering-command stencil-mask 133
+  (mask         card32))
+
+
+(define-rendering-command stencil-op 163
+  ;; *** ENUM
+  (fail         card32)
+  ;; *** ENUM
+  (zfail        card32)
+  ;; *** ENUM
+  (zpass        card32))
+
+
+(define-rendering-command tex-env-f 111
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command tex-env-fv 112
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        (list float32 (ecase pname
+                                (#.+texture-env-mode+ 1)
+                                (#.+texture-env-color+ 4)))))
+
+
+(define-rendering-command tex-env-i 113
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command tex-env-iv 114
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        (list int32 (ecase pname
+                              (#.+texture-env-mode+ 1)
+                              (#.+texture-env-color+ 4)))))
+
+
+;;; *** 
+;;; last there.
+(define-rendering-command tex-gen-d 115
+  (param        float64)
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32))
+
+
+(define-rendering-command tex-gen-dv 116
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32)
+  ;; +texture-gen-mode+ n=1
+  ;; +object-plane+     n=4
+  ;; +eye-plane+        n=1
+  (params       (list float64 (ecase pname
+                                ((#.+texture-gen-mode+ #.+eye-plane+) 1)
+                                (#.+object-plane+ 4)))))
+
+
+(define-rendering-command tex-gen-f 117
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command tex-gen-fv 118
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+texture-gen-mode+ #.+eye-plane+) 1)
+                                (#.+object-plane+ 4)))))
+
+
+(define-rendering-command tex-gen-i 119
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command tex-gen-iv 120
+  ;; *** ENUM
+  (coord        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+texture-gen-mode+ #.+eye-plane+) 1)
+                              (#.+object-plane+ 4)))))
+
+
+(define-rendering-command tex-parameter-f 105
+  ;; *** ENUM
+  (target        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        float32))
+
+
+(define-rendering-command tex-parameter-fv 106
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list float32 (ecase pname
+                                ((#.+texture-border-color+)
+                                 4)
+                                ((#.+texture-mag-filter+
+                                  #.+texture-min-filter+
+                                  #.+texture-wrap-s+
+                                  #.+texture-wrap-t+)
+                                 1)))))
+
+
+(define-rendering-command tex-parameter-i 107
+  ;; *** ENUM
+  (target        card32)
+  ;; *** ENUM
+  (pname        card32)
+  (param        int32))
+
+
+(define-rendering-command tex-parameter-iv 108
+  ;; *** ENUM
+  (target       card32)
+  ;; *** ENUM
+  (pname        card32)
+  (params       (list int32 (ecase pname
+                              ((#.+texture-border-color+)
+                               4)
+                              ((#.+texture-mag-filter+
+                                #.+texture-min-filter+
+                                #.+texture-wrap-s+
+                                #.+texture-wrap-t+)
+                               1)))))
+
+
+(define-rendering-command translate-d 189
+  ((x y z)      float64))
+
+(define-rendering-command translate-f 190
+  ((x y z)      float32))
+
+
+(define-rendering-command vertex-2d 65
+  ((x y)        float64))
+
+(define-rendering-command vertex-2f 66
+  ((x y)        float32))
+
+(define-rendering-command vertex-2i 67
+  ((x y)        int32))
+
+(define-rendering-command vertex-2s 68
+  ((x y)        int16))
+
+
+(define-rendering-command vertex-3d 69
+  ((x y z)      float64))
+
+(define-rendering-command vertex-3f 70
+  ((x y z)      float32))
+
+(define-rendering-command vertex-3i 71
+  ((x y z)      int32))
+
+(define-rendering-command vertex-3s 72
+  ((x y z)      int16))
+
+
+(define-rendering-command vertex-4d 73
+  ((x y z w)    float64))
+
+(define-rendering-command vertex-4f 74
+  ((x y z w)    float32))
+
+(define-rendering-command vertex-4i 75
+  ((x y z w)    int32))
+
+(define-rendering-command vertex-4s 76
+  ((x y z w)    int16))
+
+
+(define-rendering-command viewport 191
+  ((x y width height) int32))
+
+
+;;; Potentially lerge rendering commands.
+
+
+#-(and)
+(define-large-rendering-command call-lists 2
+  (n            int32)
+  ;; *** ENUM
+  (type         card32)
+  (lists        (list type n)))
+
+
+
+;;; Requests for GL non-rendering commands.
+
+(defun new-list (list mode)
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +new-list+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx))
+      (card32 list)
+      ;; *** ENUM
+      (card32 mode))))
+
+
+(defun gen-lists (range)
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +gen-lists+)
+         ;; *** GLX_CONTEXT_TAG
+         (card32 (context-tag ctx))
+         (integer range))
+      (card32-get 8))))
+
+
+(defun end-list ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +end-list+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx)))))
+
+
+(defun enable (cap)
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +enable+)
+         ;; *** GLX_CONTEXT_TAG
+         (card32 (context-tag ctx))
+         ;; *** ENUM?
+         (card32 cap)))))
+
+
+;;; FIXME: FLUSH and FINISH should send *all* buffered data, including
+;;; buffered rendering commands.
+(defun flush ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +flush+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx)))))
+
+
+(defun finish ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +finish+)
+         ;; *** GLX_CONTEXT_TAG
+         (card32 (context-tag ctx))))))
diff --git a/clx/glx.lisp b/clx/glx.lisp
new file mode 100644
index 000000000..9903d68c3
--- /dev/null
+++ b/clx/glx.lisp
@@ -0,0 +1,635 @@
+#+cmu
+(ext:file-comment "$Id: glx.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+
+(defpackage :glx
+  (:use :common-lisp :xlib)
+  (:import-from :xlib
+                "DEFINE-ACCESSOR"
+                "DEF-CLX-CLASS"
+                "DECLARE-EVENT"
+                "ALLOCATE-RESOURCE-ID"
+                "DEALLOCATE-RESOURCE-ID"
+                "PRINT-DISPLAY-NAME"
+                "WITH-BUFFER-REQUEST"
+                "WITH-BUFFER-REQUEST-AND-REPLY"
+                "READ-CARD32"
+                "WRITE-CARD32"
+                "CARD32-GET"
+                "CARD8-GET"
+                "SEQUENCE-GET"
+                "SEQUENCE-PUT"
+                "DATA"
+
+                ;; Types
+                "ARRAY-INDEX"
+                "BUFFER-BYTES"
+
+                "WITH-DISPLAY"
+                "BUFFER-FLUSH"
+                "BUFFER-WRITE"
+                "BUFFER-FORCE-OUTPUT"
+                "ASET-CARD8"
+                "ASET-CARD16"
+                "ASET-CARD32"
+                )
+  (:export ;; Constants
+           "+VENDOR+"
+           "+VERSION+"
+           "+EXTENSIONS+"
+
+           ;; Conditions
+           "BAD-CONTEXT"
+           "BAD-CONTEXT-STATE"
+           "BAD-DRAWABLE"
+           "BAD-PIXMAP"
+           "BAD-CONTEXT-TAG"
+           "BAD-CURRENT-WINDOW"
+           "BAD-RENDER-REQUEST"
+           "BAD-LARGE-REQUEST"
+           "UNSUPPORTED-PRIVATE-REQUEST"
+           "BAD-FB-CONFIG"
+           "BAD-PBUFFER"
+           "BAD-CURRENT-DRAWABLE"
+           "BAD-WINDOW"
+
+           ;; Requests
+           "QUERY-VERSION"
+           "QUERY-SERVER-STRING"
+           "CREATE-CONTEXT"
+           "DESTROY-CONTEXT"
+           "IS-DIRECT"
+           "QUERY-CONTEXT"
+           "GET-DRAWABLE-ATTRIBUTES"
+           "MAKE-CURRENT"
+           ;;"GET-VISUAL-CONFIGS"
+           "CHOOSE-VISUAL"
+           "VISUAL-ATTRIBUTE"
+           "VISUAL-ID"
+           "RENDER"
+           "SWAP-BUFFERS"
+           "WAIT-GL"
+           "WAIT-X"
+           ))
+
+
+(in-package :glx)
+
+
+(declaim (optimize (debug 3) (safety 3)))
+
+
+(define-extension "GLX"
+    :events (:glx-pbuffer-clobber)
+    :errors (bad-context
+             bad-context-state
+             bad-drawable
+             bad-pixmap
+             bad-context-tag
+             bad-current-window
+             bad-render-request
+             bad-large-request
+             unsupported-private-request
+             bad-fb-config
+             bad-pbuffer
+             bad-current-drawable
+             bad-window))
+
+
+;;; Opcodes.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant +render+ 1)
+(defconstant +create-context+ 3)
+(defconstant +destroy-context+ 4)
+(defconstant +make-current+ 5)
+(defconstant +is-direct+ 6)
+(defconstant +query-version+ 7)
+(defconstant +wait-gl+ 8)
+(defconstant +wait-x+ 9)
+(defconstant +copy-context+ 10)
+(defconstant +swap-buffers+ 11)
+(defconstant +get-visual-configs+ 14)
+(defconstant +destroy-glx-pixmap+ 15)
+(defconstant +query-server-string+ 19)
+(defconstant +client-info+ 20)
+(defconstant +get-fb-configs+ 21)
+(defconstant +query-context+ 25)
+(defconstant +get-drawable-attributes+ 29)
+)
+
+
+;;; Constants
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant +vendor+ 1)
+(defconstant +version+ 2)
+(defconstant +extensions+ 3)
+)
+
+
+;;; Types
+
+;;; FIXME:
+;;; - Are all the 32-bit values unsigned?  Do we care?
+;;; - These are not used much, yet.
+(progn
+  (deftype attribute-pair ())
+  (deftype bitfield () 'mask32)
+  (deftype bool32 () 'card32)           ; 1 for true and 0 for false 
+  (deftype enum () 'card32)
+  (deftype fbconfigid () 'card32)
+  ;; FIXME: How to define these two?
+  (deftype float32 () 'single-float)
+  (deftype float64 () 'double-float)
+  ;;(deftype glx-context () 'card32)
+  (deftype context-tag () 'card32)
+  ;;(deftype glx-drawable () 'card32)
+  (deftype glx-pixmap () 'card32)
+  (deftype glx-pbuffer () 'card32)
+  (deftype glx-render-command () #|TODO|#)
+  (deftype glx-window () 'card32)
+  #-(and)
+  (deftype visual-property ()
+    "An ordered list of 32-bit property values followed by unordered pairs of
+property types and property values."
+    ;; FIXME: maybe CLX-LIST or even just LIST?
+    'clx-sequence))
+
+
+;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package
+;;; (using XINTERN).  Therefore the accessors defined below can only
+;;; be accessed using double-colon, which is a bad style.  Or these
+;;; forms must be taken to another file so the accessors exist before
+;;; we get to this file.
+
+#-(and)
+(define-accessor glx-context-tag (32)
+  ((index) `(read-card32 ,index))
+  ((index thing) `(write-card32 ,index ,thing)))
+
+#-(and)
+(define-accessor glx-enum (32)
+  ((index) `(read-card32 ,index))
+  ((index thing) `(write-card32 ,index ,thing)))
+
+
+;;; FIXME: I'm just not sure we need a seperate accessors for what
+;;; essentially are aliases for other types.  Maybe use compiler
+;;; macros?
+;;;
+;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a
+;;; known accessor.  The only trick left I think is to change the
+;;; XINTERN function to intern the new symbols in the same package as
+;;; he symbol part of it comes from.  Don't know if it would break
+;;; anything, thought.  (I would be quite surprised if it did -- there
+;;; is only one package in CLX after all: XLIB.)
+;;;
+;;; I also found the origin of the error (about symbol not being a
+;;; known accessor): INDEX-INCREMENT function.  Looks like all we have
+;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol
+;;; plist.  But accessors are macros, not functions, anyway.
+
+#-(and)
+(progn
+  (declaim (inline context-tag-get context-tag-put enum-get enum-put))
+  (defun context-tag-get (index) (card32-get index))
+  (defun context-tag-put (index thing) (card32-put index thing))
+  (defun enum-get (index) (card32-get index))
+  (defun enum-put (index thing) (card32-put index thing))
+)
+
+
+;;; Structures
+
+
+(def-clx-class (context (:constructor %make-context)
+                        (:print-function print-context)
+                        (:copier nil))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (tag 0 :type card32)
+  (drawable nil :type (or null drawable))
+  ;; TODO: There can only be one current context (as far as I
+  ;; understand).  If so, we'd need only one buffer (otherwise it's a
+  ;; big waste to have a quarter megabyte buffer for each context; or
+  ;; we could allocate/grow the buffer on demand).
+  ;;
+  ;; 256k buffer for Render command.  Big requests are served with
+  ;; RenderLarge command.  First 8 octets are Render request fields.
+  ;;
+  (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes)
+  ;; Index into RBUF where the next rendering command should be inserted.
+  (index 8 :type array-index))
+
+
+(defun print-context (ctx stream depth)
+  (declare (type context ctx)
+           (ignore depth))
+  (print-unreadable-object (ctx stream :type t)
+    (print-display-name (context-display ctx) stream)
+    (write-string " " stream)
+    (princ (context-id ctx) stream)))
+
+
+(def-clx-class (visual (:constructor %make-visual)
+                       (:print-function print-visual)
+                       (:copier nil))
+  (id 0 :type resource-id)
+  (attributes nil :type list))
+
+
+(defun print-visual (visual stream depth)
+  (declare (type visual visual)
+           (ignore depth))
+  (print-unreadable-object (visual stream :type t)
+    (write-string "ID: " stream)
+    (princ (visual-id visual) stream)
+    (write-string " " stream)
+    (princ (visual-attributes visual) stream)))
+
+
+
+;;; Events.
+
+(defconstant +damaged+ #x8017)
+(defconstant +saved+ #x8018)
+(defconstant +window+ #x8019)
+(defconstant +pbuffer+ #x801a)
+
+
+(declare-event :glx-pbuffer-clobber
+  (card16 sequence)
+  (card16 event-type) ;; +DAMAGED+ or +SAVED+
+  (card16 draw-type) ;; +WINDOW+ or +PBUFFER+
+  (resource-id drawable)
+  ;; FIXME: (bitfield buffer-mask)
+  (card32 buffer-mask)
+  (card16 aux-buffer)
+  (card16 x y width height count))
+
+
+
+;;; Errors.
+
+(define-condition bad-context (request-error) ())
+(define-condition bad-context-state (request-error) ())
+(define-condition bad-drawable (request-error) ())
+(define-condition bad-pixmap (request-error) ())
+(define-condition bad-context-tag (request-error) ())
+(define-condition bad-current-window (request-error) ())
+(define-condition bad-render-request (request-error) ())
+(define-condition bad-large-request (request-error) ())
+(define-condition unsupported-private-request (request-error) ())
+(define-condition bad-fb-config (request-error) ())
+(define-condition bad-pbuffer (request-error) ())
+(define-condition bad-current-drawable (request-error) ())
+(define-condition bad-window (request-error) ())
+
+(define-error bad-context decode-core-error)
+(define-error bad-context-state decode-core-error)
+(define-error bad-drawable decode-core-error)
+(define-error bad-pixmap decode-core-error)
+(define-error bad-context-tag decode-core-error)
+(define-error bad-current-window decode-core-error)
+(define-error bad-render-request decode-core-error)
+(define-error bad-large-request decode-core-error)
+(define-error unsupported-private-request decode-core-error)
+(define-error bad-fb-config decode-core-error)
+(define-error bad-pbuffer decode-core-error)
+(define-error bad-current-drawable decode-core-error)
+(define-error bad-window decode-core-error)
+
+
+
+;;; Requests.
+
+
+(defun query-version (display)
+  (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+    ((data +query-version+)
+     (card32 1)
+     (card32 3))
+    (values
+     (card32-get 8)
+     (card32-get 12))))
+
+
+(defun query-server-string (display screen name)
+  "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+"
+  (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+    ((data +query-server-string+)
+     (card32 (or (position screen (display-roots display) :test #'eq) 0))
+     (card32 name))
+    (let* ((length (card32-get 12))
+           (bytes (sequence-get :format card8
+                                :result-type '(simple-array card8 (*))
+                                :index 32
+                                :length length)))
+      (declare (type (simple-array card8 (*)) bytes)
+               (type fixnum length))
+      (map-into (make-string (1- length)) #'code-char bytes))))
+
+
+(defun client-info (display)
+  ;; TODO: This should be invoked automatically when using this
+  ;; library in initialization stage.
+  ;; 
+  ;; TODO: No extensions supported yet.
+  ;; 
+  ;; *** Maybe the LENGTH field must be filled in some special way
+  ;;     (similar to data)?
+  (with-buffer-request (display (extension-opcode display "GLX"))
+    (data +client-info+)
+    (card32 4) ; length of the request
+    (card32 1) ; major
+    (card32 3) ; minor
+    (card32 0) ; n
+    ))
+
+
+;;; XXX: This looks like an internal thing.  Should name appropriately.
+(defun make-context (display)
+  (let ((ctx (%make-context :display display)))
+    (setf (context-id ctx)
+          (allocate-resource-id display ctx 'context))
+    ;; Prepare render request buffer.
+    ctx))
+
+
+(defun create-context (screen visual
+                       &optional
+                       (share-list 0)
+                       (is-direct nil))
+  "Do NOT use the direct mode, yet!"
+  (let* ((root (screen-root screen))
+         (display (drawable-display root))
+         (ctx (make-context display)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +create-context+)
+      (resource-id (context-id ctx))
+      (resource-id visual)
+      (card32 (or (position screen (display-roots display) :test #'eq) 0))
+      (resource-id share-list)
+      (boolean is-direct))
+    ctx))
+
+
+;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only?
+;;;
+(defvar *current-context* nil)
+
+
+(defun destroy-context (ctx)
+  (let ((id (context-id ctx))
+        (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +destroy-context+)
+      (resource-id id))
+    (deallocate-resource-id display id 'context)
+    (setf (context-id ctx) 0)
+    (when (eq ctx *current-context*)
+      (setf *current-context* nil))))
+
+
+(defun is-direct (ctx)
+  (let ((display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +is-direct+)
+         (resource-id (context-id ctx)))
+      (card8-get 8))))
+
+
+(defun query-context (ctx)
+  ;; TODO: What are the attribute types?
+  (let ((display (context-display ctx)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +query-context+)
+         (resource-id (context-id ctx)))
+      (let ((num-attributes (card32-get 8)))
+        ;; FIXME: Is this really so?
+        (declare (type fixnum num-attributes))
+        (loop
+           repeat num-attributes
+           for i fixnum upfrom 32 by 8
+           collecting (cons (card32-get i)
+                            (card32-get (+ i 4))))))))
+
+
+(defun get-drawable-attributes (drawable)
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +get-drawable-attributes+)
+         (drawable drawable))
+      (let ((num-attributes (card32-get 8)))
+        ;; FIXME: Is this really so?
+        (declare (type fixnum num-attributes))
+        (loop
+           repeat num-attributes
+           for i fixnum upfrom 32 by 8
+           collecting (cons (card32-get i)
+                            (card32-get (+ i 4))))))))
+
+
+;;; TODO: What is the idea behind passing drawable to this function?
+;;; Can a context be made current for different drawables at different
+;;; times?  (Man page on glXMakeCurrent says that context's viewport
+;;; is set to the size of drawable when creating; it does not change
+;;; afterwards.)
+;;; 
+(defun make-current (drawable ctx)
+  (let ((display (drawable-display drawable))
+        (old-tag (if *current-context* (context-tag *current-context*) 0)))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+        ((data +make-current+)
+         (resource-id (drawable-id drawable))
+         (resource-id (context-id ctx))
+         ;; *** CARD32 is really a CONTEXT-TAG
+         (card32 old-tag))
+      (let ((new-tag (card32-get 8)))
+        (setf (context-tag ctx) new-tag
+              (context-drawable ctx) drawable
+              (context-display ctx) display
+              *current-context* ctx)))))
+
+
+;;; FIXME: Decide how to represent and use these.
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (macrolet ((generate-config-properties ()
+               (let ((list '((:glx-visual visual-id)
+                             (:glx-class card32)
+                             (:glx-rgba bool32)
+                             (:glx-red-size card32)
+                             (:glx-green-size card32)
+                             (:glx-blue-size card32)
+                             (:glx-alpha-size card32)
+                             (:glx-accum-red-size card32)
+                             (:glx-accum-green-size card32)
+                             (:glx-accum-blue-size card32)
+                             (:glx-accum-alpha-size card32)
+                             (:glx-double-buffer bool32)
+                             (:glx-stereo bool32)
+                             (:glx-buffer-size card32)
+                             (:glx-depth-size card32)
+                             (:glx-stencil-size card32)
+                             (:glx-aux-buffers card32)
+                             (:glx-level int32))))
+                 `(progn
+                    ,@(loop for (symbol type) in list
+                         collect `(setf (get ',symbol 'visual-config-property-type) ',type))
+                    (defparameter *visual-config-properties*
+                      (map 'vector #'car ',list))
+                    (declaim (type simple-vector *visual-config-properties*))
+                    (deftype visual-config-property ()
+                      '(member ,@(mapcar #'car list)))))))
+    (generate-config-properties)))
+
+
+(defun make-visual (attributes)
+  (let ((id-cons (first attributes)))
+    (assert (eq :glx-visual (car id-cons))
+            (id-cons)
+            "GLX visual id must be first in attributes list!")
+    (%make-visual :id (cdr id-cons)
+                  :attributes (rest attributes))))
+
+
+(defun visual-attribute (visual attribute)
+  (assert (or (numberp attribute)
+              (find attribute *visual-config-properties*))
+          (attribute)
+          "~S is not a known GLX visual attribute." attribute)
+  (cdr (assoc attribute (visual-attributes visual))))
+
+
+;;; TODO: Make this return nice structured objects with field values of correct type.
+;;; FIXME: Looks like every other result is corrupted.
+(defun get-visual-configs (screen)
+  (let ((display (drawable-display (screen-root screen))))
+    (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
+      ((data +get-visual-configs+)
+       (card32 (or (position screen (display-roots display) :test #'eq) 0)))
+      (let* ((num-visuals (card32-get 8))
+             (num-properties (card32-get 12))
+             (num-ordered (length *visual-config-properties*)))
+        ;; FIXME: Is this really so?
+        (declare (type fixnum num-ordered num-visuals num-properties))
+        (loop
+           with index fixnum = 28
+           repeat num-visuals
+           collecting (make-visual
+                       (nconc (when (<= num-ordered num-properties)
+                                (map 'list #'(lambda (property)
+                                               (cons property (card32-get (incf index 4))))
+                                     *visual-config-properties*))
+                              (when (< num-ordered num-properties)
+                                (loop repeat (/ (- num-properties num-ordered) 2)
+                                   collecting (cons (card32-get (incf index 4))
+                                                    (card32-get (incf index 4))))))))))))
+
+
+(defun choose-visual (screen attributes)
+  "ATTRIBUTES is a list of desired attributes for a visual.  The elements may be
+either a symbol, which means that the boolean attribute with that name must be true; or
+it can be a list of the form: (attribute-name value &optional (test '<=)) which means that
+the attribute named attribute-name must satisfy the test when applied to the given value and
+attribute's value in visual.
+Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)."
+  ;; TODO: Add type checks
+  ;;
+  ;; TODO: This function checks only supplied attributes; should check
+  ;; all attributes, with default for boolean type being false, and
+  ;; for number types zero.
+  ;; 
+  ;; TODO: Make this smarter, like the docstring says, instead of
+  ;; parrotting the inflexible C API.
+  ;; 
+  (flet ((visual-matches-p (visual attributes)
+           (dolist (attribute attributes t)
+             (etypecase attribute
+               (symbol (not (null (visual-attribute visual attribute))))
+               (cons (<= (second attribute) (visual-attribute visual (car attribute))))))))
+    (let* ((visuals (get-visual-configs screen))
+           (candidates (loop
+                          for visual in visuals
+                          when (visual-matches-p visual attributes)
+                          collect visual))
+           (result (first candidates)))
+    
+      (dolist (candidate (rest candidates))
+        ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color)
+        ;; are preferred over glx-class 2 (static-color) and 5 (direct-color).
+        (let ((class (visual-attribute candidate :glx-class)))
+          (when (or (= class 3)
+                    (= class 4))
+            (setf result candidate))))
+      result)))
+
+
+(defun render ()
+  (declare (optimize (debug 3)))
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx))
+         (rbuf (context-rbuf ctx))
+         (index (context-index ctx)))
+    (declare (type buffer-bytes rbuf)
+             (type array-index index))
+    (when (< 8 index)
+      (with-display (display)
+        ;; Flush display's buffer first so we don't get messed up with X requests.
+        (buffer-flush display)
+        ;; First, update the Render request fields.
+        (aset-card8 (extension-opcode display "GLX") rbuf 0)
+        (aset-card8 1 rbuf 1)
+        (aset-card16 (ceiling index 4) rbuf 2)
+        (aset-card32 (context-tag ctx) rbuf 4)
+        ;; Then send the request.
+        (buffer-write rbuf display 0 (context-index ctx))
+        ;; Start filling from the beginning
+        (setf (context-index ctx) 8)))
+    (values)))
+
+
+(defun swap-buffers ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    ;; Make sure all rendering commands are sent away.
+    (glx:render)
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +swap-buffers+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx))
+      (resource-id (drawable-id (context-drawable ctx))))
+    (display-force-output display)))
+
+
+;;; FIXME: These two are more complicated than sending messages.  As I
+;;; understand it, wait-gl should inhibit any X requests until all GL
+;;; requests are sent...
+(defun wait-gl ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +wait-gl+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx)))))
+
+
+(defun wait-x ()
+  (assert (context-p *current-context*)
+          (*current-context*)
+          "~S is not a context." *current-context*)
+  (let* ((ctx *current-context*)
+         (display (context-display ctx)))
+    (with-buffer-request (display (extension-opcode display "GLX"))
+      (data +wait-x+)
+      ;; *** GLX_CONTEXT_TAG
+      (card32 (context-tag ctx)))))
diff --git a/clx/graphics.lisp b/clx/graphics.lisp
index 1acb7afeb..53f09fc74 100644
--- a/clx/graphics.lisp
+++ b/clx/graphics.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/graphics.lisp,v 1.5 1998/12/19 15:21:17 dtc Exp $")
+(ext:file-comment "$Id: graphics.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -34,14 +34,14 @@
     (declare (type display display))
     (with-display (display)
       (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
+      (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*)
+		   (= (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?
@@ -64,7 +64,7 @@
 	    ;; New Request
 	    (progn
 	      (put-items (4)
-		(code *x-polypoint*)
+		(code +x-polypoint+)
 		(data 0) ;; Relative-p false
 		(length 4)
 		(drawable drawable)
@@ -81,7 +81,7 @@
 	   (type gcontext gcontext)
 	   (type sequence points)		;(repeat-seq (integer x) (integer y))
 	   (type generalized-boolean relative-p))
-  (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
+  (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext)
     ((data boolean) relative-p)
     (drawable drawable)
     (gcontext gcontext)
@@ -100,14 +100,14 @@
       (incf y2 y1))
     (with-display (display)
       (force-gcontext-changes-internal gcontext)
-      (with-buffer-output (display :length *requestsize*)
+      (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*)
+		   (= (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?
@@ -129,7 +129,7 @@
 	    ;; New Request
 	    (progn
 	      (put-items (4)
-		(code *x-polysegment*)
+		(code +x-polysegment+)
 		(length 5)
 		(drawable drawable)
 		(gcontext gcontext)
@@ -147,7 +147,7 @@
 	   (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)
+    (with-buffer-request ((drawable-display drawable)  +x-polyline+ :gc-force gcontext)
       ((data boolean) relative-p)
       (drawable drawable)
       (gcontext gcontext)
@@ -161,7 +161,7 @@
 	   (type sequence points)		;(repeat-seq (integer x) (integer y))
 	   (type generalized-boolean relative-p)
 	   (type (member :complex :non-convex :convex) shape))
-  (with-buffer-request ((drawable-display drawable)  *x-fillpoly* :gc-force gcontext)
+  (with-buffer-request ((drawable-display drawable)  +x-fillpoly+ :gc-force gcontext)
     (drawable drawable)
     (gcontext gcontext)
     ((member8 :complex :non-convex :convex) shape)
@@ -173,7 +173,7 @@
 	   (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)
+  (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext)
     (drawable drawable)
     (gcontext gcontext)
     ((sequence :format int16) segments)))
@@ -186,12 +186,12 @@
 	   (type card16 width height)
 	   (type generalized-boolean fill-p))
   (let ((display (drawable-display drawable))
-	(request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
+	(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*)
+      (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
@@ -239,7 +239,7 @@
 	   (type sequence rectangles)
 	   (type generalized-boolean fill-p))
   (with-buffer-request ((drawable-display drawable)
-			(if fill-p *x-polyfillrectangle* *x-polyrectangle*)
+			(if fill-p +x-polyfillrectangle+ +x-polyrectangle+)
 			:gc-force gcontext)
     (drawable drawable)
     (gcontext gcontext)
@@ -254,12 +254,12 @@
 	   (type angle angle1 angle2)
 	   (type generalized-boolean fill-p))
   (let ((display (drawable-display drawable))
-	(request (if fill-p *x-polyfillarc* *x-polyarc*)))
+	(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*)
+      (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
@@ -310,7 +310,7 @@
   (let* ((display (drawable-display drawable))
 	 (limit (index- (buffer-size display) 12))
 	 (length (length arcs))
-	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
+	 (request (if fill-p +x-polyfillarc+ +x-polyarc+)))
     (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
       (drawable drawable)
       (gcontext gcontext)
@@ -341,7 +341,7 @@
   (let* ((display (drawable-display drawable))
 	 (limit (index- (buffer-size display) 12))
 	 (length (length arcs))
-	 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
+	 (request (if fill-p +x-polyfillarc+ +x-polyarc+)))
     (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
       (drawable drawable)
       (gcontext gcontext)
@@ -400,7 +400,7 @@
 	   (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)
+  (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext)
     ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
     (drawable drawable)
     (gcontext gcontext)
@@ -434,7 +434,7 @@
 	   (type (member :xy-pixmap :z-pixmap) format))
   (declare (clx-values (clx-sequence integer) depth visual-info))
   (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
+    (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)
@@ -445,6 +445,6 @@
 	    (visual (resource-id-get 8)))
 	(values (sequence-get :result-type result-type :format card8
 			      :length length :start start :data data
-			      :index *replysize*)
+			      :index +replysize+)
 		depth
 		(visual-info display visual))))))
diff --git a/clx/image.lisp b/clx/image.lisp
index 920ee9c81..8eb47af33 100644
--- a/clx/image.lisp
+++ b/clx/image.lisp
@@ -17,9 +17,6 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/image.lisp,v 1.10 2003/06/05 14:56:59 emarsden Exp $")
 
 (in-package :xlib)
 
@@ -62,10 +59,10 @@
     (write-string "x" stream)
     (prin1 (image-depth image) stream)))
 
-(defconstant *empty-data-x* '#.(make-sequence '(array card8 (*)) 0))
+(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0))
 
-(defconstant *empty-data-z*
-	     '#.(make-array '(0 0) :element-type 'pixarray-1-element-type))
+(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))
@@ -74,11 +71,11 @@
   (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 generalized-boolean)	; Bit order
-  (byte-lsb-first-p *image-byte-lsb-first-p* :type generalized-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
+  (bit-lsb-first-p +image-bit-lsb-first-p+ :type generalized-boolean)	; Bit order
+  (byte-lsb-first-p +image-byte-lsb-first-p+ :type generalized-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)
@@ -92,7 +89,7 @@
   ;; 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))
+  (pixarray +empty-data-z+ :type pixarray))
 
 (defun create-image (&key width height depth
 		     (data (required-arg data))
@@ -155,11 +152,11 @@
 		    (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 unit (setq unit +image-unit+))
 		(unless pad
 		  (setq pad
 			(dolist (pad '(32 16 8))
-			  (when (and (index<= pad *image-pad*)
+			  (when (and (index<= pad +image-pad+)
 				     (zerop
 				       (index-mod
 					 (index* bytes-per-line 8) pad)))
@@ -468,27 +465,26 @@
 			    (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)))
+(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)
@@ -500,7 +496,7 @@
   #.(declare-buffun)
   (with-vector (src buffer-bytes)
     (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
+      (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)))))
@@ -526,7 +522,7 @@
   #.(declare-buffun)
   (with-vector (src buffer-bytes)
     (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
+      (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)))))
@@ -563,7 +559,7 @@
   #.(declare-buffun)
   (with-vector (src buffer-bytes)
     (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
+      (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)))))
@@ -615,7 +611,7 @@
   #.(declare-buffun)
   (with-vector (src buffer-bytes)
     (with-vector (dest buffer-bytes)
-      (let ((byte-reverse *image-byte-reverse*))
+      (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)))))
@@ -704,31 +700,30 @@
 ;;; 	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 )))))
+(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
@@ -737,23 +732,22 @@
 ;;;
 ;;; 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 |#
-	     )))
+(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
        (bits-per-pixel
@@ -771,12 +765,12 @@
 		   (if from-bit-lsb-first-p 3 0)
 		   (if from-byte-lsb-first-p 6 0))))
 	   (values
-	     (aref *image-swap-function* from-index
+	     (aref +image-swap-function+ from-index
 		   (index+
 		     (ecase to-bitmap-unit (32 2) (16 1) (8 0))
 		     (if to-bit-lsb-first-p 3 0)
 		     (if to-byte-lsb-first-p 6 0)))
-	     (aref *image-swap-lsb-first-p* from-index))))
+	     (aref +image-swap-lsb-first-p+ from-index))))
 	(t
 	 (values 
 	   (if (if (index= bits-per-pixel 4)
@@ -1139,7 +1133,7 @@
 	(24 #'read-pixarray-24)
 	(32 #'read-pixarray-32))
       unit byte-lsb-first-p bit-lsb-first-p
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)))
+      +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))
 
 (defun read-xy-format-image-x
        (buffer-bbuf index length data width height depth
@@ -1226,7 +1220,7 @@
 	  (values (array-dimensions (first data))
 		  (array-element-type (first data)))
 	(values (list height
-		      (index* (index-ceiling width *image-pad*) *image-pad*))
+		      (index* (index-ceiling width +image-pad+) +image-pad+))
 		'pixarray-1-element-type))
     (do* ((arrays data)
 	  (result nil)
@@ -1264,8 +1258,8 @@
   (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*)
+	     (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
@@ -1318,7 +1312,7 @@
 	   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))
+    (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)
@@ -1365,27 +1359,27 @@
 		       (ecase format
 			 (:xy-pixmap
 			   (read-xy-format-image-x
-			     buffer-bbuf *replysize* length data
+			     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
+			     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
+			 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
+			 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)))))
@@ -1678,7 +1672,7 @@
 	(16 #'write-pixarray-16)
 	(24 #'write-pixarray-24)
 	(32 #'write-pixarray-32))
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
+      +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
       unit byte-lsb-first-p bit-lsb-first-p)))
 
 (defun write-xy-format-image-x-data
@@ -2007,7 +2001,7 @@
 		 (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*))
+		     (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))
@@ -2051,7 +2045,7 @@
 		   (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)
+	      (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)
@@ -2237,7 +2231,7 @@
 	   (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*))
+	   (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))))
@@ -2275,7 +2269,7 @@
 	   (type card16 x y width height)
 	   (clx-values image-x))
   (let* ((padded-bits-per-line
-	   (index* (index-ceiling width *image-pad*) *image-pad*))
+	   (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)))
@@ -2289,15 +2283,15 @@
 	(declare (type pixarray-1 bitmap))
 	(write-pixarray
 	  data index bitmap x y width height padded-bytes-per-line 1
-	  *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
+	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)
 	(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* :pad *image-pad*
-      :byte-lsb-first-p *image-byte-lsb-first-p*
-      :bit-lsb-first-p *image-bit-lsb-first-p*)))
+      :unit +image-unit+ :pad +image-pad+
+      :byte-lsb-first-p +image-byte-lsb-first-p+
+      :bit-lsb-first-p +image-bit-lsb-first-p+)))
 
 (defun image-xy->image-xy (image x y width height)
   (declare (type image-xy image)
@@ -2324,7 +2318,7 @@
 	   (clx-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*))
+	   (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)))
@@ -2337,15 +2331,15 @@
     (write-pixarray
       data 0 (image-z-pixarray image) x y width height padded-bytes-per-line 
       (image-z-bits-per-pixel image)
-      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
+      +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)
     (create-image
       :width width :height height :depth (image-depth image)
       :data data :format :z-pixmap
       :bits-per-pixel bits-per-pixel
       :bytes-per-line padded-bytes-per-line
-      :unit *image-unit* :pad *image-pad*
-      :byte-lsb-first-p *image-byte-lsb-first-p*
-      :bit-lsb-first-p *image-bit-lsb-first-p*)))
+      :unit +image-unit+ :pad +image-pad+
+      :byte-lsb-first-p +image-byte-lsb-first-p+
+      :bit-lsb-first-p +image-bit-lsb-first-p+)))
 
 (defun image-z->image-xy (image x y width height)
   (declare (type image-z image)
@@ -2433,7 +2427,8 @@
 		 (kintern
 		   (substitute
 		     #\- #\_
-		     (string-upcase
+		     (#-excl string-upcase
+		      #+excl correct-case
 		      (subseq line start end))
 		     :test #'char=))))
 	  (when (null name)
@@ -2598,7 +2593,7 @@
 	      (index-incf count)
 	      (unless (index= count last)
 		(write-char #\, fstream))))
-	  (format fstream "};~%" fstream))))))
+	  (format fstream "};~%"))))))
 
 (defun bitmap-image (&optional plist &rest patterns)
   ;; Create an image containg pattern
diff --git a/clx/input.lisp b/clx/input.lisp
index 2b74b5d12..c1547b0a9 100644
--- a/clx/input.lisp
+++ b/clx/input.lisp
@@ -24,34 +24,35 @@
 ;;;  Date	Author	Description
 ;;; -------------------------------------------------------------------------------------
 ;;; 12/10/87	LGO	Created
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/input.lisp,v 1.10 2003/02/09 17:23:46 emarsden Exp $")
+(ext:file-comment "$Id: input.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
 ;; 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)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; Maximum number of events supported (the X11 alpha release only has 34)
+  (defconstant +max-events+ 64) 
+  (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)
+(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)
+(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*)))
+      (make-reply-buffer +replysize+)))
 
 (defun deallocate-event (reply-buffer)
   (declare (type reply-buffer reply-buffer))
-  (setf (reply-size reply-buffer) *replysize*)
+  (setf (reply-size reply-buffer) +replysize+)
   (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
 
 ;; Extensions are handled as follows:
@@ -97,38 +98,40 @@
 	   (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)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
        (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 (clx-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
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun canonicalize-event-name (event)
+    ;; Returns the event name keyword given an event name stringable
+    (declare (type stringable event))
+    (declare (clx-values event-key))
+    (kintern event)))
+
+(defun extension-event-key-p (key)
+  (dolist (extension *extensions* nil)
+    (when (member key (second extension))
+      (return t))))
+    
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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 (extension-event-key-p name)
+	  (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)))
 
 (defun get-internal-event-code (display code)
   ;; Given an X11 event-code, return the internal event-code.
@@ -263,7 +266,7 @@
 
 (defun allocate-reply-buffer (size)
   (declare (type array-index size))
-  (if (index<= size *replysize*)
+  (if (index<= size +replysize+)
       (allocate-event)
     (let ((index (integer-length (index1- size))))
       (declare (type array-index index))
@@ -275,7 +278,7 @@
   (declare (type reply-buffer reply-buffer))
   (let ((size (reply-size reply-buffer)))
     (declare (type array-index size))
-    (if (index<= size *replysize*)
+    (if (index<= size +replysize+)
 	(deallocate-event reply-buffer)
       (let ((index (integer-length (index1- size))))
 	(declare (type array-index index))
@@ -324,18 +327,18 @@
 	   (type array-index length))
   (unwind-protect 
       (progn
-	(when (index< *replysize* length)
+	(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*)
+				  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)
+	  (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)
@@ -388,7 +391,10 @@
 	   (type generalized-boolean force-output-p)
 	   (dynamic-extent predicate-args))
   (declare (type function predicate)
-	   (dynamic-extent predicate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent predicate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg predicate))
   (let ((reply-buffer nil)
 	(token (or (current-process) (cons nil nil))))
     (declare (type (or null reply-buffer) reply-buffer))
@@ -406,17 +412,20 @@
 					(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)
+	   ;; Ensure that only 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)
-				     (dynamic-extent predicate))
+				     #+clx-ansi-common-lisp
+				     (dynamic-extent predicate)
+				     #+(and lispm (not clx-ansi-common-lisp))
+				     (sys:downward-funarg predicate))
 			    (or (apply predicate predicate-args)
 				(null (display-input-in-progress display))
 				(not (null (display-dead display)))))
@@ -432,7 +441,7 @@
 		   (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*
+		   (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+
 					      (if force-output-p 0 timeout))))
 		     (when eof-p
 		       (when (eq eof-p :timeout)
@@ -441,14 +450,14 @@
 			   (return-from read-input :timeout)))
 		       (setf (display-dead display) t)
 		       (return-from read-input eof-p)))
-		   (setf (reply-data-size reply-buffer) *replysize*)
+		   (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
+		     ;; 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))
+			       (index+ +replysize+ (index* (read-card32 4) 4))
 			       (shiftf reply-buffer nil))))
 		       (when value
 			 (return-from read-input value))
@@ -606,7 +615,7 @@
       (buffer-replace buffer
 		      (display-obuf8 display)
 		      0
-		      *replysize*
+		      +replysize+
 		      (index+ 12 (buffer-boffset display)))
       (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
 	    (aref buffer 2) 0
@@ -643,7 +652,7 @@
 
 
 (defmacro define-event (name code)
-  `(eval-when (eval compile load)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
      (setf (svref *event-key-vector* ,code) ',name)
      (setf (get ',name 'event-code) ,code)))
 
@@ -757,7 +766,10 @@
 	     (declare (type display display)
 		      (type reply-buffer event))
 	     (declare (type function handler)
-		      (dynamic-extent handler))
+		      #+clx-ansi-common-lisp
+		      (dynamic-extent handler)
+		      #+(and lispm (not clx-ansi-common-lisp))
+		      (sys:downward-funarg handler))
 	     (reading-event (event :display display :sizes (8 16 ,@get-sizes))
 	       (funcall handler
 			:display display
@@ -930,13 +942,13 @@
 (declare-event :circulate-notify
   (card16 sequence)
   (window event-window window parent)
-  ((member16 :top :bottom) place))
+  ((member8 :top :bottom) place))
 
 (declare-event :circulate-request
   (card16 sequence)
   (window (parent event-window) window)
   (pad16 1 2)
-  ((member16 :top :bottom) place))
+  ((member8 :top :bottom) place))
 
 (declare-event :property-notify
   (card16 sequence)
@@ -1168,7 +1180,10 @@
 	   (type (or null number) timeout)
 	   (type generalized-boolean peek-p discard-p force-output-p))
   (declare (type t handler)
-	   (dynamic-extent handler))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent handler)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys: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*))
@@ -1199,7 +1214,7 @@
 	   (type (or null function) default)
 	   (clx-values sequence))			;Default handler for initial content
   ;; Makes a handler sequence suitable for process-event
-  (make-sequence type *max-events* :initial-element default))
+  (make-sequence type +max-events+ :initial-element default))
    
 (defun event-handler (handlers event-key)
   (declare (type sequence handlers)
@@ -1323,7 +1338,7 @@
   ;; 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)))
+	(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
@@ -1351,7 +1366,7 @@
 			   (let ((keys (do ((i 0 (1+ i))
 					    (key nil)
 					    (result nil))
-					   ((>= i *max-events*) result)
+					   ((>= i +max-events+) result)
 					 (setq key (svref *event-key-vector* i))
 					 (when (and key (zerop (aref all-events i)))
 					   (push key result)))))
@@ -1445,7 +1460,7 @@
 ;;; Error Handling
 ;;;-----------------------------------------------------------------------------
 
-(eval-when (eval compile load)
+(eval-when (:compile-toplevel :load-toplevel :execute)
 (defparameter
   *xerror-vector*
   '#(unknown-error
@@ -1521,6 +1536,17 @@
       (when (= code (second extension))
 	(return (first extension))))))
 
+#-(or clx-ansi-common-lisp excl lcl3.0 CMU)
+(define-condition request-error (x-error)
+  ((display :reader request-error-display)
+   (error-key :reader request-error-error-key)
+   (major :reader request-error-major)
+   (minor :reader request-error-minor)
+   (sequence :reader request-error-sequence)
+   (current-sequence :reader request-error-current-sequence)
+   (asynchronous :reader request-error-asynchronous))
+  (:report report-request-error))
+
 (defun report-request-error (condition stream)
   (let ((error-key (request-error-error-key condition))
 	(asynchronous (request-error-asynchronous condition))
@@ -1535,7 +1561,7 @@
 
 ;; Since the :report arg is evaluated as (function report-request-error) the
 ;; define-condition must come after the function definition.
-
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
 (define-condition request-error (x-error)
   ((display :reader request-error-display :initarg :display)
    (error-key :reader request-error-error-key :initarg :error-key)
diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp
index 3049b7aab..2a62d2b2a 100644
--- a/clx/keysyms.lisp
+++ b/clx/keysyms.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/keysyms.lisp,v 1.4 2003/04/11 12:07:30 pmai Exp $")
+(ext:file-comment "$Id: keysyms.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -36,6 +36,16 @@
 (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 :thai        (keysym 13 0) (keysym 13 255))
+(define-keysym-set :korean      (keysym 14 0) (keysym 14 255))
+(define-keysym-set :latin-5     (keysym 15 0) (keysym 15 255))
+(define-keysym-set :latin-6     (keysym 16 0) (keysym 16 255))
+(define-keysym-set :latin-7     (keysym 17 0) (keysym 17 255))
+(define-keysym-set :latin-8     (keysym 18 0) (keysym 18 255))
+(define-keysym-set :latin-9     (keysym 19 0) (keysym 19 255))
+(define-keysym-set :currency    (keysym 32 0) (keysym 32 255))
+(define-keysym-set :|3270|      (keysym 253 0) (keysym 253 255))
+(define-keysym-set :xkb         (keysym 254 0) (keysym 254 255))
 (define-keysym-set :keyboard	(keysym 255 0) (keysym 255 255))
 
 (define-keysym :character-set-switch character-set-switch-keysym)
@@ -159,4 +169,268 @@
   (define-keysym #\backspace (keysym 255 008))	; :tty
   )
 
+;;; these keysym definitions are only correct if the underlying lisp's
+;;; definition of characters between 160 and 255 match latin1 exactly.
+;;; If the characters are in some way locale-dependent (as, I believe,
+;;; in Allegro8) or are treated as opaque without any notions of
+;;; graphicness or case (as in cmucl and openmcl) then defining these
+;;; keysyms is either not useful or wrong.  -- CSR, 2006-03-14
+#+sbcl
+(progn
+  (do ((i 160 (+ i 1)))
+      ((>= i 256))
+    (if (or (<= #xc0 i #xd6)
+            (<= #xd8 i #xde))
+        (define-keysym (code-char i) i :lowercase (+ i 32))
+        (define-keysym (code-char i) i))))
+
+#+(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
index 717e4e0b7..0652bc105 100644
--- a/clx/macros.lisp
+++ b/clx/macros.lisp
@@ -15,11 +15,8 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
-#+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/macros.lisp,v 1.6 1999/03/16 23:37:44 pw Exp $")
 
-;;; CLX basicly implements a very low overhead remote procedure call
+;;; CLX basically 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
@@ -28,8 +25,17 @@
 
 ;;; This is built on top of BUFFER
 
+#+cmu
+(ext:file-comment "$Id: macros.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $")
+
 (in-package :xlib)
 
+(defmacro type-check (value type)
+  value type
+  (when +type-check?+
+    `(unless (type? ,value ,type)
+       (x-type-error ,value ,type))))
+
 ;;; This variable is used by the required-arg macro just to satisfy compilers.
 (defvar *required-arg-dummy*)
 
@@ -66,14 +72,14 @@
 	(error "~s isn't a known field accessor" name)))
     increment))
 
-(eval-when (eval compile load)
+(eval-when (:compile-toplevel :load-toplevel :execute)
 (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
+;;; 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
@@ -93,7 +99,7 @@
 	 ,@(cdr get-macro))
        (defmacro ,(putify name) ,(car put-macro)
 	 ,@(cdr put-macro))
-       ,@(when *type-check?*
+       ,@(when +type-check?+
 	   (let ((predicating-put (third get-put-macros)))
 	     (when predicating-put
 	       `((setf (get ',name 'predicating-put) t)
@@ -225,12 +231,14 @@
 	(svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
    `(write-card8 ,index (position ,thing
-				  (the simple-vector ',(apply #'vector keywords))
+				  #+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
-			      (the simple-vector ',(apply #'vector keywords))
+			      #+lispm ',keywords
+			      #-lispm (the simple-vector ',(apply #'vector keywords))
 			      :test #'eq)))
 	(and ,value (write-card8 ,index ,value))))))
 
@@ -243,12 +251,14 @@
 	(svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
    `(write-card16 ,index (position ,thing
-				   (the simple-vector ',(apply #'vector keywords))
+				   #+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
-			      (the simple-vector ',(apply #'vector keywords))
+			      #+lispm ',keywords
+			      #-lispm (the simple-vector ',(apply #'vector keywords))
 			      :test #'eq)))
 	(and ,value (write-card16 ,index ,value))))))
 
@@ -261,13 +271,15 @@
 	(svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
    `(write-card29 ,index (position ,thing
-				   (the simple-vector ',(apply #'vector keywords))
+				   #+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
-				  (the simple-vector ',(apply #'vector keywords))
+				  #+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)))))
@@ -303,14 +315,14 @@
   ((index)
    (let ((value (gensym)))
      `(let ((,value (read-card29 ,index)))
-	(declare (type (integer 0 (,(length *boole-vector*))) ,value))
-	(type-check ,value '(integer 0 (,(length *boole-vector*))))
-	(svref *boole-vector* ,value))))
+	(declare (type (integer 0 (,(length +boole-vector+))) ,value))
+	(type-check ,value '(integer 0 (,(length +boole-vector+))))
+	(svref +boole-vector+ ,value))))
   ((index thing)
-   `(write-card29 ,index (position ,thing (the simple-vector *boole-vector*))))
+   `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+))))
   ((index thing)
    (let ((value (gensym)))
-     `(let ((,value (position ,thing (the simple-vector *boole-vector*))))
+     `(let ((,value (position ,thing (the simple-vector +boole-vector+))))
 	(and ,value (write-card29 ,index ,value))))))
 
 (define-accessor null (32)
@@ -506,7 +518,7 @@
 	(result))
        ((endp types)
 	`(cond ,@(nreverse result)
-	       ,@(when *type-check?*
+	       ,@(when +type-check?+
 		   `((t (x-type-error ,value '(or ,@type-list)))))))
      (let* ((type (car types))
 	    (type-name type)
@@ -516,7 +528,7 @@
 	       type-name (car type)))
        (push
 	 `(,@(cond ((get type-name 'predicating-put) nil)
-		   ((or *type-check?* (cdr types)) `((type? ,value ',type)))
+		   ((or +type-check?+ (cdr types)) `((type? ,value ',type)))
 		   (t '(t)))
 	   (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
 	 result)))))
@@ -531,7 +543,10 @@
 
 (defun mask-get (index type-values body-function)
   (declare (type function body-function)
-	   (dynamic-extent body-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent body-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys: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)
@@ -562,7 +577,10 @@
 
 (defun mask-put (index type-values body-function)
   (declare (type function body-function)
-	   (dynamic-extent body-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent body-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys: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)
@@ -596,11 +614,8 @@
 ;
 ; 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))))
+
+;;; type-check was here, and has been moved up
 
 (defmacro check-put (index value type &rest args &environment env)
   (let* ((var (if (or (symbolp value) (constantp value)) value '.value.))
@@ -623,7 +638,10 @@
 
 (defun get-put-items (index type-args putp &optional body-function)
   (declare (type (or null function) body-function)
-	   (dynamic-extent body-function))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent body-function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys: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.
@@ -673,7 +691,7 @@
 	   &body type-args)
   (multiple-value-bind (code index item-sizes)
       (get-put-items 4 type-args t)
-    (let ((length (if length `(index+ ,length *requestsize*) '*requestsize*))
+    (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)
@@ -693,6 +711,7 @@
 		(declare (type display .display.))
 		(with-buffer-request-internal (.display. ,opcode ,@options)
 		  ,@type-args)))
+	 #+clx-ansi-common-lisp
 	 (declare (dynamic-extent #'.request-body.))
 	 (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
 	       'with-buffer-request-function-nolock
@@ -732,6 +751,7 @@
 			   (type reply-buffer .reply-buffer.))
 		  (progn .display. .reply-buffer. nil)
 		  ,reply-body))
+	   #+clx-ansi-common-lisp
 	   (declare (dynamic-extent #'.request-body. #'.reply-body.))
 	   (with-buffer-request-and-reply-function
 	     ,buffer ,multiple-reply #'.request-body. #'.reply-body.))
@@ -817,126 +837,126 @@
 ;;; 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)
+(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
 
diff --git a/clx/manager.lisp b/clx/manager.lisp
index eaec555a9..545fdf18a 100644
--- a/clx/manager.lisp
+++ b/clx/manager.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/manager.lisp,v 1.8 2004/10/06 16:54:07 emarsden Exp $")
+(ext:file-comment "$Id: manager.lisp,v 1.9 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -320,7 +320,7 @@
 		(wm-size-hints-base-height hints) (aref vector 16)))
 	(when (logbitp 9 flags)
 	  (setf (wm-size-hints-win-gravity hints)
-		(decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
+		(decode-type (member-vector +win-gravity-vector+) (aref vector 17)))))
       ;; Obsolete fields
       (when (or (logbitp 0 flags) (logbitp 2 flags))
 	(setf (wm-size-hints-x hints) (card32->int32 (aref vector 1))
@@ -375,7 +375,7 @@
     (when (wm-size-hints-win-gravity hints)
       (setf (ldb (byte 1 9) flags) 1
 	    (aref vector 17) (encode-type
-			       (member-vector *win-gravity-vector*)
+			       (member-vector +win-gravity-vector+)
 			       (wm-size-hints-win-gravity hints))))
     ;; Obsolete fields
     (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) 
@@ -730,7 +730,36 @@
     (get-property root property :type type :result-type result-type
 		  :start start :end end :transform transform)))
 
-(defun (setf cut-buffer)
+;; 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...
+#-clx-ansi-common-lisp
+(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
+  #+clx-ansi-common-lisp (setf cut-buffer)
+  #-clx-ansi-common-lisp set-cut-buffer
   (data display &key (buffer 0) (type :STRING) (format 8)
 	(start 0) end (transform #'char->card8))
   (declare (type sequence data)
diff --git a/clx/package.lisp b/clx/package.lisp
index 199cfc741..8c44744e0 100644
--- a/clx/package.lisp
+++ b/clx/package.lisp
@@ -10,17 +10,239 @@
 ;;; documentation, and that the name MIT not be used in advertising or
 ;;; publicity pertaining to distribution of the software without specific,
 ;;; written prior permission.
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/package.lisp,v 1.6 2004/03/23 12:16:47 emarsden Exp $")
+(ext:file-comment "$Id: package.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $")
+
+;;; The CLtL way
+
+#-clx-ansi-common-lisp 
+(lisp:in-package :xlib :use '(:lisp))
+
+#+(and (or kcl ibcl) (not clx-ansi-common-lisp))
+(shadow 
+  '(
+    rational
+    ))
+
+#+(and CMU (not clx-ansi-common-lisp))
+(shadow '(define-condition))
+
+#+(and lispm (not clx-ansi-common-lisp))
+(import
+  '(
+    sys:arglist
+    sys:with-stack-list
+    sys:with-stack-list*
+    ))
+
+#+(and Genera (not clx-ansi-common-lisp))
+(import
+  '(
+    future-common-lisp:print-unreadable-object
+    future-common-lisp:with-standard-io-syntax
+    zwei:indentation
+    ))
+
+#+(and lcl3.0 (not clx-ansi-common-lisp))
+(import
+  '(
+    lcl:arglist
+    lcl:dynamic-extent
+    lcl:type-error
+    lucid::type-error-datum
+    lucid::type-error-expected-type
+    ))
+
+#+(and excl (not clx-ansi-common-lisp)) 
+(import
+  '(
+    excl::arglist
+    excl::dynamic-extent
+    excl::type-error
+    excl::type-error-datum
+    excl::type-error-expected-type
+    ))
+
+#+(and allegro (not clx-ansi-common-lisp))
+(import
+  '(
+    excl::without-interrupts
+    ))
+
+#-clx-ansi-common-lisp
+(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-plist 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 cursor-plist 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-extended-max-request-length 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-cache-p 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 generalized-boolean 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 type-error 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
+    ))
 
+
 ;;; The ANSI Common Lisp way
 
+#+(and Genera clx-ansi-common-lisp)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *readtable* si:*ansi-common-lisp-readtable*))
+
+#+clx-ansi-common-lisp
 (common-lisp:in-package :common-lisp-user)
 
-(defpackage :xlib
-  (:use :common-lisp)
+#+clx-ansi-common-lisp
+(defpackage xlib
+  (:use common-lisp)
   (:size 3000)
+  #+(or kcl ibcl) (:shadow rational)
+  #+allegro (:use cltl1)
+  #+allegro (:import-from excl without-interrupts)
+  #+excl (:import-from excl arglist)
+  #+Genera (:import-from zwei indentation)
+  #+lcl3.0 (:import-from lcl arglist)
+  #+lispm (:import-from lisp char-bit)
+  #+lispm (:import-from sys arglist with-stack-list with-stack-list*)
+  #+sbcl (:use sb-bsd-sockets)
   (:export
     *version* access-control access-error access-hosts
     activate-screen-saver add-access-host add-resource add-to-save-set
@@ -50,7 +272,8 @@
     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-display display-error-handler 
+    display-extended-max-request-length 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
@@ -108,7 +331,8 @@
     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
+    motion-events name-error no-operation 
+    open-default-display 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
@@ -166,3 +390,6 @@
     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))
+
+
+
diff --git a/clx/provide.lisp b/clx/provide.lisp
new file mode 100644
index 000000000..78b385c85
--- /dev/null
+++ b/clx/provide.lisp
@@ -0,0 +1,67 @@
+;;; -*- 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>)
+;;;
+
+#+cmu
+(ext:file-comment "$Id: provide.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+
+#+cmu
+(cl:provide "CLX")
+
+#-cmu
+(progn
+
+#-clx-ansi-common-lisp 
+(in-package :user)
+
+#+clx-ansi-common-lisp
+(in-package :common-lisp-user)
+
+#-clx-ansi-common-lisp
+(provide :clx)
+
+(defvar *clx-source-pathname*
+	(pathname "/src/local/clx/*.l"))
+
+(defvar *clx-binary-pathname*
+	(let ((lisp
+		(or #+lucid "lucid"
+		    #+akcl  "akcl"
+		    #+kcl   "kcl"
+		    #+ibcl  "ibcl"
+		    (error "Can't provide CLX for this lisp.")))
+	      (architecture
+		(or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3"
+		    #+(or sun4 sparc) "sparc"
+		    #+(and hp (or mc68000 mc68020)) "hp9000s300"
+		    #+vax "vax"
+		    #+prime "prime"
+		    #+sunrise "sunrise"
+		    #+ibm-rt-pc "ibm-rt-pc"
+		    #+mips "mips"
+		    #+prism "prism"
+		    (error "Can't provide CLX for this architecture."))))
+	  (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture))))
+
+(defvar *compile-clx*
+	nil)
+
+(load (merge-pathnames "defsystem" *clx-source-pathname*))
+
+(if *compile-clx*
+    (compile-clx *clx-source-pathname* *clx-binary-pathname*)
+  (load-clx *clx-binary-pathname*))
+
+)
diff --git a/clx/requests.lisp b/clx/requests.lisp
index f71920a5f..d2ec05b13 100644
--- a/clx/requests.lisp
+++ b/clx/requests.lisp
@@ -15,9 +15,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/requests.lisp,v 1.7 2003/02/03 14:19:58 emarsden Exp $")
+(ext:file-comment "$Id: requests.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -94,7 +94,7 @@
       (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
 
 						;Make the request
-    (with-buffer-request (display *x-createwindow*)
+    (with-buffer-request (display +x-createwindow+)
       (data depth)
       (resource-id wid)
       (window parent)
@@ -108,8 +108,8 @@
 			 (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-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)
@@ -120,62 +120,62 @@
 
 (defun destroy-window (window)
   (declare (type window window))
-  (with-buffer-request ((window-display window) *x-destroywindow*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (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*)
+  (with-buffer-request ((window-display window) +x-circulatewindow+)
     (data 1)
     (window window)))
 
@@ -185,13 +185,13 @@
   (declare (clx-values (clx-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))
+	(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*)))
+			  :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
@@ -213,7 +213,7 @@
 	(let ((string (symbol-name name)))
 	  (declare (type string string))
 	  (multiple-value-bind (id)
-	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
+	      (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
 		   ((data 0)
 		    (card16 (length string))
 		    (pad16 nil)
@@ -237,7 +237,7 @@
 	(let ((string (symbol-name name)))
 	  (declare (type string string))
 	  (multiple-value-bind (id)
-	      (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
+	      (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
 		   ((data 1)
 		    (card16 (length string))
 		    (pad16 nil)
@@ -259,10 +259,10 @@
       (let ((keyword
 	      (kintern
 		  (with-buffer-request-and-reply
-		       (display *x-getatomname* nil :sizes (16))
+		       (display +x-getatomname+ nil :sizes (16))
 		     ((resource-id atom-id))
 		  (values
-		    (string-get (card16-get 8) *replysize*))))))
+		    (string-get (card16-get 8) +replysize+))))))
 	(declare (type keyword keyword))
 	(setf (atom-id keyword display) atom-id)
 	  keyword))))
@@ -293,7 +293,7 @@
     (declare (type display display)
 	     (type array-index length)
 	     (type resource-id property-id type-id))
-    (with-buffer-request (display *x-changeproperty*)
+    (with-buffer-request (display +x-changeproperty+)
       ((data (member :replace :prepend :append)) mode)
       (window window)
       (resource-id property-id type-id)
@@ -315,7 +315,7 @@
 	 (property-id (intern-atom display property)))
     (declare (type display display)
 	     (type resource-id property-id))
-    (with-buffer-request (display *x-deleteproperty*)
+    (with-buffer-request (display +x-deleteproperty+)
       (window window)
       (resource-id property-id))))
 
@@ -338,7 +338,7 @@
 	     (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))
+	(with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32))
 	     (((data boolean) delete-p)
 	      (window window)
 	      (resource-id property-id)
@@ -358,13 +358,13 @@
 		     (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*))
+				       :index +replysize+))
 		     (16 (sequence-get :result-type result-type :format card16
 				       :length nitems :transform transform
-				       :index *replysize*))
+				       :index +replysize+))
 		     (32 (sequence-get :result-type result-type :format card32
 				       :length nitems :transform transform
-				       :index *replysize*)))))))
+				       :index +replysize+)))))))
       (values data
 	      (and (plusp reply-type) (atom-name display reply-type))
 	      reply-format
@@ -385,7 +385,7 @@
       ;; 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*)
+      (with-buffer-request (display +x-rotateproperties+)
 	(window window)
 	(card16 length)
 	(int16 (- delta))
@@ -398,11 +398,11 @@
   (declare (clx-values (clx-sequence keyword)))
   (let ((display (window-display window)))
     (multiple-value-bind (seq)
-	(with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16)
+	(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*)))
+			  :index +replysize+)))
       ;; lookup the atoms in the sequence
       (if (listp seq)
 	  (do ((elt seq (cdr elt)))
@@ -418,7 +418,7 @@
   (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)
+	(with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32)
 	     ((resource-id selection-id))
 	  (values
 	    (resource-id-or-nil-get 8)))
@@ -431,7 +431,7 @@
 	   (type timestamp time))
   (let ((selection-id (intern-atom display selection)))
     (declare (type resource-id selection-id))
-    (with-buffer-request (display *x-setselectionowner*)
+    (with-buffer-request (display +x-setselectionowner+)
       ((or null window) owner)
       (resource-id selection-id)
       ((or null card32) time))
@@ -453,7 +453,7 @@
     (declare (type display display)
 	     (type resource-id selection-id type-id)
 	     (type (or null resource-id) property-id))
-    (with-buffer-request (display *x-convertselection*)
+    (with-buffer-request (display +x-convertselection+)
       (window requestor)
       (resource-id selection-id type-id)
       ((or null resource-id) property-id)
@@ -486,7 +486,7 @@
       (let ((keyword (getf args arg)))
 	(intern-atom display keyword)))
     ;; Make the sendevent request
-    (with-buffer-request (display *x-sendevent*)
+    (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)
@@ -506,7 +506,7 @@
 	   (type timestamp time))
   (declare (clx-values grab-status))
   (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8)
+    (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8)
 	 (((data boolean) owner-p)
 	  (window window)
 	  (card16 (encode-pointer-event-mask event-mask))
@@ -519,7 +519,7 @@
 
 (defun ungrab-pointer (display &key time)
   (declare (type timestamp time))
-  (with-buffer-request (display *x-ungrabpointer*)
+  (with-buffer-request (display +x-ungrabpointer+)
     ((or null card32) time)))
 
 (defun grab-button (window button event-mask
@@ -532,7 +532,7 @@
 	   (type generalized-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*)
+  (with-buffer-request ((window-display window) +x-grabbutton+)
     ((data boolean) owner-p)
     (window window)
     (card16 (encode-pointer-event-mask event-mask))
@@ -547,7 +547,7 @@
   (declare (type window window)
 	   (type (or (member :any) card8) button)
 	   (type modifier-mask modifiers))
-  (with-buffer-request ((window-display window) *x-ungrabbutton*)
+  (with-buffer-request ((window-display window) +x-ungrabbutton+)
     (data (if (eq button :any) 0 button))
     (window window)
     (card16 (encode-modifier-mask modifiers))))
@@ -557,7 +557,7 @@
 	   (type pointer-event-mask event-mask)
 	   (type (or null cursor) cursor)
 	   (type timestamp time))
-  (with-buffer-request (display *x-changeactivepointergrab*)
+  (with-buffer-request (display +x-changeactivepointergrab+)
     ((or null cursor) cursor)
     ((or null card32) time)
     (card16 (encode-pointer-event-mask event-mask))))
@@ -568,7 +568,7 @@
 	   (type timestamp time))
   (declare (clx-values grab-status))
   (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8)
+    (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8)
 	 (((data boolean) owner-p)
 	  (window window)
 	  ((or null card32) time)
@@ -579,7 +579,7 @@
 (defun ungrab-keyboard (display &key time)
   (declare (type display display)
 	   (type timestamp time))
-  (with-buffer-request (display *x-ungrabkeyboard*)
+  (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)
@@ -587,7 +587,7 @@
 	   (type generalized-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*)
+  (with-buffer-request ((window-display window) +x-grabkey+)
     ((data boolean) owner-p)
     (window window)
     (card16 (encode-modifier-mask modifiers))
@@ -598,7 +598,7 @@
   (declare (type window window)
 	   (type (or (member :any) card8) key)
 	   (type modifier-mask modifiers))
-  (with-buffer-request ((window-display window) *x-ungrabkey*)
+  (with-buffer-request ((window-display window) +x-ungrabkey+)
     (data (if (eq key :any) 0 key))
     (window window)
     (card16 (encode-modifier-mask modifiers))))
@@ -610,7 +610,7 @@
 			 :async-both :sync-both)
 		 mode)
 	   (type timestamp time))
-  (with-buffer-request (display *x-allowevents*)
+  (with-buffer-request (display +x-allowevents+)
     ((data (member :async-pointer :sync-pointer :replay-pointer
 		   :async-keyboard :sync-keyboard :replay-keyboard
 		   :async-both :sync-both))
@@ -619,10 +619,10 @@
 
 (defun grab-server (display)
   (declare (type display display))
-  (with-buffer-request (display *x-grabserver*)))
+  (with-buffer-request (display +x-grabserver+)))
 
 (defun ungrab-server (display)
-  (with-buffer-request (display *x-ungrabserver*)))
+  (with-buffer-request (display +x-ungrabserver+)))
 
 (defmacro with-server-grabbed ((display) &body body)
   ;; The body is not surrounded by a with-display.
@@ -639,7 +639,7 @@
   (declare (type window window))
   (declare (clx-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))
+    (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32))
 	 ((window window))
       (values
 	(int16-get 20)
@@ -655,7 +655,7 @@
   (declare (type window window))
   (declare (clx-values x y same-screen-p))
   (let ((display (window-display window)))
-    (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16))
+    (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16))
 	 ((window window))
       (values
 	(int16-get 20)
@@ -665,7 +665,7 @@
 (defun global-pointer-position (display)
   (declare (type display display))
   (declare (clx-values root-x root-y root))
-  (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32))
+  (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32))
        ((window (screen-root (first (display-roots display)))))
     (values
       (int16-get 16)
@@ -678,12 +678,12 @@
 	   (type t result-type)) ;; a type specifier
   (declare (clx-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)
+    (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*)))))
+		      :index +replysize+)))))
 
 (defun translate-coordinates (src src-x src-y dst)
   ;; Returns NIL when not on the same screen
@@ -692,7 +692,7 @@
 	   (type window dst))
   (declare (clx-values dst-x dst-y child))
   (let ((display (window-display src)))
-    (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32))
+    (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)
@@ -704,7 +704,7 @@
 (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*)
+  (with-buffer-request ((window-display dst) +x-warppointer+)
     (resource-id 0) ;; None
     (window dst)
     (int16 0 0)
@@ -714,7 +714,7 @@
 (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*)
+  (with-buffer-request (display +x-warppointer+)
     (resource-id 0) ;; None
     (resource-id 0) ;; None
     (int16 0 0)
@@ -729,7 +729,7 @@
 	   (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*)
+    (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))
@@ -743,7 +743,7 @@
 	   (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*)
+    (with-buffer-request ((window-display src) +x-warppointer+)
       (window src)
       (resource-id 0) ;; None
       (int16 src-x src-y)
@@ -755,7 +755,7 @@
 	   (type (or (member :none :pointer-root) window) focus)
 	   (type (member :none :pointer-root :parent) revert-to)
 	   (type timestamp time))
-  (with-buffer-request (display *x-setinputfocus*)
+  (with-buffer-request (display +x-setinputfocus+)
     ((data (member :none :pointer-root :parent)) revert-to)
     ((or window (member :none :pointer-root)) focus)
     ((or null card32) time)))
@@ -763,7 +763,7 @@
 (defun input-focus (display)
   (declare (type display display))
   (declare (clx-values focus revert-to))
-  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
+  (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
        ()
     (values
       (or-get 8 window (member :none :pointer-root))
@@ -773,7 +773,7 @@
   (declare (type display display)
 	   (type (or null (bit-vector 256)) bit-vector))
   (declare (clx-values (bit-vector 256)))
-  (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8)
+  (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8)
        ()
     (values
       (bit-vector256-get 8 8 bit-vector))))
@@ -793,7 +793,7 @@
 	 (pixmap (or pixmap (make-pixmap :display display)))
 	 (pid (allocate-resource-id display pixmap 'pixmap)))
     (setf (pixmap-id pixmap) pid)
-    (with-buffer-request (display *x-createpixmap*)
+    (with-buffer-request (display +x-createpixmap+)
       (data depth)
       (resource-id pid)
       (drawable drawable)
@@ -803,7 +803,7 @@
 (defun free-pixmap (pixmap)
   (declare (type pixmap pixmap))
   (let ((display (pixmap-display pixmap)))
-    (with-buffer-request (display *x-freepixmap*)
+    (with-buffer-request (display +x-freepixmap+)
       (pixmap pixmap))
     (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
 
@@ -815,7 +815,7 @@
 	   (type (or null card16) width height)
 	   (type generalized-boolean exposures-p))
   (unless (or (eql width 0) (eql height 0))
-    (with-buffer-request ((window-display window) *x-cleartobackground*)
+    (with-buffer-request ((window-display window) +x-cleartobackground+)
       ((data boolean) exposures-p)
       (window window)
       (int16 x y)
@@ -826,7 +826,7 @@
 	   (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)
+  (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)
@@ -838,7 +838,7 @@
 	   (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)
+  (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)
@@ -856,7 +856,7 @@
     (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*)
+      (with-buffer-request (display +x-createcolormap+)
 	((data boolean) alloc-p)
 	(card29 id)
 	(window window)
@@ -866,7 +866,7 @@
 (defun free-colormap (colormap)
   (declare (type colormap colormap))
   (let ((display (colormap-display colormap)))
-    (with-buffer-request (display *x-freecolormap*)
+    (with-buffer-request (display +x-freecolormap+)
       (colormap colormap))
     (deallocate-resource-id display (colormap-id colormap) 'colormap)))
 
@@ -878,19 +878,19 @@
 				      :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*)
+    (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*)
+  (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*)
+  (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+)
     (colormap colormap)))
 
 (defun installed-colormaps (window &key (result-type 'list))
@@ -900,11 +900,11 @@
   (let ((display (window-display window)))
     (flet ((get-colormap (id)
 	     (lookup-colormap display id)))
-      (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16)
+      (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*))))))
+			:transform #'get-colormap :index +replysize+))))))
 
 (defun alloc-color (colormap color)
   (declare (type colormap colormap)
@@ -913,7 +913,7 @@
   (let ((display (colormap-display colormap)))
     (etypecase color
       (color
-	(with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32))
+	(with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32))
 	     ((colormap colormap)
 	      (rgb-val (color-red color)
 		       (color-green color)
@@ -928,7 +928,7 @@
       (stringable
 	(let* ((string (string color))
 	       (length (length string)))
-	  (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32))
+	  (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32))
 	       ((colormap colormap)
 		(card16 length)
 		(pad16 nil)
@@ -949,16 +949,16 @@
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))
   (let ((display (colormap-display colormap)))
-    (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16)
+    (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 pixel-length :index +replysize+)
 	  (sequence-get :result-type result-type :length mask-length
-			:index (index+ *replysize* (index* pixel-length 4))))))))
+			:index (index+ +replysize+ (index* pixel-length 4))))))))
 
 (defun alloc-color-planes (colormap colors
 			   &key (reds 0) (greens 0) (blues 0)
@@ -969,7 +969,7 @@
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-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))
+    (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32))
 	 (((data boolean) contiguous-p)
 	  (colormap colormap)
 	  (card16 colors reds greens blues))
@@ -977,14 +977,14 @@
 	    (green-mask (card32-get 16))
 	    (blue-mask (card32-get 20)))
 	(values
-	  (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*)
+	  (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*)
+  (with-buffer-request ((colormap-display colormap) +x-freecolors+)
     (colormap colormap)
     (card32 plane-mask)
     (sequence pixels)))
@@ -1003,7 +1003,7 @@
     (when blue-p (incf flags 4))
     (etypecase spec
       (color
-	(with-buffer-request (display *x-storecolors*)
+	(with-buffer-request (display +x-storecolors+)
 	  (colormap colormap)
 	  (card32 pixel)
 	  (rgb-val (color-red spec)
@@ -1014,7 +1014,7 @@
       (stringable
 	(let* ((string (string spec))
 	       (length (length string)))
-	  (with-buffer-request (display *x-storenamedcolor*)
+	  (with-buffer-request (display +x-storenamedcolor+)
 	    ((data card8) flags)
 	    (colormap colormap)
 	    (card32 pixel)
@@ -1046,11 +1046,11 @@
 	   (type t result-type))   ;; a type specifier
   (declare (clx-values (clx-sequence color)))
   (let ((display (colormap-display colormap)))
-    (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16))
+    (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*)
+	(advance-buffer-offset +replysize+)
 	(dotimes (i (length sequence) sequence)
 	  (setf (elt sequence i)
 		(make-color :red (rgb-val-get 0)
@@ -1065,7 +1065,7 @@
   (let* ((display (colormap-display colormap))
 	 (string (string name))
 	 (length (length string)))
-    (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16)
+    (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16)
 	 ((colormap colormap)
 	  (card16 length)
 	  (pad16 nil)
@@ -1094,7 +1094,7 @@
 	 (cursor (make-cursor :display display))
 	 (cid (allocate-resource-id display cursor 'cursor)))
     (setf (cursor-id cursor) cid)
-    (with-buffer-request (display *x-createcursor*)
+    (with-buffer-request (display +x-createcursor+)
       (resource-id cid)
       (pixmap source)
       ((or null pixmap) mask)
@@ -1127,7 +1127,7 @@
 	 (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*)
+    (with-buffer-request (display +x-createglyphcursor+)
       (resource-id cid source-font-id mask-font-id)
       (card16 source-char)
       (card16 mask-char)
@@ -1142,14 +1142,14 @@
 (defun free-cursor (cursor)
   (declare (type cursor cursor))
   (let ((display (cursor-display cursor)))
-    (with-buffer-request (display *x-freecursor*)
+    (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*)
+  (with-buffer-request ((cursor-display cursor) +x-recolorcursor+)
     (cursor cursor)
     (rgb-val (color-red foreground)
 	     (color-green foreground)
@@ -1168,7 +1168,7 @@
       (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)
+    (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
 	 ((data 0)
 	  (window drawable)
 	  (card16 width height))
@@ -1181,7 +1181,7 @@
 	   (type drawable drawable))
   (declare (clx-values width height))
   (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
+    (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
 	 ((data 1)
 	  (drawable drawable)
 	  (card16 width height))
@@ -1194,7 +1194,7 @@
 	   (type drawable drawable))
   (declare (clx-values width height))
   (let ((display (drawable-display drawable)))
-    (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
+    (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
 	 ((data 2)
 	  (drawable drawable)
 	  (card16 width height))
@@ -1207,7 +1207,7 @@
 	   (type stringable name))
   (declare (clx-values major-opcode first-event first-error))
   (let ((string (string name)))
-    (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8)
+    (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8)
 	 ((card16 (length string))
 	  (pad16 nil)
 	  (string string))
@@ -1221,11 +1221,11 @@
   (declare (type display display)
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-sequence string)))
-  (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8)
+  (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*))))
+	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
@@ -1240,7 +1240,7 @@
   (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))
+  (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32))
     (mask
       (integer key-click-percent bell-percent bell-pitch bell-duration)
       (card32 led)
@@ -1252,7 +1252,7 @@
   (declare (type display display))
   (declare (clx-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))
+  (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32))
        ()
     (values
       (card8-get 12)
@@ -1261,7 +1261,7 @@
       (card16-get 16)
       (card32-get 8)
       (member8-get 1 :off :on)
-      (bit-vector256-get 32))))
+      (bit-vector256-get 20))))
 
 ;;  The base volume should
 ;; be considered to be the "desired" volume in the normal case; that is, a
@@ -1276,24 +1276,24 @@
   ;; 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*)
+  (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 (clx-values sequence)) ;; Sequence of card
-  (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8)
+  (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*))))
+		    :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)
+  (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8)
 	     ((data (length map))
 	      ((sequence :format card8) map))
 	  (values
@@ -1334,14 +1334,14 @@
       (cond ((eq threshold :default) (setq threshold -1))
 	    ((null threshold) (setq threshold -1
 				    threshold-p 0)))
-      (with-buffer-request (display *x-changepointercontrol*)
+      (with-buffer-request (display +x-changepointercontrol+)
 	(int16 numerator denominator threshold)
 	(card8 acceleration-p threshold-p)))))
 
 (defun pointer-control (display)
   (declare (type display display))
   (declare (clx-values acceleration threshold))
-  (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16)
+  (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16)
        ()
     (values
       (/ (card16-get 8) (card16-get 10))	; Should we float this?
@@ -1356,7 +1356,7 @@
   (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*)
+  (with-buffer-request (display +x-setscreensaver+)
     (int16 timeout interval)
     ((member8 :on :off :default) blanking exposures)))
 
@@ -1364,7 +1364,7 @@
   ;; Returns timeout and interval in seconds.
   (declare (type display display))
   (declare (clx-values timeout interval blanking exposures))
-  (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16))
+  (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16))
        ()
     (values
       (card16-get 8)
@@ -1374,12 +1374,12 @@
 
 (defun activate-screen-saver (display)
   (declare (type display display))
-  (with-buffer-request (display *x-forcescreensaver*)
+  (with-buffer-request (display +x-forcescreensaver+)
     (data 1)))
 
 (defun reset-screen-saver (display)
   (declare (type display display))
-  (with-buffer-request (display *x-forcescreensaver*)
+  (with-buffer-request (display +x-forcescreensaver+)
     (data 0)))
 
 (defun add-access-host (display host &optional (family :internet))
@@ -1410,7 +1410,7 @@
     (setq host (host-address host family)))
   (let ((family (car host))
 	(address (cdr host)))
-    (with-buffer-request (display *x-changehosts*)
+    (with-buffer-request (display +x-changehosts+)
       ((data boolean) remove-p)
       (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
       (card16 (length address))
@@ -1424,12 +1424,12 @@
   (declare (type display display)
 	   (type t result-type)) ;; CL type
   (declare (clx-values (clx-sequence host) enabled-p))
-  (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16))
+  (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*)
+      (advance-buffer-offset +replysize+)
       (dotimes (i nhosts)
 	(let ((family (card8-get 0))
 	      (len (card16-get 2)))
@@ -1447,14 +1447,14 @@
 (defun access-control (display)
   (declare (type display display))
   (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED
-  (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8)
+  (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 generalized-boolean enabled-p))
-  (with-buffer-request (display *x-changeaccesscontrol*)
+  (with-buffer-request (display +x-changeaccesscontrol+)
     ((data boolean) enabled-p))
   enabled-p)
 
@@ -1472,7 +1472,7 @@
   (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))
+  (with-buffer-request (display +x-changeclosedownmode+ :sizes (32))
     ((data (member :destroy :retain-permanent :retain-temporary)) mode))
   mode)
 
@@ -1481,14 +1481,14 @@
 (defun kill-client (display resource-id)
   (declare (type display display)
 	   (type resource-id resource-id))
-  (with-buffer-request (display *x-killclient*)
+  (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*)
+  (with-buffer-request (display +x-killclient+)
     (resource-id 0)))
 
 (defun no-operation (display)
   (declare (type display display))
-  (with-buffer-request (display *x-nooperation*)))
+  (with-buffer-request (display +x-nooperation+)))
diff --git a/clx/resource.lisp b/clx/resource.lisp
index 2d965d5e8..aaff151dd 100644
--- a/clx/resource.lisp
+++ b/clx/resource.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/resource.lisp,v 1.10 1999/03/16 23:37:48 pw Exp $")
+(ext:file-comment "$Id: resource.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -29,6 +29,7 @@
 (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)
@@ -110,7 +111,7 @@
 	  (kintern (symbol-name (the symbol stringable)))))
     (string
       (if *uppercase-resource-symbols*
-	  (setq stringable (string-upcase
+	  (setq stringable (#-allegro string-upcase #+allegro correct-case
 			    (the string stringable))))
       (kintern (the string stringable)))))
 
@@ -246,7 +247,7 @@
 
 (defun get-entry-lookup (table name names classes)
   (declare (type list table names classes)
-	   (type stringable name))
+	   (symbol name))
   (dolist (entry table)
     (declare (type resource-database entry))
     (when (stringable-equal name (resource-database-name entry))
@@ -264,7 +265,7 @@
   (declare (type list tight loose names classes))
   (let ((name (car names))
 	(class (car classes)))
-    (declare (type stringable name class))
+    (declare (type symbol name class))
     (cond ((and tight
 		(get-entry-lookup tight name names classes)))
 	  ((and loose
@@ -353,7 +354,7 @@
 
 (defun get-tables-lookup (dbase name names classes)
   (declare (type list dbase names classes)
-	   (type stringable name))
+	   (type symbol name))
   (declare (optimize speed))
   (dolist (entry dbase)
     (declare (type resource-database entry))
@@ -379,7 +380,7 @@
   (declare (type list tight loose names classes))
   (let ((name (car names))
 	(class (car classes)))
-    (declare (type stringable name class))
+    (declare (type symbol name class))
     (when tight
       (get-tables-lookup tight name names classes))
     (when loose
@@ -408,14 +409,20 @@
   ;; FUNCTION is called with arguments (name-list value . args)
   (declare (type resource-database database)
 	   (type (function (list t &rest t) t) function)
+	   #+clx-ansi-common-lisp
 	   (dynamic-extent function)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg function)
 	   (dynamic-extent args))
   (declare (clx-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)
-		      (dynamic-extent function))		      
+		      #+clx-ansi-common-lisp
+		      (dynamic-extent function)
+		      #+(and lispm (not clx-ansi-common-lisp))
+		      (sys:downward-funarg function))		      
 	     (let ((tight (resource-database-tight database))
 		   (loose (resource-database-loose database)))
 	       (declare (type list tight loose))
diff --git a/clx/shape.lisp b/clx/shape.lisp
new file mode 100644
index 000000000..7f6d5543b
--- /dev/null
+++ b/clx/shape.lisp
@@ -0,0 +1,195 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: X11 Shape extension
+;;;   Created: 1999-05-14 11:31
+;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999 by Gilbert Baumann
+
+;;;
+;;; 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.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;;
+
+;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g.
+;;  ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz
+
+#+cmu
+(ext:file-comment "$Id")
+
+(in-package :xlib)
+
+(export '(shape-query-version
+          shape-rectangles
+          shape-mask
+          shape-combine
+          shape-offset
+          shape-query-extents
+          shape-select-input
+          shape-input-selected-p
+          shape-get-rectangles)
+        :xlib)
+
+(define-extension "SHAPE"
+    :events (:shape-notify))
+
+(declare-event :shape-notify
+               ((data (member8 :bounding :clip)) kind) ;shape kind
+               (card16 sequence)
+               (window (window event-window)) ;affected window
+               (int16 x)                ;extents
+               (int16 y)
+               (card16 width)
+               (card16 height)
+               ((or null card32) time)  ;timestamp
+               (boolean shaped-p))
+
+(defun encode-shape-kind (kind)
+  (ecase kind
+    (:bounding 0)
+    (:clip 1)))
+
+(defun encode-shape-operation (operation)
+  (ecase operation
+    (:set 0)
+    (:union 1)
+    (:interset 2)
+    (:subtract 3)
+    (:invert 4)))
+
+(defun encode-shape-rectangle-ordering (ordering)
+  (ecase ordering
+    ((:unsorted :un-sorted nil) 0)
+    ((:y-sorted) 1)
+    ((:yx-sorted) 2)
+    ((:yx-banded) 3)))
+
+(defun shape-query-version (display)
+  (with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
+                                          nil :sizes 16)
+    ((data 0))
+    (values
+     (card16-get 8)
+     (card16-get 10))))
+
+(defun shape-rectangles (window rectangles
+                                &key (kind :bounding)
+                                (x-offset 0)
+                                (y-offset 0)
+                                (operation :set)
+                                (ordering :unsorted))
+  (let* ((display (xlib:window-display window)))
+    (with-buffer-request (display (extension-opcode display "SHAPE"))
+      (data 1)
+      (card8 (encode-shape-operation operation))
+      (card8 (encode-shape-kind kind))
+      (card8 (encode-shape-rectangle-ordering ordering))
+      (card8 0)                         ;unused
+      (window window)
+      (int16 x-offset)
+      (int16 y-offset)
+      ((sequence :format int16) rectangles))))
+
+(defun shape-mask (window pixmap
+                          &key (kind :bounding)
+                          (x-offset 0)
+                          (y-offset 0)
+                          (operation :set))
+  (let* ((display (xlib:window-display window)))
+    (with-buffer-request (display (extension-opcode display "SHAPE"))
+      (data 2)
+      (card8 (encode-shape-operation operation))
+      (card8 (encode-shape-kind kind))
+      (card16 0)                        ;unused
+      (window window)
+      (int16 x-offset)
+      (int16 y-offset)
+      ((or pixmap (member :none)) pixmap))))
+
+(defun shape-combine (window source-window
+                             &key (kind :bounding)
+                             (source-kind :bounding)
+                             (x-offset 0)
+                             (y-offset 0)
+                             (operation :set))
+  (let* ((display (xlib:window-display window)))
+    (with-buffer-request (display (extension-opcode display "SHAPE"))
+      (data 3)
+      (card8 (encode-shape-operation operation))
+      (card8 (encode-shape-kind kind))
+      (card8 (encode-shape-kind source-kind))
+      (card8 0)                         ;unused
+      (window window)
+      (int16 x-offset)
+      (int16 y-offset)
+      (window source-window))))
+
+(defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0))
+  (let* ((display (xlib:window-display window)))
+    (with-buffer-request (display (extension-opcode display "SHAPE"))
+      (data 4)
+      (card8 (encode-shape-kind kind))
+      (card8 0) (card8 0) (card8 0)     ;unused
+      (window window)
+      (int16 x-offset)
+      (int16 y-offset))))
+
+(defun shape-query-extents (window)
+  (let* ((display (xlib:window-display window)))
+    (with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
+                                            nil :sizes (8 16 32))
+      ((data 5)
+       (window window))
+      (values
+       (boolean-get 8)                  ;bounding shaped
+       (boolean-get 9)                  ;clip shaped
+       (int16-get 12)                   ;bounding shape extents x
+       (int16-get 14)                   ;bounding shape extents y
+       (card16-get 16)                  ;bounding shape extents width
+       (card16-get 18)                  ;bounding shape extents height
+       (int16-get 20)                   ;clip shape extents x
+       (int16-get 22)                   ;clip shape extents y
+       (card16-get 24)                  ;clip shape extents width
+       (card16-get 26)))))              ;clip shape extents height
+
+(defun shape-select-input (window selected-p)
+  (let* ((display (window-display window)))
+    (with-buffer-request (display (extension-opcode display "SHAPE"))
+      (data 6)
+      (window window)
+      (boolean selected-p)) ))
+
+(defun shape-input-selected-p (window)
+  (let* ((display (window-display window)))
+    (with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
+                                            nil :sizes (8))
+      ((data 7)                         ;also wrong in documentation
+       (window window))
+      (boolean-get 1))))
+
+(defun shape-get-rectangles (window &optional (kind :bounding)
+                                    (result-type 'list))
+  (let* ((display (window-display window)))
+    (with-buffer-request-and-reply (display (extension-opcode display "SHAPE")
+                                            nil :sizes (8 16 32))
+      ((data 8)                         ;this was wrong in the specification
+       (window window)
+       (card8 (ecase kind
+                (:bounding 0)
+                (:clip 1))))
+      (values
+       (sequence-get :length (print (* 4 (card32-get 8)))
+                     :result-type result-type
+                     :format int16
+                     :index +replysize+)
+       (ecase (card8-get 1)
+         (0 :unsorted)
+         (1 :y-sorted)
+         (2 :yx-sorted)
+         (3 :yx-banded) )))))
diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp
new file mode 100644
index 000000000..bd499fc25
--- /dev/null
+++ b/clx/sockcl.lisp
@@ -0,0 +1,166 @@
+;;; -*- 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")
+
+#+cmu
+(ext:file-comment "$Id: sockcl.lisp,v 1.3 2007/08/21 15:49:28 fgilham Exp $")
+
+(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..3e172c61b
--- /dev/null
+++ b/clx/socket.c
@@ -0,0 +1,155 @@
+/* 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
+ *
+ * $Id: socket.c,v 1.4 2007/08/21 15:49:28 fgilham Exp $
+ */
+
+#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 */
+
+#ifndef hpux
+void bcopy();
+#endif /* hpux */
+
+/* 
+ * 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);
+	(void) 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 */
+	      (void) 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;
+#ifdef hpux
+	  (void) memcpy((char *)&inaddr.sin_addr, 
+			(char *)host_ptr->h_addr, 
+			sizeof(inaddr.sin_addr));
+#else /* hpux */
+	  (void) bcopy((char *)host_ptr->h_addr, 
+		       (char *)&inaddr.sin_addr, 
+		       sizeof(inaddr.sin_addr));
+#endif /* hpux */
+	} 
+      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/test/README b/clx/test/README
new file mode 100644
index 000000000..afcf1dd8f
--- /dev/null
+++ b/clx/test/README
@@ -0,0 +1,9 @@
+$Id: README,v 1.1 2007/08/21 15:49:30 fgilham Rel $
+
+Neither of these tests works correctly.
+
+image.lisp: Draws images on your screen.  Doesn't do what it says it will do, but that's
+probably because of various assumptions it makes that aren't true.
+
+trapezoid.lisp: Doesn't compile and wouldn't work if it did because of lack of the extension
+that implements the "poly-fill-trapezoids" functions.
diff --git a/clx/text.lisp b/clx/text.lisp
index 77cc77ca0..6c3aa79bb 100644
--- a/clx/text.lisp
+++ b/clx/text.lisp
@@ -17,9 +17,9 @@
 ;;; Texas Instruments Incorporated provides this software "as is" without
 ;;; express or implied warranty.
 ;;;
+
 #+cmu
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/text.lisp,v 1.7 2003/07/20 15:55:23 emarsden Exp $")
+(ext:file-comment "$Id: text.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
 
 (in-package :xlib)
 
@@ -34,6 +34,8 @@
 ;; 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))))
 
@@ -70,30 +72,33 @@
 	   (type vector dst)
 	   (inline graphic-char-p))
   (declare (clx-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))))))
+
+  (let ((min-char-index (xlib:font-min-char font))
+        (max-char-index (xlib:font-max-char font)))
+    (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))
+	  (setf char (char->card8 (char src i)))
+	  (if (or (< char min-char-index) (> char max-char-index))
+	      (return i)
+	      (setf (aref dst j) char)))
+	(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))
+	  (when (characterp elt) (setq elt (char->card8 elt)))
+	  (if (or (not (integerp elt))
+		  (< elt min-char-index)
+		  (> elt max-char-index))
+	      (return i)
+	      (setf (aref dst j) elt))))))
 
 ;; 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
@@ -111,7 +116,10 @@
   (declare (type sequence sequence)
 	   (type (or font gcontext) font))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values width ascent descent left right
 		  font-ascent font-descent direction
 		  (or null array-index)))
@@ -138,8 +146,8 @@
       (do* ((wbuf (display-tbuf16 display))
 	    (src-end (or end (length sequence)))
 	    (src-start start (index+ src-start buf-end))
-	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
-		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (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)
@@ -215,7 +223,10 @@
 	   (type array-index start)
 	   (type (or null array-index) end))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values integer (or null integer)))
   (when (type? font 'gcontext)
     (force-gcontext-changes font)
@@ -231,8 +242,8 @@
       (do* ((wbuf (display-tbuf16 display))
 	    (src-end (or end (length sequence)))
 	    (src-start start (index+ src-start buf-end))
-	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
-		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (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))
@@ -258,9 +269,9 @@
 	  (setq font new-font))))
     (values width next-start)))
 
-(defun text-extents-server (font string start end)
+(defun text-extents-server (font sequence start end)
   (declare (type font font)
-	   (type sequence string)
+	   (type sequence sequence)
 	   (type array-index start end))
   (declare (clx-values width ascent descent left right font-ascent font-descent direction))
   (let ((display (font-display font))
@@ -269,12 +280,12 @@
     (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))
+    (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 char2b :start start :end end :appending t)
-	   string))
+	   sequence))
       (values
 	(integer-get 16)
 	(int16-get 12)
@@ -285,9 +296,9 @@
 	(int16-get 10)
 	(member8-get 1 :left-to-right :right-to-left)))))
 
-(defun text-width-server (font string start end)
+(defun text-width-server (font sequence start end)
   (declare (type (or font gcontext) font)
-	   (type sequence string)
+	   (type sequence sequence)
 	   (type array-index start end))
   (declare (clx-values integer))
   (let ((display (font-display font))
@@ -296,12 +307,12 @@
     (declare (type display display)
 	     (type array-index length)
 	     (type resource-id font-id))
-    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)
+    (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 char2b :start start :end end :appending t)
-	   string))
+	   sequence))
       (values (integer-get 16)))))
 
 (defun text-extents-local (font sequence start end width-only-p)
@@ -456,11 +467,14 @@
 	   (type (or null int32) width)
 	   (type index-size size))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values generalized-boolean (or null int32)))
   (let* ((display (gcontext-display gcontext))
 	 (result t)
-	 (opcode *x-polytext8*))
+	 (opcode +x-polytext8+))
     (declare (type display display))
     (let ((vector (allocate-gcontext-state)))
       (declare (type gcontext-state vector))
@@ -480,7 +494,7 @@
 	(when translate-width (setq width translate-width))))
     (when result
       (when (eql size 16)
-	(setq opcode *x-polytext16*)
+	(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)
@@ -504,7 +518,10 @@
 	   (type (or null int32) width)
 	   (type index-size size))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values (or null array-index) (or null int32)))
   (unless end (setq end (length sequence)))
   (ecase size
@@ -525,7 +542,10 @@
 	   (type (or null int32) width))
   (declare (clx-values (or null array-index) (or null int32)))
   (declare (type translation-function translate)
-	   (dynamic-extent translate)) 
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg translate)) 
   (let* ((src-start start)
 	 (src-end (or end (length sequence)))
 	 (next-start nil)
@@ -537,7 +557,7 @@
     (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)
+    (with-buffer-request (display +x-polytext8+ :gc-force gcontext :length request-length)
       (drawable drawable)
       (gcontext gcontext)
       (int16 x y)
@@ -625,7 +645,10 @@
 	   (type (or null int32) width))
   (declare (clx-values (or null array-index) (or null int32)))
   (declare (type translation-function translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg translate))
   (let* ((src-start start)
 	 (src-end (or end (length sequence)))
 	 (next-start nil)
@@ -639,7 +662,7 @@
 	     (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)
+    (with-buffer-request (display +x-polytext16+ :gc-force gcontext :length request-length)
       (drawable drawable)
       (gcontext gcontext)
       (int16 x y)
@@ -725,11 +748,14 @@
 	   (type (or null int32) width)
 	   (type index-size size))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values generalized-boolean (or null int32)))
   (let* ((display (gcontext-display gcontext))
 	 (result t)
-	 (opcode *x-imagetext8*))
+	 (opcode +x-imagetext8+))
     (declare (type display display))
     (let ((vector (allocate-gcontext-state)))
       (declare (type gcontext-state vector))
@@ -749,7 +775,7 @@
 	(when translate-width (setq width translate-width))))
     (when result
       (when (eql size 16)
-	(setq opcode *x-imagetext16*)
+	(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)
@@ -778,7 +804,10 @@
 	   (type (or null int32) width)
 	   (type index-size size))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg #+Genera * #-Genera translate))
   (declare (clx-values (or null array-index) (or null int32)))
   (setf end (index-min (index+ start 255) (or end (length sequence))))
   (ecase size
@@ -803,7 +832,10 @@
 	   (type (or null array-index) end)
 	   (type (or null int32) width)) 
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg translate))
   (declare (clx-values (or null array-index) (or null int32)))
   (do* ((display (gcontext-display gcontext))
 	(length (index- end start))
@@ -819,7 +851,7 @@
     (when font-change
       (setf (gcontext-font gcontext) font))
     (block change-font
-      (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
+      (with-buffer-request (display +x-imagetext8+ :gc-force gcontext :length length)
 	(drawable drawable)
 	(gcontext gcontext)
 	(int16 x y)
@@ -866,7 +898,10 @@
 	   (type (or null array-index) end)
 	   (type (or null int32) width))
   (declare (type (or null translation-function) translate)
-	   (dynamic-extent translate))
+	   #+clx-ansi-common-lisp
+	   (dynamic-extent translate)
+	   #+(and lispm (not clx-ansi-common-lisp))
+	   (sys:downward-funarg translate))
   (declare (clx-values (or null array-index) (or null int32)))
   (do* ((display (gcontext-display gcontext))
 	(length (index- end start))
@@ -885,7 +920,7 @@
       (setf (gcontext-font gcontext) font))
 
     (block change-font
-      (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
+      (with-buffer-request (display +x-imagetext16+ :gc-force gcontext :length length)
 	(drawable drawable)
 	(gcontext gcontext)
 	(int16 x y)
@@ -955,7 +990,7 @@
     (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)
+    (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)))))
@@ -965,10 +1000,10 @@
   (declare (type display display))
   (declare (clx-values shift lock control mod1 mod2 mod3 mod4 mod5))
   (let ((lists nil))
-    (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
+    (with-buffer-request-and-reply (display +x-getmodifiermapping+ nil :sizes 8)
 	 ()
       (do* ((keycodes-per-modifier (card8-get 1))
-	    (advance-by *replysize* keycodes-per-modifier)
+	    (advance-by +replysize+ keycodes-per-modifier)
 	    (keys nil nil)
 	    (i 0 (index+ i 1)))
 	   ((index= i 8))
@@ -998,7 +1033,7 @@
 	 (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*
+    (with-buffer-request (display +x-setkeyboardmapping+
 				  :length (index-ash request-length 2)
 				  :sizes (32))
       (data length)
@@ -1033,11 +1068,11 @@
   (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))
+  (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)
+	  (advance-by +replysize+ bytes-per-keycode)
 	  (keycode-count (floor (card32-get 4) keysyms-per-keycode)
 			 (index- keycode-count 1))
 	  (result (if (and (arrayp data)
diff --git a/clx/translate.lisp b/clx/translate.lisp
index e20ee51de..01506f5be 100644
--- a/clx/translate.lisp
+++ b/clx/translate.lisp
@@ -16,6 +16,9 @@
 ;;; express or implied warranty.
 ;;;
 
+#+cmu
+(ext:file-comment "$Id: translate.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $")
+
 (in-package :xlib)
 
 (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
@@ -48,26 +51,30 @@
       (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)
-	   (clx-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)))))
-)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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.
+    ;;
+    ;; FIXME: The above means that this shouldn't really be a macro at
+    ;; all, but a compiler macro.  Probably, anyway.
+    (declare (type t keysym)
+	     (type list bytes)
+	     (clx-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))
@@ -157,7 +164,7 @@
 	 (mask-check (mask)
 	   (unless (or (numberp mask)
 		       (dolist (element mask t)
-			 (unless (or (find element *state-mask-vector*)
+			 (unless (or (find element +state-mask-vector+)
 				     (gethash element *keysym->character-map*))
 			   (return nil))))
 	     (x-type-error mask '(or mask16 (clx-list (or modifier-key modifier-keysym)))))))
@@ -245,23 +252,22 @@
 	     *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
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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)))
 
 
 ;;-----------------------------------------------------------------------------
@@ -333,7 +339,7 @@
 	   modifiers
 	 (dolist (modifier modifiers mask)
 	   (declare (type symbol modifier))
-	   (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
+	   (let ((bit (position modifier (the simple-vector +state-mask-vector+) :test #'eq)))
 	     (setq mask
 		   (logior mask
 			   (if bit
@@ -362,7 +368,7 @@
   ;; Returns a keysym-index for use with keycode->character
   (declare (clx-values card8))
   (macrolet ((keystate-p (state keyword)
-	       `(logbitp ,(position keyword *state-mask-vector*) ,state)))
+	       `(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)
@@ -388,7 +394,7 @@
 	                                  ;;; as neither if the character is alphabetic.
   (declare (clx-values generalized-boolean))
   (macrolet ((keystate-p (state keyword)
-	       `(logbitp ,(position keyword *state-mask-vector*) ,state)))
+	       `(logbitp ,(position keyword +state-mask-vector+) ,state)))
     (let* ((controlp (or (keystate-p state :control)
 			 (dolist (modifier control-modifiers)
 			   (when (state-keysymp display state modifier)
diff --git a/clx/xrender.lisp b/clx/xrender.lisp
new file mode 100644
index 000000000..e3bb1894b
--- /dev/null
+++ b/clx/xrender.lisp
@@ -0,0 +1,1131 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: The X Render Extension
+;;;   Created: 2002-08-03
+;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
+#+cmu
+(ext:file-comment "$Id: xrender.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+;;; ---------------------------------------------------------------------------
+;;;
+;;; (c) copyright 2002, 2003 by Gilbert Baumann
+;;; (c) copyright 2002 by Christian Sunesson
+;;;
+;;; 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.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;;
+
+;;; NOTE: we need to watch maximum request sizes and somehow work
+;;; around them. Sometimes e.g. in AddGlyphs this is not possible,
+;;; which is a design failure.
+
+;;; TODO
+
+;; - some request are still to be implemented at all.
+;;   + Can they not wait? Xrender seems to be in flux as the specification
+;;     isn't even conforming to the actual protocol. However backwards
+;;     wierd that sounds. --noss
+
+;; - we need to invent something for the color values of e.g. 
+;;   fill-rectangles; I would prefer some generic functions, so that
+;;   we later can map CLIM design directly to colors.
+
+;; - we want some convenience function to turn graphics contexts into
+;;   render pictures. --GB 2002-08-21
+
+;; - also: uniform-alpha-picture display alpha-value
+;;         uniform-color-picture display red green blue
+;;   --GB 2002-08-21
+
+;; - maybe we should aim for a higher level interface to
+;;   color-trapzoids and color-triangles and offer a low level [raw]
+;;   interface also for high performance apps?
+
+;; - Write tests.
+
+;;;; API issues
+
+;; - On one hand we want convenience functions like RENDER-TRIANGLE or
+;;   WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to
+;;   write a full rasterization library you obviously want high
+;;   performance entry points as RENDER-TRIANGLES-1.
+
+;; - We want to extend XLIB:COLOR into something with alpha channel.
+;;   How to name it?
+
+;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body
+;;
+;;   Example:
+;;   (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0)
+;;     (RENDER-TRIANGLE dest color ...))
+
+;; - Pose the filter and the transform slots of a picture.
+
+;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT?
+
+;; - COPY-PICTURE?
+
+;; - WITH-PICTURE-OPTIONS ?
+;;
+;;   (WITH-PICTURE-OPTIONS (pic :repeat :on) ...)
+
+;; - WITH-PICTURE ?
+;;
+;;   (WITH-PICTURE (picture drawable ...) ...)
+
+;;
+
+(in-package :xlib)
+
+;; Beginning to collect the external interface for documentation.
+(export '(render-create-picture
+	  render-free-picture
+	  
+	  render-create-glyph-set
+	  render-reference-glyph-set
+	  render-free-glyph-set
+	  
+	  render-add-glyph
+	  render-add-glyph-from-picture
+	  render-free-glyph
+          render-fill-rectangle
+
+	  picture-format-display 
+	  picture-format-id
+	  picture-format-type
+	  picture-format-depth
+	  picture-format-red-byte
+	  picture-format-green-byte
+	  picture-format-blue-byte
+	  picture-format-alpha-byte
+	  picture-format-colormap
+
+          ;; picture object
+          picture-repeat
+          picture-alpha-map
+          picture-alpha-x-origin
+          picture-alpha-y-origin
+          picture-clip-x-origin
+          picture-clip-y-origin
+          picture-clip-mask
+          picture-graphics-exposures
+          picture-subwindow-mode
+          picture-poly-edge
+          picture-poly-mode
+          picture-dither
+          picture-component-alpha
+          picture-drawable
+
+          find-matching-picture-formats
+          find-window-picture-format
+          render-free-picture
+          render-free-glyph-set
+          render-query-version
+          ;; render-query-picture-formats
+          render-fill-rectangle
+          render-composite
+          render-create-glyph-set
+          render-reference-glyph-set
+          render-composite-glyphs
+          render-add-glyph
+          render-add-glyph-from-picture
+          render-free-glyphs
+          
+          
+	  render-combine
+	  ))
+
+(pushnew :clx-ext-render *features*)
+
+(define-extension "RENDER")
+
+;;;; Request constants
+
+;; Note: Although version numbers are given render.h where the request
+;; numbers are defined, render-query-version returns 0.0 all displays
+;; i tested. --GB 2004-07-21
+
+(defconstant +X-RenderQueryVersion+ 0)                  ;done
+(defconstant +X-RenderQueryPictFormats+ 1)
+(defconstant +X-RenderQueryPictIndexValues+ 2)          ;0.7
+(defconstant +X-RenderQueryDithers+ 3)
+(defconstant +X-RenderCreatePicture+ 4)                 ;done
+(defconstant +X-RenderChangePicture+ 5)                 ;done
+(defconstant +X-RenderSetPictureClipRectangles+ 6)      ;done
+(defconstant +X-RenderFreePicture+ 7)                   ;done
+(defconstant +X-RenderComposite+ 8)                     ;we need better arglist
+(defconstant +X-RenderScale+ 9)
+(defconstant +X-RenderTrapezoids+ 10)                   ;low-level done
+(defconstant +X-RenderTriangles+ 11)                    ;low-level done
+(defconstant +X-RenderTriStrip+ 12)
+(defconstant +X-RenderTriFan+ 13)
+(defconstant +X-RenderColorTrapezoids+ 14)              ;nyi in X server, not mentioned in renderproto.h
+(defconstant +X-RenderColorTriangles+ 15)               ;nyi in X server, not mentioned in renderproto.h
+(defconstant +X-RenderTransform+ 16)                    ;commented out in render.h
+(defconstant +X-RenderCreateGlyphSet+ 17)               ;done
+(defconstant +X-RenderReferenceGlyphSet+ 18)            ;done
+(defconstant +X-RenderFreeGlyphSet+ 19)                 ;done
+(defconstant +X-RenderAddGlyphs+ 20)                    ;done, untested
+(defconstant +X-RenderAddGlyphsFromPicture+ 21)         ;done, untested
+(defconstant +X-RenderFreeGlyphs+ 22)                   ;done, untested
+(defconstant +X-RenderCompositeGlyphs8+ 23)             ;done
+(defconstant +X-RenderCompositeGlyphs16+ 24)            ;done
+(defconstant +X-RenderCompositeGlyphs32+ 25)            ;done
+
+;; >= 0.1
+  
+(defconstant +X-RenderFillRectangles+ 26)               ;single rectangle version done
+
+;; >= 0.5
+
+(defconstant +X-RenderCreateCursor+ 27)
+
+;; >= 0.6
+
+(defconstant +X-RenderSetPictureTransform+ 28)          ;I don't understand what this one should do.
+(defconstant +X-RenderQueryFilters+ 29)                 ;seems to be there on server side
+                                                        ; some guts of its implementation there.
+(defconstant +X-RenderSetPictureFilter+ 30)
+(defconstant +X-RenderCreateAnimCursor+ 31)             ;What has render to do with cursors?
+
+;;;;
+
+;; Sanity measures:
+
+;; We do away with the distinction between pict-format and
+;; picture-format-info. That is we cache picture-format-infos.
+
+(defstruct render-info
+  major-version
+  minor-version
+  picture-formats)
+
+(defun display-render-info (display)
+  (getf (xlib:display-plist display) 'render-info))
+
+(defun (setf display-render-info) (new-value display)
+  (setf (getf (xlib:display-plist display) 'render-info)
+        new-value))
+
+(defun ensure-render-initialized (display)
+  "Ensures that the RENDER extension is initialized. Should be called
+by every function that attempts to generate RENDER requests."
+  ;; xxx locking?
+  (unless (display-render-info display)
+    (let ((q (make-render-info)))
+      (multiple-value-bind (maj min) (render-query-version display)
+        (setf (render-info-major-version q) maj
+              (render-info-minor-version q) min)
+        (setf (render-info-picture-formats q)
+              (make-hash-table :test #'eql))
+        (dolist (pf (render-query-picture-formats display))
+          (setf (gethash (picture-format-id pf) (render-info-picture-formats q))
+                pf))
+        (setf (display-render-info display) q)))))
+
+(defun find-matching-picture-formats
+    (display
+     &key depth-min depth-max depth
+          red-min red-max red
+          green-min green-max green
+          blue-min blue-max blue
+          alpha-min alpha-max alpha
+          type
+          colormap)
+  ;;
+  (ensure-render-initialized display)
+  (let ((res nil))
+    (maphash (lambda (k f)
+               (declare (ignore k))
+               (when (and
+                      (or (null type) (eql (picture-format-type f) type))
+                      (or (null colormap)  (eql (picture-format-colormap f) colormap))
+                      ;; min
+                      (or (null depth-min) (>= (picture-format-depth f) depth-min))
+                      (or (null red-min)   (>= (byte-size (picture-format-red-byte f)) red-min))
+                      (or (null green-min) (>= (byte-size (picture-format-green-byte f)) green-min))
+                      (or (null blue-min)  (>= (byte-size (picture-format-blue-byte f)) blue-min))
+                      (or (null alpha-min) (>= (byte-size (picture-format-alpha-byte f)) alpha-min))
+                      ;; max
+                      (or (null depth-max) (<= (picture-format-depth f) depth-max))
+                      (or (null red-max)   (<= (byte-size (picture-format-red-byte f)) red-max))
+                      (or (null green-max) (<= (byte-size (picture-format-green-byte f)) green-max))
+                      (or (null blue-max)  (<= (byte-size (picture-format-blue-byte f)) blue-max))
+                      (or (null alpha-max) (<= (byte-size (picture-format-alpha-byte f)) alpha-max))
+                      ;; match
+                      (or (null depth)     (= (picture-format-depth f) depth))
+                      (or (null red)       (= (byte-size (picture-format-red-byte f)) red))
+                      (or (null green)     (= (byte-size (picture-format-green-byte f)) green))
+                      (or (null blue)      (= (byte-size (picture-format-blue-byte f)) blue))
+                      (or (null alpha)     (= (byte-size (picture-format-alpha-byte f)) alpha)))
+                 (pushnew f res)))
+             (render-info-picture-formats
+              (display-render-info display)))
+    res))
+
+(defun find-window-picture-format (window)
+  "Find the picture format that matches the given window."
+  (let* ((cm (window-colormap window))
+         (vi (colormap-visual-info cm))
+         (display (window-display window)))
+    (ensure-render-initialized display)
+    (case (visual-info-class vi)
+      ((:true-color)
+       (maphash (lambda (k f)
+                  (declare (ignore k))
+                  (when (and (eql (picture-format-type f) :direct)
+                             (eql (picture-format-depth f) (drawable-depth window))
+                             (eql (dpb -1 (picture-format-red-byte f) 0)
+                                  (visual-info-red-mask vi))
+                             (eql (dpb -1 (picture-format-green-byte f) 0)
+                                  (visual-info-green-mask vi))
+                             (eql (dpb -1 (picture-format-blue-byte f) 0)
+                                  (visual-info-blue-mask vi))
+                             (eql (byte-size (picture-format-alpha-byte f)) 0))
+                    (return-from find-window-picture-format f)))
+                (render-info-picture-formats
+                 (display-render-info display))))
+      (t
+       ))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (define-accessor picture (32)
+    ((index) index :blip)
+    ((index thing) `(resource-id-put ,index (picture-id ,thing))))
+  (define-accessor glyph-set (32)
+    ((index) index :blip)
+    ((index thing) `(resource-id-put ,index (glyph-set-id ,thing)))))
+
+;;; picture format
+
+(defstruct picture-format
+  display 
+  (id   0 :type (unsigned-byte 29))
+  type
+  depth
+  red-byte
+  green-byte
+  blue-byte
+  alpha-byte
+  colormap)
+
+(defmethod print-object ((object picture-format) stream)
+  (let ((abbrev
+         (with-output-to-string (bag)
+           ;; build an abbreviated representation of the format
+           (let ((bytes (sort (list (cons "r" (picture-format-red-byte object))
+                                    (cons "g" (picture-format-green-byte object))
+                                    (cons "b" (picture-format-blue-byte object))
+                                    (cons "a" (picture-format-alpha-byte object)))
+                              #'>
+                              :key #'(lambda (x) (byte-position (cdr x))))))
+             (dolist (k bytes)
+               (unless (zerop (byte-size (cdr k)))
+                 (format bag " ~A~D" (car k) (byte-size (cdr k)))))))))
+    (print-unreadable-object (object stream :type t :identity nil)
+      (format stream "~D ~S ~S ~S~A"
+              (picture-format-id object)
+              (picture-format-colormap object)
+              (picture-format-depth object)
+              (picture-format-type object) abbrev))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (define-accessor picture-format (32)
+    ((index)       `(gethash (read-card32 ,index)
+                     (render-info-picture-formats (display-render-info .display.))))
+    ((index thing) `(write-card32 ,index (picture-format-id ,thing))))
+  (define-accessor render-op (8)
+    ((index) `(member8-get ,index
+               :clear :src :dst :over :over-reverse :in :in-reverse
+               :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))
+    ((index thing) `(member8-put ,index ,thing
+                     :clear :src :dst :over :over-reverse :in :in-reverse
+                     :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum)))
+  (deftype render-op ()
+    '(member :clear :src :dst :over :over-reverse :in :in-reverse
+      :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum)))
+
+;; Now these pictures objects are like graphics contexts. I was about
+;; to introduce a synchronous mode, realizing that the RENDER protocol
+;; provides no provision to actually query a picture object's values. 
+;; *sigh*
+
+(def-clx-class (picture (:copier nil))
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (plist nil :type list)                ; Extension hook
+  (format)
+  (%changed-p)
+  (%server-values)
+  (%values)
+  (%drawable))
+
+(defun picture-drawable (picture)
+  (picture-%drawable picture))
+
+;; xx make id, display, format readonly
+
+(defun %render-change-picture-clip-rectangles (picture rectangles)
+  "Dont call me, use (SETF PICTURE-CLIP-MASK) instead."
+  (declare (optimize (speed 0)))
+  (let ((display (picture-display picture)))
+    (ensure-render-initialized display)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderSetPictureClipRectangles+)
+      (picture picture)
+      (int16    (picture-clip-x-origin picture))
+      (int16    (picture-clip-y-origin picture))
+      ((sequence :format int16) rectangles))))
+
+(macrolet ((foo (&rest specs)
+             `(progn
+               ,@(loop for (type slot default) in specs
+                       for index from 0
+                       collect
+                       `(progn
+                         (defun ,(xintern 'picture- slot) (picture)
+                           (aref (picture-%values picture) ,index))
+                         (defun (setf ,(xintern 'picture- slot)) (new-value picture)
+                           (setf (picture-%changed-p picture) t)
+                           (setf (aref (picture-%values picture) ,index) new-value))))
+    
+               (defun synchronise-picture-state (picture)
+                 (when (picture-%changed-p picture)
+                   (let ((display (picture-display picture)))
+                     (ensure-render-initialized display)
+                     (with-buffer-request (display (extension-opcode display "RENDER"))
+                       (data +X-RenderChangePicture+)
+                       (picture picture)
+                       (mask
+                        ,@(loop for (type slot default) in specs
+                                for index from 0
+                                collect
+                                `(,type (and
+                                         ,(cond ((eql slot 'clip-mask)
+                                                 `(not (typep (aref (picture-%values picture) ,index)
+                                                        'sequence)))
+                                                (t
+                                                 't))
+                                         (not (eq (aref (picture-%values picture) ,index)
+                                                  (aref (picture-%server-values picture) ,index)))
+                                         (setf (aref (picture-%server-values picture) ,index)
+                                          (aref (picture-%values picture) ,index))))))))
+                   ,(let ((index (position 'clip-mask specs :key #'second)))
+                         `(unless (eql (aref (picture-%values picture) ,index)
+                                   (aref (picture-%server-values picture)
+                                    ,index))
+                           (%render-change-picture-clip-rectangles
+                            picture (aref (picture-%values picture) ,index))
+                           (setf (aref (picture-%values picture) ,index)
+                            (aref (picture-%server-values picture)
+                             ,index))))
+                   (setf (picture-%changed-p picture) nil)))
+
+               (defun render-create-picture
+                   (drawable
+                    &key format
+                         (picture (make-picture :display (drawable-display drawable)))
+                         ,@(loop for (type slot default-value) in specs
+                                 collect (cond ((eql slot 'clip-mask)
+                                                `(clip-mask :none))
+                                               (t
+                                                slot)))
+                         )
+                 ;; xxx also offer to give a colormap instead of a picture-format
+                 ;; values!
+                 (let ((display (drawable-display drawable)))
+                   (ensure-render-initialized display)
+                   (unless format
+                     ;; xxx check for drawable being a window
+                     (setf format (find-window-picture-format drawable)))
+                   (let ((pid (allocate-resource-id display picture 'picture)))
+                     (setf (picture-id picture) pid)
+                     (with-buffer-request (display (extension-opcode display "RENDER"))
+                       (data +X-RenderCreatePicture+)
+                       (resource-id pid)
+                       (drawable drawable)
+                       (picture-format format)
+                       (mask
+                        ,@(loop for (type slot default) in specs
+                                collect
+                                (cond ((eql slot 'clip-mask)
+                                       (list type `(and
+                                                    (not (typep clip-mask 'sequence))
+                                                    clip-mask)))
+                                      (t
+                                       (list type slot)))))))
+                   (when (typep clip-mask 'sequence)
+                     (%render-change-picture-clip-rectangles picture clip-mask))
+                   (setf (picture-format picture) format)
+                   (setf (picture-%server-values picture)
+                         (vector ,@(loop for (type slot default) in specs
+                                         collect
+                                         `(or ,slot ,default))))
+                   (setf (picture-%values picture) (copy-seq (picture-%server-values picture)))
+                   (setf (picture-%drawable picture) drawable)
+                   picture))
+    
+               (defconstant +picture-state-length+
+                 ,(length specs)) )))
+
+  (foo ((member :off :on) repeat                                          :off)
+       ((or (member :none) picture) alpha-map                             :none)
+       (int16 alpha-x-origin                                              0)
+       (int16 alpha-y-origin                                              0)
+       (int16 clip-x-origin                                               0)
+       (int16 clip-y-origin                                               0)
+       ;; ### Now that is not correct is it?:
+       ((or (member :none) pixmap) clip-mask                              :none)
+       ((member :off :on) graphics-exposures                              :on)
+       ((member :clip-by-children :include-inferiors) subwindow-mode      :clip-by-children)
+       ((member :sharp :smooth) poly-edge                                 :smooth)
+       ((member :precise :imprecise) poly-mode                            :precise)
+       ((or (member :none) #||xatom||#) dither                            :none)
+       ((member :off :on) component-alpha                                 :off)))
+
+(defun render-free-picture (picture)
+  (let ((display (picture-display picture)))
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderFreePicture+)
+      (picture  picture))))
+
+(defun render-free-glyph-set (glyph-set)
+  (let ((display (glyph-set-display glyph-set)))
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderFreeGlyphSet+)
+      (glyph-set  glyph-set))))
+
+(defun render-query-version (display)
+  (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
+    ((data +X-RenderQueryVersion+)
+     (card32 0)
+     (card32 1))
+    (values
+     (card32-get 8)
+     (card32-get 12) )))
+
+(defun render-query-picture-formats (display)
+  (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
+    ((data +X-RenderQueryPictFormats+))
+    (let ((n-picture-formats (card32-get 8))
+          (n-screens      (card32-get 12))
+          (n-depths       (card32-get 16))
+          (n-visuals      (card32-get 20))
+          (n-subpixel     (card32-get 24)))
+      (declare (ignore n-screens n-depths n-visuals n-subpixel))
+      (loop for i below n-picture-formats
+            collect
+            (let ((off (+ (* 8 4)
+                          (* i 28))))   ;size of picture-format-info
+              (make-picture-format
+               :display display
+               :id         (card32-get (+ off 0))
+               :type       (member8-get (+ off 4) :indexed :direct)
+               :depth      (card8-get   (+ off 5))
+               :red-byte   (byte (integer-length (card16-get (+ off 10)))
+                                 (card16-get (+ off 8)))
+               :green-byte (byte (integer-length (card16-get (+ off 14)))
+                                 (card16-get (+ off 12)))
+               :blue-byte  (byte (integer-length (card16-get (+ off 18)))
+                                 (card16-get (+ off 16)))
+               :alpha-byte (byte (integer-length (card16-get (+ off 22)))
+                                 (card16-get (+ off 20)))
+               :colormap   (let ((cmid (card32-get (+ off 24))))
+                             (unless (zerop cmid)
+                               (lookup-colormap display cmid)))))))))
+
+(defun render-fill-rectangle (picture op color x1 y1 w h)
+  (let ((display (picture-display picture)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state picture)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderFillRectangles+)
+      (render-op op)                         ;op
+      (card8 0)                        ;pad
+      (card16 0)                        ;pad
+      (resource-id (picture-id picture))
+      (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3))
+      (int16 x1) (int16 y1) (card16 w) (card16 h))))
+
+;; fill rectangles, colors.
+
+(defun render-triangles-1 (picture op source src-x src-y format coord-sequence)
+  ;; For performance reasons we do a special typecase on (simple-array
+  ;; (unsigned-byte 32) (*)), so that it'll be possible to have high
+  ;; performance rasters.
+  (macrolet ((guts ()
+               '(let ((display (picture-display picture)))
+                 (synchronise-picture-state picture)
+                 (synchronise-picture-state source)
+                 (with-buffer-request (display (extension-opcode display "RENDER"))
+                   (data +X-RenderTriangles+)
+                   (render-op op)                       ;op
+                   (card8 0)                            ;pad
+                   (card16 0)                           ;pad
+                   (resource-id (picture-id source))
+                   (resource-id (picture-id picture))
+                   (picture-format format)
+                   (int16 src-x)
+                   (int16 src-y)
+                   ((sequence :format int32) coord-sequence) ))))
+    (typecase coord-sequence
+      ((simple-array (unsigned-byte 32) (*))
+       (locally
+           (declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence))
+         (guts)))
+      (t
+       (guts)))))
+
+#||
+(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1))
+  ...)
+||#
+
+(defun render-set-picture-transform (picture a b c d e f p q r)
+  (let ((display (picture-display picture)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state picture)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderSetPictureTransform+)
+      #|
+      (card8 0) ;; render-op op)                    ;op
+      (card8 0)                         ;pad
+      (card16 0)                        ;pad
+      |#
+      (resource-id (picture-id picture))
+      
+      (card32 a)
+      (card32 b)
+      (card32 c)
+      
+      (card32 d)
+      (card32 e)
+      (card32 f)
+      
+      (card32 p)
+      (card32 q)
+      (card32 r))))
+
+(defun render-query-filters (drawable)
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
+      ((data +X-RenderQueryFilters+)
+       (drawable drawable))
+      (let* ((len (card32-get 4))
+             (n-aliases (card32-get 8))
+             (n-filters (card32-get 12))
+             (off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4)))))
+        (print (list :aliases
+                     (loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2))))))
+        (print (list :foo len n-aliases n-filters
+                     (loop for i below len
+                           collect (card8-get (+ off 0 (* 4 i)))
+                           collect (card8-get (+ off 1 (* 4 i)))
+                           collect (card8-get (+ off 2 (* 4 i)))
+                           collect (card8-get (+ off 3 (* 4 i))))))
+        (print
+         (labels ((grab-string (j)
+                    (let ((n (card8-get j)))
+                      (incf j)
+                      (values
+                       (map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j)))
+                       j))))
+           (loop repeat n-filters collect
+                 (multiple-value-bind (s j) (grab-string off)
+                   (setf off j)
+                   (intern (string-upcase s) :keyword)))))
+        #+NIL
+        (loop for i below n-picture-formats
+              collect
+              (let ((off (+ (* 8 4)
+                            (* i 28)))) ;size of picture-format-info
+                (make-picture-format
+                 :display display
+                 :id         (card32-get (+ off 0))
+                 :type       (member8-get (+ off 4) :indexed :direct)
+                 :depth      (card8-get   (+ off 5))
+                 :red-byte   (byte (integer-length (card16-get (+ off 10)))
+                                   (card16-get (+ off 8)))
+                 :green-byte (byte (integer-length (card16-get (+ off 14)))
+                                   (card16-get (+ off 12)))
+                 :blue-byte  (byte (integer-length (card16-get (+ off 18)))
+                                   (card16-get (+ off 16)))
+                 :alpha-byte (byte (integer-length (card16-get (+ off 22)))
+                                   (card16-get (+ off 20)))
+                 :colormap   (let ((cmid (card32-get (+ off 24))))
+                               (unless (zerop cmid)
+                                 (lookup-colormap display cmid))))))))))
+
+(defun render-set-filter (picture filter)
+  (let ((display (picture-display picture)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state picture)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderSetPictureFilter+)
+      (resource-id (picture-id picture))
+      (card16 (length filter))
+      (card16 0)                        ;pad
+      ((sequence :format card8) (map 'vector #'char-code filter)))))
+  
+
+
+#||
+(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over))
+  (render-triangles-1 destination op source ...)
+  )
+||#
+
+(defun render-trapezoids-1 (picture op source src-x src-y format coord-sequence)
+  ;; coord-sequence is  top bottom
+  ;;                    line-1-x1 line-1-y1 line-1-x2 line-1-y2
+  ;;                    line-2-x1 line-2-y1 line-2-x2 line-2-y2 ...
+  ;;
+  (let ((display (picture-display picture)))
+    (synchronise-picture-state picture)
+    (synchronise-picture-state source)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderTrapezoids+)
+      (render-op op)                    ;op
+      (card8 0)                         ;pad
+      (card16 0)                        ;pad
+      (resource-id (picture-id source))
+      (resource-id (picture-id picture))
+      (picture-format format)
+      (int16 src-x)
+      (int16 src-y)
+      ((sequence :format int32) coord-sequence) )))
+
+(defun render-composite (op
+                         source mask dest
+                         src-x src-y mask-x mask-y dst-x dst-y
+                         width height)
+  (let ((display (picture-display source)))
+    (synchronise-picture-state source)
+    (when mask (synchronise-picture-state mask))
+    (synchronise-picture-state dest)
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderComposite+)
+      (render-op op)                         ;op
+      (card8 0)                         ;pad
+      (card16 0)                        ;pad
+      (resource-id (picture-id source))
+      (resource-id (if mask (picture-id mask) 0))
+      (resource-id (picture-id dest))
+      (int16 src-x)
+      (int16 src-y)
+      (int16 mask-x)
+      (int16 mask-y)
+      (int16 dst-x)
+      (int16 dst-y)
+      (card16 width)
+      (card16 height))))
+
+(def-clx-class (glyph-set (:copier nil)
+                        )
+  (id 0 :type resource-id)
+  (display nil :type (or null display))
+  (plist nil :type list)                ; Extension hook
+  (format))
+
+(defun render-create-glyph-set (format &key glyph-set)
+  (let ((display (picture-format-display format)))
+    (let* ((glyph-set (or glyph-set (make-glyph-set :display display)))
+           (gsid (setf (glyph-set-id glyph-set)
+                       (allocate-resource-id display glyph-set 'glyph-set))))
+      (declare (ignore gsid))
+      (setf (glyph-set-format glyph-set) format)
+      (with-buffer-request (display (extension-opcode display "RENDER"))
+        (data +X-RenderCreateGlyphSet+)
+        (glyph-set glyph-set)
+        (picture-format format))
+      glyph-set)))
+
+(defun render-reference-glyph-set (existing-glyph-set &key glyph-set)
+  (let ((display (glyph-set-display existing-glyph-set)))
+    (let* ((glyph-set (or glyph-set (make-glyph-set :display display)))
+           (gsid (setf (glyph-set-id glyph-set)
+                       (allocate-resource-id display glyph-set 'glyph-set))))
+      (declare (ignore gsid))
+      (setf (glyph-set-format glyph-set)
+            (glyph-set-format existing-glyph-set))
+      (with-buffer-request (display (extension-opcode display "RENDER"))
+        (data +X-RenderReferenceGlyphSet+)
+        (glyph-set glyph-set)
+        (glyph-set existing-glyph-set))
+      glyph-set)))
+
+(defun render-composite-glyphs-8 (dest glyph-set source dest-x dest-y sequence
+                                  &key (op :over)
+                                       (alu op) ;for the fun of it
+                                       (src-x 0)
+                                       (src-y 0)
+                                       (mask-format :none)
+                                       (start 0)
+                                       (end (length sequence)))
+  (let ((display (picture-display dest)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state dest)
+    (synchronise-picture-state source)
+    (when (stringp sequence)
+      ;; lazy me, but then you should not confuse glyphs with
+      ;; characters anyway.
+      (setf sequence (map 'vector #'char-code sequence)))
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderCompositeGlyphs8+)
+      (render-op alu)
+      (card8 0) (card16 0)              ;padding
+      (picture source)
+      (picture dest)
+      ((or (member :none) picture-format) mask-format)
+      (glyph-set glyph-set)
+      (int16 src-x) (int16 src-y)
+      (card8 (- end start)) ;length of glyph elt
+      (card8 0) (card16 0) ;padding
+      (int16 dest-x) (int16 dest-y)             ;dx, dy
+      ((sequence :format card8) sequence))))
+
+(defmacro %render-composite-glyphs
+    (opcode type transform display dest glyph-set source dest-x dest-y sequence
+     alu src-x src-y mask-format start end)
+  (let ((size (ecase type (card8 1) (card16 2) (card32 4)))
+	;; FIXME: the last chunk for CARD8 can be 254.
+	(chunksize (ecase type (card8 252) (card16 254) (card32 254))))
+    `(multiple-value-bind (nchunks leftover)
+         (floor (- end start) ,chunksize)
+       (let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size)))
+			      (if (> leftover 0)
+				  (+ 8 (* 4 (ceiling (* leftover ,size) 4)))
+				  0)))
+	      (request-length (+ 7 (/ payloadsize 4))))
+	 (declare (integer request-length))
+	 (with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length))
+	   (data ,opcode)
+	   (length request-length)
+	   (render-op ,alu)
+	   (card8 0) (card16 0)                        ;padding
+	   (picture ,source)
+	   (picture ,dest)
+	   ((or (member :none) picture-format) ,mask-format)
+	   (glyph-set ,glyph-set)
+	   (int16 ,src-x) (int16 ,src-y)
+	   (progn
+	     (let ((boffset (+ buffer-boffset 28))
+		   (start ,start)
+		   (end ,end)
+		   (dest-x ,dest-x)
+		   (dest-y ,dest-y))
+	       (dotimes (i nchunks)
+		 (set-buffer-offset boffset)
+		 (put-items (0)
+		   (card8 ,chunksize)
+		   (card8 0)
+		   (card16 0)
+		   (int16 dest-x)
+		   (int16 dest-y)
+		   ((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence))
+		 (setq dest-x 0 dest-y 0)
+		 (incf boffset (+ 8 (* ,chunksize ,size)))
+		 (incf start ,chunksize))
+	       (when (> leftover 0)
+		 (set-buffer-offset boffset)
+		 (put-items (0)
+		   (card8 leftover)
+		   (card8 0)
+		   (card16 0)
+		   (int16 dest-x)
+		   (int16 dest-y)
+		   ((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence))
+		 ;; padding?
+		 (incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4)))))
+	       (setf (buffer-boffset ,display) boffset))))))))
+
+(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence
+                                &key (op :over)
+                                     (alu op)   ;for the fun of it
+                                     (src-x 0)
+                                     (src-y 0)
+                                     (mask-format :none)
+                                     (start 0)
+                                     (end (length sequence)))
+  ;; xxx do we want to go with some translate function as draw-glyphs?
+  (declare (type array-index start end))
+  (let ((display (picture-display dest)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state dest)
+    (synchronise-picture-state source)
+    ;; hmm find out the element size
+    (typecase sequence
+      ((array (unsigned-byte 8) (*))
+       (%render-composite-glyphs +X-RenderCompositeGlyphs8+ card8 nil
+                                 display dest glyph-set source dest-x dest-y sequence alu src-x
+                                 src-y mask-format start end))
+      ((array (unsigned-byte 16) (*))
+       (%render-composite-glyphs +X-RenderCompositeGlyphs16+ card16 nil
+                                 display dest glyph-set source dest-x dest-y sequence alu src-x
+                                 src-y mask-format start end))
+      ((array (unsigned-byte 32) (*))
+       (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32 nil
+                                 display dest glyph-set source dest-x dest-y sequence alu src-x
+                                 src-y mask-format start end))
+      (string
+       (%render-composite-glyphs #.(cond ((<= char-code-limit (expt 2 8))  '+X-RenderCompositeGlyphs8+)
+                                         ((<= char-code-limit (expt 2 16)) '+X-RenderCompositeGlyphs16+)
+                                         ((<= char-code-limit (expt 2 32)) '+X-RenderCompositeGlyphs32+)
+                                         (t
+                                          (error "Wow!")))
+                                 #.(cond ((<= char-code-limit (expt 2 8))  'card8)
+                                         ((<= char-code-limit (expt 2 16)) 'card16)
+                                         ((<= char-code-limit (expt 2 32)) 'card32)
+                                         (t
+                                          (error "Wow!")))
+                                 #'char-code
+                                 display dest glyph-set source dest-x dest-y sequence alu src-x
+                                 src-y mask-format start end))
+      (t
+       ;; should we bother testing the array element type?
+       (%render-composite-glyphs +X-RenderCompositeGlyphs32+ card32
+                                 #'(lambda (elt)
+                                     (if (characterp elt)
+                                         (char-code elt)
+                                         elt))
+                                 display dest glyph-set source dest-x dest-y sequence alu src-x
+                                 src-y mask-format start end))) ))
+
+;; --- idea: Allow data to be an image to avoid unecessary consing? - noss
+(defun render-add-glyph (glyph-set id &key x-origin y-origin x-advance y-advance data)
+  (let ((display (glyph-set-display glyph-set)))
+    (ensure-render-initialized display)
+    (let* ((w (array-dimension data 1))
+           (h (array-dimension data 0))
+           (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)))
+      (let* ((byte-per-line (* 4 (ceiling 
+				  (* w (picture-format-depth (glyph-set-format glyph-set)))
+				  32)))
+             (request-length (+ 28
+				(* h byte-per-line))))
+        (with-buffer-request (display (extension-opcode display "RENDER"))
+          (data +X-RenderAddGlyphs+)
+          (length (ceiling request-length 4))
+          (glyph-set glyph-set)
+          (card32 1) ;number glyphs
+          (card32 id) ;id
+          (card16 w)
+          (card16 h)
+          (int16 x-origin)
+          (int16 y-origin)
+          (int16 x-advance)
+          (int16 y-advance)
+          (progn
+            (setf (buffer-boffset display) (advance-buffer-offset 28))
+            (let ((im (create-image :width w :height h :depth 8 :data data)))
+              (write-image-z display im 0 0 w h
+                             byte-per-line ;padded bytes per line
+                             unit byte-lsb-first-p bit-lsb-first-p)) ))) )))
+
+(defun render-add-glyph-from-picture (glyph-set picture
+                                      &key x-origin y-origin x-advance y-advance
+                                           x y width height)
+  ;; untested, the duplication of x-origin seems bogus.
+  ;; Still untested, but these modifications seem to be more likely, (x,y) would be the offset into the picture.
+  ;; and orgin advance would be properties of the defined glyph.
+  (let ((display (glyph-set-display glyph-set)))
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderAddGlyphsFromPicture+)
+      (glyph-set glyph-set)
+      (picture picture)
+      (card16 width)
+      (card16 height)
+      (card16 x-origin)
+      (card16 y-origin)
+      (card16 x-advance)
+      (card16 y-advance)
+      (card16 x)
+      (card16 y))))
+
+;; untested
+(defun render-free-glyphs (glyph-set glyphs)
+  "This request removes glyphs from glyph-set. Each glyph must exist in glyph-set (else a Match error results)."
+  (let ((display (glyph-set-display glyph-set)))
+    (with-buffer-request (display (extension-opcode display "RENDER"))
+      (data +X-RenderFreeGlyphs+)
+      (glyph-set glyph-set)
+      ((sequence :format card32) glyphs))))
+
+
+#||
+;;; --------------------------------------------------------------------------------
+
+;; testing code:
+
+(defun x (op)
+  (let ((dpy (open-display "")))
+    (render-query-version dpy)
+    (unwind-protect
+         (let* ((win (screen-root (first (display-roots dpy))))
+                (display dpy)
+                (pf  (find-window-picture-format win))
+                (pm   (xlib:create-pixmap
+                       :depth (xlib:drawable-depth win)
+                       :drawable win :width 1 :height 1))
+                (pm.p  (render-create-picture pm
+                                              :format pf
+                                              :repeat :on))
+                (win.p (render-create-picture win :format pf))
+                (gs  (render-create-glyph-set (first
+                                               (find-matching-picture-formats
+                                                dpy
+                                                :alpha 8
+                                                :red-max 0
+                                                :green-max 0
+                                                :blue-max 0)))))
+           (xlib:clear-area win)
+           (render-fill-rectangle pm.p :src (list #xFFFF 0 0 0) 0 0 100 100)
+           (render-add-glyph gs 18
+                             :data (make-array (list 3 3)
+                                               :initial-contents '((255 000 000)
+                                                                   (000 255 000)
+                                                                   (000 000 255))
+                                               :element-type '(unsigned-byte 8))
+                             :x-advance 4
+                             :y-advance 0
+                             :x-origin 0
+                             :y-origin 0)
+           (let ((w 50)
+                 (h 50))
+             (let ((data (make-array (list h w) :element-type '(unsigned-byte 8) :initial-element 0)))
+               (dotimes (i w)
+                 (dotimes (j h)
+                   (setf (aref data i j) (* 3 i))))
+               (render-add-glyph gs 17
+                                 :data data
+                                 :x-advance (+ w 2)
+                                 :y-advance 0
+                                 :x-origin 0
+                                 :y-origin 0)))
+
+           (render-composite-glyphs-8 win.p gs pm.p
+                                      200 330
+                                      (vector 17 18 18 17 17 17 17 17 17 17)
+                                      :alu op
+                                      )
+                                      ;;
+           (display-finish-output dpy)
+           (close-display dpy)))))
+
+(defun z (op)
+  (let ((dpy (open-display "")))
+    (unwind-protect
+         (let* ((win (screen-root (first (display-roots dpy))))
+                (pic (render-create-picture win))
+                (fmt (first (find-matching-picture-formats
+                             dpy
+                             :red-min 8
+                             :green-min 8
+                             :blue-min 8
+                             :alpha-min 8)))
+                (px  (xlib:create-pixmap :width 256 :height 256 :depth (picture-format-depth fmt)
+                      :drawable win))
+                (px.pic (render-create-picture px :format fmt))
+                (px.gc (xlib:create-gcontext :drawable px)))
+           (xlib:clear-area win)
+           ;;
+           (render-fill-rectangle px.pic :src
+                                  (list #x8000 #x0000 #x8000 #xFFFF)
+                                  0 0 256 256)
+           ;; render-combine simply does not work
+           (render-combine :src pic pic px.pic
+                           350 350 350 350 0 0 256 256)
+           ;;
+           (render-fill-rectangle px.pic :over
+                                  (list #x8000 #x8000 #x8000 #x8000)
+                                  0 0 100 100)
+           (render-combine :src
+                           px.pic px.pic pic
+                           0 0 0 0 350 350
+                           256 256)
+           (render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800)
+           (display-finish-output dpy))
+      (close-display dpy))))
+
+;;; ----------------------------------------------------------------------------------------------------
+
+(defun y (op)
+  (let ((dpy (open-display "")))
+    (render-query-version dpy)
+    (unwind-protect
+         (let* ((win (screen-root (first (display-roots dpy))))
+                (pic
+                  (render-create-picture win))
+                (px  (xlib:create-pixmap :drawable win
+                      :width 256
+                      :height 256
+                      :depth 32))
+                (px.gc (xlib:create-gcontext :drawable px)))
+           (dotimes (x 256)
+             (dotimes (y 256)
+               (setf (xlib:gcontext-foreground px.gc)
+                     (dpb x (byte 8 24)
+                          (dpb y (byte 8 16)
+                               (dpb y (byte 8 8)
+                                    y))))
+               (xlib:draw-point px px.gc x y)
+               ))
+           (xlib:clear-area win)
+           (let ((q(render-create-picture px
+                                          :format
+                                          (first (find-matching-picture-formats
+                                                  dpy
+                                                  :depth 32
+                                                  :alpha 8 :red 8 :green 8 :blue 8))
+                                          :component-alpha :on
+                                          :repeat :off
+                                          )))
+             (render-combine op
+                             q
+                             q 
+                             pic
+                             0 0
+                             0 0
+                             100 100
+                             400 400))
+           (let ()
+             ;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200)
+             (display-finish-output dpy)))
+      (close-display dpy))))
+
+(defun zz ()
+  (let* ((dpy (xlib:open-display ""))
+        (win (screen-root (first (display-roots dpy))))
+        (pic (render-create-picture win)))
+    (xlib:clear-area win)
+    (setf (picture-clip-mask pic) (list 100 100 200 2000))
+    (render-fill-rectangle pic :over (list #xFFFF 0 0 #x400) 0 0 2000 2000)
+    (display-finish-output dpy)
+    (close-display dpy)))
+||#
+
+
+;;;; Cursors
+
+(defun render-create-cursor (picture &optional (x 0) (y 0))
+  (let ((display (picture-display picture)))
+    (ensure-render-initialized display)
+    (synchronise-picture-state picture)
+    (let* ((cursor (make-cursor :display display))
+           (cid (allocate-resource-id display cursor 'cursor)))
+      (setf (cursor-id cursor) cid)
+      (with-buffer-request (display (extension-opcode display "RENDER"))
+        (data +X-RenderCreateCursor+)
+        (resource-id cid)
+        (resource-id (picture-id picture))
+        (card16 x)
+        (card16 y))
+      cursor)))
diff --git a/clx/xvidmode.lisp b/clx/xvidmode.lisp
new file mode 100644
index 000000000..9f13d0f98
--- /dev/null
+++ b/clx/xvidmode.lisp
@@ -0,0 +1,733 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: XFree86 video mode extension
+;;;   Created: 2003 03 28 15:28
+;;;    Author: Iban Hatchondo <hatchond@labri.fr>
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2003 by Iban Hatchondo
+
+;;;
+;;; 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.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;;
+
+;;; THIS IS NOT AN X CONSORTIUM STANDARD OR AN X PROJECT TEAM SPECIFICATION
+
+;;; DESCRIPTION
+;;;
+;;; These functions provide an interface to the server extension 
+;;; XFree86-VidModeExtension which allows the video modes to be 
+;;; queried, adjusted dynamically and the mode switching to be 
+;;; controlled.
+
+;;; [ personal notes ]
+;;;
+;;; The documentation on this extension is very poor, probably,
+;;; because it is not an X standard nor an X project team spec.
+;;; Because of that, it need to be tested on some XFree 3.3.6,
+;;; and XFree 4.3.x to ensure that all request are correctly 
+;;; constructed as well as to indentify any obsolete/wrong 
+;;; functions I made.
+
+#+cmu
+(ext:file-comment "$Id: xvidmode.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+
+(in-package :xlib)
+
+(export '(mode-info
+	  mode-info-dotclock
+	  mode-info-hdisplay
+	  mode-info-hsyncstart
+	  mode-info-hsyncend
+	  mode-info-htotal
+	  mode-info-hskew
+	  mode-info-vdisplay
+	  mode-info-vsyncstart
+	  mode-info-vsyncend
+	  mode-info-vtotal
+	  mode-info-flags
+	  mode-info-privsize
+	  mode-info-private
+	  make-mode-info
+
+	  xfree86-vidmode-query-version
+	  xfree86-vidmode-set-client-version
+	  xfree86-vidmode-get-permissions
+	  xfree86-vidmode-mod-mode-line 
+	  xfree86-vidmode-get-mode-line 
+	  xfree86-vidmode-get-all-mode-lines
+	  xfree86-vidmode-add-mode-line
+	  xfree86-vidmode-delete-mode-line
+	  xfree86-vidmode-validate-mode-line
+	  xfree86-vidmode-get-gamma
+	  xfree86-vidmode-set-gamma
+	  xfree86-vidmode-get-gamma-ramp
+	  xfree86-vidmode-set-gamma-ramp     
+	  xfree86-vidmode-get-gamma-ramp-size
+	  xfree86-vidmode-lock-mode-switch
+	  xfree86-vidmode-switch-to-mode
+	  xfree86-vidmode-switch-mode
+	  xfree86-vidmode-select-next-mode
+	  xfree86-vidmode-select-prev-mode
+	  xfree86-vidmode-get-monitor
+	  xfree86-vidmode-get-viewport
+	  xfree86-vidmode-set-viewport
+	  xfree86-vidmode-get-dotclocks)
+	:xlib)
+
+;; current version numbers
+;;
+;; major 0 == uses parameter-to-wire functions in XFree86 libXxf86vm.
+;; major 1 == uses parameter-to-wire functions hard-coded in xvidtune client.
+;; major 2 == uses new protocol version in XFree86 4.0.
+(defconstant +xf86vidmode-major-version+ 2)
+(defconstant +xf86vidmode-minor-version+ 2)
+
+;; requests number.
+(defconstant +query-version+        0)
+(defconstant +get-mode-line+        1)
+(defconstant +mod-mode-line+        2)
+(defconstant +switch-mode+          3)
+(defconstant +get-monitor+          4)
+(defconstant +lock-mode-switch+     5)
+(defconstant +get-all-mode-lines+   6)
+(defconstant +add-mode-line+        7)
+(defconstant +delete-mode-line+     8)
+(defconstant +validate-mode-line+   9)
+(defconstant +switch-to-mode+      10)
+(defconstant +get-viewport+        11)
+(defconstant +set-viewport+        12)
+
+;; new for version 2.x of this extension.
+(defconstant +get-dot-clocks+      13)
+(defconstant +set-client-version+  14)
+(defconstant +set-gamma+           15)
+(defconstant +get-gamma+           16)
+(defconstant +get-gamma-ramp+      17)
+(defconstant +set-gamma-ramp+      18)
+(defconstant +get-gamma-ramp-size+ 19)
+(defconstant +get-permisions+      20)
+
+(define-extension "XFree86-VidModeExtension"
+  :events (:xfree86-vidmode-notify) 
+  :errors (xf86-vidmode-bad-clock 
+	   xf86-vidmode-bad-htimings 
+	   xf86-vidmode-bad-vtimings
+	   xf86-vidmode-mode-unsuitable
+	   xf86-vidmode-extension-disabled
+	   xf86-vidmode-client-not-local
+	   xf86-vidmode-zoom-locked))
+
+(define-condition xf86-vidmode-bad-clock (request-error) ())
+(define-condition xf86-vidmode-bad-htimings (request-error) ())
+(define-condition xf86-vidmode-bad-vtimings (request-error) ())
+(define-condition xf86-vidmode-mode-unsuitable (request-error) ())
+(define-condition xf86-vidmode-extension-disabled (request-error) ())
+(define-condition xf86-vidmode-client-not-local (request-error) ())
+(define-condition xf86-vidmode-zoom-locked (request-error) ())
+
+(define-error xf86-vidmode-bad-clock decode-core-error)
+(define-error xf86-vidmode-bad-htimings decode-core-error)
+(define-error xf86-vidmode-bad-vtimings decode-core-error)
+(define-error xf86-vidmode-mode-unsuitable decode-core-error)
+(define-error xf86-vidmode-extension-disabled decode-core-error)
+(define-error xf86-vidmode-client-not-local decode-core-error)
+(define-error xf86-vidmode-zoom-locked  decode-core-error)
+
+(declare-event :XFree86-VidMode-notify
+  (card16 sequence)
+  (window (window event-window)) ; the root window of event screen
+  (int16 state)                  ; what happend
+  (int16 kind)                   ; what happend
+  (boolean forced-p)             ; extents of a new region
+  ((or null card32) time))       ; event timestamp
+
+(defstruct mode-info
+  (dotclock 0 :type card32)
+  (hdisplay   0 :type card16)
+  (hsyncstart 0 :type card16)
+  (hsyncend   0 :type card16)
+  (htotal     0 :type card16)
+  (hskew      0 :type card32)
+  (vdisplay   0 :type card16)
+  (vsyncstart 0 :type card16)
+  (vsyncend   0 :type card16)
+  (vtotal     0 :type card16)
+  (flags      0 :type card32)
+  (privsize   0 :type card32)
+  (private    nil :type sequence))
+
+(defmacro vidmode-opcode (display)
+  `(extension-opcode ,display "XFree86-VidModeExtension"))
+
+(declaim (inline screen-position))
+(defun screen-position (screen display)
+  (declare (type display display)
+	   (type screen screen))
+  (declare (clx-values position))
+  (let ((position (position screen (xlib:display-roots display))))
+    (if (not (numberp position))
+	(error "screen ~A not found in display ~A" screen display)
+	position)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                                                                       ;;;;
+;;;;              public XFree86-VidMode Extension routines                ;;;;
+;;;;                                                                       ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun xfree86-vidmode-query-version (display)
+  "Determine the version of the extension built into the server.
+return two values major-version and minor-version in that order."
+  (declare (type display display))
+  (with-buffer-request-and-reply
+      (display (vidmode-opcode display) nil :sizes 16)
+    ((data +query-version+))
+   (let ((major (card16-get 8))
+	 (minor (card16-get 10)))
+     (declare (type card16 major minor))
+     (when (>= major 2)
+       (XFree86-VidMode-set-client-version display))
+     (values major minor))))
+
+(defun xfree86-vidmode-set-client-version (display)
+  (declare (type display display))
+  (with-buffer-request (display (vidmode-opcode display))
+    (data +set-client-version+)
+    (card16 +xf86vidmode-major-version+)
+    (card16 +xf86vidmode-minor-version+)))
+
+(defun xfree86-vidmode-get-permissions (dpy screen)
+  (declare (type display dpy)
+	   (type screen screen))
+  (with-buffer-request-and-reply
+      (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+    ((data +get-permisions+)
+     (card16 (screen-position screen dpy))
+     (card16 0))
+   (values 
+    (card32-get 8))))
+
+(defun xfree86-vidmode-mod-mode-line (display screen mode-line)
+  "Change the settings of the current video mode provided the 
+requested settings are valid (e.g. they don't exceed the 
+capabilities of the monitor)."
+  (declare (type display display)
+	   (type screen screen))
+  (let* ((major (xfree86-vidmode-query-version display))
+	 (v (mode-info->v-card16 mode-line major)))
+    (declare (type card16 major)
+	     (type simple-vector v))
+    (with-buffer-request (display (vidmode-opcode display))
+      (data +mod-mode-line+)
+      (card32 (screen-position screen display))
+      ((sequence :format card16 :start 2) v))))
+
+(defun xfree86-vidmode-get-mode-line (display screen)
+  "Query the settings for the currently selected video mode.
+return a mode-info structure fields with the server answer.
+If there are any server  private  values (currently  only 
+applicable  to  the S3 server) the function will store it 
+into the returned structure."
+  (declare (clx-values mode-info)
+	   (type display display)
+	   (type screen screen))
+  (let ((major (xfree86-vidmode-query-version display))
+	(offset 8))
+    (declare (type fixnum offset)
+	     (type card16 major))    
+    (with-buffer-request-and-reply
+        (display (vidmode-opcode display) nil :sizes (8 16 32))
+      ((data +get-mode-line+)
+       (card16 (screen-position screen display))
+       (card16 0))
+     (let ((mode-info 
+	    (make-mode-info
+	        :dotclock (card32-get offset)
+		:hdisplay (card16-get (incf offset 4))
+		:hsyncstart (card16-get (incf offset 2))
+		:hsyncend (card16-get (incf offset 2))
+		:htotal (card16-get (incf offset 2))
+		:hskew (if (< major 2) 0 (card16-get (incf offset 2)))
+		:vdisplay (card16-get (incf offset 2))
+		:vsyncstart (card16-get (incf offset 2))
+		:vsyncend (card16-get (incf offset 2))
+		:vtotal (card16-get (incf offset 2))
+		:flags (card32-get (incf offset (if (< major 2) 2 4)))))
+	   (size (card32-get (incf offset (if (< major 2) 4 16)))))
+       (declare (type card32 size))
+       (incf offset 4)
+       (setf (mode-info-privsize mode-info) size
+	     (mode-info-private mode-info)
+	     (sequence-get :format card32 :index offset
+			   :length size :result-type 'list))
+       mode-info))))
+
+(defun xfree86-vidmode-get-all-mode-lines (dpy screen)
+  "Returns a list containing all video modes (as mode-info structure). 
+The first element of the list corresponds to the current video mode."
+  (declare (type display dpy)
+	   (type screen screen))
+  (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy)
+    (declare (type card16 major minor))
+    (with-buffer-request-and-reply 
+        (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+      ((data +get-all-mode-lines+)
+       (card16 (screen-position screen dpy)))
+     (values 
+      ;; Note: There was a bug in the protocol implementation in versions
+      ;; 0.x with x < 8 (the .private field wasn't being passed over the wire).
+      ;; Check the server's version, and accept the old format if appropriate.
+      (loop with bug-p = (and (= major 0) (< minor 8))
+	    with offset of-type fixnum = 32
+            for i of-type card32 from 0 below (or (card32-get 8) 0)
+	    collect
+	     (let ((mode-info
+		    (make-mode-info
+		       :dotclock (card32-get offset)
+		       :hdisplay (card16-get (incf offset 4))
+		       :hsyncstart (card16-get (incf offset 2))
+		       :hsyncend (card16-get (incf offset 2))
+		       :htotal (card16-get (incf offset 2))
+		       :hskew (if (< major 2) 0 (card32-get (incf offset 2)))
+		       :vdisplay (card16-get (incf offset 4))
+		       :vsyncstart (card16-get (incf offset 2))
+		       :vsyncend (card16-get (incf offset 2))
+		       :vtotal (card16-get (incf offset 2))
+		       :flags (card32-get (incf offset (if (< major 2) 2 6)))))
+		   (size (card32-get (incf offset (if (< major 2) 4 16)))))
+		(declare (type card32 size))
+		(incf offset 4)
+		(when bug-p 
+		  (setf size 0))
+		(setf (mode-info-privsize mode-info) size
+		      (mode-info-private mode-info)
+		      (sequence-get :format card32 :index offset
+				    :length size :result-type 'list))
+		(incf offset (* 4 size))
+		mode-info))))))
+
+(defun xfree86-vidmode-add-mode-line (dpy scr new &key (after (make-mode-info)))
+  (declare (type display dpy)
+	   (type screen scr))
+  (let* ((private (mode-info-private new))
+	 (privsize (mode-info-privsize new))
+	 (major (xfree86-vidmode-query-version dpy))
+	 (i (if (< major 2) 14 22))
+	 (v (make-array (- (+ (* 2 i) (* 2 privsize)) 2) :initial-element 0)))
+    (declare (type card32 privsize)
+	     (type fixnum i)
+	     (type card16 major)
+	     (type simple-vector v))
+    (mode-info->v-card16 new major :encode-private nil :data v)
+    (mode-info->v-card16 after major :encode-private nil :data v :index i)
+    (setf i (- (* 2 i) 2))
+    ;; strore private info (sequence card32) according clx bytes order.
+    (loop for card of-type card32 in private
+	  do (multiple-value-bind (w1 w2) (__card32->card16__ card)
+	       (setf (svref v (incf i)) w1
+		     (svref v (incf i)) w2)))
+    
+    (with-buffer-request (dpy (vidmode-opcode dpy))
+      (data +add-mode-line+)
+      (card32 (screen-position scr dpy))
+      ((sequence :format card16) v))))
+
+(defun xfree86-vidmode-delete-mode-line (dpy scr mode-info)
+  "Delete mode argument. The specified mode must match an existing mode. 
+To be considered a match, all of the fields of the given mode-info 
+structure must match, except the privsize and private fields. 
+If the mode to be deleted is the current mode, a mode switch to the next 
+mode will occur first. The last remaining mode can not be deleted."
+  (declare (type display dpy)
+	   (type screen scr))
+  (let* ((major (xfree86-vidmode-query-version dpy))
+	 (v (mode-info->v-card16 mode-info major)))
+    (declare (type card16 major)
+	     (type simple-vector v))
+    (with-buffer-request (dpy (vidmode-opcode dpy))
+      (data +delete-mode-line+)
+      (card32 (screen-position scr dpy))
+      ((sequence :format card16) v))))
+
+(defconstant +mode-status+
+  '#(:MODE_BAD             ; unspecified reason 
+     :MODE_ERROR           ; error condition 
+     :MODE_OK              ; Mode OK 
+     :MODE_HSYNC           ; hsync out of range 
+     :MODE_VSYNC           ; vsync out of range 
+     :MODE_H_ILLEGAL       ; mode has illegal horizontal timings 
+     :MODE_V_ILLEGAL       ; mode has illegal horizontal timings 
+     :MODE_BAD_WIDTH       ; requires an unsupported linepitch 
+     :MODE_NO_MODE         ; no mode with a maching name 
+     :MODE_NO_INTERLACE    ; interlaced mode not supported 
+     :MODE_NO_DBLESCAN     ; doublescan mode not supported 
+     :MODE_NO_VSCAN        ; multiscan mode not supported 
+     :MODE_MEM             ; insufficient video memory 
+     :MODE_VIRTUAL_X       ; mode width too large for specified virtual size 
+     :MODE_VIRTUAL_Y       ; mode height too large for specified virtual size 
+     :MODE_MEM_VIRT        ; insufficient video memory given virtual size 
+     :MODE_NOCLOCK         ; no fixed clock available 
+     :MODE_CLOCK_HIGH      ; clock required is too high 
+     :MODE_CLOCK_LOW       ; clock required is too low 
+     :MODE_CLOCK_RANGE     ; clock/mode isn't in a ClockRange 
+     :MODE_BAD_HVALUE      ; horizontal timing was out of range 
+     :MODE_BAD_VVALUE      ; vertical timing was out of range 
+     :MODE_BAD_VSCAN       ; VScan value out of range 
+     :MODE_HSYNC_NARROW    ; horizontal sync too narrow 
+     :MODE_HSYNC_WIDE      ; horizontal sync too wide 
+     :MODE_HBLANK_NARROW   ; horizontal blanking too narrow 
+     :MODE_HBLANK_WIDE     ; horizontal blanking too wide 
+     :MODE_VSYNC_NARROW    ; vertical sync too narrow 
+     :MODE_VSYNC_WIDE      ; vertical sync too wide 
+     :MODE_VBLANK_NARROW   ; vertical blanking too narrow 
+     :MODE_VBLANK_WIDE     ; vertical blanking too wide 
+     :MODE_PANEL           ; exceeds panel dimensions 
+     :MODE_INTERLACE_WIDTH ; width too large for interlaced mode 
+     :MODE_ONE_WIDTH       ; only one width is supported 
+     :MODE_ONE_HEIGHT      ; only one height is supported 
+     :MODE_ONE_SIZE        ; only one resolution is supported 
+     ))
+
+(defun decode-status-mode (status)
+  (declare (type int32 status))
+  (svref +mode-status+ (+ status 2)))
+
+(defun xfree86-vidmode-validate-mode-line (dpy scr mode-info)
+  "Checked the validity of a mode-info argument. If the specified mode can be 
+used by the server (i.e. meets all the constraints placed upon a mode by the 
+combination of the server, card, and monitor) the function returns :mode_ok
+otherwise it returns a keyword indicating  the  reason why the mode is 
+invalid."
+  (declare (type display dpy)
+	   (type screen scr))
+  (let* ((major (xfree86-vidmode-query-version dpy))
+	 (v (mode-info->v-card16 mode-info major)))
+    (declare (type card16 major)
+	     (type simple-vector v))
+    (with-buffer-request-and-reply
+        (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+      ((data +validate-mode-line+)
+       (card32 (screen-position scr dpy))
+       ((sequence :format card16) v))
+     (let ((status (integer-get 8)))
+       (declare (type int32 status))
+       (when status (decode-status-mode status))))))
+
+(defun xfree86-vidmode-get-gamma (display screen)
+  (declare (type display display)
+	   (type screen screen))
+  (with-buffer-request-and-reply 
+      (display (vidmode-opcode display) nil :sizes (8 16 32))
+    ((data +get-gamma+)
+     (card16 (screen-position screen display))
+     (card16 0)
+     (card32 0) (card32 0)
+     (card32 0) (card32 0)
+     (card32 0) (card32 0))
+   (values 
+    (/ (the card32 (or (card32-get 8) 0)) 10000.0)
+    (/ (the card32 (or (card32-get 12) 0)) 10000.0)
+    (/ (the card32 (or (card32-get 16) 0)) 10000.0))))
+
+(defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0))
+  (declare (type display dpy)
+	   (type screen scr)
+	   (type (single-float 0.100 10.000) red green blue))
+  (with-buffer-request (dpy (vidmode-opcode dpy))
+    (data +set-gamma+)
+    (card16 (screen-position scr dpy))
+    (card16 0)
+    (card32 (truncate (* red 10000)))
+    (card32 (truncate (* green 10000)))
+    (card32 (truncate (* blue 10000)))
+    (card32 0) 
+    (card32 0)
+    (card32 0)))
+
+(defun xfree86-vidmode-get-gamma-ramp (dpy scr size)
+  (declare (type display dpy)
+	   (type screen scr)
+	   (type card16 size))
+  (with-buffer-request-and-reply (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+    ((data +get-gamma-ramp+)
+     (card16 (screen-position scr dpy))
+     (card16 size))
+   (let ((rep-size (* (the card16 (or (card16-get 8) 0)) 2)))
+     (declare (type fixnum rep-size))
+     (unless (zerop rep-size)
+       (let* ((off1 (+ 32 rep-size (* 2 (mod rep-size 2))))
+	      (off2 (+ off1 rep-size (* 2 (mod rep-size 2)))))
+	 (declare (type fixnum off1 off2))
+	 (values
+	  (sequence-get :format card16 :length (card16-get 8)
+			:index 32 :result-type 'list)
+	  (sequence-get :format card16 :length (card16-get 8)
+			:index off1 :result-type 'list)
+	  (sequence-get :format card16 :length (card16-get 8)
+			:index off2 :result-type 'list)))))))
+
+(defun xfree86-vidmode-set-gamma-ramp (dpy scr size &key red green blue)
+  (declare (type (or null simple-vector) red green blue)
+	   (type card16 size)
+	   (type display dpy)
+	   (type screen scr))
+  (with-buffer-request (dpy (vidmode-opcode dpy))
+    (data +set-gamma-ramp+)
+    (card16 (screen-position scr dpy))
+    (card16 size)
+    ((sequence :format card16) 
+     (if (zerop (mod size 2))
+	 (concatenate 'vector red green blue)
+         (concatenate 'vector red '#(0) green '#(0) blue '#(0))))))
+
+(defun xfree86-vidmode-get-gamma-ramp-size (dpy screen)
+  (declare (type display dpy)
+	   (type screen screen))
+  (with-buffer-request-and-reply 
+      (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+    ((data +get-gamma-ramp-size+)
+     (card16 (screen-position screen dpy))
+     (card16 0))
+    (card16-get 8)))
+
+(defun xfree86-vidmode-lock-mode-switch (display screen lock-p)
+  "Allow or disallow mode switching whether the request to switch
+modes comes from a call to the mode switching functions or from one 
+of the mode switch key sequences (e.g. Ctrl-Alt-+ Ctrl-Alt--)."
+  (declare (type display display)
+	   (type screen screen)
+	   (type boolean lock-p))
+  (with-buffer-request (display (vidmode-opcode display))
+    (data +lock-mode-switch+)
+    (card16 (screen-position screen display))
+    (card16 (if lock-p 1 0))))
+
+(defun xfree86-vidmode-switch-to-mode (display screen mode-info)
+  "Switch directly to the specified mode. The specified mode must match 
+an existing mode. Matching is as specified in the description of the 
+xf86-vidmode-delete-mode-line function."
+  (declare (type display display)
+	   (type screen screen))
+  (multiple-value-bind (major minor) (xfree86-vidmode-query-version display)
+    (declare (type card16 major minor))
+    ;; Note: There was a bug in the protocol implementation in versions
+    ;; 0.x with x < 8 (the .private field wasn't being passed over the wire).
+    ;; Check the server's version, and accept the old format if appropriate.
+    (let ((bug-p (and (= major 0) (< minor 8)))
+	  (privsize (mode-info-privsize mode-info)))
+      (declare (type boolean bug-p))
+      (and bug-p (setf (mode-info-privsize mode-info) 0))
+      (let ((v (mode-info->v-card16 mode-info major :encode-private bug-p)))
+	(declare (type simple-vector v))
+	(and bug-p (setf (mode-info-privsize mode-info) privsize))
+	(with-buffer-request (display (vidmode-opcode display))
+	  (data +switch-to-mode+)
+	  (card32 (screen-position screen display))
+	  ((sequence :format card16) v))))))
+
+(defun xfree86-vidmode-switch-mode (display screen zoom)
+  "Change the video mode to next (or previous) video mode, depending 
+of zoom sign. If positive, switch to next mode, else switch to prev mode."
+  (declare (type display display)
+	   (type screen screen)
+	   (type card16 zoom))
+  (with-buffer-request (display (vidmode-opcode display))
+    (data +switch-mode+)
+    (card16 (screen-position screen display))
+    (card16 zoom)))
+
+(defun xfree86-vidmode-select-next-mode (display screen)
+  "Change the video mode to next video mode"
+  (declare (type display display)
+	   (type screen screen))
+  (with-buffer-request (display (vidmode-opcode display))
+    (data +switch-mode+)
+    (card16 (screen-position screen display))
+    (card16 1)))
+
+(defun xfree86-vidmode-select-prev-mode (display screen)
+  "Change the video mode to previous video mode"
+  (declare (type display display)
+	   (type screen screen))
+  (with-buffer-request (display (vidmode-opcode display))
+    (data +switch-mode+)
+    (card16 (screen-position screen display))
+    (card16 #xFFFF)))
+
+(defun xfree86-vidmode-get-monitor (dpy screen)
+  "Information known to the server about the monitor is returned. 
+Multiple value return:
+ hsync (list of hi, low, ...)
+ vsync (list of hi, low, ...)
+ vendor name
+ model name 
+
+The hi and low values will be equal if a discreate value was given 
+in the XF86Config file."
+  (declare (type display dpy)
+	   (type screen screen))
+  (with-buffer-request-and-reply
+      (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+    ((data +get-monitor+)
+     (card16 (screen-position screen dpy))
+     (card16 0))
+   (let* ((vendor-name-length (card8-get 8))
+	  (model-name-length (card8-get 9))
+	  (pad (- 4 (mod vendor-name-length 4)))
+	  (nhsync (card8-get 10))
+	  (nvsync (card8-get 11))
+	  (vindex (+ 32 (* 4 (+ nhsync nvsync))))
+	  (mindex (+ vindex vendor-name-length pad))
+	  (hsync (sequence-get :length nhsync :index 32 :result-type 'list))
+	  (vsync (sequence-get :length nvsync :index (+ 32 (* nhsync 4))
+			       :result-type 'list)))
+     (declare (type card8 nhsync nvsync vendor-name-length model-name-length)
+	      (type fixnum pad vindex mindex))
+     (values 
+      (loop for i of-type card32 in hsync
+	    collect (/ (ldb (byte 16 0) i) 100.)
+	    collect (/ (ldb (byte 32 16) i) 100.))
+      (loop for i of-type card32 in vsync
+	    collect (/ (ldb (byte 16 0) i) 100.)
+	    collect (/ (ldb (byte 32 16) i) 100.))
+      (string-get vendor-name-length vindex)
+      (string-get model-name-length mindex)))))
+
+(defun xfree86-vidmode-get-viewport (dpy screen)
+  "Query the location of the upper left corner of the viewport into 
+the virtual screen. The upper left coordinates will be returned as 
+a multiple value."
+  (declare (type display dpy)
+	   (type screen screen))
+  (multiple-value-bind (major minor) (xfree86-vidmode-query-version dpy)
+    (declare (type card16 major minor))
+    ;; Note: There was a bug in the protocol implementation in versions
+    ;; 0.x with x < 8 (no reply was sent, so the client would hang)
+    ;; Check the server's version, and don't wait for a reply with older
+    ;; versions.
+    (when (and (= major 0) (< minor 8))
+      (format cl:*error-output* 
+	      "running an old version ~a ~a~%"
+	      major minor)
+      (return-from xfree86-vidmode-get-viewport nil))
+    (with-buffer-request-and-reply 
+	(dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+      ((data +get-viewport+)
+       (card16 (screen-position screen dpy))
+       (card16 0))
+     (values
+      (card32-get 8)
+      (card32-get 12)))))
+       
+(defun xfree86-vidmode-set-viewport (dpy screen &key (x 0) (y 0))
+  "Set upper left corner of the viewport into the virtual screen to the 
+x and y keyword parameters value (zero will be theire default value)."
+  (declare (type display dpy)
+	   (type screen screen)
+	   (type card32 x y))
+  (with-buffer-request (dpy (vidmode-opcode dpy))
+    (data +set-viewport+)
+    (card16 (screen-position screen dpy))
+    (card16 0)
+    (card32 x)
+    (card32 y)))
+
+(defun xfree86-vidmode-get-dotclocks (dpy screen)
+  "Returns as a multiple value return the server dotclock informations:
+ flags
+ maxclocks
+ clock list"
+  (declare (type display dpy)
+	   (type screen screen))
+  (with-buffer-request-and-reply 
+      (dpy (vidmode-opcode dpy) nil :sizes (8 16 32))
+    ((data +get-dot-clocks+)
+     (card16 (screen-position screen dpy))
+     (card16 0))
+   (values
+    (card32-get 8)  ; flags
+    (card32-get 16) ; max clocks
+    (sequence-get :length (card32-get 12) :format card32
+		  :index 32 :result-type 'list))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;                                                                       ;;;;
+;;;;                       private utility routines                        ;;;;
+;;;;                                                                       ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun mode-info->v-card16
+    (mode-info major &key (encode-private t) (index 0) data)
+  (declare (type integer index)
+	   (type card16 major)
+	   (type boolean encode-private)
+	   (type (or null simple-vector) data))
+  (let ((dotclock (mode-info-dotclock mode-info))
+	(hdisplay (mode-info-hdisplay mode-info))
+	(hsyncstart (mode-info-hsyncstart mode-info))
+	(hsyncend (mode-info-hsyncend mode-info))
+	(htotal (mode-info-htotal mode-info))
+	(hskew (mode-info-hskew mode-info))
+	(vdisplay (mode-info-vdisplay mode-info))
+	(vsyncstart (mode-info-vsyncstart mode-info))
+	(vsyncend (mode-info-vsyncend mode-info))
+	(vtotal (mode-info-vtotal mode-info))
+	(flags (mode-info-flags mode-info))
+	(privsize (mode-info-privsize mode-info))
+	(private (mode-info-private mode-info)))
+    (declare (type card16 hdisplay hsyncstart hsyncend htotal hskew)
+	     (type card16 vdisplay vsyncstart vsyncend vtotal)
+	     (type card32 dotclock flags privsize)
+	     (type (or null sequence) private))
+    (let* ((size (+ (if (< major 2) 14 22) (* privsize 2)))
+	   (v (or data (make-array size :initial-element 0))))      
+      (declare (type fixnum size)
+	       (type simple-vector v))
+      ;; store dotclock (card32) according clx bytes order.
+      (multiple-value-bind (w1 w2) (__card32->card16__ dotclock)
+	(setf (svref v index) w1
+	      (svref v (incf index)) w2))
+      (setf (svref v (incf index)) hdisplay
+	    (svref v (incf index)) hsyncstart
+	    (svref v (incf index)) hsyncend
+	    (svref v (incf index)) htotal)
+      (unless (< major 2)
+	(setf (svref v (incf index)) hskew))
+      (setf (svref v (incf index)) vdisplay
+	    (svref v (incf index)) vsyncstart
+	    (svref v (incf index)) vsyncend
+	    (svref v (incf index)) vtotal)
+      (unless (< major 2)
+	(incf index))
+      ;; strore flags (card32) according clx bytes order.
+      (multiple-value-bind (w1 w2) (__card32->card16__ flags)
+	(setf (svref v (incf index)) w1
+	      (svref v (incf index)) w2))
+      ;; strore privsize (card32) according clx bytes order.
+      (multiple-value-bind (w1 w2) (__card32->card16__ privsize)
+	(setf (svref v (incf index)) w1
+	      (svref v (incf index)) w2))
+      ;; reserverd byte32 1 2 3
+      (unless (< major 2) (incf index 6))
+      ;; strore private info (sequence card32) according clx bytes order.
+      (when encode-private
+	(loop for i of-type int32 in private
+	      do (multiple-value-bind (w1 w2) (__card32->card16__ i)
+		   (setf (svref v (incf index)) w1
+			 (svref v (incf index)) w2))))
+      v)))
+
+(declaim (inline __card32->card16__))
+(defun __card32->card16__ (i)
+  (declare (type card32 i))
+  #+clx-little-endian
+  (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i)))
+  #-clx-little-endian
+  (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i))))
-- 
GitLab