diff --git a/clx/CHANGES b/clx/CHANGES
index f666fdff88dc6cbca78e54a546c9aee0abf6f6f8..0171f5678e86bdd89374425a129bf05c9ec15c60 100644
--- a/clx/CHANGES
+++ b/clx/CHANGES
@@ -1,4 +1,4 @@
-$Id: CHANGES,v 1.6 2007/08/21 15:49:27 fgilham Exp $
+$Id: CHANGES,v 1.7 2009/06/17 18:22:45 rtoy Rel $
 
 Details of changes since R5:
 
diff --git a/clx/NEWS b/clx/NEWS
index 20aa5ac9dab7136af6134a80cc9da4eb118edaf1..53e339902d5b1c814d84861d1808f3ea0776dd56 100644
--- a/clx/NEWS
+++ b/clx/NEWS
@@ -1,11 +1,11 @@
 -*- Text -*-
-$Id: NEWS,v 1.2 2009/06/11 16:03:56 rtoy Exp $
+$Id: NEWS,v 1.3 2009/06/17 18:22:45 rtoy Rel $
 -- 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 type (Douglas Crosher)
+Define a RENDER-OP typ (Douglas Crosher)
 
 ---  Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 ---
 
@@ -56,7 +56,7 @@ 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 manager, that uses very large hint values.
+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
@@ -69,7 +69,7 @@ Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS*
 
 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 undesirable performance
+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
@@ -150,7 +150,7 @@ Implement CLX MP dependencies for SBCL: HOLDING-LOCK, PROCESS-BLOCK, etc
 
 Many bug fixes
 
- * asking for text extents on uncached fonts could potentially deadlock
+ * 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
@@ -160,5 +160,6 @@ 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.
+ *  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
index aa4cab7fa830dbc7b5324e123e7bb28d55f1b5ae..c24dc6853d740e5bc9f6dd75a7bbc908cd543fb8 100644
--- a/clx/README
+++ b/clx/README
@@ -1,4 +1,4 @@
-$Id: README,v 1.5 2009/06/11 16:03:56 rtoy Exp $
+$Id: README,v 1.6 2009/06/17 18:22:45 rtoy Rel $
 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
@@ -38,7 +38,7 @@ 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?
+          http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor?
 
 = Building using asdf-install
 
diff --git a/clx/README-R5 b/clx/README-R5
index d6e7b895f6d905614aff194fc24c44b38446da99..85440b539768c21f7347aa7530ffcce383b2de30 100644
--- a/clx/README-R5
+++ b/clx/README-R5
@@ -1,4 +1,4 @@
-$Id: README-R5,v 1.1 2007/08/21 15:49:27 fgilham Exp $
+$Id: README-R5,v 1.2 2009/06/17 18:22:45 rtoy Rel $
 Original CLX README, retained for historical information
 
 --- 
diff --git a/clx/attributes.lisp b/clx/attributes.lisp
index ae042013907574fa5733dfc6f204aedf97445540..c4a92d023f48eed19512595746af1a617d12693e 100644
--- a/clx/attributes.lisp
+++ b/clx/attributes.lisp
@@ -41,7 +41,7 @@
 ;;;	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 $")
+(ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -69,14 +69,14 @@
 (defmacro state-geometry-changes (state) `(fifth ,state))
  
 (defmacro drawable-equal-function ()
-  (if (member 'drawable +clx-cached-types+)
-      ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
-    ''drawable-equal))
+  ;; Since drawables are not always cached, we must use drawable-equal
+  ;; to determine equality.
+  ''drawable-equal)
 
 (defmacro window-equal-function ()
-  (if (member 'window +clx-cached-types+)
-      ''eq
-    ''drawable-equal))
+  ;; Since windows are not always cached, we must use window-equal
+  ;; to determine equality.
+  ''window-equal)
 
 (defmacro with-state ((drawable) &body body)
   ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
@@ -498,8 +498,13 @@
   (declare (clx-values (or null colormap)))
   (with-attributes (window :sizes 32)
     (let ((id (resource-id-get 28)))
-      (if (zerop id) nil
-	(lookup-colormap (window-display window) id)))))
+      (if (zerop id)
+	  nil
+	  (let ((colormap (lookup-colormap (window-display window) id)))
+	    (unless (colormap-visual-info colormap)
+	      (setf (colormap-visual-info colormap)
+		    (visual-info (window-display window) (resource-id-get 8))))
+	    colormap)))))
 
 (defun set-window-colormap (window colormap)
   (change-window-attribute
diff --git a/clx/big-requests.lisp b/clx/big-requests.lisp
index 882691e6a13edb76058874d17154bfd8102a9500..a854866a350479932e228110cf3f2bc99ccfb50b 100644
--- a/clx/big-requests.lisp
+++ b/clx/big-requests.lisp
@@ -13,7 +13,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package "XLIB")
 
diff --git a/clx/buffer.lisp b/clx/buffer.lisp
index f79f2b5cbf58d766314e73bdc754de3ae4b52e32..a5a38889658d2002da194d2611999bae236cf621 100644
--- a/clx/buffer.lisp
+++ b/clx/buffer.lisp
@@ -50,7 +50,7 @@
 ;;     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 $")
+(ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/bufmac.lisp b/clx/bufmac.lisp
index 471fe8ebe117860dac158b33bdc5308dbaab14d1..a2cbcd938d64f09ea781f96917766ca6e40a1ff5 100644
--- a/clx/bufmac.lisp
+++ b/clx/bufmac.lisp
@@ -20,7 +20,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: bufmac.lisp,v 1.5 2007/08/21 15:49:27 fgilham Exp $")
+(ext:file-comment "$Id: bufmac.lisp,v 1.6 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/build-clx.lisp b/clx/build-clx.lisp
index a280963f9767f11a2b3828b6ccc5d5c20da1afc1..cb8ccddaa149d397a915d60f6d83af6ad8cee811 100644
--- a/clx/build-clx.lisp
+++ b/clx/build-clx.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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 $")
+(ext:file-comment "$Id: build-clx.lisp,v 1.5 2009/06/17 18:22:45 rtoy Rel $")
 
 ;;; Load this file if you want to compile CLX in its entirety.
 (proclaim '(optimize (speed 3) (safety 1) (space 1)
diff --git a/clx/clx-module.lisp b/clx/clx-module.lisp
index da96ee216a81535358a1fecd1a09ebfbf94728ce..903e1ef2222e1157a24cb7e23e2a9d6d868de6dd 100644
--- a/clx/clx-module.lisp
+++ b/clx/clx-module.lisp
@@ -2,7 +2,7 @@
 ;;;(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 $")
+(ext:file-comment "$Id: clx-module.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
 
 (provide :clx)
 (load "clx:defsystem.lisp")
diff --git a/clx/clx.asd b/clx/clx.asd
new file mode 100644
index 0000000000000000000000000000000000000000..a1ad6fbef6876e3016b4b229510c6dcf9a05d287
--- /dev/null
+++ b/clx/clx.asd
@@ -0,0 +1,216 @@
+;;; -*- Lisp -*- mode
+
+;;; Original copyright message from defsystem.lisp:
+
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
+;;; Portions 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.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is"
+;;; without express or implied warranty.
+;;;
+;;; Franz Incorporated provides this software "as is" without express
+;;; or implied warranty.
+
+(defpackage :clx-system (:use :cl :asdf))
+(in-package :clx-system)  
+
+(pushnew :clx-ansi-common-lisp *features*)
+
+(defclass clx-source-file (cl-source-file) ())
+(defclass xrender-source-file (clx-source-file) ())
+
+;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of
+;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-)
+(defclass example-source-file (cl-source-file) ())
+
+(defclass legacy-file (static-file) ())
+
+(defsystem CLX
+    :depends-on (#+sbcl sb-bsd-sockets)
+    :version "0.7.2"
+    :serial t
+    :default-component-class clx-source-file
+    :components
+    ((:file "package")
+     (:file "depdefs")
+     (:file "clx")
+     #-(or openmcl allegro) (:file "dependent")
+     #+openmcl (:file "dep-openmcl")
+     #+allegro (:file "dep-allegro")
+     (:file "macros")
+     (:file "bufmac")
+     (:file "buffer")
+     (:file "display")
+     (:file "gcontext")
+     (:file "input")
+     (:file "requests")
+     (:file "fonts")
+     (:file "graphics")
+     (:file "text")
+     (:file "attributes")
+     (:file "translate")
+     (:file "keysyms")
+     (:file "manager")
+     (:file "image")
+     (:file "resource")
+     #+allegro
+     (:file "excldep" :pathname "excldep.lisp")
+     (:module extensions
+	      :pathname #.(make-pathname :directory '(:relative))
+	      :components
+	      ((:file "shape")
+	       (:file "big-requests")
+	       (:file "xvidmode")
+	       (:xrender-source-file "xrender")
+               (:file "glx")
+               (:file "gl" :depends-on ("glx"))
+	       (:file "dpms")
+               (:file "xtest")
+               (:file "screensaver")
+               (:file "xinerama")))
+     (:module demo
+	      :default-component-class example-source-file
+	      :components
+	      ((:file "bezier")
+	       ;; KLUDGE: this requires "bezier" for proper operation,
+	       ;; but we don't declare that dependency here, because
+	       ;; asdf doesn't load example files anyway.
+	       (:file "beziertest")
+	       (:file "clclock")
+               (:file "clipboard")
+	       (:file "clx-demos")
+	       (:file "gl-test")
+	       ;; FIXME: compiling this generates 30-odd spurious code
+	       ;; deletion notes.  Find out why, and either fix or
+	       ;; workaround the problem.
+	       (:file "mandel")
+	       (:file "menu")
+	       (:file "zoid")))
+     (:module test
+	      :default-component-class example-source-file
+	      :components
+	      ((:file "image")
+	       ;; KLUDGE: again, this depends on "zoid"
+	       (:file "trapezoid")))
+     (:static-file "NEWS")
+     (:static-file "CHANGES")
+     (:static-file "README")
+     (:static-file "README-R5")
+     (:legacy-file "exclMakefile")
+     (:legacy-file "exclREADME")
+     (:legacy-file "exclcmac" :pathname "exclcmac.lisp")
+     (:legacy-file "excldepc" :pathname "excldep.c")
+     (:legacy-file "sockcl" :pathname "sockcl.lisp")
+     (:legacy-file "socket" :pathname "socket.c")
+     (:legacy-file "defsystem" :pathname "defsystem.lisp")
+     (:legacy-file "provide" :pathname "provide.lisp")
+     (:legacy-file "cmudep" :pathname "cmudep.lisp")
+     (:module manual
+	      ;; TODO: teach asdf how to process texinfo files
+	      :components ((:static-file "clx.texinfo")))
+     (:module debug
+	      :default-component-class legacy-file
+	      :components
+	      ((:file "debug" :pathname "debug.lisp")
+	       (:file "describe" :pathname "describe.lisp")
+	       (:file "event-test" :pathname "event-test.lisp")
+	       (:file "keytrans" :pathname "keytrans.lisp")
+	       (:file "trace" :pathname "trace.lisp")
+	       (:file "util" :pathname "util.lisp")))))
+
+(defmethod perform ((o load-op) (f example-source-file))
+  ;; do nothing.  We want to compile them when CLX is compiled, but
+  ;; not load them when CLX is loaded.
+  t)
+
+#+sbcl
+(defmethod perform :around ((o compile-op) (f xrender-source-file))
+  ;; RENDER would appear to be an inherently slow protocol; further,
+  ;; it's not set in stone, and consequently we care less about speed
+  ;; than we do about correctness.
+  (handler-bind ((sb-ext:compiler-note #'muffle-warning))
+    (call-next-method)))
+
+#+sbcl
+(defmethod perform :around ((o compile-op) (f clx-source-file))
+  ;; our CLX library should compile without WARNINGs, and ideally
+  ;; without STYLE-WARNINGs.  Since it currently does, let's enforce
+  ;; it here so that we can catch regressions easily.
+  (let ((on-warnings (operation-on-warnings o))
+	(on-failure (operation-on-failure o)))
+    (unwind-protect
+	 (progn
+	   (setf (operation-on-warnings o) :error
+		 (operation-on-failure o) :error)
+	   ;; a variety of accessors, such as AREF-CARD32, are not
+	   ;; declared INLINE.  Without this (non-ANSI)
+	   ;; static-type-inference behaviour, SBCL emits an extra 100
+	   ;; optimization notes (roughly one fifth of all of the
+	   ;; notes emitted).  Since the internals are unlikely to
+	   ;; change much, and certainly the internals should stay in
+	   ;; sync, enabling this extension is a win.  (Note that the
+	   ;; use of this does not imply that applications using CLX
+	   ;; calls that expand into calls to these accessors will be
+	   ;; optimized in the same way).
+	   (let ((sb-ext:*derive-function-types* t)
+                 (sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
+                 (sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
+	     ;; deeply unportable stuff, this.  I will be shot.  We
+	     ;; want to enable the dynamic-extent declarations in CLX.
+	     (when (and sadx (sb-c::policy-quality-name-p sadx))
+	       ;; no way of setting it back short of yet more yukky stuff
+	       (proclaim `(optimize (,sadx 3))))
+             (if sadx-var
+                 (progv (list sadx-var) (list t)
+                   (call-next-method))
+                 (call-next-method))))
+      (setf (operation-on-warnings o) on-warnings
+	    (operation-on-failure o) on-failure))))
+
+#+sbcl
+(defmethod perform :around (o (f clx-source-file))
+  ;; SBCL signals an error if DEFCONSTANT is asked to redefine a
+  ;; constant unEQLly.  For CLX's purposes, however, we are defining
+  ;; structured constants (lists and arrays) not for EQLity, but for
+  ;; the purposes of constant-folding operations such as (MEMBER FOO
+  ;; +BAR+), so it is safe to abort the redefinition provided the
+  ;; structured data is sufficiently equal.
+  (handler-bind
+      ((sb-ext:defconstant-uneql
+	   (lambda (c)
+	     ;; KLUDGE: this really means "don't warn me about
+	     ;; efficiency of generic array access, please"
+	     (declare (optimize (sb-ext:inhibit-warnings 3)))
+	     (let ((old (sb-ext:defconstant-uneql-old-value c))
+		   (new (sb-ext:defconstant-uneql-new-value c)))
+	       (typecase old
+		 (list (when (equal old new) (abort c)))
+		 (string (when (and (typep new 'string)
+				    (string= old new))
+			   (abort c)))
+		 (simple-vector
+		  (when (and (typep new 'simple-vector)
+			     (= (length old) (length new))
+			     (every #'eql old new))
+		    (abort c)))
+		 (array
+		  (when (and (typep new 'array)
+			     (equal (array-dimensions old)
+				    (array-dimensions new))
+			     (equal (array-element-type old)
+				    (array-element-type new))
+			     (dotimes (i (array-total-size old) t)
+			       (unless (eql (row-major-aref old i)
+					    (row-major-aref new i))
+				 (return nil))))
+		    (abort c))))))))
+    (call-next-method)))
diff --git a/clx/clx.lisp b/clx/clx.lisp
index 3cde49313f62658bd3db4684e48c45d2945c8c70..02c18f62f56fd84607f5bd1b037ea6d22dbb6475 100644
--- a/clx/clx.lisp
+++ b/clx/clx.lisp
@@ -77,7 +77,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: clx.lisp,v 1.16 2009/06/17 18:22:45 rtoy Rel $")
 
 ;; Note: all of the following is in the package XLIB.
 
@@ -829,19 +829,18 @@
   (getf (font-properties font) name))
 
 (macrolet ((make-mumble-equal (type)
-	     ;; When cached, EQ works fine, otherwise test resource id's and displays
+	     ;; Since caching is only done for objects created by the
+	     ;; client, we must always compare ID and display for
+	     ;; non-identical mumbles.
 	     (let ((predicate (xintern type '-equal))
 		   (id (xintern type '-id))
 		   (dpy (xintern type '-display)))
-	       (if (member type +clx-cached-types+)
-		   `(within-definition (,type make-mumble-equal)
-		      (declaim (inline ,predicate))
-		      (defun ,predicate (a b) (eq a b)))
-		   `(within-definition (,type make-mumble-equal)
-		      (defun ,predicate (a b)
-			(declare (type ,type a b))
-			(and (= (,id a) (,id b))
-			     (eq (,dpy a) (,dpy b)))))))))
+		`(within-definition (,type make-mumble-equal)
+		   (defun ,predicate (a b)
+		     (declare (type ,type a b))
+		     (or (eql a b)
+			 (and (= (,id a) (,id b))
+			      (eq (,dpy a) (,dpy b)))))))))
   (make-mumble-equal window)
   (make-mumble-equal pixmap)
   (make-mumble-equal cursor)
diff --git a/clx/debug/debug.lisp b/clx/debug/debug.lisp
index 82e4e38c55b5c711e925d1c90d8e7ab28b743898..7f5f11b8c429c9529bacdf12c09dbd4bff8c87f9 100644
--- a/clx/debug/debug.lisp
+++ b/clx/debug/debug.lisp
@@ -21,7 +21,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: debug.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/debug/describe.lisp b/clx/debug/describe.lisp
index 404786f99ebfdc304b8d339586850f945b41369a..d543e80a722b55c3e54bfc3e1f4b1dae3faf7af6 100644
--- a/clx/debug/describe.lisp
+++ b/clx/debug/describe.lisp
@@ -21,7 +21,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: describe.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -79,7 +79,7 @@
 		(string8
 		 (format t " Bytes:~%~v@t" margin)
 		 (dotimes (k (- length (- j start)))
-		   (format t "~a" (code-char (card8-get j)))
+		   (format t "~a" (int-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 8d6320873501f421c87ce0a4c6172f773248e1b1..bc08bd53568600e873e046414a0e9e414969a5c1 100644
--- a/clx/debug/event-test.lisp
+++ b/clx/debug/event-test.lisp
@@ -3,7 +3,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: event-test.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage "XTEST"
   (:use :xlib :common-lisp)
diff --git a/clx/debug/keytrans.lisp b/clx/debug/keytrans.lisp
index 44db61c76c01609067a831ab9c5f1fad2086cd2c..fcba36033a16d09eaad2ee9c9a72817b24ab1ce4 100644
--- a/clx/debug/keytrans.lisp
+++ b/clx/debug/keytrans.lisp
@@ -19,22 +19,22 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: keytrans.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: keytrans.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
 (defun list-missing-keysyms ()
   ;; Lists explorer characters which have no keysyms
   (dotimes (i 256)
-    (unless (character->keysyms (code-char i))
-      (format t "~%(define-keysym ~@c ~d)" (code-char i) i))))
+    (unless (character->keysyms (int-char i))
+      (format t "~%(define-keysym ~@c ~d)" (int-char i) i))))
 
 (defun list-multiple-keysyms ()
   ;; Lists characters with more than one keysym
   (dotimes (i 256)
-    (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)))
+    (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)))
 	(format t "  ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
 
 (defun check-lowercase-keysyms ()
@@ -55,7 +55,7 @@
 				 char
 				 (and lowercase (ldb (byte 8 8) lowercase))
 				 (and lowercase (ldb (byte 8 0) lowercase))
-				 (code-char lowercase)
+				 (int-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 364a3f0f9ed4f06ee089687dc980410547af992e..dc0aa70d0348c191d5762724e30b33ce7b2fbcbf 100644
--- a/clx/debug/trace.lisp
+++ b/clx/debug/trace.lisp
@@ -33,7 +33,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: trace.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/debug/util.lisp b/clx/debug/util.lisp
index 471be6d4e38fd02ce46d5d3473bd44e0dd1a7bdf..62457ded5e2b43a16c238fa35f398a0ed6981252 100644
--- a/clx/debug/util.lisp
+++ b/clx/debug/util.lisp
@@ -21,7 +21,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: util.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -148,13 +148,12 @@
   ;; Returns a list of windows in the order that they are printed.
   (declare (arglist window)
 	   (type window window)
-	   (clx-values (list window)))
+	   (values (list window)))
   (let ((props (mapcar #'(lambda (prop)
 			   (multiple-value-bind (data type format)
 			       (get-property window prop)
 			     (case type
-			       (:string (setq data (map 'string #'code-char data)))
-			       (:utf8_string (setq data (map 'string #'code-char data))))
+			       (:string (setq data (coerce data 'string))))
 			     (list prop format type data)))
 		       (list-properties window)))
 	(result (list window)))
diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp
index ce67e3f5c97a82948d0f86a777bb4031fa7dce73..ad34fbaa99905d052ea6c8a9c296c4d0d12e97a8 100644
--- a/clx/defsystem.lisp
+++ b/clx/defsystem.lisp
@@ -34,7 +34,7 @@
 ;;;   sbcl
 
 #+cmu
-(ext:file-comment "$Id: defsystem.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: defsystem.lisp,v 1.9 2009/06/17 18:22:45 rtoy Rel $")
 
 #+(or Genera Minima sbcl ecl)
 (eval-when (:compile-toplevel :load-toplevel :execute)
diff --git a/clx/demo/bezier.lisp b/clx/demo/bezier.lisp
index 6028679f36f0ab5c23500b7748f77fae1b27778c..f5776115445a67ab97dfe72a4fa8bbd078dbd9ea 100644
--- a/clx/demo/bezier.lisp
+++ b/clx/demo/bezier.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: bezier.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/demo/beziertest.lisp b/clx/demo/beziertest.lisp
index 6569fc2b99188df050f12c3f90ba2d7b9284a31c..f564bc9ef86e57efea43980eedec42372a29679e 100644
--- a/clx/demo/beziertest.lisp
+++ b/clx/demo/beziertest.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: beziertest.lisp,v 1.2 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -60,11 +60,11 @@
     ;; we don't need to worry about overflows.
     (let ((factor (ash (min width height) 5)))
       (dotimes (i (length lines))
-	(setf (svref lines i)
-	      (ash (* (svref lines i) factor) -16)))
+	(setf (aref lines i)
+	      (ash (* (aref lines i) factor) -16)))
       (dotimes (i (length curves))
-	(setf (svref curves i)
-	      (ash (* (svref curves i) factor) -16))))
+	(setf (aref curves i)
+	      (ash (* (aref curves i) factor) -16))))
     
     (map-window win)				; Map the window
     ;; Handle events
diff --git a/clx/demo/clclock.lisp b/clx/demo/clclock.lisp
index 9ad9a8b7ac60b11be9a26ae2161d3cdfa9030341..bf9db76b09fdad101e69236bdd8f4a59445e527d 100644
--- a/clx/demo/clclock.lisp
+++ b/clx/demo/clclock.lisp
@@ -1,5 +1,5 @@
 #+cmu
-(ext:file-comment "$Id: clclock.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage "XCLCLOCK"
   (:use "CL")
diff --git a/clx/demo/clipboard.lisp b/clx/demo/clipboard.lisp
index 19c50581226b7e3b5aff2bec92208df6ef80c35b..c544a09d600d47d115fdb228e34ff77dd243f30f 100644
--- a/clx/demo/clipboard.lisp
+++ b/clx/demo/clipboard.lisp
@@ -60,7 +60,7 @@
 ;;; DEALINGS IN THE SOFTWARE.
 
 #+cmu
-(ext:file-comment "$Id: clipboard.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage "CLIPBOARD"
   (:use "CL" "XLIB")
diff --git a/clx/demo/clx-demos.lisp b/clx/demo/clx-demos.lisp
index 442b82e7a8e33240095062c40e3235139481d239..4f08d8d5f0f63179fd6c8b38209da1428fd9a26a 100644
--- a/clx/demo/clx-demos.lisp
+++ b/clx/demo/clx-demos.lisp
@@ -7,7 +7,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: clx-demos.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage :demos (:use :common-lisp)
   (:export do-all-demos demo))
@@ -32,17 +32,14 @@
 (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)
+	 #+:cmu
+	 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
+	 #+(or sbcl allegro clisp)
 	 (progn
 	   (setf *display* (xlib::open-default-display))
 	   (setf *screen* (xlib:display-default-screen *display*)))
@@ -174,8 +171,7 @@
 			       (+ 4 (random (truncate width 3)))
 			       (+ 4 (random (truncate height 3)))
 			       t))
-	(xlib:display-force-output *display*)
-	(sleep *delay*)))
+	(xlib:display-force-output *display*)))
     (xlib:free-gcontext gcontext)
     (xlib:free-pixmap pixmap)))
 
@@ -306,8 +302,7 @@
 	  (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*))))))
+	  (xlib:display-force-output *display*))))))
 
 
 (defdemo qix-demo "Qix" (&optional (lengths '(30 30)) (duration 2000))
@@ -519,9 +514,7 @@
 			,x ,y ,width ,height t))
 
 (defmacro update-screen ()
-  `(progn
-     (xlib:display-force-output *display*)
-     (sleep *delay*)))
+  `(xlib:display-force-output *display*))
 
 
 ;;;; Moving disks up and down
@@ -767,7 +760,7 @@
 ;;; 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))
+			     (x-velocity 0) (elasticity 0.85) (gravity 2))
   (unless (< 0 elasticity 1)
     (error "Elasticity must be between 0 and 1."))
   (unless (plusp gravity)
@@ -782,43 +775,41 @@
 	(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*))))))))
+	  (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*)
+		  (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*))))))))
 
 ;;; Change the name of this when DEMO is not so stupid.
 ;;; 
@@ -932,7 +923,6 @@
 	      (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)))
 
@@ -1053,8 +1043,7 @@
       (dotimes (i duration)
 	(dolist (ball balls)
 	  (bounce-1-ball bounce-pixmap window gcontext ball))
-	(xlib:display-force-output display)
-	(sleep *delay*))
+	(xlib:display-force-output display))
       (xlib:free-pixmap bounce-pixmap)
       (xlib:free-gcontext gcontext))))
 
diff --git a/clx/demo/gl-test.lisp b/clx/demo/gl-test.lisp
index 453433ded05c105bd3e56e24084b394624eea1f2..d9cd3dfda8295bc1626b74c3e734288cd0cbab1c 100644
--- a/clx/demo/gl-test.lisp
+++ b/clx/demo/gl-test.lisp
@@ -1,5 +1,5 @@
 #+cmu
-(ext:file-comment "$Id: gl-test.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: gl-test.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage :gl-test
   (:use :common-lisp :xlib)
@@ -8,7 +8,7 @@
 (in-package :gl-test)
 
 
-(defun test (function &key (host "") (display 0) (width 200) (height 200))
+(defun test (function &key (host "localhost") (display 1) (width 200) (height 200))
   (let* ((display (open-display host :display display))
          (screen (display-default-screen display))
          (root (screen-root screen))
diff --git a/clx/demo/hello.lisp b/clx/demo/hello.lisp
index b2a273db5fb3eeab46792ace9fbf7f363b80fcc4..8ede2221f134829c59104e50a5a6f3c3368ed1ab 100644
--- a/clx/demo/hello.lisp
+++ b/clx/demo/hello.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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 $")
+(ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/demo/mandel.lisp b/clx/demo/mandel.lisp
index a877191f4a6cd7896e30a3f57b462a0e75b7e24e..f094b4a9c3cde455117298907038bd1694061931 100644
--- a/clx/demo/mandel.lisp
+++ b/clx/demo/mandel.lisp
@@ -1,5 +1,5 @@
 #+cmu
-(ext:file-comment "$Id: mandel.lisp,v 1.1 2007/08/21 15:49:29 fgilham Exp $")
+(ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage "XMANDEL"
   (:use "CL")
diff --git a/clx/demo/menu.lisp b/clx/demo/menu.lisp
index 821635610680ffceb1e633d0f43fd58a5e1d6af7..5de1d07267b318c1b41e52059502eb78f27d6c9d 100644
--- a/clx/demo/menu.lisp
+++ b/clx/demo/menu.lisp
@@ -16,9 +16,6 @@
 ;;; express or implied warranty.  
 ;;;
 
-#+cmu
-(ext:file-comment "$Id")
-
 (in-package :xlib)
 
 
@@ -306,7 +303,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 a3bf4cef26b0e89e8a51a797debeb4c17f5d1ddb..0a313059f2f89f23c769c34aad6b01bc9dd111ab 100644
--- a/clx/demo/zoid.lisp
+++ b/clx/demo/zoid.lisp
@@ -18,9 +18,6 @@
 ;;; 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
index ffc26a6966541e164470e559a5b9181e6e0fa19b..37def9aca6e70714d54a0ae344baf035fbc297df 100644
--- a/clx/dep-allegro.lisp
+++ b/clx/dep-allegro.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: dep-allegro.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: dep-allegro.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/dep-openmcl.lisp b/clx/dep-openmcl.lisp
index c9b994a0c659d67daa51d4ff862755b5dd561104..94d8670e340dc57e8dd6acd04f47c0c1978653a9 100644
--- a/clx/dep-openmcl.lisp
+++ b/clx/dep-openmcl.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: dep-openmcl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: dep-openmcl.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -556,17 +556,16 @@
 ;;; 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"))
+  (let ((local-socket-path (unix-socket-path-from-host host display)))
+    (if local-socket-path
     (ccl::make-socket :connect :active
                       :address-family  :file
-                      :remote-filename (format nil ccl::*x-server-unix-socket-format-string* display))
+			 :remote-filename local-socket-path)
     (ccl::make-socket :connect :active
                       :remote-host host
-                      :remote-port (+ 6000 display))))
+			 :remote-port (+ 6000 display)))))
 
 ;;; BUFFER-READ-DEFAULT - read data from the X stream
 
diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp
index 79c97178a759dc3bd78f7efeeba6ffea94f63edd..bce7c5e7036d55792302d2bb51397ff2045ea54c 100644
--- a/clx/depdefs.lisp
+++ b/clx/depdefs.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: depdefs.lisp,v 1.8 2007/08/22 03:58:59 fgilham Exp $")
+(ext:file-comment "$Id: depdefs.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -674,3 +674,23 @@ used, since NIL is the empty list.")
       (:return-type :signed-32bit))
   (host :simple-string)
   (display :signed-32bit))
+
+
+;;-----------------------------------------------------------------------------
+;; Finding the server socket
+;;-----------------------------------------------------------------------------
+
+;; These are here because dep-openmcl.lisp and dependent.lisp both need them
+(defconstant +X-unix-socket-path+
+  "/tmp/.X11-unix/X"
+  "The location of the X socket")
+
+(defun unix-socket-path-from-host (host display)
+  "Return the name of the unix domain socket for host and display, or
+nil if a network socket should be opened."
+  (cond ((or (string= host "") (string= host "unix"))
+	 (format nil "~A~D" +X-unix-socket-path+ display))
+	#+darwin
+	((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
+	 (format nil "/~A:~D" host display))	  
+	(t nil)))
diff --git a/clx/display.lisp b/clx/display.lisp
index 5cf54a991ae85a2184a2ec4e22e782be77072599..9460c0b13cd4ce7b6542ba469e8b9501d962ddcb 100644
--- a/clx/display.lisp
+++ b/clx/display.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: display.lisp,v 1.13 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: display.lisp,v 1.14 2009/06/17 18:22:46 rtoy Exp $")
 
 (in-package :xlib)
 
@@ -133,6 +133,24 @@
 		(values best-name best-data)))))))
     (values "" "")))
 
+(defmacro with-display ((display &key timeout inline)
+			&body body)
+  ;; This macro is for use in a multi-process environment.  It
+  ;; provides exclusive access to the local display object for
+  ;; multiple request generation.  It need not provide immediate
+  ;; exclusive access for replies; that is, if another process is
+  ;; waiting for a reply (while not in a with-display), then
+  ;; synchronization need not (but can) occur immediately.  Except
+  ;; where noted, all routines effectively contain an implicit
+  ;; with-display where needed, so that correct synchronization is
+  ;; always provided at the interface level on a per-call basis.
+  ;; Nested uses of this macro will work correctly.  This macro does
+  ;; not prevent concurrent event processing; see with-event-queue.
+  `(with-buffer (,display
+		 ,@(and timeout `(:timeout ,timeout))
+		 ,@(and inline `(:inline ,inline)))
+     ,@body))
+
 ;;
 ;; Resource id management
 ;;
@@ -149,40 +167,59 @@
 		 (type mask32 mask))))))
 
 (defun resourcealloc (display)
-  ;; Allocate a resource-id for in DISPLAY
+  ;; Allocate a resource-id for use in DISPLAY
   (declare (type display display))
   (declare (clx-values resource-id))
-  (dpb (incf (display-resource-id-count display))
-       (display-resource-id-byte display)
-       (display-resource-id-base display)))
+  (loop for next-count upfrom (1+ (display-resource-id-count display))
+        repeat (1+ (display-resource-id-mask display))
+        as id = (dpb next-count
+                     (display-resource-id-byte display)
+                     (display-resource-id-base display))
+        unless (nth-value 1 (gethash id (display-resource-id-map display)))
+        do (setf (display-resource-id-count display) next-count)
+           (setf (gethash id (display-resource-id-map display)) t)
+           (return-from resourcealloc id))
+  ;; internal consistency check
+  (assert (= (hash-table-count (display-resource-id-map display))
+             (1+ (display-resource-id-mask display))))
+  ;; tell the user what's gone wrong
+  (error 'resource-ids-exhausted))
 
 (defmacro allocate-resource-id (display object type)
   ;; Allocate a resource-id for OBJECT in DISPLAY
-  (if (member (eval type) +clx-cached-types+)
-      `(let ((id (funcall (display-xid ,display) ,display)))
-	 (save-id ,display id ,object)
-	 id)
-    `(funcall (display-xid ,display) ,display)))
+  `(with-display (,display)
+     ,(if (member (eval type) +clx-cached-types+)
+          `(let ((id (funcall (display-xid ,display) ,display)))
+             (save-id ,display id ,object)
+             id)
+          `(funcall (display-xid ,display) ,display))))
 
 (defmacro deallocate-resource-id (display id type)
+  (declare (ignore type))
   ;; Deallocate a resource-id for OBJECT in DISPLAY
-  (when (member (eval type) +clx-cached-types+)
-    `(deallocate-resource-id-internal ,display ,id)))
+  `(deallocate-resource-id-internal ,display ,id))
 
 (defun deallocate-resource-id-internal (display id)
-  (remhash id (display-resource-id-map display)))
+  (with-display (display)
+    (remhash id (display-resource-id-map display))))
 
 (defun lookup-resource-id (display id)
   ;; Find the object associated with resource ID
   (gethash id (display-resource-id-map display)))
 
 (defun save-id (display id object)
-  ;; Register a resource-id from another display.
+  ;; cache the object associated with ID for this display.
   (declare (type display display)
 	   (type integer id)
 	   (type t object))
   (declare (clx-values object))
-  (setf (gethash id (display-resource-id-map display)) object))
+  ;; we can't cache objects from other clients, because they may
+  ;; become invalid without us being told about that.
+  (let ((base (display-resource-id-base display))
+        (mask (display-resource-id-mask display)))
+    (when (= (logandc2 id mask) base)
+      (setf (gethash id (display-resource-id-map display)) object))
+    object))
 
 ;; Define functions to find the CLX data types given a display and resource-id
 ;; If the data type is being cached, look there first.
@@ -279,24 +316,6 @@
 ;;
 ;; Display functions
 ;;
-(defmacro with-display ((display &key timeout inline)
-			&body body)
-  ;; This macro is for use in a multi-process environment.  It
-  ;; provides exclusive access to the local display object for
-  ;; multiple request generation.  It need not provide immediate
-  ;; exclusive access for replies; that is, if another process is
-  ;; waiting for a reply (while not in a with-display), then
-  ;; synchronization need not (but can) occur immediately.  Except
-  ;; where noted, all routines effectively contain an implicit
-  ;; with-display where needed, so that correct synchronization is
-  ;; always provided at the interface level on a per-call basis.
-  ;; Nested uses of this macro will work correctly.  This macro does
-  ;; not prevent concurrent event processing; see with-event-queue.
-  `(with-buffer (,display
-		 ,@(and timeout `(:timeout ,timeout))
-		 ,@(and inline `(:inline ,inline)))
-     ,@body))
-
 (defmacro with-event-queue ((display &key timeout inline)
 			    &body body &environment env)
   ;; exclusive access to event queue
@@ -369,41 +388,38 @@ gethostname(3) - is used instead."
   ;; if any, is assumed to come from the environment somehow.
   (declare (type integer display))
   (declare (clx-values display))
-
-  (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 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
-			      :host host :display display
-			      :output-stream stream :input-stream stream))
-	   (ok-p nil))
-      (unwind-protect
-	   (progn
-	     (display-connect disp
-			      :authorization-name authorization-name
-			      :authorization-data authorization-data)
-	     (setf (display-authorization-name disp) authorization-name)
-	     (setf (display-authorization-data disp) authorization-data)
-	     (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))
-  )
-
+  ;; 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 host
+			      display
+			      (if (member host '("" "unix") :test #'equal)
+				  :local
+				  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
+			    :host host :display display
+			    :output-stream stream :input-stream stream))
+	 (ok-p nil))
+    (unwind-protect
+	(progn
+	  (display-connect disp
+			   :authorization-name authorization-name
+			   :authorization-data authorization-data)
+	  (setf (display-authorization-name disp) authorization-name)
+	  (setf (display-authorization-data disp) authorization-data)
+	  (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))
 
 (defun display-force-output (display)
   ; Output is normally buffered, this forces any buffered output to the server.
@@ -419,10 +435,10 @@ gethostname(3) - is used instead."
 (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))
@@ -437,112 +453,112 @@ gethostname(3) - is used instead."
   (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)
@@ -550,16 +566,16 @@ gethostname(3) - is used instead."
 					      :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)
diff --git a/clx/dpms.lisp b/clx/dpms.lisp
index 61d0ba719a6fd095c4cdbbb47789e987d351020f..669dd516a8c28789ae766596ad7c0eccf62a7305 100644
--- a/clx/dpms.lisp
+++ b/clx/dpms.lisp
@@ -14,7 +14,7 @@
 ;;;;  provided ``as is'' without express or implied warranty.
 
 #+cmu
-(ext:file-comment "$Id: dpms.lisp,v 1.2 2007/08/22 03:59:07 fgilham Exp $")
+(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage :dpms
   (:use :common-lisp)
diff --git a/clx/exclMakefile b/clx/exclMakefile
index 3890d23a40ad423032fb25f1518126401a8e8d31..a31a468f3c102f9d362681abbaaf7d258cd50434 100644
--- a/clx/exclMakefile
+++ b/clx/exclMakefile
@@ -2,7 +2,7 @@
 #  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 $
+# $Id: exclMakefile,v 1.5 2009/06/17 18:22:46 rtoy Rel $
 #
 
 # *************************************************************************
diff --git a/clx/exclREADME b/clx/exclREADME
index 2ecd2b9b0a0857ca9fa5e1af88d0c602c11e609f..98966a3df17b163e752084a5d9b3bfe07a3ed296 100644
--- a/clx/exclREADME
+++ b/clx/exclREADME
@@ -1,4 +1,4 @@
-$Id: exclREADME,v 1.4 2007/08/21 15:49:28 fgilham Exp $
+$Id: exclREADME,v 1.5 2009/06/17 18:22:46 rtoy Rel $
 
      This file contains instructions on how to make CLX work with Franz
 Common Lisp.  CLX should work on any machine that supports Allegro Common
diff --git a/clx/exclcmac.lisp b/clx/exclcmac.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..04fd20af87020531a2341a6b0cf82dff28a9aad0
--- /dev/null
+++ b/clx/exclcmac.lisp
@@ -0,0 +1,260 @@
+;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
+;;;
+;;; CLX -- exclcmac.cl
+;;;           This file provides for inline expansion of some functions.
+;;;
+;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify, and distribute this software, provided that this complete
+;;; copyright and permission notice is maintained, intact, in all copies and
+;;; supporting documentation.
+;;;
+;;; Franz Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+;;
+;; Type predicates
+;;
+(excl:defcmacro card8p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
+
+(excl:defcmacro card16p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
+
+(excl:defcmacro int8p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
+
+(excl:defcmacro int16p (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       (declare (optimize (speed 3) (safety 0))
+		(fixnum ,xx))
+       (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
+
+;; Card29p, card32p, int32p are too large to expand inline
+
+
+;;
+;; Type transformers
+;;
+(excl:defcmacro card8->int8 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card8 ,xx))
+       (the int8 (if (logbitp 7 ,xx)
+		     (the int8 (- ,xx #x100))
+		   ,xx)))))
+(excl:defcmacro int8->card8 (x)
+  `(locally ,(declare-bufmac)
+     (the card8 (ldb (byte 8 0) (the int8 ,x)))))
+
+(excl:defcmacro card16->int16 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card16 ,xx))
+       (the int16 (if (logbitp 15 ,xx)
+		      (the int16 (- ,xx #x10000))
+		    ,xx)))))
+
+(excl:defcmacro int16->card16 (x)
+  `(locally ,(declare-bufmac)
+     (the card16 (ldb (byte 16 0) (the int16 ,x)))))
+
+(excl:defcmacro card32->int32 (x)
+  (let ((xx (gensym)))
+    `(let ((,xx ,x))
+       ,(declare-bufmac)
+       (declare (type card32 ,xx))
+       (the int32 (if (logbitp 31 ,xx)
+		      (the int32 (- ,xx #x100000000))
+		    ,xx)))))
+
+(excl:defcmacro int32->card32 (x)
+  `(locally ,(declare-bufmac)
+     (the card32 (ldb (byte 32 0) (the int32 ,x)))))
+
+(excl:defcmacro char->card8 (char)
+  `(locally ,(declare-bufmac)
+     (the card8 (char-code (the string-char ,char)))))
+
+(excl:defcmacro card8->char (card8)
+  `(locally ,(declare-bufmac)
+     (the string-char (code-char (the card8 ,card8)))))
+
+
+;;
+;; Array accessors and setters
+;;
+(excl:defcmacro aref-card8 (a i)
+  `(locally ,(declare-bufmac)
+     (the card8 (sys:memref (the buffer-bytes ,a)
+			    #.(comp::mdparam 'comp::md-svector-data0-adj)
+			    (the array-index ,i)
+			    :unsigned-byte))))
+  
+(excl:defcmacro aset-card8 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-byte)
+	   (the card8 ,v))))
+  
+(excl:defcmacro aref-int8 (a i)
+  `(locally ,(declare-bufmac)
+     (the int8 (sys:memref (the buffer-bytes ,a)
+			   #.(comp::mdparam 'comp::md-svector-data0-adj)
+			   (the array-index ,i)
+			   :signed-byte))))
+  
+(excl:defcmacro aset-int8 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :signed-byte)
+       (the int8 ,v))))
+
+(excl:defcmacro aref-card16 (a i)
+  `(locally ,(declare-bufmac)
+     (the card16 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-word))))
+  
+(excl:defcmacro aset-card16 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-word)
+	   (the card16 ,v))))
+  
+(excl:defcmacro aref-int16 (a i)
+  `(locally ,(declare-bufmac)
+     (the int16 (sys:memref (the buffer-bytes ,a)
+			    #.(comp::mdparam 'comp::md-svector-data0-adj)
+			    (the array-index ,i)
+			    :signed-word))))
+  
+(excl:defcmacro aset-int16 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :signed-word)
+       (the int16 ,v))))
+  
+(excl:defcmacro aref-card32 (a i)
+  `(locally ,(declare-bufmac)
+     (the card32 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-long))))
+    
+(excl:defcmacro aset-card32 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-long)
+       (the card32 ,v))))
+
+(excl:defcmacro aref-int32 (a i)
+  `(locally ,(declare-bufmac)
+     (the int32 (sys:memref (the buffer-bytes ,a)
+			    #.(comp::mdparam 'comp::md-svector-data0-adj)
+			    (the array-index ,i)
+			    :signed-long))))
+    
+(excl:defcmacro aset-int32 (v a i)
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :signed-long)
+       (the int32 ,v))))
+
+(excl:defcmacro aref-card29 (a i)
+  ;; Don't need to mask bits here since X protocol guarantees top bits zero
+  `(locally ,(declare-bufmac)
+     (the card29 (sys:memref (the buffer-bytes ,a)
+			     #.(comp::mdparam 'comp::md-svector-data0-adj)
+			     (the array-index ,i)
+			     :unsigned-long))))
+
+(excl:defcmacro aset-card29 (v a i)
+  ;; I also assume here Lisp is passing a number that fits in 29 bits.
+  `(locally ,(declare-bufmac)
+     (setf (sys:memref (the buffer-bytes ,a)
+		       #.(comp::mdparam 'comp::md-svector-data0-adj)
+		       (the array-index ,i)
+		       :unsigned-long)
+       (the card29 ,v))))
+
+;;
+;; Font accessors
+;;
+(excl:defcmacro font-id (font)
+  ;; Get font-id, opening font if needed
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-id-internal ,f)
+	   (open-font-internal ,f)))))
+
+(excl:defcmacro font-font-info (font)
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-font-info-internal ,f)
+	   (query-font ,f)))))
+
+(excl:defcmacro font-char-infos (font)
+  (let ((f (gensym)))
+    `(let ((,f ,font))
+       (or (font-char-infos-internal ,f)
+	   (progn (query-font ,f)
+		  (font-char-infos-internal ,f))))))
+
+
+;;
+;; Miscellaneous
+;;
+(excl:defcmacro current-process ()
+  `(the (or mp::process null) (and mp::*scheduler-stack-group*
+				  mp::*current-process*)))
+
+(excl:defcmacro process-wakeup (process)
+  (let ((proc (gensym)))
+    `(let ((.pw-curproc. mp::*current-process*)
+	   (,proc ,process))
+       (when (and .pw-curproc. ,proc)
+	 (if (> (mp::process-priority ,proc)
+		(mp::process-priority .pw-curproc.))
+	     (mp::process-allow-schedule ,proc))))))
+
+(excl:defcmacro buffer-new-request-number (buffer)
+  (let ((buf (gensym)))
+    `(let ((,buf ,buffer))
+       (declare (type buffer ,buf))
+       (setf (buffer-request-number ,buf)
+	 (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
+
+
diff --git a/clx/excldep.c b/clx/excldep.c
index 5b96a44d280d115feb284d089c8d19cc1b2e8174..5bf47a78342b7ccf100aa1a82a367938c0dfe44c 100644
--- a/clx/excldep.c
+++ b/clx/excldep.c
@@ -3,7 +3,7 @@
  */
 
 /* 
- * $Id: excldep.c,v 1.3 2007/08/21 15:49:28 fgilham Exp $
+ * $Id: excldep.c,v 1.4 2009/06/17 18:22:46 rtoy Rel $
  */
 
 /*
diff --git a/clx/excldep.lisp b/clx/excldep.lisp
index 93ee776bc49a3e0104d422a69039940cccbde534..b5ea9c5b69a76ce22fa44868219b741c0dc78286 100644
--- a/clx/excldep.lisp
+++ b/clx/excldep.lisp
@@ -14,7 +14,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: excldep.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: excldep.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/fonts.lisp b/clx/fonts.lisp
index 5a84b6698037bf46846bff5410a833088acc100a..a9225fa4ddffe6b45f3166a8573e69bebc175f98 100644
--- a/clx/fonts.lisp
+++ b/clx/fonts.lisp
@@ -17,7 +17,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: fonts.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: fonts.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp
index 5039ae3fce1c189f629901ddcfa968639fab9c74..052d16b3e1d196673095d025f8de3ace2960e26b 100644
--- a/clx/gcontext.lisp
+++ b/clx/gcontext.lisp
@@ -43,7 +43,7 @@
 ;;;	environment.
 
 #+cmu
-(ext:file-comment "$Id: gcontext.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: gcontext.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/generalock.lisp b/clx/generalock.lisp
index aa1a6fbe97b557ca70bee0692194a17da1a06053..21c25705e3cec0f61bfab4872c6d3cb03101b7ff 100644
--- a/clx/generalock.lisp
+++ b/clx/generalock.lisp
@@ -11,7 +11,7 @@
 ;;; express or implied warranty.
 
 #+cmu
-(ext:file-comment "$Id: generalock.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: generalock.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $")
 
 (defflavor xlib::clx-lock () (simple-recursive-normal-lock)
   (:init-keywords :flavor))
diff --git a/clx/gl.lisp b/clx/gl.lisp
index 391af3f2168633c9d5ea089736eb0a079c2e2e13..1d7582d1def0ef4daac13eec9b364ce61907e20e 100644
--- a/clx/gl.lisp
+++ b/clx/gl.lisp
@@ -1,5 +1,5 @@
 #+cmu
-(ext:file-comment "$Id: gl.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage :gl
   (:use :common-lisp :xlib)
diff --git a/clx/glx.lisp b/clx/glx.lisp
index 9903d68c3902c53a23cd0d301e41c9b357f6db66..b5c275035c51c73f4fb00c127d797871b26084be 100644
--- a/clx/glx.lisp
+++ b/clx/glx.lisp
@@ -1,5 +1,5 @@
 #+cmu
-(ext:file-comment "$Id: glx.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (defpackage :glx
   (:use :common-lisp :xlib)
diff --git a/clx/graphics.lisp b/clx/graphics.lisp
index 53f09fc74c5222af1aa37ce7b5d298b6cecc9175..b9498489ad1e56616489013dd0e0332d39fe4735 100644
--- a/clx/graphics.lisp
+++ b/clx/graphics.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: graphics.lisp,v 1.6 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: graphics.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/image.lisp b/clx/image.lisp
index d578c265c696213221a20995700ed51482ed21fe..882f8c2209a398ef69df7e217793a0d738632ff1 100644
--- a/clx/image.lisp
+++ b/clx/image.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: image.lisp,v 1.12 2007/08/22 03:59:16 fgilham Exp $")
+(ext:file-comment "$Id: image.lisp,v 1.13 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/input.lisp b/clx/input.lisp
index c1547b0a9cc67d07402fd2af535f227c9427cbcd..7ee2adc6cc843ffa42cc2b6f7ef29a4b6af7f901 100644
--- a/clx/input.lisp
+++ b/clx/input.lisp
@@ -26,7 +26,7 @@
 ;;; 12/10/87	LGO	Created
 
 #+cmu
-(ext:file-comment "$Id: input.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: input.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -1780,6 +1780,13 @@
       (format stream "inconsistent-parameters:~{ ~s~}"
 	      (inconsistent-parameters-parameters condition)))))
 
+(define-condition resource-ids-exhausted (x-error)
+  ()
+  (:report
+    (lambda (condition stream)
+      (declare (ignore condition))
+      (format stream "All X resource IDs are in use."))))
+
 (defun get-error-key (display error-code)
   (declare (type display display)
 	   (type array-index error-code))
diff --git a/clx/keysyms.lisp b/clx/keysyms.lisp
index 2a62d2b2a7c56bd06271ada9ab54d86484ace7d0..f63f5d09d0a3d79131ce8d7fa212f9773041dc0a 100644
--- a/clx/keysyms.lisp
+++ b/clx/keysyms.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: keysyms.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: keysyms.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/macros.lisp b/clx/macros.lisp
index 0652bc105657faee9d16a9b39ab83c0fa91fc8af..cbf28d0c94c6cfc18044b86a74ad0b5ced349d53 100644
--- a/clx/macros.lisp
+++ b/clx/macros.lisp
@@ -26,7 +26,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: macros.lisp,v 1.8 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -337,6 +337,10 @@
   ((index) (declare (ignore index)) nil)
   ((index value) (declare (ignore index value)) nil))
 
+(define-accessor pad32 (32)
+  ((index) (declare (ignore index)) nil)
+  ((index value) (declare (ignore index value)) nil))
+
 (define-accessor bit-vector256 (256)
   ;; used for key-maps
   ;; REAL-INDEX parameter provided so the default index can be over-ridden.
diff --git a/clx/manager.lisp b/clx/manager.lisp
index 545fdf18a0969ca455436bcb2d809f42e98ec73d..326223abbff20be24709a995f3867dde79c6f393 100644
--- a/clx/manager.lisp
+++ b/clx/manager.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: manager.lisp,v 1.9 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: manager.lisp,v 1.10 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -64,7 +64,10 @@
     (when value
       (let* ((name-len (position 0 (the (vector card8) value)))
 	     (name (subseq (the (vector card8) value) 0 name-len))
-	     (class (subseq (the (vector card8) value) (1+ name-len) (1- (length value)))))
+	     (class
+              (when name-len
+                (subseq (the (vector card8) value) (1+ name-len)
+                        (position 0 (the (vector card8) value) :start (1+ name-len))))))
 	(values (and (plusp (length name)) (map 'string #'card8->char name))
 		(and (plusp (length class)) (map 'string #'card8->char class)))))))
 
diff --git a/clx/package.lisp b/clx/package.lisp
index d483ebacac9066afae3bbc6836f91a6004622fc4..90665f38f8b8c064a965f9edce011ee4b270dab5 100644
--- a/clx/package.lisp
+++ b/clx/package.lisp
@@ -12,7 +12,7 @@
 ;;; written prior permission.
 
 #+cmu
-(ext:file-comment "$Id: package.lisp,v 1.8 2007/11/09 20:34:23 rtoy Exp $")
+(ext:file-comment "$Id: package.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
 
 ;;; The CLtL way
 
diff --git a/clx/provide.lisp b/clx/provide.lisp
index 78b385c85598e38931587403f31922742a3a86c2..fe59ebedcb4db07626fddc343ecd093341d6e3c9 100644
--- a/clx/provide.lisp
+++ b/clx/provide.lisp
@@ -15,7 +15,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: provide.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: provide.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $")
 
 #+cmu
 (cl:provide "CLX")
@@ -63,5 +63,4 @@
 (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 d2ec05b13c6f89376b2956b7aad1e445eab73126..49aeb3edfefb5a624ba522f1535c9a29fff82e7e 100644
--- a/clx/requests.lisp
+++ b/clx/requests.lisp
@@ -17,7 +17,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: requests.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: requests.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/resource.lisp b/clx/resource.lisp
index aaff151dda2cca71298dfbea7bbf23e866897607..f5c1e5b18ee6389733bbd39e74543c9bb487c6e0 100644
--- a/clx/resource.lisp
+++ b/clx/resource.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: resource.lisp,v 1.11 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: resource.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/screensaver.lisp b/clx/screensaver.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3605d03e5598c3f1c3e1aecc17d05c4f65779faa
--- /dev/null
+++ b/clx/screensaver.lisp
@@ -0,0 +1,69 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: X11 MIT Screensaver extension
+;;;   Created: 2005-08-28 01:41
+;;;    Author: Istvan Marko <mi-clx@kismala.com>
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2005 by Istvan Marko
+
+;;;
+;;; 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.
+;;;
+
+;;; Description:
+;;;
+;;; This is a partial interface to the MIT-SCREEN-SAVER
+;;; extension. Only the ScreenSaverQueryVersion and
+;;; ScreenSaverQueryInfo requests are implemented because I couldn't
+;;; think of a use for the rest. In fact, the only use I see for this
+;;; extension is screen-saver-get-idle which provides and easy way to
+;;; find out how long has it been since the last keyboard or mouse
+;;; activity.
+
+;;; A description of this extension can be found at
+;;; doc/hardcopy/saver/saver.PS.gz in the X11 distribution.
+
+(in-package :xlib)
+
+(export '(screen-saver-query-version
+	  screen-saver-query-info
+	  screen-saver-get-idle)
+        :xlib)
+
+(define-extension "MIT-SCREEN-SAVER")
+
+(defun screen-saver-query-version (display)
+  (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER")
+                                          nil)
+    ((data 0)
+     (card8 1) ;client major version
+     (card8 0) ;client minor version
+     (card16 0)) ; unused
+    (values
+     (card16-get 8) ; server major version
+     (card16-get 10)))) ; server minor version
+
+(defun screen-saver-query-info (display drawable)
+  (with-buffer-request-and-reply (display (extension-opcode display "MIT-SCREEN-SAVER")
+                                          nil)
+    ((data 1)
+     (drawable drawable))
+    (values
+     (card8-get 1) ; state: off, on, disabled
+     (window-get 8) ; screen saver window if active
+     (card32-get 12) ; tilorsince msecs. how soon before the screen saver kicks in or how long has it been active
+     (card32-get 16) ; idle msecs
+     (card8-get 24)))) ; kind: Blanked, Internal, External
+
+(defun screen-saver-get-idle (display drawable)
+  "How long has it been since the last keyboard or mouse input"
+   (multiple-value-bind (state window tilorsince idle kind) (screen-saver-query-info display drawable)
+     (declare (ignore state window kind))
+     (values idle tilorsince)))
diff --git a/clx/shape.lisp b/clx/shape.lisp
index 416330b78c85cb5c99532038c4dd3a2e8ec3ff12..5804a8a34824941e38b7b1eb9d57a21961ab004d 100644
--- a/clx/shape.lisp
+++ b/clx/shape.lisp
@@ -21,7 +21,7 @@
 ;;  ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz
 
 #+cmu
-(ext:file-comment "$Id: shape.lisp,v 1.2 2007/08/22 03:59:24 fgilham Exp $")
+(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/sockcl.lisp b/clx/sockcl.lisp
index bd499fc25dc1d832ce46109a219351a8cb1d1836..b5e2ca5e1e6b00658fc93ce8df6aed40622fda04 100644
--- a/clx/sockcl.lisp
+++ b/clx/sockcl.lisp
@@ -24,7 +24,7 @@
 ;;; 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 $")
+(ext:file-comment "$Id: sockcl.lisp,v 1.4 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/socket.c b/clx/socket.c
index 3e172c61b8c4470261825f44f9b089b2e0a1541b..fcac36264b2ac1bc565e7967eb6232ef92da9cf1 100644
--- a/clx/socket.c
+++ b/clx/socket.c
@@ -7,7 +7,7 @@
  * Compile using   
  *                    % cc -c socket.c -DUNIXCONN
  *
- * $Id: socket.c,v 1.4 2007/08/21 15:49:28 fgilham Exp $
+ * $Id: socket.c,v 1.5 2009/06/17 18:22:46 rtoy Rel $
  */
 
 #include <stdio.h>
diff --git a/clx/test/image.lisp b/clx/test/image.lisp
index 7f6903c399f4a1ca58ada17d212f79d486a07d52..15dae1f0c2c2d51393b086e8109ef999668bd080 100644
--- a/clx/test/image.lisp
+++ b/clx/test/image.lisp
@@ -28,6 +28,7 @@
 
 (defun image-test
        (&key
+	(host *image-test-host*)
 	(nimages *image-test-nimages*)
 	(copy *image-test-copy*)
 	(copy-random-subimage *image-test-copy-random-subimage*)
@@ -36,6 +37,7 @@
 	  *image-test-get-image-result-type-choices*)
 	(get-image-image-x-format-choices
 	  *image-test-get-image-image-x-format-choices*))
+  (declare (ignore host))
   (let* ((display nil)
 	 (abort t)
 	 (images nil))
@@ -43,12 +45,14 @@
       (setq images nil)
       (unwind-protect
 	  (progn
-	    (setq display (ext:open-clx-display))
+	    (setq display (open-default-display))
 	    (let* ((screen (display-default-screen display))
 		   (window (screen-root screen))
 		   (gcontext (create-gcontext
-			       :drawable window
-			       :font (open-font display "fixed"))))
+			      :foreground (screen-white-pixel screen)
+			      :background (screen-black-pixel screen)
+			      :drawable window
+			      :font (open-font display "fixed"))))
 	      (dotimes (i nimages)
 		(let ((image (image-test-get-image
 			       window
@@ -91,10 +95,8 @@
 	     (image-z :z-pixmap)))
 	 (image (get-image window :x x :y y :width width :height height
 			   :format format :result-type result-type)))
-    ;; XCreatePixmapCursor(3X11) says that x,y for hotspot are
-    ;; unsigned
-    ;; (setf (image-x-hot image) (- x))
-    ;; (setf (image-y-hot image) (- y))
+    (setf (getf (image-plist image) :root-x) x)
+    (setf (getf (image-plist image) :root-y) y)
     image))
 
 (defun image-test-subimage-parameters (image random-subimage-p)
@@ -119,6 +121,8 @@
 	      ((or image-xy image-z) 'image-x)))))
     (multiple-value-bind (x y width height)
 	(image-test-subimage-parameters image random-subimage-p)
+      (incf (getf (image-plist image) :root-x) x)
+      (incf (getf (image-plist image) :root-y) y)
       (copy-image image :x x :y y :width width :height height
 		  :result-type result-type))))
 
@@ -126,8 +130,10 @@
   (multiple-value-bind (src-x src-y width height)
       (image-test-subimage-parameters image random-subimage-p)
     (let* ((border-width 1)
-	   (x (- src-x #+nil (image-x-hot image) border-width))
-	   (y (- src-y #+nil (image-y-hot image) border-width)))
+	   (root-x (getf (image-plist image) :root-x))
+	   (root-y (getf (image-plist image) :root-y))
+	   (x (+ src-x root-x (- border-width)))
+	   (y (+ src-y root-y (- border-width))))
       (unless (or (zerop width) (zerop height))
 	(let ((window
 		(create-window
diff --git a/clx/test/trapezoid.lisp b/clx/test/trapezoid.lisp
index 7b1a571b44f73578010fe072fbc5fd8ecba8a6c2..ff959425867fa5b0ea872cb16677ee8b8a1d4660 100644
--- a/clx/test/trapezoid.lisp
+++ b/clx/test/trapezoid.lisp
@@ -21,9 +21,9 @@
 (in-package :xlib)
 
 
-(defun zoid-test (host)
+(defun zoid-test ()
   ;; Display the part picture in /extensions/test/datafile
-  (let* ((display (open-display host))
+  (let* ((display (open-default-display))
 	 (width 400)
 	 (height 400)
 	 (screen (display-default-screen display))
@@ -55,15 +55,15 @@
 	      (when (zerop count) ;; Ignore all but the last exposure event
 		(clear-area window)
 		;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES
-		(poly-fill-Trapezoids window gc  '(10 20 30 40 100 200))
+		(draw-filled-trapezoids window gc  '(10 20 30 40 100 200))
 		(setf (gcontext-trapezoid-alignment gc) :y)
-		(poly-fill-Trapezoids window gc  #(10 20 30 40 100 200))
+		(draw-filled-trapezoids window gc  #(10 20 30 40 100 200))
 		(with-gcontext (gc :trapezoid-alignment :x)
-		  (poly-fill-Trapezoids window gc  '(40 50 60 70 140 240)))
+		  (draw-filled-trapezoids window gc  '(40 50 60 70 140 240)))
 		(setf (gcontext-trapezoid-alignment gc) :x)
-		(poly-fill-Trapezoids window gc  #(40 50 60 70 80 90))
+		(draw-filled-trapezoids window gc  #(40 50 60 70 80 90))
 		(with-gcontext (gc :trapezoid-alignment :y)
-		  (poly-fill-Trapezoids window gc  #(40 50 60 70 140 240)))
+		  (draw-filled-trapezoids window gc  #(40 50 60 70 140 240)))
 		  
 		(draw-glyphs window gc 10 10 "Press any key to exit")
 		;; Returning non-nil causes event-case to exit
diff --git a/clx/text.lisp b/clx/text.lisp
index 6c3aa79bbe50e3330fb59e3af1ee265aefe82de2..6e3b0a478baa96fc547510fcadb72e1cfa746a7f 100644
--- a/clx/text.lisp
+++ b/clx/text.lisp
@@ -19,7 +19,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: text.lisp,v 1.8 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: text.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -73,8 +73,8 @@
 	   (inline graphic-char-p))
   (declare (clx-values integer (or null integer font) (or null integer)))
 
-  (let ((min-char-index (xlib:font-min-char font))
-        (max-char-index (xlib:font-max-char font)))
+  (let ((min-char-index (and font (xlib:font-min-char font)))
+        (max-char-index (and font (xlib:font-max-char font))))
     (if (stringp src)
 	(do ((i src-start (index+ i 1))
 	     (j dst-start (index+ j 1))
@@ -83,7 +83,7 @@
 	     i)
 	  (declare (type array-index i j))
 	  (setf char (char->card8 (char src i)))
-	  (if (or (< char min-char-index) (> char max-char-index))
+	  (if (and font (or (< char min-char-index) (> char max-char-index)))
 	      (return i)
 	      (setf (aref dst j) char)))
 	(do ((i src-start (index+ i 1))
@@ -95,8 +95,9 @@
 	  (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))
+                  (and font
+                       (< elt min-char-index)
+                       (> elt max-char-index)))
 	      (return i)
 	      (setf (aref dst j) elt))))))
 
@@ -481,7 +482,7 @@
       (setf (aref vector 0) elt)
       (multiple-value-bind (new-start new-font translate-width)
 	  (funcall (or translate #'translate-default)
-		   vector 0 1 (gcontext-font gcontext t) vector 1)
+		   vector 0 1 (gcontext-font gcontext nil) vector 1)
 	;; Allow translate to set a new font
 	(when (type? new-font 'font) 
 	  (setf (gcontext-font gcontext) new-font)
@@ -552,8 +553,7 @@
 	 (length (index- src-end src-start))
 	 (request-length (* length 2))		; Leave lots of room for font shifts.
 	 (display (gcontext-display gcontext))
-	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	 (font (gcontext-font gcontext t)))
+	 (font (gcontext-font gcontext nil)))
     (declare (type array-index src-start src-end length)
 	     (type (or null array-index) next-start)
 	     (type display display))
@@ -655,8 +655,7 @@
 	 (length (index- src-end src-start))
 	 (request-length (* length 3))		; Leave lots of room for font shifts.
 	 (display (gcontext-display gcontext))
-	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	 (font (gcontext-font gcontext t))
+	 (font (gcontext-font gcontext nil))
 	 (buffer (display-tbuf16 display)))
     (declare (type array-index src-start src-end length)
 	     (type (or null array-index) next-start)
@@ -762,7 +761,7 @@
       (setf (aref vector 0) elt)
       (multiple-value-bind (new-start new-font translate-width)
 	  (funcall (or translate #'translate-default)
-		   vector 0 1 (gcontext-font gcontext t) vector 1)
+		   vector 0 1 (gcontext-font gcontext nil) vector 1)
 	;; Allow translate to set a new font
 	(when (type? new-font 'font) 
 	  (setf (gcontext-font gcontext) new-font)
@@ -839,8 +838,7 @@
   (declare (clx-values (or null array-index) (or null int32)))
   (do* ((display (gcontext-display gcontext))
 	(length (index- end start))
-	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	(font (gcontext-font gcontext t))
+	(font (gcontext-font gcontext nil))
 	(font-change nil)
 	(new-start) (translated-width) (chunk))
        (nil) ;; forever
@@ -905,8 +903,7 @@
   (declare (clx-values (or null array-index) (or null int32)))
   (do* ((display (gcontext-display gcontext))
 	(length (index- end start))
-	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
-	(font (gcontext-font gcontext t)) 
+	(font (gcontext-font gcontext nil)) 
 	(font-change nil)
 	(new-start) (translated-width) (chunk)
 	(buffer (buffer-tbuf16 display)))
diff --git a/clx/translate.lisp b/clx/translate.lisp
index 01506f5beccca579eeae468647fb11f32e9d9a70..1c015c7e70edcc927b79c8c2257b2870085d7d0b 100644
--- a/clx/translate.lisp
+++ b/clx/translate.lisp
@@ -17,7 +17,7 @@
 ;;;
 
 #+cmu
-(ext:file-comment "$Id: translate.lisp,v 1.5 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: translate.lisp,v 1.6 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
diff --git a/clx/xinerama.lisp b/clx/xinerama.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ee688e64b404e0d4c04317ac173337d3f83162f3
--- /dev/null
+++ b/clx/xinerama.lisp
@@ -0,0 +1,93 @@
+;;; -*- Mode: Lisp -*-
+;;;
+;;; Copyright (C) 2008, Julian Stecklina
+;;;
+;;;   ((
+;;;    ))     This file is COFFEEWARE. As long as you retain this notice
+;;;  |   |o)  you can do whatever you want with this code. If you think,
+;;;  |___|jgs it's worth it, you may buy the author a coffee in return.
+;;;
+;;; Description:
+;;;
+;;; This is an implementation of the XINERAMA extension. It does not
+;;; include the obsolete PanoramiX calls.
+
+(defpackage "XLIB.XINERAMA"
+  (:use "COMMON-LISP" "XLIB")
+  (:nicknames "XINERAMA")
+  (:import-from "XLIB"
+		"WITH-BUFFER-REQUEST"
+		"WITH-BUFFER-REQUEST-AND-REPLY"
+		"DATA"
+		"BOOLEAN" "BOOLEAN-GET"
+		"CARD8" "CARD8-GET"
+		"CARD16" "CARD16-GET"
+		"CARD32" "CARD32-GET"
+		"INT16" "INT16-GET")
+  (:export "SCREEN-INFO"
+           "SCREEN-INFO-NUMBER"
+           "SCREEN-INFO-X"
+           "SCREEN-INFO-Y"
+           "SCREEN-INFO-WIDTH"
+           "SCREEN-INFO-HEIGHT"
+           "XINERAMA-QUERY-VERSION"
+           "XINERAMA-IS-ACTIVE"
+           "XINERAMA-QUERY-SCREENS"))
+(in-package "XINERAMA")
+
+(define-extension "XINERAMA")
+
+(defun xinerama-opcode (display)
+  (extension-opcode display "XINERAMA"))
+
+(defconstant +major-version+ 1)
+(defconstant +minor-version+ 1)
+
+(defconstant +get-version+ 0)
+(defconstant +get-state+ 1)
+(defconstant +get-screen-count+ 2)
+(defconstant +get-screen-size+ 3)
+(defconstant +is-active+ 4)
+(defconstant +query-screens+ 5)
+
+(defstruct screen-info
+  (number 0 :type (unsigned-byte 32))
+  (x 0 :type (signed-byte 16))
+  (y 0 :type (signed-byte 16))
+  (width 0 :type (unsigned-byte 16))
+  (height 0 :type (unsigned-byte 16)))
+
+(defun xinerama-query-version (display)
+  (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+    ((data +get-version+)
+     (card8 +major-version+)
+     (card8 +minor-version+))
+    (values
+     (card16-get 8)                     ; server major version
+     (card16-get 10))))                 ; server minor version
+
+(defun xinerama-is-active (display)
+  "Returns T, iff Xinerama is supported and active."
+  (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+    ((data +is-active+))
+    (values
+     ;; XCB says this is actually a CARD32, but why?!
+     (boolean-get 8))))
+
+(defun xinerama-query-screens (display)
+  "Returns a list of screen-info structures."
+  (with-buffer-request-and-reply (display (xinerama-opcode display) nil)
+    ((data +query-screens+))
+    (values
+     (loop
+        with index = 32
+        for number from 0 below (card32-get 8)
+        collect (prog1
+                    (make-screen-info :number number
+                                      :x (int16-get index)
+                                      :y (int16-get (+ index 2))
+                                      :width (card16-get (+ index 4))
+                                      :height (card16-get (+ index 6)))
+                  (incf index 8))))))
+
+;;; EOF
diff --git a/clx/xrender.lisp b/clx/xrender.lisp
index e3bb1894b38e318e069d0884769c028227aabcce..a0b3b961ba6e4a8c325309ae135b6047933a2439 100644
--- a/clx/xrender.lisp
+++ b/clx/xrender.lisp
@@ -4,7 +4,7 @@
 ;;;   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 $")
+(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 ;;; ---------------------------------------------------------------------------
 ;;;
 ;;; (c) copyright 2002, 2003 by Gilbert Baumann
@@ -28,14 +28,14 @@
 
 ;; - 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
+;;     isn't even conforming to the acctual protocol. However backwards
+;;     wierd that sound. --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
+;; - we want some conviencene function to turn graphics contexts into
 ;;   render pictures. --GB 2002-08-21
 
 ;; - also: uniform-alpha-picture display alpha-value
@@ -134,11 +134,7 @@
           render-composite-glyphs
           render-add-glyph
           render-add-glyph-from-picture
-          render-free-glyphs
-          
-          
-	  render-combine
-	  ))
+          render-free-glyphs))
 
 (pushnew :clx-ext-render *features*)
 
@@ -214,7 +210,7 @@
 
 (defun ensure-render-initialized (display)
   "Ensures that the RENDER extension is initialized. Should be called
-by every function that attempts to generate RENDER requests."
+by every function, which attempts to generate RENDER requests."
   ;; xxx locking?
   (unless (display-render-info display)
     (let ((q (make-render-info)))
@@ -269,9 +265,8 @@ by every function that attempts to generate RENDER requests."
     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))
+  "Find the picture format which matches the given window."
+  (let* ((vi (window-visual-info window))
          (display (window-display window)))
     (ensure-render-initialized display)
     (case (visual-info-class vi)
@@ -342,13 +337,43 @@ by every function that attempts to generate RENDER requests."
   (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))
+               :out :out-reverse :atop :atop-reverse :xor :add :saturate
+               '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
+               :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
+               :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
+               :disjoint-out :disjoint-out-reverse :disjoint-atop
+               :disjoint-atop-reverse :disjoint-xor
+               '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
+               '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
+               :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
+               :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
+               :conjoint-out :conjoint-out-reverse :conjoint-atop
+               :conjoint-atop-reverse :conjoint-xor))
     ((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)))
+                     :out :out-reverse :atop :atop-reverse :xor :add :saturate
+                     '#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
+                     :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
+                     :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
+                     :disjoint-out :disjoint-out-reverse :disjoint-atop
+                     :disjoint-atop-reverse :disjoint-xor
+                     '#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
+                     '#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
+                     :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
+                     :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
+                     :conjoint-out :conjoint-out-reverse :conjoint-atop
+                     :conjoint-atop-reverse :conjoint-xor)))
   (deftype render-op ()
     '(member :clear :src :dst :over :over-reverse :in :in-reverse
-      :out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum)))
+      :out :out-reverse :atop :atop-reverse :xor :add :saturate
+      :disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
+      :disjoint-over-reverse :disjoint-in :disjoint-in-reverse
+      :disjoint-out :disjoint-out-reverse :disjoint-atop
+      :disjoint-atop-reverse :disjoint-xor
+      :conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
+      :conjoint-over-reverse :conjoint-in :conjoint-in-reverse
+      :conjoint-out :conjoint-out-reverse :conjoint-atop
+      :conjoint-atop-reverse :conjoint-xor)))
 
 ;; Now these pictures objects are like graphics contexts. I was about
 ;; to introduce a synchronous mode, realizing that the RENDER protocol
@@ -421,9 +446,9 @@ by every function that attempts to generate RENDER requests."
                                     ,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 (aref (picture-%server-values picture) ,index)
+                                 (aref (picture-%values picture) ,index))))
+
                    (setf (picture-%changed-p picture) nil)))
 
                (defun render-create-picture
@@ -680,7 +705,7 @@ by every function that attempts to generate RENDER requests."
   )
 ||#
 
-(defun render-trapezoids-1 (picture op source src-x src-y format coord-sequence)
+(defun render-trapezoids-1 (picture op source src-x src-y mask-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 ...
@@ -695,7 +720,7 @@ by every function that attempts to generate RENDER requests."
       (card16 0)                        ;pad
       (resource-id (picture-id source))
       (resource-id (picture-id picture))
-      (picture-format format)
+      ((or (member :none) picture-format) mask-format)
       (int16 src-x)
       (int16 src-y)
       ((sequence :format int32) coord-sequence) )))
@@ -1040,17 +1065,17 @@ by every function that attempts to generate RENDER requests."
            (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-composite :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-composite :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))))
@@ -1079,23 +1104,22 @@ by every function that attempts to generate RENDER requests."
                (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 ((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-composite 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)))
diff --git a/clx/xtest.lisp b/clx/xtest.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..587a845b8d4b321c2d4eb113d2a5e32e044469ef
--- /dev/null
+++ b/clx/xtest.lisp
@@ -0,0 +1,154 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
+;;;
+;;; Implementation of the XTest extension as described by
+;;; http://www.x.org/docs/Xext/xtest.pdf
+;;;
+;;; Written by Lionel Flandrin <lionel.flandrin@gmail.com> in july
+;;; 2008 and placed in the public domain.
+;;;
+;;; TODO:
+;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard
+;;; * Add the missing (declare (type ...
+
+(defpackage :xtest
+  (:use :common-lisp :xlib)
+  (:import-from :xlib
+                #:data
+                #:card8
+                #:card8-get
+                #:card16
+                #:card16-get
+                #:card32
+                #:card32-get
+                #:extension-opcode
+                #:define-extension
+                #:gcontext
+                #:resource-id
+                #:window-id
+                #:cursor
+                #:make-cursor
+                #:with-buffer-request-and-reply
+                #:with-buffer-request
+                #:display)
+  (:export
+   ;; Constants
+   #:+major-version+
+   #:+minor-version+
+
+   ;; Functions
+   #:set-gc-context-of-gc
+   #:get-version
+   #:compare-cursor
+   #:fake-motion-event
+   #:fake-button-event
+   #:fake-key-event
+   #:grab-control))
+
+(in-package :xtest)
+
+(define-extension "XTEST")
+
+(defmacro opcode (display)
+  `(extension-opcode ,display "XTEST"))
+
+;;; The version we implement
+(defconstant +major-version+ 2)
+(defconstant +minor-version+ 2)
+
+(defconstant +none+           0)
+(defconstant +current-cursor+ 1)
+
+;;; XTest opcodes
+(defconstant +get-version+    0)
+(defconstant +compare-cursor+ 1)
+(defconstant +fake-input+     2)
+(defconstant +grab-control+   3)
+
+;;; Fake events
+(defconstant +fake-key-press+      2)
+(defconstant +fake-key-release+    3)
+(defconstant +fake-button-press+   4)
+(defconstant +fake-button-release+ 5)
+(defconstant +fake-motion-notify+  6)
+
+;;; Client operations
+(defun set-gc-context-of-gc (gcontext gcontext-id)
+  (declare (type gcontext gcontext)
+           (type resource-id gcontext-id))
+    (setf (gcontext-id gcontext) gcontext-id))
+
+;;; Server requests
+(defun get-version (display &optional (major +major-version+) (minor +minor-version+))
+  "Returns the major and minor version of the server's XTest implementation"
+  (declare (type display display))
+  (with-buffer-request-and-reply (display (opcode display) nil)
+      ((data +get-version+)
+       (card8 major)
+       (card16 minor))
+    (values (card8-get 1)
+            (card16-get 8))))
+
+(defun compare-cursor (display window &optional (cursor-id +current-cursor+))
+  (declare (type display display)
+           (type resource-id cursor-id)
+           (type window window))
+  (with-buffer-request-and-reply (display (opcode display) nil)
+      ((data +compare-cursor+)
+       (resource-id (window-id window))
+       (resource-id cursor-id))
+    (values (card8-get 1))))
+
+(defun fake-motion-event (display x y &key (delay 0) relative (root-window-id 0))
+  "Move the mouse pointer at coordinates (x, y). If :relative is t,
+the movement is relative to the pointer's current position"
+  (declare (type display display))
+  (with-buffer-request (display (opcode display))
+    (data +fake-input+)
+    (card8 +fake-motion-notify+)
+    (card8  (if relative 1 0))
+    (pad16 0)
+    (card32 delay)
+    (card32 root-window-id)
+    (pad32 0 0)
+    (card16 x)
+    (card16 y)
+    (pad32 0 0)))
+
+(defun fake-button-event (display button pressed &key (delay 0))
+  "Send a fake button event (button pressed or released) to the
+server. Most of the time, button 1 is the left one, 2 the middle and 3
+the right one but it's not always the case."
+  (declare (type display display))
+  (with-buffer-request (display (opcode display))
+    (data +fake-input+)
+    (card8 (if pressed +fake-button-press+ +fake-button-release+))
+    (card8 button)
+    (pad16 0)
+    (card32 delay)
+    (pad32 0 0 0 0 0 0)))
+
+(defun fake-key-event (display keycode pressed &key (delay 0))
+  "Send a fake key event (key pressed or released) to the server based
+on its keycode."
+  (declare (type display display))
+  (with-buffer-request (display (opcode display))
+    (data +fake-input+)
+    (card8 (if pressed +fake-key-press+ +fake-key-release+))
+    (card8 keycode)
+    (pad16 0)
+    (card32 delay)
+    (pad32 0 0 0 0 0 0)))
+
+(defun grab-control (display grab?)
+  "Make the client grab the server, that is allow it to make requests
+even when another client grabs the server."
+  (declare (type display display))
+  (with-buffer-request (display (opcode display))
+    (data +grab-control+)
+    (card8 (if grab? 1 0))
+    (pad8  0)
+    (pad16 0)))
+
+;;; Local Variables:
+;;; indent-tabs-mode: nil
+;;; End:
diff --git a/clx/xvidmode.lisp b/clx/xvidmode.lisp
index 9f13d0f980721b11a888dbfbb797b5ba0aa7b5d6..a58b38b078e274118949a86c535d8623d3877a10 100644
--- a/clx/xvidmode.lisp
+++ b/clx/xvidmode.lisp
@@ -36,7 +36,7 @@
 ;;; functions I made.
 
 #+cmu
-(ext:file-comment "$Id: xvidmode.lisp,v 1.1 2007/08/21 15:49:28 fgilham Exp $")
+(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
 
 (in-package :xlib)
 
@@ -439,7 +439,7 @@ invalid."
 (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))
+	   (type (single-float 0.100f0 10.000f0) red green blue))
   (with-buffer-request (dpy (vidmode-opcode dpy))
     (data +set-gamma+)
     (card16 (screen-position scr dpy))