diff --git a/src/clx/README.md b/src/clx/README.md
index bf62d0af4ac82dc269fa29b89dc6c8ae62cd225d..5adf841071175b2736b2c8fdff59378c86cafc4f 100644
--- a/src/clx/README.md
+++ b/src/clx/README.md
@@ -5,27 +5,29 @@ taken from a CMUCL distribution, was modified somewhat in order to
 make it compile and run under SBCL, then a selection of patches were
 added from other CLXes around the net.
 
-# Features
+## Features
 
  - SHAPE extension support (Gilbert Baumann)
  - XFREE86-VIDMODE extension support (Iban Hatchondo)
- - experimental RENDER extension support 
+ - experimental RENDER extension support
      (Gilbert Baumann and Christian Sunesson)
  - X authority support that works with ssh forwarding (Eric Marsden via CMUCL)
  - OPEN-DEFAULT-DISPLAY function which, as the name suggests, does that (dan)
  - various bug fixes (Iban Hatchondo and a cast of several)
  - a manual in texinfo format (Shawn Betts, Gilbert Baumann)
 
-# Supported versions
+## Supported versions
 
-CLX should work with SBCL, CCL, ECL and CLISP. If it doesn't please submit an
+CLX should work with CCL, CLISP, CMUCL, ECL and SBCL. If it doesn't please submit an
 [issue](https://github.com/sharplispers/clx/issues/new) along with the version
 information of your implementation.
 
 Allegro Common Lisp users should use clx version maintained by Franz Inc., which can
 be found at [https://github.com/franzinc/clx](https://github.com/franzinc/clx)
 
-# Building using quicklisp
+## Getting started
+
+### Building using Quicklisp
 
 ```lisp
 (ql:quickload 'clx)
@@ -45,7 +47,7 @@ cd ~/quicklisp/local-projects/
 git clone git://github.com/sharplispers/clx.git
 ```
 
-# Building using ASDF
+### Building using ASDF
 
 If you don't have quicklisp installed you can use ASDF to load CLX. To do so clone this repository to either:
 
@@ -58,7 +60,7 @@ and then on the lisp REPL type
 
 ```lisp
 (require 'asdf)
-(asdf:load-system 'clx)
+(asdf:load-system "clx")
 ```
 
 If you want to load clx from another location you have to first tell ASDF to
@@ -67,42 +69,35 @@ look in that directory by adding the directory to ASDF's central registry on eve
 ```lisp
 (require 'asdf)
 (push "/path/to/the/clx/directory/" asdf:*central-registry*) ; Mind the trailing slash, it is important.
-(asdf:load-system 'clx)
+(asdf:load-system "clx")
 ```
 
 or you can configure ASDF to look in your directory as described in the [ASDF Manual](https://common-lisp.net/project/asdf/asdf.html#Configuring-ASDF-to-find-your-systems)
 
-To load demo and test files as well:
-
-```lisp
-(asdf:load-system 'clx/demo)
-```
-
-
-# Demos
+### Demos
 
-To test CLX (and get a small amount of Lisp advocacy), try loading the file
-"demo/menu", and then executing the function xlib::just-say-lisp.
+To test CLX, load the demo and test files and start the demo overview:
 
 ```lisp
-(load "clx/demo/menu")
-(xlib::just-say-lisp)
+(asdf:load-system "clx/demo")
+(xlib-demo/demos:demo)
 ```
 
 Note: If you're new to Lisp, be advised that despite the examples in
-demo/, it's generally /not/ considered good style to switch to the
-:xlib package and write your code in it.  Spend some time with a
-language reference to familiarize yourself with USE-PACKAGE, or 
-better yet, the USE option to DEFPACKAGE.
+the `demo/` directory, it's generally *not* considered good style to switch to the
+`:xlib` package and write your code in it.  Spend some time with a
+language reference to familiarize yourself with `use-package`, or
+better yet, the `:use` option to `defpackage`.
 
-# Documentation
+## Documentation
 
 An up to date version of the manual can be found at [sharplispers.github.io/clx](https://sharplispers.github.io/clx/)
 
-#Bug reports, new features, patches
+## Bug reports, new features, patches
 
 Please use github to track issues:
-# Contributing
+
+## Contributing
 
 To contribute submit a [pull request](https://github.com/sharplispers/clx/pulls)
 
@@ -111,11 +106,10 @@ To report bugs, request features, etc please use the [github issue tracker](http
 ---
 
 Heavy lifting by <Raymond.Wiker at fast.no>
-ASDFized version by Daniel Barlow <dan at metacircles.com> 
+ASDFized version by Daniel Barlow <dan at metacircles.com>
 and Christophe Rhodes <csr21 at cam.ac.uk>
 
 The sharplispers group on github have recently (November 2011)
 "adopted" clx and maintain the version that lives at:
 
 https://github.com/sharplispers/clx
-
diff --git a/src/clx/attributes.lisp b/src/clx/attributes.lisp
index 613abda304a8c3bc9525e1c0018b44af2d91bb41..cd959ebbaee3265500a340ab2b656a814d4b4355 100644
--- a/src/clx/attributes.lisp
+++ b/src/clx/attributes.lisp
@@ -64,7 +64,7 @@
 (defmacro state-attribute-changes (state) `(third ,state))
 (defmacro state-geometry (state) `(fourth ,state))
 (defmacro state-geometry-changes (state) `(fifth ,state))
- 
+
 (defmacro drawable-equal-function ()
   ;; Since drawables are not always cached, we must use drawable-equal
   ;; to determine equality.
@@ -298,7 +298,7 @@
 (defmacro with-attributes ((window &rest options) &body body)
   `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
      (declare (type reply-buffer .with-attributes-reply-buffer.))
-     (prog1 
+     (prog1
        (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
        (unless *window-attributes*
 	 (deallocate-context .with-attributes-reply-buffer.)))))
@@ -309,7 +309,7 @@
 (defmacro with-geometry ((window &rest options) &body body)
   `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
      (declare (type reply-buffer .with-geometry-reply-buffer.))
-     (prog1 
+     (prog1
        (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
        (unless *window-attributes*
 	 (deallocate-context .with-geometry-reply-buffer.)))))
@@ -336,32 +336,43 @@
   (with-attributes (window :sizes 16)
     (member16-get 12 :copy :input-output :input-only)))
 
+(deftype window-background ()
+  '(or (member :none :parent-relative) pixel pixmap))
+
 (defun set-window-background (window background)
-  (declare (type window window)
-	   (type (or (member :none :parent-relative) pixel pixmap) background))
-  (cond ((eq background :none) (change-window-attribute window 0 0))
-	((eq background :parent-relative) (change-window-attribute window 0 1))
-	((integerp background) ;; Background pixel
-	 (change-window-attribute window 0 0) ;; pixmap :NONE
-	 (change-window-attribute window 1 background))
-	((type? background 'pixmap) ;; Background pixmap
-	 (change-window-attribute window 0 (pixmap-id background)))
-	(t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
+  (declare (type window window))
+  (if (not (typep background 'window-background))
+      (x-type-error background '(or (member :none :parent-relative) integer pixmap))
+      (locally (declare (type window-background background))
+        (cond ((eq background :none)
+               (change-window-attribute window 0 0))
+              ((eq background :parent-relative)
+               (change-window-attribute window 0 1))
+              ((integerp background) ; Background pixel
+               (change-window-attribute window 0 0) ; pixmap :NONE
+               (change-window-attribute window 1 background))
+              ((type? background 'pixmap) ; Background pixmap
+               (change-window-attribute window 0 (pixmap-id background))))))
   background)
 
 #+Genera (eval-when (compile) (compiler:function-defined 'window-background))
 
 (defsetf window-background set-window-background)
 
+(deftype window-border ()
+  '(or (member :copy) pixel pixmap))
+
 (defun set-window-border (window border)
-  (declare (type window window)
-	   (type (or (member :copy) pixel pixmap) border))
-  (cond ((eq border :copy) (change-window-attribute window 2 0))
-	((type? border 'pixmap) ;; Border pixmap
-	 (change-window-attribute window 2 (pixmap-id border)))
-	((integerp border) ;; Border pixel
-	 (change-window-attribute window 3 border))
-	(t (x-type-error border '(or (member :copy) integer pixmap))))
+  (declare (type window window))
+  (if (not (typep border 'window-border))
+      (x-type-error border '(or (member :copy) integer pixmap))
+      (locally (declare (type window-border border))
+        (cond ((eq border :copy)
+               (change-window-attribute window 2 0))
+              ((type? border 'pixmap) ; Border pixmap
+               (change-window-attribute window 2 (pixmap-id border)))
+              ((integerp border) ; Border pixel
+               (change-window-attribute window 3 border)))))
   border)
 
 #+Genera (eval-when (compile) (compiler:function-defined 'window-border))
@@ -405,7 +416,7 @@
 
 (defun set-window-backing-store (window when)
   (change-window-attribute
-    window 6 (encode-type (member :not-useful :when-mapped :always) when))
+   window 6 (encode-type (member :not-useful :when-mapped :always) when))
   when)
 
 (defsetf window-backing-store set-window-backing-store)
diff --git a/src/clx/buffer.lisp b/src/clx/buffer.lisp
index dd71190e255d1e65f43c2f1a27bbaa89126df0c0..aa24ca7dbe345d4faf2ba9f6b6e710e502d54375 100644
--- a/src/clx/buffer.lisp
+++ b/src/clx/buffer.lisp
@@ -84,12 +84,12 @@
 
 (defun with-buffer-function (buffer timeout function)
   (declare (type display buffer)
-	   (type (or null number) timeout)
-	   (type function function)
-	   (dynamic-extent function)
-	   ;; FIXME: This is probably more a bug in SBCL (logged as
-	   ;; bug #243)
-	   (ignorable timeout))
+           (type (or null real) timeout)
+           (type function function)
+           (dynamic-extent function)
+           ;; FIXME: This is probably more a bug in SBCL (logged as
+           ;; bug #243)
+           (ignorable timeout))
   (with-buffer (buffer :timeout timeout :inline t)
     (funcall function)))
 
@@ -404,7 +404,7 @@
   (declare (type buffer buffer)
 	   (type vector vector)
 	   (type array-index start end)
-	   (type (or null number) timeout))
+	   (type (or null real) timeout))
   (declare (clx-values eof-p))
   (when (buffer-dead buffer)
     (x-error 'closed-display :display buffer))
diff --git a/src/clx/clx.asd b/src/clx/clx.asd
index 48872ccf64e08271728b8646fb071490abe212d1..28aa580606e06b08e82176382cdbc13ee240f3ae 100644
--- a/src/clx/clx.asd
+++ b/src/clx/clx.asd
@@ -31,92 +31,92 @@
 (defclass legacy-file (static-file) ())
 
 (defsystem #:clx
-    :description "An implementation of the X Window System protocol in Lisp."
-    :author "Texas Instruments Incorporated.
+  :description "An implementation of the X Window System protocol in Lisp."
+  :author "Texas Instruments Incorporated.
 Franz Inc, Berkeley, Ca.
 Independent FOSS developers"
-    :maintainer "sharplispers"
-    :license "MIT"
-    :depends-on (#+(or ecl sbcl) sb-bsd-sockets)
-    :version "0.7.5"
-    :serial t
-    :default-component-class clx-source-file
-    :in-order-to ((test-op (test-op "clx/test")))
-    :components
-    ((:file "package")
-     (:file "depdefs")
-     (:file "clx")
-     #-(or openmcl allegro lispworks) (:file "dependent")
-     #+openmcl (:file "dep-openmcl")
-     #+allegro (:file "dep-allegro")
-     #+lispworks (:file "dep-lispworks")
-     (: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"
-	      :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 "randr")
-               (:file "xinerama")
-               (:file "dbe")
-               (:file "xc-misc")
-               (:file "dri2")
-               (:file "composite")))
-     (:static-file "NEWS")
-     (:static-file "CHANGES")
-     (:static-file "README.md")
-     (: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")))))
+  :maintainer "sharplispers"
+  :license "MIT"
+  :depends-on (#+(or ecl sbcl) sb-bsd-sockets)
+  :version "0.7.5"
+  :serial t
+  :default-component-class clx-source-file
+  :in-order-to ((test-op (test-op "clx/test")))
+  :components
+  ((:file "package")
+   (:file "depdefs")
+   (:file "clx")
+   #-(or openmcl allegro lispworks) (:file "dependent")
+   #+openmcl (:file "dep-openmcl")
+   #+allegro (:file "dep-allegro")
+   #+lispworks (:file "dep-lispworks")
+   (: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")
+   (:module "extensions"
+	    :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 "randr")
+             (:file "xinerama")
+             (:file "dbe")
+             (:file "xc-misc")
+             (:file "dri2")
+             (:file "composite")))
+   (:static-file "NEWS")
+   (:static-file "CHANGES")
+   (:static-file "README.md")
+   (: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")))))
 
 (defsystem #:clx/demo
   :depends-on ("clx")
   :components
   ((:module "demo"
 	    :components
-	    ((:file "bezier")
+	    ((:file "menu")
+             (:file "bezier")
 	     (:file "beziertest" :depends-on ("bezier"))
 	     (:file "clclock")
 	     (:file "clipboard")
@@ -126,7 +126,6 @@ Independent FOSS developers"
 	     ;; deletion notes.  Find out why, and either fix or
 	     ;; workaround the problem.
 	     (:file "mandel")
-	     (:file "menu")
 	     (:file "zoid")
 	     (:file "image")
 	     (:file "trapezoid" :depends-on ("zoid"))))))
@@ -174,42 +173,3 @@ Independent FOSS developers"
         (progv (list sadx-var) (list t)
           (call-next-method))
         (call-next-method))))
-
-#+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/src/clx/clx.lisp b/src/clx/clx.lisp
index 2795556245ead84d7ab108abaf9540554e968659..5be6fa2bf8361ed7b7b573d5bb63203e5f481e16 100644
--- a/src/clx/clx.lisp
+++ b/src/clx/clx.lisp
@@ -329,8 +329,7 @@
   (atom-id-map (make-hash-table :test (resource-id-map-test)
 				:size *atom-cache-size*)
 	       :type hash-table)
-  (extended-max-request-length 0 :type card32)
-  )
+  (extended-max-request-length 0 :type card32))
 
 (defun print-display-name (display stream)
   (declare (type (or null display) display))
@@ -359,8 +358,8 @@
 (def-clx-class (drawable (:copier nil) (:print-function print-drawable))
   (id 0 :type resource-id)
   (display nil :type (or null display))
-  (plist nil :type list)			; Extension hook
-  )
+  ;; Extension hook
+  (plist nil :type list))
 
 (defun print-drawable (drawable stream depth)
   (declare (type drawable drawable)
@@ -371,12 +370,10 @@
     (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream))))
 
 (def-clx-class (window (:include drawable) (:copier nil)
-		       (:print-function print-drawable))
-  )
+		       (:print-function print-drawable)))
 
 (def-clx-class (pixmap (:include drawable) (:copier nil)
-		       (:print-function print-drawable))
-  )
+		       (:print-function print-drawable)))
 
 (def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
   (id 0 :type resource-id)
@@ -406,8 +403,7 @@
 (def-clx-class (colormap (:copier nil) (:print-function print-colormap))
   (id 0 :type resource-id)
   (display nil :type (or null display))
-  (visual-info nil :type (or null visual-info))
-  )
+  (visual-info nil :type (or null visual-info)))
 
 (defun print-colormap (colormap stream depth)
   (declare (type colormap colormap)
@@ -422,8 +418,7 @@
 
 (def-clx-class (cursor (:copier nil) (:print-function print-cursor))
   (id 0 :type resource-id)
-  (display nil :type (or null display))
-  )
+  (display nil :type (or null display)))
 
 (defun print-cursor (cursor stream depth)
   (declare (type cursor cursor)
@@ -536,8 +531,7 @@
   (server-state (allocate-gcontext-state) :type gcontext-state)
   (local-state (allocate-gcontext-state) :type gcontext-state)
   (plist nil :type list)			; Extension hook
-  (next nil #-explorer :type #-explorer (or null gcontext))
-  )
+  (next nil #-explorer :type #-explorer (or null gcontext)))
 
 (defun print-gcontext (gcontext stream depth)
   (declare (type gcontext gcontext)
diff --git a/src/clx/demo/clclock.lisp b/src/clx/demo/clclock.lisp
index c5413dadca04c1bfa1d85d75dbb0b407e2d8dcdf..c519261c3190cd1c5fc9a990cdd157d5342476f9 100644
--- a/src/clx/demo/clclock.lisp
+++ b/src/clx/demo/clclock.lisp
@@ -4,46 +4,8 @@
 
 (in-package #:xlib-demo/clclock)
 
-(defvar *display* (xlib:open-default-display))
-(defvar *screen* (xlib:display-default-screen *display*))
-(defvar *colormap* (xlib:screen-default-colormap *screen*))
-
-(defvar *font* (xlib:open-font *display* "fixed"))
-(defvar *win*)
-
-(multiple-value-bind (width ascent)
-    (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII")
-  (setq *win*
-    (xlib:create-window
-     :parent (xlib:screen-root *screen*)
-     :x 512
-     :y 512
-     :width (+ 20 width) 
-     :height (+ 20 ascent)
-     :background (xlib:alloc-color *colormap*
-				   (xlib:lookup-color *colormap*
-						      "midnightblue")))))
-
-(defvar *gcontext* (xlib:create-gcontext
-                    :drawable *win*
-		    :fill-style :solid
-                    :background (xlib:screen-white-pixel *screen*)
-                    :foreground (xlib:alloc-color *colormap*
-						  (xlib:lookup-color
-						   *colormap*
-						   "yellow"))
-		    :font *font*))
-
-(defvar *background* (xlib:create-gcontext
-		      :drawable *win*
-		      :fill-style :solid
-		      :background (xlib:screen-white-pixel *screen*)
-		      :foreground (xlib:alloc-color *colormap*
-				   (xlib:lookup-color *colormap*
-						      "midnightblue"))
-		      :font *font*))
-(defvar *palette* nil)
-(defvar *black* (xlib:screen-black-pixel *screen*))
+(declaim (special *display* *screen* *colormap* *font* *win* *gcontext*
+                  *background* *palette* *black*))
 
 (defun romanize (arg)
   (if (zerop arg)
@@ -58,21 +20,56 @@
   (let ((string (clock-string)))
     (let ((string-width (xlib:text-width *gcontext* string)))
       (xlib:draw-rectangle *win* *background*
-			   0 0
-			   (xlib:drawable-width *win*)
-			   (xlib:drawable-height *win*)
-			   :fill-p)
+                           0 0
+                           (xlib:drawable-width *win*)
+                           (xlib:drawable-height *win*)
+                           :fill-p)
       (xlib:draw-glyphs *win* *gcontext*
-			(- (truncate
-			    (- (xlib:drawable-width *win*) string-width)
-			    2)
-			   10)
-			(- (xlib:drawable-height *win*) 10)
-			string)))
+                        (- (truncate
+                            (- (xlib:drawable-width *win*) string-width)
+                            2)
+                           10)
+                        (- (xlib:drawable-height *win*) 10)
+                        string)))
   (xlib:display-force-output *display*))
 
 (defun clock ()
-  (xlib:map-window *win*)
-  (loop
-   (update-clockface)
-   (sleep 1)))
+  (let* ((*display* (xlib:open-default-display))
+         (*screen* (xlib:display-default-screen *display*))
+         (*colormap* (xlib:screen-default-colormap *screen*))
+
+         (*font* (xlib:open-font *display* "fixed")))
+    (multiple-value-bind (width ascent)
+        (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII")
+      (setq *win* (xlib:create-window
+                   :parent (xlib:screen-root *screen*)
+                   :x 512
+                   :y 512
+                   :width (+ 20 width)
+                   :height (+ 20 ascent)
+                   :background (xlib:alloc-color *colormap*
+                                                 (xlib:lookup-color *colormap*
+                                                                    "midnightblue")))
+            *gcontext* (xlib:create-gcontext
+                        :drawable *win*
+                        :fill-style :solid
+                        :background (xlib:screen-white-pixel *screen*)
+                        :foreground (xlib:alloc-color *colormap*
+                                                      (xlib:lookup-color
+                                                       *colormap*
+                                                       "yellow"))
+                        :font *font*)
+            *background* (xlib:create-gcontext
+                          :drawable *win*
+                          :fill-style :solid
+                          :background (xlib:screen-white-pixel *screen*)
+                          :foreground (xlib:alloc-color *colormap*
+                                                        (xlib:lookup-color *colormap*
+                                                                           "midnightblue"))
+                          :font *font*)
+            *palette* nil
+            *black* (xlib:screen-black-pixel *screen*)))
+    (xlib:map-window *win*)
+    (loop
+      (update-clockface)
+      (sleep 1))))
diff --git a/src/clx/demo/clx-demos.lisp b/src/clx/demo/clx-demos.lisp
index 0179e538ba9e4b9836bb5e76546ed0387e5f2ca4..05a5a1c825147429e7c07af3cbf9bd3bf03e7492 100644
--- a/src/clx/demo/clx-demos.lisp
+++ b/src/clx/demo/clx-demos.lisp
@@ -5,9 +5,15 @@
 ;;;
 ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88.
 ;;;
+;;; CMUCL MP support by Douglas Crosher 1998.
+;;; Enhancements including the CLX menu, rewrite of the greynetic
+;;; demo, and other fixes by Fred Gilham 1998.
+;;;
+;;; Backported some changes found in CMUCL repository -- jd 2018-12-29.
 
-(defpackage #:xlib-demo/demos (:use :common-lisp)
-  (:export do-all-demos demo))
+(defpackage #:xlib-demo/demos
+  (:use :common-lisp)
+  (:export #:demo))
 
 (in-package :xlib-demo/demos)
 
@@ -21,6 +27,7 @@
 ;;; it is running.
 
 (defparameter *demos* nil)
+(defparameter *delay* 0.5)
 
 (defvar *display* nil)
 (defvar *screen* nil)
@@ -33,105 +40,82 @@
   `(progn
      (defun ,fun-name ,args
        ,doc
-       (unless *display*
-	 #+:cmu
-	 (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
-	 #+(or sbcl allegro clisp lispworks)
-	 (progn
-	   (setf *display* (xlib::open-default-display))
-	   (setf *screen* (xlib:display-default-screen *display*)))
-	 #-(or cmu sbcl allegro clisp lispworks)
-	 (progn
-	   ;; Portable method
-	   (setf *display* (xlib:open-display (machine-instance)))
-	   (setf *screen* (xlib:display-default-screen *display*)))
-	 (setf *root* (xlib:screen-root *screen*))
-	 (setf *black-pixel* (xlib:screen-black-pixel *screen*))
-	 (setf *white-pixel* (xlib:screen-white-pixel *screen*)))
-       (let ((*window* (xlib:create-window :parent *root*
-					   :x ,x :y ,y
-					   :event-mask nil
-					   :width ,width :height ,height
-					   :background *white-pixel*
-					   :border *black-pixel*
-					   :border-width 2
-					   :override-redirect :on)))
+       (let* ((*display* (or *display*
+                             (xlib:open-default-display)
+                             (xlib:open-display (machine-instance))))
+              (*screen* (xlib:display-default-screen *display*))
+              (*root* (xlib:screen-root *screen*))
+              (*black-pixel* (xlib:screen-black-pixel *screen*))
+              (*white-pixel* (xlib:screen-white-pixel *screen*))
+              (*window* (xlib:create-window :parent *root*
+                                            :x ,x :y ,y
+                                            :event-mask '(:visibility-change)
+                                            :width ,width :height ,height
+                                            :background *white-pixel*
+                                            :border *black-pixel*
+                                            :border-width 2
+                                            :override-redirect :off)))
+         (xlib:set-wm-properties *window*
+				 :name ,demo-name
+				 :icon-name ,demo-name
+				 :resource-name ,demo-name
+				 :x ,x :y ,y :width ,width :height ,height
+				 :user-specified-position-p t
+				 :user-specified-size-p t
+				 :min-width ,width :min-height ,height
+				 :width-inc nil :height-inc nil)
 	 (xlib:map-window *window*)
-	 ;; 
-	 ;; I hate to do this since this is not something any normal
-	 ;; program should do ...
-	 (setf (xlib:window-priority *window*) :above)
-	 (xlib:display-finish-output *display*)
-	 (unwind-protect
-	      (progn ,@forms)
-	   (xlib:unmap-window *window*)
-	   (xlib:display-finish-output *display*))))
+	 ;; Wait until we get mapped before doing anything.
+         (xlib:display-finish-output *display*)
+	 (unwind-protect (progn ,@forms)
+           (xlib:display-finish-output *display*)
+	   (xlib:unmap-window *window*))))
     (setf (get ',fun-name 'demo-name) ',demo-name)
     (setf (get ',fun-name 'demo-doc) ',doc)
-    (export ',fun-name)
     (pushnew ',fun-name *demos*)
     ',fun-name))
 
 
-;;;; Main entry points.
-
-(defun do-all-demos ()
-  (loop
-   (dolist (demo *demos*)
-     (funcall demo)
-     (sleep 3))))
-
-;;; DEMO is a hack to get by.  It should be based on creating a menu.  At
-;;; that time, *name-to-function* should be deleted, since this mapping will
-;;; be manifested in the menu slot name cross its action.  Also the
-;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for
-;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi".
-;;;
+;;; DEMO
 
 (defvar *name-to-function* (make-hash-table :test #'eq))
 (defvar *keyword-package* (find-package "KEYWORD"))
+(defvar *demo-names* nil)
 
 (defun demo ()
-  (macrolet ((read-demo ()
-	       `(let ((*package* *keyword-package*))
-		  (read))))
+  (let ((*demo-names* '("Quit")))
     (dolist (d *demos*)
       (setf (gethash (intern (string-upcase (get d 'demo-name))
 			     *keyword-package*)
 		     *name-to-function*)
-	    d))
-    (loop
-      (fresh-line)
-      (dolist (d *demos*)
-	(write-string "   ")
-	(write-line (get d 'demo-name)))
-      (write-string "   ")
-      (write-line "Help <demo name>")
-      (write-string "   ")
-      (write-line "Quit")
-      (write-string "Enter demo name: ")
-      (let ((demo (read-demo)))
-	(case demo
-	  (:help
-	   (let* ((demo (read-demo))
-		  (fun (gethash demo *name-to-function*)))
-	     (fresh-line)
-	     (if fun
-		 (format t "~&~%~A~&~%" (get fun 'demo-doc))
-		 (format t "Unknown demo name -- ~A." demo))))
-	  (:quit (return t))
-	  (t
-	   (let ((fun (gethash demo *name-to-function*)))
-	     (if fun
-		 #+mp
-		 (mp:make-process #'(lambda ()
-				      (loop
-				       (funcall fun)
-				       (sleep 2)))
-				  :name (format nil "~S" demo))
-		 #-mp
-		 (funcall fun)
-		 (format t "~&~%Unknown demo name -- ~A.~&~%" demo)))))))))
+	    d)
+      (push (get d 'demo-name) *demo-names*))
+  
+    (let* ((display (xlib:open-default-display))
+           (screen (xlib:display-default-screen display))
+           (fg-color (xlib:screen-white-pixel screen))
+           (bg-color (xlib:screen-black-pixel screen))
+           (nice-font (xlib:open-font display "fixed")))
+      
+      (let ((a-menu (xlib::create-menu
+                     (xlib::screen-root screen) ;the menu's parent
+                     fg-color bg-color nice-font)))
+        
+        (setf (xlib::menu-title a-menu) "Please pick your favorite demo:")
+        (xlib::menu-set-item-list a-menu *demo-names*)
+        (ignore-errors ;; closing window is not handled properly in menu.
+          (unwind-protect
+               (do ((choice (xlib::menu-choose a-menu 100 100)
+                            (xlib::menu-choose a-menu 100 100)))
+                   ((and choice (string-equal "Quit" choice)))
+                 (let* ((demo-choice (intern (string-upcase choice)
+                                             *keyword-package*))
+                        (fun (gethash demo-choice *name-to-function*)))
+                   (setf choice nil)
+                   (when fun
+                     (ignore-errors (funcall fun)))))
+            (xlib:display-finish-output display)
+            (xlib:close-display display)))))))
 
 
 ;;;; Shared demo utilities.
@@ -143,60 +127,124 @@
 	    (xlib:window-map-state w))))
 
 
-;;;; Greynetic.
-
-;;; GREYNETIC displays random sized and shaded boxes in a window.  This is
-;;; real slow.  It needs work.
-;;; 
-(defun greynetic (window duration)
-  (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1
-				     :drawable window))
-	 (gcontext (xlib:create-gcontext :drawable window
-					 :background *white-pixel*
-					 :foreground *black-pixel*
-					 :tile pixmap
-					 :fill-style :tiled)))
-    (multiple-value-bind (width height) (full-window-state window)
-      (dotimes (i duration)
-	(let* ((pixmap-data (greynetic-pixmapper))
-	       (image (xlib:create-image :width 32 :height 32
-					 :depth 1 :data pixmap-data)))
-	  (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32)
-	  (xlib:draw-rectangle window gcontext
-			       (- (random width) 5)
-			       (- (random height) 5)
-			       (+ 4 (random (truncate width 3)))
-			       (+ 4 (random (truncate height 3)))
-			       t))
-	(xlib:display-force-output *display*)))
-    (xlib:free-gcontext gcontext)
-    (xlib:free-pixmap pixmap)))
-
-(defvar *greynetic-pixmap-array*
-  (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel))
-
-(defun greynetic-pixmapper ()
-  (let ((pixmap-data *greynetic-pixmap-array*))
+(defun make-random-bitmap ()
+  (let ((bitmap-data (make-array '(32 32) :initial-element 0
+				 :element-type 'xlib::bit)))
     (dotimes (i 4)
       (declare (fixnum i))
       (let ((nibble (random 16)))
-	(setf nibble (logior nibble (ash nibble 4))
-	      nibble (logior nibble (ash nibble 8))
-	      nibble (logior nibble (ash nibble 12))
-	      nibble (logior nibble (ash nibble 16)))
-	(dotimes (j 32)
-	  (let ((bit (if (logbitp j nibble) 1 0)))
-	    (setf (aref pixmap-data i j) bit
-		  (aref pixmap-data (+ 4 i) j) bit
-		  (aref pixmap-data (+ 8 i) j) bit
-		  (aref pixmap-data (+ 12 i) j) bit
-		  (aref pixmap-data (+ 16 i) j) bit
-		  (aref pixmap-data (+ 20 i) j) bit
-		  (aref pixmap-data (+ 24 i) j) bit
-		  (aref pixmap-data (+ 28 i) j) bit)))))
-    pixmap-data))
-
-#+nil
+        (setf nibble (logior nibble (ash nibble 4))
+              nibble (logior nibble (ash nibble 8))
+              nibble (logior nibble (ash nibble 12))
+              nibble (logior nibble (ash nibble 16)))
+        (dotimes (j 32)
+          (let ((bit (if (logbitp j nibble) 1 0)))
+            (setf (aref bitmap-data i j) bit
+                  (aref bitmap-data (+ 4 i) j) bit
+                  (aref bitmap-data (+ 8 i) j) bit
+                  (aref bitmap-data (+ 12 i) j) bit
+                  (aref bitmap-data (+ 16 i) j) bit
+                  (aref bitmap-data (+ 20 i) j) bit
+                  (aref bitmap-data (+ 24 i) j) bit
+                  (aref bitmap-data (+ 28 i) j) bit)))))
+    bitmap-data))
+
+
+(defun make-random-pixmap ()
+  (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap))))
+    (make-pixmap image 32 32)))
+
+(defvar *pixmaps* nil)
+
+(defun make-pixmap (image width height)
+  (let* ((pixmap (xlib:create-pixmap :width width :height height
+				     :depth 1 :drawable *root*))
+	 (gc (xlib:create-gcontext :drawable pixmap
+				   :background *black-pixel*
+				   :foreground *white-pixel*)))
+    (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height)
+    (xlib:free-gcontext gc)
+    pixmap))
+
+
+;;;
+;;; This function returns one of the pixmaps in the *pixmaps* array.
+(defun greynetic-pixmapper ()
+  (aref *pixmaps* (random (length *pixmaps*))))
+
+
+(defun greynetic (window duration)
+  (let* ((depth (xlib:drawable-depth window))
+	 (draw-gcontext (xlib:create-gcontext :drawable window
+					      :foreground *white-pixel*
+					      :background *black-pixel*))
+	 ;; Need a random state per process.
+	 (*random-state* (make-random-state t))
+	 (*pixmaps* (let ((pixmap-array (make-array 30)))
+		      (dotimes (i 30)
+			(setf (aref pixmap-array i) (make-random-pixmap)))
+		      pixmap-array)))
+
+    (unwind-protect
+	(multiple-value-bind (width height) (full-window-state window)
+	  (declare (fixnum width height))
+	  (let ((border-x (truncate width 20))
+		(border-y (truncate height 20)))
+	    (declare (fixnum border-x border-y))
+	    (dotimes (i duration)
+	      (let ((pixmap (greynetic-pixmapper)))
+		(xlib:with-gcontext (draw-gcontext
+				     :foreground (random (ash 1 depth))
+				     :background (random (ash 1 depth))
+				     :stipple pixmap
+				     :fill-style
+				     :opaque-stippled)
+		   (cond ((zerop (mod i 500))
+			  (xlib:clear-area window)
+			  (sleep .1))
+			 (t
+			  (sleep (/ *delay* 20))))
+		   (if (< (random 3) 2)
+		       (let* ((w (+ border-x
+				    (truncate (* (random (- width
+							    (* 2 border-x)))
+						 (random width)) width)))
+			      (h (+ border-y
+				    (truncate (* (random (- height
+							    (* 2 border-y)))
+						 (random height)) height)))
+			      (x (random (- width w)))
+			      (y (random (- height h))))
+			 (declare (fixnum w h x y))
+			 (if (zerop (random 2))
+			     (xlib:draw-rectangle window draw-gcontext
+						  x y w h t)
+			     (xlib:draw-arc window draw-gcontext
+					    x y w h 0 (* 2 pi) t)))
+		       (let ((p1-x (+ border-x
+				      (random (- width (* 2 border-x)))))
+			     (p1-y (+ border-y
+				      (random (- height (* 2 border-y)))))
+			     (p2-x (+ border-x
+				      (random (- width (* 2 border-x)))))
+			     (p2-y (+ border-y
+				      (random (- height (* 2 border-y)))))
+			     (p3-x (+ border-x
+				      (random (- width (* 2 border-x)))))
+			     (p3-y (+ border-y
+				      (random (- height (* 2 border-y))))))
+			 (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y))
+			 (xlib:draw-lines window draw-gcontext
+					  (list p1-x p1-y p2-x p2-y p3-x p3-y)
+					  :relative-p nil
+					  :fill-p t
+					  :shape :convex)))
+		   (xlib:display-force-output *display*))))))
+      (dotimes (i (length *pixmaps*))
+	(xlib:free-pixmap (aref *pixmaps* i)))
+      (xlib:free-gcontext draw-gcontext))))
+
+
 (defdemo greynetic-demo "Greynetic" (&optional (duration 300))
   100 100 600 600
   "Displays random grey rectangles."
@@ -677,6 +725,7 @@
 			    start-needle
 			    end-needle)
 	     end-needle)
+  (sleep *delay*)
   t)
 
 ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE
@@ -775,27 +824,28 @@
 	  (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))
+               (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)
+                 (sleep (/ *delay* 100)))
 	      (when (and negative-velocity (>= y-velocity 0))
 		(setf negative-velocity nil))
 	      (let ((next-x (+ x x-velocity)))
@@ -814,7 +864,7 @@
   100 100 300 300
   "Drops the demo window with an inital X velocity which bounces off
   screen borders."
-  (bounce-window *window* 30))
+  (bounce-window *window* 3))
 
 (defdemo bounce-demo "Bounce" ()
   100 100 300 300
@@ -846,8 +896,8 @@
     (multiple-value-bind (width height) (full-window-state window)
       (xlib:clear-area window)
       (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
-      (xlib:display-force-output display)
-      (sleep 4))
+      (xlib:display-finish-output display)
+      (sleep 1))
     (xlib:free-gcontext gc)))
 
 ;;; Draw points.  X assumes points are in the range of width x height,
@@ -892,8 +942,8 @@
 					:function boole-c2
 					:plane-mask (logxor *white-pixel*
 							    *black-pixel*)
-					:background *white-pixel*
-					:foreground *black-pixel*
+					:background *black-pixel*
+					:foreground *white-pixel*
 					:fill-style :solid))
 	(rectangles (make-array (* 4 num-rectangles)
 				:element-type 'number
@@ -920,6 +970,7 @@
 	      (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)))
 
@@ -935,12 +986,15 @@
 ;;; Ported to CLX by Blaine Burks
 ;;; 
 
-(defvar *ball-size-x* 38)
+(defvar *ball-size-x* 36)
 (defvar *ball-size-y* 34)
 
-(defmacro xor-ball (pixmap window gcontext x y)
-  `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y*
-		   ,window ,x ,y))
+(defun xor-ball (pixmap window gcontext x y)
+  (xlib:copy-plane pixmap gcontext 1
+		  0 0
+		  *ball-size-x* *ball-size-y*
+		  window
+		  x y))
 
 (defconstant bball-gravity 1)
 (defconstant maximum-x-drift 7)
@@ -1016,7 +1070,7 @@
 
 (defun bounce-balls (display window how-many duration)
   (xlib:clear-area window)
-  (xlib:display-force-output display)
+  (xlib:display-finish-output display)
   (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window)
     (let* ((balls (do ((i 0 (1+ i))
 		       (list () (cons (make-ball) list)))
@@ -1036,16 +1090,16 @@
       (xlib:free-gcontext pixmap-gc)
       (dolist (ball balls)
 	(xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball)))
-      (xlib:display-force-output display)
+      (xlib:display-finish-output display)
       (dotimes (i duration)
 	(dolist (ball balls)
-	  (bounce-1-ball bounce-pixmap window gcontext ball))
-	(xlib:display-force-output display))
+	  (bounce-1-ball bounce-pixmap window gcontext ball)
+          (xlib:display-finish-output display))
+	(sleep (/ *delay* 50.0)))
       (xlib:free-pixmap bounce-pixmap)
       (xlib:free-gcontext gcontext))))
 
-#+nil
 (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500))
-  34 34 700 500
+  36 34 700 500
   "Bouncing balls in space."
   (bounce-balls *display*  *window* how-many duration))
diff --git a/src/clx/demo/mandel.lisp b/src/clx/demo/mandel.lisp
index 008797417481e7ef2aa3e516691ac21be84664a2..5cef6918e131f8135cddcccb73fad6096d67014c 100644
--- a/src/clx/demo/mandel.lisp
+++ b/src/clx/demo/mandel.lisp
@@ -4,26 +4,27 @@
 
 (in-package #:xlib-demo/mandel)
 
-(defvar *display* (xlib:open-default-display))
-(defvar *screen* (xlib:display-default-screen *display*))
-
-(defvar *backing-store* (make-hash-table) "Backing store hashtable, keyed off window id")
-(defvar *colmap* nil)
-(defvar *helpwin* nil)
-(defvar *zoom-table* (make-hash-table))
-(defvar *zoomcolmap* (xlib:create-gcontext
-		      :drawable (xlib:screen-root *screen*)
-		      :foreground (xlib:screen-white-pixel *screen*)
-		      :function boole-xor))
-(defvar *white* (xlib:create-gcontext
-		 :drawable (xlib:screen-root *screen*)
-		 :foreground (xlib:screen-white-pixel *screen*)
-		 ))
-(defvar *winmap* (make-hash-table))
-(defvar *textmap* (xlib:create-gcontext
-		   :drawable (xlib:screen-root *screen*)
-		   :foreground (xlib:screen-black-pixel *screen*)
-		   :background (xlib:screen-white-pixel *screen*)))
+(declaim (special *display* *screen* *backing-store* *colmap* *helpwin*
+                  *zoom-table* *zoomcolmap* *white* *winmap* *textmap*))
+
+(defun init ()
+  (setf *display* (xlib:open-default-display)
+        *screen* (xlib:display-default-screen *display*)
+
+        *backing-store* (make-hash-table) ; Backing store hashtable, keyed off window id
+        *colmap* nil
+        *helpwin* nil
+        *zoom-table* (make-hash-table)
+        *zoomcolmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*)
+                                           :foreground (xlib:screen-white-pixel *screen*)
+                                           :function boole-xor)
+        *white* (xlib:create-gcontext :drawable (xlib:screen-root *screen*)
+                                      :foreground (xlib:screen-white-pixel *screen*))
+        *winmap* (make-hash-table)
+        *textmap* (xlib:create-gcontext :drawable (xlib:screen-root *screen*)
+                                        :foreground (xlib:screen-black-pixel *screen*)
+                                        :background (xlib:screen-white-pixel *screen*)))
+  (init-colours))
 
 ;;; OK, this is an ugly hack to make sure we can handle
 ;;; shift and modstate in a sane way, alas we can't 100% rely
@@ -99,7 +100,7 @@
 (defmethod empty-win ((q out-queue) win)
   (let ((temp-queue (gethash win (win-queues q))))
     (empty temp-queue)))
-  
+
 (defmethod enqueue ((q queue) item)
   (cond ((empty-p q)
 	 (setf (q-head q) (cons item nil))
@@ -150,7 +151,7 @@
 	      (val nil)
 	      (temp-queue (gethash next (win-queues q))
 			  (gethash next (win-queues q))))
-	     (finished val) 
+	     (finished val)
 	  (cond ((empty-p temp-queue)
 		 (setf next (dequeue windows)))
 		(t (setf val (dequeue temp-queue))
@@ -180,8 +181,11 @@
 ;;; a^2+2abi+(bi)^2 -->
 ;;; a^2+2abi-b^2
 
+(deftype zoom-type ()
+  '(member :zoom-same :zoom-new :zoom-out))
+
 (defclass zoomer ()
-  ((zoom-type :initarg :type :reader zoom-type :type fixnum)
+  ((zoom-type :initarg :type :reader zoom-type :type zoom-type)
    (start-x :initarg :x :reader start-x :type fixnum)
    (start-y :initarg :y :reader start-y :type fixnum)
    (stop-x :accessor stop-x :initform -1 :type fixnum)
@@ -289,7 +293,7 @@
 	   (double-float lx ly hx hy)
 	   (fixnum maxiter))
   (let ((dx (coerce (/ (- hx lx) 512.0d0) 'double-float))
-	(dy (coerce (/ (- hy ly) 512.0d0) 'double-float)))	    
+	(dy (coerce (/ (- hy ly) 512.0d0) 'double-float)))
     (setf (gethash win *winmap*)
 	  (make-mandel-square :x 0 :y 0 :s 512
 			      :base-r lx :base-i ly
@@ -320,7 +324,7 @@
 (defun fill-square-p (ix iy s bx by dx dy max win)
   (declare (fixnum ix iy s max)
 	   (double-float bx by dx dy))
-  (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max))) 
+  (let ((norm (iter (+ bx (* ix dx)) (+ by (* iy dy)) max)))
     (and
      (loop for px from ix below (+ ix s)
 	   for x of-type double-float = (+ bx (* px dx))
@@ -432,7 +436,7 @@
 				(the fixnum (start-y zoomer))))))
 	  (xlib:draw-rectangle win *zoomcolmap*
 			       (the fixnum (start-x zoomer))
-			       (the fixnum (start-y zoomer)) 
+			       (the fixnum (start-y zoomer))
 			       old-side old-side))
 	(setf (stop-x zoomer) (max (the fixnum (start-x zoomer))
 				   (the fixnum x)
@@ -442,7 +446,7 @@
 				   ))
 	(xlib:draw-rectangle win *zoomcolmap*
 			     (the fixnum (start-x zoomer))
-			     (the fixnum (start-y zoomer)) 
+			     (the fixnum (start-y zoomer))
 			     new-side new-side)
 	(xlib:display-force-output *display*)))))
 
@@ -476,7 +480,7 @@
 	    (setf lx (+ (ms-base-r sq)
 			(* x (ms-dr sq)))
 		  ly (+ (ms-base-i sq)
-			(* y (ms-dr sq))) 
+			(* y (ms-dr sq)))
 		  hx (+ (ms-base-r sq)
 			(* (+ side x) (ms-dr sq)))
 		  hy (+ (ms-base-i sq)
@@ -495,7 +499,7 @@
 				   (- br (* 512 dr)) (- bi (* 512 di))
 				   (+ (* 1024 dr) br) (+ (* 1024 di) bi)
 				   (ms-maxiter sq))))
-				 
+
 	  (t (format t "Unknown/unimplemented zoom type ~a~%~%" (zoom-type zoomer))))))))
 
 (defun quit-window (window)
@@ -504,7 +508,7 @@
       (empty temp))))
 
 (defun event-loop ()
-  (init-colours)
+  (init)
   (do ((quit nil)
        (redisplay nil t))
       ((eq quit 'quit))
diff --git a/src/clx/demo/menu.lisp b/src/clx/demo/menu.lisp
index 5de1d07267b318c1b41e52059502eb78f27d6c9d..599852bac70f79231fb64073e4efad26d8ec5bd8 100644
--- a/src/clx/demo/menu.lisp
+++ b/src/clx/demo/menu.lisp
@@ -13,7 +13,7 @@
 ;;; documentation.
 ;;;
 ;;; Texas Instruments Incorporated provides this software "as is" without
-;;; express or implied warranty.  
+;;; express or implied warranty.
 ;;;
 
 (in-package :xlib)
@@ -27,7 +27,8 @@
 ;;;                                                                                  |
 ;;;----------------------------------------------------------------------------------+
 
-
+;;; Some changes are backported from CMUCL CLX source (our implementation had
+;;; errors when we tried to use menu). This one is a little shorter.
 
 (defstruct (menu)
   "A simple menu of text strings."
@@ -45,29 +46,27 @@
 
 (defun create-menu (parent-window text-color background-color text-font)
   (make-menu
-    ;; Create menu graphics context
-    :gcontext (CREATE-GCONTEXT :drawable   parent-window
-			       :foreground text-color
-			       :background background-color
-			       :font       text-font)
-    ;; Create menu window
-    :window   (CREATE-WINDOW
-		:parent       parent-window
-		:class        :input-output
-		:x            0			;temporary value
-		:y            0			;temporary value
-		:width        16		;temporary value
-		:height       16		;temporary value		
-		:border-width 2
-		:border       text-color
-		:background   background-color
-		:save-under   :on
-		:override-redirect :on		;override window mgr when positioning
-		:event-mask   (MAKE-EVENT-MASK :leave-window					       
-					       :exposure))))
-
-
-(defun menu-set-item-list (menu &rest item-strings)
+   ;; Create menu graphics context
+   :gcontext (CREATE-GCONTEXT :drawable   parent-window
+			      :foreground text-color
+			      :background background-color
+			      :font       text-font)
+   ;; Create menu window
+   :window   (CREATE-WINDOW
+	      :parent       parent-window
+	      :class        :input-output
+	      :x            0			;temporary value
+	      :y            0			;temporary value
+	      :width        16			;temporary value
+	      :height       16			;temporary value
+	      :border-width 2
+	      :border       text-color
+	      :background   background-color
+	      :save-under   :on
+	      ;; :override-redirect :on		;override window mgr when positioning
+	      :event-mask   (MAKE-EVENT-MASK :leave-window :exposure))))
+
+(defun menu-set-item-list (menu item-strings)
   ;; Assume the new items will change the menu's width and height
   (setf (menu-geometry-changed-p menu) t)
 
@@ -105,25 +104,25 @@
 	   (item-width  0)
 	   (items       (menu-item-alist menu))
 	   menu-width)
-      
+
       ;; Find max item string width
       (dolist (next-item items)
-	(setf item-width (max item-width 
+	(setf item-width (max item-width
 			      (TEXT-EXTENTS menu-font (second next-item)))))
-      
+
       ;; Compute final menu width, taking margins into account
       (setf menu-width (max title-width
-			    (+ item-width *menu-item-margin* *menu-item-margin*)))      
+			    (+ item-width *menu-item-margin* *menu-item-margin*)))
       (let ((window  (menu-window menu))
 	    (delta-y (+ item-height *menu-item-margin*)))
-	
-	;; Update width and height of menu window        
+
+	;; Update width and height of menu window
 	(WITH-STATE (window)
 	  (setf (DRAWABLE-WIDTH  window) menu-width
 		(DRAWABLE-HEIGHT window) (+ *menu-item-margin*
 					    (* (1+ (length items))
 					       delta-y))))
-	
+
 	;; Update width, height, position of item windows
 	(let ((item-left     (round (- menu-width item-width) 2))
 	      (next-item-top delta-y))
@@ -135,7 +134,7 @@
 		      (DRAWABLE-X      window) item-left
 		      (DRAWABLE-Y      window) next-item-top)))
 	    (incf next-item-top delta-y))))
-      
+
       ;; Map all item windows
       (MAP-SUBWINDOWS (menu-window menu))
 
@@ -148,9 +147,13 @@
 
 
 (defun menu-refresh (menu)
- (let* ((gcontext   (menu-gcontext menu))
+  (xlib:set-wm-properties (menu-window menu)
+			  :name (menu-title menu)
+			  :icon-name (menu-title menu)
+			  :resource-name (menu-title menu))
+  (let* ((gcontext   (menu-gcontext menu))
         (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
-   
+
    ;; Show title centered in "reverse-video"
    (let ((fg (GCONTEXT-BACKGROUND gcontext))
 	 (bg (GCONTEXT-FOREGROUND gcontext)))
@@ -162,7 +165,7 @@
 		   (menu-title-width menu)) 2)	;start x
 	 baseline-y				;start y
 	 (menu-title menu))))
-   
+
    ;; Show each menu item (position is relative to item window)
    (dolist (item (menu-item-alist menu))
      (DRAW-IMAGE-GLYPHS
@@ -175,32 +178,32 @@
 (defun menu-choose (menu x y)
   ;; Display the menu so that first item is at x,y.
   (menu-present menu x y)
-  
+
   (let ((items (menu-item-alist menu))
 	(mw    (menu-window menu))
 	selected-item)
 
     ;; Event processing loop
-    (do () (selected-item)				
+    (do () (selected-item)
       (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
 	(:exposure     (count)
-		       
+
 	 ;; Discard all but final :exposure then display the menu
 	 (when (zerop count) (menu-refresh menu))
 	 t)
-	
+
 	(:button-release (event-window)
 	 ;;Select an item
 	 (setf selected-item (second (assoc event-window items)))
 	 t)
-	
+
 	(:enter-notify (window)
 	 ;;Highlight an item
 	 (let ((position (position window items :key #'first)))
 	   (when position
 	     (menu-highlight-item menu position)))
 	 t)
-	
+
 	(:leave-notify (window kind)
 	 (if (eql mw window)
 	     ;; Quit if pointer moved out of main menu window
@@ -211,14 +214,14 @@
 	     (when position
 	       (menu-unhighlight-item menu position))))
 	 t)
-	
+
 	(otherwise ()
 		   ;;Ignore and discard any other event
 		   t)))
-    
+
     ;; Erase the menu
-    (UNMAP-WINDOW mw)
-    
+;;;    (UNMAP-WINDOW mw)
+
     ;; Return selected item string, if any
     (unless (eq selected-item :none) selected-item)))
 
@@ -232,7 +235,7 @@
 			 box-margin))
 	 (width       (+ (menu-item-width menu) box-margin box-margin))
 	 (height      (+ (menu-item-height menu) box-margin box-margin)))
-    
+
     ;; Draw a box in menu window around the given item.
     (DRAW-RECTANGLE (menu-window menu)
 		    (menu-gcontext menu)
@@ -249,7 +252,7 @@
 (defun menu-present (menu x y)
   ;; Make sure menu geometry is up-to-date
   (menu-recompute-geometry menu)
-  
+
   ;; Try to center first item at the given location, but
   ;; make sure menu is completely visible in its parent
   (let ((menu-window (menu-window menu)))
@@ -272,111 +275,99 @@
 
     ;; Make menu visible
     (MAP-WINDOW menu-window)))
+
+;;; Demo functions
 
 (defun just-say-lisp (&optional (font-name "fixed"))
   (let* ((display   (open-default-display))
-	 (screen    (first (DISPLAY-ROOTS display)))
-	 (fg-color  (SCREEN-BLACK-PIXEL screen))
-	 (bg-color  (SCREEN-WHITE-PIXEL screen))
-	 (nice-font (OPEN-FONT display font-name))
-	 (a-menu    (create-menu (screen-root screen)	;the menu's parent
-				 fg-color bg-color nice-font)))
-    
+         (screen    (first (DISPLAY-ROOTS display)))
+         (fg-color  (SCREEN-BLACK-PIXEL screen))
+         (bg-color  (SCREEN-WHITE-PIXEL screen))
+         (nice-font (OPEN-FONT display font-name))
+         (a-menu    (create-menu (screen-root screen) ; the menu's parent
+                                 fg-color bg-color nice-font)))
+
     (setf (menu-title a-menu) "Please pick your favorite language:")
-    (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp")
-    
+    (menu-set-item-list a-menu '("Fortran" "APL" "Forth" "Lisp"))
+
     ;; Bedevil the user until he picks a nice programming language
     (unwind-protect
-	(do (choice)
-	    ((and (setf choice (menu-choose a-menu 100 100))
-		  (string-equal "Lisp" choice))))
+        (do (choice)
+            ((and (setf choice (menu-choose a-menu 100 100))
+                  (string-equal "Lisp" choice))))
 
       (CLOSE-DISPLAY display))))
-  
 
 (defun pop-up (host strings &key (title "Pick one:") (font "fixed"))
   (let* ((display   (OPEN-DISPLAY host))
-	 (screen    (first (DISPLAY-ROOTS display)))
-	 (fg-color  (SCREEN-BLACK-PIXEL screen))
-	 (bg-color  (SCREEN-WHITE-PIXEL screen))
-	 (font      (OPEN-FONT display font))
-	 (parent-width 400)
-	 (parent-height 400)
-	 (parent    (CREATE-WINDOW :parent (SCREEN-ROOT screen)
-				   :override-redirect :on
-				   :x 100 :y 100
-				   :width parent-width :height parent-height
-				   :background bg-color
-				   :event-mask (MAKE-EVENT-MASK :button-press
-								:exposure)))
-	 (a-menu    (create-menu parent fg-color bg-color font))
-	 (prompt    "Press a button...")	 
-	 (prompt-gc (CREATE-GCONTEXT :drawable parent
-				     :foreground fg-color
-				     :background bg-color
-				     :font font))
-	 (prompt-y  (FONT-ASCENT font))
-	 (ack-y     (- parent-height  (FONT-DESCENT font))))
-    
+         (screen    (first (DISPLAY-ROOTS display)))
+         (fg-color  (SCREEN-BLACK-PIXEL screen))
+         (bg-color  (SCREEN-WHITE-PIXEL screen))
+         (font      (OPEN-FONT display font))
+         (parent-width 400)
+         (parent-height 400)
+         (parent    (CREATE-WINDOW :parent (SCREEN-ROOT screen)
+                                   :override-redirect :on
+                                   :x 100 :y 100
+                                   :width parent-width :height parent-height
+                                   :background bg-color
+                                   :event-mask (MAKE-EVENT-MASK :button-press
+                                                                :exposure)))
+         (a-menu    (create-menu parent fg-color bg-color font))
+         (prompt    "Press a button...")
+         (prompt-gc (CREATE-GCONTEXT :drawable parent
+                                     :foreground fg-color
+                                     :background bg-color
+                                     :font font))
+         (prompt-y  (FONT-ASCENT font))
+         (ack-y     (- parent-height  (FONT-DESCENT font))))
     (setf (menu-title a-menu) title)
-    (apply #'menu-set-item-list a-menu strings)
-    
+    (menu-set-item-list a-menu strings)
     ;; Present main window
     (MAP-WINDOW parent)
-    
     (flet ((display-centered-text
-	     (window string gcontext height width)	     
-	     (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
-	       (declare (ignore a d l r))
-	       (let ((box-height (+ fa fd)))
-		 
-		 ;; Clear previous text
-		 (CLEAR-AREA window
-			     :x 0 :y (- height fa)
-			     :width width :height box-height)
-		 
-		 ;; Draw new text
-		 (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
-      
+             (window string gcontext height width)
+             (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
+               (declare (ignore a d l r))
+               (let ((box-height (+ fa fd)))
+                 ;; Clear previous text
+                 (CLEAR-AREA window
+                             :x 0 :y (- height fa)
+                             :width width :height box-height)
+                 ;; Draw new text
+                 (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
       (unwind-protect
-	  (loop
-	    (EVENT-CASE (display :force-output-p t)
-	      
-	      (:exposure (count)
-			 
-			 ;; Display prompt
-			 (when (zerop count)
-			   (display-centered-text
-			     parent
-			     prompt
-			     prompt-gc
-			     prompt-y
-			     parent-width))
-			 t)
-	      
-	      (:button-press (x y)
-			     
-			     ;; Pop up the menu
-			     (let ((choice (menu-choose a-menu x y)))
-			       (if choice
-				   (display-centered-text
-				     parent
-				     (format nil "You have selected ~a." choice)
-				     prompt-gc
-				     ack-y
-				     parent-width)
-				   
-				   (display-centered-text
-				     parent
-				     "No selection...try again."
-				     prompt-gc
-				     ack-y
-				     parent-width)))
-			     t)	    	    
-	      
-	      (otherwise ()
-			 ;;Ignore and discard any other event
-			 t)))
-	
-	(CLOSE-DISPLAY display)))))
-
+          (loop
+            (EVENT-CASE (display :force-output-p t)
+              (:exposure (count)
+                ;; Display prompt
+                (when (zerop count)
+                  (display-centered-text
+                   parent
+                   prompt
+                   prompt-gc
+                   prompt-y
+                   parent-width))
+                t)
+              (:button-press (x y)
+                ;; Pop up the menu
+                (let ((choice (menu-choose a-menu x y)))
+                  (if choice
+                      (display-centered-text
+                       parent
+                       (format nil "You have selected ~a." choice)
+                       prompt-gc
+                       ack-y
+                       parent-width)
+
+                      (display-centered-text
+                       parent
+                       "No selection...try again."
+                       prompt-gc
+                       ack-y
+                       parent-width)))
+                             t)
+              (otherwise ()
+                ;; Ignore and discard any other event
+                t)))
+        (CLOSE-DISPLAY display)))))
diff --git a/src/clx/dep-allegro.lisp b/src/clx/dep-allegro.lisp
index dcca5809b900f0e8fd4843124b07439806a56c9b..2f12a7e7fc0879375fd95cbd464345edfd6cd76e 100644
--- a/src/clx/dep-allegro.lisp
+++ b/src/clx/dep-allegro.lisp
@@ -78,16 +78,13 @@
 		 card16->int16 int16->card16
 		 card32->int32 int32->card32))
 
-#-Genera
-(progn
-
 (defun card8->int8 (x)
   (declare (type card8 x))
   (declare (clx-values int8))
   #.(declare-buffun)
   (the int8 (if (logbitp 7 x)
 		(the int8 (- x #x100))
-	      x)))
+		x)))
 
 (defun int8->card8 (x)
   (declare (type int8 x))
@@ -123,54 +120,11 @@
   #.(declare-buffun)
   (the card32 (ldb (byte 32 0) x)))
 
-)
-
 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
 
-#+(or excl lcl3.0 clx-overlapping-arrays)
 (declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
 		 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
 
-#+(and clx-overlapping-arrays (not Genera))
-(progn
-
-(defun aref-card16 (a i)
-  (aref a i))
-
-(defun aset-card16 (v a i)
-  (setf (aref a i) v))
-
-(defun aref-int16 (a i)
-  (card16->int16 (aref a i)))
-
-(defun aset-int16 (v a i)
-  (setf (aref a i) (int16->card16 v))
-  v)
-
-(defun aref-card32 (a i)
-  (aref a i))
-
-(defun aset-card32 (v a i)
-  (setf (aref a i) v))
-
-(defun aref-int32 (a i)
-  (card32->int32 (aref a i)))
-
-(defun aset-int32 (v a i)
-  (setf (aref a i) (int32->card32 v))
-  v)
-
-(defun aref-card29 (a i)
-  (aref a i))
-
-(defun aset-card29 (v a i)
-  (setf (aref a i) v))
-
-)
-
-#+excl
-(progn
-  
 (defun aref-card8 (a i)
   (declare (type buffer-bytes a)
 	   (type array-index i))
@@ -282,8 +236,6 @@
   #.(declare-buffun)
   (setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
 		    :unsigned-long) v))
-  
-)
 
 (defsetf aref-card8 (a i) (v)
   `(aset-card8 ,v ,a ,i))
@@ -338,31 +290,11 @@
   #.(declare-buffun)
   (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
 
-
-#+(or cmu sbcl) (progn
-
-;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
-;;; is irrational, there can't be a precise rational representation.  In
-;;; particular, the different float approximations will always be /=.  This
-;;; causes problems with type checking, because people might compute an
-;;; argument in any precision.  What we do is discard all the excess precision
-;;; in the value, and see if the protocol encoding falls in the desired range
-;;; (64'ths of a degree.)
-;;;
-(deftype angle () '(satisfies anglep))
-
-(defun anglep (x)
-  (and (typep x 'real)
-       (<= (* -360 64) (radians->int16 x) (* 360 64))))
-
-)
-
 
 ;;-----------------------------------------------------------------------------
 ;; Character transformation
 ;;-----------------------------------------------------------------------------
 
-
 ;;; This stuff transforms chars to ascii codes in card8's and back.
 ;;; You might have to hack it a little to get it to work for your machine.
 
@@ -370,109 +302,79 @@
 
 (macrolet ((char-translators ()
 	     (let ((alist
-		     `(#-lispm
-		       ;; The normal ascii codes for the control characters.
-		       ,@`((#\Return . 13)
-			   (#\Linefeed . 10)
-			   (#\Rubout . 127)
-			   (#\Page . 12)
-			   (#\Tab . 9)
-			   (#\Backspace . 8)
-			   (#\Newline . 10)
-			   (#\Space . 32))
-		       ;; One the lispm, #\Newline is #\Return, but we'd really like
-		       ;; #\Newline to translate to ascii code 10, so we swap the
-		       ;; Ascii codes for #\Return and #\Linefeed. We also provide
-		       ;; mappings from the counterparts of these control characters
-		       ;; so that the character mapping from the lisp machine
-		       ;; character set to ascii is invertible.
-		       #+lispm
-		       ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
-			   (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
-			   (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
-			   (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
-			   (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
-			   (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
-			   (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
-			   (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
-		       ;; The rest of the common lisp charater set with the normal
-		       ;; ascii codes for them.
-		       (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
-		       (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
-		       (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
-		       (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
-		       (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
-		       (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
-		       (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
-		       (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
-		       (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
-		       (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
-		       (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
-		       (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
-		       (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
-		       (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
-		       (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
-		       (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
-		       (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
-		       (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
-		       (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
-		       (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
-		       (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
-		       (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
-		       (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
-		       (#\} . 125) (#\~ . 126))))
+		    `(#-lispm
+		      ;; The normal ascii codes for the control characters.
+		      ,@`((#\Return . 13)
+			  (#\Linefeed . 10)
+			  (#\Rubout . 127)
+			  (#\Page . 12)
+			  (#\Tab . 9)
+			  (#\Backspace . 8)
+			  (#\Newline . 10)
+			  (#\Space . 32))
+		      (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
+		      (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
+		      (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
+		      (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
+		      (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
+		      (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
+		      (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
+		      (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
+		      (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
+		      (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
+		      (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
+		      (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
+		      (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
+		      (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
+		      (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
+		      (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
+		      (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
+		      (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
+		      (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
+		      (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
+		      (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
+		      (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
+		      (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
+		      (#\} . 125) (#\~ . 126))))
 	       (cond ((dolist (pair alist nil)
 			(when (not (= (char-code (car pair)) (cdr pair)))
 			  (return t)))
 		      `(progn
 			 (defconstant *char-to-card8-translation-table*
-				      ',(let ((array (make-array
-						       (let ((max-char-code 255))
-							 (dolist (pair alist)
-							   (setq max-char-code
-								 (max max-char-code
-								      (char-code (car pair)))))
-							 (1+ max-char-code))
-						       :element-type 'card8)))
-					  (dotimes (i (length array))
-					    (setf (aref array i) (mod i 256)))
-					  (dolist (pair alist)
-					    (setf (aref array (char-code (car pair)))
-						  (cdr pair)))
-					  array))
+			   ',(let ((array (make-array
+					   (let ((max-char-code 255))
+					     (dolist (pair alist)
+					       (setq max-char-code
+						     (max max-char-code
+							  (char-code (car pair)))))
+					     (1+ max-char-code))
+					   :element-type 'card8)))
+			       (dotimes (i (length array))
+				 (setf (aref array i) (mod i 256)))
+			       (dolist (pair alist)
+				 (setf (aref array (char-code (car pair)))
+				       (cdr pair)))
+			       array))
 			 (defconstant *card8-to-char-translation-table*
-				      ',(let ((array (make-array 256)))
-					  (dotimes (i (length array))
-					    (setf (aref array i) (code-char i)))
-					  (dolist (pair alist)
-					    (setf (aref array (cdr pair)) (car pair)))
-					  array))
-			 #-Genera
-			 (progn
-  			   (defun char->card8 (char)
-			     (declare (type base-char char))
-			     #.(declare-buffun)
-			     (the card8 (aref (the (simple-array card8 (*))
-						   *char-to-card8-translation-table*)
-					      (the array-index (char-code char)))))
-			   (defun card8->char (card8)
-			     (declare (type card8 card8))
-			     #.(declare-buffun)
-			     (the base-char
-				  (or (aref (the simple-vector *card8-to-char-translation-table*)
-					    card8)
-				      (error "Invalid CHAR code ~D." card8))))
-			   )
-			 #+Genera
-			 (progn
-			   (defun char->card8 (char)
-			     (declare lt:(side-effects reader reducible))
-			     (aref *char-to-card8-translation-table* (char-code char)))
-			   (defun card8->char (card8)
-			     (declare lt:(side-effects reader reducible))
-			     (aref *card8-to-char-translation-table* card8))
-			   )
-			 #-Minima
+			   ',(let ((array (make-array 256)))
+			       (dotimes (i (length array))
+				 (setf (aref array i) (code-char i)))
+			       (dolist (pair alist)
+				 (setf (aref array (cdr pair)) (car pair)))
+			       array))
+  			 (defun char->card8 (char)
+			   (declare (type base-char char))
+			   #.(declare-buffun)
+			   (the card8 (aref (the (simple-array card8 (*))
+						 *char-to-card8-translation-table*)
+					    (the array-index (char-code char)))))
+			 (defun card8->char (card8)
+			   (declare (type card8 card8))
+			   #.(declare-buffun)
+			   (the base-char
+				(or (aref (the simple-vector *card8-to-char-translation-table*)
+					  card8)
+				    (error "Invalid CHAR code ~D." card8))))
 			 (dotimes (i 256)
 			   (unless (= i (char->card8 (card8->char i)))
 			     (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
@@ -480,7 +382,6 @@
 					 (card8->char i)
 					 (char->card8 (card8->char i))))
 			     (return nil)))
-			 #-Minima
 			 (dotimes (i (length *char-to-card8-translation-table*))
 			   (let ((char (code-char i)))
 			     (unless (eql char (card8->char (char->card8 char)))
@@ -513,7 +414,6 @@
 
 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
 
-#+excl
 (defun make-process-lock (name)
   (mp:make-process-lock :name name))
 
@@ -526,45 +426,32 @@
 ;; If you're not sharing DISPLAY objects within a multi-processing
 ;; shared-memory environment, this is sufficient
 
-;;; HOLDING-LOCK for CMU Common Lisp.
-;;;
-;;; We are not multi-processing, but we use this macro to try to protect
-;;; against re-entering request functions.  This can happen if an interrupt
-;;; occurs and the handler attempts to use X over the same display connection.
-;;; This can happen if the GC hooks are used to notify the user over the same
-;;; display connection.  We inhibit GC notifications since display of them
-;;; could cause recursive entry into CLX.
-;;;
-
-;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
-;;;
-#+excl
 (defmacro holding-lock ((locator display &optional whostate &key timeout)
 			&body body)
   (declare (ignore display))
   `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
      (unwind-protect
-	 (block .hl-doit.
-	   (when (sys:scheduler-running-p) ; fast test for scheduler running
-	     (setq .hl-lock. ,locator
-		   .hl-curproc. mp::*current-process*)
-	     (when (and .hl-curproc.	; nil if in process-wait fun
-			(not (eq (mp::process-lock-locker .hl-lock.)
-				 .hl-curproc.)))
-	       ;; Then we need to grab the lock.
-	       ,(if timeout
-		    `(if (not (mp::process-lock .hl-lock. .hl-curproc.
-						,whostate ,timeout))
-			 (return-from .hl-doit. nil))
-		  `(mp::process-lock .hl-lock. .hl-curproc.
-				     ,@(when whostate `(,whostate))))
-	       ;; There is an apparent race condition here.  However, there is
-	       ;; no actual race condition -- our implementation of mp:process-
-	       ;; lock guarantees that the lock will still be held when it
-	       ;; returns, and no interrupt can happen between that and the
-	       ;; execution of the next form.  -- jdi 2/27/91
-	       (setq .hl-obtained-lock. t)))
-	   ,@body)
+	  (block .hl-doit.
+	    (when (sys:scheduler-running-p) ; fast test for scheduler running
+	      (setq .hl-lock. ,locator
+		    .hl-curproc. mp::*current-process*)
+	      (when (and .hl-curproc.	; nil if in process-wait fun
+			 (not (eq (mp::process-lock-locker .hl-lock.)
+				  .hl-curproc.)))
+		;; Then we need to grab the lock.
+		,(if timeout
+		     `(if (not (mp::process-lock .hl-lock. .hl-curproc.
+						 ,whostate ,timeout))
+			  (return-from .hl-doit. nil))
+		     `(mp::process-lock .hl-lock. .hl-curproc.
+					,@(when whostate `(,whostate))))
+		;; There is an apparent race condition here.  However, there is
+		;; no actual race condition -- our implementation of mp:process-
+		;; lock guarantees that the lock will still be held when it
+		;; returns, and no interrupt can happen between that and the
+		;; execution of the next form.  -- jdi 2/27/91
+		(setq .hl-obtained-lock. t)))
+	    ,@body)
        (if (and .hl-obtained-lock.
 		;; Note -- next form added to allow error handler inside
 		;; body to unlock the lock prematurely if it knows that
@@ -580,15 +467,16 @@
 ;;; request writing and reply reading to ensure that requests are atomically
 ;;; written and replies are atomically read from the stream.
 
-#+excl
 (defmacro without-aborts (&body body)
-  `(without-interrupts ,@body))
-    
+  #- (and allegro-version>= allegro-v10.1)
+  `(excl:without-interrupts ,@body)
+  #+ (and allegro-version>= allegro-v10.1)
+  `(excl:with-delayed-interrupts ,@body))
+
 ;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
 ;;; value changes.
 
-#+excl
 (defun process-block (whostate predicate &rest predicate-args)
   (if (sys:scheduler-running-p)
       (apply #'mp::process-wait whostate predicate predicate-args)
@@ -598,8 +486,6 @@
 ;;; PROCESS-WAKEUP: Check some other process' wait function.
 
 (declaim (inline process-wakeup))
-
-#+excl
 (defun process-wakeup (process)
   (let ((curproc mp::*current-process*))
     (when (and curproc process)
@@ -610,7 +496,6 @@
       (if (> (mp::process-priority process) (mp::process-priority curproc))
 	  (mp::process-allow-schedule process)))))
 
-
 ;;; CURRENT-PROCESS: Return the current process object for input locking and
 ;;; for calling PROCESS-WAKEUP.
 
@@ -618,18 +503,22 @@
 
 ;;; Default return NIL, which is acceptable even if there is a scheduler.
 
-#+excl
 (defun current-process ()
   (and (sys:scheduler-running-p)
        mp::*current-process*))
 
 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
 
+(defmacro without-interrupts (&body body)
+  #- (and allegro-version>= allegro-v10.1)
+  `(excl:without-interrupts ,@body)
+  #+ (and allegro-version>= allegro-v10.1)
+  `(excl:with-delayed-interrupts ,@body))
+
 ;;; CONDITIONAL-STORE:
 
 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
-#-sbcl
 (defmacro conditional-store (place old-value new-value)
   `(without-interrupts
      (cond ((eq ,place ,old-value)
@@ -643,13 +532,11 @@
 ;;;
 ;;;----------------------------------------------------------------------------
 
-#-Genera
 (defmacro wrap-buf-output ((buffer) &body body)
   ;; Error recovery wrapper
   `(unless (buffer-dead ,buffer)
      ,@body))
 
-#-Genera
 (defmacro wrap-buf-input ((buffer) &body body)
   (declare (ignore buffer))
   ;; Error recovery wrapper
@@ -658,19 +545,16 @@
 
 ;;;----------------------------------------------------------------------------
 ;;; System dependent IO primitives
-;;;	Functions for opening, reading writing forcing-output and closing 
+;;;	Functions for opening, reading writing forcing-output and closing
 ;;;	the stream to the server.
 ;;;----------------------------------------------------------------------------
 
 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
 ;;; server
 
-
 ;;
-;; Note that since we don't use the CL i/o facilities to do i/o, the display
-;; input and output "stream" is really a file descriptor (fixnum).
+;; On AllegroCL the Display stream actually is a stream!
 ;;
-#+excl
 (defun open-x-stream (host display protocol)
   (declare (ignore protocol)) ;; assume TCP
   (let ((stream (socket:make-socket :remote-host (string host)
@@ -683,26 +567,21 @@
 
 ;;; BUFFER-READ-DEFAULT - read data from the X stream
 
-
-;;
-;; Rewritten 10/89 to not use foreign function interface to do I/O.
-;;
-#+excl
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
 	   (type buffer-bytes vector)
 	   (type array-index start end)
 	   (type (or null (real 0 *)) timeout))
   #.(declare-buffun)
-    
+
   (let* ((howmany (- end start))
-	 (fd (display-input-stream display)))
-    (declare (type array-index howmany))
-    (or (cond ((fd-char-avail-p fd) nil)
+	 (stream (display-input-stream display)))
+    (declare (type array-index howmany)
+	     (type (or null stream) stream))
+    (or (cond ((stream-char-avail-p stream) nil)
 	      ((and timeout (= timeout 0)) :timeout)
 	      ((buffer-input-wait-default display timeout)))
-	(fd-read-bytes fd vector start howmany))))
-
+	(stream-read-bytes stream vector start howmany))))
 
 ;;; WARNING:
 ;;;	CLX performance will suffer if your lisp uses read-byte for
@@ -713,7 +592,6 @@
 
 ;;; BUFFER-WRITE-DEFAULT - write data to the X stream
 
-#+excl
 (defun buffer-write-default (vector display start end)
   (declare (type buffer-bytes vector)
 	   (type display display)
@@ -723,7 +601,7 @@
     (unless (null stream)
       (write-sequence vector stream :start start :end end)))
   )
-  
+
 ;;; WARNING:
 ;;;	CLX performance will be severely degraded if your lisp uses
 ;;;	write-byte to send all data to the X Window System server.
@@ -732,7 +610,6 @@
 
 ;;; buffer-force-output-default - force output to the X stream
 
-#+excl
 (defun buffer-force-output-default (display)
   ;; The default buffer force-output function for use with common-lisp streams
   (declare (type display display))
@@ -741,10 +618,8 @@
     (unless (null stream)
       (force-output stream))))
 
-
 ;;; BUFFER-CLOSE-DEFAULT - close the X stream
 
-#+excl
 (defun buffer-close-default (display &key abort)
   ;; The default buffer close function for use with common-lisp streams
   (declare (type display display))
@@ -754,7 +629,6 @@
     (unless (null stream)
       (close stream :abort abort))))
 
-
 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
 ;;; buffer.  This is called in read-input between requests, so that a process
 ;;; waiting for input is abortable when between requests.  Should return
@@ -762,87 +636,47 @@
 
 ;;; The default implementation
 
-
 ;;
 ;; This is used so an 'eq' test may be used to find out whether or not we can
 ;; safely throw this process out of the CLX read loop.
 ;;
-#+excl
 (defparameter *read-whostate* "waiting for input from X server")
 
 ;;
 ;; Note that this function returns nil on error if the scheduler is running,
 ;; t on error if not.  This is ok since buffer-read will detect the error.
 ;;
-#+excl
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null (real 0 *)) timeout))
   (declare (clx-values timeout))
-  (let ((fd (display-input-stream display)))
-    (when (streamp fd)
-      (cond ((fd-char-avail-p fd)
-	     nil)
-	    
-	    ;; Otherwise no bytes were available on the socket
-	    ((and timeout (= timeout 0))
-	     ;; If there aren't enough and timeout == 0, timeout.
-	     :timeout)
-	  
-	    ;; If the scheduler is running let it do timeouts.
-	    ((sys:scheduler-running-p)
-	     (if (not
-		  (mp:wait-for-input-available fd :whostate *read-whostate*
-					       :wait-function #'fd-char-avail-p
-					       :timeout timeout))
-		 (return-from buffer-input-wait-default :timeout))
-	     )
-	    
-	    ;; Otherwise we have to handle timeouts by hand, and call select()
-	    ;; to block until input is available.  Note we don't really handle
-	    ;; the interaction of interrupts and (numberp timeout) here.  XX
-	    (t
-	     #+mswindows
-	     (error "scheduler must be running to use CLX on MS Windows")
-	     #-mswindows
-	     (let ((res 0))
-	       (declare (fixnum res))
-	       (with-interrupt-checking-on
-		(loop
-		  (setq res (fd-wait-for-input fd (if (null timeout) 0
-						    (truncate timeout))))
-		  (cond ((plusp res)	; success
-			 (return nil))
-			((eq res 0)	; timeout
-			 (return :timeout))
-			((eq res -1)	; error
-			 (return t))
-			;; Otherwise we got an interrupt -- go around again.
-			)))))))))
-
-	   
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((stream-char-avail-p stream)
+	   nil)
+
+	  ;; Otherwise no bytes were available on the socket
+	  ((and timeout (= timeout 0))
+	   ;; If there aren't enough and timeout == 0, timeout.
+	   :timeout)
+
+	  ;; If the scheduler is running let it do timeouts.
+	  (t
+	   (if (not
+		(mp:wait-for-input-available stream :whostate *read-whostate*
+					     :wait-function #'stream-char-avail-p
+					     :timeout timeout))
+	       (return-from buffer-input-wait-default :timeout))
+	   ))))
+
 ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
 ;;; buffer. This should never block, so it can be called from the scheduler.
 
-;;; The default implementation is to just use listen.
-#+excl 
-#+(and excl clx-use-allegro-streams)
 (defun buffer-listen-default (display)
   (declare (type display display))
   (let ((stream (display-input-stream display)))
     (declare (type (or null stream) stream))
-    (if (null stream)
-	t
-      (listen stream))))
-
-#+(and excl (not clx-use-allegro-streams))
-(defun buffer-listen-default (display)
-  (declare (type display display))
-  (let ((fd (display-input-stream display)))
-    (declare (type fixnum fd))
-    (if (= fd -1)
-	t
-      (fd-char-avail-p fd))))
+    (stream-char-avail-p stream)))
 
 
 ;;;----------------------------------------------------------------------------
@@ -855,7 +689,6 @@
 ;; consing garbage, you may want to re-write this to allocate and
 ;; initialize lists from a resource.
 ;;
-#-lispm
 (defmacro with-stack-list ((var &rest elements) &body body)
   ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
   ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
@@ -866,7 +699,6 @@
               (dynamic-extent ,var))
      ,@body))
 
-#-lispm
 (defmacro with-stack-list* ((var &rest elements) &body body)
   ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
   ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
@@ -879,37 +711,35 @@
 
 (declaim (inline buffer-replace))
 
-#+excl
 (defun buffer-replace (target-sequence source-sequence target-start
-				       target-end &optional (source-start 0))
+		       target-end &optional (source-start 0))
   (declare (type buffer-bytes target-sequence source-sequence)
 	   (type array-index target-start target-end source-start)
 	   (optimize (speed 3) (safety 0)))
-  
+
   (let ((source-end (length source-sequence)))
     (declare (type array-index source-end))
-    
+
     (excl:if* (and (eq target-sequence source-sequence)
 		   (> target-start source-start))
-       then (let ((nelts (min (- target-end target-start)
-			      (- source-end source-start))))
-	      (do ((target-index (+ target-start nelts -1) (1- target-index))
-		   (source-index (+ source-start nelts -1) (1- source-index)))
-		  ((= target-index (1- target-start)) target-sequence)
-		(declare (type array-index target-index source-index))
-		
-		(setf (aref target-sequence target-index)
-		  (aref source-sequence source-index))))
-       else (do ((target-index target-start (1+ target-index))
-		 (source-index source-start (1+ source-index)))
-		((or (= target-index target-end) (= source-index source-end))
-		 target-sequence)
-	      (declare (type array-index target-index source-index))
-
-	      (setf (aref target-sequence target-index)
-		(aref source-sequence source-index))))))
-
-#-lispm
+	      then (let ((nelts (min (- target-end target-start)
+				     (- source-end source-start))))
+		     (do ((target-index (+ target-start nelts -1) (1- target-index))
+			  (source-index (+ source-start nelts -1) (1- source-index)))
+			 ((= target-index (1- target-start)) target-sequence)
+		       (declare (type array-index target-index source-index))
+
+		       (setf (aref target-sequence target-index)
+			     (aref source-sequence source-index))))
+	      else (do ((target-index target-start (1+ target-index))
+			(source-index source-start (1+ source-index)))
+		       ((or (= target-index target-end) (= source-index source-end))
+			target-sequence)
+		     (declare (type array-index target-index source-index))
+
+		     (setf (aref target-sequence target-index)
+			   (aref source-sequence source-index))))))
+
 (defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
 				  &body body)
   (let ((local-state (gensym))
@@ -933,25 +763,25 @@
 ;;; Several levels are possible:
 ;;;
 ;;; 1. Do the equivalent of check-type on every argument.
-;;; 
+;;;
 ;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
 ;;;    strings generated by check-type.
-;;; 
+;;;
 ;;; 3. Do error checking only on arguments that are likely to have errors
 ;;;    (like keyword names)
-;;; 
+;;;
 ;;; 4. Do error checking only where not doing so may dammage the envirnment
 ;;;    on a non-tagged machine (i.e. when storing into a structure that has
 ;;;    been passed in)
-;;; 
+;;;
 ;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
-;;;    store a non-integer into a number array. 
-;;; 
+;;;    store a non-integer into a number array.
+;;;
 ;;; How extensive should the error checking be?  For example, if the server
 ;;; expects a CARD16, is is sufficient for CLX to check for integer, or
 ;;; should it also check for non-negative and less than 65536?
 ;;;----------------------------------------------------------------------------
- 
+
 ;; The +TYPE-CHECK?+ constant controls how much error checking is done.
 ;; Possible values are:
 ;;    NIL      - Don't do any error checking
@@ -961,9 +791,7 @@
 ;;; This controls macro expansion, and isn't changable at run-time You will
 ;;; probably want to set this to nil if you want good performance at
 ;;; production time.
-(defconstant +type-check?+
-  #+(or Genera Minima CMU sbcl) nil
-  #-(or Genera Minima CMU sbcl) t)
+(defconstant +type-check?+ nil)
 
 ;; TYPE? is used to allow the code to do error checking at a different level from
 ;; the declarations.  It also does some optimizations for systems that don't have
@@ -976,32 +804,24 @@
 ;; dispatching, not just type checking.  -- Ram.
 
 (defmacro type? (object type)
-  #+(or cmu sbcl)
-  `(typep ,object ,type)
-  #-(or cmu sbcl)
   (if (not (constantp type))
       `(typep ,object ,type)
-    (progn
-      (setq type (eval type))
-      #+(or Genera explorer Minima)
-      (if +type-check?+
-	  `(locally (declare (optimize safety)) (typep ,object ',type))
-	`(typep ,object ',type))
-      #-(or Genera explorer Minima)
-      (let ((predicate (assoc type
-			      '((drawable drawable-p) (window window-p)
-				(pixmap pixmap-p) (cursor cursor-p)
-				(font font-p) (gcontext gcontext-p)
-				(colormap colormap-p) (null null)
-				(integer integerp)))))
-	(cond (predicate
-	       `(,(second predicate) ,object))
-	      ((eq type 'generalized-boolean)
-	       't)			; Everything is a generalized-boolean.
-	      (+type-check?+
-	       `(locally (declare (optimize safety)) (typep ,object ',type)))
-	      (t
-	       `(typep ,object ',type)))))))
+      (progn
+	(setq type (eval type))
+	(let ((predicate (assoc type
+				'((drawable drawable-p) (window window-p)
+				  (pixmap pixmap-p) (cursor cursor-p)
+				  (font font-p) (gcontext gcontext-p)
+				  (colormap colormap-p) (null null)
+				  (integer integerp)))))
+	  (cond (predicate
+		 `(,(second predicate) ,object))
+		((eq type 'generalized-boolean)
+		 't)			; Everything is a generalized-boolean.
+		(+type-check?+
+		 `(locally (declare (optimize safety)) (typep ,object ',type)))
+		(t
+		 `(typep ,object ',type)))))))
 
 ;; X-TYPE-ERROR is the function called for type errors.
 ;; If you want lots of checking, but are concerned about code size,
@@ -1016,7 +836,7 @@
 
 ;;-----------------------------------------------------------------------------
 ;; Error handlers
-;;    Hack up KMP error signaling using zetalisp until the real thing comes 
+;;    Hack up KMP error signaling using zetalisp until the real thing comes
 ;;    along
 ;;-----------------------------------------------------------------------------
 
@@ -1038,24 +858,6 @@
   (declare (dynamic-extent keyargs))
   (apply #'cerror proceed-format-string condition keyargs))
 
-;;; X-ERROR for CMU Common Lisp
-;;;
-;;; We detect a couple condition types for which we disable event handling in
-;;; our system.  This prevents going into the debugger or returning to a
-;;; command prompt with CLX repeatedly seeing the same condition.  This occurs
-;;; because CMU Common Lisp provides for all events (that is, X, input on file
-;;; descriptors, Mach messages, etc.) to come through one routine anyone can
-;;; use to wait for input.
-;;;
-#+(and CMU (not mp)) 
-(defun x-error (condition &rest keyargs)
-  (let ((condx (apply #'make-condition condition keyargs)))
-    (when (eq condition 'closed-display)
-      (let ((disp (closed-display-display condx)))
-	(warn "Disabled event handling on ~S." disp)
-	(ext::disable-clx-event-handling disp)))
-    (error condx)))
-
 (define-condition x-error (error) ())
 
 
@@ -1063,26 +865,25 @@
 ;;  HOST hacking
 ;;-----------------------------------------------------------------------------
 
-#+(and allegro-version>= (version>= 5 0))
-(eval-when (compile eval load)
-  #+(version>= 6 0)
-  (progn
-    (require :sock)
-    #-(version>= 7 0)
-    (require :gray-compat))
-  #-(version>= 6 0)
+#+(and allegro-version>= allegro-v10.1)
+(eval-when (:compile-toplevel :execute :load-toplevel)
+  (require :sock))
+
+#-(and allegro-version>= allegro-v10.1)
+(eval-when (compile-toplevel execute load-toplevel)
+  (require :gray-compat)
   (require :sock))
 
-#+(and allegro-version>= (version>= 5 0))
+#+(and allegro-version>= allegro-v10.1)
 (defun host-address (host &optional (family :internet))
   (ecase family
     (:internet
      (cons :internet
 	   (multiple-value-list
-	    (socket::ipaddr-to-dotted (socket::lookup-hostname host)
-				      :values t))))))
+	    (socket:ipaddr-to-dotted (socket:lookup-hostname host)
+				     :values t))))))
 
-#+(and allegro-version>= (not (version>= 5 0)))
+#-(and allegro-version>= allegro-v10.1)
 (defun host-address (host &optional (family :internet))
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
   ;; and cdr is a list of network address bytes.
@@ -1130,10 +931,8 @@
 ;;; want to make this expand to T, as it makes the code more compact.
 
 (defmacro use-closures ()
-  #+(or lispm Minima) t
-  #-(or lispm Minima) nil)
+  nil)
 
-#-(or Genera Minima)
 (defun clx-macroexpand (form env)
   (macroexpand form env))
 
@@ -1142,22 +941,18 @@
 ;; Resource stuff
 ;;-----------------------------------------------------------------------------
 
-
-;;; Utilities 
+;;; Utilities
 
 (defun getenv (name)
-  #+excl (sys:getenv name)
-  )
+  (sys:getenv name))
 
 (defun get-host-name ()
   "Return the same hostname as gethostname(3) would"
   ;; resources-pathname was using short-site-name for this purpose
-  #+excl (short-site-name)
-  )
+  (short-site-name))
 
 (defun homedir-file-pathname (name)
-  (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
-       (merge-pathnames (user-homedir-pathname) (pathname name))))
+  (merge-pathnames (user-homedir-pathname) (pathname name)))
 
 ;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
 ;;; a resource manager isn't running.
@@ -1184,7 +979,7 @@
       (homedir-file-pathname ".Xauthority")))
 
 ;;; this particular defaulting behaviour is typical to most Unices, I think
-#+unix
+
 (defun get-default-display (&optional display-name)
   "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
 if it is NIL.  Display names have the format
@@ -1341,11 +1136,10 @@ Returns a list of (host display-number screen protocol)."
 (deftype bitmap ()
   'pixarray-1)
 
-;;; WITH-UNDERLYING-SIMPLE-VECTOR 
+;;; WITH-UNDERLYING-SIMPLE-VECTOR
 
-#+excl
 (defmacro with-underlying-simple-vector
-	  ((variable element-type pixarray) &body body)
+    ((variable element-type pixarray) &body body)
   `(let ((,variable (cdr (excl::ah_data ,pixarray))))
      (declare (type (simple-array ,element-type (*)) ,variable))
      ,@body))
@@ -1357,25 +1151,22 @@ Returns a list of (host display-number screen protocol)."
 (defmacro read-image-load-byte (size position integer)
   (unless +image-bit-lsb-first-p+ (setq position (- 7 position)))
   `(the (unsigned-byte ,size)
-	(#-Genera ldb #+Genera sys:%logldb
-	 (byte ,size ,position)
-	 (the card8 ,integer))))
+	(ldb (byte ,size ,position) (the card8 ,integer))))
 
 ;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
 ;;; the appropriate number of CARD8s.
 
 (defmacro read-image-assemble-bytes (&rest bytes)
-  (unless +image-byte-lsb-first-p+ (setq bytes (reverse bytes)))
+  (unless +image-byte-lsb-first-p+
+    (setq bytes (reverse bytes)))
   (let ((it (first bytes))
 	(count 0))
     (dolist (byte (rest bytes))
       (setq it
-	    `(#-Genera dpb #+Genera sys:%logdpb 
-	      (the card8 ,byte)
-	      (byte 8 ,(incf count 8))
-	      (the (unsigned-byte ,count) ,it))))
-    #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)
-    #+Genera it))
+	    `(dpb (the card8 ,byte)
+		  (byte 8 ,(incf count 8))
+		  (the (unsigned-byte ,count) ,it))))
+    `(the (unsigned-byte ,(* (length bytes) 8)) ,it)))
 
 ;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
 ;;; pixel.
@@ -1384,11 +1175,8 @@ Returns a list of (host display-number screen protocol)."
   integer-size
   (unless +image-byte-lsb-first-p+ (setq position (- integer-size 8 position)))
   `(the card8
-	(#-Genera ldb #+Genera sys:%logldb
-	 (byte 8 ,position)
-	 #-Genera (the (unsigned-byte ,integer-size) ,integer)
-	 #+Genera ,integer
-	 )))
+	(ldb (byte 8 ,position)
+	     (the (unsigned-byte ,integer-size) ,integer))))
 
 ;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
 ;;; pixels.
@@ -1399,16 +1187,12 @@ Returns a list of (host display-number screen protocol)."
 	(it (first bytes))
 	(count 0))
     (dolist (byte (rest bytes))
-      (setq it `(#-Genera dpb #+Genera sys:%logdpb
-		 (the (unsigned-byte ,size) ,byte)
-		 (byte ,size ,(incf count size))
-		 (the (unsigned-byte ,count) ,it))))
+      (setq it `(dpb (the (unsigned-byte ,size) ,byte)
+		     (byte ,size ,(incf count size))
+		     (the (unsigned-byte ,count) ,it))))
     `(the card8 ,it)))
 
-#+(or Genera lcl3.0 excl)
 (defvar *computed-image-byte-lsb-first-p* +image-byte-lsb-first-p+)
-
-#+(or Genera lcl3.0 excl)
 (defvar *computed-image-bit-lsb-first-p* +image-bit-lsb-first-p+)
 
 ;;; The following table gives the bit ordering within bytes (when accessed
@@ -1416,7 +1200,7 @@ Returns a list of (host display-number screen protocol)."
 ;;; 31, where bit 0 should be leftmost on the display.  For a given byte
 ;;; labelled A-B, A is for the most significant bit of the byte, and B is
 ;;; for the least significant bit.
-;;; 
+;;;
 ;;; legend:
 ;;; 	1   scanline-unit = 8
 ;;; 	2   scanline-unit = 16
@@ -1425,10 +1209,10 @@ Returns a list of (host display-number screen protocol)."
 ;;; 	L   byte-order = LeastSignificant
 ;;; 	m   bit-order = MostSignificant
 ;;; 	l   bit-order = LeastSignificant
-;;; 
-;;; 
+;;;
+;;;
 ;;; format	ordering
-;;; 
+;;;
 ;;; 1Mm	00-07 08-15 16-23 24-31
 ;;; 2Mm	00-07 08-15 16-23 24-31
 ;;; 4Mm	00-07 08-15 16-23 24-31
@@ -1442,9 +1226,8 @@ Returns a list of (host display-number screen protocol)."
 ;;; 2Ll	07-00 15-08 23-16 31-24
 ;;; 4Ll	07-00 15-08 23-16 31-24
 
-#+(or Genera lcl3.0 excl) 
 (defconstant
-  *image-bit-ordering-table*
+    *image-bit-ordering-table*
   '(((1 (00 07) (08 15) (16 23) (24 31)) (nil nil))
     ((2 (00 07) (08 15) (16 23) (24 31)) (nil nil))
     ((4 (00 07) (08 15) (16 23) (24 31)) (nil nil))
@@ -1457,11 +1240,10 @@ Returns a list of (host display-number screen protocol)."
     ((1 (07 00) (15 08) (23 16) (31 24)) (t   t))
     ((2 (07 00) (15 08) (23 16) (31 24)) (t   t))
     ((4 (07 00) (15 08) (23 16) (31 24)) (t   t))))
-  
-#+(or Genera lcl3.0 excl) 
+
 (defun compute-image-byte-and-bit-ordering ()
   (declare (clx-values image-byte-lsb-first-p image-bit-lsb-first-p))
-  ;; First compute the ordering 
+  ;; First compute the ordering
   (let ((ordering nil)
 	(a (make-array '(1 32) :element-type 'bit :initial-element 0)))
     (dotimes (i 4)
@@ -1471,10 +1253,10 @@ Returns a list of (host display-number screen protocol)."
 			      (type fixnum i n))
 		     (with-underlying-simple-vector (v (unsigned-byte 8) a)
 		       (prog2
-			 (setf (aref v i) n)
-			 (dotimes (i 32)
-			   (unless (zerop (aref a 0 i))
-			     (return i)))
+			   (setf (aref v i) n)
+			   (dotimes (i 32)
+			     (unless (zerop (aref a 0 i))
+			       (return i)))
 			 (setf (aref v i) 0)))))
 	      (list (bitpos a i #b10000000)
 		    (bitpos a i #b00000001)))
@@ -1482,17 +1264,16 @@ Returns a list of (host display-number screen protocol)."
     (setq ordering (cons (floor +image-unit+ 8) (nreverse ordering)))
     ;; Now from the ordering, compute byte-lsb-first-p and bit-lsb-first-p
     (let ((byte-and-bit-ordering
-	    (second (assoc ordering *image-bit-ordering-table*
-			   :test #'equal))))
+	   (second (assoc ordering *image-bit-ordering-table*
+			  :test #'equal))))
       (unless byte-and-bit-ordering
 	(error "Couldn't determine image byte and bit ordering~@
                 measured image ordering = ~A"
 	       ordering))
       (values-list byte-and-bit-ordering))))
 
-#+(or Genera lcl3.0 excl) 
 (multiple-value-setq
-  (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+    (*computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
   (compute-image-byte-and-bit-ordering))
 
 ;;; If you can write fast routines that can read and write pixarrays out of a
@@ -1508,8 +1289,7 @@ Returns a list of (host display-number screen protocol)."
 
 ;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
 
-#+(or lcl3.0 excl)
-(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
+(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height
 			     padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
 	   (type pixarray-1 array)
@@ -1643,10 +1423,9 @@ Returns a list of (host display-number screen protocol)."
 		   (setf (aref vector (index+ x 7))
 			 (read-image-load-byte 1 7 byte))))
 	       )))))
-    t)
+  t)
 
-#+(or lcl3.0 excl)
-(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height 
+(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height
 			     padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
 	   (type pixarray-4 array)
@@ -1673,7 +1452,7 @@ Returns a list of (host display-number screen protocol)."
 	(unless (index-zerop left-nibbles)
 	  (setf (aref array y 0)
 		(read-image-load-byte
-		  4 4 (aref buffer-bbuf (index1- start)))))
+		 4 4 (aref buffer-bbuf (index1- start)))))
 	(do* ((end (index+ start middle-bytes))
 	      (i start (index1+ i))
 	      (x (array-row-major-index array y left-nibbles) (index+ x 2)))
@@ -1691,8 +1470,7 @@ Returns a list of (host display-number screen protocol)."
 	)))
   t)
 
-#+(or Genera lcl3.0 excl CMU sbcl)
-(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height
 			      padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
 	   (type pixarray-24 array)
@@ -1717,9 +1495,9 @@ Returns a list of (host display-number screen protocol)."
 	  (declare (type array-index end i x))
 	  (setf (aref vector x)
 		(read-image-assemble-bytes
-		  (aref buffer-bbuf (index+ i 0))
-		  (aref buffer-bbuf (index+ i 1))
-		  (aref buffer-bbuf (index+ i 2))))))))
+		 (aref buffer-bbuf (index+ i 0))
+		 (aref buffer-bbuf (index+ i 1))
+		 (aref buffer-bbuf (index+ i 2))))))))
   t)
 
 ;;; COPY-BIT-RECT  --  Internal
@@ -1729,10 +1507,9 @@ Returns a list of (host display-number screen protocol)."
 ;;; Widths are specified in bits.  Neither array can have a non-zero
 ;;; displacement.  We allow extra random bit-offset to be thrown into the X.
 ;;;
-#+(or Genera lcl3.0 excl)
 (defun fast-read-pixarray-with-swap
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+    (bbuf boffset pixarray x y width height padded-bytes-per-line
+     bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (declare (type buffer-bytes bbuf)
 	   (type array-index boffset
 		 padded-bytes-per-line)
@@ -1743,35 +1520,35 @@ Returns a list of (host display-number screen protocol)."
 	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
   (unless (index= bits-per-pixel 24)
     (let ((pixarray-padded-bits-per-line
-	    (if (index= height 1) 0
-	      (index* (index- (array-row-major-index pixarray 1 0)
-			      (array-row-major-index pixarray 0 0))
-		      bits-per-pixel)))
+	   (if (index= height 1) 0
+	       (index* (index- (array-row-major-index pixarray 1 0)
+			       (array-row-major-index pixarray 0 0))
+		       bits-per-pixel)))
 	  (x-bits (index* x bits-per-pixel)))
       (declare (type array-index pixarray-padded-bits-per-line x-bits))
       (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
 		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
 		     (index-zerop (index-mod x-bits 8)))
-	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
-		   (index-zerop (index-mod x-bits +image-unit+))))
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod x-bits +image-unit+))))
 	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
 	    (image-swap-function
-	      bits-per-pixel 
-	      unit byte-lsb-first-p bit-lsb-first-p
-	      +image-unit+ *computed-image-byte-lsb-first-p*
-	      *computed-image-bit-lsb-first-p*)
+	     bits-per-pixel
+	     unit byte-lsb-first-p bit-lsb-first-p
+	     +image-unit+ *computed-image-byte-lsb-first-p*
+	     *computed-image-bit-lsb-first-p*)
 	  (declare (type symbol image-swap-function)
 		   (type generalized-boolean image-swap-lsb-first-p))
 	  (with-underlying-simple-vector (dst card8 pixarray)
 	    (funcall
-	      (symbol-function image-swap-function) bbuf dst
-	      (index+ boffset
-		      (index* y padded-bytes-per-line)
-		      (index-floor x-bits 8))
-	      0 (index-ceiling (index* width bits-per-pixel) 8)
-	      padded-bytes-per-line
-	      (index-floor pixarray-padded-bits-per-line 8)
-	      height image-swap-lsb-first-p)))
+	     (symbol-function image-swap-function) bbuf dst
+	     (index+ boffset
+		     (index* y padded-bytes-per-line)
+		     (index-floor x-bits 8))
+	     0 (index-ceiling (index* width bits-per-pixel) 8)
+	     padded-bytes-per-line
+	     (index-floor pixarray-padded-bits-per-line 8)
+	     height image-swap-lsb-first-p)))
 	t))))
 
 (defun fast-read-pixarray (bbuf boffset pixarray
@@ -1786,45 +1563,26 @@ Returns a list of (host display-number screen protocol)."
 	   (type (member 1 4 8 16 24 32) bits-per-pixel)
 	   (type (member 8 16 32) unit)
 	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
-  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
-	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (or
-    #+(or Genera lcl3.0 excl)
-    (fast-read-pixarray-with-swap
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (let ((function
-	    (or #+lispm
-		(and (= (sys:array-element-size pixarray) bits-per-pixel)
-		     (zerop (index-mod padded-bytes-per-line 4))
-		     (zerop (index-mod
-			      (* #+Genera (sys:array-row-span pixarray)
-				 #-Genera (array-dimension pixarray 1)
-				 bits-per-pixel)
-			      32))
-		     #'fast-read-pixarray-using-bitblt)
-		#+(or CMU)
-		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
-		     #'fast-read-pixarray-using-bitblt)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 1)
-		     #'fast-read-pixarray-1)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 4)
-		     #'fast-read-pixarray-4)
-		#+(or Genera lcl3.0 excl CMU)
-		(and (index= bits-per-pixel 24)
-		     #'fast-read-pixarray-24))))
-      (when function
-	(read-pixarray-internal
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel function
-	  unit byte-lsb-first-p bit-lsb-first-p
-	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))))
+   (fast-read-pixarray-with-swap
+    bbuf boffset pixarray x y width height padded-bytes-per-line
+    bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+   (let ((function
+	  (or  (and (index= bits-per-pixel 1)
+		    #'fast-read-pixarray-1)
+	       (and (index= bits-per-pixel 4)
+		    #'fast-read-pixarray-4)
+	       (and (index= bits-per-pixel 24)
+		    #'fast-read-pixarray-24))))
+     (when function
+       (read-pixarray-internal
+	bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel function
+	unit byte-lsb-first-p bit-lsb-first-p
+	+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+)))))
 
 ;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
 
-#+(or lcl3.0 excl)
 (defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
 			      padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1852,44 +1610,43 @@ Returns a list of (host display-number screen protocol)."
 	     ((index>= i end)
 	      (unless (index-zerop right-bits)
 		(let ((x (array-row-major-index
-			   array y (index+ start-x middle-bits))))
+			  array y (index+ start-x middle-bits))))
 		  (declare (type array-index x))
 		  (setf (aref buffer-bbuf end)
 			(write-image-assemble-bytes
-			  (aref vector (index+ x 0))
-			  (if (index> right-bits 1)
-			      (aref vector (index+ x 1))
-			    0)
-			  (if (index> right-bits 2)
-			      (aref vector (index+ x 2))
-			    0)
-			  (if (index> right-bits 3)
-			      (aref vector (index+ x 3))
-			    0)
-			  (if (index> right-bits 4)
-			      (aref vector (index+ x 4))
-			    0)
-			  (if (index> right-bits 5)
-			      (aref vector (index+ x 5))
-			    0)
-			  (if (index> right-bits 6)
-			      (aref vector (index+ x 6))
-			    0)
-			  0)))))
+			 (aref vector (index+ x 0))
+			 (if (index> right-bits 1)
+			     (aref vector (index+ x 1))
+			     0)
+			 (if (index> right-bits 2)
+			     (aref vector (index+ x 2))
+			     0)
+			 (if (index> right-bits 3)
+			     (aref vector (index+ x 3))
+			     0)
+			 (if (index> right-bits 4)
+			     (aref vector (index+ x 4))
+			     0)
+			 (if (index> right-bits 5)
+			     (aref vector (index+ x 5))
+			     0)
+			 (if (index> right-bits 6)
+			     (aref vector (index+ x 6))
+			     0)
+			 0)))))
 	  (declare (type array-index end i start-x x))
 	  (setf (aref buffer-bbuf i)
 		(write-image-assemble-bytes
-		  (aref vector (index+ x 0))
-		  (aref vector (index+ x 1))
-		  (aref vector (index+ x 2))
-		  (aref vector (index+ x 3))
-		  (aref vector (index+ x 4))
-		  (aref vector (index+ x 5))
-		  (aref vector (index+ x 6))
-		  (aref vector (index+ x 7))))))))
+		 (aref vector (index+ x 0))
+		 (aref vector (index+ x 1))
+		 (aref vector (index+ x 2))
+		 (aref vector (index+ x 3))
+		 (aref vector (index+ x 4))
+		 (aref vector (index+ x 5))
+		 (aref vector (index+ x 6))
+		 (aref vector (index+ x 7))))))))
   t)
 
-#+(or lcl3.0 excl)
 (defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
 			      padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1919,16 +1676,15 @@ Returns a list of (host display-number screen protocol)."
 	      (unless (index-zerop right-nibbles)
 		(setf (aref buffer-bbuf end)
 		      (write-image-assemble-bytes
-			(aref array y (index+ start-x middle-nibbles))
-			0))))
+		       (aref array y (index+ start-x middle-nibbles))
+		       0))))
 	  (declare (type array-index end i start-x x))
 	  (setf (aref buffer-bbuf i)
 		(write-image-assemble-bytes
-		  (aref vector (index+ x 0))
-		  (aref vector (index+ x 1))))))))
+		 (aref vector (index+ x 0))
+		 (aref vector (index+ x 1))))))))
   t)
 
-#+(or Genera lcl3.0 excl CMU sbcl)
 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
 			       padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -1961,10 +1717,9 @@ Returns a list of (host display-number screen protocol)."
 		  (write-image-load-byte 16 pixel 24)))))))
   t)
 
-#+(or Genera lcl3.0 excl)
 (defun fast-write-pixarray-with-swap
-       (bbuf boffset pixarray x y width height padded-bytes-per-line
-	bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+    (bbuf boffset pixarray x y width height padded-bytes-per-line
+     bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (declare (type buffer-bytes bbuf)
 	   (type pixarray pixarray)
 	   (type card16 x y width height)
@@ -1974,35 +1729,35 @@ Returns a list of (host display-number screen protocol)."
 	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
   (unless (index= bits-per-pixel 24)
     (let ((pixarray-padded-bits-per-line
-	    (if (index= height 1) 0
-	      (index* (index- (array-row-major-index pixarray 1 0)
-			      (array-row-major-index pixarray 0 0))
-		      bits-per-pixel)))
+	   (if (index= height 1) 0
+	       (index* (index- (array-row-major-index pixarray 1 0)
+			       (array-row-major-index pixarray 0 0))
+		       bits-per-pixel)))
 	  (pixarray-start-bit-offset
-	    (index* (array-row-major-index pixarray y x)
-		    bits-per-pixel)))
+	   (index* (array-row-major-index pixarray y x)
+		   bits-per-pixel)))
       (declare (type array-index pixarray-padded-bits-per-line
 		     pixarray-start-bit-offset))
       (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
 		(and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
 		     (index-zerop (index-mod pixarray-start-bit-offset 8)))
-	      (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
-		   (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+		(and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		     (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
 	(multiple-value-bind (image-swap-function image-swap-lsb-first-p)
 	    (image-swap-function
-	      bits-per-pixel
-	      +image-unit+ *computed-image-byte-lsb-first-p*
-	      *computed-image-bit-lsb-first-p*
-	      unit byte-lsb-first-p bit-lsb-first-p)
+	     bits-per-pixel
+	     +image-unit+ *computed-image-byte-lsb-first-p*
+	     *computed-image-bit-lsb-first-p*
+	     unit byte-lsb-first-p bit-lsb-first-p)
 	  (declare (type symbol image-swap-function)
 		   (type generalized-boolean image-swap-lsb-first-p))
 	  (with-underlying-simple-vector (src card8 pixarray)
 	    (funcall
-	      (symbol-function image-swap-function)
-	      src bbuf (index-floor pixarray-start-bit-offset 8) boffset
-	      (index-ceiling (index* width bits-per-pixel) 8)
-	      (index-floor pixarray-padded-bits-per-line 8)
-	      padded-bytes-per-line height image-swap-lsb-first-p))
+	     (symbol-function image-swap-function)
+	     src bbuf (index-floor pixarray-start-bit-offset 8) boffset
+	     (index-ceiling (index* width bits-per-pixel) 8)
+	     (index-floor pixarray-padded-bits-per-line 8)
+	     padded-bytes-per-line height image-swap-lsb-first-p))
 	  t)))))
 
 (defun fast-write-pixarray (bbuf boffset pixarray x y width height
@@ -2015,41 +1770,23 @@ Returns a list of (host display-number screen protocol)."
 	   (type (member 1 4 8 16 24 32) bits-per-pixel)
 	   (type (member 8 16 32) unit)
 	   (type generalized-boolean byte-lsb-first-p bit-lsb-first-p))
-  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
-	 bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
   (or
-    #+(or Genera lcl3.0 excl)
-    (fast-write-pixarray-with-swap
-      bbuf boffset pixarray x y width height padded-bytes-per-line
-      bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
-    (let ((function
-	    (or #+lispm
-		(and (= (sys:array-element-size pixarray) bits-per-pixel)
-		     (zerop (index-mod padded-bytes-per-line 4))
-		     (zerop (index-mod
-			      (* #+Genera (sys:array-row-span pixarray)
-				 #-Genera (array-dimension pixarray 1)
-				 bits-per-pixel)
-			      32))
-		     #'fast-write-pixarray-using-bitblt)
-		#+(or CMU)
-		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
-		     #'fast-write-pixarray-using-bitblt)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 1)
-		     #'fast-write-pixarray-1)
-		#+(or lcl3.0 excl)
-		(and (index= bits-per-pixel 4)
-		     #'fast-write-pixarray-4)
-		#+(or Genera lcl3.0 excl CMU)
-		(and (index= bits-per-pixel 24)
-		     #'fast-write-pixarray-24))))
-      (when function
-	(write-pixarray-internal
-	  bbuf boffset pixarray x y width height padded-bytes-per-line
-	  bits-per-pixel function
-	  +image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
-	  unit byte-lsb-first-p bit-lsb-first-p)))))
+   (fast-write-pixarray-with-swap
+    bbuf boffset pixarray x y width height padded-bytes-per-line
+    bits-per-pixel unit byte-lsb-first-p bit-lsb-first-p)
+   (let ((function
+	  (or (and (index= bits-per-pixel 1)
+		   #'fast-write-pixarray-1)
+	      (and (index= bits-per-pixel 4)
+		   #'fast-write-pixarray-4)
+	      (and (index= bits-per-pixel 24)
+		   #'fast-write-pixarray-24))))
+     (when function
+       (write-pixarray-internal
+	bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel function
+	+image-unit+ +image-byte-lsb-first-p+ +image-bit-lsb-first-p+
+	unit byte-lsb-first-p bit-lsb-first-p)))))
 
 ;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
 
@@ -2057,96 +1794,66 @@ Returns a list of (host display-number screen protocol)."
   (declare (type pixarray pixarray copy)
 	   (type card16 x y width height)
 	   (type (member 1 4 8 16 24 32) bits-per-pixel))
-  (progn pixarray copy x y width height bits-per-pixel nil)
   (or
-    #+(or lispm CMU)
-    (let* ((pixarray-padded-pixels-per-line
-	     #+Genera (sys:array-row-span pixarray)
-	     #-Genera (array-dimension pixarray 1))
-	   (pixarray-padded-bits-per-line
-	     (* pixarray-padded-pixels-per-line bits-per-pixel))
-	   (copy-padded-pixels-per-line
-	     #+Genera (sys:array-row-span copy)
-	     #-Genera (array-dimension copy 1))
-	   (copy-padded-bits-per-line
-	     (* copy-padded-pixels-per-line bits-per-pixel)))
-      #-(or CMU)
-      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
-		 (zerop (index-mod pixarray-padded-bits-per-line 32))
-		 (zerop (index-mod copy-padded-bits-per-line 32)))
-	(sys:bitblt boole-1 width height pixarray x y copy 0 0)
-	t)
-      #+(or CMU)
-      (when (index= (pixarray-element-size pixarray)
-		    (pixarray-element-size copy)
-		    bits-per-pixel)
-	(copy-bit-rect pixarray pixarray-padded-bits-per-line x y
-		       copy copy-padded-bits-per-line 0 0
-		       height
-		       (index* width bits-per-pixel))
-	t))
-	
-    #+(or lcl3.0 excl)
-    (unless (index= bits-per-pixel 24)
-      (let ((pixarray-padded-bits-per-line
-	      (if (index= height 1) 0
+   (unless (index= bits-per-pixel 24)
+     (let ((pixarray-padded-bits-per-line
+	    (if (index= height 1) 0
 		(index* (index- (array-row-major-index pixarray 1 0)
 				(array-row-major-index pixarray 0 0))
 			bits-per-pixel)))
-	    (copy-padded-bits-per-line
-	      (if (index= height 1) 0
+	   (copy-padded-bits-per-line
+	    (if (index= height 1) 0
 		(index* (index- (array-row-major-index copy 1 0)
 				(array-row-major-index copy 0 0))
 			bits-per-pixel)))
-	    (pixarray-start-bit-offset
-	      (index* (array-row-major-index pixarray y x)
-		      bits-per-pixel)))
-	(declare (type array-index pixarray-padded-bits-per-line
-		       copy-padded-bits-per-line pixarray-start-bit-offset))
-	(when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
-		  (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
-		       (index-zerop (index-mod copy-padded-bits-per-line 8))
-		       (index-zerop (index-mod pixarray-start-bit-offset 8)))
-		(and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
-		     (index-zerop (index-mod copy-padded-bits-per-line +image-unit+))
-		     (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
-	  (with-underlying-simple-vector (src card8 pixarray)
-	    (with-underlying-simple-vector (dst card8 copy)
-	      (image-noswap
-		src dst
-		(index-floor pixarray-start-bit-offset 8) 0
-		(index-ceiling (index* width bits-per-pixel) 8)
-		(index-floor pixarray-padded-bits-per-line 8)
-		(index-floor copy-padded-bits-per-line 8)
-		height nil)))
-	  t)))
-    #+(or lcl3.0 excl)
-    (macrolet
-      ((copy (type element-type)
-	 `(let ((pixarray pixarray)
-		(copy copy))
-	    (declare (type ,type pixarray copy))
-	    #.(declare-buffun)
-	    (with-underlying-simple-vector (src ,element-type pixarray)
-	      (with-underlying-simple-vector (dst ,element-type copy)
-		(do* ((dst-y 0 (index1+ dst-y))
-		      (src-y y (index1+ src-y)))
-		     ((index>= dst-y height))
-		  (declare (type card16 dst-y src-y))
-		  (do* ((dst-idx (array-row-major-index copy dst-y 0)
-				 (index1+ dst-idx))
-			(dst-end (index+ dst-idx width))
-			(src-idx (array-row-major-index pixarray src-y x)
-				 (index1+ src-idx)))
-		       ((index>= dst-idx dst-end))
-		    (declare (type array-index dst-idx src-idx dst-end))
-		    (setf (aref dst dst-idx)
-			  (the ,element-type (aref src src-idx))))))))))
-      (ecase bits-per-pixel
-	(1  (copy pixarray-1  pixarray-1-element-type))
-	(4  (copy pixarray-4  pixarray-4-element-type))
-	(8  (copy pixarray-8  pixarray-8-element-type))
-	(16 (copy pixarray-16 pixarray-16-element-type))
-	(24 (copy pixarray-24 pixarray-24-element-type))
-	(32 (copy pixarray-32 pixarray-32-element-type)))
-      t)))
+	   (pixarray-start-bit-offset
+	    (index* (array-row-major-index pixarray y x)
+		    bits-per-pixel)))
+       (declare (type array-index pixarray-padded-bits-per-line
+		      copy-padded-bits-per-line pixarray-start-bit-offset))
+       (when (if (eq *computed-image-byte-lsb-first-p* *computed-image-bit-lsb-first-p*)
+		 (and (index-zerop (index-mod pixarray-padded-bits-per-line 8))
+		      (index-zerop (index-mod copy-padded-bits-per-line 8))
+		      (index-zerop (index-mod pixarray-start-bit-offset 8)))
+		 (and (index-zerop (index-mod pixarray-padded-bits-per-line +image-unit+))
+		      (index-zerop (index-mod copy-padded-bits-per-line +image-unit+))
+		      (index-zerop (index-mod pixarray-start-bit-offset +image-unit+))))
+	 (with-underlying-simple-vector (src card8 pixarray)
+	   (with-underlying-simple-vector (dst card8 copy)
+	     (image-noswap
+	      src dst
+	      (index-floor pixarray-start-bit-offset 8) 0
+	      (index-ceiling (index* width bits-per-pixel) 8)
+	      (index-floor pixarray-padded-bits-per-line 8)
+	      (index-floor copy-padded-bits-per-line 8)
+	      height nil)))
+	 t)))
+   (macrolet
+       ((copy (type element-type)
+	  `(let ((pixarray pixarray)
+		 (copy copy))
+	     (declare (type ,type pixarray copy))
+	     #.(declare-buffun)
+	     (with-underlying-simple-vector (src ,element-type pixarray)
+	       (with-underlying-simple-vector (dst ,element-type copy)
+		 (do* ((dst-y 0 (index1+ dst-y))
+		       (src-y y (index1+ src-y)))
+		      ((index>= dst-y height))
+		   (declare (type card16 dst-y src-y))
+		   (do* ((dst-idx (array-row-major-index copy dst-y 0)
+				  (index1+ dst-idx))
+			 (dst-end (index+ dst-idx width))
+			 (src-idx (array-row-major-index pixarray src-y x)
+				  (index1+ src-idx)))
+			((index>= dst-idx dst-end))
+		     (declare (type array-index dst-idx src-idx dst-end))
+		     (setf (aref dst dst-idx)
+			   (the ,element-type (aref src src-idx))))))))))
+     (ecase bits-per-pixel
+       (1  (copy pixarray-1  pixarray-1-element-type))
+       (4  (copy pixarray-4  pixarray-4-element-type))
+       (8  (copy pixarray-8  pixarray-8-element-type))
+       (16 (copy pixarray-16 pixarray-16-element-type))
+       (24 (copy pixarray-24 pixarray-24-element-type))
+       (32 (copy pixarray-32 pixarray-32-element-type)))
+     t)))
diff --git a/src/clx/dep-lispworks.lisp b/src/clx/dep-lispworks.lisp
index b9bc968be9f6c500107dad2b31a4607d984772a2..8b7ee1f8fe3cc92e99e9ff9103916a26901a15ac 100644
--- a/src/clx/dep-lispworks.lisp
+++ b/src/clx/dep-lispworks.lisp
@@ -1133,8 +1133,7 @@ Returns a list of (host display-number screen protocol)."
 (defmacro with-underlying-simple-vector
     ((variable element-type pixarray) &body body)
   (declare (ignore element-type))
-  `(#+cmu kernel::with-array-data #+sbcl sb-kernel:with-array-data
-    ((,variable ,pixarray) (start) (end))
+  `(sb-kernel:with-array-data ((,variable ,pixarray) (start) (end))
     (declare (ignore start end))
     ,@body))
 
@@ -1267,8 +1266,8 @@ Returns a list of (host display-number screen protocol)."
   (declare (type (array * 2) pixarray))
   #.(declare-buffun)
   (copy-bit-rect bbuf
-		 (index* padded-bytes-per-line #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
-		 (index* boffset #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits) 0
+		 (index* padded-bytes-per-line sb-vm:n-byte-bits)
+		 (index* boffset sb-vm:n-byte-bits) 0
 		 pixarray
 		 (index* (array-dimension pixarray 1) bits-per-pixel)
 		 x y
@@ -1382,28 +1381,20 @@ Returns a list of (host display-number screen protocol)."
 	   (type card16 x y width height)
 	   (type (member 1 4 8 16 24 32) bits-per-pixel))
   (progn pixarray copy x y width height bits-per-pixel nil)
-  (or
-   #+(or cmu)
-   (let* ((pixarray-padded-pixels-per-line
-            (array-dimension pixarray 1))
-          (pixarray-padded-bits-per-line
-            (* pixarray-padded-pixels-per-line bits-per-pixel))
-          (copy-padded-pixels-per-line
-            (array-dimension copy 1))
-          (copy-padded-bits-per-line
-            (* copy-padded-pixels-per-line bits-per-pixel)))
-     #-(or cmu)
-     (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
-                (zerop (index-mod pixarray-padded-bits-per-line 32))
-                (zerop (index-mod copy-padded-bits-per-line 32)))
-       (sys:bitblt boole-1 width height pixarray x y copy 0 0)
-       t)
-     #+(or cmu)
-     (when (index= (pixarray-element-size pixarray)
-                   (pixarray-element-size copy)
-                   bits-per-pixel)
-       (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
-                      copy copy-padded-bits-per-line 0 0
-                      height
-                      (index* width bits-per-pixel))
-       t))))
+  #+cmu
+  (let* ((pixarray-padded-pixels-per-line
+           (array-dimension pixarray 1))
+         (pixarray-padded-bits-per-line
+           (* pixarray-padded-pixels-per-line bits-per-pixel))
+         (copy-padded-pixels-per-line
+           (array-dimension copy 1))
+         (copy-padded-bits-per-line
+           (* copy-padded-pixels-per-line bits-per-pixel)))
+    (when (index= (pixarray-element-size pixarray)
+                  (pixarray-element-size copy)
+                  bits-per-pixel)
+      (copy-bit-rect pixarray pixarray-padded-bits-per-line x y
+                     copy copy-padded-bits-per-line 0 0
+                     height
+                     (index* width bits-per-pixel))
+      t)))
diff --git a/src/clx/depdefs.lisp b/src/clx/depdefs.lisp
index 07e199956edec0d25bbd0ec906f7422d509e6373..ebf78ff8ebf933048f84656bec0f26431b05b6ce 100644
--- a/src/clx/depdefs.lisp
+++ b/src/clx/depdefs.lisp
@@ -20,6 +20,11 @@
 
 (in-package :xlib)
 
+;;; Enable this for debug optimization settings and to enforce type checks.
+#+ (or)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (pushnew :clx-debugging *features*))
+
 ;;;-------------------------------------------------------------------------
 ;;; Declarations
 ;;;-------------------------------------------------------------------------
@@ -35,6 +40,42 @@
 	(lisp:rational x)))
   (deftype rational (&optional l u) `(lisp:rational ,l ,u)))
 
+;;; DEFINE-CONSTANT allows to portably define constants with predicate different
+;;; than EQL. This utility is taken from Alexandria library (Public
+;;; Domain). Implementations which require that are sbcl and clasp.
+
+#+ (or sbcl clasp)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %reevaluate-constant (name value test)
+    (if (not (boundp name))
+        value
+        (let ((old (symbol-value name))
+              (new value))
+          (if (not (constantp name))
+              (prog1 new
+                (cerror "Try to redefine the variable as a constant."
+                        "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+              (if (funcall test old new)
+                  old
+                  (restart-case
+                      (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                    (ignore ()
+                      :report "Retain the current value."
+                      old)
+                    (continue ()
+                      :report "Try to redefine the constant."
+                      new)))))))
+
+  (defmacro define-constant (name initial-value &key (test ''eql) documentation)
+    `(cl:defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+       ,@(when documentation `(,documentation))))
+
+  (defmacro defconstant (name value &optional doc)
+    `(define-constant ,name ,value :test #'equalp :documentation ,doc)))
+
 ;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
 
 #-Genera
@@ -95,6 +136,7 @@
 ;;; useful for much beyond xatoms and windows (since almost nothing else
 ;;; ever comes back in events).
 ;;;--------------------------------------------------------------------------
+
 (defconstant +clx-cached-types+
  '(drawable
    window
@@ -500,9 +542,15 @@ used, since NIL is the empty list.")
 		      ,(closintern 'print-object)
 		      ((object ,name) stream)
 		      (,print-function object stream 0))))))))
-      `(within-definition (,name def-clx-class)
-	 (defstruct (,name ,@options)
-	   ,@slots))))
+      (flet ((assert-valid-option (option)
+               (unless (typep option
+                              '(cons (member :constructor :include
+                                             :print-function :copier :predicate)))
+                 (error "~s: invalid option ~s." 'def-clx-class option))))
+        (mapc #'assert-valid-option options)
+        `(within-definition (,name def-clx-class)
+	   (defstruct (,name ,@options)
+	     ,@slots)))))
 
 #+Genera
 (progn
diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp
index c627e174514642cecf4a63131ad52c46322602af..f559ef0cba67dfe9eba38f3ebaab5c05ae063ad0 100644
--- a/src/clx/dependent.lisp
+++ b/src/clx/dependent.lisp
@@ -61,9 +61,9 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
                "Speed compiler option for buffer code.")
-  (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
+  (defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 1
                "Safety compiler option for buffer code.")
-  (defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
+  (defconstant +buffer-debug+ #+clx-debugging 3 #-clx-debugging 1
                "Debug compiler option for buffer code>")
   (defun declare-bufmac ()
     `(declare (optimize
@@ -372,7 +372,7 @@
   (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
 
 
-#+(or cmu sbcl clisp ecl)
+#+(or cmu sbcl clisp ecl clasp)
 (progn
 
 ;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
@@ -387,7 +387,9 @@
 
   (defun anglep (x)
     (and (typep x 'real)
-         (<= (* -360 64) (radians->int16 x) (* 360 64)))))
+         (<= (* -360 64)
+             (the int16 (round x #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))
+             (* 360 64)))))
 
 
 ;;-----------------------------------------------------------------------------
@@ -530,7 +532,7 @@
 
 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
 
-#-(or sbcl (and cmu mp) (and ecl threads))
+#-(or abcl sbcl (and cmu mp) (and ecl threads) (and clasp threads))
 (defun make-process-lock (name)
   (declare (ignore name))
   nil)
@@ -547,6 +549,14 @@
 (defun make-process-lock (name)
   (mp:make-lock :name name :recursive t))
 
+#+(and clasp threads)
+(defun make-process-lock (name)
+  (mp:make-recursive-mutex name))
+
+#+abcl
+(defun make-process-lock (name)
+  (threads:make-thread-lock))
+
 ;;; HOLDING-LOCK: Execute a body of code with a lock held.
 
 ;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
@@ -555,7 +565,7 @@
 
 ;; If you're not sharing DISPLAY objects within a multi-processing
 ;; shared-memory environment, this is sufficient
-#-(or sbcl (and CMU mp) (and ecl threads))
+#-(or abcl sbcl (and CMU mp) (and ecl threads) (and clasp threads))
 (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
   (declare (ignore locator display whostate timeout))
   `(progn ,@body))
@@ -569,16 +579,15 @@
 ;;; display connection.  We inhibit GC notifications since display of them
 ;;; could cause recursive entry into CLX.
 ;;;
-#+(and CMU (not mp))
+#+(and cmu (not mp))
 (defmacro holding-lock ((locator display &optional whostate &key timeout)
                         &body body)
-  `(let #+cmu((ext:*gc-verbose* nil)
-              (ext:*gc-inhibit-hook* nil)
-              (ext:*before-gc-hooks* nil)
-              (ext:*after-gc-hooks* nil))
-        #+sbcl()
-        ,locator ,display ,whostate ,timeout
-        (system:without-interrupts (progn ,@body))))
+  `(let ((ext:*gc-verbose* nil)
+         (ext:*gc-inhibit-hook* nil)
+         (ext:*before-gc-hooks* nil)
+         (ext:*after-gc-hooks* nil))
+     ,locator ,display ,whostate ,timeout
+     (system:without-interrupts (progn ,@body))))
 
 ;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
 ;;;
@@ -590,21 +599,21 @@
   `(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
      ,@body))
 
-#+clisp
+#+(and ecl threads)
 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
                               &key timeout)
                         &body body)
-  (declare (ignore lock display whostate timeout))
-  `(progn
+  (declare (ignore display))
+  `(mp::with-lock (,lock)
      ,@body))
 
-#+(and ecl threads)
+#+(and clasp threads)
 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
                               &key timeout)
                         &body body)
   (declare (ignore display))
   `(mp::with-lock (,lock)
-     ,@body))
+      ,@body))
 
 #+sbcl
 (defmacro holding-lock ((lock display &optional (whostate "CLX wait")
@@ -612,21 +621,18 @@
                         &body body)
   ;; This macro is used by WITH-DISPLAY, which claims to be callable
   ;; recursively.  So, had better use a recursive lock.
-  ;;
-  ;; FIXME: This is hideously ugly.  If WITH-TIMEOUT handled NIL
-  ;; timeouts...
   (declare (ignore display whostate))
-  (if timeout
-      `(if ,timeout
-           (handler-case
-               (sb-ext:with-timeout ,timeout
-                 (sb-thread:with-recursive-lock (,lock)
-                   ,@body))
-             (sb-ext:timeout () nil))
-           (sb-thread:with-recursive-lock (,lock)
-             ,@body))
-      `(sb-thread:with-recursive-lock (,lock)
-         ,@body)))
+  `(sb-thread:with-recursive-lock (,lock ,@(when timeout
+                                             `(:timeout ,timeout)))
+     ,@body))
+
+#+abcl
+(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
+                              &key timeout)
+                        &body body)
+  (declare (ignore display whostate timeout))
+  `(threads:with-thread-lock (,lock)
+     ,@body))
 
 ;;; WITHOUT-ABORTS
 
@@ -642,7 +648,7 @@
 ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
 ;;; value changes.
 
-#-(or (and sb-thread sbcl) (and cmu mp) (and ecl threads))
+#-(or (and sb-thread sbcl) (and cmu mp) (and ecl threads) (and clasp threads))
 (defun process-block (whostate predicate &rest predicate-args)
   (declare (ignore whostate))
   (or (apply predicate predicate-args)
@@ -681,6 +687,15 @@
        (return))
      (mp:process-yield)))
 
+#+(and clasp threads)
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (ignore whostate))
+  (declare (type function predicate))
+  (loop
+   (when (apply predicate predicate-args)
+     (return))
+     (mp:process-yield)))
+
 ;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
 ;;; queues and condition variables might seem better, but in fact it
 ;;; turns out to make performance extremely suboptimal, at least as
@@ -716,11 +731,16 @@
 
 (declaim (inline process-wakeup))
 
-#-(or (and sbcl sb-thread) (and cmu mp) (and ecl threads))
+#-(or abcl (and sbcl sb-thread) (and cmu mp) (and ecl threads) (and clasp threads))
 (defun process-wakeup (process)
   (declare (ignore process))
   nil)
 
+#+abcl
+(defun process-wakeup (process)
+  (declare (ignore process))
+  (threads:yield))
+
 #+(and cmu mp)
 (defun process-wakeup (process)
   (declare (ignore process))
@@ -736,6 +756,11 @@
   (declare (ignore process))
   (mp:process-yield))
 
+#+(and clasp threads)
+(defun process-wakeup (process)
+  (declare (ignore process))
+  (mp:process-yield))
+
 #+(or)
 (defun process-wakeup (process)
   (declare (ignore process))
@@ -754,11 +779,11 @@
 
 ;;; Default return NIL, which is acceptable even if there is a scheduler.
 
-#-(or sbcl (and cmu mp) (and ecl threads))
+#-(or abcl sbcl (and cmu mp) (and ecl threads) (and clasp threads))
 (defun current-process ()
   nil)
 
-#+(or (and cmu mp) (and ecl threads))
+#+(or (and cmu mp) (and ecl threads) (and clasp threads))
 (defun current-process ()
   mp:*current-process*)
 
@@ -766,9 +791,13 @@
 (defun current-process ()
   sb-thread:*current-thread*)
 
+#+abcl
+(defun current-process ()
+  (threads:current-thread))
+
 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
 
-#-(or ecl cmu sbcl)
+#-(or ecl cmu sbcl clasp)
 (defmacro without-interrupts (&body body)
   `(progn ,@body))
 
@@ -780,6 +809,10 @@
 (defmacro without-interrupts (&body body)
   `(mp:without-interrupts ,@body))
 
+#+clasp
+(defmacro without-interrupts (&body body)
+  `(mp:without-interrupts ,@body))
+
 #+sbcl
 (defvar *without-interrupts-sic-lock*
   (sb-thread:make-mutex :name "lock simulating *without-interrupts*"))
@@ -793,24 +826,34 @@
 ;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
 ;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
 
-;; FIXME: both sbcl and ecl has compare-and-swap these days.
+#-(or (and clasp threads) ecl sbcl)
+(progn
+  (defvar *conditional-store-lock*
+    (make-process-lock "conditional store"))
+  (defmacro conditional-store (place old-value new-value)
+    `(holding-lock (*conditional-store-lock* nil)
+       (if (eq ,place ,old-value)
+           (prog1 t
+             (setf ,place ,new-value))
+           nil))))
+
+#+(and clasp threads)
+(defmacro conditional-store (place old-value new-value)
+  (let ((ov (gensym)))
+    `(let ((,ov ,old-value))
+       (eq ,ov (mp:cas ,place ,ov ,new-value)))))
 
-#-sbcl
+#+ecl
 (defmacro conditional-store (place old-value new-value)
-  `(without-interrupts
-     (cond ((eq ,place ,old-value)
-            (setf ,place ,new-value)
-            t))))
+  (let ((ov (gensym)))
+    `(let ((,ov ,old-value))
+       (eq ,ov (mp:compare-and-swap ,place ,ov ,new-value)))))
 
 #+sbcl
-(progn
-  (defvar *conditional-store-lock*
-    (sb-thread:make-mutex :name "conditional store"))
-  (defmacro conditional-store (place old-value new-value)
-    `(sb-thread:with-mutex (*conditional-store-lock*)
-       (cond ((eq ,place ,old-value)
-              (setf ,place ,new-value)
-              t)))))
+(defmacro conditional-store (place old-value new-value)
+  (let ((ov (gensym)))
+    `(let ((,ov ,old-value))
+       (eq ,ov (sb-ext:compare-and-swap ,place ,ov ,new-value)))))
 
 ;;;----------------------------------------------------------------------------
 ;;; IO Error Recovery
@@ -839,7 +882,7 @@
 ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
 ;;; server
 
-#-(or CMU sbcl ecl clisp)
+#-(or CMU sbcl ecl clisp clasp)
 (defun open-x-stream (host display protocol)
   host display protocol ;; unused
   (error "OPEN-X-STREAM not implemented yet."))
@@ -884,6 +927,24 @@
    :element-type '(unsigned-byte 8)
    :input t :output t :buffering :none))
 
+#+clasp
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol)
+           (type (integer 0) display))
+  (SB-BSD-SOCKETS:socket-make-stream
+   (let ((unix-domain-socket-path (unix-socket-path-from-host host display)))
+     (if unix-domain-socket-path
+         (let ((s (make-instance 'SB-BSD-SOCKETS:local-socket :type :stream)))
+           (SB-BSD-SOCKETS:socket-connect s unix-domain-socket-path)
+           s)
+         (let ((host (car (SB-BSD-SOCKETS:host-ent-addresses (SB-BSD-SOCKETS:get-host-by-name host)))))
+           (when host
+             (let ((s (make-instance 'SB-BSD-SOCKETS:inet-socket :type :stream :protocol :tcp)))
+               (SB-BSD-SOCKETS:socket-connect s host (+ 6000 display))
+               s)))))
+   :element-type '(unsigned-byte 8)
+   :input t :output t :buffering :none))
+
 #+cmu
 (defun open-x-stream (host display protocol)
   (let ((stream-fd
@@ -936,9 +997,10 @@
   (declare (type display display)
            (type buffer-bytes vector)
            (type array-index start end)
-           (type (or null fixnum) timeout))
+           (type (or null (real 0 *)) timeout))
   #.(declare-buffun)
-  (cond ((and (eql timeout 0)
+  (cond ((and (not (null timeout))
+              (zerop timeout)
               (not (listen (display-input-stream display))))
          :timeout)
         (t
@@ -948,14 +1010,15 @@
                 vector start (- end start))
          nil)))
 
-#+(or ecl clisp)
+#+(or ecl clisp clasp)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
            (type buffer-bytes vector)
            (type array-index start end)
-           (type (or null fixnum) timeout))
+           (type (or null (real 0 *)) timeout))
   #.(declare-buffun)
-  (cond ((and (eql timeout 0)
+  (cond ((and (not (null timeout))
+              (zerop timeout)
               (not (listen (display-input-stream display))))
          :timeout)
         (t
@@ -970,7 +1033,7 @@
 ;;;	receiving all data from the X Window System server.
 ;;;	You are encouraged to write a specialized version of
 ;;;	buffer-read-default that does block transfers.
-#-(or CMU sbcl ecl clisp)
+#-(or CMU sbcl ecl clisp clasp)
 (defun buffer-read-default (display vector start end timeout)
   (declare (type display display)
            (type buffer-bytes vector)
@@ -1003,7 +1066,7 @@
   (system:output-raw-bytes (display-output-stream display) vector start end)
   nil)
 
-#+(or sbcl ecl clisp)
+#+(or sbcl ecl clisp clasp)
 (defun buffer-write-default (vector display start end)
   (declare (type buffer-bytes vector)
            (type display display)
@@ -1018,7 +1081,7 @@
 ;;;	You are STRONGLY encouraged to write a specialized version
 ;;;	of buffer-write-default that does block transfers.
 
-#-(or CMU sbcl clisp ecl)
+#-(or CMU sbcl clisp ecl clasp)
 (defun buffer-write-default (vector display start end)
   ;; The default buffer write function for use with common-lisp streams
   (declare (type buffer-bytes vector)
@@ -1061,36 +1124,56 @@
 ;;; :TIMEOUT if it times out, NIL otherwise.
 
 ;;; The default implementation
-
-;; Poll for input every *buffer-read-polling-time* SECONDS.
-#-(or CMU sbcl)
-(defparameter *buffer-read-polling-time* 0.5)
-
-#-(or CMU sbcl clisp)
+#-(or cmu sbcl clisp (and ecl serve-event))
+(progn
+  ;; Issue a warning to incentivize providing better implementation.
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (warn "XLIB::BUFFER-INPUT-WAIT-DEFAULT: timeout polling used."))
+  ;; Poll for input every *buffer-read-polling-time* SECONDS.
+  (defparameter *buffer-read-polling-time* 0.01)
+  (defun buffer-input-wait-default (display timeout)
+    (declare (type display display)
+             (type (or null (real 0 *)) timeout))
+    (declare (clx-values timeout))
+    (let ((stream (display-input-stream display)))
+      (declare (type (or null stream) stream))
+      (cond ((null stream))
+            ((listen stream) nil)
+            ((and timeout (= timeout 0)) :timeout)
+            ((not (null timeout))
+             (multiple-value-bind (npoll fraction)
+                 (truncate timeout *buffer-read-polling-time*)
+               (dotimes (i npoll)        ; Sleep for a time, then listen again
+                 (sleep *buffer-read-polling-time*)
+                 (when (listen stream)
+                   (return-from buffer-input-wait-default nil)))
+               (when (plusp fraction)
+                 (sleep fraction)        ; Sleep a fraction of a second
+                 (when (listen stream)   ; and listen one last time
+                   (return-from buffer-input-wait-default nil)))
+               :timeout))))))
+
+#+(and ecl serve-event)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
-           (type (or null (real 0 *)) timeout))
-  (declare (clx-values timeout))
-
+           (type (or null number) timeout))
   (let ((stream (display-input-stream display)))
     (declare (type (or null stream) stream))
     (cond ((null stream))
           ((listen stream) nil)
-          ((and timeout (= timeout 0)) :timeout)
-          ((not (null timeout))
-           (multiple-value-bind (npoll fraction)
-               (truncate timeout *buffer-read-polling-time*)
-             (dotimes (i npoll)			; Sleep for a time, then listen again
-               (sleep *buffer-read-polling-time*)
-               (when (listen stream)
-                 (return-from buffer-input-wait-default nil)))
-             (when (plusp fraction)
-               (sleep fraction)			; Sleep a fraction of a second
-               (when (listen stream)		; and listen one last time
-                 (return-from buffer-input-wait-default nil)))
-             :timeout)))))
-
-#+(or CMU sbcl clisp)
+          ((eql timeout 0) :timeout)
+          (T (flet ((usable! (fd)
+                      (declare (ignore fd))
+                      (return-from buffer-input-wait-default)))
+               (serve-event:with-fd-handler ((ext:file-stream-fd
+                                              (typecase stream
+                                                (two-way-stream (two-way-stream-input-stream stream))
+                                                (otherwise stream)))
+                                             :input #'usable!)
+                 (serve-event:serve-event timeout)))
+             :timeout))))
+
+#+(or cmu sbcl clisp)
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
            (type (or null number) timeout))
@@ -1099,18 +1182,14 @@
     (cond ((null stream))
           ((listen stream) nil)
           ((eql timeout 0) :timeout)
-          (t
-           (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
-                                                   :input timeout)
-               #+mp (mp:process-wait-until-fd-usable
-                     (system:fd-stream-fd stream) :input timeout)
+          ;; MP package protocol may be shared between clisp and cmu.
+          ((or #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout)
+               #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout)
                #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
-                         (ext:socket-status stream (and timeout sec)
-                                            (round usec 1d-6)))
-               #-(or sbcl mp clisp) (system:wait-until-fd-usable
-                                     (system:fd-stream-fd stream) :input timeout)
-               nil
-               :timeout)))))
+                         (ext:socket-status stream (and timeout sec) (round usec 1d-6)))
+               #+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout))
+           nil)
+          (T :timeout))))
 
 ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
 ;;; buffer. This should never block, so it can be called from the scheduler.
@@ -1172,11 +1251,11 @@
            (type array-index start1 end1 start2))
   #.(declare-buffun)
   (kernel:bit-bash-copy
-   buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
-           (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
-   buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
-           (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
-   (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)))
+   buf2 (+ (* start2 vm:byte-bits)
+           (* vm:vector-data-offset vm:word-bits))
+   buf1 (+ (* start1 vm:byte-bits)
+           (* vm:vector-data-offset vm:word-bits))
+   (* (- end1 start1) vm:byte-bits)))
 
 #+clx-overlapping-arrays
 (defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
@@ -1242,9 +1321,10 @@
 ;;; This controls macro expansion, and isn't changable at run-time You will
 ;;; probably want to set this to nil if you want good performance at
 ;;; production time.
+
 (defconstant +type-check?+
-  #+(or ecl CMU sbcl) nil
-  #-(or ecl CMU sbcl) t)
+  #+clx-debugging t
+  #-clx-debugging nil)
 
 ;; TYPE? is used to allow the code to do error checking at a different level from
 ;; the declarations.  It also does some optimizations for systems that don't have
@@ -1339,7 +1419,7 @@
 ;;  HOST hacking
 ;;-----------------------------------------------------------------------------
 
-#-(or CMU sbcl ecl clisp)
+#-(or CMU sbcl ecl clisp clasp)
 (defun host-address (host &optional (family :internet))
   ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
   ;; and cdr is a list of network address bytes.
@@ -1398,39 +1478,19 @@
              (error "Unknown host ~S" host))
            (no-address-error ()
              (error "Host ~S has no ~S address" host family)))
-    (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host))
-                   #+mna-sockets(net.sbcl.sockets:look-up-host-entry
-                                 (string host))
-                   #+db-sockets(sockets:get-host-by-name (string host))))
+    (let ((hostent (ext:lookup-host-entry (string host))))
       (when (not hostent)
         (no-host-error))
       (ecase family
         ((:internet nil 0)
-         #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2)
-                        (no-address-error))
-         #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2)
-                        (no-address-error))
-         ;; the following form is for use with SBCL and Daniel
-         ;; Barlow's socket package
-         #+db-sockets(unless (sockets:host-ent-address hostent)
-                       (no-address-error))
-         (append (list :internet)
-                 #+rwi-sockets
-                 (let ((addr (first (ext::host-entry-addr-list hostent))))
-                   (list (ldb (byte 8 24) addr)
-                         (ldb (byte 8 16) addr)
-                         (ldb (byte 8  8) addr)
-                         (ldb (byte 8  0) addr)))
-                 #+mna-sockets
-                 (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent))))
-                   (list (ldb (byte 8 24) addr)
-                         (ldb (byte 8 16) addr)
-                         (ldb (byte 8  8) addr)
-                         (ldb (byte 8  0) addr)))
-                 ;; the following form is for use with SBCL and Daniel
-                 ;; Barlow's socket package
-                 #+db-sockets(coerce (sockets:host-ent-address hostent)
-                                     'list)))))))
+         (unless (= (ext::host-entry-addr-type hostent) 2)
+           (no-address-error))
+         (let ((addr (first (ext::host-entry-addr-list hostent))))
+           (list :internet
+                 (ldb (byte 8 24) addr)
+                 (ldb (byte 8 16) addr)
+                 (ldb (byte 8  8) addr)
+                 (ldb (byte 8  0) addr))))))))
 
 ;;#+sbcl
 ;;(require :sockets)
@@ -1464,6 +1524,18 @@
             (ldb (byte 8  8) addr)
             (ldb (byte 8  0) addr)))))
 
+#+clasp
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type stringable host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (clx-values list))
+  (let ((hostent (SB-BSD-SOCKETS:get-host-by-name (string host))))
+    (ecase family
+      ((:internet nil 0)
+       (cons :internet (coerce (SB-BSD-SOCKETS:host-ent-address hostent) 'list))))))
+
 
 ;;-----------------------------------------------------------------------------
 ;; Whether to use closures for requests or not.
@@ -1494,15 +1566,16 @@
   #+sbcl (sb-ext:posix-getenv name)
   #+ecl (si:getenv name)
   #+clisp (ext:getenv name)
-  #-(or sbcl CMU ecl clisp) (progn name nil))
+  #+clasp (ext:getenv name)
+  #-(or sbcl CMU ecl clisp clasp) (progn name nil))
 
 (defun get-host-name ()
   "Return the same hostname as gethostname(3) would"
   ;; machine-instance probably works on a lot of lisps, but clisp is not
   ;; one of them
-  #+(or cmu sbcl ecl) (machine-instance)
+  #+(or cmu sbcl ecl clasp) (machine-instance)
   #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
-  #-(or cmu sbcl ecl clisp) (error "get-host-name not implemented"))
+  #-(or cmu sbcl ecl clisp clasp) (error "get-host-name not implemented"))
 
 (defun homedir-file-pathname (name)
   (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
@@ -1791,7 +1864,6 @@ Returns a list of (host display-number screen protocol)."
           (t
            (error "Invalid pixarray: ~S." pixarray)))))
 
-#+CMU
 ;;; COPY-BIT-RECT  --  Internal
 ;;;
 ;;;    This is the classic BITBLT operation, copying a rectangular subarray
@@ -1799,6 +1871,7 @@ Returns a list of (host display-number screen protocol)."
 ;;; Widths are specified in bits.  Neither array can have a non-zero
 ;;; displacement.  We allow extra random bit-offset to be thrown into the X.
 ;;;
+#+cmu
 (defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
                       height width)
   (declare (type array-index source-width sx sy dest-width dx dy height width))
@@ -1812,10 +1885,10 @@ Returns a list of (host display-number screen protocol)."
                               (dend))
       (declare (ignore dend))
       (assert (and (zerop sstart) (zerop dstart)))
-      (do ((src-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
+      (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
                             sx (index* sy source-width))
                     (index+ src-idx source-width))
-           (dest-idx (index+ (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits)
+           (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
                              dx (index* dy dest-width))
                      (index+ dest-idx dest-width))
            (count height (1- count)))
diff --git a/src/clx/display.lisp b/src/clx/display.lisp
index b96357d1a34f8126bee31a00305bf92a257d5b17..d1bc1f5747ed72511bde0c5b2c0ac78589f99919 100644
--- a/src/clx/display.lisp
+++ b/src/clx/display.lisp
@@ -231,11 +231,17 @@
 				   (type resource-id id))
 			  (declare (clx-values ,type))
 			  ,(if (member type +clx-cached-types+)
-			       `(let ((,type (lookup-resource-id display id)))
-				  (cond ((null ,type) ;; Not found, create and save it.
-					 (setq ,type (,(xintern 'make- type)
-						      :display display :id id))
-					 (save-id display id ,type))
+			       `(multiple-value-bind (,type foundp)
+				    (with-display (display)
+				      (let ((,type (lookup-resource-id display id)))
+					(if (null ,type) ; Not found, create and save it.
+					    (let ((,type (,(xintern 'make- type)
+							  :display display :id id)))
+					      (save-id display id ,type)
+					      (values ,type nil))
+					    (values ,type t))))
+				  (cond ((not foundp)
+					 ,type)
 					;; Found.  Check the type
 					,(cond ((null +type-check?+)
 						`(t ,type))
diff --git a/src/clx/excldep.lisp b/src/clx/excldep.lisp
index 940a70f7cdfb642103496a8998a09e61c2c19813..678f2fd3de7383c76e6908182233b4e1a5d5f475 100644
--- a/src/clx/excldep.lisp
+++ b/src/clx/excldep.lisp
@@ -15,17 +15,16 @@
 
 (in-package :xlib)
 
-(eval-when (compile load eval)
+(eval-when (:compile-toplevel :execute :load-toplevel)
   (require :foreign)
   (require :process)			; Needed even if scheduler is not
 					; running.  (Must be able to make
 					; a process-lock.)
   )
 
-(eval-when (load)
+(eval-when (:load-toplevel)
   (provide :clx))
 
-
 #-(or little-endian big-endian)
 (eval-when (eval compile load)
   (let ((x '#(1)))
@@ -33,11 +32,10 @@
 				#.(sys::mdparam 'comp::md-lvector-data0-norm)
 				0 :unsigned-byte)))
 	(pushnew :little-endian *features*)
-      (pushnew :big-endian *features*))))
-
+	(pushnew :big-endian *features*))))
 
 (defmacro correct-case (string)
-  ;; This macro converts the given string to the 
+  ;; This macro converts the given string to the
   ;; current preferred case, or leaves it alone in a case-sensitive mode.
   (let ((str (gensym)))
     `(let ((,str ,string))
@@ -49,387 +47,161 @@
 	 ((:case-sensitive-lower :case-sensitive-upper)
 	  ,str)))))
 
-
 (defconstant type-pred-alist
-    '(#-(version>= 4 1 devel 16)
-      (card8  . card8p)
-      #-(version>= 4 1 devel 16)
-      (card16 . card16p)
-      #-(version>= 4 1 devel 16)
-      (card29 . card29p)
-      #-(version>= 4 1 devel 16)
-      (card32 . card32p)
-      #-(version>= 4 1 devel 16)
-      (int8   . int8p)
-      #-(version>= 4 1 devel 16)
-      (int16  . int16p)
-      #-(version>= 4 1 devel 16)
-      (int32  . int32p)
-      #-(version>= 4 1 devel 16)
-      (mask16 . card16p)
-      #-(version>= 4 1 devel 16)
-      (mask32 . card32p)
-      #-(version>= 4 1 devel 16)
-      (pixel  . card32p)
-      #-(version>= 4 1 devel 16)
-      (resource-id . card29p)
-      #-(version>= 4 1 devel 16)
-      (keysym . card32p)
-      (angle  . anglep)
-      (color  . color-p)
-      (bitmap-format . bitmap-format-p)
-      (pixmap-format . pixmap-format-p)
-      (display  . display-p)
-      (drawable . drawable-p)
-      (window   . window-p)
-      (pixmap   . pixmap-p)
-      (visual-info . visual-info-p)
-      (colormap . colormap-p)
-      (cursor . cursor-p)
-      (gcontext .  gcontext-p)
-      (screen . screen-p)
-      (font . font-p)
-      (image-x . image-x-p)
-      (image-xy . image-xy-p)
-      (image-z . image-z-p)
-      (wm-hints . wm-hints-p)
-      (wm-size-hints . wm-size-hints-p)
-      ))
-
-;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 
+  '((card8  . card8p)
+    (card16 . card16p)
+    (card29 . card29p)
+    (card32 . card32p)
+    (int8   . int8p)
+    (int16  . int16p)
+    (int32  . int32p)
+    (mask16 . card16p)
+    (mask32 . card32p)
+    (pixel  . card32p)
+    (resource-id . card29p)
+    (keysym . card32p)
+    (angle  . anglep)
+    (color  . color-p)
+    (bitmap-format . bitmap-format-p)
+    (pixmap-format . pixmap-format-p)
+    (display  . display-p)
+    (drawable . drawable-p)
+    (window   . window-p)
+    (pixmap   . pixmap-p)
+    (visual-info . visual-info-p)
+    (colormap . colormap-p)
+    (cursor . cursor-p)
+    (gcontext .  gcontext-p)
+    (screen . screen-p)
+    (font . font-p)
+    (image-x . image-x-p)
+    (image-xy . image-xy-p)
+    (image-z . image-z-p)
+    (wm-hints . wm-hints-p)
+    (wm-size-hints . wm-size-hints-p)
+    ))
+
+;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
 ;; sun4 compiler opencode the `and'.
 
-#-(version>= 4 1 devel 16)
 (defun card8p (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
   (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun card16p (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
   (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun card29p (x)
   (declare (optimize (speed 3) (safety 0)))
   (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
 	  (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
 	       (>= (the bignum x) 0)))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun card32p (x)
   (declare (optimize (speed 3) (safety 0)))
   (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
 	  (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
 	       (>= (the bignum x) 0)))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun int8p (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
   (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun int16p (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
   (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
       t
-    nil))
+      nil))
 
-#-(version>= 4 1 devel 16)
 (defun int32p (x)
   (declare (optimize (speed 3) (safety 0)))
   (if (or (excl:fixnump x)
 	  (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
 	       (>= (the bignum x) #.(expt -2 31))))
       t
-    nil))
+      nil))
 
 ;; This one can be handled better by knowing a little about what we're
 ;; testing for.  Plus this version can handle (single-float pi), which
 ;; is otherwise larger than pi!
 (defun anglep (x)
   (declare (optimize (speed 3) (safety 0)))
-  (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
+  (if (or (and (excl:fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
 	       (<= (the fixnum x) #.(truncate (* 2 pi))))
-	  (and (excl::single-float-p x)
+	  (and (excl:single-float-p x)
 	       (>= (the single-float x) #.(float (* -2 pi) 0.0s0))
 	       (<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
-	  (and (excl::double-float-p x)
+	  (and (excl:double-float-p x)
 	       (>= (the double-float x) #.(float (* -2 pi) 0.0d0))
 	       (<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
       t
-    nil))
+      nil))
 
-(eval-when (load eval)
-  #+(version>= 4 1 devel 16)
+(eval-when (:load-toplevel :execute :compile-toplevel)
   (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
-	  type-pred-alist)
-  #-(version>= 4 1 devel 16)
-  (nconc excl::type-pred-alist type-pred-alist))
-
+	  type-pred-alist))
 
-;; Return t if there is a character available for reading or on error,
-;; otherwise return nil.
-#-(version>= 6 0)
-(progn
-
-#-(or (version>= 4 2) mswindows)
-(defun fd-char-avail-p (fd)
-  (multiple-value-bind (available-p errcode)
-      (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
-    (excl:if* errcode
-       then t
-       else available-p)))
-
-#+(and (version>= 4 2) (not mswindows))
-(defun fd-char-avail-p (fd)
-  (excl::filesys-character-available-p fd))
-
-#+mswindows
 (defun fd-char-avail-p (socket-stream)
-  (listen socket-stream))
-)
+  (excl:read-no-hang-p socket-stream))
 
-#+(version>= 6 0)
-(defun fd-char-avail-p (socket-stream)
-  (excl::read-no-hang-p socket-stream))
+(defun stream-char-avail-p (socket-stream)
+  (excl:read-no-hang-p socket-stream))
 
 (defmacro with-interrupt-checking-on (&body body)
   `(locally (declare (optimize (safety 1)))
      ,@body))
 
-;; Read from the given fd into 'vector', which has element type card8.
-;; Start storing at index 'start-index' and read exactly 'length' bytes.
-;; Return t if an error or eof occurred, nil otherwise.
 (defun fd-read-bytes (fd vector start-index length)
   ;; Read from the given stream fd into 'vector', which has element type card8.
   ;; Start storing at index 'start-index' and read exactly 'length' bytes.
   ;; Return t if an error or eof occurred, nil otherwise.
-  (declare (fixnum next-index start-index length))
+  (declare (fixnum start-index length))
   (with-interrupt-checking-on
-      (let ((end-index (+ start-index length)))
-	(loop
-	  (let ((next-index (excl:read-vector vector fd 
-					      :start start-index
-					      :end end-index)))
-	    (excl:if* (eq next-index start-index)
-	       then			; end of file before was all filled up
-		    (return t)
-	     elseif (eq next-index end-index)
-	       then			; we're all done
-		    (return nil)
-	       else (setq start-index next-index)))))))
-
-
-;; special patch for CLX (various process fixes)
-;; patch1000.2
-
-(eval-when (compile load eval)
-  (unless (find-package :patch)
-    (make-package :patch :use '(:lisp :excl))))
-
-(in-package :patch)
-
-(defvar *patches* nil)
-
-#+allegro
-(eval-when (compile eval load)
-  (when (and (= excl::cl-major-version-number 3)
-	     (or (= excl::cl-minor-version-number 0)
-		 (and (= excl::cl-minor-version-number 1)
-		      excl::cl-generation-number
-		      (< excl::cl-generation-number 9))))
-    (push :clx-r4-process-patches *features*)))
-
-#+clx-r4-process-patches
-(push (cons 1000.2 "special patch for CLX (various process fixes)")
-      *patches*)
-
-
-(in-package :mp)
-
-#+clx-r4-process-patches
-(export 'wait-for-input-available)
-
-
-#+clx-r4-process-patches
-(defun with-timeout-event (seconds fnc args)
-  (unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
-  (let ((clock-event (make-clock-event)))
-    (when (<= seconds 0) (setq seconds 0))
-    (multiple-value-bind (secs msecs) (truncate seconds)
-      ;; secs is now a nonegative integer, and msecs is either fixnum zero
-      ;; or else something interesting.
-      (unless (eq 0 msecs)
-	(setq msecs (truncate (* 1000.0 msecs))))
-      ;; Now msecs is also a nonnegative fixnum.
-      (multiple-value-bind (now mnow) (excl::cl-internal-real-time)
-	(incf secs now)
-	(incf msecs mnow)
-	(when (>= msecs 1000)
-	  (decf msecs 1000)
-	  (incf secs))
-	(unless (excl:fixnump secs) (setq secs most-positive-fixnum))
-	(setf (clock-event-secs clock-event) secs
-	      (clock-event-msecs clock-event) msecs
-	      (clock-event-function clock-event) fnc
-	      (clock-event-args clock-event) args)))
-    clock-event))
-
-
-#+clx-r4-process-patches
-(defmacro with-timeout ((seconds &body timeout-body) &body body)
-  `(let* ((clock-event (with-timeout-event ,seconds
-					   #'process-interrupt
-					   (cons *current-process*
-						 '(with-timeout-internal))))
-	  (excl::*without-interrupts* t)
-	  ret)
-     (unwind-protect
-	 ;; Warning: Branch tensioner better not reorder this code!
-	 (setq ret (catch 'with-timeout-internal
-		     (add-to-clock-queue clock-event)
-		     (let ((excl::*without-interrupts* nil))
-		       (multiple-value-list (progn ,@body)))))
-       (excl:if* (eq ret 'with-timeout-internal)
-	  then (let ((excl::*without-interrupts* nil))
-		 (setq ret (multiple-value-list (progn ,@timeout-body))))
-	  else (remove-from-clock-queue clock-event)))
-     (values-list ret)))
-
-
-#+clx-r4-process-patches
-(defun process-lock (lock &optional (lock-value *current-process*)
-				    (whostate "Lock") timeout)
-  (declare (optimize (speed 3)))
-  (unless (process-lock-p lock)
-    (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
-  (without-interrupts
-   (excl:if* (null (process-lock-locker lock))
-      then (setf (process-lock-locker lock) lock-value)
-      else (excl:if* timeout
-	      then (excl:if* (or (eq 0 timeout) ;for speed
-				 (zerop timeout))
-		      then nil
-		      else (with-timeout (timeout)
-			     (process-lock-1 lock lock-value whostate)))
-	      else (process-lock-1 lock lock-value whostate)))))
-
-
-#+clx-r4-process-patches
-(defun process-lock-1 (lock lock-value whostate)
-  (declare (type process-lock lock)
-	   (optimize (speed 3)))
-  (let ((process *current-process*))
-    (declare (type process process))
-    (unless process
-      (error
-       "PROCESS-LOCK may not be called on the scheduler's stack group."))
-    (loop (unless (process-lock-locker lock)
-	    (return (setf (process-lock-locker lock) lock-value)))
-      (push process (process-lock-waiting lock))
-      (let ((saved-whostate (process-whostate process)))
-	(unwind-protect
-	    (progn (setf (process-whostate process) whostate)
-		   (process-add-arrest-reason process lock))
-	  (setf (process-whostate process) saved-whostate))))))
-
-
-#+clx-r4-process-patches
-(defun process-wait (whostate function &rest args)
-  (declare (optimize (speed 3)))
-  ;; Run the wait function once here both for efficiency and as a
-  ;; first line check for errors in the function.
-  (unless (apply function args)
-    (process-wait-1 whostate function args)))
-
-
-#+clx-r4-process-patches
-(defun process-wait-1 (whostate function args)
-  (declare (optimize (speed 3)))
-  (let ((process *current-process*))
-    (declare (type process process))
-    (unless process
-      (error
-       "Process-wait may not be called within the scheduler's stack group."))
-    (let ((saved-whostate (process-whostate process)))
-      (unwind-protect
-	  (without-scheduling-internal
-	   (without-interrupts
-	    (setf (process-whostate process) whostate
-		  (process-wait-function process) function
-		  (process-wait-args process) args)
-	    (chain-rem-q process)
-	    (chain-ins-q process *waiting-processes*))
-	   (process-resume-scheduler nil))
-	(setf (process-whostate process) saved-whostate
-	      (process-wait-function process) nil
-	      (process-wait-args process) nil)))))
-
-
-#+clx-r4-process-patches
-(defun process-wait-with-timeout (whostate seconds function &rest args)
-  ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
-  ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
-  ;;  -- 28Feb90 smh
-  ;; Run the wait function once here both for efficiency and as a
-  ;; first line check for errors in the function.
-  (excl:if* (apply function args)
-     then t
-     else (let ((ret (list nil)))
-            (without-interrupts
-             (let ((clock-event
-                    (with-timeout-event seconds #'identity '(nil))))
-               (add-to-clock-queue clock-event)
-               (process-wait-1 whostate
-                               #'(lambda (clock-event function args ret)
-                                   (or (null (chain-next clock-event))
-                                       (and (apply function args)
-                                            (setf (car ret) 't))))
-                               (list clock-event function args ret))))
-            (car ret))))
-
-
-;;
-;; Returns nil on timeout, otherwise t.
-;;
-#+clx-r4-process-patches
-(defun wait-for-input-available
-    (stream-or-fd &key (wait-function #'listen)
-		       (whostate "waiting for input")
-		       timeout)
-  (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
-	     elseif (streamp stream-or-fd)
-	       then (excl::stream-input-fn stream-or-fd)
-	       else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
-    ;; At this point fd could be nil, since stream-input-fn returns nil for
-    ;; streams that are output only, or for certain special purpose streams.
-    (if fd
-	(unwind-protect
-	    (progn
-	      (mp::mpwatchfor fd)
-	      (excl:if* timeout
-		 then (mp::process-wait-with-timeout
-		       whostate timeout wait-function stream-or-fd)
-		 else (mp::process-wait whostate wait-function stream-or-fd)
-		      t))
-	  (mp::mpunwatchfor fd))
-      (excl:if* timeout
-	 then (mp::process-wait-with-timeout
-	       whostate timeout wait-function stream-or-fd)
-	 else (mp::process-wait whostate wait-function stream-or-fd)
-	      t))))
+    (let ((end-index (+ start-index length)))
+      (loop
+	 (let ((next-index (excl:read-vector vector fd
+					     :start start-index
+					     :end end-index)))
+	   (excl:if* (eq next-index start-index)
+		     then			; end of file before was all filled up
+		     (return t)
+		     elseif (eq next-index end-index)
+		     then			; we're all done
+		     (return nil)
+		     else (setq start-index next-index)))))))
+
+
+(defun stream-read-bytes (stream vector start-index length)
+  ;; Read from the given stream fd into 'vector', which has element type card8.
+  ;; Start storing at index 'start-index' and read exactly 'length' bytes.
+  ;; Return t if an error or eof occurred, nil otherwise.
+  (declare (fixnum start-index length))
+  (declare (type (or null stream) stream))
+  (with-interrupt-checking-on
+    (let ((end-index (+ start-index length)))
+      (loop
+	 (let ((next-index (excl:read-vector vector stream
+					     :start start-index
+					     :end end-index)))
+	   (excl:if* (eq next-index start-index)
+		     then			; end of file before was all filled up
+		     (return t)
+		     elseif (eq next-index end-index)
+		     then			; we're all done
+		     (return nil)
+		     else (setq start-index next-index)))))))
diff --git a/src/clx/extensions/composite.lisp b/src/clx/extensions/composite.lisp
index b7580c79b0bebe7c7c1f003104c1449aa04063df..ce1cb5a9aa80a8ff16f331a5570246337dbb3772 100644
--- a/src/clx/extensions/composite.lisp
+++ b/src/clx/extensions/composite.lisp
@@ -20,33 +20,46 @@
 (in-package :xlib)
 
 (export '(composite-query-version
-	  composite-redirect-window
-	  composite-redirect-subwindows
-	  composite-unredirect-window
-	  composite-unredirect-subwindows
-	  composite-get-overlay-window
-	  
-	  ))
+          composite-redirect-window
+          composite-redirect-subwindows
+          composite-unredirect-window
+          composite-unredirect-subwindows
+          composite-get-overlay-window
+          composite-release-overlay-window))
+
 (define-extension "Composite")
 
-(defconstant +composite-major+    0)
-(defconstant +composite-minor+    4)
+(defconstant +composite-major+ 0
+  "Major version.")
+(defconstant +composite-minor+ 4
+  "Minor version.")
 
 
-(defconstant +redirect-automatic+		0)
-(defconstant +redirect-manual+			1)
+(defconstant +redirect-automatic+ 0
+  "The automatic update type automatically updates the parent window.")
+(defconstant +redirect-manual+ 1
+  "Prevents some activities that would otherwise be automatic.")
 
 ;; xrequests
 
-(defconstant  +composite-QueryVersion+			0)
-(defconstant  +composite-RedirectWindow+		1)
-(defconstant  +composite-RedirectSubwindows+		2)
-(defconstant  +composite-UnredirectWindow+		3)
-(defconstant  +composite-UnredirectSubwindows+		4)
-(defconstant  +composite-CreateRegionFromBorderClip+	5)
-(defconstant  +composite-NameWindowPixmap+		6)
-(defconstant  +composite-GetOverlayWindow+             7)
-(defconstant  +composite-ReleaseOverlayWindow+         8)
+(defconstant  +composite-QueryVersion+ 0
+  "Query for the version of composite.")
+(defconstant  +composite-RedirectWindow+ 1
+  "Store this hierarchy off-screen.")
+(defconstant  +composite-RedirectSubwindows+ 2
+  "Store only the sub-hierarchy.")
+(defconstant  +composite-UnredirectWindow+ 3
+  "Stop storing the window and subwindows.")
+(defconstant  +composite-UnredirectSubwindows+ 4
+  "Stop storing the sub-hierarchy.")
+(defconstant  +composite-CreateRegionFromBorderClip+ 5
+  "The region clinpped against the surrounding windows.")
+(defconstant  +composite-NameWindowPixmap+ 6
+  "The off-screen pixmap for the window.")
+(defconstant  +composite-GetOverlayWindow+ 7
+  "Get a surface to draw on.")
+(defconstant  +composite-ReleaseOverlayWindow+ 8
+  "Release the overlay surface.")
 
 
 (defmacro composite-opcode (display)
@@ -56,29 +69,26 @@
 
 (deftype update-type () '(card8))
 
-
-
 ;; x requests
 
 (defun composite-query-version (display)
-  ""
+  "Query for the version. All clients are expected to query!"
   (declare (type display display))
   (with-buffer-request-and-reply (display (composite-opcode display) nil :sizes (32))
-				 ((data +composite-QueryVersion+)
-				  (card32 +composite-major+)
-				  (card32 +composite-minor+))
+                                 ((data +composite-QueryVersion+)
+                                  (card32 +composite-major+)
+                                  (card32 +composite-minor+))
     (values
      (card32-get 8)
      (card32-get 12))))
 
-
-
 (defun composite-redirect-window (window update-type)
-  ""
+  "Store window and its children off-screen, using update-type for whether to
+sync those or not."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window)
-	     (type update-type update-type))  
+             (type window window)
+             (type update-type update-type))
     (with-buffer-request (display (composite-opcode display))
       (data +composite-redirectwindow+)
       (window window)
@@ -87,11 +97,12 @@
       (card16 0))))
 
 (defun composite-redirect-subwindows (window update-type)
-  ""
+  "Store the subwindows of the window (but not the window itself).
+update-type determines if syncing is allowed."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window)
-	     (type update-type update-type))  
+             (type window window)
+             (type update-type update-type))
     (with-buffer-request (display (composite-opcode display))
       (data +composite-redirectsubwindows+)
       (window window)
@@ -100,57 +111,57 @@
       (card16 0))))
 
 (defun composite-unredirect-window (window)
-  ""
+  "Terminates the redirection."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))  
+             (type window window))
     (with-buffer-request (display (composite-opcode display))
       (data +composite-unredirectwindow+)
       (window window))))
 
 (defun composite-unredirect-subwindows (window)
-  ""
+  "Terminates the redirection of the child hierarchies of window."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))  
+             (type window window))
     (with-buffer-request (display (composite-opcode display))
       (data +composite-unredirectsubwindows+)
       (window window))))
 
 (defun composite-create-region-from-border-clip (window region)
-  ""
+  "Region clipped on surrounding windows."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))
-    (with-buffer-request (display (composite-opcode display)) 
+             (type window window))
+    (with-buffer-request (display (composite-opcode display))
       (data +composite-createregionfromborderclip+)
       (card32 region)
       (window window))))
-	    
+
 (defun composite-name-window-pixmap (window drawable)
-  ""
+  "Refer to an off-screen pixmap for the window."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))
+             (type window window))
     (with-buffer-request (display (composite-opcode display))
       (data +composite-namewindowpixmap+)
       (window window)
       (drawable drawable))))
 
 (defun composite-get-overlay-window (window)
-  ""
+  "Take control of the window for composite use. A place to draw things without
+interference. Requires a compositing window manager to be running in order to
+use the overlay. Release it with COMPOSITE-RELEASE-OVERLAY-WINDOW."
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))
+             (type window window))
     (with-buffer-request-and-reply (display (composite-opcode display) nil :sizes (32))
-				   ((data +composite-getoverlaywindow+)
-				    (window window)
-				    )
-      (values
-       (card32-get 8)))))
+                                   ((data +composite-getoverlaywindow+)
+                                    (window window))
+      (values (card32-get 8)))))
 
 (defun composite-release-overlay-window (window)
-  ""
+  "Release a window which was controlled by COMPOSITE-GET-OVERLAY-WINDOW."
   (let ((display (window-display window)))
     (declare (type display display)
              (type window window))
diff --git a/src/clx/extensions/gl.lisp b/src/clx/extensions/gl.lisp
index 241c06609d2d20370ea469834789bc9a511388d9..d7d347036d7729e8861c30655d4ac0b3143736d0 100644
--- a/src/clx/extensions/gl.lisp
+++ b/src/clx/extensions/gl.lisp
@@ -2324,23 +2324,24 @@
 (defun byte-width-calculation (argspecs)
   (let ((constant 0)
         (calculated ()))
-    (loop
-       for (name type length length-var) in argspecs
-       do (let ((byte-width (byte-width type)))
-            (typecase length
-              (number (incf constant (* byte-width length)))
-              (symbol (push `(* ,byte-width ,length) calculated))
-              (cons  (push `(* ,byte-width ,length-var) calculated)))))
+    (loop for (nil type length length-var) in argspecs
+          ;;   ^ name
+          for byte-width = (byte-width type)
+          do (typecase length
+               (number (incf constant (* byte-width length)))
+               (symbol (push `(* ,byte-width ,length) calculated))
+               (cons  (push `(* ,byte-width ,length-var) calculated))))
     (if (null calculated)
         constant
         (list* '+ constant calculated))))
 
 
 (defun composite-args (argspecs)
-  (loop
-     for (name type length length-var) in argspecs
-     when (consp length)
-     collect (list length-var length)))
+  (loop for (nil nil length length-var) in argspecs
+        ;;       ^ type
+        ;;   ^ name
+        when (consp length)
+        collect (list length-var length)))
 
 
 (defun make-setter-forms (argspecs)
diff --git a/src/clx/extensions/randr.lisp b/src/clx/extensions/randr.lisp
index cb5a4b79f041c083c6a8478a47fd623e1464b077..28e8922dea558e1c02e62bc91c4b6db9d7b689ff 100644
--- a/src/clx/extensions/randr.lisp
+++ b/src/clx/extensions/randr.lisp
@@ -20,84 +20,84 @@
 (in-package :xlib)
 
 (export '(rr-query-version
-	  rr-get-screen-info
-	  rr-set-screen-config
-
- 	  ;;  1.2
-
-	  rr-get-screen-size-range
-	  rr-set-screen-size
-	  rr-get-screen-resources
-	  rr-get-output-info 
-	  rr-list-output-properties
-	  rr-query-output-property
-	  rr-configure-output-property
-	  rr-change-output-property
-	  rr-delete-output-property
-	  rr-get-output-property
-	  rr-create-mode
-	  rr-destroy-mode
-	  rr-add-output-mode
-	  rr-delete-output-mode
-	  rr-get-crtc-info
-	  rr-get-crtc-gamma-size
-	  rr-get-crtc-gamma
-	  rr-set-crtc-gamma
-
-	  ;;  1.3
-	  
-	  rr-get-screen-resources-current
-	  rr-set-crtc-transform
-	  rr-get-crtc-transform
-	  rr-get-panning
-	  rr-set-panning
-	  rr-set-output-primary
-	  rr-get-output-primary
-
-	  ;;  1.4
-	  
-	  rr-get-providers
-	  rr-get-provider-info
-	  rr-set-provider-output-source
-	  rr-set-provider-offload-sink
-	  rr-list-provider-properties
-	  rr-select-input
-
-	  ;; mask related
-	  make-mode-flag-keys
-	  make-mode-flag-mask
-	  make-rr-select-mask
-	  make-rr-select-keys
-	  make-rotation-keys
-	  make-rotation-mask
-
-	  ;; struct related
-	  rr-panning-top
-	  rr-panning-left
-	  rr-panning-width
-	  rr-panning-height
-	  rr-panning-track-top
-	  rr-panning-track-left
-	  rr-panning-track-width
-	  rr-panning-track-height
-	  rr-panning-border-left
-	  rr-panning-border-top
-	  rr-panning-border-bottom
-	  rr-panning-border-right
-	  rr-panning
-	  make-rr-transform
-	  ))
+          rr-get-screen-info
+          rr-set-screen-config
+
+          ;;  1.2
+
+          rr-get-screen-size-range
+          rr-set-screen-size
+          rr-get-screen-resources
+          rr-get-output-info
+          rr-list-output-properties
+          rr-query-output-property
+          rr-configure-output-property
+          rr-change-output-property
+          rr-delete-output-property
+          rr-get-output-property
+          rr-create-mode
+          rr-destroy-mode
+          rr-add-output-mode
+          rr-delete-output-mode
+          rr-get-crtc-info
+          rr-get-crtc-gamma-size
+          rr-get-crtc-gamma
+          rr-set-crtc-gamma
+
+          ;;  1.3
+
+          rr-get-screen-resources-current
+          rr-set-crtc-transform
+          rr-get-crtc-transform
+          rr-get-panning
+          rr-set-panning
+          rr-set-output-primary
+          rr-get-output-primary
+
+          ;;  1.4
+
+          rr-get-providers
+          rr-get-provider-info
+          rr-set-provider-output-source
+          rr-set-provider-offload-sink
+          rr-list-provider-properties
+          rr-select-input
+
+          ;; mask related
+          make-mode-flag-keys
+          make-mode-flag-mask
+          make-rr-select-mask
+          make-rr-select-keys
+          make-rotation-keys
+          make-rotation-mask
+
+          ;; struct related
+          rr-panning-top
+          rr-panning-left
+          rr-panning-width
+          rr-panning-height
+          rr-panning-track-top
+          rr-panning-track-left
+          rr-panning-track-width
+          rr-panning-track-height
+          rr-panning-border-left
+          rr-panning-border-top
+          rr-panning-border-bottom
+          rr-panning-border-right
+          rr-panning
+          make-rr-transform
+          ))
 
 (pushnew :clx-ext-randr *features*)
 
 (define-extension "RANDR"
   :events (:rr-screen-change-notify
-	   :rr-crtc-change-notify
-	   :rr-output-change-notify
-	   :rr-output-property-notify)
+           :rr-crtc-change-notify
+           :rr-output-change-notify
+           :rr-output-property-notify)
   :errors (output
-	   crtc
-	   mode))
+           crtc
+           mode))
 
 (defun randr-opcode (display)
   (extension-opcode display "RANDR"))
@@ -106,22 +106,22 @@
 (defconstant +rr-major+			1)
 (defconstant +rr-minor+			4)
 
-(defconstant  +rr-QueryVersion+         	0)
+(defconstant  +rr-QueryVersion+                 0)
   ;; we skip 1 to make old clients fail pretty immediately */
-  
 
-(defconstant  +rr-SetScreenConfig+	        2)
+
+(defconstant  +rr-SetScreenConfig+              2)
 (defconstant  +rr-OldScreenChangeSelectInput+	3) ;; 3 used to be ScreenChangeSelectInput; deprecated */
-  
-(defconstant  +rr-SelectInput+	        	4)
-(defconstant  +rr-GetScreenInfo+        	5)
+
+(defconstant  +rr-SelectInput+                  4)
+(defconstant  +rr-GetScreenInfo+                5)
 
   ;; * V1.2 additions */
-  
-(defconstant  +rr-GetScreenSizeRange+	        6)
-(defconstant  +rr-SetScreenSize+	        7)
-(defconstant  +rr-GetScreenResources+	        8)
-(defconstant  +rr-GetOutputInfo+	        9)
+
+(defconstant  +rr-GetScreenSizeRange+           6)
+(defconstant  +rr-SetScreenSize+                7)
+(defconstant  +rr-GetScreenResources+           8)
+(defconstant  +rr-GetOutputInfo+                9)
 (defconstant  +rr-ListOutputProperties+        10)
 (defconstant  +rr-QueryOutputProperty+	       11)
 (defconstant  +rr-ConfigureOutputProperty+     12)
@@ -139,7 +139,7 @@
 (defconstant  +rr-SetCrtcGamma+	    24)
 
   ;; /* V1.3 additions */
-  
+
 (defconstant  +rr-GetScreenResourcesCurrent+	25)
 (defconstant  +rr-SetCrtcTransform+	    26)
 (defconstant  +rr-GetCrtcTransform+	    27)
@@ -149,7 +149,7 @@
 (defconstant  +rr-GetOutputPrimary+	    31)
 
   ;; 1.4 additions
-  
+
 
 (defconstant  +rr-GetProviders+	      32)
 (defconstant  +rr-GetProviderInfo+	      33)
@@ -163,7 +163,7 @@
 (defconstant  +rr-GetProviderProperty+	      41)
 
 ;;; status returns
-  
+
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +rr-config-status+ '#(:success :invalid-config-time :invalid-time :failed))
@@ -172,7 +172,7 @@
 ;;; mask-vectors and types
 
   ;; Rotation
-  
+
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +rotation-mask-vector+
@@ -182,10 +182,10 @@
   '(member :rotate-0 :rotate-90 :rotate-180 :rotate-270 :reflect-x :reflect-y))
 
 (deftype rotation-mask ()
-  '(or mask16 (clx-list event-mask-class)))
+  '(or mask16 (clx-list rotation-mask-class)))
 
   ;; Select
-  
+
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +rr-select-mask-vector+
@@ -198,22 +198,22 @@
   '(or mask8 (clx-list rr-select-mask-class)))
 
   ;; Mode-flag
-  
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +mode-flag-mask-vector+
-    '#(:hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan :csync 
+    '#(:hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan :csync
        :csync-positive :csync-negative :hskew-present :b-cast :pixel-multiplex :double-clock :clock-divide-by-2)))
 
-(deftype mode-flag-mask-class () 
-  '(member :hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan 
-    :csync :csync-positive :csync-negative :hskew-present :b-cast :pixel-multiplex :double-clock 
+(deftype mode-flag-mask-class ()
+  '(member :hsync-positive :hsync-negative :vsync-positive :vsync-negative :interlace :double-scan
+    :csync :csync-positive :csync-negative :hskew-present :b-cast :pixel-multiplex :double-clock
     :clock-divide-by-2))
 
 (deftype mode-flag-mask ()
   '(or mask32 (clx-list mode-flag-mask-class)))
 
   ;; temporarily here since not in xrender.lisp
-  
+
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant +render-subpixel-order+
@@ -231,19 +231,19 @@
 
   ;; (defun make-rotation-mask (key-list)
   ;;   (encode-mask +rotation-mask-vector+ key-list ))
-  
+
 
 
 (defmacro define-mask-fns (name mask-size mask-vector mask-type)
   (let ((encode-fn (xintern 'make- name '-mask))
-	(decode-fn (xintern 'make- name '-keys))) 
+        (decode-fn (xintern 'make- name '-keys)))
     `(progn
        (defun ,encode-fn (key-list)
-	 (encode-mask ,mask-vector key-list ',mask-type))
+         (encode-mask ,mask-vector key-list ',mask-type))
        (defun ,decode-fn (bit-mask)
-	 (declare (type ,mask-size bit-mask))
-	 (declare (clx-values (clx-list ,mask-type)))
-	 (decode-mask ,mask-vector bit-mask))
+         (declare (type ,mask-size bit-mask))
+         (declare (clx-values (clx-list ,mask-type)))
+         (decode-mask ,mask-vector bit-mask))
        )))
 
 (define-mask-fns mode-flag card32 +mode-flag-mask-vector+ mode-flag-mask)
@@ -265,18 +265,18 @@
 ;; structs
 
 (def-clx-class (screen-size (:constructor make-screen-size (width-in-pixels
-							    height-in-pixels
-							    width-in-mm
-							    height-in-mm)))
+                                                            height-in-pixels
+                                                            width-in-mm
+                                                            height-in-mm)))
   (width-in-pixels 0 :type card16)
   (height-in-pixels 0 :type card16)
   (width-in-mm 0 :type card16)
   (height-in-mm 0 :type card16))
 
-(def-clx-class (rr-mode-info 
-		(:constructor make-rr-mode-info (id width height dot-clock
-						 h-sync-start h-sync-end h-sync-total h-sync-skew
-						 v-sync-start v-sync-end v-total name-length mode-flags)))
+(def-clx-class (rr-mode-info
+                (:constructor make-rr-mode-info (id width height dot-clock
+                                                 h-sync-start h-sync-end h-sync-total h-sync-skew
+                                                 v-sync-start v-sync-end v-total name-length mode-flags)))
   (id  0 :type card32)
   (width  0 :type card16)
   (height  0 :type card16)
@@ -297,7 +297,7 @@
   (top 0 :type card16)
   (width 0 :type card16)
   (height 0 :type card16)
-  (track-left 0 :type card16)  
+  (track-left 0 :type card16)
   (track-top 0 :type card16)
   (track-width 0 :type card16)
   (track-height 0 :type card16)
@@ -306,10 +306,10 @@
   (border-right 0 :type int16)
   (border-bottom 0 :type int16))
 
-(def-clx-class (rr-transform ( :type vector) :named )
-  (x  0 :type card32)
-  (y  0 :type card32)
-  (z  0 :type card32)
+(defstruct (rr-transform (:type vector) :named)
+  (x 0 :type card32)
+  (y 0 :type card32)
+  (z 0 :type card32)
   (i 0 :type card32)
   (j 0 :type card32)
   (k 0 :type card32)
@@ -322,59 +322,62 @@
 
 (define-accessor rr-transform (36)
   ((index) `(make-rr-transform :x (card32-get (index+ ,index 0))
-			       :y (card32-get (index+ ,index 4)) :z (card32-get (index+ ,index 8))
-			       :i (card32-get (index+ ,index 12)) :j (card32-get (index+ ,index 16))
-			       :k (card32-get (index+ ,index 20)) :d (card32-get (index+ ,index 24))
-			       :e (card32-get (index+ ,index 28)) :f (card32-get (index+ ,index 32))
-			       ))
+                               :y (card32-get (index+ ,index 4))
+                               :z (card32-get (index+ ,index 8))
+                               :i (card32-get (index+ ,index 12))
+                               :j (card32-get (index+ ,index 16))
+                               :k (card32-get (index+ ,index 20))
+                               :d (card32-get (index+ ,index 24))
+                               :e (card32-get (index+ ,index 28))
+                               :f (card32-get (index+ ,index 32))))
   ((index thing) `(sequence-put ,index ,thing :start 1)))
 
 ;; (define-accessor rr-panning (24)
 ;;   ((index) `(make-rr-panning :left (card16-get ,index)
-;; 			     :top (card16-get (index+ ,index 2))
-;; 			     :width (card16-get (index+ ,index 4))
-;; 			     :height (card16-get (index+ ,index 6))
-;; 			     :track-left (card16-get (index+ ,index 8))
-;; 			     :track-top (card16-get (index+ ,index 10))
-;; 			     :track-width (card16-get (index+ ,index 12))
-;; 			     :track-height (card16-get (index+ ,index 14))
-;; 			     :border-left (int16-get (index+ ,index 16))
-;; 			     :border-top (int16-get (index+ ,index 18))
-;; 			     :border-right (int16-get (index+ ,index 20))
-;; 			     :border-bottom (int16-get (index+ ,index 22))))
+;;                           :top (card16-get (index+ ,index 2))
+;;                           :width (card16-get (index+ ,index 4))
+;;                           :height (card16-get (index+ ,index 6))
+;;                           :track-left (card16-get (index+ ,index 8))
+;;                           :track-top (card16-get (index+ ,index 10))
+;;                           :track-width (card16-get (index+ ,index 12))
+;;                           :track-height (card16-get (index+ ,index 14))
+;;                           :border-left (int16-get (index+ ,index 16))
+;;                           :border-top (int16-get (index+ ,index 18))
+;;                           :border-right (int16-get (index+ ,index 20))
+;;                           :border-bottom (int16-get (index+ ,index 22))))
 ;;   ;; put doesn't work
-;;   ((index thing)  `(progn ,`(write-card16 (index+ ,index 0)(rr-panning-left ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 2)(rr-panning-top ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 4)(rr-panning-width ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 6)(rr-panning-height ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 8)(rr-panning-track-left ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 10)(rr-panning-track-top ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 12)(rr-panning-track-width ,thing)) 
-;; 			  , `(write-card16 (index+ ,index 14)(rr-panning-track-height ,thing)) 
-;; 			  , `(write-int16 (index+ ,index 16)(rr-panning-border-left ,thing)) 
-;; 			  , `(write-int16 (index+ ,index 18)(rr-panning-border-top ,thing)) 
-;; 			  , `(write-int16 (index+ ,index 20)(rr-panning-border-right ,thing)) 
-;; 			  , `(write-int16(index+ ,index 22)(rr-panning-border-bottom ,thing)))
-;; 		       ))
+;;   ((index thing)  `(progn ,`(write-card16 (index+ ,index 0)(rr-panning-left ,thing))
+;;                        , `(write-card16 (index+ ,index 2)(rr-panning-top ,thing))
+;;                        , `(write-card16 (index+ ,index 4)(rr-panning-width ,thing))
+;;                        , `(write-card16 (index+ ,index 6)(rr-panning-height ,thing))
+;;                        , `(write-card16 (index+ ,index 8)(rr-panning-track-left ,thing))
+;;                        , `(write-card16 (index+ ,index 10)(rr-panning-track-top ,thing))
+;;                        , `(write-card16 (index+ ,index 12)(rr-panning-track-width ,thing))
+;;                        , `(write-card16 (index+ ,index 14)(rr-panning-track-height ,thing))
+;;                        , `(write-int16 (index+ ,index 16)(rr-panning-border-left ,thing))
+;;                        , `(write-int16 (index+ ,index 18)(rr-panning-border-top ,thing))
+;;                        , `(write-int16 (index+ ,index 20)(rr-panning-border-right ,thing))
+;;                        , `(write-int16(index+ ,index 22)(rr-panning-border-bottom ,thing)))
+;;                     ))
 
 ;; (defmacro pan-put ())
 
 (define-accessor rr-mode-info (32)
   ((index)
-   `(make-rr-mode-info 
+   `(make-rr-mode-info
      (card32-get ,index)
      (card16-get (+ ,index 4))
      (card16-get (+ ,index 6))
      (card32-get (+ ,index 8))
      (card16-get (+ ,index 12))
      (card16-get (+ ,index 14))
-     (card16-get (+ ,index 16))					
+     (card16-get (+ ,index 16))
      (card16-get (+ ,index 18))
      (card16-get (+ ,index 20))
      (card16-get (+ ,index 22))
      (card16-get (+ ,index 24))
      (card16-get (+ ,index 26))
-     (card32-get (+ ,index 28)))) 
+     (card32-get (+ ,index 28))))
   ((index thing)
    `(progn (card32-put ,index (rr-mode-info-id ,thing))
      (card16-put (index+ ,index 4) (rr-mode-info-width ,thing))
@@ -432,37 +435,68 @@
   (boolean state)
   )
 
-;; x-requests
+;;; Helpers
 
+(declaim (ftype (function (card32 card32) (values boolean &optional))
+                rr-has-rates))
+(defun rr-has-rates (major minor)
+  (or (> major 1)
+      (and (= major 1) (>= minor 1))))
+
+;;; Requests
+
+(declaim (ftype (function (display) (values card32 card32 &optional))
+                rr-query-version))
 (defun rr-query-version (display)
-"Returns version MAJOR and MINOR from server."
-  (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (32))
-				 ((data +rr-QueryVersion+)
-				  (card32 +rr-major+)
-				  (card32 +rr-minor+))
+  "Execute the RRQueryVersion request and return its result as multiple
+values consisting of the server's major and minor protocol versions."
+  (with-buffer-request-and-reply (display (randr-opcode display) nil
+                                  :sizes (32))
+                                 ((data +rr-QueryVersion+)
+                                  (card32 +rr-major+)
+                                  (card32 +rr-minor+))
     (values
      (card32-get 8)
      (card32-get 12))))
 
+;; Unexported
+(declaim (ftype (function (display (or null card32) (or null card32))
+                          (values card32 card32 &optional))
+                rr-maybe-query-version))
+(defun rr-maybe-query-version (display major minor)
+  "Return MAJOR and MINOR as multiple values, substituting 0 for NIL,
+unless they are both NIL, in which case call RR-QUERY-VERSION and return
+its values.
+
+Some requests (e.g., RRGetScreenInfo) behave differently after a version
+query (only the first query has any effect on these requests).
+In order that the functions executing such requests be able to skip
+subsequent (redundant) queries, have them accept MAJOR and MINOR keyword
+arguments and call this function with those arguments instead of calling
+RR-QUERY-VERSION."
+  (if (or major minor)
+      (values (or major 0) (or minor 0))
+      (rr-query-version display)))
+
 (defun rr-set-screen-config (window timestamp conf-timestamp size-id rotation refresh)
   "Sets the current screen to which the given window belongs.  Timestamps are obtained from rr-get-screen-info.  Rotation can be a list of rotation keys or a rotation mask.  Returns timestamp, config timestamp, the root window of the screen and sub-pixel order."
   (let ((display (window-display window))
-	(rot-mask (if (consp rotation) 
-		      (make-rotation-mask rotation) 
-		      rotation)))
+        (rot-mask (if (consp rotation)
+                      (make-rotation-mask rotation)
+                      rotation)))
     (declare (type display display)
-	     (type window window)
-	     (type card16 size-id rot-mask refresh)
-	     (type card32 timestamp conf-timestamp))
+             (type window window)
+             (type card16 size-id rot-mask refresh)
+             (type card32 timestamp conf-timestamp))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (16 32))
-				   ((data +rr-SetScreenConfig+)
-				    (window window)
-				    (card32 timestamp)
-				    (card32 conf-timestamp)
-				    (card16 size-id)
-				    (card16 rot-mask)
-				    (card16 refresh)
-				    (pad16))
+                                   ((data +rr-SetScreenConfig+)
+                                    (window window)
+                                    (card32 timestamp)
+                                    (card32 conf-timestamp)
+                                    (card16 size-id)
+                                    (card16 rot-mask)
+                                    (card16 refresh)
+                                    (pad16))
       (values
        (member8-vector-get 1 +rr-config-status+)
        (card32-get 8)  ;; timestamp
@@ -474,54 +508,111 @@
 (defun rr-select-input (window enable)
 "Enables event reception for given window.  Enable may be a select-mask or list of select-keys "
   (let ((display (window-display window))
-	(select-mask (if (consp enable) (make-rr-select-mask enable) enable)))
+        (select-mask (if (consp enable) (make-rr-select-mask enable) enable)))
     (declare (type display display)
-	     (type window window)
-	     (type card16 select-mask))
+             (type window window)
+             (type card16 select-mask))
     (with-buffer-request (display (randr-opcode display))
       (data +rr-selectinput+)
       (window window)
       (card16 select-mask)
       (pad16))))
 
-(defun rr-get-screen-info (window &optional (result-type 'list))
-"Returns rotations, root-window, timestamp, config-timestamp, current-size-id, current rotation, current rate, a list of screen-size structures, and last a sequence of refresh-rates"
+(declaim (ftype (function (window &key
+                                  (:major (or null card32))
+                                  (:minor (or null card32))
+                                  (:result-type t))
+                          (values (clx-list rotation-mask-class)
+                                  window
+                                  timestamp
+                                  timestamp
+                                  size-id
+                                  (clx-list rotation-mask-class)
+                                  (clx-list screen-size)
+                                  (or null card16)
+                                  (clx-sequence card16)
+                                  &optional))
+                rr-get-screen-info))
+(defun rr-get-screen-info (window &key major minor (result-type 'list))
+  "Execute the RRGetScreenInfo request and return its result as multiple
+values consisting of:
+
+1. List of possible rotations and reflections
+2. Root window
+3. Timestamp
+4. Configuration timestamp
+5. Current screen size index (in the list of possible screen sizes)
+6. Current rotation and reflection
+7. List of possible screen sizes
+8. Current refresh rate (non-NIL only if server's protocol version is
+   1.1 or later)
+9. Sequence of refresh rate information (non-NIL only if server's
+   protocol version is 1.1 or later)
+
+Each screen size has in the refresh rate information sequence a
+corresponding refresh rate count followed by that number of possible
+refresh rates.
+For example, '(2 120 60 1 60) means that the first screen size has the
+two refresh rates 120 and 60, and that the second screen size has the
+single refresh rate 60.
+
+If MAJOR and MINOR, which comprise the server's protocol version, are
+missing, this function executes the RRQueryVersion request before
+RRGetScreenInfo in order to, first, potentially ask the server to
+include, if it can, the current refresh rate and the refresh rate
+information sequence in its reply to the latter request, and second,
+determine whether this information is forthcoming.
+Otherwise, this function assumes MAJOR and MINOR are the result of
+RR-QUERY-VERSION -- failing which it will behave unreliably -- and it
+skips executing the RRQueryVersion request."
   (let ((display (window-display window)))
-    (declare (type display display)
-	     (type window window))
-    (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-GetScreenInfo+ )
-				    (window window))
-      (let ((num-screens (card16-get 20))
-	      (num-rates (card16-get 28))
-	    (rates-location 0))
-	(declare (type fixnum rates-location num-rates))
-	  (values
-	   (make-rotation-keys (card16-get 1)) ; possible rotations, using card16, not card8 from spec.
-	   (window-get 8) ;root window
-	   (card32-get 12) ;timestamp
-	   (card32-get 16) ;config-timestamp
-	   (card16-get 22) ;size-id
-	   (make-rotation-keys (card16-get 24)) ;current rotation
-	   (card16-get 26) ; current rate
-	   (loop :for x fixnum :from 1 :to num-screens
-		 :for offset fixnum := 32 :then (+ offset 8)
-		 :collect (make-screen-size (card16-get offset)
-					    (card16-get (index+ offset 2))
-					    (card16-get (index+ offset 4))
-					    (card16-get (index+ offset 6)))
-		 :finally (setf rates-location (+ offset 8 2)))
-	   (sequence-get :format card16 :length num-rates :index rates-location :result-type result-type))))))
-
+    (declare (type display display))
+    (multiple-value-bind (major minor)
+        (rr-maybe-query-version display major minor)
+      (with-buffer-request-and-reply (display (randr-opcode display) nil
+                                      :sizes (8 16 32))
+                                     ((data +rr-GetScreenInfo+)
+                                      (window window))
+        (let* ((num-screens (card16-get 20))
+               (rate-info-length (card16-get 28))
+               (screen-start +replysize+)
+               (rate-info-start (index+ screen-start (index* num-screens 8)))
+               (has-rates (rr-has-rates major minor)))
+          (values
+           ;; Possible rotations and reflections
+           (make-rotation-keys (card16-get 1))
+           (window-get 8)               ; Root window
+           (card32-get 12)              ; Timestamp
+           (card32-get 16)              ; Configuration timestamp
+           (card16-get 22)              ; Current screen size index
+           ;; Current rotation and reflection
+           (make-rotation-keys (card16-get 24))
+           (loop for i fixnum from 1 to num-screens
+                 for offset fixnum = screen-start then (+ offset 8)
+                 collect (make-screen-size (card16-get offset)
+                                           (card16-get (index+ offset 2))
+                                           (card16-get (index+ offset 4))
+                                           (card16-get (index+ offset 6))))
+           ;; Some servers (e.g., X.Org) always reply with the current
+           ;; refresh rate if they support it, even before receiving any
+           ;; version query.
+           ;; However, the refresh rate information is available only
+           ;; after querying the version (when providing an appropriate
+           ;; client version).
+           (when has-rates (card16-get 26)) ; Current refresh rate
+           (when has-rates (sequence-get :result-type result-type
+                                         :format card16
+                                         :length rate-info-length
+                                         :index rate-info-start))))))))
 
 ;; Version 1.2
 
-(defun rr-get-screen-size-range (window &optional (result-type 'list))
+(defun rr-get-screen-size-range (window &key (result-type 'list))
 "Returns a sequence of minimum width, minimum height, max width, max height."
   (let ((display (window-display window)))
    (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (16))
-				  ((data +rr-getscreensizerange+)
-				   (window window))
+                                  ((data +rr-getscreensizerange+)
+                                   (window window))
      (values
       (sequence-get :format card16 :length 4 :index 8 :result-type result-type)))))
 
@@ -532,9 +623,9 @@
   ""
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window)
-	     (type card16 width height)
-	     (type card32 width-mm height-mm))
+             (type window window)
+             (type card16 width height)
+             (type card32 width-mm height-mm))
     (with-buffer-request (display (randr-opcode display))
       (data +rr-setscreensize+)
       (window window)
@@ -543,97 +634,97 @@
       (card32 width-mm)
       (card32 height-mm))))
 
-(defun rr-get-screen-resources (window &optional (result-type 'list))
+(defun rr-get-screen-resources (window &key (result-type 'list))
   ""
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window))
+             (type window window))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-getscreenresources+)
-				    (window window))
-      (let* ((num-crtcs (card16-get 16))	     
-	     (num-outputs (card16-get 18))
-	     (output-start (index+ +replysize+ (index* num-crtcs 4)))	     
-	     (num-modeinfos (card16-get 20))
-	     (name-bytes (card16-get 22))
-	     (mode-start (index+ output-start (index* num-outputs 4)))
-	     (name-start (index+ mode-start (index* num-modeinfos 32))))
-	(values
-	 (card32-get 8)			; timestamp
-	 (card32-get 12)		; config-timestamp
-	 (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs)
-	 (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs)
-	 (loop :for i fixnum :from 1 :to num-modeinfos
-	       :for offset fixnum := mode-start :then (+ offset 32)
-	       :collect (rr-mode-info-get offset))
-	 (string-get name-bytes name-start))
-	))))
-
-
-
-(defun rr-get-output-info (display output config-timestamp &optional (result-type 'list))
+                                   ((data +rr-getscreenresources+)
+                                    (window window))
+      (let* ((num-crtcs (card16-get 16))
+             (num-outputs (card16-get 18))
+             (output-start (index+ +replysize+ (index* num-crtcs 4)))
+             (num-modeinfos (card16-get 20))
+             (name-bytes (card16-get 22))
+             (mode-start (index+ output-start (index* num-outputs 4)))
+             (name-start (index+ mode-start (index* num-modeinfos 32))))
+        (values
+         (card32-get 8)			; timestamp
+         (card32-get 12)		; config-timestamp
+         (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs)
+         (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs)
+         (loop :for i fixnum :from 1 :to num-modeinfos
+               :for offset fixnum := mode-start :then (+ offset 32)
+               :collect (rr-mode-info-get offset))
+         (string-get name-bytes name-start))
+        ))))
+
+
+
+(defun rr-get-output-info (display output config-timestamp &key (result-type 'list))
 "FIXME: indexes might be off, name not decoded properly"
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-getoutputinfo+)
-				  (card32 output)
-				  (card32 config-timestamp))
+                                 ((data +rr-getoutputinfo+)
+                                  (card32 output)
+                                  (card32 config-timestamp))
     (let* ((num-crtcs (card16-get 26))
-	  (num-modes (card16-get 28))
-	  (num-clones (card16-get 32))
-	  (name-length (card16-get 34))
-	  (crtc-start 26)
-	  (mode-start (index+ crtc-start (index* num-crtcs 4)))
-	  (clone-start (index+ mode-start (index* num-modes 4)))
-	  (name-start (index+ clone-start (index* num-clones 4))))
+          (num-modes (card16-get 28))
+          (num-clones (card16-get 32))
+          (name-length (card16-get 34))
+          (crtc-start 26)
+          (mode-start (index+ crtc-start (index* num-crtcs 4)))
+          (clone-start (index+ mode-start (index* num-modes 4)))
+          (name-start (index+ clone-start (index* num-clones 4))))
       (values
-	(member8-vector-get 1 +rr-config-status+)
-	(card32-get 8)  ; timestamp
-	(card32-get 12) ; current connected crtc
-	(card32-get 16) ; width in mm
-	(card32-get 20) ; height in mm
-	(member8-vector-get 24 +rr-connection+)
-	(member8-vector-get 25 +render-subpixel-order+)  ; sub-pixel-order
-	(sequence-get :result-type result-type :length num-crtcs :index 26)
-	(card16-get 30)
-	(sequence-get :result-type result-type :length num-modes :index mode-start)
-	(sequence-get :result-type result-type :length num-clones :index clone-start)
-	;(string-get name-length name-start )
-	(sequence-get :result-type 'string :format card16 :length name-length :index name-start :transform #'code-char)) 
+        (member8-vector-get 1 +rr-config-status+)
+        (card32-get 8)  ; timestamp
+        (card32-get 12) ; current connected crtc
+        (card32-get 16) ; width in mm
+        (card32-get 20) ; height in mm
+        (member8-vector-get 24 +rr-connection+)
+        (member8-vector-get 25 +render-subpixel-order+)  ; sub-pixel-order
+        (sequence-get :result-type result-type :length num-crtcs :index 26)
+        (card16-get 30)
+        (sequence-get :result-type result-type :length num-modes :index mode-start)
+        (sequence-get :result-type result-type :length num-clones :index clone-start)
+        ;(string-get name-length name-start )
+        (sequence-get :result-type 'string :format card16 :length name-length :index name-start :transform #'code-char))
 )))
 
-(defun rr-list-output-properties (display output &optional (result-type 'list))
+(defun rr-list-output-properties (display output &key (result-type 'list))
 "Returns a list of atom properties for given display. ?keep it simple and return id's or atom-names?"
-  (declare (type display display) 
-	   (type card32 output))
+  (declare (type display display)
+           (type card32 output))
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-listoutputproperties+)
-				  (card32 output))
+                                 ((data +rr-listoutputproperties+)
+                                  (card32 output))
     (let ((num-atoms (card16-get 8)))
       (values
        (sequence-get :format card32 :result-type result-type :length num-atoms :index +replysize+ :transform #'(lambda (id) (atom-name display id)))))))
 
-(defun rr-query-output-property (display output atom &optional (result-type 'list))
+(defun rr-query-output-property (display output atom &key (result-type 'list))
 "Querys the current properties of an atom.  Atom may be referenced by either id or keyword"
   (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom)))
     (declare (type display display)
-	     (type card32 atom))
+             (type card32 atom))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-queryoutputproperty+)
-				    (card32 output)
-				    (card32 atom))
+                                   ((data +rr-queryoutputproperty+)
+                                    (card32 output)
+                                    (card32 atom))
       (values
        (boolean-get 8)  ; pending
        (boolean-get 9)  ; range
        (boolean-get 10) ; immutable
        (sequence-get :result-type result-type :index +replysize+ :length (card32-get 4))))))
 
-(defun rr-configure-output-property (display output atom value-list &optional (pending nil) (range nil))
+(defun rr-configure-output-property (display output atom value-list &key pending range)
   "Atom can be specified by either id or keyword"
   (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom))
-	(seq (coerce value-list 'vector)))
+        (seq (coerce value-list 'vector)))
     (declare (type display display)
-	     (type card32 output value-list)
-	     (type boolean pending range))
+             (type card32 output value-list)
+             (type boolean pending range))
     (with-buffer-request (display (randr-opcode display))
       (data +rr-configureoutputproperty+)
       (card32 output)
@@ -644,18 +735,18 @@
 ;; Spec says type is not interpreted, what use?  shit, are certain property types tied to certain formats?  change if necessary after get-output-property
 
 ;; FIXME asynchronous match error
-(defun rr-change-output-property (display output atom mode data &optional  (atom-type 0) )
+(defun rr-change-output-property (display output atom mode data &key (atom-type 0))
 "Mode may be 0-replace 1-prepend 2-append. atom-type is obtained by calling rr-get-output-property "
   (let ((atom (if (typep atom 'keyword) (find-atom display atom) atom))
-	(data-length (length data))
-	(seq (coerce data 'vector))
-	)
+        (data-length (length data))
+        (seq (coerce data 'vector))
+        )
     (with-buffer-request (display (randr-opcode display))
       (data +rr-changeoutputproperty+)
       (card32 output)
       (card32 atom)
       (card32 atom-type)
-      (card8 32) ; should we be concerned about extra bytes for small values?		
+      (card8 32) ; should we be concerned about extra bytes for small values?
       (card8 mode)
       (pad16)
       (card32 data-length)
@@ -669,38 +760,38 @@
       (card32 output)
       (card32 atom))))
 
-(defun rr-get-output-property (display output property  &optional (type 0) (delete 0) (pending 0) (result-type 'list))
+(defun rr-get-output-property (display output property &key (type 0) (delete 0) (pending 0) (result-type 'list))
   ""
   (let ((atom (if (typep property 'keyword) (find-atom display property) property)))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-getoutputproperty+)
-				    (card32 output)
-				    (card32 atom)
-				    (card32 type)
-				    (card32 0) ; long-offset
-				    (card32 0) ; long-length
-				    (card8 delete)
-				    (card8 pending)
-				    (pad16))
+                                   ((data +rr-getoutputproperty+)
+                                    (card32 output)
+                                    (card32 atom)
+                                    (card32 type)
+                                    (card32 0) ; long-offset
+                                    (card32 0) ; long-length
+                                    (card8 delete)
+                                    (card8 pending)
+                                    (pad16))
       (let* ((bytes-after (card32-get 12))
-	     (value-length (card32-get 16))
-	     (byte-format (unless (eql value-length 0) 
-			    (if (eql bytes-after value-length)
-				'card8
-				(if (eql 2 (/ bytes-after value-length))
-				    'card16
-				    'card32)))))
-	
-	(values
-	 (card32-get 8)			; type
-	 value-length
-	 (when (not (eql value-length 0)) 
-	   (case byte-format 
-	     (card8 (sequence-get :format card8 :index +replysize+
+             (value-length (card32-get 16))
+             (byte-format (unless (eql value-length 0)
+                            (if (eql bytes-after value-length)
+                                'card8
+                                (if (eql 2 (/ bytes-after value-length))
+                                    'card16
+                                    'card32)))))
+
+        (values
+         (card32-get 8)			; type
+         value-length
+         (when (not (eql value-length 0))
+           (case byte-format
+             (card8 (sequence-get :format card8 :index +replysize+
                                   :length value-length :result-type result-type))
-	     (card16 (sequence-get :format card16 :index +replysize+
+             (card16 (sequence-get :format card16 :index +replysize+
                                    :length value-length :result-type result-type))
-	     (card32 (sequence-get :format card32 :index +replysize+
+             (card32 (sequence-get :format card32 :index +replysize+
                                    :length value-length :result-type result-type)))))))))
 
 
@@ -709,14 +800,14 @@
   "FIXME"
   (let ((display (window-display window)))
     (declare (type display display)
-	     (type window window)
-	     (type rr-mode-info mode-info)
-	     (type string name))
+             (type window window)
+             (type rr-mode-info mode-info)
+             (type string name))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-createmode+)
-				    (window window)
-				    (progn (rr-mode-info-put 8 mode-info)
-					   (string-put 40 name)))
+                                   ((data +rr-createmode+)
+                                    (window window)
+                                    (progn (rr-mode-info-put 8 mode-info)
+                                           (string-put 40 name)))
       (values
        (card32-get 8) ; mode
        ))))
@@ -741,15 +832,15 @@
    (card32 output)
    (card32 mode)))
 
-(defun rr-get-crtc-info (display crtc config-timestamp &optional (result-type 'list))
+(defun rr-get-crtc-info (display crtc config-timestamp &key (result-type 'list))
   ""
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-getcrtcinfo+)
-				  (card32 crtc)
-				  (card32 config-timestamp))
+                                 ((data +rr-getcrtcinfo+)
+                                  (card32 crtc)
+                                  (card32 config-timestamp))
     (let* ((num-outputs (card16-get 28))
-	   (pos-outputs (card16-get 30))
-	   (pos-start (index+ +replysize+ (index* num-outputs 4))))
+           (pos-outputs (card16-get 30))
+           (pos-start (index+ +replysize+ (index* num-outputs 4))))
       (values
        (member8-vector-get 1 +rr-config-status+)
        (card32-get 8)                                   ; timestamp
@@ -766,18 +857,18 @@
 (defun rr-set-crtc-config (display crtc timestamp config-timestamp x y mode rotation output-list)
 "Rotation can be a rotation mask or list of rotation keys."
   (let ((rot-mask (if (consp rotation) (make-rotation-mask rotation) rotation))
-	(seq (coerce output-list 'vector)))
+        (seq (coerce output-list 'vector)))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-setcrtcconfig+)
-				    (card32 crtc)
-				    (card32 timestamp)
-				    (card32 config-timestamp)
-				    (card16 x)
-				    (card16 y)
-				    (card32 mode)
-				    (card16 rot-mask)
-				    (pad16)
-				    ((sequence :format card32) seq))
+                                   ((data +rr-setcrtcconfig+)
+                                    (card32 crtc)
+                                    (card32 timestamp)
+                                    (card32 config-timestamp)
+                                    (card16 x)
+                                    (card16 y)
+                                    (card32 mode)
+                                    (card16 rot-mask)
+                                    (pad16)
+                                    ((sequence :format card32) seq))
       (values
        (member8-vector-get 1 +rr-config-status+)
        (card32-get 8) ; new timestamp
@@ -786,19 +877,19 @@
 (defun rr-get-crtc-gamma-size (display crtc)
 "Used to determine length of gamma ramps to submit in set-crtc-gamma"
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-getcrtcgammasize+)
-				  (card32 crtc))
+                                 ((data +rr-getcrtcgammasize+)
+                                  (card32 crtc))
     (values
      (card16-get 8))))
 
-(defun rr-get-crtc-gamma (display crtc &optional (result-type 'list))
+(defun rr-get-crtc-gamma (display crtc &key (result-type 'list))
   "Get current gamma ramps, returns 3 sequences for red, green, blue."
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-getcrtcgamma+)
-				  (card32 crtc))
+                                 ((data +rr-getcrtcgamma+)
+                                  (card32 crtc))
     (let* ((size (card16-get 8))
-	  (green-start (index+ +replysize+ (index* 2 size)))
-	  (blue-start (index+ green-start (index* 2 size)))) 
+          (green-start (index+ +replysize+ (index* 2 size)))
+          (blue-start (index+ green-start (index* 2 size))))
       (values
        (sequence-get :format card16 :length size :index +replysize+ :result-type result-type)
        (sequence-get :format card16 :length size :index green-start :result-type result-type)
@@ -808,53 +899,53 @@
   "gamma values must be lists and must be the same length as returned by get-crtc-gamma-size"
   (declare (type cons red green blue))
   (let ((size (length blue))
-	(seq (coerce (append red green blue) 'vector)))
+        (seq (coerce (append red green blue) 'vector)))
     (declare (type vector seq)
-	     (type display display)
-	     (type card16 size))
+             (type display display)
+             (type card16 size))
     (with-buffer-request (display (randr-opcode display))
       (data +rr-setcrtcgamma+)
       (card32 crtc)
       (card16 size)
-      (pad16)     
+      (pad16)
       ((sequence :format card16) seq))))
 
 ;; version 1.3
 
 
- (defun rr-get-screen-resources-current (window &optional (result-type 'list ))
+ (defun rr-get-screen-resources-current (window &key (result-type 'list))
    "Unlike RRGetScreenResources, this merely returns the current configuration, and does not poll for hardware changes."
    (let ((display (window-display window)))
      (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				    ((data +rr-getscreenresourcescurrent+)
-				     (window window))
-       (let* ((num-crtcs (card16-get 16))	     
-	     (num-outputs (card16-get 18))
-	     (output-start (index+ +replysize+ (index* num-crtcs 4)))	     
-	     (num-modeinfos (card16-get 20))
-	     (name-bytes (card16-get 22))
-	     (mode-start (index+ output-start (index* num-outputs 4)))
-	     (name-start (index+ mode-start (index* num-modeinfos 32))))
-	(values
-	 (card32-get 8)			; timestamp
-	 (card32-get 12)		; config-timestamp
-	 (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs)
-	 (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs)
-	 (loop :for i fixnum :from 1 :to num-modeinfos
-	       :for offset fixnum := mode-start :then (+ offset 32)
-	       :collect (rr-mode-info-get offset))
-	 (string-get name-bytes name-start))))))
-
-
-;; (defun rr-set-crtc-transform (display crtc transform &optional ( filter-name nil) ( filter-parameters nil))
+                                    ((data +rr-getscreenresourcescurrent+)
+                                     (window window))
+       (let* ((num-crtcs (card16-get 16))
+             (num-outputs (card16-get 18))
+             (output-start (index+ +replysize+ (index* num-crtcs 4)))
+             (num-modeinfos (card16-get 20))
+             (name-bytes (card16-get 22))
+             (mode-start (index+ output-start (index* num-outputs 4)))
+             (name-start (index+ mode-start (index* num-modeinfos 32))))
+        (values
+         (card32-get 8)			; timestamp
+         (card32-get 12)		; config-timestamp
+         (sequence-get :format card32 :result-type result-type :index 32 :length num-crtcs)
+         (sequence-get :format card32 :result-type result-type :index output-start :length num-outputs)
+         (loop :for i fixnum :from 1 :to num-modeinfos
+               :for offset fixnum := mode-start :then (+ offset 32)
+               :collect (rr-mode-info-get offset))
+         (string-get name-bytes name-start))))))
+
+
+;; (defun rr-set-crtc-transform (display crtc transform &key filter-name filter-parameters)
 ;;   "FIXME:Transfrom may be a list or vector of length 9.  ?perhaps allow length 6?"
 ;;   (let ((seq (if filter-parameters (coerce filter-parameters 'vector) nil ))
-;; 	(param-length (length filter-parameters))
-;; 	(name-length (length filter-name)))
+;;      (param-length (length filter-parameters))
+;;      (name-length (length filter-name)))
 ;;     (declare ;(type vector seq)
-;; 	     (type card16 param-length)
-;; 	     (type display display)
-;; 	     (type string filter-name))
+;;           (type card16 param-length)
+;;           (type display display)
+;;           (type string filter-name))
 ;;     (with-buffer-request (display (randr-opcode display))
 ;;       (data +rr-setcrtctransform+)
 ;;       (card32 crtc)
@@ -865,27 +956,27 @@
 ;;       (pad16)
 ;;       (string filter-name)
 ;; ;      ((sequence :format card32) seq)
-		     
-      
+
+
 ;;       ;((sequence :format card32) seq)
 ;;       )))
 
 
-(defun rr-get-crtc-transform (display crtc &optional (result-type 'list))
+(defun rr-get-crtc-transform (display crtc &key (result-type 'list))
   ""
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-  				 ((data +rr-getcrtctransform+)
-				  (card32 crtc))
+                                 ((data +rr-getcrtctransform+)
+                                  (card32 crtc))
     (let* ((pend-name        (card16-get 88))
-	   (pend-num-params (card16-get 90))
-	   (pad-pend (- 4 (mod pend-name 4)))
-	   (pad-pend-start (index+ 96 pend-name pad-pend))
-	   (cur-name         (card16-get 92))
-	   (cur-num-params   (card16-get 94))
-	   (pad-cur (- 4 (mod cur-name 4)))
-	   (cur-name-start (index+ pad-pend-start (index* 4 pend-num-params)))
-	   (cur-param-start (index+ cur-name-start cur-name pad-cur))
-	   )
+           (pend-num-params (card16-get 90))
+           (pad-pend (- 4 (mod pend-name 4)))
+           (pad-pend-start (index+ 96 pend-name pad-pend))
+           (cur-name         (card16-get 92))
+           (cur-num-params   (card16-get 94))
+           (pad-cur (- 4 (mod cur-name 4)))
+           (cur-name-start (index+ pad-pend-start (index* 4 pend-num-params)))
+           (cur-param-start (index+ cur-name-start cur-name pad-cur))
+           )
       (declare (type card16 pend-name cur-name))
       (values
        (rr-transform-get 8)
@@ -902,13 +993,13 @@
 ;; (defun rr-get-panning (display crtc)
 ;;   ""
 ;;   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-;;   				 ((data +rr-getpanning+)
-;; 				  (card32 crtc))
+;;                               ((data +rr-getpanning+)
+;;                                (card32 crtc))
 ;;     (values
 ;;      (member8-vector-get 1 +rr-config-status+)
 ;;      (card32-get 8) ; timestamp
 ;;      (rr-panning-get 12)
-;; 					;(sequence-get :length 8 :format card16 :index 12 :result-type result-type)
+;;                                      ;(sequence-get :length 8 :format card16 :index 12 :result-type result-type)
 ;;      ;(sequence-get :length 4 :format int16 :index 28 :result-type result-type)
 ;;      )))
 
@@ -918,15 +1009,15 @@
 ;;   ""
 ;;   (declare (type rr-panning rr-panning))
 ;;   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-;;   				 ((data +rr-setpanning+)
-;; 				  (card32 crtc)
-;; 				  (card32 timestamp)
-;; 				 ;				  (progn ()
-;; 				  (rr-panning rr-panning))
-    
+;;                               ((data +rr-setpanning+)
+;;                                (card32 crtc)
+;;                                (card32 timestamp)
+;;                               ;				  (progn ()
+;;                                (rr-panning rr-panning))
+
 ;;     (values
 ;;      (member8-vector-get 1 +rr-config-status+)
-;; 					;  (card32-get 8) ; new timestamp
+;;                                      ;  (card32-get 8) ; new timestamp
 ;;      )))
 
 (defun rr-set-output-primary (window output)
@@ -941,8 +1032,8 @@
   ""
   (let ((display (window-display window)))
     (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				   ((data +rr-getoutputprimary+)
-				    (window window))
+                                   ((data +rr-getoutputprimary+)
+                                    (window window))
       (values
        (card32-get 8)
        ))))
@@ -954,21 +1045,21 @@
 ""
   (let ((display (window-display window)))
       (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				     ((data +rr-getproviders+)
-				      (window window))
-	(values
-	 (card32-get 8)  ; timestamp	 
-	 (card16-get 12) ; num providers  
-	; (string-get 1256 14) ; checking if this is supposed to return anything besides just num
-	; (sequence-get :index 46 :length (card16-get 12) :format card8 :result-type 'list )
-	 ))))
+                                     ((data +rr-getproviders+)
+                                      (window window))
+        (values
+         (card32-get 8)  ; timestamp
+         (card16-get 12) ; num providers
+        ; (string-get 1256 14) ; checking if this is supposed to return anything besides just num
+        ; (sequence-get :index 46 :length (card16-get 12) :format card8 :result-type 'list )
+         ))))
 
 (defun rr-get-provider-info (display provider config-timestamp)
 ""
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-getproviderinfo+)
-				  (card32 provider)
-				  (card32 config-timestamp))
+                                 ((data +rr-getproviderinfo+)
+                                  (card32 provider)
+                                  (card32 config-timestamp))
     (values
      (card32-get 8)  ;timestamp
      (card32-get 12) ; capabilities
@@ -996,8 +1087,8 @@
 (defun rr-list-provider-properties (display provider)
 ""
   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-				 ((data +rr-listproviderproperties+)
-				  (card32 provider))
+                                 ((data +rr-listproviderproperties+)
+                                  (card32 provider))
     (values
      (card32-get 4)
      (card16-get 8))))
@@ -1006,9 +1097,9 @@
 ;; (defun rr-query-provider-property (display provider atom)
 ;; "untested"
 ;;   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-;; 				 ((data +rr-queryproviderproperty+)
-;; 				  (card32 provider)
-;; 				  (card32 atom))
+;;                               ((data +rr-queryproviderproperty+)
+;;                                (card32 provider)
+;;                                (card32 atom))
 ;;     (values
 ;;      (boolean-get 8)
 ;;      (boolean-get 9)
@@ -1017,14 +1108,13 @@
 ;; (defun  (display)
 ;; ""
 ;;   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-;; 				 ((data))
+;;                               ((data))
 ;;     (values
 ;;      ())))
 
 ;; (defun  (display)
 ;; ""
 ;;   (with-buffer-request-and-reply (display (randr-opcode display) nil :sizes (8 16 32))
-;; 				 ((data))
+;;                               ((data))
 ;;     (values
 ;;      ())))
-
diff --git a/src/clx/extensions/xrender.lisp b/src/clx/extensions/xrender.lisp
index d552f6559c4dfce5dba03af4a33530580dcf653e..6d6b01d6eb060bc58f57237091de4ec8910336b9 100644
--- a/src/clx/extensions/xrender.lisp
+++ b/src/clx/extensions/xrender.lisp
@@ -117,6 +117,8 @@
 
           find-matching-picture-formats
           find-window-picture-format
+          find-standard-picture-format
+
           render-free-picture
           render-free-glyph-set
           render-query-version
@@ -378,6 +380,55 @@ by every function, which attempts to generate RENDER requests."
               (display-render-info display)))
     res))
 
+(defun find-standard-picture-format (display format)
+  (ensure-render-initialized display)
+  (maphash (ecase format
+             (:argb32
+              (lambda (k f)
+                (declare (ignore k))
+                (when (and (= (picture-format-depth f) 32)
+                           (= (byte-size (picture-format-alpha-byte f)) 8)
+                           (= (byte-size (picture-format-red-byte f)) 8)
+                           (= (byte-size (picture-format-green-byte f)) 8)
+                           (= (byte-size (picture-format-blue-byte f)) 8)
+                           (= (byte-position (picture-format-alpha-byte f)) 24)
+                           (= (byte-position (picture-format-red-byte f)) 16)
+                           (= (byte-position (picture-format-green-byte f)) 8)
+                           (= (byte-position (picture-format-blue-byte f)) 0))
+                  (return-from find-standard-picture-format f))))
+             (:rgb24
+              (lambda (k f)
+                (declare (ignore k))
+                (when (and (= (picture-format-depth f) 24)
+                           (= (byte-size (picture-format-red-byte f)) 8)
+                           (= (byte-size (picture-format-green-byte f)) 8)
+                           (= (byte-size (picture-format-blue-byte f)) 8)
+                           (= (byte-position (picture-format-red-byte f)) 16)
+                           (= (byte-position (picture-format-green-byte f)) 8)
+                           (= (byte-position (picture-format-blue-byte f)) 0))
+                  (return-from find-standard-picture-format f))))
+             (:a8
+              (lambda (k f)
+                (declare (ignore k))
+                (when (and (= (picture-format-depth f) 8)
+                           (= (byte-size (picture-format-alpha-byte f)) 8))
+                  (return-from find-standard-picture-format f))))
+             (:a4
+              (lambda (k f)
+                (declare (ignore k))
+                (when (and (= (picture-format-depth f) 4)
+                           (= (byte-size (picture-format-alpha-byte f)) 4))
+                  (return-from find-standard-picture-format f))))
+             (:a1
+              (lambda (k f)
+                (declare (ignore k))
+                (when (and (= (picture-format-depth f) 1)
+                           (= (byte-size (picture-format-alpha-byte f)) 1))
+                  (return-from find-standard-picture-format f)))))
+           (render-info-picture-formats (display-render-info display)))
+  (error "Standard format ~s not found." format))
+
+;;; fixme?
 (defun find-window-picture-format (window)
   "Find the picture format which matches the given window."
   (let* ((vi (window-visual-info window))
diff --git a/src/clx/input.lisp b/src/clx/input.lisp
index b1d70dcd803b1e4e68156aba6a4b0cf851b4454b..0546cc0332ae871097b3d4f4aac168081aacd6b6 100644
--- a/src/clx/input.lisp
+++ b/src/clx/input.lisp
@@ -386,7 +386,7 @@
 
 (defun read-input (display timeout force-output-p predicate &rest predicate-args)
   (declare (type display display)
-	   (type (or null number) timeout)
+	   (type (or null real) timeout)
 	   (type generalized-boolean force-output-p)
 	   (dynamic-extent predicate-args))
   (declare (type function predicate)
@@ -501,7 +501,7 @@
 
 (defun wait-for-event (display timeout force-output-p)
   (declare (type display display)
-	   (type (or null number) timeout)
+	   (type (or null real) timeout)
 	   (type generalized-boolean force-output-p))
   (let ((event-process-p (not (eql timeout 0))))
     (declare (type generalized-boolean event-process-p))
@@ -1020,7 +1020,7 @@
 
 (defun event-loop-step-before (display timeout force-output-p current-event-symbol)
   (declare (type display display)
-	   (type (or null number) timeout)
+	   (type (or null real) timeout)
 	   (type generalized-boolean force-output-p)
 	   (type symbol current-event-symbol)
 	   (clx-values event eof-or-timeout))
@@ -1165,36 +1165,35 @@
   ;;
   ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
   ;; from the queue (it is left in place), NIL means the event is removed.
-  
   (declare (type display display)
-	   (type (or null number) timeout)
-	   (type generalized-boolean peek-p discard-p force-output-p))
-  (declare (type t handler)
-	   (dynamic-extent handler))
+           (type (or null real) timeout)
+           (type generalized-boolean peek-p discard-p force-output-p)
+           (type t handler)
+           (dynamic-extent handler))
   (event-loop (display event timeout force-output-p discard-p)
     (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
-	   (event-decoder (and (index< event-code (length *event-handler-vector*))
-			       (svref *event-handler-vector* event-code))))
+           (event-decoder (and (index< event-code (length *event-handler-vector*))
+                               (svref *event-handler-vector* event-code))))
       (declare (type array-index event-code)
-	       (type (or null function) event-decoder))
+               (type (or null function) event-decoder))
       (if event-decoder
-	  (let ((event-handler (if (functionp handler)
-				   handler
-				   (and (type? handler 'sequence)
-					(< event-code (length handler))
-					(elt handler event-code)))))
-	    (if event-handler
-		(let ((result (funcall event-decoder display event event-handler)))
-		  (when result
-		    (unless peek-p
-		      (discard-current-event display))
-		    (return result)))
-	      (cerror "Ignore this event"
-		      "No handler for ~s event"
-		      (svref *event-key-vector* event-code))))
-	(cerror "Ignore this event"
-		"Server Error: event with unknown event code ~d received."
-		event-code)))))
+          (let ((event-handler (if (functionp handler)
+                                   handler
+                                   (and (type? handler 'sequence)
+                                        (< event-code (length handler))
+                                        (elt handler event-code)))))
+            (if event-handler
+                (let ((result (funcall event-decoder display event event-handler)))
+                  (when result
+                    (unless peek-p
+                      (discard-current-event display))
+                    (return result)))
+              (cerror "Ignore this event"
+                      "No handler for ~s event"
+                      (svref *event-key-vector* event-code))))
+        (cerror "Ignore this event"
+                "Server Error: event with unknown event code ~d received."
+                event-code)))))
 
 (defun make-event-handlers (&key (type 'vector) default)
   (declare (type t type)			;Sequence type specifier
diff --git a/src/clx/macros.lisp b/src/clx/macros.lisp
index 57a3ae63f4c3b1406a88d61103b04c319e0f2bd0..efa03a2a15f3a8839f2c3cb4111170178f2711b3 100644
--- a/src/clx/macros.lisp
+++ b/src/clx/macros.lisp
@@ -96,12 +96,11 @@
            ,@(cdr get-macro))
          (defmacro ,(putify name) ,(car put-macro)
            ,@(cdr put-macro))
-         ,@(when +type-check?+
-             (let ((predicating-put (third get-put-macros)))
-               (when predicating-put
-                 `((setf (get ',name 'predicating-put) t)
-                   (defmacro ,(putify name t) ,(car predicating-put)
-                     ,@(cdr predicating-put)))))))))
+         ,@(let ((predicating-put (third get-put-macros)))
+             (when predicating-put
+               `((setf (get ',name 'predicating-put) t)
+                 (defmacro ,(putify name t) ,(car predicating-put)
+                   ,@(cdr predicating-put))))))))
   ) ;; End eval-when
 
 (define-accessor card32 (32)
@@ -219,6 +218,29 @@
     :descent       (int16-get ,(+ index 8))
     :attributes   (card16-get ,(+ index 10))))
 
+(defun generate-member-case (thing keywords mismatch-error-p)
+  `(case ,thing
+     ,@(loop :for i :from 0
+             :for keyword :in keywords
+             :collect `(,keyword ,i))
+     ,@(when mismatch-error-p
+         `((t (x-type-error ,thing '(member ,@keywords)))))))
+
+(defun generate-member-lookup (thing keywords mismatch-error-p)
+  (let ((lookup `(position ,thing
+                           #+lispm ',keywords ;; Lispm's prefer lists
+                           #-lispm (the simple-vector ',(apply #'vector keywords))
+                           :test #'eq)))
+    (if mismatch-error-p
+        `(or ,lookup
+             (x-type-error ,thing '(member ,@keywords)))
+        lookup)))
+
+(defun generate-member-to-integer (thing keywords mismatch-error-p)
+  (if (< (length keywords) 8)
+      (generate-member-case thing keywords mismatch-error-p)
+      (generate-member-lookup thing keywords mismatch-error-p)))
+
 (define-accessor member8 (8)
   ((index &rest keywords)
    (let ((value (gensym)))
@@ -227,16 +249,10 @@
         (type-check ,value '(integer 0 (,(length keywords))))
         (svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
-   `(write-card8 ,index (position ,thing
-                                  #+lispm ',keywords ;; Lispm's prefer lists
-                                  #-lispm (the simple-vector ',(apply #'vector keywords))
-                                  :test #'eq)))
+   `(write-card8 ,index ,(generate-member-to-integer thing keywords t)))
   ((index thing &rest keywords)
    (let ((value (gensym)))
-     `(let ((,value (position ,thing
-                              #+lispm ',keywords
-                              #-lispm (the simple-vector ',(apply #'vector keywords))
-                              :test #'eq)))
+     `(let ((,value ,(generate-member-to-integer thing keywords t)))
         (and ,value (write-card8 ,index ,value))))))
 
 (define-accessor member16 (16)
@@ -247,16 +263,10 @@
         (type-check ,value '(integer 0 (,(length keywords))))
         (svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
-   `(write-card16 ,index (position ,thing
-                                   #+lispm ',keywords ;; Lispm's prefer lists
-                                   #-lispm (the simple-vector ',(apply #'vector keywords))
-                                   :test #'eq)))
+   `(write-card16 ,index ,(generate-member-to-integer thing keywords t)))
   ((index thing &rest keywords)
    (let ((value (gensym)))
-     `(let ((,value (position ,thing
-                              #+lispm ',keywords
-                              #-lispm (the simple-vector ',(apply #'vector keywords))
-                              :test #'eq)))
+     `(let ((,value ,(generate-member-to-integer thing keywords nil)))
         (and ,value (write-card16 ,index ,value))))))
 
 (define-accessor member (32)
@@ -267,19 +277,11 @@
         (type-check ,value '(integer 0 (,(length keywords))))
         (svref ',(apply #'vector keywords) ,value))))
   ((index thing &rest keywords)
-   `(write-card29 ,index (position ,thing
-                                   #+lispm ',keywords ;; Lispm's prefer lists
-                                   #-lispm (the simple-vector ',(apply #'vector keywords))
-                                   :test #'eq)))
+   `(write-card29 ,index ,(generate-member-to-integer thing keywords t)))
   ((index thing &rest keywords)
-   (if (cdr keywords) ;; IF more than one
-       (let ((value (gensym)))
-         `(let ((,value (position ,thing
-                                  #+lispm ',keywords
-                                  #-lispm (the simple-vector ',(apply #'vector keywords))
-                                  :test #'eq)))
-            (and ,value (write-card29 ,index ,value))))
-       `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
+   (let ((value (gensym)))
+     `(let ((,value ,(generate-member-to-integer thing keywords nil)))
+        (and ,value (write-card29 ,index ,value))))))
 
 (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
 
@@ -484,7 +486,7 @@
 ;;
 (define-accessor or (32)
   ;; Select from among two types (NULL/MEMBER and something else).
-  ((index &rest type-list &environment environment)
+  ((index &rest type-list)
    ;; OR-GET accessor accepts only two types. The first one must enum (either
    ;; null or a member specifier). Otherwise if the first type didn't match we
    ;; could have a condition signalled by a type-check or by other assertions
diff --git a/src/clx/manager.lisp b/src/clx/manager.lisp
index 729ba00dbe6c9d56c4cc53624a01a45e0adb832a..65e59558212d478d1178ce7765e3555ad1db6239 100644
--- a/src/clx/manager.lisp
+++ b/src/clx/manager.lisp
@@ -30,8 +30,8 @@
 
 (defun set-string-property (window property string)
   (declare (type window window)
-	   (type keyword property)
-	   (type stringable string))
+           (type keyword property)
+           (type stringable string))
   (change-property window property (string string) :STRING 8 :transform #'char->card8)
   string)
 
@@ -39,7 +39,7 @@
   (declare (type window window))
   (declare (clx-values string))
   (get-property window :WM_ICON_NAME :type :STRING
-		:result-type 'string :transform #'card8->char))
+                :result-type 'string :transform #'card8->char))
 
 (defsetf wm-icon-name (window) (name)
   `(set-string-property ,window :WM_ICON_NAME ,name))
@@ -48,7 +48,7 @@
   (declare (type window window))
   (declare (clx-values string))
   (get-property window :WM_CLIENT_MACHINE :type :STRING
-		:result-type 'string :transform #'card8->char))
+                :result-type 'string :transform #'card8->char))
 
 (defsetf wm-client-machine (window) (name)
   `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
@@ -60,63 +60,63 @@
     (declare (type (or null (vector card8)) value))
     (when value
       (let* ((name-len (position 0 (the (vector card8) value)))
-	     (name (subseq (the (vector card8) value) 0 name-len))
-	     (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)))))))
+             (name (subseq (the (vector card8) value) 0 name-len))
+             (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)))))))
 
 (defun set-wm-class (window resource-name resource-class)
   (declare (type window window)
-	   (type (or null stringable) resource-name resource-class))
+           (type (or null stringable) resource-name resource-class))
   (change-property window :WM_CLASS
-		   (concatenate '(vector card8)
-				(map '(vector card8) #'char->card8
-				     (string (or resource-name "")))
-				#(0)
-				(map '(vector card8) #'char->card8
-				     (string (or resource-class "")))
-				#(0))
-		   :string 8)
+                   (concatenate '(vector card8)
+                                (map '(vector card8) #'char->card8
+                                     (string (or resource-name "")))
+                                #(0)
+                                (map '(vector card8) #'char->card8
+                                     (string (or resource-class "")))
+                                #(0))
+                   :string 8)
   (values))
 
 (defun wm-command (window)
-  ;; Returns a list whose car is the command and 
+  ;; Returns a list whose car is the command and
   ;; whose cdr is the list of arguments
   (declare (type window window))
   (declare (clx-values list))
   (do* ((command-string (get-property window :WM_COMMAND :type :STRING
-				      :result-type '(vector card8)))
-	(command nil)
-	(start 0 (1+ end))
-	(end 0)
-	(len (length command-string)))
+                                      :result-type '(vector card8)))
+        (command nil)
+        (start 0 (1+ end))
+        (end 0)
+        (len (length command-string)))
        ((>= start len) (nreverse command))
     (setq end (position 0 command-string :start start))
     (push (map 'string #'card8->char (subseq command-string start end))
-	  command)))
+          command)))
 
 (defsetf wm-command set-wm-command)
 (defun set-wm-command (window command)
   ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
   ;; equivalent), with elements of command separated by NULL characters.  This
-  ;; enables 
+  ;; enables
   ;;   (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
   ;; to recover a lisp command.
   (declare (type window window)
-	   (type list command))
+           (type list command))
   (change-property window :WM_COMMAND
-		   (apply #'concatenate '(vector card8)
-			  (mapcan #'(lambda (c)
-				      (list (map '(vector card8) #'char->card8
-						 (with-output-to-string (stream)
-						   (with-standard-io-syntax 
-						     (prin1 c stream))))
-					    #(0)))
-				  command))
-		   :string 8)
+                   (apply #'concatenate '(vector card8)
+                          (mapcan #'(lambda (c)
+                                      (list (map '(vector card8) #'char->card8
+                                                 (with-output-to-string (stream)
+                                                   (with-standard-io-syntax
+                                                     (prin1 c stream))))
+                                            #(0)))
+                                  command))
+                   :string 8)
   command)
 
 ;;-----------------------------------------------------------------------------
@@ -145,47 +145,47 @@
 (defsetf wm-hints set-wm-hints)
 (defun set-wm-hints (window wm-hints)
   (declare (type window window)
-	   (type wm-hints wm-hints))
+           (type wm-hints wm-hints))
   (declare (clx-values wm-hints))
   (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
   wm-hints)
 
 (defun decode-wm-hints (vector display)
   (declare (type (simple-vector *) vector)
-	   (type display display))
+           (type display display))
   (declare (clx-values wm-hints))
   (let ((hint-mask (1- (ash 1 29)))
-	(input-hint 0)
-	(state-hint 1)
-	(icon-pixmap-hint 2)
-	(icon-window-hint 3)
-	(icon-position-hint 4)
-	(icon-mask-hint 5)
-	(window-group-hint 6))
+        (input-hint 0)
+        (state-hint 1)
+        (icon-pixmap-hint 2)
+        (icon-window-hint 3)
+        (icon-position-hint 4)
+        (icon-mask-hint 5)
+        (window-group-hint 6))
     (let ((flags (aref vector 0))
-	  (hints (make-wm-hints))
-	  (%buffer display))
+          (hints (make-wm-hints))
+          (%buffer display))
       (declare (type card32 flags)
-	       (type wm-hints hints)
-	       (type display %buffer))
+               (type wm-hints hints)
+               (type display %buffer))
       (setf (wm-hints-flags hints) flags)
       (when (logbitp input-hint flags)
-	(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
+        (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
       (when (logbitp state-hint flags)
-	(setf (wm-hints-initial-state hints)
-	      (decode-type (member :dont-care :normal :zoom :iconic :inactive)
-			   (aref vector 2))))
+        (setf (wm-hints-initial-state hints)
+              (decode-type (member :dont-care :normal :zoom :iconic :inactive)
+                           (aref vector 2))))
       (when (logbitp icon-pixmap-hint flags)
-	(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
+        (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
       (when (logbitp icon-window-hint flags)
-	(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
+        (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
       (when (logbitp icon-position-hint flags)
-	(setf (wm-hints-icon-x hints) (logand hint-mask (aref vector 5))
-	      (wm-hints-icon-y hints) (logand hint-mask (aref vector 6))))
+        (setf (wm-hints-icon-x hints) (logand hint-mask (aref vector 5))
+              (wm-hints-icon-y hints) (logand hint-mask (aref vector 6))))
       (when (logbitp icon-mask-hint flags)
-	(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
+        (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
       (when (and (logbitp window-group-hint flags) (> (length vector) 7))
-	(setf (wm-hints-window-group hints) (logand hint-mask (aref vector 8))))
+        (setf (wm-hints-window-group hints) (logand hint-mask (aref vector 8))))
       hints)))
 
 
@@ -193,41 +193,41 @@
   (declare (type wm-hints wm-hints))
   (declare (clx-values simple-vector))
   (let ((input-hint         #b1)
-	(state-hint         #b10)
-	(icon-pixmap-hint   #b100)
-	(icon-window-hint   #b1000)
-	(icon-position-hint #b10000)
-	(icon-mask-hint     #b100000)
-	(window-group-hint  #b1000000)
-	(mask               #b1111111)
-	)
+        (state-hint         #b10)
+        (icon-pixmap-hint   #b100)
+        (icon-window-hint   #b1000)
+        (icon-position-hint #b10000)
+        (icon-mask-hint     #b100000)
+        (window-group-hint  #b1000000)
+        (mask               #b1111111)
+        )
     (let ((vector (make-array 9 :initial-element 0))
-	  (flags 0))
+          (flags 0))
       (declare (type (simple-vector 9) vector)
-	       (type card16 flags))
+               (type card16 flags))
       (when (wm-hints-input wm-hints)
-	(setf flags input-hint
-	      (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
+        (setf flags input-hint
+              (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
       (when (wm-hints-initial-state wm-hints)
-	(setf flags (logior flags state-hint)
-	      (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
-					   (wm-hints-initial-state wm-hints))))
+        (setf flags (logior flags state-hint)
+              (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
+                                           (wm-hints-initial-state wm-hints))))
       (when (wm-hints-icon-pixmap wm-hints)
-	(setf flags (logior flags icon-pixmap-hint)
-	      (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
+        (setf flags (logior flags icon-pixmap-hint)
+              (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
       (when (wm-hints-icon-window wm-hints)
-	(setf flags (logior flags icon-window-hint)
-	      (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
+        (setf flags (logior flags icon-window-hint)
+              (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
       (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
-	(setf flags (logior flags icon-position-hint)
-	      (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
-	      (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
+        (setf flags (logior flags icon-position-hint)
+              (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
+              (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
       (when (wm-hints-icon-mask wm-hints)
-	(setf flags (logior flags icon-mask-hint)
-	      (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
+        (setf flags (logior flags icon-mask-hint)
+              (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
       (when (wm-hints-window-group wm-hints)
-	(setf flags (logior flags window-group-hint)
-	      (aref vector 8) (wm-hints-window-group wm-hints)))
+        (setf flags (logior flags window-group-hint)
+              (aref vector 8) (wm-hints-window-group wm-hints)))
       (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
       vector)))
 
@@ -268,7 +268,7 @@
 (defsetf wm-normal-hints set-wm-normal-hints)
 (defun set-wm-normal-hints (window hints)
   (declare (type window window)
-	   (type wm-size-hints hints))
+           (type wm-size-hints hints))
   (declare (clx-values wm-size-hints))
   (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
   hints)
@@ -284,7 +284,7 @@
 ;;; OBSOLETE
 (defun set-wm-zoom-hints (window hints)
   (declare (type window window)
-	   (type wm-size-hints hints))
+           (type wm-size-hints hints))
   (declare (clx-values wm-size-hints))
   (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
   hints)
@@ -294,22 +294,22 @@
   (declare (clx-values (or null wm-size-hints)))
   (when vector
     (let ((flags (aref vector 0))
-	  (hints (make-wm-size-hints)))
+          (hints (make-wm-size-hints)))
       (declare (type card16 flags)
-	       (type wm-size-hints hints))
+               (type wm-size-hints hints))
       (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
       (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
       (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
       (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
       (when (logbitp 4 flags)
-	(setf (wm-size-hints-min-width hints) (aref vector 5)
-	      (wm-size-hints-min-height hints) (aref vector 6)))
+        (setf (wm-size-hints-min-width hints) (aref vector 5)
+              (wm-size-hints-min-height hints) (aref vector 6)))
       (when (logbitp 5 flags)
-	(setf (wm-size-hints-max-width hints) (aref vector 7)
-	      (wm-size-hints-max-height hints) (aref vector 8)))
+        (setf (wm-size-hints-max-width hints) (aref vector 7)
+              (wm-size-hints-max-height hints) (aref vector 8)))
       (when (logbitp 6 flags)
-	(setf (wm-size-hints-width-inc hints) (aref vector 9)
-	      (wm-size-hints-height-inc hints) (aref vector 10)))
+        (setf (wm-size-hints-width-inc hints) (aref vector 9)
+              (wm-size-hints-height-inc hints) (aref vector 10)))
       (when (logbitp 7 flags)
         (let ((low (aref vector 12)))
           (unless (zerop low)
@@ -318,36 +318,36 @@
           (unless (zerop low)
             (setf (wm-size-hints-max-aspect hints) (/ (aref vector 13) low)))))
       (when (> (length vector) 15)
-	;; This test is for backwards compatibility since old Xlib programs
-	;; can set a size-hints structure that is too small.  See ICCCM.
-	(when (logbitp 8 flags)
-	  (setf (wm-size-hints-base-width hints) (aref vector 15)
-		(wm-size-hints-base-height hints) (aref vector 16)))
-	(when (logbitp 9 flags)
-	  (setf (wm-size-hints-win-gravity hints)
-		;; many games don't initialize win-gravity correctly,
-		;; so we need to bring it to within the correct range
-		;; ICCCM specifies a default gravity of NorthWest
-		(let ((gravity (aref vector 17)))
-		  (if (< 0 gravity #.(length +win-gravity-vector+))
-		      (decode-type (member-vector +win-gravity-vector+) gravity)
-		      :north-west)))))
+        ;; This test is for backwards compatibility since old Xlib programs
+        ;; can set a size-hints structure that is too small.  See ICCCM.
+        (when (logbitp 8 flags)
+          (setf (wm-size-hints-base-width hints) (aref vector 15)
+                (wm-size-hints-base-height hints) (aref vector 16)))
+        (when (logbitp 9 flags)
+          (setf (wm-size-hints-win-gravity hints)
+                ;; many games don't initialize win-gravity correctly,
+                ;; so we need to bring it to within the correct range
+                ;; ICCCM specifies a default gravity of NorthWest
+                (let ((gravity (aref vector 17)))
+                  (if (< 0 gravity #.(length +win-gravity-vector+))
+                      (decode-type (member-vector +win-gravity-vector+) gravity)
+                      :north-west)))))
       ;; Obsolete fields
       (when (or (logbitp 0 flags) (logbitp 2 flags))
-	(setf (wm-size-hints-x hints) (card32->int32 (aref vector 1))
-	      (wm-size-hints-y hints) (card32->int32 (aref vector 2))))
+        (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1))
+              (wm-size-hints-y hints) (card32->int32 (aref vector 2))))
       (when (or (logbitp 1 flags) (logbitp 3 flags))
-	(setf (wm-size-hints-width hints) (aref vector 3)
-	      (wm-size-hints-height hints) (aref vector 4)))
+        (setf (wm-size-hints-width hints) (aref vector 3)
+              (wm-size-hints-height hints) (aref vector 4)))
       hints)))
 
 (defun encode-wm-size-hints (hints)
   (declare (type wm-size-hints hints))
   (declare (clx-values simple-vector))
   (let ((vector (make-array 18 :initial-element 0))
-	(flags 0))
+        (flags 0))
     (declare (type (simple-vector 18) vector)
-	     (type card16 flags)) 
+             (type card16 flags))
     (when (wm-size-hints-user-specified-position-p hints)
       (setf (ldb (byte 1 0) flags) 1))
     (when (wm-size-hints-user-specified-size-p hints)
@@ -358,47 +358,47 @@
       (setf (ldb (byte 1 3) flags) 1))
     (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
       (setf (ldb (byte 1 4) flags) 1
-	    (aref vector 5) (wm-size-hints-min-width hints)
-	    (aref vector 6) (wm-size-hints-min-height hints)))
+            (aref vector 5) (wm-size-hints-min-width hints)
+            (aref vector 6) (wm-size-hints-min-height hints)))
     (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
       (setf (ldb (byte 1 5) flags) 1
-	    (aref vector 7) (wm-size-hints-max-width hints)
-	    (aref vector 8) (wm-size-hints-max-height hints)))
+            (aref vector 7) (wm-size-hints-max-width hints)
+            (aref vector 8) (wm-size-hints-max-height hints)))
     (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
       (setf (ldb (byte 1 6) flags) 1
-	    (aref vector 9) (wm-size-hints-width-inc hints)
-	    (aref vector 10) (wm-size-hints-height-inc hints)))
+            (aref vector 9) (wm-size-hints-width-inc hints)
+            (aref vector 10) (wm-size-hints-height-inc hints)))
     (let ((min-aspect (wm-size-hints-min-aspect hints))
-	  (max-aspect (wm-size-hints-max-aspect hints)))
+          (max-aspect (wm-size-hints-max-aspect hints)))
       (when (and min-aspect max-aspect)
-	(setf (ldb (byte 1 7) flags) 1
-	      min-aspect (rationalize min-aspect)
-	      max-aspect (rationalize max-aspect)
-	      (aref vector 11) (numerator min-aspect)
-	      (aref vector 12) (denominator min-aspect)
-	      (aref vector 13) (numerator max-aspect)
-	      (aref vector 14) (denominator max-aspect))))
+        (setf (ldb (byte 1 7) flags) 1
+              min-aspect (rationalize min-aspect)
+              max-aspect (rationalize max-aspect)
+              (aref vector 11) (numerator min-aspect)
+              (aref vector 12) (denominator min-aspect)
+              (aref vector 13) (numerator max-aspect)
+              (aref vector 14) (denominator max-aspect))))
     (when (and (wm-size-hints-base-width hints)
-	       (wm-size-hints-base-height hints))
+               (wm-size-hints-base-height hints))
       (setf (ldb (byte 1 8) flags) 1
-	    (aref vector 15) (wm-size-hints-base-width hints)
-	    (aref vector 16) (wm-size-hints-base-height hints)))
+            (aref vector 15) (wm-size-hints-base-width hints)
+            (aref vector 16) (wm-size-hints-base-height hints)))
     (when (wm-size-hints-win-gravity hints)
       (setf (ldb (byte 1 9) flags) 1
-	    (aref vector 17) (encode-type
-			       (member-vector +win-gravity-vector+)
-			       (wm-size-hints-win-gravity hints))))
+            (aref vector 17) (encode-type
+                              (member-vector +win-gravity-vector+)
+                              (wm-size-hints-win-gravity hints))))
     ;; Obsolete fields
-    (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) 
+    (when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
       (unless (wm-size-hints-user-specified-position-p hints)
-	(setf (ldb (byte 1 2) flags) 1))
-      (setf (aref vector 1) (wm-size-hints-x hints)
-	    (aref vector 2) (wm-size-hints-y hints)))
+        (setf (ldb (byte 1 2) flags) 1))
+      (setf (aref vector 1) (int32->card32 (wm-size-hints-x hints))
+            (aref vector 2) (int32->card32 (wm-size-hints-y hints))))
     (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
       (unless (wm-size-hints-user-specified-size-p hints)
-	(setf (ldb (byte 1 3) flags) 1))
+        (setf (ldb (byte 1 3) flags) 1))
       (setf (aref vector 3) (wm-size-hints-width hints)
-	    (aref vector 4) (wm-size-hints-height hints)))
+            (aref vector 4) (wm-size-hints-height hints)))
     (setf (aref vector 0) flags)
     vector))
 
@@ -414,23 +414,23 @@
     (declare (type (or null (simple-vector 6)) vector))
     (when vector
       (make-wm-size-hints
-	:min-width (aref vector 0)
-	:min-height (aref vector 1)
-	:max-width (aref vector 2)
-	:max-height (aref vector 3)
-	:width-inc (aref vector 4)
-	:height-inc (aref vector 5)))))
-  
+       :min-width (aref vector 0)
+       :min-height (aref vector 1)
+       :max-width (aref vector 2)
+       :max-height (aref vector 3)
+       :width-inc (aref vector 4)
+       :height-inc (aref vector 5)))))
+
 (defsetf icon-sizes set-icon-sizes)
 (defun set-icon-sizes (window wm-size-hints)
   (declare (type window window)
-	   (type wm-size-hints wm-size-hints))
+           (type wm-size-hints wm-size-hints))
   (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
-			(wm-size-hints-min-height wm-size-hints)
-			(wm-size-hints-max-width wm-size-hints)
-			(wm-size-hints-max-height wm-size-hints)
-			(wm-size-hints-width-inc wm-size-hints)
-			(wm-size-hints-height-inc wm-size-hints))))
+                        (wm-size-hints-min-height wm-size-hints)
+                        (wm-size-hints-max-width wm-size-hints)
+                        (wm-size-hints-max-height wm-size-hints)
+                        (wm-size-hints-width-inc wm-size-hints)
+                        (wm-size-hints-height-inc wm-size-hints))))
     (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
     wm-size-hints))
 
@@ -444,9 +444,9 @@
 (defsetf wm-protocols set-wm-protocols)
 (defun set-wm-protocols (window protocols)
   (change-property window :WM_PROTOCOLS
-		   (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
-			protocols)
-		   :ATOM 32)
+                   (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
+                        protocols)
+                   :ATOM 32)
   protocols)
 
 ;;-----------------------------------------------------------------------------
@@ -454,13 +454,13 @@
 
 (defun wm-colormap-windows (window)
   (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
-			:transform #'(lambda (id)
-				       (lookup-window (window-display window) id)))))
+                               :transform #'(lambda (id)
+                                              (lookup-window (window-display window) id)))))
 
 (defsetf wm-colormap-windows set-wm-colormap-windows)
 (defun set-wm-colormap-windows (window colormap-windows)
   (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
-		   :transform #'window-id)
+                  :transform #'window-id)
   colormap-windows)
 
 ;;-----------------------------------------------------------------------------
@@ -479,51 +479,51 @@
 ;;-----------------------------------------------------------------------------
 ;; Set-WM-Properties
 
-(defun set-wm-properties (window &rest options &key 
-			  name icon-name resource-name resource-class command
-			  client-machine hints normal-hints zoom-hints
-			  ;; the following are used for wm-normal-hints
-			  (user-specified-position-p nil usppp)
-			  (user-specified-size-p nil usspp)
-			  (program-specified-position-p nil psppp)
-			  (program-specified-size-p nil psspp)
-			  x y width height min-width min-height max-width max-height
-			  width-inc height-inc min-aspect max-aspect
-			  base-width base-height win-gravity
-			  ;; the following are used for wm-hints
-			  input initial-state icon-pixmap icon-window
-			  icon-x icon-y icon-mask window-group)
+(defun set-wm-properties (window &rest options &key
+                                                 name icon-name resource-name resource-class command
+                                                 client-machine hints normal-hints zoom-hints
+                                                 ;; the following are used for wm-normal-hints
+                                                 (user-specified-position-p nil usppp)
+                                                 (user-specified-size-p nil usspp)
+                                                 (program-specified-position-p nil psppp)
+                                                 (program-specified-size-p nil psspp)
+                                                 x y width height min-width min-height max-width max-height
+                                                 width-inc height-inc min-aspect max-aspect
+                                                 base-width base-height win-gravity
+                                                 ;; the following are used for wm-hints
+                                                 input initial-state icon-pixmap icon-window
+                                                 icon-x icon-y icon-mask window-group)
   ;; Set properties for WINDOW.
-  (declare (arglist window &rest options &key 
-		   name icon-name resource-name resource-class command
-		   client-machine hints normal-hints
-		   ;; the following are used for wm-normal-hints
-		   user-specified-position-p user-specified-size-p
-		   program-specified-position-p program-specified-size-p
-		   min-width min-height max-width max-height
-		   width-inc height-inc min-aspect max-aspect
-		   base-width base-height win-gravity
-		   ;; the following are used for wm-hints
-		   input initial-state icon-pixmap icon-window
-		   icon-x icon-y icon-mask window-group))
+  (declare (arglist window &rest options &key
+                    name icon-name resource-name resource-class command
+                    client-machine hints normal-hints
+                    ;; the following are used for wm-normal-hints
+                    user-specified-position-p user-specified-size-p
+                    program-specified-position-p program-specified-size-p
+                    min-width min-height max-width max-height
+                    width-inc height-inc min-aspect max-aspect
+                    base-width base-height win-gravity
+                    ;; the following are used for wm-hints
+                    input initial-state icon-pixmap icon-window
+                    icon-x icon-y icon-mask window-group))
   (declare (type window window)
-	   (type (or null stringable) name icon-name resource-name resource-class client-machine)
-	   (type (or null list) command)
-	   (type (or null wm-hints) hints)
-	   (type (or null wm-size-hints) normal-hints zoom-hints)
-	   (type generalized-boolean user-specified-position-p user-specified-size-p)
-	   (type generalized-boolean program-specified-position-p program-specified-size-p)
-	   (type (or null int32) x y)
-	   (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
-	   (type (or null win-gravity) win-gravity)
-	   (type (or null number) min-aspect max-aspect)
-	   (type (or null (member :off :on)) input)
-	   (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
-	   (type (or null pixmap) icon-pixmap icon-mask)
-	   (type (or null window) icon-window)
-	   (type (or null card32) icon-x icon-y)
-	   (type (or null resource-id) window-group)
-	   (dynamic-extent options))
+           (type (or null stringable) name icon-name resource-name resource-class client-machine)
+           (type (or null list) command)
+           (type (or null wm-hints) hints)
+           (type (or null wm-size-hints) normal-hints zoom-hints)
+           (type generalized-boolean user-specified-position-p user-specified-size-p)
+           (type generalized-boolean program-specified-position-p program-specified-size-p)
+           (type (or null int32) x y)
+           (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
+           (type (or null win-gravity) win-gravity)
+           (type (or null number) min-aspect max-aspect)
+           (type (or null (member :off :on)) input)
+           (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
+           (type (or null pixmap) icon-pixmap icon-mask)
+           (type (or null window) icon-window)
+           (type (or null card32) icon-x icon-y)
+           (type (or null resource-id) window-group)
+           (dynamic-extent options))
   (when name (setf (wm-name window) name))
   (when icon-name (setf (wm-icon-name window) icon-name))
   (when client-machine (setf (wm-client-machine window) client-machine))
@@ -532,51 +532,51 @@
   (when command (setf (wm-command window) command))
   ;; WM-HINTS
   (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
-			    :icon-x :icon-y :icon-mask :window-group))
-	(when (getf options arg) (return t)))
+                     :icon-x :icon-y :icon-mask :window-group))
+        (when (getf options arg) (return t)))
       (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
-	(when input (setf (wm-hints-input wm-hints) input))
-	(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
-	(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
-	(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
-	(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
-	(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
-	(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
-	(when window-group (setf (wm-hints-window-group wm-hints) window-group))
-	(setf (wm-hints window) wm-hints))
+        (when input (setf (wm-hints-input wm-hints) input))
+        (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
+        (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
+        (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
+        (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
+        (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
+        (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
+        (when window-group (setf (wm-hints-window-group wm-hints) window-group))
+        (setf (wm-hints window) wm-hints))
       (when hints (setf (wm-hints window) hints)))
   ;; WM-NORMAL-HINTS
   (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
-			:width-inc :height-inc :min-aspect :max-aspect
-			:user-specified-position-p :user-specified-size-p
-			:program-specified-position-p :program-specified-size-p
-			:base-width :base-height :win-gravity))
-	(when (getf options arg) (return t)))
+                     :width-inc :height-inc :min-aspect :max-aspect
+                     :user-specified-position-p :user-specified-size-p
+                     :program-specified-position-p :program-specified-size-p
+                     :base-width :base-height :win-gravity))
+        (when (getf options arg) (return t)))
       (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
-	(when x (setf (wm-size-hints-x size) x))
-	(when y (setf (wm-size-hints-y size) y))
-	(when width (setf (wm-size-hints-width size) width))
-	(when height (setf (wm-size-hints-height size) height))
-	(when min-width (setf (wm-size-hints-min-width size) min-width))
-	(when min-height (setf (wm-size-hints-min-height size) min-height))
-	(when max-width (setf (wm-size-hints-max-width size) max-width))
-	(when max-height (setf (wm-size-hints-max-height size) max-height))
-	(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
-	(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
-	(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
-	(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
-	(when base-width (setf (wm-size-hints-base-width size) base-width))
-	(when base-height (setf (wm-size-hints-base-height size) base-height))
-	(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
-	(when usppp
-	  (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
-	(when usspp
-	  (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
-	(when psppp
-	  (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
-	(when psspp
-	  (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
-	(setf (wm-normal-hints window) size))
+        (when x (setf (wm-size-hints-x size) x))
+        (when y (setf (wm-size-hints-y size) y))
+        (when width (setf (wm-size-hints-width size) width))
+        (when height (setf (wm-size-hints-height size) height))
+        (when min-width (setf (wm-size-hints-min-width size) min-width))
+        (when min-height (setf (wm-size-hints-min-height size) min-height))
+        (when max-width (setf (wm-size-hints-max-width size) max-width))
+        (when max-height (setf (wm-size-hints-max-height size) max-height))
+        (when width-inc (setf (wm-size-hints-width-inc size) width-inc))
+        (when height-inc (setf (wm-size-hints-height-inc size) height-inc))
+        (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
+        (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
+        (when base-width (setf (wm-size-hints-base-width size) base-width))
+        (when base-height (setf (wm-size-hints-base-height size) base-height))
+        (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
+        (when usppp
+          (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
+        (when usspp
+          (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
+        (when psppp
+          (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
+        (when psspp
+          (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
+        (setf (wm-normal-hints window) size))
       (when normal-hints (setf (wm-normal-hints window) normal-hints)))
   (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
   )
@@ -591,20 +591,20 @@
 
 (defun iconify-window (window screen)
   (declare (type window window)
-	   (type screen screen))
+           (type screen screen))
   (let ((root (screen-root screen)))
     (declare (type window root))
     (send-event root :client-message '(:substructure-redirect :substructure-notify)
-		:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
+                :window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
 
 (defun withdraw-window (window screen)
   (declare (type window window)
-	   (type screen screen))
+           (type screen screen))
   (unmap-window window)
   (let ((root (screen-root screen)))
     (declare (type window root))
     (send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
-		:window window :event-window root :configure-p nil)))
+                :window window :event-window root :configure-p nil)))
 
 
 ;;-----------------------------------------------------------------------------
@@ -617,145 +617,148 @@
   (mult-color nil :type (or null color))
   (visual nil :type (or null visual-info))
   (kill nil :type (or (member nil :release-by-freeing-colormap)
-		      drawable gcontext cursor colormap font)))
+                      drawable gcontext cursor colormap font)))
 
 (defun rgb-colormaps (window property)
   (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+           (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+                                          :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
   (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
     (declare (type (or null simple-vector) prop))
     (when prop
       (list (make-standard-colormap
-	      :colormap (lookup-colormap (window-display window) (aref prop 0))
-	      :base-pixel (aref prop 7)
-	      :max-color (make-color :red   (card16->rgb-val (aref prop 1))
-				     :green (card16->rgb-val (aref prop 3))
-				     :blue  (card16->rgb-val (aref prop 5)))
-	      :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
-				      :green (card16->rgb-val (aref prop 4))
-				      :blue  (card16->rgb-val (aref prop 6)))
-	      :visual (and (<= 9 (length prop))
-			   (visual-info (window-display window) (aref prop 8)))
-	      :kill (and (<= 10 (length prop))
-			 (let ((killid (aref prop 9)))
-			   (if (= killid 1)
-			       :release-by-freeing-colormap
-			       (lookup-resource-id (window-display window) killid)))))))))
+             :colormap (lookup-colormap (window-display window) (aref prop 0))
+             :base-pixel (aref prop 7)
+             :max-color (make-color :red   (card16->rgb-val (aref prop 1))
+                                    :green (card16->rgb-val (aref prop 3))
+                                    :blue  (card16->rgb-val (aref prop 5)))
+             :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
+                                     :green (card16->rgb-val (aref prop 4))
+                                     :blue  (card16->rgb-val (aref prop 6)))
+             :visual (and (<= 9 (length prop))
+                          (visual-info (window-display window) (aref prop 8)))
+             :kill (and (<= 10 (length prop))
+                        (let ((killid (aref prop 9)))
+                          (if (= killid 1)
+                              :release-by-freeing-colormap
+                              (lookup-resource-id (window-display window) killid)))))))))
 
 (defsetf rgb-colormaps set-rgb-colormaps)
 (defun set-rgb-colormaps (window property maps)
   (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
-	   (type list maps))
+           (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+                         :RGB_GREEN_MAP :RGB_BLUE_MAP)
+                 property)
+           (type list maps))
   (let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
-	(index -1))
+        (index -1))
     (dolist (map maps)
       (setf (aref prop (incf index))
-	    (encode-type colormap (standard-colormap-colormap map)))
+            (encode-type colormap (standard-colormap-colormap map)))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-red (standard-colormap-max-color map))))
+            (encode-type rgb-val (color-red (standard-colormap-max-color map))))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
+            (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-green (standard-colormap-max-color map))))
+            (encode-type rgb-val (color-green (standard-colormap-max-color map))))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
+            (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
+            (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
       (setf (aref prop (incf index))
-	    (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
+            (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
       (setf (aref prop (incf index))
-	    (standard-colormap-base-pixel map))
+            (standard-colormap-base-pixel map))
       (setf (aref prop (incf index))
-	    (visual-info-id (standard-colormap-visual map)))
+            (visual-info-id (standard-colormap-visual map)))
       (setf (aref prop (incf index))
-	    (let ((kill (standard-colormap-kill map)))
-	      (etypecase kill
-		(symbol
-		  (ecase kill
-		    ((nil) 0)
-		    ((:release-by-freeing-colormap) 1)))
-		(drawable (drawable-id kill))
-		(gcontext (gcontext-id kill))
-		(cursor (cursor-id kill))
-		(colormap (colormap-id kill))
-		(font (font-id kill))))))
+            (let ((kill (standard-colormap-kill map)))
+              (etypecase kill
+                (symbol
+                 (ecase kill
+                   ((nil) 0)
+                   ((:release-by-freeing-colormap) 1)))
+                (drawable (drawable-id kill))
+                (gcontext (gcontext-id kill))
+                (cursor (cursor-id kill))
+                (colormap (colormap-id kill))
+                (font (font-id kill))))))
     (change-property window property prop :RGB_COLOR_MAP 32)))
 
 ;;; OBSOLETE
 (defun get-standard-colormap (window property)
   (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+           (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+                         :RGB_GREEN_MAP :RGB_BLUE_MAP)
+                 property))
   (declare (clx-values colormap base-pixel max-color mult-color))
   (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
     (declare (type (or null simple-vector) prop))
     (when prop
       (values (lookup-colormap (window-display window) (aref prop 0))
-	      (aref prop 7)			;Base Pixel
-	      (make-color :red   (card16->rgb-val (aref prop 1))	;Max Color
-			  :green (card16->rgb-val (aref prop 3))
-			  :blue  (card16->rgb-val (aref prop 5)))
-	      (make-color :red   (card16->rgb-val (aref prop 2))	;Mult color
-			  :green (card16->rgb-val (aref prop 4))
-			  :blue  (card16->rgb-val (aref prop 6)))))))
+              (aref prop 7)			;Base Pixel
+              (make-color :red   (card16->rgb-val (aref prop 1))	;Max Color
+                          :green (card16->rgb-val (aref prop 3))
+                          :blue  (card16->rgb-val (aref prop 5)))
+              (make-color :red   (card16->rgb-val (aref prop 2))	;Mult color
+                          :green (card16->rgb-val (aref prop 4))
+                          :blue  (card16->rgb-val (aref prop 6)))))))
 
 ;;; OBSOLETE
 (defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
   (declare (type window window)
-	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
-			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
-	   (type colormap colormap)
-	   (type pixel base-pixel)
-	   (type color max-color mult-color))
+           (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+                         :RGB_GREEN_MAP :RGB_BLUE_MAP)
+                 property)
+           (type colormap colormap)
+           (type pixel base-pixel)
+           (type color max-color mult-color))
   (let ((prop (vector (encode-type colormap colormap)
-		      (encode-type rgb-val (color-red max-color))
-		      (encode-type rgb-val (color-red mult-color))
-		      (encode-type rgb-val (color-green max-color))
-		      (encode-type rgb-val (color-green mult-color))
-		      (encode-type rgb-val (color-blue max-color))
-		      (encode-type rgb-val (color-blue mult-color))
-		      base-pixel)))
+                      (encode-type rgb-val (color-red max-color))
+                      (encode-type rgb-val (color-red mult-color))
+                      (encode-type rgb-val (color-green max-color))
+                      (encode-type rgb-val (color-green mult-color))
+                      (encode-type rgb-val (color-blue max-color))
+                      (encode-type rgb-val (color-blue mult-color))
+                      base-pixel)))
     (change-property window property prop :RGB_COLOR_MAP 32)))
 
 ;;-----------------------------------------------------------------------------
 ;; Cut-Buffers
 
 (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
-		   (transform #'card8->char) (start 0) end)
+                             (transform #'card8->char) (start 0) end)
   ;; Return the contents of cut-buffer BUFFER
   (declare (type display display)
-	   (type (integer 0 7) buffer)
-	   (type xatom type)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type t result-type)			;a sequence type
-	   (type (or null (function (integer) t)) transform))
+           (type (integer 0 7) buffer)
+           (type xatom type)
+           (type array-index start)
+           (type (or null array-index) end)
+           (type t result-type)			;a sequence type
+           (type (or null (function (integer) t)) transform))
   (declare (clx-values sequence type format bytes-after))
   (let* ((root (screen-root (first (display-roots display))))
-	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
-			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
-			 buffer)))
+         (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+                            :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+                         buffer)))
     (get-property root property :type type :result-type result-type
-		  :start start :end end :transform transform)))
+                                :start start :end end :transform transform)))
 
 (defun (setf cut-buffer)
-  (data display &key (buffer 0) (type :STRING) (format 8)
-	(start 0) end (transform #'char->card8))
+    (data display &key (buffer 0) (type :STRING) (format 8)
+                    (start 0) end (transform #'char->card8))
   (declare (type sequence data)
-	   (type display display)
-	   (type (integer 0 7) buffer)
-	   (type xatom type)
-	   (type (member 8 16 32) format)
-	   (type array-index start)
-	   (type (or null array-index) end)
-	   (type (or null (function (integer) t)) transform))
+           (type display display)
+           (type (integer 0 7) buffer)
+           (type xatom type)
+           (type (member 8 16 32) format)
+           (type array-index start)
+           (type (or null array-index) end)
+           (type (or null (function (integer) t)) transform))
   (let* ((root (screen-root (first (display-roots display))))
-	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
-					 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
-			 buffer)))
+         (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+                            :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+                         buffer)))
     (change-property root property data type format :transform transform :start start :end end)
     data))
 
@@ -763,15 +766,14 @@
   ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
   ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
   (declare (type display display)
-	   (type int16 delta)
-	   (type generalized-boolean careful-p))
+           (type int16 delta)
+           (type generalized-boolean careful-p))
   (let* ((root (screen-root (first (display-roots display))))
-	 (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
-		     :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
+         (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
+                     :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
     (when careful-p
       (let ((props (list-properties root)))
-	(dotimes (i 8)
-	  (unless (member (aref buffers i) props)
-	    (setf (cut-buffer display :buffer i) "")))))
+        (dotimes (i 8)
+          (unless (member (aref buffers i) props)
+            (setf (cut-buffer display :buffer i) "")))))
     (rotate-properties root buffers delta)))
-
diff --git a/src/clx/manual/clx.texinfo b/src/clx/manual/clx.texinfo
index f38577cdeb09a8a127a4bd15967b3028f1b8ac78..7a90a097ac64a437f6f3bf738852c630ba6f2a68 100644
--- a/src/clx/manual/clx.texinfo
+++ b/src/clx/manual/clx.texinfo
@@ -16022,7 +16022,7 @@ server and rendering sets of them.
 @subsection Picture formats
 
 The following is what the X protocol rendering spec has to say about picture formats.
-@url{http://www.xfree86.org/~keithp/render/protocol.html}
+@url{https://www.x.org/releases/X11R7.7/doc/renderproto/renderproto.txt}
 
 
 The @var{picture-format} object holds information needed to translate pixel values
diff --git a/src/clx/package.lisp b/src/clx/package.lisp
index 7e8f9de6cec431995590cfd6376396fd3b4ed883..4a90b7a7e4eeebadaca2ce6434a9e8af171e133e 100644
--- a/src/clx/package.lisp
+++ b/src/clx/package.lisp
@@ -24,13 +24,14 @@
   (:use common-lisp)
   (:size 3000)
   #+(or kcl ibcl) (:shadow rational)
-  #+allegro (:import-from excl without-interrupts)
+  #+(or sbcl clasp) (:shadow defconstant)
   #+excl (:import-from excl arglist)
   #+Genera (:import-from zwei indentation)
   #+lcl3.0 (:import-from lcl arglist)
   #+lispm (:import-from lisp char-bit)
   #+lispm (:import-from sys arglist with-stack-list with-stack-list*)
-  #+(or sbcl ecl) (:use sb-bsd-sockets)
+  #+clasp (:shadow arglist)
+  #+(or sbcl ecl clasp) (:use sb-bsd-sockets)
   (:export
     *version* access-control access-error access-hosts
     activate-screen-saver add-access-host add-resource add-to-save-set
@@ -177,93 +178,4 @@
     wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
     wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
     wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
-    write-resources xatom
-    picture-subwindow-mode picture-format-id
-    mode-info-hsyncstart
-    mode-info
-    xfree86-vidmode-get-mode-line
-    picture-drawable
-    picture-alpha-y-origin
-    make-mode-info
-    shape-mask
-    xfree86-vidmode-get-viewport
-    render-query-version
-    shape-rectangles
-    xfree86-vidmode-select-next-mode
-    xfree86-vidmode-set-gamma
-    render-composite-glyphs
-    xfree86-vidmode-get-dotclocks
-    render-trapezoids
-    xfree86-vidmode-get-all-mode-lines
-    mode-info-hskew
-    picture-format-type
-    xfree86-vidmode-get-gamma-ramp
-    render-create-picture
-    picture-format-blue-byte
-    shape-query-extents
-    xfree86-vidmode-validate-mode-line
-    shape-offset
-    shape-input-selected-p
-    mode-info-vsyncend
-    shape-select-input
-    screen-saver-get-idle
-    mode-info-vtotal
-    picture-format-depth
-    picture-clip-x-origin
-    picture-format-alpha-byte
-    screen-saver-query-info
-    xfree86-vidmode-set-gamma-ramp
-    xfree86-vidmode-switch-to-mode
-    mode-info-vdisplay
-    xfree86-vidmode-delete-mode-line
-    xfree86-vidmode-set-viewport
-    picture-dither
-    picture-format-colormap
-    xfree86-vidmode-lock-mode-switch
-    render-triangles
-    xfree86-vidmode-add-mode-line
-    picture-component-alpha
-    xfree86-vidmode-get-permissions
-    shape-get-rectangles
-    shape-query-version
-    mode-info-hsyncend
-    mode-info-hdisplay
-    picture-repeat
-    picture-graphics-exposures
-    xfree86-vidmode-query-version
-    screen-saver-query-version
-    find-window-picture-format
-    render-add-glyph-from-picture
-    mode-info-private
-    xfree86-vidmode-get-gamma
-    picture-alpha-map
-    xfree86-vidmode-mod-mode-line
-    mode-info-htotal
-    render-free-picture
-    picture-poly-mode
-    picture-format-green-byte
-    render-free-glyph-set
-    render-free-glyphs
-    shape-combine
-    render-free-glyph
-    mode-info-flags
-    render-fill-rectangle
-    picture-clip-y-origin
-    mode-info-vsyncstart
-    mode-info-privsize
-    picture-poly-edge
-    render-composite
-    picture-format-red-byte
-    render-add-glyph
-    picture-format-display
-    render-reference-glyph-set
-    xfree86-vidmode-get-gamma-ramp-size
-    find-matching-picture-formats
-    mode-info-dotclock
-    xfree86-vidmode-set-client-version
-    picture-clip-mask
-    picture-alpha-x-origin
-    xfree86-vidmode-get-monitor
-    render-create-glyph-set
-    xfree86-vidmode-switch-mode
-    xfree86-vidmode-select-prev-mode))
+    write-resources xatom))
diff --git a/src/clx/provide.lisp b/src/clx/provide.lisp
index 208e42d69755d78bb21bef8c66607ac9bb801544..5f2c7caacde487342db09167598d7f727475dc99 100644
--- a/src/clx/provide.lisp
+++ b/src/clx/provide.lisp
@@ -17,38 +17,3 @@
 (in-package :common-lisp-user)
 
 (provide :clx)
-
-#-cmu
-(progn
-(defvar *clx-source-pathname*
-	(pathname "/src/local/clx/*.l"))
-
-(defvar *clx-binary-pathname*
-	(let ((lisp
-		(or #+lucid "lucid"
-		    #+akcl  "akcl"
-		    #+kcl   "kcl"
-		    #+ibcl  "ibcl"
-		    (error "Can't provide CLX for this lisp.")))
-	      (architecture
-		(or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3"
-		    #+(or sun4 sparc) "sparc"
-		    #+(and hp (or mc68000 mc68020)) "hp9000s300"
-		    #+vax "vax"
-		    #+prime "prime"
-		    #+sunrise "sunrise"
-		    #+ibm-rt-pc "ibm-rt-pc"
-		    #+mips "mips"
-		    #+prism "prism"
-		    (error "Can't provide CLX for this architecture."))))
-	  (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture))))
-
-(defvar *compile-clx*
-	nil)
-
-(load (merge-pathnames "defsystem" *clx-source-pathname*))
-
-(if *compile-clx*
-    (compile-clx *clx-source-pathname* *clx-binary-pathname*)
-  (load-clx *clx-binary-pathname*))
-)
\ No newline at end of file