diff --git a/clx/defsystem.lisp b/clx/defsystem.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b711c59504fe373e7369efa11cdb43ee5c71ebed
--- /dev/null
+++ b/clx/defsystem.lisp
@@ -0,0 +1,603 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes;  -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;; #+ features used in this file
+;;;   ansi-common-lisp
+;;;   lispm
+;;;   genera
+;;;   lucid
+;;;   lcl3.0
+;;;   apollo
+;;;   kcl
+;;;   ibcl
+;;;   excl
+
+#-ansi-common-lisp 
+(lisp:in-package :xlib :use '(:lisp))
+
+#+ansi-common-lisp
+(common-lisp:in-package :common-lisp-user)
+
+#+ansi-common-lisp
+(common-lisp:defpackage xlib
+  (:use common-lisp)
+  (:size 3000)
+  #+Genera
+  (:import-from
+    (system
+      arglist downward-funarg array-register)
+    (zwei
+      indentation))
+  (:export
+    *version* access-control access-error access-hosts
+    activate-screen-saver add-access-host add-resource add-to-save-set
+    alist alloc-color alloc-color-cells alloc-color-planes alloc-error
+    allow-events angle arc-seq array-index atom-error atom-name
+    bell bit-gravity bitmap bitmap-format bitmap-format-lsb-first-p
+    bitmap-format-p bitmap-format-pad bitmap-format-unit bitmap-image
+    boole-constant boolean card16 card29 card32 card8
+    card8->char change-active-pointer-grab change-keyboard-control
+    change-keyboard-mapping change-pointer-control change-property
+    char->card8 char-ascent char-attributes char-descent
+    char-left-bearing char-right-bearing char-width character->keysyms
+    character-in-map-p circulate-window-down circulate-window-up clear-area
+    close-display close-down-mode close-font closed-display color
+    color-blue color-green color-p color-red color-rgb colormap
+    colormap-display colormap-equal colormap-error colormap-id
+    colormap-p colormap-visual-info connection-failure convert-selection
+    copy-area copy-colormap-and-free copy-gcontext copy-gcontext-components
+    copy-image copy-plane create-colormap create-cursor
+    create-gcontext create-glyph-cursor create-image create-pixmap
+    create-window cursor cursor-display cursor-equal cursor-error
+    cursor-id cursor-p cut-buffer declare-event decode-core-error
+    default-error-handler default-keysym-index default-keysym-translate
+    define-error define-extension define-gcontext-accessor
+    define-keysym define-keysym-set delete-property delete-resource
+    destroy-subwindows destroy-window device-busy device-event-mask
+    device-event-mask-class discard-current-event discard-font-info display
+    display-after-function display-authorization-data display-authorization-name
+    display-bitmap-format display-byte-order display-default-screen
+    display-display display-error-handler display-finish-output
+    display-force-output display-host display-image-lsb-first-p
+    display-invoke-after-function display-keycode-range display-max-keycode
+    display-max-request-length display-min-keycode display-motion-buffer-size
+    display-nscreens display-p display-pixmap-formats display-plist
+    display-protocol-major-version display-protocol-minor-version
+    display-protocol-version display-release-number
+    display-report-asynchronous-errors display-resource-id-base
+    display-resource-id-mask display-roots display-vendor
+    display-vendor-name display-xdefaults display-xid draw-arc
+    draw-arcs draw-direction draw-glyph draw-glyphs draw-image-glyph
+    draw-image-glyphs draw-line draw-lines draw-point draw-points
+    draw-rectangle draw-rectangles draw-segments drawable
+    drawable-border-width drawable-depth drawable-display drawable-equal
+    drawable-error drawable-height drawable-id drawable-p
+    drawable-plist drawable-root drawable-width drawable-x drawable-y
+    error-key event-case event-cond event-handler event-key
+    event-listen event-mask event-mask-class extension-opcode
+    find-atom font font-all-chars-exist-p font-ascent
+    font-default-char font-descent font-direction font-display
+    font-equal font-error font-id font-max-byte1 font-max-byte2
+    font-max-char font-min-byte1 font-min-byte2 font-min-char
+    font-name font-p font-path font-plist font-properties
+    font-property fontable force-gcontext-changes free-colormap
+    free-colors free-cursor free-gcontext free-pixmap gcontext
+    gcontext-arc-mode gcontext-background gcontext-cap-style
+    gcontext-clip-mask gcontext-clip-ordering gcontext-clip-x
+    gcontext-clip-y gcontext-dash-offset gcontext-dashes gcontext-display
+    gcontext-equal gcontext-error gcontext-exposures gcontext-fill-rule
+    gcontext-fill-style gcontext-font gcontext-foreground gcontext-function
+    gcontext-id gcontext-join-style gcontext-key gcontext-line-style
+    gcontext-line-width gcontext-p gcontext-plane-mask gcontext-plist
+    gcontext-stipple gcontext-subwindow-mode gcontext-tile gcontext-ts-x
+    gcontext-ts-y get-external-event-code get-image get-property
+    get-raw-image get-resource get-search-resource get-search-table
+    get-standard-colormap get-wm-class global-pointer-position grab-button
+    grab-key grab-keyboard grab-pointer grab-server grab-status
+    icon-sizes iconify-window id-choice-error illegal-request-error
+    image image-blue-mask image-depth image-green-mask image-height
+    image-name image-pixmap image-plist image-red-mask image-width
+    image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
+    image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
+    image-z-pixarray implementation-error input-focus install-colormap
+    installed-colormaps int16 int32 int8 intern-atom invalid-font
+    keyboard-control keyboard-mapping keycode->character keycode->keysym
+    keysym keysym->character keysym->keycodes keysym-in-map-p
+    keysym-set kill-client kill-temporary-clients length-error
+    list-extensions list-font-names list-fonts list-properties
+    lookup-color lookup-error make-color make-event-handlers
+    make-event-keys make-event-mask make-resource-database make-state-keys
+    make-state-mask make-wm-hints make-wm-size-hints map-resource
+    map-subwindows map-window mapping-notify mask16 mask32
+    match-error max-char-ascent max-char-attributes max-char-descent
+    max-char-left-bearing max-char-right-bearing max-char-width
+    merge-resources min-char-ascent min-char-attributes min-char-descent
+    min-char-left-bearing min-char-right-bearing min-char-width
+    missing-parameter modifier-key modifier-mapping modifier-mask
+    motion-events name-error no-operation open-display open-font
+    pixarray pixel pixmap pixmap-display pixmap-equal
+    pixmap-error pixmap-format pixmap-format-bits-per-pixel
+    pixmap-format-depth pixmap-format-p pixmap-format-scanline-pad
+    pixmap-id pixmap-p pixmap-plist point-seq pointer-control
+    pointer-event-mask pointer-event-mask-class pointer-mapping
+    pointer-position process-event put-image put-raw-image
+    query-best-cursor query-best-stipple query-best-tile query-colors
+    query-extension query-keymap query-pointer query-tree queue-event
+    read-bitmap-file read-resources recolor-cursor rect-seq
+    remove-access-host remove-from-save-set reparent-window repeat-seq
+    reply-length-error reply-timeout request-error reset-screen-saver
+    resource-database resource-database-timestamp resource-error
+    resource-id resource-key rgb-colormaps rgb-val root-resources
+    rotate-cut-buffers rotate-properties screen screen-backing-stores
+    screen-black-pixel screen-default-colormap screen-depths
+    screen-event-mask-at-open screen-height screen-height-in-millimeters
+    screen-max-installed-maps screen-min-installed-maps screen-p
+    screen-plist screen-root screen-root-depth screen-root-visual
+    screen-root-visual-info screen-save-unders-p screen-saver
+    screen-white-pixel screen-width screen-width-in-millimeters seg-seq
+    selection-owner send-event sequence-error set-access-control
+    set-close-down-mode set-input-focus set-modifier-mapping
+    set-pointer-mapping set-screen-saver set-selection-owner
+    set-standard-colormap set-standard-properties set-wm-class
+    set-wm-properties set-wm-resources state-keysym-p state-mask-key
+    store-color store-colors stringable text-extents text-width
+    timestamp transient-for translate-coordinates translate-default
+    translation-function undefine-keysym unexpected-reply
+    ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
+    ungrab-server uninstall-colormap unknown-error unmap-subwindows
+    unmap-window value-error visual-info visual-info-bits-per-rgb
+    visual-info-blue-mask visual-info-class visual-info-colormap-entries
+    visual-info-display visual-info-green-mask visual-info-id visual-info-p
+    visual-info-plist visual-info-red-mask warp-pointer
+    warp-pointer-if-inside warp-pointer-relative warp-pointer-relative-if-inside
+    win-gravity window window-all-event-masks window-background
+    window-backing-pixel window-backing-planes window-backing-store
+    window-bit-gravity window-border window-class window-colormap
+    window-colormap-installed-p window-cursor window-display
+    window-do-not-propagate-mask window-equal window-error
+    window-event-mask window-gravity window-id window-map-state
+    window-override-redirect window-p window-plist window-priority
+    window-save-under window-visual window-visual-info with-display
+    with-event-queue with-gcontext with-server-grabbed with-state
+    withdraw-window wm-client-machine wm-colormap-windows wm-command
+    wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
+    wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
+    wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
+    wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
+    wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
+    wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
+    wm-size-hints-max-height wm-size-hints-max-width wm-size-hints-min-aspect
+    wm-size-hints-min-height wm-size-hints-min-width wm-size-hints-p
+    wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
+    wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
+    wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
+    write-resources xatom))
+
+#+ansi-common-lisp
+(common-lisp:in-package :xlib)
+
+#-lispm
+(export '(
+	  compile-clx
+	  load-clx))
+
+#+excl (error "Use excldefsys")
+
+
+;;;; Lisp Machines
+
+;;; Lisp machines have their own defsystems, so we use them to define
+;;; the CLX load.
+
+#+(and lispm (not genera))
+(global:defsystem CLX
+  (:pathname-default "clx:clx;")
+  (:patchable "clx:patch;" clx-ti)
+  (:initial-status :experimental)
+
+  (:module depdefs "depdefs")
+  (:module clx "clx")
+  (:module dependent "dependent")
+  (:module macros "macros")
+  (:module bufmac "bufmac")
+  (:module buffer "buffer")
+  (:module display "display")
+  (:module gcontext "gcontext")
+  (:module requests "requests")
+  (:module input "input")
+  (:module fonts "fonts")
+  (:module graphics "graphics")
+  (:module text "text")
+  (:module attributes "attributes")
+  (:module translate "translate")
+  (:module keysyms "keysyms")
+  (:module manager "manager")
+  (:module image "image")
+  (:module resource "resource")
+  (:module doc "doc")
+
+  (:compile-load depdefs)
+  (:compile-load clx
+   (:fasload depdefs))
+  (:compile-load dependent
+   (:fasload depdefs clx))
+  ;; Macros only needed for compilation
+  (:skip :compile-load macros
+   (:fasload depdefs clx dependent))
+  ;; Bufmac only needed for compilation
+  (:skip :compile-load bufmac
+   (:fasload depdefs clx dependent macros))
+  (:compile-load buffer
+   (:fasload depdefs clx dependent macros bufmac))
+  (:compile-load display
+   (:fasload depdefs clx dependent macros bufmac buffer))
+  (:compile-load gcontext
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load input
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load requests
+   (:fasload depdefs clx dependent macros bufmac buffer display input))
+  (:compile-load fonts
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load graphics
+   (:fasload depdefs clx dependent macros fonts bufmac buffer display fonts))
+  (:compile-load text
+   (:fasload depdefs clx dependent macros fonts bufmac buffer display gcontext fonts))
+  (:compile-load-init attributes
+   (dependent)					;<- There may be other modules needed here.
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load translate
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load keysyms
+   (:fasload depdefs clx dependent macros bufmac buffer display translate))
+  (:compile-load manager
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load image
+   (:fasload depdefs clx dependent macros bufmac buffer display))
+  (:compile-load resource)
+  (:auxiliary doc)
+  )
+
+
+#+Genera
+(scl:defsystem CLX
+    (:default-pathname "SYS:X11;CLX;"
+     :default-package "XLIB"
+     :pretty-name "CLX"
+     :maintaining-sites (:scrc)
+     :distribute-sources t
+     :distribute-binaries t
+     :source-category :basic)
+  (:module doc ("doc")
+	   (:type :lisp-example))
+  (:module depdefs ("depdefs" "generalock"))
+  (:module clx ("clx")
+	   (:uses-definitions-from depdefs))
+  (:module dependent ("dependent")
+	   (:uses-definitions-from clx))
+  (:module macros ("macros")
+	   (:uses-definitions-from dependent))
+  (:module bufmac ("bufmac")
+	   (:uses-definitions-from dependent macros))
+  (:module buffer ("buffer")
+	   (:uses-definitions-from dependent macros bufmac))
+  (:module display ("display")
+	   (:uses-definitions-from dependent macros bufmac buffer))
+  (:module gcontext ("gcontext")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module input ("input")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module requests ("requests")
+	   (:uses-definitions-from dependent macros bufmac display input))
+  (:module fonts ("fonts")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module graphics ("graphics")
+	   (:uses-definitions-from dependent macros bufmac fonts))
+  (:module text ("text")
+	   (:uses-definitions-from dependent macros bufmac gcontext fonts))
+  (:module attributes ("attributes")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module translate ("translate")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module keysyms ("keysyms")
+	   (:uses-definitions-from translate))
+  (:module manager ("manager")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module image ("image")
+	   (:uses-definitions-from dependent macros bufmac display))
+  (:module resource ("resource"))
+  )
+
+
+;;;; Non Lisp Machines
+
+#+lucid
+(defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites
+
+#+lucid
+(defun clx-foreign-files (binary-path)
+
+  ;; apply a patch to 2.0 systems
+  #+(and (not lcl3.0) (or mc68000 mc68020))
+  (load (merge-pathnames "make-sequence-patch" binary-path))
+
+  ;; Link lisp to the C function connect_to_server
+  #+(and apollo (not lcl3.0))
+  (lucid::define-foreign-function '(xlib::connect-to-server "connect_to_server")
+      '((:val host    :string)
+	(:val display :integer32))
+    :integer32)
+  #+(and (not apollo) (not lcl3.0))
+  (lucid::define-c-function xlib::connect-to-server
+      (host display)
+    :result-type :integer)
+  #+lcl3.0
+  (lucid::def-foreign-function (xlib::connect-to-server 
+				 (:language :c)
+				 (:return-type :signed-32bit))
+      (host :simple-string) (display :signed-32bit))
+  (unintern 'display)
+
+  ;; Load the definition of connect_to_server
+  #+apollo
+  (lucid::load-foreign-file (merge-pathnames "socket" binary-path)
+			    :preserve-pathname t)
+  #-apollo
+  (lucid::load-foreign-files (list (merge-pathnames "socket.o" binary-path))
+			     *foreign-libraries*))
+
+
+;; socket interface for kcl and ibcl
+;;   defines the function (open-socket-stream host display)
+;;
+;; You must first compile file socket.c
+#+(or kcl ibcl)
+(defun kcl-socket-init (binary-path)
+  (let ((sockcl (namestring (merge-pathnames "sockcl.o" binary-path)))
+	(socket (namestring (merge-pathnames "socket.o" binary-path))))
+    (si:faslink sockcl (format nil "~a -lc" socket))
+    ))
+
+
+;;;; Compile CLX
+
+;;; COMPILE-CLX compiles the lisp source files and loads the binaries.
+;;; It goes to some trouble to let the source files be in one directory
+;;; and the binary files in another.  Thus the same set of sources can
+;;; be used for different machines and/or lisp systems.  It also allows
+;;; you to supply explicit extensions, so source files do not have to
+;;; be renamed to fit into the naming conventions of an implementation.
+
+;;; For example,
+;;;     (compile-clx "*.lisp" "machine/")
+;;; compiles source files from the connected directory and puts them
+;;; into the "machine" subdirectory.  You can then load CLX out of the
+;;; machine directory.
+
+;;; The code has no knowledge of the source file types (eg, ".l" or
+;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin").  Calling
+;;; compile-file and load with a file type of NIL usually sorts things
+;;; out correctly, but you may have to explicitly give the source and
+;;; binary file types.
+
+;;; An attempt at compiling the C language sources is also made,
+;;; but you may have to set different compiler switches
+;;; should be.  If it doesn't do the right thing, then do
+;;;     (compile-clx "" "" :compile-c NIL)
+;;; to prevent the compilation.
+
+;;; compilation notes
+;;;   lucid2.0/hp9000
+;;;     must uudecode the file make-sequence-patch.uu
+
+#-lispm
+(defun compile-clx (&optional
+		    (source-pathname-defaults "")
+		    (binary-pathname-defaults "")
+		    &key
+		    (compile-c t))
+
+  ;; The pathname-defaults above might only be strings, so coerce them
+  ;; to pathnames.  Build a default binary path with every component
+  ;; of the source except the file type.  This should prevent
+  ;; (compile-clx "*.lisp") from destroying source files.
+  (let* ((source-path (pathname source-pathname-defaults))
+	 (path        (make-pathname
+			:host      (pathname-host      source-path)
+			:device    (pathname-device    source-path)
+			:directory (pathname-directory source-path)
+			:name      (pathname-name      source-path)
+			:type      nil
+			:version   (pathname-version   source-path)))
+	 (binary-path (merge-pathnames binary-pathname-defaults
+				       path)))
+				       
+    ;; Make sure source-path and binary-path file types are distinct so
+    ;; we don't accidently overwrite the source files.  NIL should be an
+    ;; ok type, but anything else spells trouble.
+    (if (and (equal (pathname-type source-path)
+		    (pathname-type binary-path))
+	     (not (null (pathname-type binary-path))))
+	(error "Source and binary pathname defaults have same type ~s ~s"
+	       source-path binary-path))
+
+    (format t ";;; Default paths: ~s ~s~%" source-path binary-path)
+
+    ;; In lucid make sure we're using the compiler in production mode.
+    #+lcl3.0
+    (progn
+      #-pqc 
+      (cerror "Go ahead anyway."
+	      "Lucid's production mode compiler must be loaded to compile CLX.")
+      (proclaim '(optimize (speed 3)
+			   (safety 1)
+			   (space 0)
+			   (compilation-speed 0))))
+
+    (flet ((compile-and-load (filename)
+	     (let ((source (merge-pathnames filename source-path))
+		   (binary (merge-pathnames filename binary-path)))
+	       ;; If the source and binary pathnames are the same,
+	       ;; then don't supply an output file just to be sure
+	       ;; compile-file defaults correctly.
+	       #+(or kcl ibcl) (load source)
+	       (if (equal source binary)
+		   (compile-file source)
+		   (compile-file source :output-file binary))
+	       (load binary))))
+
+      ;; Now compile and load all the files.
+      ;; Defer compiler warnings until everything's compiled, if possible.
+      (#.(if (fboundp 'with-compilation-unit)
+	     'with-compilation-unit
+	   #+lcl3.0 'lucid::with-deferred-warnings
+	   #-lcl3.0 'progn)
+       ()
+       
+       #+lucid
+       (progn 
+	 (when compile-c			; compile the C files
+	   #+(and (not lcl3.0) (or mc68000 mc68020))
+	   (progn				; sequence patch
+	     (format t "You may need to uudecode ms-patch.uu and copy~%")
+	     (format t "the result to the binary directory.~%")
+	     (format t "You also must rename the file to have the canonical~%")
+	     (format t "binary file type in order for lisp to realize it's a~%")
+	     (format t "binary file.~%"))
+	   ;; compile socket.c
+	   (let* ((src  (merge-pathnames "socket.c" source-path))
+		  (obj  (merge-pathnames "socket.o" binary-path))
+		  (args (list "-c" (namestring src)
+			      "-o" (namestring obj)
+			      "-DUNIXCONN")))
+	     (format t ";;; cc~{ ~a~}~%" args)
+	     (multiple-value-bind (iostream estream exitstatus pid)
+		 ;; in 2.0, run-program is exported from system:
+		 ;; in 3.0, run-program is exported from lcl:
+		 ;; system inheirits lcl
+		 (system::run-program "cc" :arguments args)
+	       (declare (ignore iostream estream pid))
+	       (if (/= 0 exitstatus)
+		   (error "Exit status of socket.c compile is ~d" exitstatus)))))
+	 (format t ";;; Loading foreign files~%")
+	 (clx-foreign-files binary-path))
+
+       #+(or kcl ibcl)
+       (progn
+	 (when compile-c			; compile the C files
+	   (let* ((src (merge-pathnames "socket.c" source-path))
+		  (obj (merge-pathnames "socket.o" binary-path))
+		  (arg (format nil "cc -c ~a -o ~a -DUNIXCONN"
+			       (namestring src)
+			       (namestring obj))))
+	     (format t ";;; ~a~%" arg)
+	     (if (/= 0 (system arg))
+		 (error "bad exit status for ~s" src))))
+	 ;; compile the lisp interface to the c code
+	 (let ((src (merge-pathnames "sockcl"   source-path))
+	       (obj (merge-pathnames "sockcl.o" binary-path)))
+	   (compile-file src :output-file obj))
+	 (kcl-socket-init binary-path))
+
+       (compile-and-load "depdefs")
+       (compile-and-load "clx")
+       (compile-and-load "dependent")
+       (compile-and-load "macros")		; these are just macros
+       (compile-and-load "bufmac")		; these are just macros
+       (compile-and-load "buffer")
+       (compile-and-load "display")
+       (compile-and-load "gcontext")
+       (compile-and-load "input")
+       (compile-and-load "requests")
+       (compile-and-load "fonts")
+       (compile-and-load "graphics")
+       (compile-and-load "text")
+       (compile-and-load "attributes")
+       (compile-and-load "translate")
+       (compile-and-load "keysyms")
+       (compile-and-load "manager")
+       (compile-and-load "image")
+       (compile-and-load "resource")
+       ))))
+
+
+;;;; Load CLX
+
+;;; This procedure loads the binaries for CLX.  All of the binaries
+;;; should be in the same directory, so setting the default pathname
+;;; should point load to the right place.
+
+;;; You should have a module definition somewhere so the require/provide
+;;; mechanism can avoid reloading CLX.  In an ideal world, somebody would
+;;; just put
+;;;		(REQUIRE 'CLX)
+;;; in their file (some implementations don't have a central registry for
+;;; modules, so a pathname needs to be supplied).
+
+;;; The REQUIRE should find a file that does
+;;;		(IN-PACKAGE 'XLIB :USE '(LISP))
+;;;		(PROVIDE 'CLX)
+;;;		(LOAD <clx-defsystem-file>)
+;;;		(LOAD-CLX <binary-specific-clx-directory>)
+
+#-lispm
+(defun load-clx (&optional (binary-pathname-defaults "")
+		 &key (macros-p nil))
+
+  (let* ((source-path (pathname ""))
+	 (path        (make-pathname
+			:host      (pathname-host      source-path)
+			:device    (pathname-device    source-path)
+			:directory (pathname-directory source-path)
+			:name      (pathname-name      source-path)
+			:type      nil
+			:version   (pathname-version   source-path)))
+	 (binary-path (merge-pathnames binary-pathname-defaults
+				       path)))
+
+    (flet ((load-binary (filename)
+	     (let ((binary (merge-pathnames filename binary-path)))
+	       (load binary))))
+
+      #+lucid
+      (clx-foreign-files binary-path)
+
+      #+(or kcl ibcl)
+      (kcl-socket-init binary-path)
+
+      (load-binary "depdefs")
+      (load-binary "clx")
+      (load-binary "dependent")
+      (when macros-p
+	(load-binary "macros")
+	(load-binary "bufmac"))
+      (load-binary "buffer")
+      (load-binary "display")
+      (load-binary "gcontext")
+      (load-binary "input")
+      (load-binary "requests")
+      (load-binary "fonts")
+      (load-binary "graphics")
+      (load-binary "text")
+      (load-binary "attributes")
+      (load-binary "translate")
+      (load-binary "keysyms")
+      (load-binary "manager")
+      (load-binary "image")
+      (load-binary "resource")
+      )))
diff --git a/clx/depdefs.lisp b/clx/depdefs.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1f86c22d6b607dfc886354099f65f2abbfd47083
--- /dev/null
+++ b/clx/depdefs.lisp
@@ -0,0 +1,654 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;; This file contains some of the system dependent code for CLX
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+;;;-------------------------------------------------------------------------
+;;; Declarations
+;;;-------------------------------------------------------------------------
+
+;;; fix a bug in kcl's RATIONAL...
+;;;   redefine both the function and the type.
+
+#+(or kcl ibcl)
+(shadow 'rational)
+
+#+(or kcl ibcl)
+(progn
+  (defun rational (x)
+    (if (rationalp x)
+	x
+	(lisp:rational x)))
+  (deftype rational () 'lisp:rational))
+
+;;; DECLAIM
+
+#-ansi-common-lisp
+(defmacro declaim (&rest decl-specs)
+  (if (cdr decl-specs)
+      `(progn
+	 ,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
+		   decl-specs))
+    `(proclaim ',(car decl-specs))))
+
+;;; VALUES value1 value2 ... -- Documents the values returned by the function.
+
+#-lispm
+(declaim (declaration values))
+
+;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function.  Overrides
+;;; the documentation that might get generated by the real arglist of the
+;;; function.
+
+#+lispm 
+(import '(sys:arglist))
+
+#+lcl3.0
+(import '(lcl:arglist))
+
+#-(or lispm lcl3.0)
+(declaim (declaration arglist))
+
+;;; DOWNWARD-FUNARG name1 name2 ... -- Tells callers of this function that
+;;; closures passed in as the argument named by name can be consed on the
+;;; stack, as they have dynamic extent.  In Genera keyword args can't be named
+;;; this way.  Instead use * to specify all functional args have dynamic
+;;; extent.
+
+#+lispm 
+(import '(sys:downward-funarg))
+
+#-lispm
+(declaim (declaration downward-funarg))
+
+;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
+;;; dynamic extent and therefore can be kept on the stack and not copied to
+;;; the heap, even though the value is passed out of the function.
+
+#+lcl3.0
+(import '(lcl:dynamic-extent))
+
+#-(or ansi-common-lisp lcl3.0)
+(declaim (declaration dynamic-extent))
+
+;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not
+;;; args) that hold vectors.  
+
+#+Genera
+(import '(sys:array-register))
+
+#-Genera 
+(declaim (declaration array-register))
+
+;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
+;;; indent calls to the function or macro containing the declaration.  
+
+#+genera
+(import '(zwei:indentation))
+
+#-genera
+(declaim (declaration indentation))
+
+;;;-------------------------------------------------------------------------
+;;; Declaration macros
+;;;-------------------------------------------------------------------------
+
+;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
+;;; and then does a type declaration and array register declaration
+(defmacro with-vector ((var type) &body body)
+  `(let ((,var ,var))
+     (declare (type ,type ,var)
+	      (array-register ,var))
+     ,@body))
+
+;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
+;;; Meta-.
+
+#+lispm
+(defmacro within-definition ((name type) &body body)
+  `(zl:local-declare
+     ((sys:function-parent ,name ,type))
+     (sys:record-source-file-name ',name ',type)
+     ,@body))
+
+#-lispm
+(defmacro within-definition ((name type) &body body)
+  (declare (ignore name type))
+  `(progn ,@body))
+
+
+;;;-------------------------------------------------------------------------
+;;; CLX can maintain a mapping from X server ID's to local data types.  If
+;;; one takes the view that CLX objects will be instance variables of
+;;; objects at the next higher level, then PROCESS-EVENT will typically map
+;;; from resource-id to higher-level object.  In that case, the lower-level
+;;; CLX mapping will almost never be used (except in rare cases like
+;;; query-tree), and only serve to consume space (which is difficult to
+;;; GC), in which case always-consing versions of the make-<mumble>s will
+;;; be better.  Even when maps are maintained, it isn't clear they are
+;;; useful for much beyond xatoms and windows (since almost nothing else
+;;; ever comes back in events).
+;;;--------------------------------------------------------------------------
+(defconstant *clx-cached-types*
+	     '( drawable
+		window
+		pixmap
+;		gcontext
+		cursor
+		colormap
+		font))
+
+(defmacro resource-id-map-test ()
+  #+excl '#'equal
+  #-excl '#'eql)		    ; (eq fixnum fixnum) is not guaranteed.
+
+(defmacro keysym->character-map-test ()
+  #+excl '#'equal
+  #-excl '#'eql)
+
+;;; You must define this to match the real byte order.  It is used by
+;;; overlapping array and image code.
+
+#+(or lispm vax little-endian)
+(eval-when (eval compile load)
+  (pushnew :clx-little-endian *features*))
+
+#+lcl3.0
+(eval-when (compile eval load)
+  (ecase lucid::machine-endian
+    (:big)
+    (:little (pushnew :clx-little-endian *features*))))
+
+;;; Steele's Common-Lisp states:  "It is an error if the array specified
+;;; as the :displaced-to argument  does not have the same :element-type
+;;; as the array being created" If this is the case on your lisp, then
+;;; leave the overlapping-arrays feature turned off.  Lisp machines
+;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
+;;; with different element types to overlap.  CLX will take advantage of
+;;; this to do fast array packing/unpacking when the overlapping-arrays
+;;; feature is enabled.
+
+#+(and clx-little-endian lispm)
+(eval-when (eval compile load)
+  (pushnew :clx-overlapping-arrays *features*))
+
+#+(and clx-overlapping-arrays genera)
+(progn
+(deftype overlap16 () '(unsigned-byte 16))
+(deftype overlap32 () '(signed-byte 32))
+)
+
+#+(and clx-overlapping-arrays (or explorer lambda cadr))
+(progn
+(deftype overlap16 () '(unsigned-byte 16))
+(deftype overlap32 () '(unsigned-byte 32))
+)
+
+(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
+
+#+clx-overlapping-arrays
+(progn
+(deftype buffer-words () `(vector overlap16))
+(deftype buffer-longs () `(vector overlap32))
+)
+
+;;; This defines a type which is a subtype of the integers.
+;;; This type is used to describe all variables that can be array indices.
+;;; It is here because it is used below.
+;;; This is inclusive because start/end can be 1 past the end.
+(deftype array-index () `(integer 0 ,array-dimension-limit))
+
+
+;; this is the best place to define these?
+
+#-Genera
+(progn
+
+(defun make-index-typed (form)
+  (if (constantp form) form `(the array-index ,form)))
+
+(defun make-index-op (operator args)
+  `(the array-index
+	(values 
+	  ,(case (length args)
+	     (0 `(,operator))
+	     (1 `(,operator
+		  ,(make-index-typed (first args))))
+	     (2 `(,operator
+		  ,(make-index-typed (first args))
+		  ,(make-index-typed (second args))))
+	     (otherwise
+	       `(,operator
+		 ,(make-index-op operator (subseq args 0 (1- (length args))))
+		 ,(make-index-typed (first (last args)))))))))
+
+(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
+(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
+(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
+(defmacro index- (&rest numbers) (make-index-op '- numbers))
+(defmacro index* (&rest numbers) (make-index-op '* numbers))
+
+(defmacro index1+ (number) (make-index-op '1+ (list number)))
+(defmacro index1- (number) (make-index-op '1- (list number)))
+
+(defmacro index-incf (place &optional (delta 1))
+  (make-index-op 'incf (list place delta)))
+(defmacro index-decf (place &optional (delta 1))
+  (make-index-op 'decf (list place delta)))
+
+(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
+(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
+
+(defmacro index-floor (number divisor)
+  (make-index-op 'floor (list number divisor)))
+(defmacro index-ceiling (number divisor)
+  (make-index-op 'ceiling (list number divisor)))
+(defmacro index-truncate (number divisor)
+  (make-index-op 'truncate (list number divisor)))
+
+(defmacro index-mod (number divisor)
+  (make-index-op 'mod (list number divisor)))
+
+(defmacro index-ash (number count)
+  (make-index-op 'ash (list number count)))
+
+(defmacro index-plusp (number) `(plusp (the array-index ,number)))
+(defmacro index-zerop (number) `(zerop (the array-index ,number)))
+(defmacro index-evenp (number) `(evenp (the array-index ,number)))
+(defmacro index-oddp  (number) `(oddp  (the array-index ,number)))
+
+(defmacro index> (&rest numbers)
+  `(> ,@(mapcar #'make-index-typed numbers)))
+(defmacro index= (&rest numbers)
+  `(= ,@(mapcar #'make-index-typed numbers)))
+(defmacro index< (&rest numbers)
+  `(< ,@(mapcar #'make-index-typed numbers)))
+(defmacro index>= (&rest numbers)
+  `(>= ,@(mapcar #'make-index-typed numbers)))
+(defmacro index<= (&rest numbers)
+  `(<= ,@(mapcar #'make-index-typed numbers)))
+
+)
+
+#+Genera
+(progn
+
+(defmacro index+ (&rest numbers) `(+ ,@numbers))
+(defmacro index-logand (&rest numbers) `(logand ,@numbers))
+(defmacro index-logior (&rest numbers) `(logior ,@numbers))
+(defmacro index- (&rest numbers) `(- ,@numbers))
+(defmacro index* (&rest numbers) `(* ,@numbers))
+
+(defmacro index1+ (number) `(1+ ,number))
+(defmacro index1- (number) `(1- ,number))
+
+(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
+(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
+
+(defmacro index-min (&rest numbers) `(min ,@numbers))
+(defmacro index-max (&rest numbers) `(max ,@numbers))
+
+(defun positive-power-of-two-p (x)
+  (and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
+
+(defmacro index-floor (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,divisor))
+	(t `(floor ,number ,divisor))))
+
+(defmacro index-ceiling (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
+	 `(si:%fixnum-ceiling ,number ,divisor))
+	(t `(ceiling ,number ,divisor))))
+
+(defmacro index-truncate (number divisor)
+  (cond ((eql divisor 1) number)
+	((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,divisor))
+	(t `(truncate ,number ,divisor))))
+
+(defmacro index-mod (number divisor)
+  (cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
+	 `(si:%fixnum-mod ,number ,divisor))
+	(t `(mod ,number ,divisor))))
+
+(defmacro index-ash (number count)
+  (cond ((eql count 0) number)
+	((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
+	 `(si:%fixnum-floor ,number ,(expt 2 (- count))))
+	((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
+	 `(si:%fixnum-multiply ,number ,(expt 2 count)))
+	(t `(ash ,number ,count))))
+
+(defmacro index-plusp (number) `(plusp ,number))
+(defmacro index-zerop (number) `(zerop ,number))
+(defmacro index-evenp (number) `(evenp ,number))
+(defmacro index-oddp  (number) `(oddp  ,number))
+
+(defmacro index> (&rest numbers) `(> ,@numbers))
+(defmacro index= (&rest numbers) `(= ,@numbers))
+(defmacro index< (&rest numbers) `(< ,@numbers))
+(defmacro index>= (&rest numbers) `(>= ,@numbers))
+(defmacro index<= (&rest numbers) `(<= ,@numbers))
+
+)
+
+;;;; Stuff for BUFFER definition
+
+(defconstant *replysize* 32.)
+
+;; used in defstruct initializations to avoid compiler warnings
+(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
+(declaim (type buffer-bytes *empty-bytes*))
+#+clx-overlapping-arrays
+(progn
+(defvar *empty-words* (make-sequence 'buffer-words 0))
+(declaim (type buffer-words *empty-words*))
+)
+#+clx-overlapping-arrays
+(progn
+(defvar *empty-longs* (make-sequence 'buffer-longs 0))
+(declaim (type buffer-longs *empty-longs*))
+)
+
+(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
+			 (:copier nil) (:predicate nil))
+  (size 0 :type array-index)			;Buffer size
+  ;; Byte (8 bit) input buffer
+  (ibuf8 *empty-bytes* :type buffer-bytes)
+  ;; Word (16bit) input buffer
+  #+clx-overlapping-arrays
+  (ibuf16 *empty-words* :type buffer-words)
+  ;; Long (32bit) input buffer
+  #+clx-overlapping-arrays
+  (ibuf32 *empty-longs* :type buffer-longs)
+  (next nil #-explorer :type #-explorer (or null reply-buffer))
+  (data-size 0 :type array-index)
+  )
+
+(defconstant *buffer-text16-size* 256)
+(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
+
+;; These are here because.
+
+(defparameter *xlib-package* (find-package 'xlib))
+
+(defun xintern (&rest parts)
+  (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
+
+(defparameter *keyword-package* (find-package 'keyword))
+
+(defun kintern (name)
+  (intern (string name) *keyword-package*))
+
+;;; Pseudo-class mechanism.
+
+(defmacro def-clx-class ((name &rest options) &body slots)
+  (let ((clos-package (or (find-package 'clos)
+			  (find-package 'pcl)
+			  (let ((lisp-pkg (find-package 'lisp)))
+			    (and (find-symbol (string 'defclass) lisp-pkg)
+				 lisp-pkg)))))
+    (if clos-package
+	(let ((constructor t)
+	      (constructor-args t)
+	      (include nil)
+	      (print-function nil)
+	      (copier t)
+	      (predicate t))
+	  (dolist (option options)
+	    (ecase (pop option)
+	      (:constructor
+		(setf constructor (pop option))
+		(setf constructor-args (if (null option) t (pop option))))
+	      (:include
+		(setf include (pop option)))
+	      (:print-function
+		(setf print-function (pop option)))
+	      (:copier
+		(setf copier (pop option)))
+	      (:predicate
+		(setf predicate (pop option)))))
+	  (flet ((cintern (&rest symbols)
+		   (intern (apply #'concatenate 'simple-string
+				  (mapcar #'symbol-name symbols))
+			   *package*))
+		 (kintern (symbol)
+		   (intern (symbol-name symbol) (find-package 'keyword)))
+		 (closintern (symbol)
+		   (intern (symbol-name symbol) clos-package)))
+	    (when (eq constructor t)
+	      (setf constructor (cintern 'make- name)))
+	    (when (eq copier t)
+	      (setf copier (cintern 'copy- name)))
+	    (when (eq predicate t)
+	      (setf predicate (cintern name '-p)))
+	    (when include
+	      (setf slots (append (get include 'def-clx-class) slots)))
+	    (let* ((n-slots (length slots))
+		   (slot-names (make-list n-slots))
+		   (slot-initforms (make-list n-slots))
+		   (slot-types (make-list n-slots)))
+	      (dotimes (i n-slots)
+		(let ((slot (elt slots i)))
+		  (setf (elt slot-names i) (pop slot))
+		  (setf (elt slot-initforms i) (pop slot))
+		  (setf (elt slot-types i) (getf slot :type t))))
+	      `(progn
+
+		 (eval-when (compile load eval)
+		   (setf (get ',name 'def-clx-class) ',slots))
+
+		 ;; From here down are the system-specific expansions:
+
+		 ,(cond (clos-package
+			 `(within-definition (,name def-clx-class)
+			    (,(closintern 'defclass)
+			     ,name ,(and include `(,include))
+			     (,@(map 'list
+				     #'(lambda (slot-name slot-initform slot-type)
+					 `(,slot-name
+					   :initform ,slot-initform :type ,slot-type
+					   :accessor ,(cintern name '- slot-name)
+					   ,@(when (and constructor
+							(or (eq constructor-args t)
+							    (member slot-name
+								    constructor-args)))
+					       `(:initarg ,(kintern slot-name)))
+					   ))
+				     slot-names slot-initforms slot-types)))
+			    ,(when constructor
+			       (if (eq constructor-args t)
+				   `(defun ,constructor (&rest args)
+				      (apply #',(closintern 'make-instance)
+					     ',name args))
+				   `(defun ,constructor ,constructor-args
+				      (,(closintern 'make-instance) ',name
+				       ,@(mapcan #'(lambda (slot-name)
+						     (and (member slot-name slot-names)
+							  `(,(kintern slot-name) ,slot-name)))
+						 constructor-args)))))
+			    ,(when predicate
+			       `(defun ,predicate (object)
+				  (typep object ',name)))
+			    ,(when copier
+			       `(,(closintern 'defmethod) ,copier ((.object. ,name))
+				 (,(closintern 'with-slots) ,slot-names .object.
+				  (,(closintern 'make-instance) ',name
+				   ,@(mapcan #'(lambda (slot-name)
+						 `(,(kintern slot-name) ,slot-name))
+					     slot-names)))))
+			    ,(when print-function
+			       `(,(closintern 'defmethod)
+				 ,(closintern 'print-object)
+				 ((object ,name) stream)
+				 (,print-function object stream 0)))))
+
+			#+Genera
+			(t
+			 `(within-definition (,name def-clx-class)
+			    (flavor:defflavor ,name
+				    (,@(map 'list
+					    #'(lambda (slot-name slot-initform)
+						`(,slot-name ,slot-initform))
+					    slot-names slot-initforms))
+				    ,(and include `(,include))
+			      :initable-instance-variables
+			      :locatable-instance-variables
+			      :readable-instance-variables
+			      :writable-instance-variables
+			      ,(if constructor
+				   `(:constructor ,constructor
+				     ,(if (eq constructor-args t)
+					  `(&key ,@slot-names)
+					  constructor-args))
+				   :abstract-flavor))
+			    ,(when predicate
+			       `(defun ,predicate (object)
+				  (typep object ',name)))
+			    ,(when copier
+			       (error ":COPIER not supported."))
+			    ,(when print-function
+			       `(flavor:defmethod (sys:print-self ,name)
+						  (stream depth *print-escape*)
+				  (,print-function sys:self stream depth)))
+			    (flavor:compile-flavor-methods ,name))))))))
+	`(within-definition (,name def-clx-class)
+	   (defstruct (,name ,@options)
+	     ,@slots)))))
+
+#+Genera
+(progn
+  (scl:defprop def-clx-class "CLX Class" si:definition-type-name)
+  (scl:defprop def-clx-class zwei:defselect-function-spec-finder
+	       zwei:definition-function-spec-finder))
+
+
+;; We need this here so we can define DISPLAY for CLX.
+;;
+;; This structure is :INCLUDEd in the DISPLAY structure.
+;; Overlapping (displaced) arrays are provided for byte
+;; half-word and word access on both input and output.
+;;
+(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
+  ;; Lock for multi-processing systems
+  (lock (make-process-lock "CLX Buffer Lock"))
+  #-excl (output-stream nil :type (or null stream))
+  #+excl (output-stream -1 :type fixnum)
+  ;; Buffer size
+  (size 0 :type array-index)
+  (request-number 0 :type (unsigned-byte 16))
+  ;; Byte position of start of last request
+  ;; used for appending requests and error recovery
+  (last-request nil :type (or null array-index))
+  ;; Byte position of start of last flushed request
+  (last-flushed-request nil :type (or null array-index))
+  ;; Current byte offset
+  (boffset 0 :type array-index)
+  ;; Byte (8 bit) output buffer
+  (obuf8 *empty-bytes* :type buffer-bytes)
+  ;; Word (16bit) output buffer
+  #+clx-overlapping-arrays
+  (obuf16 *empty-words* :type buffer-words)
+  ;; Long (32bit) output buffer
+  #+clx-overlapping-arrays
+  (obuf32 *empty-longs* :type buffer-longs)
+  ;; Holding buffer for 16-bit text
+  (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
+  ;; Probably EQ to Output-Stream
+  #-excl (input-stream nil :type (or null stream))
+  #+excl (input-stream -1 :type fixnum)
+  ;; T when the host connection has gotten errors
+  (dead nil :type (or null (not null)))
+  ;; T makes buffer-flush a noop.  Manipulated with with-buffer-flush-inhibited.
+  (flush-inhibit nil :type (or null (not null)))
+  
+  ;; Change these functions when using shared memory buffers to the server
+  ;; Function to call when writing the buffer
+  (write-function 'buffer-write-default)
+  ;; Function to call when flushing the buffer
+  (force-output-function 'buffer-force-output-default)
+  ;; Function to call when closing a connection
+  (close-function 'buffer-close-default)
+  ;; Function to call when reading the buffer
+  (input-function 'buffer-read-default)
+  ;; Function to call to wait for data to be input
+  (input-wait-function 'buffer-input-wait-default)
+  ;; Function to call to listen for input data
+  (listen-function 'buffer-listen-default)
+
+  #+Genera (debug-io nil :type (or null stream))
+  ) 
+
+;;-----------------------------------------------------------------------------
+;; Printing routines.
+;;-----------------------------------------------------------------------------
+
+#+(and (not ansi-common-lisp) Genera)
+(import 'future-common-lisp:print-unreadable-object)
+
+#-(or ansi-common-lisp Genera)
+(defun print-unreadable-object-function (object stream type identity function)
+  (princ "#<" stream)
+  (when type
+    (let ((type (type-of object))
+	  (pcl-package (find-package 'pcl)))
+      ;; Handle pcl type-of lossage
+      (when (and pcl-package
+		 (symbolp type)
+		 (eq (symbol-package type) pcl-package)
+		 (string-equal (symbol-name type) "STD-INSTANCE"))
+	(setq type
+	      (funcall (intern (symbol-name 'class-name) pcl-package)
+		       (funcall (intern (symbol-name 'class-of) pcl-package)
+				object))))
+      (prin1 type stream)))
+  (when (and type function) (princ " " stream))
+  (when function (funcall function))
+  (when (and (or type function) identity) (princ " " stream))
+  (when identity (princ "???" stream))
+  (princ ">" stream)
+  nil)
+  
+#-(or ansi-common-lisp Genera)
+(defmacro print-unreadable-object
+	  ((object stream &key type identity) &body body)
+  `(print-unreadable-object-function
+     ,object ,stream ,type ,identity
+     ,(and body `#'(lambda () ,@body))))
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+(defconstant *image-bit-lsb-first-p*
+	     #+clx-little-endian t
+	     #-clx-little-endian nil)
+
+(defconstant *image-byte-lsb-first-p*
+	     #+clx-little-endian t
+	     #-clx-little-endian nil)
+
+(defconstant *image-unit* 32)
+
+(defconstant *image-pad* 32)
diff --git a/clx/dependent.lisp b/clx/dependent.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b8e5a3d752c2a2c5636a1986310e1aaa3870030d
--- /dev/null
+++ b/clx/dependent.lisp
@@ -0,0 +1,3064 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;; This file contains some of the system dependent code for CLX
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+#+lcl3.0
+(import '(
+	  lcl:define-condition
+	  lcl:type-error
+	  lucid::type-error-datum
+	  lucid::type-error-expected-type
+	  sys:underlying-simple-vector))
+
+(export '(
+	  char->card8
+	  card8->char
+	  default-error-handler
+	  #-ansi-common-lisp define-condition))
+
+#+explorer
+(zwei:define-indentation event-case (1 1))
+
+;;; Number of seconds to wait for a reply to a server request
+(defparameter *reply-timeout* nil) 
+
+#-(or clx-overlapping-arrays (not clx-little-endian))
+(progn
+  (defconstant *word-0* 0)
+  (defconstant *word-1* 1)
+
+  (defconstant *long-0* 0)
+  (defconstant *long-1* 1)
+  (defconstant *long-2* 2)
+  (defconstant *long-3* 3))
+
+#-(or clx-overlapping-arrays clx-little-endian)
+(progn
+  (defconstant *word-0* 1)
+  (defconstant *word-1* 0)
+
+  (defconstant *long-0* 3)
+  (defconstant *long-1* 2)
+  (defconstant *long-2* 1)
+  (defconstant *long-3* 0))
+
+;;; Set some compiler-options for often used code
+
+(eval-when (eval compile load)
+
+(defconstant *buffer-speed* 3
+  "Speed compiler option for buffer code.")
+(defconstant *buffer-safety* #+clx-debugging 3 #-clx-debugging 0
+  "Safety compiler option for buffer code.")
+
+(defun declare-bufmac ()
+  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
+
+;;; It's my impression that in lucid there's some way to make a declaration
+;;; called fast-entry or something that causes a function to not do some
+;;; checking on args. Sadly, we have no lucid manuals here.  If such a
+;;; declaration is available, it would be a good idea to make it here when
+;;; *buffer-speed* is 3 and *buffer-safety* is 0.
+(defun declare-buffun ()
+  `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
+
+)
+
+(declaim (inline card8->int8 int8->card8
+		 card16->int16 int16->card16
+		 card32->int32 int32->card32))
+
+#-Genera
+(progn
+
+(defun card8->int8 (x)
+  (declare (type card8 x))
+  (declare (values int8))
+  #.(declare-buffun)
+  (the int8 (if (logbitp 7 x)
+		(the int8 (- x #x100))
+	      x)))
+
+(defun int8->card8 (x)
+  (declare (type int8 x))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (ldb (byte 8 0) x)))
+
+(defun card16->int16 (x)
+  (declare (type card16 x))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16 (if (logbitp 15 x)
+		 (the int16 (- x #x10000))
+		 x)))
+
+(defun int16->card16 (x)
+  (declare (type int16 x))
+  (declare (values card16))
+  #.(declare-buffun)
+  (the card16 (ldb (byte 16 0) x)))
+
+(defun card32->int32 (x)
+  (declare (type card32 x))
+  (declare (values int32))
+  #.(declare-buffun)
+  (the int32 (if (logbitp 31 x)
+		 (the int32 (- x #x100000000))
+		 x)))
+
+(defun int32->card32 (x)
+  (declare (type int32 x))
+  (declare (values card32))
+  #.(declare-buffun)
+  (the card32 (ldb (byte 32 0) x)))
+
+)
+
+#+Genera
+(progn
+
+(defun card8->int8 (x)
+  (declare lt:(side-effects simple reducible))
+  (if (logbitp 7 x) (- x #x100) x))
+
+(defun int8->card8 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 8 0) x))
+
+(defun card16->int16 (x)
+  (declare lt:(side-effects simple reducible))
+  (if (logbitp 15 x) (- x #x10000) x))
+
+(defun int16->card16 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 16 0) x))
+
+(defun card32->int32 (x)
+  (declare lt:(side-effects simple reducible))
+  (sys:%logldb (byte 32 0) x))
+
+(defun int32->card32 (x)
+  (declare lt:(side-effects simple reducible))
+  (ldb (byte 32 0) x))
+
+)
+
+(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
+
+#-(or Genera lcl3.0)
+(progn
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (aref a i)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a i) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int8))
+  #.(declare-buffun)
+  (card8->int8 (aref a i)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a i) (int8->card8 v)))
+
+)
+
+#+Genera
+(progn
+
+(defun aref-card8 (a i)
+  (aref a i))
+
+(defun aset-card8 (v a i)
+  (zl:aset v a i))
+
+(defun aref-int8 (a i)
+  (card8->int8 (aref a i)))
+
+(defun aset-int8 (v a i)
+  (zl:aset (int8->card8 v) a i))
+
+)
+
+#+lcl3.0 ;in lcl2.1 these symbols are in different packages and making too
+         ;many conditionalizations makes my brain hurt.
+(progn
+
+(defun aref-card8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card8))
+  #.(declare-buffun)
+  (the card8 (sys:svref-8bit a i)))
+
+(defun aset-card8 (v a i)
+  (declare (type card8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:svref-8bit a i) v))
+
+(defun aref-int8 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int8))
+  #.(declare-buffun)
+  (the int8 (sys:svref-signed-8bit a i)))
+
+(defun aset-int8 (v a i)
+  (declare (type int8 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (sys:svref-signed-8bit a i) v))
+
+)
+
+#+clx-overlapping-arrays
+(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
+		 aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
+
+#+(and clx-overlapping-arrays Genera)
+(progn
+
+(defun aref-card16 (a i)
+  (aref a i))
+
+(defun aset-card16 (v a i)
+  (zl:aset v a i))
+
+(defun aref-int16 (a i)
+  (card16->int16 (aref a i)))
+
+(defun aset-int16 (v a i)
+  (zl:aset (int16->card16 v) a i)
+  v)
+
+(defun aref-card32 (a i)
+  (int32->card32 (aref a i)))
+
+(defun aset-card32 (v a i)
+  (zl:aset (card32->int32 v) a i))
+
+(defun aref-int32 (a i) (aref a i))
+
+(defun aset-int32 (v a i)
+  (zl:aset v a i))
+
+(defun aref-card29 (a i)
+  (aref a i))
+
+(defun aset-card29 (v a i)
+  (zl:aset v a i))
+
+)
+
+#+(and clx-overlapping-arrays (not Genera))
+(progn
+
+(defun aref-card16 (a i)
+  (aref a i))
+
+(defun aset-card16 (v a i)
+  (setf (aref a i) v))
+
+(defun aref-int16 (a i)
+  (card16->int16 (aref a i)))
+
+(defun aset-int16 (v a i)
+  (setf (aref a i) (int16->card16 v))
+  v)
+
+(defun aref-card32 (a i)
+  (aref a i))
+
+(defun aset-card32 (v a i)
+  (setf (aref a i) v))
+
+(defun aref-int32 (a i)
+  (card32->int32 (aref a i)))
+
+(defun aset-int32 (v a i)
+  (setf (aref a i) (int32->card32 v))
+  v)
+
+(defun aref-card29 (a i)
+  (aref a i))
+
+(defun aset-card29 (v a i)
+  (setf (aref a i) v))
+
+)
+
+#+excl
+(progn
+  
+  (defun aref-card16 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card16))
+    #.(declare-buffun)
+    (the card16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-word)))
+  
+  (defun aset-card16 (v a i)
+    (declare (type card16 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-word) v))
+  
+  (defun aref-int16 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values int16))
+    #.(declare-buffun)
+    (the int16 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			   :signed-word)))
+  
+  (defun aset-int16 (v a i)
+    (declare (type int16 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :signed-word) v))
+  
+  (defun aref-card32 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card32))
+    #.(declare-buffun)
+    (the card32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-long)))
+    
+  (defun aset-card32 (v a i)
+    (declare (type card32 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-long) v))
+
+  (defun aref-int32 (a i)
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values int32))
+    #.(declare-buffun)
+    (the int32 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			   :signed-long)))
+    
+  (defun aset-int32 (v a i)
+    (declare (type int32 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :signed-long) v))
+
+  (defun aref-card29 (a i)
+    ;; Do I need to mask off a few bits here?  XXX
+    (declare (type buffer-bytes a)
+	     (type array-index i))
+    (declare (values card29))
+    #.(declare-buffun)
+    (the card29 (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+			    :unsigned-long)))
+
+  (defun aset-card29 (v a i)
+    (declare (type card29 v)
+	     (type buffer-bytes a)
+	     (type array-index i))
+    #.(declare-buffun)
+    (setf (sys:memref a #.(comp::mdparam 'comp::md-svector-data0-adj) i
+		      :unsigned-long) v))
+
+  
+)
+
+#+lcl3.0
+(progn ;; all these lucid optimizations need to be compiled to work.
+
+(defun aref-card16 (a i)
+  #.(declare-buffun)
+  (the card16 (sys:svref-16bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -1))))
+  
+(defun aset-card16 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-16bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -1))
+	(the card16 v)))
+  
+(defun aref-int16 (a i)
+  #.(declare-buffun)
+  (the int16 
+       (sys:svref-signed-16bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -1))))
+  
+(defun aset-int16 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-signed-16bit (the buffer-bytes a)
+				(lucid:ash& (the array-index i) -1))
+	(the int16 v)))
+
+(defun aref-card32 (a i)
+  #.(declare-buffun)
+  (the card32
+       (sys:svref-32bit (the buffer-bytes a)
+			(lucid:ash& (the array-index i) -2))))
+    
+(defun aset-card32 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-32bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -2))
+	(the card32 v)))
+
+(defun aref-int32 (a i)
+  #.(declare-buffun)
+  (the int32
+       (sys:svref-signed-32bit (the buffer-bytes a)
+			       (lucid:ash& (the array-index i) -2))))
+    
+(defun aset-int32 (v a i)
+  #.(declare-buffun)
+  (setf (sys:svref-signed-32bit (the buffer-bytes a)
+				(lucid:ash& (the array-index i) -2))
+	(the int32 v)))
+
+(defun aref-card29 (a i)
+  ;; Don't need to mask bits here since X protocol guarantees top bits zero
+  #.(declare-buffun)
+  (the card29
+       (sys:svref-32bit (the buffer-bytes a)
+			(lucid:ash& (the array-index i) -2))))
+
+(defun aset-card29 (v a i)
+  ;; I also assume here Lisp is passing a number that fits in 29 bits.
+  #.(declare-buffun)
+  (setf (sys:svref-32bit (the buffer-bytes a)
+			 (lucid:ash& (the array-index i) -2))
+	(the card29 v)))
+)
+
+
+
+#-(or excl lcl3.0 clx-overlapping-arrays)
+(progn
+
+(defun aref-card16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card16))
+  #.(declare-buffun)
+  (the card16
+       (logior (the card16
+		    (ash (the card8 (aref a (index+ i *word-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *word-0*))))))
+
+(defun aset-card16 (v a i)
+  (declare (type card16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-int16 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16
+       (logior (the int16
+		    (ash (the int8 (aref-int8 a (index+ i *word-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *word-0*))))))
+
+(defun aset-int16 (v a i)
+  (declare (type int16 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *word-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *word-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-card32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card32))
+  #.(declare-buffun)
+  (the card32
+       (logior (the card32
+		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-card32 (v a i)
+  (declare (type card32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-int32 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values int32))
+  #.(declare-buffun)
+  (the int32
+       (logior (the int32
+		    (ash (the int8 (aref-int8 a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-int32 (v a i)
+  (declare (type int32 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+(defun aref-card29 (a i)
+  (declare (type buffer-bytes a)
+	   (type array-index i))
+  (declare (values card29))
+  #.(declare-buffun)
+  (the card29
+       (logior (the card29
+		    (ash (the card8 (aref a (index+ i *long-3*))) 24))
+	       (the card29
+		    (ash (the card8 (aref a (index+ i *long-2*))) 16))
+	       (the card16
+		    (ash (the card8 (aref a (index+ i *long-1*))) 8))
+	       (the card8
+		    (aref a (index+ i *long-0*))))))
+
+(defun aset-card29 (v a i)
+  (declare (type card29 v)
+	   (type buffer-bytes a)
+	   (type array-index i))
+  #.(declare-buffun)
+  (setf (aref a (index+ i *long-3*)) (the card8 (ldb (byte 8 24) v))
+	(aref a (index+ i *long-2*)) (the card8 (ldb (byte 8 16) v))
+	(aref a (index+ i *long-1*)) (the card8 (ldb (byte 8 8) v))
+	(aref a (index+ i *long-0*)) (the card8 (ldb (byte 8 0) v)))
+  v)
+
+)
+
+(defsetf aref-card8 (a i) (v)
+  `(aset-card8 ,v ,a ,i))
+
+(defsetf aref-int8 (a i) (v)
+  `(aset-int8 ,v ,a ,i))
+
+(defsetf aref-card16 (a i) (v)
+  `(aset-card16 ,v ,a ,i))
+
+(defsetf aref-int16 (a i) (v)
+  `(aset-int16 ,v ,a ,i))
+
+(defsetf aref-card32 (a i) (v)
+  `(aset-card32 ,v ,a ,i))
+
+(defsetf aref-int32 (a i) (v)
+  `(aset-int32 ,v ,a ,i))
+
+(defsetf aref-card29 (a i) (v)
+  `(aset-card29 ,v ,a ,i))
+
+;;; Other random conversions
+
+(defun rgb-val->card16 (value)
+  ;; Short floats are good enough
+  (declare (type rgb-val value))
+  (declare (values card16))
+  #.(declare-buffun)
+  ;; Convert VALUE from float to card16
+  (the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
+
+(defun card16->rgb-val (value) 
+  ;; Short floats are good enough
+  (declare (type card16 value))
+  (declare (values short-float))
+  #.(declare-buffun)
+  ;; Convert VALUE from card16 to float
+  (the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
+
+(defun radians->int16 (value)
+  ;; Short floats are good enough
+  (declare (type angle value))
+  (declare (values int16))
+  #.(declare-buffun)
+  (the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
+
+(defun int16->radians (value)
+  ;; Short floats are good enough
+  (declare (type int16 value))
+  (declare (values short-float))
+  #.(declare-buffun)
+  (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
+
+
+;;-----------------------------------------------------------------------------
+;; Character transformation
+;;-----------------------------------------------------------------------------
+
+
+;;; This stuff transforms chars to ascii codes in card8's and back.
+;;; You might have to hack it a little to get it to work for your machine.
+
+(declaim (inline char->card8 card8->char))
+
+(macrolet ((char-translators ()
+	     (let ((alist
+		     `(#-lispm
+		       ;; The normal ascii codes for the control characters.
+		       ,@`((#\Return . 13)
+			   (#\Linefeed . 10)
+			   (#\Rubout . 127)
+			   (#\Page . 12)
+			   (#\Tab . 9)
+			   (#\Backspace . 8)
+			   (#\Newline . 10)
+			   (#\Space . 32))
+		       ;; One the lispm, #\Newline is #\Return, but we'd really like
+		       ;; #\Newline to translate to ascii code 10, so we swap the
+		       ;; Ascii codes for #\Return and #\Linefeed. We also provide
+		       ;; mappings from the counterparts of these control characters
+		       ;; so that the character mapping from the lisp machine
+		       ;; character set to ascii is invertible.
+		       #+lispm
+		       ,@`((#\Return . 10)   (,(code-char  10) . ,(char-code #\Return))
+			   (#\Linefeed . 13) (,(code-char  13) . ,(char-code #\Linefeed))
+			   (#\Rubout . 127)  (,(code-char 127) . ,(char-code #\Rubout))
+			   (#\Page . 12)     (,(code-char  12) . ,(char-code #\Page))
+			   (#\Tab . 9)       (,(code-char   9) . ,(char-code #\Tab))
+			   (#\Backspace . 8) (,(code-char   8) . ,(char-code #\Backspace))
+			   (#\Newline . 10)  (,(code-char  10) . ,(char-code #\Newline))
+			   (#\Space . 32)    (,(code-char  32) . ,(char-code #\Space)))
+		       ;; The rest of the common lisp charater set with the normal
+		       ;; ascii codes for them.
+		       (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
+		       (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
+		       (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
+		       (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
+		       (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
+		       (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
+		       (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
+		       (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
+		       (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
+		       (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
+		       (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
+		       (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
+		       (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
+		       (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
+		       (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
+		       (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
+		       (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
+		       (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
+		       (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
+		       (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
+		       (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
+		       (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
+		       (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
+		       (#\} . 125) (#\~ . 126))))
+	       (cond ((dolist (pair alist nil)
+			(when (not (= (char-code (car pair)) (cdr pair)))
+			  (return t)))
+		      `(progn
+			 (defconstant *char-to-card8-translation-table*
+				      ',(let ((array (make-array
+						       (let ((max-char-code 255))
+							 (dolist (pair alist)
+							   (setq max-char-code
+								 (max max-char-code
+								      (char-code (car pair)))))
+							 (1+ max-char-code))
+						       :element-type 'card8)))
+					  (dotimes (i (length array))
+					    (setf (aref array i) (mod i 256)))
+					  (dolist (pair alist)
+					    (setf (aref array (char-code (car pair)))
+						  (cdr pair)))
+					  array))
+			 (defconstant *card8-to-char-translation-table*
+				      ',(let ((array (make-string 256)))
+					  (dotimes (i (length array))
+					    (setf (aref array i) (code-char i)))
+					  (dolist (pair alist)
+					    (setf (aref array (cdr pair)) (car pair)))
+					  array))
+			 #-Genera
+			 (progn
+  			   (defun char->card8 (char)
+			     (declare (type string-char char))
+			     #.(declare-buffun)
+			     (the card8 (aref (the (simple-array card8 (*))
+						   *char-to-card8-translation-table*)
+					      (the array-index (char-code char)))))
+			   (defun card8->char (card8)
+			     (declare (type card8 card8))
+			     #.(declare-buffun)
+			     (the string-char
+				  (aref (the simple-string *card8-to-char-translation-table*)
+					card8)))
+			   )
+			 #+Genera
+			 (progn
+			   (defun char->card8 (char)
+			     (declare lt:(side-effects reader reducible))
+			     (aref *char-to-card8-translation-table* (char-code char)))
+			   (defun card8->char (card8)
+			     (declare lt:(side-effects reader reducible))
+			     (aref *card8-to-char-translation-table* card8))
+			   )
+			 (dotimes (i 256)
+			   (unless (= i (char->card8 (card8->char i)))
+			     (warn "The card8->char mapping is not invertible through char->card8.  Info:~%~S"
+				   (list i
+					 (card8->char i)
+					 (char->card8 (card8->char i))))
+			     (return nil)))
+			 (dotimes (i (length *char-to-card8-translation-table*))
+			   (let ((char (code-char i)))
+			     (unless (eql char (card8->char (char->card8 char)))
+			       (warn "The char->card8 mapping is not invertible through card8->char.  Info:~%~S"
+				     (list char
+					   (char->card8 char)
+					   (card8->char (char->card8 char))))
+			       (return nil))))))
+		     (t
+		      `(progn
+			 (defun char->card8 (char)
+			   (declare (type string-char char))
+			   #.(declare-buffun)
+			   (the card8 (char-code char)))
+			 (defun card8->char (card8)
+			   (declare (type card8 card8))
+			   #.(declare-buffun)
+			   (the string-char (code-char card8)))
+			 ))))))
+  (char-translators))
+
+;;-----------------------------------------------------------------------------
+;; Process Locking
+;;
+;;	Common-Lisp doesn't provide process locking primitives, so we define
+;;	our own here, based on Zetalisp primitives.  Holding-Lock is very
+;;	similar to with-lock on The TI Explorer, and a little more efficient
+;;	than with-process-lock on a Symbolics.
+;;-----------------------------------------------------------------------------
+
+;;; MAKE-PROCESS-LOCK: Creating a process lock.
+
+#-(or LispM excl)
+(defun make-process-lock (name)
+  (declare (ignore name))
+  nil)
+
+#+excl
+(defun make-process-lock (name)
+  (mp:make-process-lock :name name))
+
+#+(and LispM (not Genera))
+(defun make-process-lock (name)
+  (vector nil name))
+
+#+Genera
+(defun make-process-lock (name)
+  (process:make-lock name :flavor 'clx-lock))
+
+;;; HOLDING-LOCK: Execute a body of code with a lock held.
+
+;;; The holding-lock macro takes a timeout keyword argument.  EVENT-LISTEN
+;;; passes its timeout to the holding-lock macro, so any timeout you want to
+;;; work for event-listen you should do for holding-lock.
+
+;; If you're not sharing DISPLAY objects within a multi-processing
+;; shared-memory environment, this is sufficient
+#-(or lispm excl lcl3.0)
+(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
+  (declare (ignore locator display whostate timeout))
+  `(progn ,@body))
+
+#+Genera
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore whostate))
+  `(process:with-lock (,locator :timeout ,timeout)
+     (let ((.debug-io. (buffer-debug-io ,display)))
+       (scl:let-if .debug-io. ((*debug-io* .debug-io.))
+	 ,@body))))
+
+#+(and lispm (not Genera))
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  ;; This macro is for use in a multi-process environment.
+  (let ((lock (gensym))
+	(have-lock (gensym))
+	(timeo (gensym)))
+    `(let* ((,lock (zl:locf (svref ,locator 0)))
+	    (,have-lock (eq (car ,lock) sys:current-process))
+	    (,timeo ,timeout))
+       (unwind-protect 
+	   (when (cond (,have-lock)
+		       ((#+explorer si:%store-conditional
+			 #-explorer sys:store-conditional
+			 ,lock nil sys:current-process))
+		       ((null ,timeo)
+			(sys:process-lock ,lock nil ,(or whostate "CLX Lock")))
+		       ((sys:process-wait-with-timeout
+			    ,(or whostate "CLX Lock") (round (* ,timeo 60.))
+			  #'(lambda (lock process)
+			      (#+explorer si:%store-conditional
+			       #-explorer sys:store-conditional
+			       lock nil process))
+			  ,lock sys:current-process)))
+	     ,@body)
+	 (unless ,have-lock
+	   (#+explorer si:%store-conditional
+	    #-explorer sys:store-conditional
+	    ,lock sys:current-process nil))))))
+
+;; Lucid has a process locking mechanism as well under release 3.0
+#+lcl3.0
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  (if timeout
+      ;; Hair to support timeout.
+      `(let ((.have-lock. (eq ,locator lcl:*current-process*))
+	     (.timeout. ,timeout))
+	 (unwind-protect
+	     (when (cond (.have-lock.)
+			 ((conditional-store ,locator nil lcl:*current-process*))
+			 ((null .timeout.)
+			  (lcl:process-lock ,locator)
+			  t)
+			 ((lcl:process-wait-with-timeout ,whostate .timeout.
+			    #'(lambda ()
+				(conditional-store ,locator nil lcl:*current-process*)))))
+	       ,@body)
+	   (unless .have-lock. 
+	     (lcl:process-unlock ,locator))))
+    `(lcl:with-process-lock (,locator)
+       ,@body)))
+
+
+#+excl
+(defmacro holding-lock ((locator display &optional whostate &key timeout)
+			&body body)
+  (declare (ignore display))
+  `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
+     (unwind-protect
+	 (block .hl-doit.
+	   (when mp::*scheduler-stack-group* ; fast test for scheduler running
+	     (setq .hl-lock. ,locator
+		   .hl-curproc. mp::*current-process*)
+	     (when (and .hl-curproc.	; nil if in process-wait fun
+			(not (eq (mp::process-lock-locker .hl-lock.)
+				 .hl-curproc.)))
+	       ;; Then we need to grab the lock.
+	       ,(if timeout
+		    `(if (not (mp::process-lock .hl-lock. .hl-curproc.
+						,whostate ,timeout))
+			 (return-from .hl-doit. nil))
+		  `(mp::process-lock .hl-lock. .hl-curproc.
+				     ,@(when whostate `(,whostate))))
+	       (setq .hl-obtained-lock. t)))
+	   ,@body)
+       (if (and .hl-obtained-lock.
+		;; Note -- next form added to allow error handler inside
+		;; body to unlock the lock prematurely if it knows that
+		;; the current process cannot possibly continue but will
+		;; throw out (or is it throw up?).
+		(eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
+	   (mp::process-unlock .hl-lock. .hl-curproc.)))))
+
+
+;;; WITHOUT-ABORTS
+
+;;; If you can inhibit asynchronous keyboard aborts inside the body of this
+;;; macro, then it is a good idea to do this.  This macro is wrapped around
+;;; request writing and reply reading to ensure that requests are atomically
+;;; written and replies are atomically read from the stream.
+
+#-(or Genera excl lcl3.0)
+(defmacro without-aborts (&body body)
+  `(progn ,@body))
+
+#+Genera
+(defmacro without-aborts (&body body)
+  `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
+     ,@body))
+
+#+excl
+(defmacro without-aborts (&body body)
+  `(without-interrupts ,@body))
+    
+#+lcl3.0
+(defmacro without-aborts (&body body)
+  `(lcl:with-interruptions-inhibited ,@body))
+
+;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
+;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
+;;; value changes.
+
+#-(or lispm excl lcl3.0)
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (ignore whostate))
+  (or (apply predicate predicate-args)
+      (error "Program tried to wait with no scheduler.")))
+
+#+Genera
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (apply #'process:block-process whostate predicate predicate-args))
+
+#+(and lispm (not Genera))
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (apply #'global:process-wait whostate predicate predicate-args))
+
+#+excl
+(defun process-block (whostate predicate &rest predicate-args)
+  (if mp::*scheduler-stack-group*
+      (apply #'mp::process-wait whostate predicate predicate-args)
+      (or (apply predicate predicate-args)
+	  (error "Program tried to wait with no scheduler."))))
+
+#+lcl3.0
+(defun process-block (whostate predicate &rest predicate-args)
+  (declare (dynamic-extent predicate-args))
+  (apply #'lcl:process-wait whostate predicate predicate-args))
+
+;;; PROCESS-WAKEUP: Check some other process' wait function.
+
+(declaim (inline process-wakeup))
+
+#-(or excl Genera)
+(defun process-wakeup (process)
+  (declare (ignore process))
+  nil)
+
+#+excl
+(defun process-wakeup (process)
+  (let ((curproc mp::*current-process*))
+    (when (and curproc process)
+      (unless (mp::process-p curproc)
+	(error "~s is not a process" curproc))
+      (unless (mp::process-p process)
+	(error "~s is not a process" process))
+      (if (> (mp::process-priority process) (mp::process-priority curproc))
+	  (mp::process-allow-schedule process)))))
+
+#+Genera
+(defun process-wakeup (process)
+  (process:wakeup process))
+
+;;; CURRENT-PROCESS: Return the current process object for input locking and
+;;; for calling PROCESS-WAKEUP.
+
+(declaim (inline current-process))
+
+;;; Default return NIL, which is acceptable even if there is a scheduler.
+
+#-(or lispm excl lcl3.0)
+(defun current-process ()
+  nil)
+
+#+lispm
+(defun current-process ()
+  sys:current-process)
+
+#+excl
+(defun current-process ()
+  (and mp::*scheduler-stack-group*
+       mp::*current-process*))
+
+#+lcl3.0
+(defun current-process ()
+  lcl:*current-process*)
+
+;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
+
+#-(or lispm excl lcl3.0)
+(defmacro without-interrupts (&body body)
+  `(progn ,@body))
+
+#+(and lispm (not Genera))
+(defmacro without-interrupts (&body body)
+  `(sys:without-interrupts ,@body))
+
+#+Genera
+(defmacro without-interrupts (&body body)
+  `(process:with-no-other-processes ,@body))
+
+#+LCL3.0
+(defmacro without-interrupts (&body body)
+  `(lcl:with-scheduling-inhibited ,@body))
+
+;;; CONDITIONAL-STORE:
+
+;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
+;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
+(defmacro conditional-store (place old-value new-value)
+  `(without-interrupts
+     (cond ((eq ,place ,old-value)
+	    (setf ,place ,new-value)
+	    t))))
+
+;;;----------------------------------------------------------------------------
+;;; IO Error Recovery
+;;;	All I/O operations are done within a WRAP-BUF-OUTPUT macro.
+;;;	It prevents multiple mindless errors when the network craters.
+;;;
+;;;----------------------------------------------------------------------------
+
+#-Genera
+(defmacro wrap-buf-output ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(unless (buffer-dead ,buffer)
+     ,@body))
+
+#+Genera
+(defmacro wrap-buf-output ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(let ((.buffer. ,buffer))
+     (unless (buffer-dead .buffer.)
+       (scl:condition-bind
+	 (((sys:network-error)
+	   #'(lambda (error)
+	       (scl:condition-case () 
+		    (funcall (buffer-close-function .buffer.) .buffer. :abort t)
+		  (sys:network-error))
+	       (setf (buffer-dead .buffer.) error)
+	       (setf (buffer-output-stream .buffer.) nil)
+	       (setf (buffer-input-stream .buffer.) nil)
+	       nil)))
+	 ,@body))))
+
+#-Genera
+(defmacro wrap-buf-input ((buffer) &body body)
+  (declare (ignore buffer))
+  ;; Error recovery wrapper
+  `(progn ,@body))
+
+#+Genera
+(defmacro wrap-buf-input ((buffer) &body body)
+  ;; Error recovery wrapper
+  `(let ((.buffer. ,buffer))
+     (scl:condition-bind
+       (((sys:network-error)
+	 #'(lambda (error)
+	     (scl:condition-case () 
+		  (funcall (buffer-close-function .buffer.) .buffer. :abort t)
+		(sys:network-error))
+	     (setf (buffer-dead .buffer.) error)
+	     (setf (buffer-output-stream .buffer.) nil)
+	     (setf (buffer-input-stream .buffer.) nil)
+	     nil)))
+       ,@body)))
+
+
+;;;----------------------------------------------------------------------------
+;;; System dependent IO primitives
+;;;	Functions for opening, reading writing forcing-output and closing 
+;;;	the stream to the server.
+;;;----------------------------------------------------------------------------
+
+;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
+;;; server
+
+#-(or explorer Genera lucid kcl ibcl excl)
+(defun open-x-stream (host display protocol)
+  host display protocol ;; unused
+  (error "OPEN-X-STREAM not implemented yet."))
+
+;;; Genera:
+
+;;; TCP and DNA are both layered products, so try to work with either one.
+
+#+Genera
+(when (fboundp 'tcp:add-tcp-port-for-protocol)
+  (tcp:add-tcp-port-for-protocol :x-window-system 6000))
+
+#+Genera
+(when (fboundp 'dna:add-dna-contact-id-for-protocol)
+  (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))
+
+#+Genera
+(net:define-protocol :x-window-system (:x-window-system :byte-stream)
+  (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
+    stream))
+
+#+Genera
+(eval-when (compile)
+  (compiler:function-defined 'tcp:open-tcp-stream)
+  (compiler:function-defined 'dna:open-dna-bidirectional-stream))
+
+#+Genera
+(defun open-x-stream (host display protocol)
+  (let ((host (net:parse-host host)))
+    (if (or protocol (plusp display))
+	;; The protocol was specified or the display isn't 0, so we
+	;; can't use the Generic Network System.  If the protocol was
+	;; specified, then use that protocol, otherwise, blindly use
+	;; TCP.
+	(ccase protocol
+	  ((:tcp nil)
+	   (tcp:open-tcp-stream
+	     host (+ *x-tcp-port* display) nil
+	     :direction :io
+	     :characters nil
+	     :ascii-translation nil))
+	  ((:dna)
+	   (dna:open-dna-bidirectional-stream
+	     host (format nil "X$X~D" display)
+	     :characters nil
+	     :ascii-translation nil)))
+      (let ((neti:*invoke-service-automatic-retry* t))
+	(net:invoke-service-on-host :x-window-system host)))))
+
+#+explorer
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol))
+  (net:open-connection-on-medium
+    (net:parse-host host)			;Host
+    :byte-stream				;Medium
+    "X11"					;Logical contact name
+    :stream-type :character-stream
+    :direction :bidirectional
+    :timeout-after-open nil
+    :remote-port (+ *x-tcp-port* display)))
+
+#+explorer
+(net:define-logical-contact-name
+  "X11"
+  `((:local "X11")
+    (:chaos "X11")
+    (:nsp-stream "X11")
+    (:tcp ,*x-tcp-port*)))
+
+#+lucid
+(defun open-x-stream (host display protocol)
+  protocol ;; unused
+  (let ((fd (connect-to-server host display)))
+    (when (minusp fd)
+      (error "Failed to connect to server: ~A ~D" host display))
+    (user::make-lisp-stream :input-handle fd
+			    :output-handle fd
+			    :element-type 'unsigned-byte
+			    #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))
+
+#+(or kcl ibcl)
+(defun open-x-stream (host display protocol)
+  protocol ;; unused
+  (let ((stream (open-socket-stream host display)))
+    (if (streamp stream)
+	stream
+      (error "Cannot connect to server: ~A:~D" host display))))
+
+#+excl
+;;
+;; Note that since we don't use the CL i/o facilities to do i/o, the display
+;; input and output "stream" is really a file descriptor (fixnum).
+;;
+(defun open-x-stream (host display protocol)
+  (declare (ignore protocol));; unused
+  (let ((fd (connect-to-server (string host) display)))
+    (when (minusp fd)
+      (error "Failed to connect to server: ~A ~D" host display))
+    fd))
+
+;;; BUFFER-READ-DEFAULT - read data from the X stream
+
+#+(or Genera explorer)
+(defun buffer-read-default (display vector start end timeout)
+  ;; returns non-NIL if EOF encountered
+  ;; Returns :TIMEOUT when timeout exceeded
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (or (cond ((null stream))
+	      ((funcall stream :listen) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(multiple-value-bind (ignore eofp)
+	    (funcall stream :string-in nil vector start end)
+	  eofp))))
+
+
+#+excl
+;;
+;; Rewritten 10/89 to not use foreign function interface to do I/O.
+;;
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout))
+  #.(declare-buffun)
+    
+  (let* ((howmany (- end start))
+	 (fd (display-input-stream display)))
+    (declare (type array-index howmany)
+	     (fixnum fd))
+	  
+    (or (cond ((fd-char-avail-p fd) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(fd-read-bytes fd vector start howmany))))
+
+
+#+lcl3.0
+(defmacro extract-underlying-stream (stream display direction)
+  ;;;Our job is to quickly get at the underlying stream for this display's
+  ;;;input stream structure.
+  `(or (getf (display-plist ,display) ,direction)
+       (setf (getf (display-plist ,display) ,direction)
+	     (lucid::underlying-stream
+	       ,stream (if (eq ,direction 'input) :input :output)))))
+
+#+lcl3.0
+(defun buffer-read-default (display vector start end timeout)
+  ;;Note that LISTEN must still be done on "slow stream" or the I/O system
+  ;;gets confused.  But reading should be done from "fast stream" for speed.
+  ;;We used to inhibit scheduling because there were races in Lucid's 
+  ;;multitasking system.  Empirical evidence suggests they may be gone now.
+  ;;Should you decide you need to inhibit scheduling, do it around the do*.
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null number) timeout)
+	   (optimize (speed 3)
+		     (safety 0)))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(let ((stream (extract-underlying-stream stream display 'input)))
+	  (do* ((index start (index1+ index)))
+	       ((index>= index end) nil)
+	    (declare (type array-index index))
+	    (let ((c (lcl:fast-read-byte stream (unsigned-byte 8) nil nil)))
+	      (declare (type (or null card8) c))
+	      (if (null c)
+		  (return t)
+		  (setf (aref vector index) (the card8 c)))))))))
+
+
+
+;;; WARNING:
+;;;	CLX performance will suffer if your lisp uses read-byte for
+;;;	receiving all data from the X Window System server.
+;;;	You are encouraged to write a specialized version of
+;;;	buffer-read-default that does block transfers.
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (type (or null (rational 0 *) (float 0.0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+	      ((listen stream) nil)
+	      ((eql timeout 0) :timeout)
+	      ((buffer-input-wait-default display timeout)))
+	(do* ((index start (index1+ index)))
+	     ((index>= index end) nil)
+	  (declare (type array-index index))
+	  (let ((c (read-byte stream nil nil)))
+	    (declare (type (or null card8) c))
+	    (if (null c)
+		(return t)
+	      (setf (aref vector index) (the card8 c))))))))
+
+;;; BUFFER-WRITE-DEFAULT - write data to the X stream
+
+#+(or Genera explorer)
+(defun buffer-write-default (vector display start end)
+  ;; The default buffer write function for use with common-lisp streams
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream) 
+      (write-string vector stream :start start :end end))))
+
+#+excl
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (excl::filesys-write-bytes (display-output-stream display) vector start
+			     (- end start)))
+  
+#+lcl3.0
+(defun buffer-write-default (vector display start end)
+  ;;We inhibit scheduling here because there seem to be races in Lucid's
+  ;;multitasking implementation.  Anyway, when we take it out we get bugs!
+  (declare (type display display)
+	   (type buffer-bytes vector)
+	   (type array-index start end)
+	   (optimize (:tail-merge nil)
+		     (speed 3)
+		     (safety 0)))
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream) 
+      (let ((stream (extract-underlying-stream stream display 'output)))
+	(lcl:with-scheduling-inhibited
+          (lcl:write-array stream vector start end))))))
+
+;;; WARNING:
+;;;	CLX performance will be severely degraded if your lisp uses
+;;;	write-byte to send all data to the X Window System server.
+;;;	You are STRONGLY encouraged to write a specialized version
+;;;	of buffer-write-default that does block transfers.
+
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-write-default (vector display start end)
+  ;; The default buffer write function for use with common-lisp streams
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (with-vector (vector buffer-bytes)
+	(do ((index start (index1+ index)))
+	    ((index>= index end))
+	  (declare (type array-index index))
+	  (write-byte (aref vector index) stream))))))
+
+;;; buffer-force-output-default - force output to the X stream
+
+#+excl
+(defun buffer-force-output-default (display)
+  ;; buffer-write-default does the actual writing.
+  (declare (ignore display)))
+
+#-excl
+(defun buffer-force-output-default (display)
+  ;; The default buffer force-output function for use with common-lisp streams
+  (declare (type display display))
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (force-output stream))))
+
+;;; BUFFER-CLOSE-DEFAULT - close the X stream
+
+#+excl
+(defun buffer-close-default (display &key abort)
+  ;; The default buffer close function for use with common-lisp streams
+  (declare (type display display)
+	   (ignore abort))
+  #.(declare-buffun)
+  (excl::filesys-checking-close (display-output-stream display)))
+
+#-excl
+(defun buffer-close-default (display &key abort)
+  ;; The default buffer close function for use with common-lisp streams
+  (declare (type display display))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (close stream :abort abort))))
+
+;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
+;;; buffer.  This is called in read-input between requests, so that a process
+;;; waiting for input is abortable when between requests.  Should return
+;;; :TIMEOUT if it times out, NIL otherwise.
+
+;;; The default implementation
+
+;; Poll for input every *buffer-read-polling-time* SECONDS.
+#-(or Genera explorer excl lcl3.0)
+(defparameter *buffer-read-polling-time* 0.5)
+
+#-(or Genera explorer excl lcl3.0)
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((eql timeout 0) :timeout)
+	  ((not (null timeout))
+	   (multiple-value-bind (npoll fraction)
+	       (truncate timeout *buffer-read-polling-time*)
+	     (dotimes (i npoll)			; Sleep for a time, then listen again
+	       (sleep *buffer-read-polling-time*)
+	       (when (listen stream)
+		 (return-from buffer-input-wait-default nil)))
+	     (when (plusp fraction)
+	       (sleep fraction)			; Sleep a fraction of a second
+	       (when (listen stream)		; and listen one last time
+		 (return-from buffer-input-wait-default nil)))
+	     :timeout)))))
+
+#+Genera
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((scl:send stream :listen) nil)
+	  ((eql timeout 0) :timeout)
+	  ((null timeout) (si:stream-input-block stream "CLX Input"))
+	  (t
+	   (scl:condition-bind ((neti:protocol-timeout
+				  #'(lambda (error)
+				      (when (eq stream (scl:send error :stream))
+					(return-from buffer-input-wait-default :timeout)))))
+	     (neti:with-stream-timeout (stream :input timeout)
+	       (si:stream-input-block stream "CLX Input")))))
+    nil))
+
+#+explorer
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((zl:send stream :listen) nil)
+	  ((eql timeout 0) :timeout)
+	  ((null timeout)
+	   (si:process-wait "CLX Input" stream :listen))
+	  (t
+	   (unless (si:process-wait-with-timeout
+		       "CLX Input" (round (* timeout 60.)) stream :listen)
+	     (return-from buffer-input-wait-default :timeout))))
+    nil))
+
+#+excl
+;;
+;; This is used so an 'eq' test may be used to find out whether or not we can
+;; safely throw this process out of the CLX read loop.
+;;
+(defparameter *read-whostate* "blocked on read from X server")
+
+;;
+;; Note that this function returns nil on error if the scheduler is running,
+;; t on error if not.  This is ok since buffer-read will detect the error.
+;;
+#+excl
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout))
+  (declare (values timeout))
+  (let ((fd (display-input-stream display)))
+    (declare (fixnum fd))
+    (when (>= fd 0)
+      (cond ((fd-char-avail-p fd)
+	     nil)
+	    
+	    ;; Otherwise no bytes were available on the socket
+	    ((and timeout (zerop timeout))
+	     ;; If there aren't enough and timeout == 0, timeout.
+	     :timeout)
+	  
+	    ;; If the scheduler is running let it do timeouts.
+	    (mp::*scheduler-stack-group*
+	     #+allegro
+	     (if (not
+		  (mp:wait-for-input-available fd :whostate *read-whostate*
+					       :wait-function #'fd-char-avail-p
+					       :timeout timeout))
+		 (return-from buffer-input-wait-default :timeout))
+	     #-allegro
+	     (mp::wait-for-input-available fd :whostate *read-whostate*
+					   :wait-function #'fd-char-avail-p))
+	    
+	    ;; Otherwise we have to handle timeouts by hand, and call select()
+	    ;; to block until input is available.  Note we don't really handle
+	    ;; the interaction of interrupts and (numberp timeout) here.  XX
+	    (t
+	     (let ((res 0))
+	       (declare (fixnum res))
+	       (with-interrupt-checking-on
+		(loop
+		  (setq res (fd-wait-for-input fd (if (null timeout) 0
+						    (truncate timeout))))
+		  (cond ((plusp res)	; success
+			 (return nil))
+			((eq res 0)	; timeout
+			 (return :timeout))
+			((eq res -1)	; error
+			 (return t))
+			;; Otherwise we got an interrupt -- go around again.
+			)))))))))
+
+	   
+#+lcl3.0
+(defun buffer-input-wait-default (display timeout)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (optimize (speed 3) (safety 0)))
+  (declare (values timeout))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (cond ((null stream))
+	  ((listen stream) nil)
+	  ((eql timeout 0) :timeout)
+	  ((let ((stream (extract-underlying-stream stream display 'input)))
+	     (lucid::waiting-for-input-from-stream stream
+               (lucid::with-io-unlocked
+		 (if (null timeout)
+		     (lcl:process-wait "CLX Input" #'listen stream)
+		   (lcl:process-wait-with-timeout
+		     "CLX Input" timeout #'listen stream)))))
+	   nil)
+	  (:timeout))))
+
+
+;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
+;;; buffer. This should never block, so it can be called from the scheduler.
+
+;;; The default implementation is to just use listen.
+#-excl
+(defun buffer-listen-default (display)
+  (declare (type display display))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (if (null stream)
+	t
+      (listen stream))))
+
+#+excl 
+(defun buffer-listen-default (display)
+  (declare (type display display))
+  (let ((fd (display-input-stream display)))
+    (declare (type fixnum fd))
+    (if (= fd -1)
+	t
+      (fd-char-avail-p fd))))
+
+
+;;;----------------------------------------------------------------------------
+;;; System dependent speed hacks
+;;;----------------------------------------------------------------------------
+
+;;
+;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
+;; If your lisp doesn't have stack-lists, and you're worried about
+;; consing garbage, you may want to re-write this to allocate and
+;; initialize lists from a resource.
+;;
+#+lispm
+(defmacro with-stack-list ((var &rest elements) &body body)
+  `(sys:with-stack-list (,var ,@elements) ,@body))
+
+#+lispm
+(defmacro with-stack-list* ((var &rest elements) &body body)
+  `(sys:with-stack-list* (,var ,@elements) ,@body))
+
+#-lispm
+(defmacro with-stack-list ((var &rest elements) &body body)
+  ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
+  ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
+  ;; except that the list produced by MAPCAR resides on the stack and
+  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
+  `(let ((,var (list ,@elements))) ,@body))
+
+#-lispm
+(defmacro with-stack-list* ((var &rest elements) &body body)
+  ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
+  ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
+  ;; except that the list produced by MAPCAR resides on the stack and
+  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
+  `(let ((,var (list* ,@elements))) ,@body))
+
+(declaim (inline buffer-replace))
+
+#+lispm
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type vector buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))
+
+#+excl
+(defun buffer-replace (target-sequence source-sequence target-start
+				       target-end &optional (source-start 0))
+  (declare (type buffer-bytes target-sequence source-sequence)
+	   (type array-index target-start target-end source-start)
+	   (optimize (speed 3) (safety 0)))
+  
+  (let ((source-end (length source-sequence)))
+    (declare (type array-index source-end))
+    
+    (if* (and (eq target-sequence source-sequence)
+	      (> target-start source-start))
+       then (let ((nelts (min (- target-end target-start)
+			      (- source-end source-start))))
+	      (do ((target-index (+ target-start nelts -1) (1- target-index))
+		   (source-index (+ source-start nelts -1) (1- source-index)))
+		  ((= target-index (1- target-start)) target-sequence)
+		(declare (type array-index target-index source-index))
+		
+		(setf (aref target-sequence target-index)
+		  (aref source-sequence source-index))))
+       else (do ((target-index target-start (1+ target-index))
+		 (source-index source-start (1+ source-index)))
+		((or (= target-index target-end) (= source-index source-end))
+		 target-sequence)
+	      (declare (type array-index target-index source-index))
+
+	      (setf (aref target-sequence target-index)
+		(aref source-sequence source-index))))))
+
+#+lucid
+;;;The compiler is *supposed* to optimize calls to replace, but in actual
+;;;fact it does not.
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type buffer-bytes buf1 buf2)
+	   (type array-index start1 end1 start2))
+  #.(declare-buffun)
+  (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
+    (declare (type array-index end2))
+    (lucid::simple-8bit-vector-replace-internal
+      buf1 buf2 start1 end1 start2 end2)))
+
+#+(and clx-overlapping-arrays (not (or lispm excl)))
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type vector buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
+
+#-(or lispm lucid excl clx-overlapping-arrays)
+(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
+  (declare (type buffer-bytes buf1 buf2)
+	   (type array-index start1 end1 start2))
+  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))
+
+#+ti
+(defun with-location-bindings (sys:&quote bindings &rest body)
+  (do ((bindings bindings (cdr bindings)))
+      ((null bindings)
+       (sys:eval-body-as-progn body))
+    (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
+	      (sys:*eval (cadar bindings)))))
+
+#+ti
+(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
+  (let ((bindings (cadr form))
+	(body (cddr form)))
+    `(let ()
+       ,@(loop for (accessor value) in bindings
+	       collect `(si:bind (si:locf ,accessor) ,value))
+       ,@body)))
+
+#+ti
+(defun (:property with-location-bindings compiler::cw-handler) (exp)
+  (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
+	 (body (compiler::cw-clause (cddr exp))))
+    (and compiler::cw-return-expansion-flag
+	 (list* (first exp) bindlist body))))
+
+#+(and lispm (not ti))
+(defmacro with-location-bindings (bindings &body body)
+  `(sys:letf* ,bindings ,@body))
+
+#+lispm
+(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
+				  &body body)
+  ;; don't use svref on LHS because Symbolics didn't define locf for it
+  (let* ((local-state (gensym))
+	 (bindings `(((aref ,local-state ,ts-index) 0))))	; will become zero anyway
+    (dolist (index indexes)
+      (push `((aref ,local-state ,index) (svref ,saved-state ,index))
+	    bindings))
+    `(let ((,local-state (gcontext-local-state ,gc)))
+       (declare (type gcontext-state ,local-state))
+       (unwind-protect
+	   (with-location-bindings ,bindings
+	     ,@body)
+	 (setf (svref ,local-state ,ts-index) 0)
+	 (when ,temp-gc
+	   (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
+	 (deallocate-gcontext-state ,saved-state)))))
+
+#-lispm
+(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
+				  &body body)
+  (let ((local-state (gensym))
+	(resets nil))
+    (dolist (index indexes)
+      (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
+	    resets))
+    `(unwind-protect
+	 (progn
+	   ,@body)
+       (let ((,local-state (gcontext-local-state ,gc)))
+	 (declare (type gcontext-state ,local-state))
+	 ,@resets
+	 (setf (svref ,local-state ,ts-index) 0))
+       (when ,temp-gc
+	 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
+       (deallocate-gcontext-state ,saved-state))))
+
+;;;----------------------------------------------------------------------------
+;;; How error detection should CLX do?
+;;; Several levels are possible:
+;;;
+;;; 1. Do the equivalent of check-type on every argument.
+;;; 
+;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
+;;;    strings generated by check-type.
+;;; 
+;;; 3. Do error checking only on arguments that are likely to have errors
+;;;    (like keyword names)
+;;; 
+;;; 4. Do error checking only where not doing so may dammage the envirnment
+;;;    on a non-tagged machine (i.e. when storing into a structure that has
+;;;    been passed in)
+;;; 
+;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
+;;;    store a non-integer into a number array. 
+;;; 
+;;; How extensive should the error checking be?  For example, if the server
+;;; expects a CARD16, is is sufficient for CLX to check for integer, or
+;;; should it also check for non-negative and less than 65536?
+;;;----------------------------------------------------------------------------
+ 
+;; The *TYPE-CHECK?* constant controls how much error checking is done.
+;; Possible values are:
+;;    NIL      - Don't do any error checking
+;;    t        - Do the equivalent of checktype on every argument
+;;    :minimal - Do error checking only where errors are likely
+
+;;; This controls macro expansion, and isn't changable at run-time You will
+;;; probably want to set this to nil if you want good performance at
+;;; production time.
+(defconstant *type-check?* #+Genera nil #-Genera t)
+
+;; TYPE? is used to allow the code to do error checking at a different level from
+;; the declarations.  It also does some optimizations for systems that don't have
+;; good compiler support for TYPEP.  The definitions for CARD32, CARD16, INT16, etc.
+;; include range checks.  You can modify TYPE? to do less extensive checking
+;; for these types if you desire.
+
+(defmacro type? (object type)
+  (if (not (constantp type))
+      `(typep ,object ,type)
+    (progn
+      (setq type (eval type))
+      #+(or Genera explorer)
+      (if *type-check?*
+	  `(locally (declare (optimize safety)) (typep ,object ',type))
+	`(typep ,object ',type))
+      #-(or Genera explorer)
+      (let ((predicate (assoc type
+			      '((drawable drawable-p) (window window-p)
+				(pixmap pixmap-p) (cursor cursor-p)
+				(font font-p) (gcontext gcontext-p)
+				(colormap colormap-p) (null null)
+				(integer integerp)))))
+	(cond (predicate
+	       `(,(second predicate) ,object))
+	      ((eq type 'boolean)
+	       't)			; Everything is a boolean.
+	      (*type-check?*
+	       `(locally (declare (optimize safety)) (typep ,object ',type)))
+	      (t
+	       `(typep ,object ',type)))))))
+
+;; X-TYPE-ERROR is the function called for type errors.
+;; If you want lots of checking, but are concerned about code size,
+;; this can be made into a macro that ignores some parameters.
+
+(defun x-type-error (object type &optional error-string)
+  (x-error 'x-type-error
+	   :datum object
+	   :expected-type type
+	   :error-string error-string))
+
+
+;;-----------------------------------------------------------------------------
+;; Error handlers
+;;    Hack up KMP error signaling using zetalisp until the real thing comes 
+;;    along
+;;-----------------------------------------------------------------------------
+
+(defun default-error-handler (display error-key &rest key-vals
+			      &key asynchronous &allow-other-keys)
+  (declare (type boolean asynchronous)
+	   (dynamic-extent key-vals))
+  ;; The default display-error-handler.
+  ;; It signals the conditions listed in the DISPLAY file.
+  (if asynchronous
+      (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
+      (apply #'x-error error-key :display display :error-key error-key key-vals)))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (apply #'sys:signal condition keyargs))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (sys:signal (apply #'zl:make-condition condition keyargs)
+	      :proceed-types proceed-format-string))
+
+#+(and Genera (not ansi-common-lisp))
+(defun x-error (condition &rest keyargs)
+  (declare (dbg:error-reporter))
+  (apply #'sys:signal condition keyargs))
+
+#+(and Genera (not ansi-common-lisp))
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dbg:error-reporter))
+  (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(defun x-error (condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'error condition keyargs))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (declare (dynamic-extent keyargs))
+  (apply #'cerror proceed-format-string condition keyargs))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun x-error (condition &rest keyargs)
+  (error "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun x-cerror (proceed-format-string condition &rest keyargs)
+  (cerror proceed-format-string "X-Error: ~a"
+	 (princ-to-string (apply #'make-condition condition keyargs))))
+
+;; version 15 of Pitman error handling defines the syntax for define-condition to be:
+;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
+;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
+;; or (:report exp)
+
+#+(and lispm (not ansi-common-lisp))
+(defmacro define-condition (name parents &body options)
+  (let ((slots (pop options))
+	(documentation nil)
+	(conc-name (concatenate 'string (string name) "-"))	       
+	(reporter nil))
+    (dolist (item options)
+      (ecase (first item)
+	(:documentation (setq documentation (second item)))
+	(:conc-name (setq conc-name (string (second item))))
+	(:report (setq reporter (second item)))))
+    `(within-definition (,name define-condition)
+       (zl:defflavor ,name ,slots ,parents
+	 :initable-instance-variables
+	 #-Genera
+	 (:accessor-prefix ,conc-name)
+	 #+Genera
+	 (:conc-name ,conc-name)
+	 #-Genera
+	 (:outside-accessible-instance-variables ,@slots)
+	 #+Genera
+	 (:readable-instance-variables ,@slots))
+       ,(when reporter ;; when no reporter, parent's is inherited
+	  `(zl:defmethod #-Genera (,name :report)
+	                 #+Genera (dbg:report ,name) (stream)
+	      ,(if (stringp reporter)
+		   `(write-string ,reporter stream)
+		 `(,reporter global:self stream))
+	      global:self))
+       (zl:compile-flavor-methods ,name)
+       ,(when documentation
+	  `(setf (documentation name 'type) ,documentation))
+       ',name)))
+
+#+(and lispm (not Genera) (not ansi-common-lisp))
+(zl:defflavor x-error () (global:error))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defflavor x-error
+	((dbg:proceed-types '(:continue))	;
+	 continue-format-string)
+	(sys:error)
+  (:initable-instance-variables continue-format-string))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defmethod (scl:make-instance x-error) (&rest ignore)
+  (when (not (sys:variable-boundp continue-format-string))
+    (setf dbg:proceed-types (remove :continue dbg:proceed-types))))
+
+#+(and Genera (not ansi-common-lisp))
+(scl:defmethod (dbg:proceed x-error :continue) ()
+  :continue)
+
+#+(and Genera (not ansi-common-lisp))
+(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
+  (format stream continue-format-string))
+
+#+(or ansi-common-lisp excl lcl3.0)
+(define-condition x-error (error))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defstruct x-error
+  report-function)
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun reporter-for-condition (name)
+  (xintern "." name '-reporter.))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defmacro define-condition (name parents &body options)
+  ;; Define a structure that when printed displays an error message
+  (let ((slots (pop options))
+	(documentation nil)
+	(conc-name (concatenate 'string (string name) "-"))	       
+	(reporter nil)
+	(condition (gensym))
+	(stream (gensym))
+	(report-function (reporter-for-condition name)))
+    (dolist (item options)
+      (ecase (first item)
+	(:documentation (setq documentation (second item)))
+	(:conc-name (setq conc-name (string (second item))))
+	(:report (setq reporter (second item)))))
+    (unless reporter (setq report-function (reporter-for-condition (car parents))))
+    `(within-definition (,name define-condition)
+       (defstruct (,name (:conc-name ,(intern conc-name))
+		         (:print-function condition-print)
+			 (:include ,(car parents) (report-function ',report-function)))
+	 ,@slots)
+       ,(when documentation
+	  `(setf (documentation name 'type) ,documentation))
+       ,(when reporter
+	  `(defun ,report-function (,condition ,stream)
+	     ,(if (stringp reporter)
+		  `(write-string ,reporter ,stream)
+		`(,reporter ,condition ,stream))
+	     ,condition))
+       ',name)))
+
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun condition-print (condition stream depth)
+  (declare (type x-error condition)
+	   (type stream stream)
+	   (ignore depth))
+  (if *print-escape*
+      (print-unreadable-object (condition stream :type t))
+    (funcall (x-error-report-function condition) condition stream))
+  condition)
+  
+#-(or lispm ansi-common-lisp excl lcl3.0)
+(defun make-condition (type &rest slot-initializations)
+  (declare (dynamic-extent slot-initializations))
+  (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
+			       (symbol-package type))))
+    (apply make-function slot-initializations)))
+
+#-(or ansi-common-lisp excl lcl3.0)
+(define-condition type-error (x-error)
+  (datum
+   expected-type)
+  (:report (lambda (condition stream)
+	     (format stream "~s isn't a ~a"
+		     (type-error-datum condition)
+		     (type-error-expected-type condition)))))
+
+
+;;-----------------------------------------------------------------------------
+;;  HOST hacking
+;;-----------------------------------------------------------------------------
+
+#-(or explorer Genera)
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  host family
+  (error "HOST-ADDRESS not implemented yet."))
+
+#+explorer
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  (ecase family
+    (:internet
+     (let ((addr (ip:get-ip-address host)))
+       (unless addr (error "~s isn't an internet host name" host))
+       (list :internet
+	     (ldb (byte 8 24) addr)
+	     (ldb (byte 8 16) addr)
+	     (ldb (byte 8 8) addr)
+	     (ldb (byte 8 0) addr))))
+    (:chaos
+     (let ((addr (first (chaos:chaos-addresses host))))
+       (unless addr (error "~s isn't a chaos host name" host))
+       (list :chaos
+	     (ldb (byte 8 0) addr)
+	     (ldb (byte 8 8) addr))))))
+
+#+Genera
+(defun host-address (host &optional (family :internet))
+  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type (or stringable list) host)
+	   (type (or null (member :internet :decnet :chaos) card8) family))
+  (declare (values list))
+  (let ((net-type (if (eq family :DECnet)
+		      :DNA
+		      family)))
+    (dolist (addr
+	      (sys:send (net:parse-host host) :network-addresses)
+	      (error "~s isn't a valid ~(~A~) host name" host family))
+      (let ((network (car addr))
+	    (address (cadr addr)))
+	(when (sys:send network :network-typep net-type)
+	  (return (ecase family
+		    (:internet
+		      (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
+			(list :internet a b c d)))
+		    ((:chaos :DECnet)
+		     (list family (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))
+
+#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
+(defun get-host (host-object)
+  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type list host-object))
+  (declare (values string family))
+  (let* ((family (first host-object))
+	 (address (ecase family
+		    (:internet
+		     (dpb (second host-object)
+			  (byte 8 24)
+			  (dpb (third host-object)
+			       (byte 8 16)
+			       (dpb (fourth host-object)
+				    (byte 8 8)
+				    (fifth host-object)))))
+		    (:chaos
+		     (dpb (third host-object) (byte 8 8) (second host-object))))))
+    (when (eq family :internet) (setq family :ip))
+    (let ((host (si:get-host-from-address address family)))
+      (values (and host (funcall host :name)) family))))
+
+;;; This isn't required, but it helps make sense of the results from access-hosts
+#+Genera
+(defun get-host (host-object)
+  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
+  ;; and cdr is a list of network address bytes.
+  (declare (type list host-object))
+  (declare (values string family))
+  (let ((family (first host-object)))
+    (values (sys:send (net:get-host-from-address 
+			(ecase family
+			  (:internet
+			    (apply #'tcp:build-internet-address (rest host-object)))
+			  ((:chaos :DECnet)
+			   (dpb (third host-object) (byte 8 8) (second host-object))))
+			(net:local-network-of-type (if (eq family :DECnet)
+						       :DNA
+						       family)))
+		      :name)
+	    family)))
+
+
+;;-----------------------------------------------------------------------------
+;; Whether to use closures for requests or not.
+;;-----------------------------------------------------------------------------
+
+;;; If this macro expands to non-NIL, then request and locking code is
+;;; compiled in a much more compact format, as the common code is shared, and
+;;; the specific code is built into a closure that is funcalled by the shared
+;;; code.  If your compiler makes efficient use of closures then you probably
+;;; want to make this expand to T, as it makes the code more compact.
+
+(defmacro use-closures ()
+  #+lispm t #-lispm nil)
+
+
+;;-----------------------------------------------------------------------------
+;; Resource stuff
+;;-----------------------------------------------------------------------------
+
+
+;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
+;;; a resource manager isn't running.
+
+(defun default-resources-pathname ()
+  (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal)
+    (merge-pathnames (user-homedir-pathname) (pathname ".Xdefaults"))))
+
+
+
+;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
+;;; defaults have been loaded.
+
+(defun resources-pathname ()
+  (when #+unix t #-unix (search "Unix" (software-type) :test #'char-equal)
+    (or #+(or excl lcl3.0)
+	(let ((string (#+excl sys:getenv
+		       #+lcl3.0 lcl:environment-variable
+		       "XENVIRONMENT")))
+	  (when string
+	    (pathname string)))
+	(merge-pathnames
+	  (user-homedir-pathname)
+	  (pathname 
+	    (concatenate 'simple-string ".Xdefaults-"
+			 #+excl (short-site-name)
+			 #-excl (machine-instance)))))))
+
+
+;;-----------------------------------------------------------------------------
+;; GC stuff
+;;-----------------------------------------------------------------------------
+
+#+Genera
+(si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
+  (declare (special *event-free-list*
+		    *pending-command-free-list*
+		    *reply-buffer-free-lists*
+		    *gcontext-local-state-cache*
+		    *temp-gcontext-cache*))
+  (setq *event-free-list* nil)
+  (setq *pending-command-free-list* nil)
+  (fill *reply-buffer-free-lists* nil)
+  (setq *gcontext-local-state-cache* nil)
+  (setq *temp-gcontext-cache* nil))
+
+
+;;-----------------------------------------------------------------------------
+;; Image stuff
+;;-----------------------------------------------------------------------------
+
+(deftype pixarray-1-element-type ()
+  'bit)
+
+(deftype pixarray-4-element-type ()
+  'card4)
+
+(deftype pixarray-8-element-type ()
+  'card8)
+
+(deftype pixarray-16-element-type ()
+  'card16)
+
+(deftype pixarray-24-element-type ()
+  #-Genera 'card24 #+Genera 'int32)
+
+(deftype pixarray-32-element-type ()
+  #-Genera 'card32 #+Genera 'int32)
+
+(deftype pixarray-1  ()
+  '(array pixarray-1-element-type (* *)))
+
+(deftype pixarray-4  ()
+  '(array pixarray-4-element-type (* *)))
+
+(deftype pixarray-8  ()
+  '(array pixarray-8-element-type (* *)))
+
+(deftype pixarray-16 ()
+  '(array pixarray-16-element-type (* *)))
+
+(deftype pixarray-24 ()
+  '(array pixarray-24-element-type (* *)))
+
+(deftype pixarray-32 ()
+  '(array pixarray-32-element-type (* *)))
+
+(deftype pixarray ()
+  '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
+
+(deftype bitmap ()
+  'pixarray-1)
+
+
+;;; These are used to read and write pixels from and to CARD8s.
+
+;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
+
+(defmacro read-image-load-byte (size position integer)
+  `(the (unsigned-byte ,size)
+	(#-Genera ldb #+Genera sys:%logldb
+	 (byte ,size ,(if *image-bit-lsb-first-p* position (- 7 position)))
+	 (the card8 ,integer))))
+
+;;; READ-IMAGE-ASSEMBLE-BYTES is used to build 16, 24 and 32 bit pixels from
+;;; the appropriate number of CARD8s.
+
+(defmacro read-image-assemble-bytes (&rest bytes)
+  (let* ((bytes (if *image-byte-lsb-first-p* bytes (reverse bytes)))
+	 (it (first bytes))
+	 (count 0))
+    (dolist (byte (rest bytes))
+      (setq it
+	    `(#-Genera dpb #+Genera sys:%logdpb 
+	      (the card8 ,byte)
+	      (byte 8 ,(incf count 8))
+	      (the (unsigned-byte ,count) ,it))))
+    #-Genera `(the (unsigned-byte ,(* (length bytes) 8)) ,it)
+    #+Genera it))
+
+;;; WRITE-IMAGE-LOAD-BYTE is used to extract a CARD8 from a 16, 24 or 32 bit
+;;; pixel.
+
+(defmacro write-image-load-byte (position integer integer-size)
+  integer-size
+  `(the card8
+	(#-Genera ldb #+Genera sys:%logldb
+	  (byte 8 ,(if *image-byte-lsb-first-p*
+		       position
+		     (- integer-size 8 position)))
+	  #-Genera (the (unsigned-byte ,integer-size) ,integer)
+	  #+Genera ,integer
+	  )))
+
+;;; WRITE-IMAGE-ASSEMBLE-BYTES is used to build a CARD8 from 1 or 4 bit
+;;; pixels.
+
+(defmacro write-image-assemble-bytes (&rest bytes)
+  (let* ((bytes (if *image-bit-lsb-first-p* bytes (reverse bytes)))
+	 (size (floor 8 (length bytes)))
+	 (it (first bytes))
+	 (count 0))
+    (dolist (byte (rest bytes))
+      (setq it `(#-Genera dpb #+Genera sys:%logdpb
+		 (the (unsigned-byte ,size) ,byte)
+		 (byte ,size ,(incf count size))
+		 (the (unsigned-byte ,count) ,it))))
+    `(the card8 ,it)))
+
+;;; If you can write fast routines that can read and write pixarrays out of a
+;;; buffer-bytes, do it!  It makes the image code a lot faster.  The
+;;; FAST-READ-PIXARRAY, FAST-WRITE-PIXARRAY and FAST-COPY-PIXARRAY routines
+;;; return T if they can do it, NIL if they can't.
+
+;;; FAST-READ-PIXARRAY - fill part of a pixarray from a buffer of card8s
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-1 (buffer-bbuf index array x y width height  
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 8))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-bits (index-mod (index- x) 8))
+	  (right-bits (index-mod (index- width left-bits) 8))
+	  (middle-bits (index- width left-bits right-bits))
+	  (middle-bytes (index-floor middle-bits 8)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-1-element-type (*)) vector)
+	       (type array-index start y
+		     left-bits right-bits middle-bits middle-bytes))
+      (cond ((index< middle-bits 0)
+	     (let ((byte (aref buffer-bbuf (index1- start)))
+		   (x (array-row-major-index array y left-bits)))
+	       (declare (type card8 byte)
+			(type array-index x))
+	       (when (index> right-bits 6)
+		 (setf (aref vector (index- x 1))
+		       (read-image-load-byte 1 7 byte)))
+	       (when (and (index> left-bits 1)
+			  (index> right-bits 5))
+		 (setf (aref vector (index- x 2))
+		       (read-image-load-byte 1 6 byte)))
+	       (when (and (index> left-bits 2)
+			  (index> right-bits 4))
+		 (setf (aref vector (index- x 3))
+		       (read-image-load-byte 1 5 byte)))
+	       (when (and (index> left-bits 3)
+			  (index> right-bits 3))
+		 (setf (aref vector (index- x 4))
+		       (read-image-load-byte 1 4 byte)))
+	       (when (and (index> left-bits 4)
+			  (index> right-bits 2))
+		 (setf (aref vector (index- x 5))
+		       (read-image-load-byte 1 3 byte)))
+	       (when (and (index> left-bits 5)
+			  (index> right-bits 1))
+		 (setf (aref vector (index- x 6))
+		       (read-image-load-byte 1 2 byte)))
+	       (when (index> left-bits 6)
+		 (setf (aref vector (index- x 7))
+		       (read-image-load-byte 1 1 byte)))))
+	    (t
+	     (unless (index-zerop left-bits)
+	       (let ((byte (aref buffer-bbuf (index1- start)))
+		     (x (array-row-major-index array y left-bits)))
+		 (declare (type card8 byte)
+			  (type array-index x))
+		 (setf (aref vector (index- x 1))
+		       (read-image-load-byte 1 7 byte))
+		 (when (index> left-bits 1)
+		   (setf (aref vector (index- x 2))
+			 (read-image-load-byte 1 6 byte))
+		   (when (index> left-bits 2)
+		     (setf (aref vector (index- x 3))
+			   (read-image-load-byte 1 5 byte))
+		     (when (index> left-bits 3)
+		       (setf (aref vector (index- x 4))
+			     (read-image-load-byte 1 4 byte))
+		       (when (index> left-bits 4)
+			 (setf (aref vector (index- x 5))
+			       (read-image-load-byte 1 3 byte))
+			 (when (index> left-bits 5)
+			   (setf (aref vector (index- x 6))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> left-bits 6)
+			     (setf (aref vector (index- x 7))
+				   (read-image-load-byte 1 1 byte))
+			     ))))))))
+	     (do* ((end (index+ start middle-bytes))
+		   (i start (index1+ i))
+		   (x (array-row-major-index array y left-bits) (index+ x 8)))
+		  ((index>= i end)
+		   (unless (index-zerop right-bits)
+		     (let ((byte (aref buffer-bbuf end))
+			   (x (array-row-major-index
+				array y (index+ left-bits middle-bits))))
+		       (declare (type card8 byte)
+				(type array-index x))
+		       (setf (aref vector (index+ x 0))
+			     (read-image-load-byte 1 0 byte))
+		       (when (index> right-bits 1)
+			 (setf (aref vector (index+ x 1))
+			       (read-image-load-byte 1 1 byte))
+			 (when (index> right-bits 2)
+			   (setf (aref vector (index+ x 2))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> right-bits 3)
+			     (setf (aref vector (index+ x 3))
+				   (read-image-load-byte 1 3 byte))
+			     (when (index> right-bits 4)
+			       (setf (aref vector (index+ x 4))
+				     (read-image-load-byte 1 4 byte))
+			       (when (index> right-bits 5)
+				 (setf (aref vector (index+ x 5))
+				       (read-image-load-byte 1 5 byte))
+				 (when (index> right-bits 6)
+				   (setf (aref vector (index+ x 6))
+					 (read-image-load-byte 1 6 byte))
+				   )))))))))
+	       (declare (type array-index end i x))
+	       (let ((byte (aref buffer-bbuf i)))
+		 (declare (type card8 byte))
+		 (setf (aref vector (index+ x 0))
+		       (read-image-load-byte 1 0 byte))
+		 (setf (aref vector (index+ x 1))
+		       (read-image-load-byte 1 1 byte))
+		 (setf (aref vector (index+ x 2))
+		       (read-image-load-byte 1 2 byte))
+		 (setf (aref vector (index+ x 3))
+		       (read-image-load-byte 1 3 byte))
+		 (setf (aref vector (index+ x 4))
+		       (read-image-load-byte 1 4 byte))
+		 (setf (aref vector (index+ x 5))
+		       (read-image-load-byte 1 5 byte))
+		 (setf (aref vector (index+ x 6))
+		       (read-image-load-byte 1 6 byte))
+		 (setf (aref vector (index+ x 7))
+		       (read-image-load-byte 1 7 byte))))
+	     ))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-4 (buffer-bbuf index array x y width height 
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-nibbles (index-mod (index- x) 2))
+	  (right-nibbles (index-mod (index- width left-nibbles) 2))
+	  (middle-nibbles (index- width left-nibbles right-nibbles))
+	  (middle-bytes (index-floor middle-nibbles 2)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-4-element-type (*)) vector)
+	       (type array-index start y
+		     left-nibbles right-nibbles middle-nibbles middle-bytes))
+      (unless (index-zerop left-nibbles)
+	(setf (aref array y 0)
+	      (read-image-load-byte
+		4 4 (aref buffer-bbuf (index1- start)))))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (x (array-row-major-index array y left-nibbles) (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref array y (index+ left-nibbles middle-nibbles))
+		    (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
+	(declare (type array-index end i x))
+	(let ((byte (aref buffer-bbuf i)))
+	  (declare (type card8 byte))
+	  (setf (aref vector (index+ x 0))
+		(read-image-load-byte 4 0 byte))
+	  (setf (aref vector (index+ x 1))
+		(read-image-load-byte 4 4 byte))))
+      ))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-8 (buffer-bbuf index array x y width height 
+			     padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 x)
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-8-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start width))
+ 	    (i start (index1+ i))
+ 	    (x (array-row-major-index array y 0) (index1+ x)))
+ 	   ((index>= i end))
+ 	(declare (type array-index end i x))
+ 	(setf (aref vector x)
+ 	      (the card8 (aref buffer-bbuf i))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-16 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-16-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1)))))))
+  t)
+
+#+Genera
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((array array)
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (sys:array-register-1d array)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (sys:%1d-aref array x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-24-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-read-pixarray-32 (buffer-bbuf index array x y width height 
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 4))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type (simple-array pixarray-32-element-type (*)) vector)
+	       (type array-index start y))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x (array-row-major-index array y 0) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref vector x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))
+		(aref buffer-bbuf (index+ i 3)))))))
+  t)
+
+(defun fast-read-pixarray (bbuf boffset pixarray
+			   x y width height padded-bytes-per-line
+			   bits-per-pixel)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index boffset
+		 padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((padded-bits-per-line (* padded-bytes-per-line 8))
+	   (padded-pixels-per-line
+	     (floor padded-bits-per-line bits-per-pixel))
+	   (pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod padded-bits-per-line 32))
+		 (zerop (index-mod pixarray-padded-bits-per-line 32)))
+	(#+Genera sys:stack-let* #-Genera let*
+	 ((dimensions (list height padded-pixels-per-line))
+	  (a (make-array
+	       dimensions
+	       :element-type (array-element-type pixarray)
+	       :displaced-to bbuf
+	       :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
+	 (sys:bitblt boole-1 width height a x y pixarray 0 0))
+	t))
+    #+Genera
+    (when (= bits-per-pixel 24)
+      (fast-read-pixarray-24
+	bbuf boffset pixarray x y width height padded-bytes-per-line))
+    #+(or lcl3.0 excl)
+    (funcall
+      (ecase bits-per-pixel 
+	(1 #'fast-read-pixarray-1) (4 #'fast-read-pixarray-4)
+	(8 #'fast-read-pixarray-8) (16 #'fast-read-pixarray-16)
+	(24 #'fast-read-pixarray-24) (32 #'fast-read-pixarray-32))
+      bbuf boffset pixarray x y width height padded-bytes-per-line)
+    ))
+
+;;; FAST-WRITE-PIXARRAY - copy part of a pixarray into an array of CARD8s
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-1 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-bits (index-mod width 8))
+	  (middle-bits (index- width right-bits))
+	  (middle-bytes (index-ceiling middle-bits 8))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-1-element-type (*)) vector)
+	       (type array-index h y right-bits middle-bits
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x (array-row-major-index array y start-x) (index+ x 8)))
+	   ((index>= i end)
+	    (unless (index-zerop right-bits)
+	      (let ((x (array-row-major-index
+			 array y (index+ start-x middle-bits))))
+		(declare (type array-index x))
+		(setf (aref buffer-bbuf end)
+		      (write-image-assemble-bytes
+			(aref vector (index+ x 0))
+			(if (index> right-bits 1)
+			    (aref vector (index+ x 1))
+			  0)
+			(if (index> right-bits 2)
+			    (aref vector (index+ x 2))
+			  0)
+			(if (index> right-bits 3)
+			    (aref vector (index+ x 3))
+			  0)
+			(if (index> right-bits 4)
+			    (aref vector (index+ x 4))
+			  0)
+			(if (index> right-bits 5)
+			    (aref vector (index+ x 5))
+			  0)
+			(if (index> right-bits 6)
+			    (aref vector (index+ x 6))
+			  0)
+			0)))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref vector (index+ x 0))
+		(aref vector (index+ x 1))
+		(aref vector (index+ x 2))
+		(aref vector (index+ x 3))
+		(aref vector (index+ x 4))
+		(aref vector (index+ x 5))
+		(aref vector (index+ x 6))
+		(aref vector (index+ x 7)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-4 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-nibbles (index-mod width 2))
+	  (middle-nibbles (index- width right-nibbles))
+	  (middle-bytes (index-ceiling middle-nibbles 2))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-4-element-type (*)) vector)
+	       (type array-index h y right-nibbles middle-nibbles
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x (array-row-major-index array y start-x) (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref buffer-bbuf end)
+		    (write-image-assemble-bytes
+		      (aref array y (index+ start-x middle-nibbles))
+		      0))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref vector (index+ x 0))
+		(aref vector (index+ x 1)))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-8 (buffer-bbuf index array x y width height
+			      padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-8-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref buffer-bbuf i) (the card8 (aref vector x))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-16 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-16-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-16-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 16))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 16))))))
+  t)
+
+#+Genera
+(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((array array)
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (sys:array-register-1d array)
+	       (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (sys:%1d-aref array x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-24-element-type (*)) vector)
+	       (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24))))))
+  t)
+
+#+(or lcl3.0 excl)
+(defun fast-write-pixarray-32 (buffer-bbuf index array x y width height
+			       padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((vector (underlying-simple-vector array))
+	  (h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type (simple-array pixarray-32-element-type (*)) vector)
+	       (type array-index h y start))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x (array-row-major-index array y x) (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref vector x)))
+	  (declare (type pixarray-32-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 24 pixel 32))))))
+  t)
+
+(defun fast-write-pixarray (bbuf boffset pixarray x y width height
+			    padded-bytes-per-line bits-per-pixel)
+  (declare (type buffer-bytes bbuf)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn bbuf boffset pixarray x y width height padded-bytes-per-line
+	 bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((padded-bits-per-line (* padded-bytes-per-line 8))
+	   (padded-pixels-per-line
+	     (floor padded-bits-per-line bits-per-pixel))
+	   (pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod padded-bits-per-line 32))
+		 (zerop (index-mod pixarray-padded-bits-per-line 32)))
+	(#+Genera sys:stack-let* #-Genera let*
+	 ((dimensions (list height padded-pixels-per-line))
+	  (a (make-array
+	       dimensions
+	       :element-type (array-element-type pixarray)
+	       :displaced-to bbuf
+	       :displaced-index-offset (floor (* boffset 8) bits-per-pixel))))
+	 (sys:bitblt boole-1 width height pixarray x y a 0 0))
+	t))
+    #+Genera
+    (when (= bits-per-pixel 24)
+      (fast-write-pixarray-24
+	bbuf boffset pixarray x y width height padded-bytes-per-line))
+    #+(or lcl3.0 excl)
+    (funcall
+      (ecase bits-per-pixel 
+	(1 #'fast-write-pixarray-1) (4 #'fast-write-pixarray-4)
+	(8 #'fast-write-pixarray-8) (16 #'fast-write-pixarray-16)
+	(24 #'fast-write-pixarray-24) (32 #'fast-write-pixarray-32))
+      bbuf boffset pixarray x y width height padded-bytes-per-line)
+    ))
+
+;;; FAST-COPY-PIXARRAY - copy part of a pixarray into another
+
+(defun fast-copy-pixarray (pixarray copy x y width height bits-per-pixel)
+  (declare (type pixarray pixarray copy)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (progn pixarray copy x y width height bits-per-pixel)
+  (or
+    #+lispm
+    (let* ((pixarray-padded-pixels-per-line
+	     #+Genera (sys:array-row-span pixarray)
+	     #-Genera (array-dimension pixarray 1))
+	   (pixarray-padded-bits-per-line
+	     (* pixarray-padded-pixels-per-line bits-per-pixel))
+	   (copy-padded-pixels-per-line
+	     #+Genera (sys:array-row-span copy)
+	     #-Genera (array-dimension copy 1))
+	   (copy-padded-bits-per-line
+	     (* copy-padded-pixels-per-line bits-per-pixel)))
+      (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
+		 (zerop (index-mod pixarray-padded-bits-per-line 32))
+		 (zerop (index-mod copy-padded-bits-per-line 32)))
+	(sys:bitblt boole-1 width height pixarray x y copy 0 0)
+	t))
+    #+Genera
+    (let ((src pixarray)
+	  (dest copy))
+      (declare (sys:array-register-1d src dest))
+      (do* ((dst-y 0 (index1+ dst-y))
+	    (src-y y (index1+ src-y)))
+	   ((index>= dst-y height))
+	(declare (type card16 dst-y src-y))
+	(do* ((dst-idx (array-row-major-index copy dst-y 0)
+		       (index1+ dst-idx))
+	      (dst-end (index+ dst-idx width))
+	      (src-idx (array-row-major-index pixarray src-y x)
+		       (index1+ src-idx)))
+	     ((index>= dst-idx dst-end))
+	  (declare (type array-index dst-idx src-idx dst-end))
+	  (setf (sys:%1d-aref dest dst-idx)
+		(sys:%1d-aref src src-idx))))
+      t)
+    #+(or lcl3.0 excl)
+    (macrolet
+      ((copy (type element-type)
+	 `(let* ((pixarray pixarray)
+		 (copy copy)
+		 (src (underlying-simple-vector pixarray))
+		 (dst (underlying-simple-vector copy)))
+	    (declare (type ,type pixarray copy)
+		     (type (simple-array ,element-type (*)) src dst))
+	    #.(declare-buffun)
+	    (do* ((dst-y 0 (index1+ dst-y))
+		  (src-y y (index1+ src-y)))
+		 ((index>= dst-y height))
+	      (declare (type card16 dst-y src-y))
+	      (do* ((dst-idx (array-row-major-index copy dst-y 0)
+			     (index1+ dst-idx))
+		    (dst-end (index+ dst-idx width))
+		    (src-idx (array-row-major-index pixarray src-y x)
+			     (index1+ src-idx)))
+		   ((index>= dst-idx dst-end))
+		(declare (type array-index dst-idx src-idx dst-end))
+		(setf (aref dst dst-idx)
+		      (the ,element-type (aref src src-idx))))))))
+      (ecase bits-per-pixel
+	(1  (copy pixarray-1  pixarray-1-element-type))
+	(4  (copy pixarray-4  pixarray-4-element-type))
+	(8  (copy pixarray-8  pixarray-8-element-type))
+	(16 (copy pixarray-16 pixarray-16-element-type))
+	(24 (copy pixarray-24 pixarray-24-element-type))
+	(32 (copy pixarray-32 pixarray-32-element-type)))
+      t)))
diff --git a/clx/display.lisp b/clx/display.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..05cbcc283f587fb293f0f9bb463f3b0b5e014b71
--- /dev/null
+++ b/clx/display.lisp
@@ -0,0 +1,533 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  with-display
+	  with-event-queue
+	  open-display
+	  display-force-output
+	  close-display
+	  display-protocol-version
+	  display-vendor
+	  display-roots
+	  display-motion-buffer-size
+	  display-max-request-length
+	  display-error-handler
+	  display-after-function
+	  display-invoke-after-function
+	  display-finish-output))
+
+;;
+;; Resource id management
+;;
+(defun initialize-resource-allocator (display)
+  ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
+  (let ((id-mask (display-resource-id-mask display)))
+    (unless (zerop id-mask) ;; zero mask is an error
+      (do ((first 0 (index1+ first))
+	   (mask id-mask (the mask32 (ash mask -1))))
+	  ((oddp mask)
+	   (setf (display-resource-id-byte display)
+		 (byte (integer-length mask) first)))
+	(declare (type array-index first)
+		 (type mask32 mask))))))
+
+(defun resourcealloc (display)
+  ;; Allocate a resource-id for in DISPLAY
+  (declare (type display display))
+  (declare (values resource-id))
+  (dpb (incf (display-resource-id-count display))
+       (display-resource-id-byte display)
+       (display-resource-id-base display)))
+
+(defmacro allocate-resource-id (display object type)
+  ;; Allocate a resource-id for OBJECT in DISPLAY
+  (declare (type display display)
+	   (type t object))
+  (declare (values resource-id))
+  (if (member (eval type) *clx-cached-types*)
+      `(let ((id (funcall (display-xid ,display) ,display)))
+	 (save-id ,display id ,object)
+	 id)
+    `(funcall (display-xid ,display) ,display)))
+
+(defmacro deallocate-resource-id (display id type)
+  ;; Deallocate a resource-id for OBJECT in DISPLAY
+  (when (member (eval type) *clx-cached-types*)
+    `(deallocate-resource-id-internal ,display ,id)))
+
+(defun deallocate-resource-id-internal (display id)
+  (remhash id (display-resource-id-map display)))
+
+(defun lookup-resource-id (display id)
+  ;; Find the object associated with resource ID
+  (gethash id (display-resource-id-map display)))
+
+(defun save-id (display id object)
+  ;; Register a resource-id from another display.
+  (declare (type display display)
+	   (type integer id)
+	   (type t object))
+  (declare (values object))
+  (setf (gethash id (display-resource-id-map display)) object))
+
+;; Define functions to find the CLX data types given a display and resource-id
+;; If the data type is being cached, look there first.
+(macrolet ((generate-lookup-functions (useless-name &body types)
+	    `(within-definition (,useless-name generate-lookup-functions)
+	       ,@(mapcar
+		   #'(lambda (type)
+		       `(defun ,(xintern 'lookup- type)
+			       (display id)
+			  (declare (type display display)
+				   (type resource-id id))
+			  (declare (values ,type))
+			  ,(if (member type *clx-cached-types*)
+			       `(let ((,type (lookup-resource-id display id)))
+				  (cond ((null ,type) ;; Not found, create and save it.
+					 (setq ,type (,(xintern 'make- type)
+						      :display display :id id))
+					 (save-id display id ,type))
+					;; Found.  Check the type
+					,(cond ((null *type-check?*)
+						`(t ,type))
+					       ((member type '(window pixmap))
+						`((type? ,type 'drawable) ,type))
+					       (t `((type? ,type ',type) ,type)))
+					,@(when *type-check?*
+					    `((t (x-error 'lookup-error
+							  :id id
+							  :display display
+							  :type ',type
+							  :object ,type))))))
+			       ;; Not being cached.  Create a new one each time.
+			       `(,(xintern 'make- type)
+				 :display display :id id))))
+		   types))))
+  (generate-lookup-functions ignore
+    drawable
+    window
+    pixmap
+    gcontext
+    cursor
+    colormap
+    font))
+
+(defun id-atom (id display)
+  ;; Return the cached atom for an atom ID
+  (declare (type resource-id id)
+	   (type display display))
+  (declare (values (or null keyword)))
+  (gethash id (display-atom-id-map display)))
+
+(defun atom-id (atom display)
+  ;; Return the ID for an atom in DISPLAY
+  (declare (type xatom atom)
+	   (type display display))
+  (declare (values (or null resource-id)))
+  (gethash (if (keywordp atom)
+	       atom
+	       (kintern atom))
+	   (display-atom-cache display)))
+
+(defun set-atom-id (atom display id)
+  ;; Set the ID for an atom in DISPLAY
+  (declare (type xatom atom)
+	   (type display display)
+	   (type resource-id id))
+  (declare (values resource-id))
+  (let ((atom (if (keywordp atom) atom (kintern atom))))
+    (declare (type keyword atom))
+    (setf (gethash id (display-atom-id-map display)) atom)
+    (setf (gethash atom (display-atom-cache display)) id)
+    id))
+
+(defsetf atom-id set-atom-id)
+
+(defun initialize-predefined-atoms (display)
+  (do ((i 1 (1+ i))
+       (end (length *predefined-atoms*)))
+      ((>= i end))
+    (declare (type resource-id i))
+    (setf (atom-id (svref *predefined-atoms* i) display) i)))
+
+(defun visual-info (display visual-id)
+  (declare (type display display)
+	   (type resource-id visual-id)
+	   (values visual-info))
+  (when (zerop visual-id)
+    (return-from visual-info nil))
+  (dolist (screen (display-roots display))
+    (declare (type screen screen))
+    (dolist (depth (screen-depths screen))
+      (declare (type cons depth))
+      (dolist (visual-info (rest depth))
+	(declare (type visual-info visual-info))
+	(when (funcall (resource-id-map-test) visual-id (visual-info-id visual-info))
+	  (return-from visual-info visual-info)))))
+  (error "Visual info not found for id #x~x in display ~s." visual-id display))
+
+
+;;
+;; Display functions
+;;
+(defmacro with-display ((display &key timeout inline)
+			&body body)
+  ;; This macro is for use in a multi-process environment.  It provides exclusive
+  ;; access to the local display object for multiple request generation.  It need not
+  ;; provide immediate exclusive access for replies; that is, if another process is
+  ;; waiting for a reply (while not in a with-display), then synchronization need not
+  ;; (but can) occur immediately.  Except where noted, all routines effectively
+  ;; contain an implicit with-display where needed, so that correct synchronization
+  ;; is always provided at the interface level on a per-call basis.  Nested uses of
+  ;; this macro will work correctly.  This macro does not prevent concurrent event
+  ;; processing; see with-event-queue.
+  `(with-buffer (,display
+		 ,@(and timeout `(:timeout ,timeout))
+		 ,@(and inline `(:inline ,inline)))
+     ,@body))
+
+(defmacro with-event-queue ((display &key timeout inline)
+			    &body body &environment env)
+  ;; exclusive access to event queue
+  `(macrolet ((with-event-queue ((display &key timeout) &body body)
+		;; Speedup hack for lexically nested with-event-queues
+		`(progn
+		   (progn ,display ,@(and timeout `(,timeout)) nil)
+		   ,@body)))
+     ,(if (and (null inline) (macroexpand '(use-closures) env))
+	  `(flet ((.with-event-queue-body. () ,@body))
+	     #+ansi-common-lisp
+	     (declare (dynamic-extent #'.with-event-queue-body.))
+	     (with-event-queue-function
+	       ,display ,timeout #'.with-event-queue-body.))
+	(let ((disp (if (or (symbolp display) (constantp display))
+			display
+		      '.display.)))
+	  `(let (,@(unless (eq disp display) `((,disp ,display))))
+	     (holding-lock ((display-event-lock ,disp) ,disp "CLX Event Lock"
+			    ,@(and timeout `(:timeout ,timeout)))
+	       ,@body))))))
+
+(defun with-event-queue-function (display timeout function)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type function function)
+	   (downward-funarg function))
+  (with-event-queue (display :timeout timeout :inline t)
+    (funcall function)))
+
+(defmacro with-event-queue-internal ((display &key timeout) &body body)
+  ;; exclusive access to the internal event queues
+  (let ((disp (if (or (symbolp display) (constantp display)) display '.display.)))
+    `(let (,@(unless (eq disp display) `((,disp ,display))))
+       (holding-lock ((display-event-queue-lock ,disp) ,disp "CLX Event Queue Lock"
+		      ,@(and timeout `(:timeout ,timeout)))
+	 ,@body))))
+
+(defun open-display (host  &rest options &key (display 0) protocol
+		     authorization-name authorization-data &allow-other-keys)
+  ;; Implementation specific routine to setup the buffer for a specific host and display.
+  ;; This must interface with the local network facilities, and will probably do special
+  ;; things to circumvent the nework when displaying on the local host.
+  ;;
+  ;; A string must be acceptable as a host, but otherwise the possible types
+  ;; for host and protocol are not constrained, and will likely be very
+  ;; system dependent.  The default protocol is system specific.  Authorization,
+  ;; if any, is assumed to come from the environment somehow.
+  (declare (type integer display)
+	   (dynamic-extent options))
+  (declare (values display))
+  ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
+  (let* ((stream (open-x-stream host display protocol))
+	 (disp (apply #'make-buffer
+		      #x2000 'make-display-internal
+		      :host host
+		      :display display
+		      :output-stream stream
+		      :input-stream stream
+		      :allow-other-keys t
+		      options))
+	 (ok-p nil))
+    (unwind-protect
+	(progn
+	  (display-connect disp
+			   :authorization-name authorization-name
+			   :authorization-data authorization-data)
+	  (initialize-resource-allocator disp)
+	  (initialize-predefined-atoms disp)
+	  (initialize-extensions disp)
+	  (setq ok-p t))
+      (unless ok-p (close-display disp :abort t)))
+    disp))
+
+(defun display-force-output (display)
+  ; Output is normally buffered, this forces any buffered output to the server.
+  (declare (type display display))
+  (with-display (display)
+    (buffer-force-output display)))
+
+(defun close-display (display &key abort)
+  ;; Close the host connection in DISPLAY
+  (declare (type display display))
+  (close-buffer display :abort abort))
+
+(defun display-connect (display &key authorization-name authorization-data)
+  (unless authorization-name (setq authorization-name ""))
+  (unless authorization-data (setq authorization-data ""))
+  (with-buffer-output (display :sizes (8 16))
+    (card8-put
+      0
+      (ecase (display-byte-order display)
+	(:lsbfirst #x6c)   ;; Ascii lowercase l - Least Significant Byte First
+	(:msbfirst #x42))) ;; Ascii uppercase B -  Most Significant Byte First
+    (card16-put 2 *protocol-major-version*)
+    (card16-put 4 *protocol-minor-version*)
+    (card16-put 6 (length authorization-name))
+    (card16-put 8 (length authorization-data))
+    (write-sequence-char display 12 authorization-name)
+    (write-sequence-char display
+			 (lround (+ 12 (length authorization-name))) authorization-data))
+  (buffer-force-output display)
+  (let ((reply-buffer nil))
+    (declare (type (or null reply-buffer) reply-buffer))
+    (unwind-protect
+	(progn
+	  (setq reply-buffer (allocate-reply-buffer #x1000))
+	  (with-buffer-input (reply-buffer :sizes (8 16 32))
+	    (buffer-input display buffer-bbuf 0 8)
+	    (let ((success (boolean-get 0))
+		  (reason-length (card8-get 1))
+		  (major-version (card16-get 2))
+		  (minor-version (card16-get 4))
+		  (total-length (card16-get 6))
+		  vendor-length
+		  num-roots
+		  num-formats)
+	      (declare (ignore total-length))
+	      (unless success
+		(x-error 'connection-failure
+			 :major-version major-version
+			 :minor-version minor-version
+			 :host (display-host display)
+			 :display (display-display display)
+			 :reason
+			 (progn (buffer-input display buffer-bbuf 0 reason-length)
+				(string-get reason-length 0 :reply-buffer reply-buffer))))
+	      (buffer-input display buffer-bbuf 0 32)
+	      (setf (display-protocol-major-version display) major-version)
+	      (setf (display-protocol-minor-version display) minor-version)
+	      (setf (display-release-number display) (card32-get 0))
+	      (setf (display-resource-id-base display) (card32-get 4))
+	      (setf (display-resource-id-mask display) (card32-get 8))
+	      (setf (display-motion-buffer-size display) (card32-get 12))
+	      (setq vendor-length (card16-get 16))
+	      (setf (display-max-request-length display) (card16-get 18))
+	      (setq num-roots (card8-get 20))
+	      (setq num-formats (card8-get 21))
+	      ;; Get the image-info
+	      (setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
+	      (let ((format (display-bitmap-format display)))
+		(declare (type bitmap-format format))
+		(setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
+		(setf (bitmap-format-unit format) (card8-get 24))
+		(setf (bitmap-format-pad format) (card8-get 25)))
+	      (setf (display-min-keycode display) (card8-get 26))
+	      (setf (display-max-keycode display) (card8-get 27))
+	      ;; 4 bytes unused
+	      ;; Get the vendor string
+	      (buffer-input display buffer-bbuf 0 (lround vendor-length))
+	      (setf (display-vendor-name display)
+		    (string-get vendor-length 0 :reply-buffer reply-buffer))
+	      ;; Initialize the pixmap formats
+	      (dotimes (i num-formats) ;; loop gathering pixmap formats
+		(buffer-input display buffer-bbuf 0 8)
+		(push (make-pixmap-format :depth (card8-get 0)
+					  :bits-per-pixel (card8-get 1)
+					  :scanline-pad (card8-get 2))
+						; 5 unused bytes
+		      (display-pixmap-formats display)))
+	      (setf (display-pixmap-formats display)
+		    (nreverse (display-pixmap-formats display)))
+	      ;; Initialize the screens
+	      (dotimes (i num-roots)
+		(buffer-input display buffer-bbuf 0 40)
+		(let* ((root (make-window :id (card32-get 0) :display display))
+		       (root-visual (card32-get 32))
+		       (default-colormap
+			 (make-colormap :id (card32-get 4)
+					:display display))
+		       (screen
+			 (make-screen
+			   :root root
+			   :default-colormap default-colormap
+			   :white-pixel (card32-get 8)
+			   :black-pixel (card32-get 12)
+			   :event-mask-at-open (card32-get 16)
+			   :width  (card16-get 20)
+			   :height (card16-get 22)
+			   :width-in-millimeters  (card16-get 24)
+			   :height-in-millimeters (card16-get 26)
+			   :min-installed-maps (card16-get 28)
+			   :max-installed-maps (card16-get 30)
+			   :backing-stores (member8-get 36 :never :when-mapped :always)
+			   :save-unders-p (boolean-get 37)
+			   :root-depth (card8-get 38)))
+		       (num-depths (card8-get 39))
+		       (depths nil))
+		  ;; Save root window for event reporting
+		  (save-id display (window-id root) root)
+		  ;; Create the depth AList for a screen, (depth . visual-infos)
+		  (dotimes (j num-depths)
+		    (buffer-input display buffer-bbuf 0 8)
+		    (let ((depth (card8-get 0))
+			  (num-visuals (card16-get 2))
+			  (visuals nil)) ;; 4 bytes unused
+		      (dotimes (k num-visuals)
+			(buffer-input display buffer-bbuf 0 24)
+			(let* ((visual (card32-get 0))
+			       (visual-info (make-visual-info
+					      :id visual
+					      :display display
+					      :class (member8-get 4 :static-gray :gray-scale
+								  :static-color :pseudo-color
+								  :true-color :direct-color)
+					      :bits-per-rgb (card8-get 5)
+					      :colormap-entries (card16-get 6)
+					      :red-mask (card32-get 8)
+					      :green-mask (card32-get 12)
+					      :blue-mask (card32-get 16)
+					      ;; 4 bytes unused
+					      )))
+			  (push visual-info visuals)
+			  (when (funcall (resource-id-map-test) root-visual visual)
+			    (setf (screen-root-visual-info screen)
+				  (setf (colormap-visual-info default-colormap)
+					visual-info)))))
+		      (push (cons depth (nreverse visuals)) depths)))
+		  (setf (screen-depths screen) (nreverse depths))
+		  (push screen (display-roots display))))
+	      (setf (display-roots display) (nreverse (display-roots display)))
+	      (setf (display-default-screen display) (first (display-roots display))))))
+      (when reply-buffer
+	(deallocate-reply-buffer reply-buffer))))
+  display)
+
+(defun display-protocol-version (display)
+  (declare (type display display))
+  (declare (values major minor))
+  (values (display-protocol-major-version display)
+	  (display-protocol-minor-version display)))
+
+(defun display-vendor (display)
+  (declare (type display display))
+  (declare (values name release))
+  (values (display-vendor-name display)
+	  (display-release-number display)))
+
+(defun display-nscreens (display)
+  (declare (type display display))
+  (length (display-roots display)))
+
+#+comment ;; defined by the DISPLAY defstruct
+(defsetf display-error-handler (display) (handler)
+  ;; All errors (synchronous and asynchronous) are processed by calling an error
+  ;; handler in the display.  If handler is a sequence it is expected to contain
+  ;; handler functions specific to each error; the error code is used to index the
+  ;; sequence, fetching the appropriate handler.  Any results returned by the handler
+  ;; are ignored; it is assumed the handler either takes care of the error
+  ;; completely, or else signals. For all core errors, the keyword/value argument
+  ;; pairs are:
+  ;;    :display display
+  ;;    :error-key error-key
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;;    :current-sequence integer
+  ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
+  ;; :window errors another pair is:
+  ;;    :resource-id integer
+  ;; For :atom errors, another pair is:
+  ;;    :atom-id integer
+  ;; For :value errors, another pair is:
+  ;;    :value integer
+  )
+
+  ;; setf'able
+  ;; If defined, called after every protocol request is generated, even those inside
+  ;; explicit with-display's, but never called from inside the after-function itself.
+  ;; The function is called inside the effective with-display for the associated
+  ;; request.  Default value is nil.  Can be set, for example, to
+  ;; #'display-force-output or #'display-finish-output.
+
+(defvar *inside-display-after-function* nil)
+
+(defun display-invoke-after-function (display)
+  ; Called after every protocal request is generated
+  (declare (type display display))
+  (when (and (display-after-function display)
+	     (not *inside-display-after-function*))
+    (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
+      (funcall (display-after-function display) display))))
+
+(defun display-finish-output (display)
+  ;; Forces output, then causes a round-trip to ensure that all possible
+  ;; errors and events have been received.
+  (declare (type display display))
+  (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
+       ()
+    )
+  ;; Report asynchronous errors here if the user wants us to.
+  (report-asynchronous-errors display :after-finish-output))
+
+(defparameter
+  *request-names*
+  '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
+     "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
+     "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
+     "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
+     "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
+     "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
+     "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
+     "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
+     "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
+     "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
+     "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
+     "QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
+     "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
+     "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
+     "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
+     "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
+     "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
+     "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
+     "PutImage" "GetImage" "PolyText8" "PolyText16"
+     "ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
+     "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
+     "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
+     "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
+     "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
+     "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
+     "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
+     "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
+     "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
+     "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
+     "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))
diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..41c33a6c2fe761226ca9783caeb86e6db387426e
--- /dev/null
+++ b/clx/gcontext.lisp
@@ -0,0 +1,994 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; GContext
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;;	GContext values are usually cached locally in the GContext object.
+;;;	This is required because the X.11 server doesn't have any requests
+;;;	for getting GContext values back.
+;;;
+;;;	GContext changes are cached until force-GContext-changes is called.
+;;;	All the requests that use GContext (including the GContext accessors,
+;;;	but not the SETF's) call force-GContext-changes.
+;;;	In addition, the macro WITH-GCONTEXT may be used to provide a 
+;;;	local view if a GContext.
+;;;
+;;;	Each GContext keeps a copy of the values the server has seen, and
+;;;	a copy altered by SETF, called the LOCAL-STATE (bad name...).
+;;;	The SETF accessors increment a timestamp in the GContext.
+;;;	When the timestamp in a GContext isn't equal to the timestamp in
+;;;	the local-state, changes have been made, and force-GContext-changes
+;;;	loops through the GContext and local-state, sending differences to
+;;;	the server, and updating GContext.
+;;;
+;;;	WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
+;;;	a private copy.  This is easy (and fast) for lisp machines, but other
+;;;	lisps will have problems.  Fortunately, most other lisps don't care,
+;;;	because they don't run in a multi-processing shared-address space
+;;;	environment.
+
+(in-package :xlib)
+
+(export '(force-gcontext-changes
+	  with-gcontext
+	  create-gcontext
+	  copy-gcontext-components
+	  copy-gcontext
+	  free-gcontext
+	  
+	  gcontext-function
+	  gcontext-plane-mask
+	  gcontext-foreground
+	  gcontext-background
+	  gcontext-line-width
+	  gcontext-line-style
+	  gcontext-cap-style
+	  gcontext-join-style
+	  gcontext-fill-style
+	  gcontext-fill-rule
+	  gcontext-tile
+	  gcontext-stipple
+	  gcontext-ts-x
+	  gcontext-ts-y
+	  gcontext-font
+	  gcontext-subwindow-mode
+	  gcontext-exposures
+	  gcontext-clip-x
+	  gcontext-clip-y
+	  gcontext-clip-mask
+	  gcontext-dashes
+	  gcontext-arc-mode
+	  gcontext-dash-offset
+          gcontext-clip-ordering
+
+	  define-gcontext-accessor
+	  ))
+
+;; GContext state accessors
+;;	The state vector contains all card32s to speed server updating
+
+(eval-when (eval compile load)
+
+(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
+
+(macrolet ((def-gc-internals (name &rest extras)
+	    (let ((macros nil)
+		  (indexes nil)
+		  (masks nil)
+		  (index 0))
+	      (dolist (name *gcontext-components*)
+		(push `(defmacro ,(xintern 'gcontext-internal- name) (state)
+			 `(svref ,state ,,index))
+		      macros)
+		(setf (getf indexes name) index)
+		(push (ash 1 index) masks)
+		(incf index))
+	      (dolist (extra extras)
+		(push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
+			 `(svref ,state ,,index))
+		      macros)
+		;; don't override already correct index entries
+		(unless (or (getf indexes (second extra)) (getf indexes (first extra)))
+		  (setf (getf indexes (or (second extra) (first extra))) index))
+		(push (logior (ash 1 index)
+			      (if (second extra)
+				  (ash 1 (position (second extra) *gcontext-components*))
+				  0))
+		      masks)
+		(incf index))
+	      `(within-definition (def-gc-internals ,name)
+		 ,@(nreverse macros)
+		 (eval-when (eval compile load)
+		   (defconstant *gcontext-data-length* ,index)
+		   (defconstant *gcontext-indexes* ',indexes)
+		   (defconstant *gcontext-masks*
+				',(coerce (nreverse masks) 'simple-vector)))))))
+  (def-gc-internals ignore
+    (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
+
+) ;; end EVAL-WHEN
+
+(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
+
+(deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
+
+(defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
+  (name nil :type symbol :read-only t)
+  (default nil :type t :read-only t)
+  (set-function #'identity :type (function (gcontext t) t) :read-only t)
+  (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t))
+
+(defvar *gcontext-extensions* nil) ;; list of gcontext-extension
+
+;; Gcontext state Resource
+(defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
+
+(defmacro gcontext-state-next (state)
+  `(svref ,state 0))
+
+(defun allocate-gcontext-state ()
+  ;; Allocate a gcontext-state
+  ;; Loop until a local state is found that's large enough to hold
+  ;; any extensions that may exist.
+  (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
+    (declare (type array-index length))
+    (loop
+      (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
+					    gcontext-state-next gcontext-state)
+		       (make-array length :initial-element nil))))
+	(declare (type gcontext-state state))
+	(when (index>= (length state) length)
+	  (return state))))))
+
+(defun deallocate-gcontext-state (state)
+  (declare (type gcontext-state state))
+  (fill state nil)
+  (threaded-atomic-push state *gcontext-local-state-cache*
+			gcontext-state-next gcontext-state))
+
+;; Temp-Gcontext Resource
+(defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
+
+(defun allocate-temp-gcontext ()
+  (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
+      (make-gcontext :local-state '#() :server-state '#())))
+
+(defun deallocate-temp-gcontext (gc)
+  (declare (type gcontext gc))
+  (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
+
+;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
+;; as (type <type> <name>), there is an accessor:
+
+;(defun gcontext-<name> (gcontext)
+;  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
+;  ;; off, or the component was copied from a gcontext with unknown state).
+;  (declare (type gcontext gcontext)
+;	   (values <type>)))
+
+;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
+;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
+
+;(defsetf gcontext-<name> (gcontext) (value)
+;  )
+
+;; Generate all the accessors and defsetf's for GContext
+
+(defmacro xgcmask->gcmask (mask)
+  `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
+
+(defmacro access-gcontext ((gcontext local-state) &body body)
+  `(let ((,local-state (gcontext-local-state ,gcontext)))
+     (declare (type gcontext-state ,local-state))
+     ,@body))
+
+(defmacro modify-gcontext ((gcontext local-state) &body body)
+  ;; The timestamp must be altered after the modification
+  `(let ((,local-state (gcontext-local-state ,gcontext)))
+     (declare (type gcontext-state ,local-state))
+     (prog1
+	 (progn ,@body)
+       (setf (gcontext-internal-timestamp ,local-state) 0))))
+
+(defmacro def-gc-accessor (name type)
+  (let* ((gcontext-name (xintern 'gcontext- name))
+	 (internal-accessor (xintern 'gcontext-internal- name))
+	 (internal-setfer (xintern 'set- gcontext-name)))
+    `(within-definition (,name def-gc-accessor)
+
+       (defun ,gcontext-name (gcontext)
+	 (declare (type gcontext gcontext))
+	 (declare (values (or null ,type)))
+	 (let ((value (,internal-accessor (gcontext-local-state gcontext))))
+	   (declare (type (or null card32) value))
+	   (when value ;; Don't do anything when value isn't known
+	     (let ((%buffer (gcontext-display gcontext)))
+	       (declare (type display %buffer))
+	       %buffer
+	       (decode-type ,type value)))))
+       
+       (defun ,internal-setfer (gcontext value)
+	 (declare (type gcontext gcontext)
+		  (type ,type value))
+	 (modify-gcontext (gcontext local-state)
+	   (setf (,internal-accessor local-state) (encode-type ,type value))
+	   ,@(when (eq type 'pixmap)
+	       ;; write-through pixmaps, because the protocol allows
+	       ;; the server to copy the pixmap contents at the time
+	       ;; of the store, rather than continuing to share with
+	       ;; the pixmap.
+	       `((let ((server-state (gcontext-server-state gcontext)))
+		   (setf (,internal-accessor server-state) nil))))
+	   value))
+       
+       (defsetf ,gcontext-name ,internal-setfer))))
+
+(defmacro incf-internal-timestamp (state)
+  (let ((ts (gensym)))
+    `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
+       (declare (type fixnum ,ts))
+       ;; the probability seems low enough
+       (setq ,ts (if (= ,ts most-positive-fixnum)
+		     1
+		     (the fixnum (1+ ,ts))))
+       (setf (gcontext-internal-timestamp ,state) ,ts))))
+
+(def-gc-accessor function boole-constant)
+(def-gc-accessor plane-mask card32)
+(def-gc-accessor foreground card32)
+(def-gc-accessor background card32)
+(def-gc-accessor line-width card16)
+(def-gc-accessor line-style (member :solid :dash :double-dash))
+(def-gc-accessor cap-style (member :not-last :butt :round :projecting))
+(def-gc-accessor join-style (member :miter :round :bevel))
+(def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
+(def-gc-accessor fill-rule (member :even-odd :winding))
+(def-gc-accessor tile pixmap)
+(def-gc-accessor stipple pixmap)
+(def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
+(def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
+;; (def-GC-accessor font font) ;; See below
+(def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
+(def-gc-accessor exposures (member :off :on))
+(def-gc-accessor clip-x int16)
+(def-gc-accessor clip-y int16)
+;; (def-GC-accessor clip-mask) ;; see below
+(def-gc-accessor dash-offset card16)
+;; (def-GC-accessor dashes)  ;; see below
+(def-gc-accessor arc-mode (member :chord :pie-slice))
+
+
+(defun gcontext-clip-mask (gcontext)
+  (declare (type gcontext gcontext))
+  (declare (values (or null (member :none) pixmap rect-seq)
+		   (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
+  (access-gcontext (gcontext local-state)
+    (multiple-value-bind (clip clip-mask)
+	(without-interrupts
+	  (values (gcontext-internal-clip local-state)
+		  (gcontext-internal-clip-mask local-state)))
+      (if (null clip)
+	  (values (let ((%buffer (gcontext-display gcontext)))
+		    (declare (type display %buffer))
+		    (decode-type (or (member :none) pixmap) clip-mask))
+		  nil)
+	(values (second clip)
+		(decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
+			     (first clip)))))))
+
+(defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
+  ;; A bit strange, but retains setf form.
+  ;; a nil clip-mask is transformed to an empty vector
+  `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
+
+(defun set-gcontext-clip-mask (gcontext ordering clip-mask)
+  ;; a nil clip-mask is transformed to an empty vector
+  (declare (type gcontext gcontext)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
+	   (type (or (member :none) pixmap rect-seq) clip-mask))
+  (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
+  (multiple-value-bind (clip-mask clip)
+      (typecase clip-mask
+	(pixmap (values (pixmap-id clip-mask) nil))
+	((member :none) (values 0 nil))
+	(sequence
+	  (values nil
+		  (list (encode-type
+			  (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
+			  ordering)
+			(copy-seq clip-mask))))
+	(otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-clip local-state) clip
+		(gcontext-internal-clip-mask local-state) clip-mask)
+	  (if (null clip)
+	      (setf (gcontext-internal-clip server-state) nil)
+	    (setf (gcontext-internal-clip-mask server-state) nil))
+	  (when (and clip-mask (not (zerop clip-mask)))
+	    ;; write-through clip-mask pixmap, because the protocol allows the
+	    ;; server to copy the pixmap contents at the time of the store,
+	    ;; rather than continuing to share with the pixmap.
+	    (setf (gcontext-internal-clip-mask server-state) nil))))))
+  clip-mask)
+
+(defun gcontext-dashes (gcontext)
+  (declare (type gcontext gcontext))
+  (declare (values (or null card8 sequence)))
+  (access-gcontext (gcontext local-state)
+    (multiple-value-bind (dash dashes)
+	(without-interrupts 
+	  (values (gcontext-internal-dash local-state)
+		  (gcontext-internal-dashes local-state)))
+      (if (null dash)
+	  dashes
+	dash))))
+
+(defsetf gcontext-dashes set-gcontext-dashes)
+
+(defun set-gcontext-dashes (gcontext dashes)
+  (declare (type gcontext gcontext)
+	   (type (or card8 sequence) dashes))
+  (multiple-value-bind (dashes dash)
+      (if (type? dashes 'sequence)
+	  (if (zerop (length dashes))
+	      (x-type-error dashes '(or card8 sequence) "non-empty sequence")
+	    (values nil (or (copy-seq dashes) (vector))))
+	(values (encode-type card8 dashes) nil))
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-dash local-state) dash
+		(gcontext-internal-dashes local-state) dashes)
+	  (if (null dash)
+	      (setf (gcontext-internal-dash server-state) nil)
+	    (setf (gcontext-internal-dashes server-state) nil))))))
+  dashes)
+
+(defun gcontext-font (gcontext &optional metrics-p)
+  ;; If the stored font is known, it is returned.  If it is not known and
+  ;; metrics-p is false, then nil is returned.  If it is not known and
+  ;; metrics-p is true, then a pseudo font is returned.  Full metric and
+  ;; property information can be obtained, but the font does not have a name or
+  ;; a resource-id, and attempts to use it where a resource-id is required will
+  ;; result in an invalid-font error.
+  (declare (type gcontext gcontext)
+	   (type boolean metrics-p))
+  (declare (values (or null font)))
+  (access-gcontext (gcontext local-state)
+    (let ((font (gcontext-internal-font-obj local-state)))
+      (or font
+	  (when metrics-p
+	    ;; XXX this isn't correct
+	    (make-font :display (gcontext-display gcontext)
+		       :id (gcontext-id gcontext)
+		       :name nil))))))
+
+(defsetf gcontext-font set-gcontext-font)
+
+(defun set-gcontext-font (gcontext font)
+  (declare (type gcontext gcontext)
+	   (type fontable font))
+  (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
+	 (font (and font-object (font-id font-object))))
+    ;; XXX need to check font has id (and name?)
+    (modify-gcontext (gcontext local-state)
+      (let ((server-state (gcontext-server-state gcontext)))
+	(declare (type gcontext-state server-state))
+	(without-interrupts
+	  (setf (gcontext-internal-font-obj local-state) font-object
+		(gcontext-internal-font local-state) font)
+	  ;; check against font, not against font-obj
+	  (if (null font)
+	      (setf (gcontext-internal-font server-state) nil)
+	    (setf (gcontext-internal-font-obj server-state) font-object))))))
+  font)
+
+(defun force-gcontext-changes-internal (gcontext)
+  ;; Force any delayed changes.
+  (declare (type gcontext gcontext))
+  #.(declare-buffun)
+
+  (let ((display (gcontext-display gcontext))
+	(server-state (gcontext-server-state gcontext))
+	(local-state (gcontext-local-state gcontext)))
+    (declare (type display display)
+	     (type gcontext-state server-state local-state))
+
+    ;; Update server when timestamps don't match
+    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
+	       (the fixnum (gcontext-internal-timestamp server-state)))
+
+      ;; The display is already locked.
+      (macrolet ((with-buffer ((buffer &key timeout) &body body)
+		   `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
+			   ,@body)))
+
+	;; Because there is no locking on the local state we have to
+	;; assume that state will change and set timestamps up front,
+	;; otherwise by the time we figured out there were no changes
+	;; and tried to store the server stamp as the local stamp, the
+	;; local stamp might have since been modified.
+	(setf (gcontext-internal-timestamp local-state)
+	      (incf-internal-timestamp server-state))
+
+	(block no-changes
+	  (let ((last-request (buffer-last-request display)))
+	    (with-buffer-request (display *x-changegc*)
+	      (gcontext gcontext)
+	      (progn
+		(do ((i 0 (index+ i 1))
+		     (bit 1 (the xgcmask (ash bit 1)))
+		     (nbyte 12)
+		     (mask 0)
+		     (local 0))
+		    ((index>= i *gcontext-fast-change-length*)
+		     (when (zerop mask)
+		       ;; If nothing changed, restore last-request and quit
+		       (setf (buffer-last-request display)
+			     (if (zerop (buffer-last-request display))
+				 nil
+			       last-request))
+		       (return-from no-changes nil))
+		     (card29-put 8 mask)
+		     (card16-put 2 (index-ash nbyte -2))
+		     (index-incf (buffer-boffset display) nbyte))
+		  (declare (type array-index i nbyte)
+			   (type xgcmask bit)
+			   (type gcmask mask)
+			   (type (or null card32) local))
+		  (unless (eql (the (or null card32) (svref server-state i))
+			       (setq local (the (or null card32) (svref local-state i))))
+		    (setf (svref server-state i) local)
+		    (card32-put nbyte local)
+		    (setq mask (the gcmask (logior mask bit)))
+		    (index-incf nbyte 4)))))))
+
+	;; Update GContext extensions
+	(do ((extension *gcontext-extensions* (cdr extension))
+	     (i *gcontext-data-length* (index+ i 1))
+	     (local))
+	    ((endp extension))
+	  (unless (eql (svref server-state i)
+		       (setq local (svref local-state i)))
+	    (setf (svref server-state i) local)
+	    (funcall (gcontext-extension-set-function (car extension)) gcontext local)))
+
+	;; Update clipping rectangles
+	(multiple-value-bind (local-clip server-clip)
+	    (without-interrupts 
+	      (values (gcontext-internal-clip local-state)
+		      (gcontext-internal-clip server-state)))
+	  (unless (equalp local-clip server-clip)
+	    (setf (gcontext-internal-clip server-state) nil)
+	    (unless (null local-clip)
+	      (with-buffer-request (display *x-setcliprectangles*)
+		(data (first local-clip))
+		(gcontext gcontext)
+		;; XXX treat nil correctly
+		(card16 (or (gcontext-internal-clip-x local-state) 0)
+			(or (gcontext-internal-clip-y local-state) 0))
+		;; XXX this has both int16 and card16 values
+		((sequence :format int16) (second local-clip)))
+	      (setf (gcontext-internal-clip server-state) local-clip))))
+
+	;; Update dashes
+	(multiple-value-bind (local-dash server-dash)
+	    (without-interrupts 
+	      (values (gcontext-internal-dash local-state)
+		      (gcontext-internal-dash server-state)))
+	  (unless (equalp local-dash server-dash)
+	    (setf (gcontext-internal-dash server-state) nil)
+	    (unless (null local-dash)
+	      (with-buffer-request (display *x-setdashes*)
+		(gcontext gcontext)
+		;; XXX treat nil correctly
+		(card16 (or (gcontext-internal-dash-offset local-state) 0)
+			(length local-dash))
+		((sequence :format card8) local-dash))
+	      (setf (gcontext-internal-dash server-state) local-dash))))))))
+
+(defun force-gcontext-changes (gcontext)
+  ;; Force any delayed changes.
+  (declare (type gcontext gcontext))
+  (let ((display (gcontext-display gcontext))
+	(server-state (gcontext-server-state gcontext))
+	(local-state (gcontext-local-state gcontext)))
+    (declare (type gcontext-state server-state local-state)
+	     (array-register server-state local-state))
+    ;; Update server when timestamps don't match
+    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
+	       (the fixnum (gcontext-internal-timestamp server-state)))
+      (with-display (display)
+	(force-gcontext-changes-internal gcontext)))))
+
+;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
+;;;	     SET IN THE GCONTEXT ON ENTRY.  BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
+;;;	     UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
+;;;	     COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
+;;;          BACK.
+
+(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
+				   &allow-other-keys)
+			 &body body)
+  ;; "Binds" the gcontext components specified by options within the
+  ;; dynamic scope of the body (i.e., indefinite scope and dynamic
+  ;; extent), on a per-process basis in a multi-process environment.
+  ;; The body is not surrounded by a with-display.  If cache-p is nil or
+  ;; the some component states are unknown, this will implement
+  ;; save/restore by creating a temporary gcontext and doing
+  ;; copy-gcontext-components to and from it.
+
+  (declare (arglist (gcontext &rest options &key
+			     function plane-mask foreground background
+			     line-width line-style cap-style join-style
+			     fill-style fill-rule arc-mode tile stipple ts-x
+			     ts-y font subwindow-mode exposures clip-x clip-y
+			     clip-mask clip-ordering dash-offset dashes
+			     &allow-other-keys)
+		   &body body))
+  (remf options :clip-ordering)
+
+  (let ((gc (gensym))
+	(saved-state (gensym))
+	(temp-gc (gensym))
+	(temp-mask (gensym))
+	(temp-vars nil)
+	(setfs nil)
+	(indexes nil) ; List of gcontext field indices
+	(extension-indexes nil) ; List of gcontext extension field indices
+	(ts-index (getf *gcontext-indexes* :timestamp)))
+
+    (do* ((option options (cddr option))
+	  (name (car option) (car option))
+	  (value (cadr option) (cadr option)))
+	 ((endp option) (setq setfs (nreverse setfs)))
+      (let ((index (getf *gcontext-indexes* name)))
+	(if index
+	    (push index indexes)
+	  (let ((extension (find name *gcontext-extensions*
+				 :key #'gcontext-extension-name)))
+	    (if extension
+		(progn
+		  (push (xintern "Internal-" 'gcontext- name "-State-Index")
+			extension-indexes))
+	      (x-type-error name 'gcontext-key)))))
+      (let ((accessor `(,(xintern 'gcontext- name) ,gc
+			,@(when (eq name :clip-mask) `(,clip-ordering))))
+	    (temp-var (gensym)))
+	(when value
+	  (push `(,temp-var ,value) temp-vars)
+	  (push `(setf ,accessor ,temp-var) setfs))))
+    (if setfs
+	`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
+	     (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
+	   (declare (type gcontext ,gc)
+		    (type gcontext-state ,saved-state)
+		    (type xgcmask ,temp-mask)
+		    (type (or null resource-id) ,temp-gc))
+	   (with-gcontext-bindings (,gc ,saved-state
+					,(append indexes extension-indexes)
+				    ,ts-index ,temp-mask ,temp-gc)
+	     (let ,temp-vars
+	       ,@setfs)
+	     ,@body))
+      `(progn ,@body))))
+
+(defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
+  ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
+  (declare (type gcontext gcontext)
+	   (type list indexes)
+	   (dynamic-extent extension-indices))
+  (let ((local-state (gcontext-local-state gcontext))
+	(saved-state (allocate-gcontext-state))
+	(cache-p (gcontext-cache-p gcontext)))
+    (declare (type gcontext-state local-state saved-state))
+    (setf (gcontext-internal-timestamp saved-state) 1)
+    (let ((temp-gc nil)
+	  (temp-mask 0)
+	  (extension-mask 0))
+      (declare (type xgcmask temp-mask)
+	       (type integer extension-mask))
+      (dolist (i indexes)
+	(when (or (not (setf (svref saved-state i) (svref local-state i)))
+		  (not cache-p))
+	  (setq temp-mask
+		(the xgcmask (logior temp-mask
+				     (the xgcmask (svref *gcontext-masks* i)))))))
+      (dolist (i extension-indices)
+	(when (or (not (setf (svref saved-state i) (svref local-state i)))
+		  (not cache-p))
+	  (setq extension-mask
+		(the xgcmask (logior extension-mask (ash 1 i))))))
+      (when (or (plusp temp-mask)
+		(plusp extension-mask))
+	;; Copy to temporary GC when field unknown or cache-p false
+	(let ((display (gcontext-display gcontext)))
+	  (declare (type display display))
+	  (with-display (display)
+	    (setq temp-gc (allocate-temp-gcontext))
+	    (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
+		  (gcontext-display temp-gc) display
+		  (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
+		  (gcontext-server-state temp-gc) saved-state
+		  (gcontext-local-state temp-gc) saved-state)
+	    ;; Create a new (temporary) gcontext
+	    (with-buffer-request (display *x-creategc*)
+	      (gcontext temp-gc)
+	      (drawable (gcontext-drawable gcontext))
+	      (card29 0))
+	    ;; Copy changed components to the temporary gcontext
+	    (when (plusp temp-mask)
+	      (with-buffer-request (display *x-copygc*)
+		(gcontext gcontext)
+		(gcontext temp-gc)
+		(card29 (xgcmask->gcmask temp-mask))))
+	    ;; Copy extension fields to the new gcontext
+	    (when (plusp extension-mask)
+	      ;; Copy extension fields from temp back to gcontext
+	      (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
+		   (i 0 (index+ i 1)))
+		  ((zerop bit))
+		(let ((copy-function (gcontext-extension-copy-function
+				       (elt *gcontext-extensions* i))))
+		  (funcall copy-function gcontext temp-gc
+			   (svref local-state (index+ i *gcontext-data-length*))))))
+	    )))
+      (values gcontext saved-state (logior temp-mask extension-mask) temp-gc)))) 
+
+(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
+  (declare (type gcontext gcontext temp-gc)
+	   (type xgcmask temp-mask))
+  (let ((display (gcontext-display gcontext)))
+    (declare (type display display))
+    (with-display (display)
+      (with-buffer-request (display *x-copygc*)
+	(gcontext temp-gc)
+	(gcontext gcontext)
+	(card29 (xgcmask->gcmask temp-mask)))
+      ;; Copy extension fields from temp back to gcontext
+      (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
+	   (extensions *gcontext-extensions* (cdr extensions))
+	   (i *gcontext-data-length* (index+ i 1))
+	   (local-state (gcontext-local-state temp-gc)))
+	  ((zerop bit))
+	(let ((copy-function (gcontext-extension-copy-function (car extensions))))
+	  (funcall copy-function temp-gc gcontext (svref local-state i))))
+      ;; free gcontext
+      (with-buffer-request (display *x-freegc*)
+	(gcontext temp-gc))
+      (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
+      (deallocate-temp-gcontext temp-gc)
+      ;; Copy saved state back to server state
+      (do ((server-state (gcontext-server-state gcontext))
+	   (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
+	   (i 0 (index+ i 1)))
+	  ((zerop bit)
+	   (incf-internal-timestamp server-state))
+	(declare (type gcontext-state server-state)
+		 (type gcmask bit)
+		 (type array-index i))
+	(when (oddp bit)
+	  (setf (svref server-state i) nil))))))
+
+(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
+			function plane-mask foreground background
+			line-width line-style cap-style join-style fill-style fill-rule
+			arc-mode tile stipple ts-x ts-y font subwindow-mode
+			exposures clip-x clip-y clip-mask clip-ordering
+			dash-offset dashes
+			(cache-p t)
+			&allow-other-keys)
+  ;; Only non-nil components are passed on in the request, but for effective caching
+  ;; assumptions have to be made about what the actual protocol defaults are.  For
+  ;; all gcontext components, a value of nil causes the default gcontext value to be
+  ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
+  ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
+  ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
+  ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
+  ;; component will have no effect unless the new value differs from the cached
+  ;; value.  Component changes (setfs and with-gcontext) are always deferred
+  ;; regardless of the cache mode, and sent over the protocol only when required by a
+  ;; local operation or by an explicit call to force-gcontext-changes.
+  (declare (type drawable drawable) ; Required to be non-null
+	   (type (or null boole-constant) function)
+	   (type (or null pixel) plane-mask foreground background)
+	   (type (or null card16) line-width dash-offset)
+	   (type (or null int16) ts-x ts-y clip-x clip-y)
+	   (type (or null (member :solid :dash :double-dash)) line-style)
+	   (type (or null (member :not-last :butt :round :projecting)) cap-style)
+	   (type (or null (member :miter :round :bevel)) join-style)
+	   (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
+	   (type (or null (member :even-odd :winding)) fill-rule)
+	   (type (or null (member :chord :pie-slice)) arc-mode)
+	   (type (or null pixmap) tile stipple)
+	   (type (or null fontable) font)
+	   (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
+	   (type (or null (member :on :off)) exposures)
+	   (type (or null (member :none) pixmap rect-seq) clip-mask)
+	   (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
+	   (type (or null card8 sequence) dashes)
+	   (dynamic-extent options)
+	   (type boolean cache-p))
+  (declare (values gcontext))
+  (let* ((display (drawable-display drawable))
+	 (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
+	 (local-state (gcontext-local-state gcontext))
+	 (server-state (gcontext-server-state gcontext))
+	 (gcontextid (allocate-resource-id display gcontext 'gcontext)))
+    (declare (type display display)
+	     (type gcontext gcontext)
+	     (type resource-id gcontextid)
+	     (type gcontext-state local-state server-state))
+    (setf (gcontext-id gcontext) gcontextid)
+
+    (unless function (setf (gcontext-function gcontext) boole-1))
+    ;; using the depth of the drawable would be better, but ...
+    (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
+    (unless foreground (setf (gcontext-foreground gcontext) 0))
+    (unless background (setf (gcontext-background gcontext) 1))
+    (unless line-width (setf (gcontext-line-width gcontext) 0))
+    (unless line-style (setf (gcontext-line-style gcontext) :solid))
+    (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
+    (unless join-style (setf (gcontext-join-style gcontext) :miter))
+    (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
+    (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
+    (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
+    (unless ts-x (setf (gcontext-ts-x gcontext) 0))
+    (unless ts-y (setf (gcontext-ts-y gcontext) 0))
+    (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
+				 :clip-by-children))
+    (unless exposures (setf (gcontext-exposures gcontext) :on))
+    (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
+    (unless clip-x (setf (gcontext-clip-x gcontext) 0))
+    (unless clip-y (setf (gcontext-clip-y gcontext) 0))
+    (unless dashes (setf (gcontext-dashes gcontext) 4))
+    (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
+    ;; a bit kludgy, but ...
+    (replace server-state local-state)
+
+    (when function (setf (gcontext-function gcontext) function))
+    (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
+    (when foreground (setf (gcontext-foreground gcontext) foreground))
+    (when background (setf (gcontext-background gcontext) background))
+    (when line-width (setf (gcontext-line-width gcontext) line-width))
+    (when line-style (setf (gcontext-line-style gcontext) line-style))
+    (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
+    (when join-style (setf (gcontext-join-style gcontext) join-style))
+    (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
+    (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
+    (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
+    (when tile (setf (gcontext-tile gcontext) tile))
+    (when stipple (setf (gcontext-stipple gcontext) stipple))
+    (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
+    (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
+    (when font (setf (gcontext-font gcontext) font))
+    (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
+    (when exposures (setf (gcontext-exposures gcontext) exposures))
+    (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
+    (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
+    (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
+    (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
+    (when dashes (setf (gcontext-dashes gcontext) dashes))
+    
+    (setf (gcontext-internal-timestamp server-state) 1)
+    (setf (gcontext-internal-timestamp local-state) 1)
+    
+    (with-buffer-request (display *x-creategc*)
+      (resource-id gcontextid)
+      (drawable drawable)
+      (progn (do* ((i 0 (index+ i 1))
+		   (bit 1 (the xgcmask (ash bit 1)))
+		   (nbyte 16)
+		   (mask 0)
+		   (local (svref local-state i) (svref local-state i)))
+		 ((index>= i *gcontext-fast-change-length*)
+		  (card29-put 12 mask)
+		  (card16-put 2 (index-ash nbyte -2))
+		  (index-incf (buffer-boffset display) nbyte))
+	       (declare (type array-index i nbyte)
+			(type xgcmask bit)
+			(type gcmask mask)
+			(type (or null card32) local))
+	       (unless (eql local (the (or null card32) (svref server-state i)))
+		 (setf (svref server-state i) local)
+		 (card32-put nbyte local)
+		 (setq mask (the gcmask (logior mask bit)))
+		 (index-incf nbyte 4)))))
+
+    ;; Initialize extensions
+    (do ((extensions *gcontext-extensions* (cdr extensions))
+	 (i *gcontext-data-length* (index+ i 1)))
+	((endp extensions))
+      (declare (type list extensions)
+	       (type array-index i))
+      (setf (svref server-state i)
+	    (setf (svref local-state i)
+		  (gcontext-extension-default (car extensions)))))
+
+    ;; Set extension values
+    (do* ((option-list options (cddr option-list))
+	  (option (car option-list) (car option-list))
+	  (extension))
+	 ((endp option-list))
+      (declare (type list option-list))
+      (cond ((getf *gcontext-indexes* option))	; Gcontext field
+	    ((member option '(:drawable :clip-ordering :cache-p)))	; Optional parameter
+	    ((setq extension (find option *gcontext-extensions*
+				   :key #'gcontext-extension-name))
+	     (funcall (gcontext-extension-set-function extension)
+		      gcontext (second option-list)))
+	    (t (x-type-error option 'gcontext-key))))
+    gcontext)) 
+
+(defun copy-gcontext-components (src dst &rest keys)
+  (declare (type gcontext src dst)
+	   (dynamic-extent keys))
+  ;; you might ask why this isn't just a bunch of
+  ;;   (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
+  ;; the answer is that you can do that yourself if you want, what we are
+  ;; providing here is access to the protocol request, which will generally
+  ;; be more efficient (particularly for things like clip and dash lists).
+  (when keys
+    (let ((display (gcontext-display src))
+	  (mask 0))
+      (declare (type xgcmask mask))
+      (with-display (display)
+	(force-gcontext-changes-internal src)
+	(force-gcontext-changes-internal dst)
+	
+	;; collect entire mask and handle extensions
+	(dolist (key keys)
+	  (let ((i (getf *gcontext-indexes* key)))
+	    (declare (type (or null array-index) i))
+	    (if i
+		(setq mask (the xgcmask (logior mask
+						(the xgcmask (svref *gcontext-masks* i)))))
+	      (multiple-value-bind (extension index)
+		  (find key *gcontext-extensions* :key #'gcontext-extension-name)
+		(if extension
+		    (funcall (gcontext-extension-copy-function extension)
+			     src dst (svref (gcontext-local-state src)
+					    (index+ index *gcontext-data-length*)))
+		  (x-type-error key 'gcontext-key))))))
+	
+	(when (plusp mask)
+	  (do ((src-server-state (gcontext-server-state src))
+	       (dst-server-state (gcontext-server-state dst))
+	       (dst-local-state (gcontext-local-state dst))
+	       (bit mask (the xgcmask (ash bit -1)))
+	       (i 0 (index+ i 1)))
+	      ((zerop bit)
+	       (incf-internal-timestamp dst-server-state)
+	       (setf (gcontext-internal-timestamp dst-local-state) 0))
+	    (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
+		     (type xgcmask bit)
+		     (type array-index i))
+	    (when (oddp bit)
+	      (setf (svref dst-local-state i)
+		    (setf (svref dst-server-state i) (svref src-server-state i)))))
+	  (with-buffer-request (display *x-copygc*)
+	    (gcontext src dst)
+	    (card29 (xgcmask->gcmask mask))))))))
+
+(defun copy-gcontext (src dst)
+  (declare (type gcontext src dst))
+  ;; Copies all components.
+  (apply #'copy-gcontext-components src dst *gcontext-components*)
+  (do ((extensions *gcontext-extensions* (cdr extensions))
+       (i *gcontext-data-length* (index+ i 1)))
+      ((endp extensions))
+    (funcall (gcontext-extension-copy-function (car extensions))
+	     src dst (svref (gcontext-local-state src) i))))
+	   
+(defun free-gcontext (gcontext)
+  (declare (type gcontext gcontext))
+  (let ((display (gcontext-display gcontext)))
+    (with-buffer-request (display *x-freegc*)
+      (gcontext gcontext))
+    (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
+    (deallocate-gcontext-state (gcontext-server-state gcontext))
+    (deallocate-gcontext-state (gcontext-local-state gcontext))
+    nil))
+
+(defmacro define-gcontext-accessor (name &key default set-function copy-function)
+  ;; This will define a new gcontext accessor called NAME.
+  ;; Defines the gcontext-NAME accessor function and its defsetf.
+  ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
+  ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
+  ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
+  ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
+  ;; from create-gcontext, and force-gcontext-changes.
+  ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
+  ;; from copy-gcontext and copy-gcontext-components.
+  ;; The copy-function defaults to:
+  ;; (lambda (ignore dst-gc value)
+  ;;    (if value
+  ;;	    (,set-function dst-gc value)
+  ;;	  (error "Can't copy unknown GContext component ~a" ',name)))
+  (declare (type symbol name)
+	   (type t default)
+	   (type (function (gcontext t) t) set-function) ;; required
+	   (type (or null (function (gcontext gcontext t) t))
+		 copy-function))
+  (let* ((gc-name (intern (concatenate 'string
+				       (string 'gcontext-)
+				       (string name)))) ;; in current package
+	 (key-name (kintern name))
+	 (setfer (xintern "Set-" gc-name))
+	 (internal-set-function (xintern "Internal-Set-" gc-name))
+	 (internal-copy-function (xintern "Internal-Copy-" gc-name))
+	 (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
+    (unless copy-function
+      (setq copy-function
+	    `(lambda (src-gc dst-gc value)
+	       (declare (ignore src-gc))
+	       (if value
+		   (,set-function dst-gc value)
+		 (error "Can't copy unknown GContext component ~a" ',name)))))
+    `(progn
+       (eval-when (compile load eval)
+	 (defparameter ,internal-state-index
+		       (add-gcontext-extension ',key-name ,default ',internal-set-function
+					       ',internal-copy-function))
+	 ) ;; end eval-when
+       (defun ,gc-name (gcontext)
+	 (svref (gcontext-local-state gcontext) ,internal-state-index))
+       (defun ,setfer (gcontext new-value)
+	 (let ((local-state (gcontext-local-state gcontext)))
+	   (setf (gcontext-internal-timestamp local-state) 0)
+	   (setf (svref local-state ,internal-state-index) new-value)))
+       (defsetf ,gc-name ,setfer)
+       (defun ,internal-set-function (gcontext new-value)
+	 (,set-function gcontext new-value)
+	 (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
+	       (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
+		     new-value)))
+       (defun ,internal-copy-function (src-gc dst-gc new-value)
+	 (,copy-function src-gc dst-gc new-value)
+	 (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
+	       (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
+		     new-value)))
+       ',name)))
+
+;; GContext extension fields are treated in much the same way as normal GContext
+;; components.  The current value is stored in a slot of the gcontext-local-state,
+;; and the value known to the server is in a slot of the gcontext-server-state.
+;; The slot-number is defined by its position in the *gcontext-extensions* list.
+;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is 
+;; the extension component name) reflects this position.  The position within
+;; *gcontext-extensions* and the value of the special value are determined at
+;; LOAD time to facilitate merging of seperately compiled extension files.
+
+(defun add-gcontext-extension (name default-value set-function copy-function)
+  (declare (type symbol name)
+	   (type t default-value)
+	   (type (function (gcontext t) t) set-function)
+	   (type (function (gcontext gcontext t) t) copy-function))
+  (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
+		    (prog1 (length *gcontext-extensions*)
+			   (push nil *gcontext-extensions*)))))
+    (setf (nth number *gcontext-extensions*)
+	  (make-gcontext-extension :name name
+				   :default default-value
+				   :set-function set-function
+				   :copy-function copy-function))
+    (+ number *gcontext-data-length*)))
diff --git a/clx/image.lisp b/clx/image.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..152af53f8a65114e315359545afe0d0c99836fc9
--- /dev/null
+++ b/clx/image.lisp
@@ -0,0 +1,2697 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;;; CLX Image functions
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(bitmap
+	  pixarray 
+	  image
+	  image-width
+	  image-height
+	  image-depth
+	  image-plist
+	  image-name
+	  image-x-hot
+	  image-y-hot
+	  image-red-mask
+	  image-blue-mask
+	  image-green-mask
+	  image-x
+	  image-xy
+	  image-z
+	  image-x-p
+	  image-xy-p
+	  image-z-p
+	  image-xy-bitmap-list
+	  image-z-bits-per-pixel
+	  image-z-pixarray
+	  create-image
+	  get-image
+	  put-image
+	  copy-image
+	  read-bitmap-file
+	  write-bitmap-file
+	  bitmap-image
+	  image-pixmap))
+
+(def-clx-class (image (:constructor nil) (:copier nil) (:predicate nil))
+  ;; Public structure
+  (width 0 :type card16 :read-only t)
+  (height 0 :type card16 :read-only t)
+  (depth 1 :type card8 :read-only t)
+  (plist nil :type list))
+
+;; Image-Plist accessors:
+(defmacro image-name (image) `(getf (image-plist ,image) :name))
+(defmacro image-x-hot (image) `(getf (image-plist ,image) :x-hot))
+(defmacro image-y-hot (image) `(getf (image-plist ,image) :y-hot))
+(defmacro image-red-mask (image) `(getf (image-plist ,image) :red-mask))
+(defmacro image-blue-mask (image) `(getf (image-plist ,image) :blue-mask))
+(defmacro image-green-mask (image) `(getf (image-plist ,image) :green-mask))
+
+(defun print-image (image stream depth)
+  (declare (type image image)
+	   (ignore depth))
+  (print-unreadable-object (image stream :type t)
+    (when (image-name image)
+      (princ (image-name image) stream)
+      (princ " " stream))
+    (prin1 (image-width image) stream)
+    (princ "x" stream)
+    (prin1 (image-height image) stream)
+    (princ "x" stream)
+    (prin1 (image-depth image) stream)))
+
+(defconstant *empty-data-x* #.(make-sequence '(array card8 (*)) 0))
+
+(defconstant *empty-data-z*
+	     #.(make-array '(0 0) :element-type 'pixarray-1-element-type))
+
+(def-clx-class (image-x (:include image) (:copier nil)
+			(:print-function print-image))
+  ;; Use this format for shoveling image data
+  ;; Private structure. Accessors for these NOT exported.
+  (format :z-pixmap :type (member :bitmap :xy-pixmap :z-pixmap))
+  (bytes-per-line 0 :type card16)
+  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
+  (bit-lsb-first-p *image-bit-lsb-first-p* :type boolean)	; Bit order
+  (byte-lsb-first-p *image-byte-lsb-first-p* :type boolean)	; Byte order
+  (data *empty-data-x* :type (array card8 (*)))			; row-major
+  (unit *image-unit* :type (member 8 16 32))			; Bitmap unit
+  (pad *image-pad* :type (member 8 16 32))			; Scanline pad
+  (left-pad 0 :type card8))					; Left pad
+
+(def-clx-class (image-xy (:include image) (:copier nil)
+			 (:print-function print-image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bitmap-list nil :type list)) ;; list of bitmaps
+
+(def-clx-class (image-z (:include image) (:copier nil)
+			(:print-function print-image))
+  ;; Public structure
+  ;; Use this format for image processing
+  (bits-per-pixel 1 :type (member 1 4 8 16 24 32))
+  (pixarray *empty-data-z* :type pixarray))
+
+(defun create-image (&key width height depth
+		     (data (required-arg data))
+		     plist name x-hot y-hot
+		     red-mask blue-mask green-mask
+		     bits-per-pixel format bytes-per-line
+		     (byte-lsb-first-p *image-byte-lsb-first-p*)
+		     (bit-lsb-first-p *image-bit-lsb-first-p*)
+		     unit pad left-pad)
+  ;; Returns an image-x image-xy or image-z structure, depending on the
+  ;; type of the :DATA parameter.
+  (declare
+    (type (or null card16) width height)	; Required
+    (type (or null card8) depth)		; Defualts to 1
+    (type (or buffer-bytes			; Returns image-x
+	      list				; Returns image-xy
+	      pixarray) data)			; Returns image-z
+    (type list plist)
+    (type (or null stringable) name)
+    (type (or null card16) x-hot y-hot)
+    (type (or null pixel) red-mask blue-mask green-mask)
+    (type (or null (member 1 4 8 16 24 32)) bits-per-pixel)
+    
+    ;; The following parameters are ignored for image-xy and image-z:
+    (type (or null (member :bitmap :xy-pixmap :z-pixmap))
+	  format)				; defaults to :z-pixmap
+    (type (or null card16) bytes-per-line)
+    (type boolean byte-lsb-first-p bit-lsb-first-p)
+    (type (or null (member 8 16 32)) unit pad)
+    (type (or null card8) left-pad))
+  (declare (values image))
+  (let ((image
+	  (etypecase data
+	    (buffer-bytes			; image-x
+	      (let ((data data))
+		(declare (type buffer-bytes data))
+		(unless depth (setq depth (or bits-per-pixel 1)))
+		(unless format
+		  (setq format (if (= depth 1) :xy-pixmap :z-pixmap)))
+		(unless bits-per-pixel
+		  (setq bits-per-pixel
+			(cond ((eq format :xy-pixmap) 1)
+			      ((index> depth 24) 32)
+			      ((index> depth 16) 24)
+			      ((index> depth 8)  16)
+			      ((index> depth 4)   8)
+			      ((index> depth 1)   4)
+			      (t                  1))))
+		(unless width (required-arg width))
+		(unless height (required-arg height))
+		(unless bytes-per-line
+		  (let* ((pad (or pad 8))
+			 (bits-per-line (index* width bits-per-pixel))
+			 (padded-bits-per-line
+			   (index* (index-ceiling bits-per-line pad) pad)))
+		    (declare (type array-index pad bits-per-line
+				   padded-bits-per-line))
+		    (setq bytes-per-line (index-ceiling padded-bits-per-line 8))))
+		(unless unit (setq unit *image-unit*))
+		(unless pad
+		  (setq pad
+			(dolist (pad '(32 16 8))
+			  (when (and (index<= pad *image-pad*)
+				     (zerop
+				       (index-mod
+					 (index* bytes-per-line 8) pad)))
+			    (return pad)))))
+		(unless left-pad (setq left-pad 0))
+		(make-image-x
+		  :width width :height height :depth depth :plist plist
+		  :format format :data data
+		  :bits-per-pixel bits-per-pixel 
+		  :bytes-per-line bytes-per-line
+		  :byte-lsb-first-p byte-lsb-first-p
+		  :bit-lsb-first-p bit-lsb-first-p
+		  :unit unit :pad pad :left-pad left-pad)))
+	    (list				; image-xy
+	      (let ((data data))
+		(declare (type list data))
+		(unless depth (setq depth (length data)))
+		(when data
+		  (unless width (setq width (array-dimension (car data) 1)))
+		  (unless height (setq height (array-dimension (car data) 0))))
+		(make-image-xy
+		  :width width :height height :plist plist :depth depth
+		  :bitmap-list data)))
+	    (pixarray				; image-z
+	      (let ((data data))
+		(declare (type pixarray data))
+		(unless width (setq width (array-dimension data 1)))
+		(unless height (setq height (array-dimension data 0)))
+		(unless bits-per-pixel
+		  (setq bits-per-pixel
+			(etypecase data
+			  (pixarray-32 32)
+			  (pixarray-24 24)
+			  (pixarray-16 16)
+			  (pixarray-8   8)
+			  (pixarray-4   4)
+			  (pixarray-1   1)))))
+	      (unless depth (setq depth bits-per-pixel))
+	      (make-image-z
+		:width width :height height :depth depth :plist plist
+		:bits-per-pixel bits-per-pixel :pixarray data)))))
+    (declare (type image image))
+    (when name (setf (image-name image) name))
+    (when x-hot (setf (image-x-hot image) x-hot))
+    (when y-hot (setf (image-y-hot image) y-hot))
+    (when red-mask (setf (image-red-mask image) red-mask))
+    (when blue-mask (setf (image-blue-mask image) blue-mask))
+    (when green-mask (setf (image-green-mask image) green-mask))
+    image))
+
+;;;-----------------------------------------------------------------------------
+;;; Swapping stuff
+
+(defun image-noswap
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p)
+	   (ignore lsb-first-p))
+  #.(declare-buffun)
+  (if (index= srcinc destinc)
+      (buffer-replace
+	dest src destoff
+	(index+ destoff (index* srcinc (index1- height)) srclen)
+	srcoff)
+    (do* ((h height (index1- h))
+	  (srcstart srcoff (index+ srcstart srcinc))
+	  (deststart destoff (index+ deststart destinc))
+	  (destend (index+ deststart srclen) (index+ deststart srclen)))
+	 ((index-zerop h))
+      (declare (type array-index srcstart deststart destend)
+	       (type card16 h))
+      (buffer-replace dest src deststart destend srcstart))))
+
+(defun image-swap-two-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 2) 2))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 2)
+	  (if lsb-first-p
+	      (setf (aref dest (index1+ (index+ deststart length)))
+		    (the card8 (aref src (index+ srcstart length))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index1+ (index+ srcstart length)))))))
+	(do ((i length (index- i 2))
+	     (srcidx srcstart (index+ srcidx 2))
+	     (destidx deststart (index+ destidx 2)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-three-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 3) 3))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 3)
+	  (when (index= (index- srclen length) 2)
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (if lsb-first-p
+	      (setf (aref dest (index+ deststart length 2))
+		    (the card8 (aref src (index+ srcstart length))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 2))))))
+	(do ((i length (index- i 3))
+	     (srcidx srcstart (index+ srcidx 3))
+	     (destidx deststart (index+ destidx 3)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-four-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 4) 4))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 4)
+	  (unless lsb-first-p
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 3)))))
+	  (when (if lsb-first-p
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 2)))))
+	  (when (if (null lsb-first-p)
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 2))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (when lsb-first-p
+	    (setf (aref dest (index+ deststart length 3))
+		  (the card8 (aref src (index+ srcstart length))))))
+	(do ((i length (index- i 4))
+	     (srcidx srcstart (index+ srcidx 4))
+	     (destidx deststart (index+ destidx 4)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 3))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src (index1+ srcidx))))
+	  (setf (aref dest (index+ destidx 3))
+		(the card8 (aref src srcidx))))))))
+
+(defun image-swap-words
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((length (index* (index-ceiling srclen 4) 4))
+	   (h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index length srcstart deststart)
+		 (type card16 h))
+	(when (and (index= h 1) (not (index= srclen length)))
+	  (index-decf length 4)
+	  (unless lsb-first-p
+	    (setf (aref dest (index+ deststart length 1))
+		  (the card8 (aref src (index+ srcstart length 3)))))
+	  (when (if lsb-first-p
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length))
+		  (the card8 (aref src (index+ srcstart length 2)))))
+	  (when (if (null lsb-first-p)
+		    (index= (index- srclen length) 3)
+		  (not (index-zerop (index-logand srclen 2))))
+	    (setf (aref dest (index+ deststart length 3))
+		  (the card8 (aref src (index+ srcstart length 1)))))
+	  (when lsb-first-p
+	    (setf (aref dest (index+ deststart length 2))
+		  (the card8 (aref src (index+ srcstart length))))))
+	(do ((i length (index- i 4))
+	     (srcidx srcstart (index+ srcidx 4))
+	     (destidx deststart (index+ destidx 4)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8 (aref src (index+ srcidx 2))))
+	  (setf (aref dest (index1+ destidx))
+		(the card8 (aref src (index+ srcidx 3))))
+	  (setf (aref dest (index+ destidx 2))
+		(the card8 (aref src srcidx)))
+	  (setf (aref dest (index+ destidx 3))
+		(the card8 (aref src (index1+ srcidx)))))))))
+
+(defun image-swap-nibbles
+       (src dest srcoff destoff srclen srcinc destinc height)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index srcstart deststart)
+		 (type card16 h))
+	(do ((i srclen (index1- i))
+	     (srcidx srcstart (index1+ srcidx))
+	     (destidx deststart (index1+ destidx)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8
+		     (let ((byte (aref src srcidx)))
+		       (declare (type card8 byte))
+		       (dpb (the card4 (ldb (byte 4 0) byte))
+			    (byte 4 4)
+			    (the card4 (ldb (byte 4 4) byte)))))))))))
+
+(defun image-swap-nibbles-left
+       (src dest srcoff destoff srclen srcinc destinc height)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (do ((h height (index1- h))
+	   (srcstart srcoff (index+ srcstart srcinc))
+	   (deststart destoff (index+ deststart destinc)))
+	  ((index-zerop h))
+	(declare (type array-index srcstart deststart)
+		 (type card16 h))
+	(do ((i srclen (index1- i))
+	     (srcidx srcstart (index1+ srcidx))
+	     (destidx deststart (index1+ destidx)))
+	    ((index-zerop i))
+	  (declare (type array-index i srcidx destidx))
+	  (setf (aref dest destidx)
+		(the card8
+		     (let ((byte1 (aref src srcidx))
+			   (byte2 (aref src (index1+ srcidx))))
+		       (declare (type card8 byte1 byte2))
+		       (dpb (the card4 (ldb (byte 4 0) byte1))
+			    (byte 4 4)
+			    (the card4 (ldb (byte 4 4) byte2)))))))))))
+
+(defconstant
+  *image-byte-reverse*
+  '#.(coerce
+       '#(
+	  0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
+	  8 136 72 200 40 168 104 232 24 152 88 216 56 184 120 248
+	  4 132 68 196 36 164 100 228 20 148 84 212 52 180 116 244
+	  12 140 76 204 44 172 108 236 28 156 92 220 60 188 124 252
+	  2 130 66 194 34 162 98 226 18 146 82 210 50 178 114 242
+	  10 138 74 202 42 170 106 234 26 154 90 218 58 186 122 250
+	  6 134 70 198 38 166 102 230 22 150 86 214 54 182 118 246
+	  14 142 78 206 46 174 110 238 30 158 94 222 62 190 126 254
+	  1 129 65 193 33 161 97 225 17 145 81 209 49 177 113 241
+	  9 137 73 201 41 169 105 233 25 153 89 217 57 185 121 249
+	  5 133 69 197 37 165 101 229 21 149 85 213 53 181 117 245
+	  13 141 77 205 45 173 109 237 29 157 93 221 61 189 125 253
+	  3 131 67 195 35 163 99 227 19 147 83 211 51 179 115 243
+	  11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
+	  7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
+	  15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
+       '(vector card8)))
+
+(defun image-swap-bits
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p)
+	   (ignore lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index srcstart deststart)
+		       (type card16 h))
+	      (do ((i srclen (index1- i))
+		   (srcidx srcstart (index1+ srcidx))
+		   (destidx deststart (index1+ destidx)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx) (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-two-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 2) 2))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 2)
+		(if lsb-first-p
+		    (setf (aref dest (index1+ (index+ deststart length)))
+			  (br (aref src (index+ srcstart length))))
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index1+ (index+ srcstart length)))))))
+	      (do ((i length (index- i 2))
+		   (srcidx srcstart (index+ srcidx 2))
+		   (destidx deststart (index+ destidx 2)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index1+ srcidx))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-four-bytes
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 4) 4))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 4)
+		(unless lsb-first-p
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index+ srcstart length 3)))))
+		(when (if lsb-first-p
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 1))
+			(br (aref src (index+ srcstart length 2)))))
+		(when (if (null lsb-first-p)
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 2))
+			(br (aref src (index+ srcstart length 1)))))
+		(when lsb-first-p
+		  (setf (aref dest (index+ deststart length 3))
+			(br (aref src (index+ srcstart length))))))
+	      (do ((i length (index- i 4))
+		   (srcidx srcstart (index+ srcidx 4))
+		   (destidx deststart (index+ destidx 4)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index+ srcidx 3))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src (index+ srcidx 2))))
+		(setf (aref dest (index+ destidx 2))
+		      (br (aref src (index1+ srcidx))))
+		(setf (aref dest (index+ destidx 3))
+		      (br (aref src srcidx)))))))))))
+
+(defun image-swap-bits-and-words
+       (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type boolean lsb-first-p))
+  #.(declare-buffun)
+  (with-vector (src buffer-bytes)
+    (with-vector (dest buffer-bytes)
+      (let ((byte-reverse *image-byte-reverse*))
+	(with-vector (byte-reverse (simple-array card8 (256)))
+	  (macrolet ((br (byte)
+		       `(the card8 (aref byte-reverse (the card8 ,byte)))))
+	    (do ((length (index* (index-ceiling srclen 4) 4))
+		 (h height (index1- h))
+		 (srcstart srcoff (index+ srcstart srcinc))
+		 (deststart destoff (index+ deststart destinc)))
+		((index-zerop h))
+	      (declare (type array-index length srcstart deststart)
+		       (type card16 h))
+	      (when (and (index= h 1) (not (index= srclen length)))
+		(index-decf length 4)
+		(unless lsb-first-p
+		  (setf (aref dest (index+ deststart length 1))
+			(br (aref src (index+ srcstart length 3)))))
+		(when (if lsb-first-p
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length))
+			(br (aref src (index+ srcstart length 2)))))
+		(when (if (null lsb-first-p)
+			  (index= (index- srclen length) 3)
+			(not (index-zerop (index-logand srclen 2))))
+		  (setf (aref dest (index+ deststart length 3))
+			(br (aref src (index+ srcstart length 1)))))
+		(when lsb-first-p
+		  (setf (aref dest (index+ deststart length 2))
+			(br (aref src (index+ srcstart length))))))
+	      (do ((i length (index- i 4))
+		   (srcidx srcstart (index+ srcidx 4))
+		   (destidx deststart (index+ destidx 4)))
+		  ((index-zerop i))
+		(declare (type array-index i srcidx destidx))
+		(setf (aref dest destidx)
+		      (br (aref src (index+ srcidx 2))))
+		(setf (aref dest (index1+ destidx))
+		      (br (aref src (index+ srcidx 3))))
+		(setf (aref dest (index+ destidx 2))
+		      (br (aref src srcidx)))
+		(setf (aref dest (index+ destidx 3))
+		      (br (aref src (index1+ srcidx))))))))))))
+
+;;; The following table gives the bit ordering within bytes (when accessed
+;;; sequentially) for a scanline containing 32 bits, with bits numbered 0 to
+;;; 31, where bit 0 should be leftmost on the display.  For a given byte
+;;; labelled A-B, A is for the most significant bit of the byte, and B is
+;;; for the least significant bit.
+;;; 
+;;; legend:
+;;; 	1   scanline-unit = 8
+;;; 	2   scanline-unit = 16
+;;; 	4   scanline-unit = 32
+;;; 	M   byte-order = MostSignificant
+;;; 	L   byte-order = LeastSignificant
+;;; 	m   bit-order = MostSignificant
+;;; 	l   bit-order = LeastSignificant
+;;; 
+;;; 
+;;; format	ordering
+;;; 
+;;; 1Mm	00-07 08-15 16-23 24-31
+;;; 2Mm	00-07 08-15 16-23 24-31
+;;; 4Mm	00-07 08-15 16-23 24-31
+;;; 1Ml	07-00 15-08 23-16 31-24
+;;; 2Ml	15-08 07-00 31-24 23-16
+;;; 4Ml	31-24 23-16 15-08 07-00
+;;; 1Lm	00-07 08-15 16-23 24-31
+;;; 2Lm	08-15 00-07 24-31 16-23
+;;; 4Lm	24-31 16-23 08-15 00-07
+;;; 1Ll	07-00 15-08 23-16 31-24
+;;; 2Ll	07-00 15-08 23-16 31-24
+;;; 4Ll	07-00 15-08 23-16 31-24
+;;; 
+;;; 
+;;; The following table gives the required conversion between any two
+;;; formats.  It is based strictly on the table above.  If you believe one,
+;;; you should believe the other.
+;;; 
+;;; legend:
+;;; 	n   no changes
+;;; 	s   reverse 8-bit units within 16-bit units
+;;; 	l   reverse 8-bit units within 32-bit units
+;;; 	w   reverse 16-bit units within 32-bit units
+;;; 	r   reverse bits within 8-bit units
+;;; 	sr  s+R
+;;; 	lr  l+R
+;;; 	wr  w+R
+
+(defconstant 
+  *image-swap-function*
+  '#.(make-array
+       '(12 12) :initial-contents
+       (let ((n  'image-noswap)
+	     (s  'image-swap-two-bytes)
+	     (l  'image-swap-four-bytes)
+	     (w  'image-swap-words)
+	     (r  'image-swap-bits)
+	     (sr 'image-swap-bits-and-two-bytes)
+	     (lr 'image-swap-bits-and-four-bytes)
+	     (wr 'image-swap-bits-and-words))
+	 (list #|             1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll  |#
+	       (list #| 1Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 2Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 4Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 1Ml |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 2Ml |# sr  sr  sr  s   n   w   sr  r   wr  s   s   s )
+	       (list #| 4Ml |# lr  lr  lr  l   w   n   lr  wr  r   l   l   l )
+	       (list #| 1Lm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
+	       (list #| 2Lm |# s   s   s   sr  r   wr  s   n   w   sr  sr  sr)
+	       (list #| 4Lm |# l   l   l   lr  wr  r   l   w   n   lr  lr  lr)
+	       (list #| 1Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 2Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
+	       (list #| 4Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )))))
+
+;;; Of course, the table above is a lie.  We also need to factor in the
+;;; order of the source data to cope with swapping half of a unit at the
+;;; end of a scanline, since we are trying to avoid de-ref'ing off the
+;;; end of the source.
+;;;
+;;; Defines whether the first half of a unit has the first half of the data
+
+(defconstant
+  *image-swap-lsb-first-p*
+  '#.(make-array
+       12 :initial-contents
+       (list t   #| 1mm |#
+	     t   #| 2mm |#
+	     t   #| 4mm |#
+	     t   #| 1ml |#
+	     nil #| 2ml |#
+	     nil #| 4ml |#
+	     t   #| 1lm |#
+	     nil #| 2lm |#
+	     nil #| 4lm |#
+	     t   #| 1ll |#
+	     t   #| 2ll |#
+	     t   #| 4ll |#
+	     )))
+
+(defun image-swap-function
+       (from-bitmap-unit from-bitmap-byte-lsb-first-p
+	from-bitmap-bit-lsb-first-p to-bitmap-unit
+	to-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p)
+  (declare (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-bitmap-bit-lsb-first-p
+		 from-bitmap-byte-lsb-first-p to-bitmap-bit-lsb-first-p
+		 to-bitmap-byte-lsb-first-p)
+	   (values function lsb-first-p))
+  (let ((from-index
+	  (index+
+	    (ecase from-bitmap-unit (32 2) (16 1) (8 0))
+	    (if from-bitmap-bit-lsb-first-p 3 0)
+	    (if from-bitmap-byte-lsb-first-p 6 0))))
+    (values
+      (aref *image-swap-function* from-index
+	    (index+
+	      (ecase to-bitmap-unit (32 2) (16 1) (8 0))
+	      (if to-bitmap-bit-lsb-first-p 3 0)
+	      (if to-bitmap-byte-lsb-first-p 6 0)))
+      (aref *image-swap-lsb-first-p* from-index))))
+
+(defun image-swap-xy
+       (src dest srcoff destoff srclen srcinc destinc height
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type card16 height)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (multiple-value-bind (function lsb-first-p)
+      (image-swap-function
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+    (declare (type symbol function)
+	     (type boolean lsb-first-p))
+    (funcall function src dest srcoff destoff srclen srcinc destinc height
+	     lsb-first-p)))
+
+(defun image-swap-z
+       (src dest srcoff destoff srclen srcinc destinc height
+	bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p)
+  (declare (type buffer-bytes src dest)
+	   (type array-index srcoff destoff srclen srcinc destinc)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type card16 height)
+	   (type boolean from-byte-lsb-first-p to-byte-lsb-first-p))
+  (cond ((or (eq from-byte-lsb-first-p to-byte-lsb-first-p)
+	     (= bits-per-pixel 8))
+	 (image-noswap
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 32)
+	 (image-swap-four-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 24)
+	 (image-swap-three-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	((= bits-per-pixel 16)
+	 (image-swap-two-bytes
+	   src dest srcoff destoff srclen srcinc destinc height
+	   from-byte-lsb-first-p))
+	(t
+	 (image-swap-nibbles
+	   src dest srcoff destoff srclen srcinc destinc height))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; GET-IMAGE
+
+(defun read-pixarray-1 (buffer-bbuf index array x y width height  
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 8))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-bits (index-mod (index- x) 8))
+	  (right-bits (index-mod (index- width left-bits) 8))
+	  (middle-bits (index- width left-bits right-bits))
+	  (middle-bytes (index-floor middle-bits 8)))
+	 ((index>= y height))
+      (declare (type array-index start y
+		     left-bits right-bits middle-bits middle-bytes))
+      (cond ((index< middle-bits 0)
+	     (let ((byte (aref buffer-bbuf (index1- start)))
+		   (x left-bits))
+	       (declare (type card8 byte)
+			(type array-index x))
+	       (when (index> right-bits 6)
+		 (setf (aref array y (index- x 1))
+		       (read-image-load-byte 1 7 byte)))
+	       (when (and (index> left-bits 1)
+			  (index> right-bits 5))
+		 (setf (aref array y (index- x 2))
+		       (read-image-load-byte 1 6 byte)))
+	       (when (and (index> left-bits 2)
+			  (index> right-bits 4))
+		 (setf (aref array y (index- x 3))
+		       (read-image-load-byte 1 5 byte)))
+	       (when (and (index> left-bits 3)
+			  (index> right-bits 3))
+		 (setf (aref array y (index- x 4))
+		       (read-image-load-byte 1 4 byte)))
+	       (when (and (index> left-bits 4)
+			  (index> right-bits 2))
+		 (setf (aref array y (index- x 5))
+		       (read-image-load-byte 1 3 byte)))
+	       (when (and (index> left-bits 5)
+			  (index> right-bits 1))
+		 (setf (aref array y (index- x 6))
+		       (read-image-load-byte 1 2 byte)))
+	       (when (index> left-bits 6)
+		 (setf (aref array y (index- x 7))
+		       (read-image-load-byte 1 1 byte)))))
+	    (t
+	     (unless (index-zerop left-bits)
+	       (let ((byte (aref buffer-bbuf (index1- start)))
+		     (x left-bits))
+		 (declare (type card8 byte)
+			  (type array-index x))
+		 (setf (aref array y (index- x 1))
+		       (read-image-load-byte 1 7 byte))
+		 (when (index> left-bits 1)
+		   (setf (aref array y (index- x 2))
+			 (read-image-load-byte 1 6 byte))
+		   (when (index> left-bits 2)
+		     (setf (aref array y (index- x 3))
+			   (read-image-load-byte 1 5 byte))
+		     (when (index> left-bits 3)
+		       (setf (aref array y (index- x 4))
+			     (read-image-load-byte 1 4 byte))
+		       (when (index> left-bits 4)
+			 (setf (aref array y (index- x 5))
+			       (read-image-load-byte 1 3 byte))
+			 (when (index> left-bits 5)
+			   (setf (aref array y (index- x 6))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> left-bits 6)
+			     (setf (aref array y (index- x 7))
+				   (read-image-load-byte 1 1 byte))
+			     ))))))))
+	     (do* ((end (index+ start middle-bytes))
+		   (i start (index1+ i))
+		   (x left-bits (index+ x 8)))
+		  ((index>= i end)
+		   (unless (index-zerop right-bits)
+		     (let ((byte (aref buffer-bbuf end))
+			   (x (index+ left-bits middle-bits)))
+		       (declare (type card8 byte)
+				(type array-index x))
+		       (setf (aref array y (index+ x 0))
+			     (read-image-load-byte 1 0 byte))
+		       (when (index> right-bits 1)
+			 (setf (aref array y (index+ x 1))
+			       (read-image-load-byte 1 1 byte))
+			 (when (index> right-bits 2)
+			   (setf (aref array y (index+ x 2))
+				 (read-image-load-byte 1 2 byte))
+			   (when (index> right-bits 3)
+			     (setf (aref array y (index+ x 3))
+				   (read-image-load-byte 1 3 byte))
+			     (when (index> right-bits 4)
+			       (setf (aref array y (index+ x 4))
+				     (read-image-load-byte 1 4 byte))
+			       (when (index> right-bits 5)
+				 (setf (aref array y (index+ x 5))
+				       (read-image-load-byte 1 5 byte))
+				 (when (index> right-bits 6)
+				   (setf (aref array y (index+ x 6))
+					 (read-image-load-byte 1 6 byte))
+				   )))))))))
+	       (declare (type array-index end i x))
+	       (let ((byte (aref buffer-bbuf i)))
+		 (declare (type card8 byte))
+		 (setf (aref array y (index+ x 0))
+		       (read-image-load-byte 1 0 byte))
+		 (setf (aref array y (index+ x 1))
+		       (read-image-load-byte 1 1 byte))
+		 (setf (aref array y (index+ x 2))
+		       (read-image-load-byte 1 2 byte))
+		 (setf (aref array y (index+ x 3))
+		       (read-image-load-byte 1 3 byte))
+		 (setf (aref array y (index+ x 4))
+		       (read-image-load-byte 1 4 byte))
+		 (setf (aref array y (index+ x 5))
+		       (read-image-load-byte 1 5 byte))
+		 (setf (aref array y (index+ x 6))
+		       (read-image-load-byte 1 6 byte))
+		 (setf (aref array y (index+ x 7))
+		       (read-image-load-byte 1 7 byte))))
+	     )))))
+
+(defun read-pixarray-4 (buffer-bbuf index array x y width height 
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index-ceiling x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y))
+	  (left-nibbles (index-mod (index- x) 2))
+	  (right-nibbles (index-mod (index- width left-nibbles) 2))
+	  (middle-nibbles (index- width left-nibbles right-nibbles))
+	  (middle-bytes (index-floor middle-nibbles 2)))
+	 ((index>= y height))
+      (declare (type array-index start y
+		     left-nibbles right-nibbles middle-nibbles middle-bytes))
+      (unless (index-zerop left-nibbles)
+	(setf (aref array y 0)
+	      (read-image-load-byte
+		4 4 (aref buffer-bbuf (index1- start)))))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (x left-nibbles (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref array y (index+ left-nibbles middle-nibbles))
+		    (read-image-load-byte 4 0 (aref buffer-bbuf end)))))
+	(declare (type array-index end i x))
+	(let ((byte (aref buffer-bbuf i)))
+	  (declare (type card8 byte))
+	  (setf (aref array y (index+ x 0))
+		(read-image-load-byte 4 0 byte))
+	  (setf (aref array y (index+ x 1))
+		(read-image-load-byte 4 4 byte))))
+      )))
+
+(defun read-pixarray-8 (buffer-bbuf index array x y width height 
+			padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 x)
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (the card8 (aref buffer-bbuf i)))))))
+
+(defun read-pixarray-16 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 2))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))))))))
+
+(defun read-pixarray-24 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 3))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))))))))
+
+(defun read-pixarray-32 (buffer-bbuf index array x y width height 
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((start (index+ index
+			 (index* y padded-bytes-per-line)
+			 (index* x 4))
+		 (index+ start padded-bytes-per-line))
+	  (y 0 (index1+ y)))
+	 ((index>= y height))
+      (declare (type array-index start y))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x 0 (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref array y x)
+	      (read-image-assemble-bytes
+		(aref buffer-bbuf (index+ i 0))
+		(aref buffer-bbuf (index+ i 1))
+		(aref buffer-bbuf (index+ i 2))
+		(aref buffer-bbuf (index+ i 3))))))))
+
+(defun read-xy-format-image-x
+       (buffer-bbuf index length data width height depth
+	padded-bytes-per-line padded-bytes-per-plane
+	unit byte-lsb-first-p bit-lsb-first-p pad)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type card16 width height)
+	   (type array-index index length padded-bytes-per-line
+		 padded-bytes-per-plane)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit pad)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-x))
+  (assert (index<= (index* depth padded-bytes-per-plane) length))
+  (let* ((bytes-per-line (index-ceiling width 8))
+	 (data-length (index* padded-bytes-per-plane depth)))
+    (declare (type array-index bytes-per-line data-length))
+    (cond (data
+	   (check-type data buffer-bytes)
+	   (assert (index>= (length data) data-length)))
+	  (t
+	   (setq data (make-array data-length :element-type 'card8))))
+    (do ((plane 0 (index1+ plane)))
+	((index>= plane depth))
+      (declare (type image-depth plane))
+      (image-noswap
+	buffer-bbuf data
+	(index+ index (index* plane padded-bytes-per-plane))
+	(index* plane padded-bytes-per-plane)
+	bytes-per-line padded-bytes-per-line padded-bytes-per-line
+	height byte-lsb-first-p))
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel 1 :format :xy-pixmap
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad)))
+
+(defun read-z-format-image-x
+       (buffer-bbuf index length data width height depth
+	padded-bytes-per-line 
+	unit byte-lsb-first-p bit-lsb-first-p pad bits-per-pixel)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type card16 width height)
+	   (type array-index index length padded-bytes-per-line)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit pad)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (values image-x))
+  (assert (index<= (index* height padded-bytes-per-line) length))
+  (let ((bytes-per-line (index-ceiling (index* width bits-per-pixel) 8))
+	(data-length (index* padded-bytes-per-line height)))
+    (declare (type array-index bytes-per-line data-length))
+    (cond (data
+	   (check-type data buffer-bytes)
+	   (assert (index>= (length data) data-length)))
+	  (t
+	   (setq data (make-array data-length :element-type 'card8))))
+    (image-noswap
+      buffer-bbuf data index 0 bytes-per-line padded-bytes-per-line
+      padded-bytes-per-line height byte-lsb-first-p)
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel bits-per-pixel :format :z-pixmap
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :unit unit :pad pad)))
+
+(defmacro with-image-data-buffer ((buffer size) &body body)
+  (declare (indentation 0 4 1 1))
+  `(let ((.reply-buffer. (allocate-reply-buffer ,size)))
+     (declare (type reply-buffer .reply-buffer.))
+     (unwind-protect
+	 (let ((,buffer (reply-ibuf8 .reply-buffer.)))
+	   (declare (type buffer-bytes ,buffer))
+	   (with-vector (,buffer buffer-bytes)
+	     ,@body))
+       (deallocate-reply-buffer .reply-buffer.))))
+
+(defun read-image-xy-data (bbuf index pixarray x y width height
+			   padded-bytes-per-line
+			   unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index index padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (let* ((x1 (index* (index-floor x unit) unit))
+	 (x (index- x x1))
+	 (width1 (index+ width x))
+	 (padded-bits-per-line1
+	   (index* (index-ceiling width1 *image-pad*) *image-pad*))
+	 (padded-bytes-per-line1 (index-ceiling padded-bits-per-line1 8)))
+    (declare (type card16 x1 x width1)
+	     (type array-index padded-bits-per-line1 padded-bytes-per-line1))
+    (with-image-data-buffer (buf (index* height padded-bytes-per-line1))
+      (image-swap-xy
+	bbuf buf 
+	(index+ index
+		(index* y padded-bytes-per-line)
+		(index-floor x1 8))
+	0
+	(index-ceiling width1 8)
+	padded-bytes-per-line padded-bytes-per-line1
+	height
+	unit byte-lsb-first-p bit-lsb-first-p
+	*image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*)
+      (unless (fast-read-pixarray
+		buf 0 pixarray x 0 width height padded-bytes-per-line1 1)
+	(read-pixarray-1
+	  buf 0 pixarray x 0 width height padded-bytes-per-line1)))))
+
+(defun read-image-xy (bbuf index length data x y width height depth
+		      padded-bytes-per-line padded-bytes-per-plane
+		      unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type card16 x y width height)
+	   (type array-index index length padded-bytes-per-line
+		 padded-bytes-per-plane)
+	   (type image-depth depth)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-xy))
+  (check-type data list)
+  (multiple-value-bind (dimensions element-type)
+      (if data
+	  (values (array-dimensions (first data))
+		  (array-element-type (first data)))
+	(values (list height
+		      (index* (index-ceiling width *image-pad*) *image-pad*))
+		'pixarray-1-element-type))
+    (do* ((arrays data)
+	  (result nil)
+	  (limit (index+ length index))
+	  (plane 0 (1+ plane))
+	  (index index (index+ index padded-bytes-per-plane)))
+	 ((or (>= plane depth)
+	      (index> (index+ index padded-bytes-per-plane) limit))
+	  (setq data (nreverse result) depth (length data)))
+      (declare (type array-index limit index)
+	       (type image-depth plane)
+	       (type list arrays result))
+      (let ((array (or (pop arrays)
+		       (make-array dimensions :element-type element-type))))
+	(declare (type pixarray-1 array))
+	(push array result)
+	(read-image-xy-data
+	  bbuf index array x y width height
+	  padded-bytes-per-line
+	  unit byte-lsb-first-p bit-lsb-first-p)))
+    (create-image 
+      :width width :height height :depth depth :data data)))
+
+(defun read-image-z-data (bbuf index pixarray x y width height
+			  padded-bytes-per-line
+			  bits-per-pixel
+			  unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type array-index index padded-bytes-per-line)
+	   (type pixarray pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (read-image-xy-data
+	bbuf index pixarray x y width height
+	padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+  (let* ((xbits (index* x bits-per-pixel))
+	 (xbits1 (index* (index-floor xbits unit) unit))
+	 (x1 (index-floor xbits1 bits-per-pixel))
+	 (x (index- x x1))
+	 (width1 (index+ width x))
+	 (bits-per-line1 (index* width1 bits-per-pixel))
+	 (bytes-per-line1 (index-ceiling bits-per-line1 8))
+	 (padded-bits-per-line1
+	   (index* (index-ceiling bits-per-line1 *image-pad*) *image-pad*))
+	 (padded-bytes-per-line1
+	   (index-ceiling padded-bits-per-line1 8)))
+      (declare (type array-index xbits xbits1 x1 x
+		     bits-per-line1 bytes-per-line1
+		     padded-bits-per-line1 padded-bytes-per-line1))
+      (with-image-data-buffer (buf (index* height padded-bytes-per-line1))
+	(image-swap-z
+	  bbuf buf 
+	  (index+ index
+		  (index* y padded-bytes-per-line)
+		  (index-floor xbits1 8))
+	  0
+	  bytes-per-line1
+	  padded-bytes-per-line padded-bytes-per-line1
+	  height
+	  bits-per-pixel byte-lsb-first-p *image-byte-lsb-first-p*)
+	(unless (fast-read-pixarray
+		  buf 0 pixarray x 0 width height padded-bytes-per-line1
+		  bits-per-pixel)
+	  (funcall
+	    (ecase bits-per-pixel 
+	      (1 #'read-pixarray-1) (4 #'read-pixarray-4)
+	      (8 #'read-pixarray-8) (16 #'read-pixarray-16)
+	      (24 #'read-pixarray-24) (32 #'read-pixarray-32))
+	    buf 0 pixarray x 0 width height padded-bytes-per-line1))))))
+
+(defun read-image-z (bbuf index length data x y width height depth
+		     padded-bytes-per-line bits-per-pixel
+		     unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes bbuf)
+	   (type card16 x y width height)
+	   (type array-index index length padded-bytes-per-line)
+	   (type image-depth depth)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p)
+	   (values image-z))
+  (assert (index<= (index* (index+ y height) padded-bytes-per-line) length))
+  (let* ((image-bits-per-line (index* width bits-per-pixel))
+	 (image-pixels-per-line
+	   (index-ceiling
+	     (index* (index-ceiling image-bits-per-line *image-pad*)
+		     *image-pad*)
+	     bits-per-pixel)))
+    (declare (type array-index image-bits-per-line image-pixels-per-line))
+    (unless data
+      (setq data
+	    (make-array
+	      (list height image-pixels-per-line)
+	      :element-type (ecase bits-per-pixel
+			      (1  'pixarray-1-element-type)
+			      (4  'pixarray-4-element-type)
+			      (8  'pixarray-8-element-type)
+			      (16 'pixarray-16-element-type)
+			      (24 'pixarray-24-element-type)
+			      (32 'pixarray-32-element-type)))))
+    (read-image-z-data
+      bbuf index data x y width height
+      padded-bytes-per-line bits-per-pixel
+      unit byte-lsb-first-p bit-lsb-first-p)
+    (create-image 
+      :width width :height height :depth depth :data data
+      :bits-per-pixel bits-per-pixel)))
+
+(defun get-image (drawable &key
+		  data
+		  (x (required-arg x))
+		  (y (required-arg y))
+		  (width (required-arg width))
+		  (height (required-arg height))
+		  plane-mask format result-type)
+  (declare (type drawable drawable)
+	   (type (or buffer-bytes list pixarray) data)
+	   (type int16 x y) ;; required
+	   (type card16 width height) ;; required
+	   (type (or null pixel) plane-mask)
+	   (type (or null (member :xy-pixmap :z-pixmap)) format)
+	   (type (or null (member image-xy image-x image-z)) result-type)
+	   (values image visual-info))
+  (unless result-type
+    (setq result-type (ecase format
+			(:xy-pixmap 'image-xy)
+			(:z-pixmap 'image-z)
+			((nil) 'image-x))))
+  (unless format
+    (setq format (case result-type
+		   (image-xy :xy-pixmap)
+		   ((image-z image-x) :z-pixmap))))
+  (unless (ecase result-type
+	    (image-xy (eq format :xy-pixmap))
+	    (image-z (eq format :z-pixmap))
+	    (image-x t))
+    (error "Result-type ~s is incompatable with format ~s"
+	   result-type format))
+  (unless plane-mask (setq plane-mask #xffffffff))
+  (let ((display (drawable-display drawable)))
+    (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
+	 (((data (member error :xy-pixmap :z-pixmap)) format)
+	  (drawable drawable)
+	  (int16 x y)
+	  (card16 width height)
+	  (card32 plane-mask))
+      (let* ((depth (card8-get 1))
+	     (length (index* 4 (card32-get 4)))
+	     (visual-info (visual-info display (resource-id-get 8)))
+	     (bitmap-format (display-bitmap-format display))
+	     (unit (bitmap-format-unit bitmap-format))
+	     (byte-lsb-first-p (display-image-lsb-first-p display))
+	     (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
+	(declare (type image-depth depth)
+		 (type array-index length)
+		 (type (or null visual-info) visual-info)
+		 (type bitmap-format bitmap-format)
+		 (type (member 8 16 32) unit)
+		 (type boolean byte-lsb-first-p bit-lsb-first-p))
+	(multiple-value-bind (pad bits-per-pixel)
+	    (ecase format
+	      (:xy-pixmap
+		(values (bitmap-format-pad bitmap-format) 1))
+	      (:z-pixmap
+		(if (= depth 1)
+		    (values (bitmap-format-pad bitmap-format) 1)
+		  (let ((pixmap-format
+			  (find depth (display-pixmap-formats display)
+				:key #'pixmap-format-depth)))
+		    (declare (type pixmap-format pixmap-format))
+		    (values (pixmap-format-scanline-pad pixmap-format)
+			    (pixmap-format-bits-per-pixel pixmap-format))))))
+	  (declare (type (member 8 16 32) pad)
+		   (type (member 1 4 8 16 24 32) bits-per-pixel))
+	  (let* ((bits-per-line (index* bits-per-pixel width))
+		 (padded-bits-per-line
+		   (index* (index-ceiling bits-per-line pad) pad))
+		 (padded-bytes-per-line
+		   (index-ceiling padded-bits-per-line 8))
+		 (padded-bytes-per-plane
+		   (index* padded-bytes-per-line height))
+		 (image
+		   (ecase result-type
+		     (image-x
+		       (ecase format
+			 (:xy-pixmap
+			   (read-xy-format-image-x
+			     buffer-bbuf *replysize* length data
+			     width height depth
+			     padded-bytes-per-line padded-bytes-per-plane
+			     unit byte-lsb-first-p bit-lsb-first-p
+			     pad))
+			 (:z-pixmap
+			   (read-z-format-image-x
+			     buffer-bbuf *replysize* length data
+			     width height depth
+			     padded-bytes-per-line
+			     unit byte-lsb-first-p bit-lsb-first-p
+			     pad bits-per-pixel))))
+		     (image-xy
+		       (read-image-xy
+			 buffer-bbuf *replysize* length data
+			 0 0 width height depth
+			 padded-bytes-per-line padded-bytes-per-plane
+			 unit byte-lsb-first-p bit-lsb-first-p))
+		     (image-z
+		       (read-image-z
+			 buffer-bbuf *replysize* length data
+			 0 0 width height depth padded-bytes-per-line
+			 bits-per-pixel 
+			 unit byte-lsb-first-p bit-lsb-first-p)))))
+	    (declare (type image image)
+		     (type array-index bits-per-line 
+			   padded-bits-per-line padded-bytes-per-line))
+	    (when visual-info
+	      (unless (zerop (visual-info-red-mask visual-info))
+		(setf (image-red-mask image)
+		      (visual-info-red-mask visual-info)))
+	      (unless (zerop (visual-info-green-mask visual-info))
+		(setf (image-green-mask image)
+		      (visual-info-green-mask visual-info)))
+	      (unless (zerop (visual-info-blue-mask visual-info))
+		(setf (image-blue-mask image)
+		      (visual-info-blue-mask visual-info))))
+	    (values image visual-info)))))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; PUT-IMAGE
+
+(defun write-pixarray-1 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-1 array)
+	   (type card16 x y width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-bits (index-mod width 8))
+	  (middle-bits (index- width right-bits))
+	  (middle-bytes (index-ceiling middle-bits 8))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y right-bits middle-bits
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x start-x (index+ x 8)))
+	   ((index>= i end)
+	    (unless (index-zerop right-bits)
+	      (let ((x (index+ start-x middle-bits)))
+		(declare (type array-index x))
+		(setf (aref buffer-bbuf end)
+		      (write-image-assemble-bytes
+			(aref array y (index+ x 0))
+			(if (index> right-bits 1)
+			    (aref array y (index+ x 1))
+			  0)
+			(if (index> right-bits 2)
+			    (aref array y (index+ x 2))
+			  0)
+			(if (index> right-bits 3)
+			    (aref array y (index+ x 3))
+			  0)
+			(if (index> right-bits 4)
+			    (aref array y (index+ x 4))
+			  0)
+			(if (index> right-bits 5)
+			    (aref array y (index+ x 5))
+			  0)
+			(if (index> right-bits 6)
+			    (aref array y (index+ x 6))
+			  0)
+			0)))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref array y (index+ x 0))
+		(aref array y (index+ x 1))
+		(aref array y (index+ x 2))
+		(aref array y (index+ x 3))
+		(aref array y (index+ x 4))
+		(aref array y (index+ x 5))
+		(aref array y (index+ x 6))
+		(aref array y (index+ x 7))))))))
+
+(defun write-pixarray-4 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-4 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (right-nibbles (index-mod width 2))
+	  (middle-nibbles (index- width right-nibbles))
+	  (middle-bytes (index-ceiling middle-nibbles 2))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y right-nibbles middle-nibbles
+		     middle-bytes start))
+      (do* ((end (index+ start middle-bytes))
+	    (i start (index1+ i))
+	    (start-x x)
+	    (x start-x (index+ x 2)))
+	   ((index>= i end)
+	    (unless (index-zerop right-nibbles)
+	      (setf (aref buffer-bbuf end)
+		    (write-image-assemble-bytes
+		      (aref array y (index+ start-x middle-nibbles))
+		      0))))
+	(declare (type array-index end i start-x x))
+	(setf (aref buffer-bbuf i)
+	      (write-image-assemble-bytes
+		(aref array y (index+ x 0))
+		(aref array y (index+ x 1))))))))
+
+(defun write-pixarray-8 (buffer-bbuf index array x y width height
+			 padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-8 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start width))
+	    (i start (index1+ i))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(setf (aref buffer-bbuf i) (the card8 (aref array y x)))))))
+
+(defun write-pixarray-16 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-16 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start (index* width 2)))
+	    (i start (index+ i 2))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-16-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 16))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 16)))))))
+
+(defun write-pixarray-24 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-24 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index y start))
+      (do* ((end (index+ start (index* width 3)))
+	    (i start (index+ i 3))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-24-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 24))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 24)))))))
+
+(defun write-pixarray-32 (buffer-bbuf index array x y width height
+			  padded-bytes-per-line)
+  (declare (type buffer-bytes buffer-bbuf)
+	   (type pixarray-32 array)
+	   (type int16 x y)
+	   (type card16 width height)
+	   (type array-index index padded-bytes-per-line))
+  #.(declare-buffun)
+  (with-vector (buffer-bbuf buffer-bytes)
+    (do* ((h 0 (index1+ h))
+	  (y y (index1+ y))
+	  (start index (index+ start padded-bytes-per-line)))
+	 ((index>= h height))
+      (declare (type array-index h y start))
+      (do* ((end (index+ start (index* width 4)))
+	    (i start (index+ i 4))
+	    (x x (index1+ x)))
+	   ((index>= i end))
+	(declare (type array-index end i x))
+	(let ((pixel (aref array y x)))
+	  (declare (type pixarray-32-element-type pixel))
+	  (setf (aref buffer-bbuf (index+ i 0))
+		(write-image-load-byte 0 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 1))
+		(write-image-load-byte 8 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 16 pixel 32))
+	  (setf (aref buffer-bbuf (index+ i 2))
+		(write-image-load-byte 24 pixel 32)))))))
+
+(defun write-xy-format-image-x-data
+       (data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes data obuf)
+	   (type array-index data-start obuf-start
+		 from-padded-bytes-per-line to-padded-bytes-per-line)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (assert (index-zerop (index-mod x 8)))
+  (let ((x-mod-unit (index-mod x from-bitmap-unit)))
+    (declare (type card16 x-mod-unit))
+    (if (and (index-plusp x-mod-unit)
+	     (not (eq from-byte-lsb-first-p from-bit-lsb-first-p)))
+	(let* ((temp-width (index+ width x-mod-unit))
+	       (temp-bytes-per-line (index-ceiling temp-width 8))
+	       (temp-padded-bits-per-line
+		 (index* (index-ceiling temp-width from-bitmap-unit)
+			 from-bitmap-unit))
+	       (temp-padded-bytes-per-line
+		 (index-ceiling temp-padded-bits-per-line 8)))
+	  (declare (type card16 temp-width temp-bytes-per-line
+			 temp-padded-bits-per-line temp-padded-bytes-per-line))
+	  (with-image-data-buffer (buf (index* height
+					       temp-padded-bytes-per-line))
+	    (image-swap-xy
+	      data buf
+	      (index+ data-start
+		      (index* y from-padded-bytes-per-line)
+		      (index-floor (index- x x-mod-unit) 8))
+	      0
+	      temp-bytes-per-line
+	      from-padded-bytes-per-line temp-padded-bytes-per-line
+	      height
+	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	      from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p)
+	    (write-xy-format-image-x-data
+	      buf obuf 0 obuf-start x-mod-unit 0 width height
+	      temp-padded-bytes-per-line to-padded-bytes-per-line
+	      from-bitmap-unit to-byte-lsb-first-p to-byte-lsb-first-p
+	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)))
+      (image-swap-xy
+	data obuf 
+	(index+ data-start
+		(index* y from-padded-bytes-per-line)
+		(index-floor x 8))
+	obuf-start
+	(index-ceiling width 8)
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	height
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))))
+
+(defun write-xy-format-image-x
+       (display image src-x src-y width height
+	padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-x image)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type array-index padded-bytes-per-line)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (dotimes (plane (image-depth image))
+    (let ((data-start
+	    (index* (index* plane (image-height image))
+		    (image-x-bytes-per-line image)))
+	  (src-y src-y)
+	  (height height))
+      (declare (type int16 src-y)
+	       (type card16 height))
+      (loop 
+	(when (index-zerop height) (return))
+	(let ((nlines
+		(index-min (index-floor (index- (buffer-size display)
+						(buffer-boffset display))
+					padded-bytes-per-line)
+			   height)))
+	  (declare (type array-index nlines))
+	  (when (index-plusp nlines)
+	    (write-xy-format-image-x-data
+	      (image-x-data image) (buffer-obuf8 display)
+	      data-start (buffer-boffset display)
+	      src-x src-y width nlines 
+	      (image-x-bytes-per-line image) padded-bytes-per-line
+	      (image-x-unit image) (image-x-byte-lsb-first-p image)
+	      (image-x-bit-lsb-first-p image)
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	    (index-incf (buffer-boffset display)
+			(index* nlines padded-bytes-per-line))
+	    (index-incf src-y nlines)
+	    (when (index-zerop (index-decf height nlines)) (return))))
+	(buffer-flush display)))))
+
+(defun write-z-format-image-x-data
+       (data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	bits-per-pixel
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+  (declare (type buffer-bytes data obuf)
+	   (type array-index data-start obuf-start
+		 from-padded-bytes-per-line to-padded-bytes-per-line)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) from-bitmap-unit to-bitmap-unit)
+	   (type boolean from-byte-lsb-first-p from-bit-lsb-first-p
+		 to-byte-lsb-first-p to-bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (write-xy-format-image-x-data
+	data obuf data-start obuf-start x y width height
+	from-padded-bytes-per-line to-padded-bytes-per-line
+	from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p)
+    (let ((srcoff
+	    (index+ data-start
+		    (index* y from-padded-bytes-per-line)
+		    (index-floor (index* x bits-per-pixel) 8)))
+	  (srclen (index-ceiling (index* width bits-per-pixel) 8)))
+      (declare (type array-index srcoff srclen))
+      (if (and (index= bits-per-pixel 4) (index-oddp x))
+	  (with-image-data-buffer (buf (index* height to-padded-bytes-per-line))
+	    (image-swap-nibbles-left
+	      data buf srcoff 0 srclen
+	      from-padded-bytes-per-line to-padded-bytes-per-line height)
+	    (write-z-format-image-x-data
+	      buf obuf 0 obuf-start 0 0 width height
+	      to-padded-bytes-per-line to-padded-bytes-per-line
+	      bits-per-pixel
+	      from-bitmap-unit from-byte-lsb-first-p from-bit-lsb-first-p
+	      to-bitmap-unit to-byte-lsb-first-p to-bit-lsb-first-p))
+	(image-swap-z
+	  data obuf srcoff obuf-start srclen
+	  from-padded-bytes-per-line to-padded-bytes-per-line height
+	  bits-per-pixel from-byte-lsb-first-p to-byte-lsb-first-p)))))
+
+(defun write-z-format-image-x (display image src-x src-y width height
+			       padded-bytes-per-line
+			       unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-x image)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type array-index padded-bytes-per-line)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (loop 
+    (when (index-zerop height) (return))
+    (let ((nlines
+	    (index-min (index-floor (index- (buffer-size display)
+					    (buffer-boffset display))
+				    padded-bytes-per-line)
+		       height)))
+      (declare (type array-index nlines))
+      (when (index-plusp nlines)
+	(write-z-format-image-x-data 
+	  (image-x-data image) (buffer-obuf8 display) 0 (buffer-boffset display)
+	  src-x src-y width nlines
+	  (image-x-bytes-per-line image) padded-bytes-per-line
+	  (image-x-bits-per-pixel image)
+	  (image-x-unit image) (image-x-byte-lsb-first-p image)
+	  (image-x-bit-lsb-first-p image)
+	  unit byte-lsb-first-p bit-lsb-first-p)
+	(index-incf (buffer-boffset display)
+		    (index* nlines padded-bytes-per-line))
+	(index-incf src-y nlines)
+	(when (index-zerop (index-decf height nlines)) (return))))
+    (buffer-flush display)))
+
+(defun write-image-xy-data (obuf boffset pixarray x y width height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes obuf)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type pixarray-1 pixarray)
+	   (type card16 x y width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (with-image-data-buffer (buf (index* height padded-bytes-per-line))
+    (unless (fast-write-pixarray
+	      buf 0 pixarray x y width height padded-bytes-per-line 1)
+      (write-pixarray-1 
+	buf 0 pixarray x y width height padded-bytes-per-line))
+    (image-swap-xy
+      buf obuf 0 boffset (index-ceiling width 8)
+      padded-bytes-per-line padded-bytes-per-line height
+      *image-unit* *image-byte-lsb-first-p* *image-bit-lsb-first-p*
+      unit byte-lsb-first-p bit-lsb-first-p)))
+
+(defun write-image-xy (display image src-x src-y width height
+		       padded-bytes-per-line
+		       unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-xy image)
+	   (type array-index padded-bytes-per-line)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (dolist (bitmap (image-xy-bitmap-list image))
+    (declare (type pixarray-1 bitmap))
+    (let ((src-y src-y)
+	  (height height))
+      (declare (type int16 src-y)
+	       (type card16 height))
+      (loop 
+	(let ((nlines
+		(index-min (index-floor (index- (buffer-size display)
+						(buffer-boffset display))
+					padded-bytes-per-line)
+			   height)))
+	  (declare (type array-index nlines))
+	  (when (index-plusp nlines)
+	    (write-image-xy-data
+	      (buffer-obuf8 display) (buffer-boffset display)
+	      bitmap src-x src-y width nlines
+	      padded-bytes-per-line
+	      unit byte-lsb-first-p bit-lsb-first-p)
+	    (index-incf (buffer-boffset display)
+			(index* nlines padded-bytes-per-line))
+	    (index-incf src-y nlines)
+	    (when (index-zerop (index-decf height nlines)) (return))))
+	(buffer-flush display)))))
+
+(defun write-image-z-data (obuf boffset pixarray x y width height
+			   padded-bytes-per-line bits-per-pixel
+			   unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type buffer-bytes obuf)
+	   (type array-index boffset padded-bytes-per-line)
+	   (type pixarray-1 pixarray)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (if (index= bits-per-pixel 1)
+      (write-image-xy-data
+	obuf boffset pixarray x y width height padded-bytes-per-line
+	unit byte-lsb-first-p bit-lsb-first-p)
+    (with-image-data-buffer (buf (index* height padded-bytes-per-line))
+      (unless (fast-write-pixarray
+		buf 0 pixarray x y width height
+		padded-bytes-per-line bits-per-pixel)
+	(funcall
+	  (ecase bits-per-pixel
+	    (1 #'write-pixarray-1) (4 #'write-pixarray-4)
+	    (8 #'write-pixarray-8) (16 #'write-pixarray-16)
+	    (24 #'write-pixarray-24) (32 #'write-pixarray-32))
+	  buf 0 pixarray x y width height padded-bytes-per-line))
+      (image-swap-z
+	buf obuf 0 boffset 
+	(index-ceiling (index* width bits-per-pixel) 8)
+	padded-bytes-per-line padded-bytes-per-line
+	height bits-per-pixel
+	*image-byte-lsb-first-p* byte-lsb-first-p))))
+
+(defun write-image-z (display image src-x src-y width height
+		      padded-bytes-per-line
+		      unit byte-lsb-first-p bit-lsb-first-p)
+  (declare (type display display)
+	   (type image-z image)
+	   (type array-index padded-bytes-per-line)
+	   (type int16 src-x src-y)
+	   (type card16 width height)
+	   (type (member 8 16 32) unit)
+	   (type boolean byte-lsb-first-p bit-lsb-first-p))
+  (loop 
+    (let ((bits-per-pixel (image-z-bits-per-pixel image))
+	  (nlines
+	    (index-min (index-floor (index- (buffer-size display)
+					    (buffer-boffset display))
+				    padded-bytes-per-line)
+		       height)))
+      (declare (type (member 1 4 8 16 24 32) bits-per-pixel)
+	       (type array-index nlines))
+      (when (index-plusp nlines)
+	(write-image-z-data
+	  (buffer-obuf8 display) (buffer-boffset display)
+	  (image-z-pixarray image) src-x src-y width nlines
+	  padded-bytes-per-line bits-per-pixel
+	  unit byte-lsb-first-p bit-lsb-first-p)
+	(index-incf (buffer-boffset display)
+		    (index* nlines padded-bytes-per-line))
+	(index-incf src-y nlines)
+	(when (index-zerop (index-decf height nlines)) (return))))
+    (buffer-flush display)))
+
+;;; Note:	The only difference between a format of :bitmap and :xy-pixmap
+;;;		of depth 1 is that when sending a :bitmap format the foreground 
+;;;		and background in the gcontext are used.
+
+(defun put-image (drawable gcontext image &key
+		  (src-x 0) (src-y 0)		;Position within image
+		  (x (required-arg x))		;Position within drawable
+		  (y (required-arg y))
+		  width height
+		  bitmap-p)
+  ;; Copy an image into a drawable.
+  ;; WIDTH and HEIGHT default from IMAGE.
+  ;; When BITMAP-P, force format to be :bitmap when depth=1.
+  ;; This causes gcontext to supply foreground & background pixels.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type image image)
+	   (type int16 x y) ;; required
+	   (type int16 src-x src-y)
+	   (type (or null card16) width height)
+	   (type boolean bitmap-p))
+  (let* ((format
+	   (etypecase image
+	     (image-x (image-x-format (the image-x image)))
+	     (image-xy :xy-pixmap)
+	     (image-z :z-pixmap)))
+	 (src-x
+	   (if (image-x-p image)
+	       (index+ src-x (image-x-left-pad (the image-x image)))
+	     src-x))
+	 (image-width (image-width image))
+	 (image-height (image-height image))
+	 (width (min (or width image-width) (index- image-width src-x)))
+	 (height (min (or height image-height) (index- image-height src-y)))
+	 (depth (image-depth image))
+	 (display (drawable-display drawable))
+	 (bitmap-format (display-bitmap-format display))
+	 (unit (bitmap-format-unit bitmap-format))
+	 (byte-lsb-first-p (display-image-lsb-first-p display))
+	 (bit-lsb-first-p  (bitmap-format-lsb-first-p bitmap-format)))
+    (declare (type (member :bitmap :xy-pixmap :z-pixmap) format)
+	     (type card16 src-x image-width image-height width height)
+	     (type image-depth depth)
+	     (type display display)
+	     (type bitmap-format bitmap-format)
+	     (type (member 8 16 32) unit)
+	     (type boolean byte-lsb-first-p bit-lsb-first-p))
+    (when (and bitmap-p (not (index= depth 1)))
+      (error "Bitmaps must have depth 1"))
+    (unless (index<= 0 src-x (index1- (image-width image)))
+      (error "src-x not inside image"))
+    (unless (index<= 0 src-y (index1- (image-height image)))
+      (error "src-y not inside image"))
+    (when (and (index> width 0) (index> height 0))
+      (multiple-value-bind (pad bits-per-pixel)
+	  (ecase format
+	    ((:bitmap :xy-pixmap)
+	      (values (bitmap-format-pad bitmap-format) 1))
+	    (:z-pixmap
+	      (if (= depth 1) 
+		  (values (bitmap-format-pad bitmap-format) 1)
+		(let ((pixmap-format
+			(find depth (display-pixmap-formats display)
+			      :key #'pixmap-format-depth)))
+		  (declare (type pixmap-format pixmap-format))
+		  (values (pixmap-format-scanline-pad pixmap-format)
+			  (pixmap-format-bits-per-pixel pixmap-format))))))
+	(declare (type (member 8 16 32) pad)
+		 (type (member 1 4 8 16 24 32) bits-per-pixel))
+	(let* ((left-pad
+		 (if (or (eq format :xy-pixmap) (= depth 1))
+		     (index-mod src-x (index-min pad *image-pad*))
+		   0))
+	       (left-padded-src-x (index- src-x left-pad))
+	       (left-padded-width (index+ width left-pad))
+	       (bits-per-line (index* left-padded-width bits-per-pixel))
+	       (padded-bits-per-line
+		 (index* (index-ceiling bits-per-line pad) pad))
+	       (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	       (request-bytes-per-line
+		 (ecase format
+		   ((:bitmap :xy-pixmap) (index* padded-bytes-per-line depth))
+		   (:z-pixmap padded-bytes-per-line)))
+	       (max-bytes-per-request
+		 (index* (index- (display-max-request-length display) 6) 4))
+	       (max-request-height
+		 (floor max-bytes-per-request request-bytes-per-line)))
+	  (declare (type card8 left-pad)
+		   (type int16 left-padded-src-x)
+		   (type card16 left-padded-width)
+		   (type array-index bits-per-line padded-bits-per-line
+			 padded-bytes-per-line request-bytes-per-line
+			 max-bytes-per-request max-request-height))
+	  ;; Be sure that a scanline can fit in a request
+	  (when (index-zerop max-request-height)
+	    (error "Can't even fit one image scanline in a request"))
+	  ;; Be sure a scanline can fit in a buffer
+	  (buffer-ensure-size display padded-bytes-per-line)
+	  ;; Send the image in multiple requests to avoid exceeding the
+	  ;; request limit
+	  (do* ((request-src-y src-y (index+ request-src-y request-height))
+		(request-y y (index+ request-y request-height))
+		(height-remaining
+		  height (index- height-remaining request-height))
+		(request-height
+		  (index-min height-remaining max-request-height)
+		  (index-min height-remaining max-request-height)))
+	       ((index<= height-remaining 0))
+	    (declare (type array-index request-src-y height-remaining
+			   request-height))
+	    (let* ((request-bytes (index* request-bytes-per-line request-height))
+		   (request-words (index-ceiling request-bytes 4))
+		   (request-length (index+ request-words 6)))
+	      (declare (type array-index request-bytes)
+		       (type card16 request-words request-length))
+	      (with-buffer-request (display *x-putimage* :gc-force gcontext)
+		((data (member :bitmap :xy-pixmap :z-pixmap))
+		 (cond ((or (eq format :bitmap) bitmap-p) :bitmap)
+		       ((plusp left-pad) :xy-pixmap)
+		       (t format)))
+		(drawable drawable)
+		(gcontext gcontext)
+		(card16 width request-height)
+		(int16 x request-y)
+		(card8 left-pad depth)
+		(pad16 nil)
+		(progn 
+		  (length-put 2 request-length)
+		  (setf (buffer-boffset display) (advance-buffer-offset 24))
+		  (etypecase image
+		    (image-x
+		      (ecase (image-x-format (the image-x image))
+			((:bitmap :xy-pixmap)
+			  (write-xy-format-image-x
+			    display image left-padded-src-x request-src-y
+			    left-padded-width request-height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p))
+			(:z-pixmap
+			  (write-z-format-image-x
+			    display image left-padded-src-x request-src-y
+			    left-padded-width request-height
+			    padded-bytes-per-line
+			    unit byte-lsb-first-p bit-lsb-first-p))))
+		    (image-xy
+		      (write-image-xy
+			display image left-padded-src-x request-src-y
+			left-padded-width request-height
+			padded-bytes-per-line
+			unit byte-lsb-first-p bit-lsb-first-p))
+		    (image-z
+		      (write-image-z
+			display image left-padded-src-x request-src-y
+			left-padded-width request-height
+			padded-bytes-per-line
+			unit byte-lsb-first-p bit-lsb-first-p)))
+		  ;; Be sure the request is padded to a multiple of 4 bytes
+		  (buffer-pad-request display (index- (index* request-words 4) request-bytes))
+		  )))))))))
+
+;;;-----------------------------------------------------------------------------
+;;; COPY-IMAGE
+
+(defun xy-format-image-x->image-x (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-x (index+ x (image-x-left-pad image)))
+	 (left-pad (index-mod padded-x 8))
+	 (x (index- padded-x left-pad))
+	 (unit (image-x-unit image))
+	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
+	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
+	 (pad (image-x-pad image))
+	 (padded-width
+	   (index* (index-ceiling (index+ width left-pad) pad) pad))
+	 (padded-bytes-per-line (index-ceiling padded-width 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (length (index* padded-bytes-per-plane (image-depth image)))
+	 (obuf (make-array length :element-type 'card8)))
+    (declare (type card16 x)
+	     (type card8 left-pad)
+	     (type (member 8 16 32) unit pad)
+	     (type array-index padded-width padded-bytes-per-line
+		   padded-bytes-per-plane length)
+	     (type buffer-bytes obuf))
+    (dotimes (plane (image-depth image))
+      (let ((data-start
+	      (index* (image-x-bytes-per-line image)
+		      (image-height image)
+		      plane))
+	    (obuf-start
+	      (index* padded-bytes-per-plane
+		      plane)))
+	(declare (type array-index data-start obuf-start))
+	(write-xy-format-image-x-data
+	  (image-x-data image) obuf data-start obuf-start
+	  x y width height 
+	  (image-x-bytes-per-line image) padded-bytes-per-line
+	  unit byte-lsb-first-p bit-lsb-first-p
+	  unit byte-lsb-first-p bit-lsb-first-p)))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data obuf :format (image-x-format image) :bits-per-pixel 1
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad)))
+
+(defun z-format-image-x->image-x (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-x (index+ x (image-x-left-pad image)))
+	 (left-pad
+	   (if (index= (image-depth image) 1)
+	       (index-mod padded-x 8)
+	     0))
+	 (x (index- padded-x left-pad))
+	 (bits-per-pixel (image-x-bits-per-pixel image))
+	 (unit (image-x-unit image))
+	 (byte-lsb-first-p (image-x-byte-lsb-first-p image))
+	 (bit-lsb-first-p (image-x-bit-lsb-first-p image))
+	 (pad (image-x-pad image))
+	 (bits-per-line (index* (index+ width left-pad) bits-per-pixel))
+	 (padded-bits-per-line (index* (index-ceiling bits-per-line pad) pad))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (length (index* padded-bytes-per-plane (image-depth image)))
+	 (obuf (make-array length :element-type 'card8)))
+    (declare (type card16 x)
+	     (type card8 left-pad)
+	     (type (member 8 16 32) unit pad)
+	     (type array-index bits-per-pixel padded-bytes-per-line
+		   padded-bytes-per-plane length)
+	     (type buffer-bytes obuf))
+    (write-z-format-image-x-data
+      (image-x-data image) obuf 0 0
+      x y width height 
+      (image-x-bytes-per-line image) padded-bytes-per-line
+      bits-per-pixel
+      unit byte-lsb-first-p bit-lsb-first-p
+      unit byte-lsb-first-p bit-lsb-first-p)
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data obuf :format :z-pixmap :bits-per-pixel bits-per-pixel
+      :bytes-per-line padded-bytes-per-line
+      :unit unit :byte-lsb-first-p byte-lsb-first-p
+      :bit-lsb-first-p bit-lsb-first-p :pad pad :left-pad left-pad)))
+
+(defun image-x->image-x  (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (ecase (image-x-format image)
+    ((:bitmap :xy-pixmap)
+      (xy-format-image-x->image-x image x y width height))
+    (:z-pixmap
+      (z-format-image-x->image-x image x y width height))))
+
+(defun image-x->image-xy (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-xy))
+  (unless (or (eq (image-x-format image) :bitmap)
+	      (eq (image-x-format image) :xy-pixmap)
+	      (and (eq (image-x-format image) :z-pixmap)
+		   (index= (image-depth image) 1)))
+    (error "Format conversion from ~S to ~S not supported"
+	   (image-x-format image) :xy-pixmap))
+  (read-image-xy
+    (image-x-data image) 0 (length (image-x-data image)) nil
+    (index+ x (image-x-left-pad image)) y width height
+    (image-depth image) (image-x-bytes-per-line image)
+    (index* (image-x-bytes-per-line image) (image-height image))
+    (image-x-unit image) (image-x-byte-lsb-first-p image)
+    (image-x-bit-lsb-first-p image)))
+
+(defun image-x->image-z  (image x y width height)
+  (declare (type image-x image)
+	   (type card16 x y width height)
+	   (values image-z))
+  (unless (or (eq (image-x-format image) :z-pixmap)
+	      (eq (image-x-format image) :bitmap)
+	      (and (eq (image-x-format image) :xy-pixmap)
+		   (index= (image-depth image) 1)))
+    (error "Format conversion from ~S to ~S not supported"
+	   (image-x-format image) :z-pixmap))
+  (read-image-z
+    (image-x-data image) 0 (length (image-x-data image)) nil
+    (index+ x (image-x-left-pad image)) y width height
+    (image-depth image) (image-x-bytes-per-line image)
+    (image-x-bits-per-pixel image)
+    (image-x-unit image) (image-x-byte-lsb-first-p image)
+    (image-x-bit-lsb-first-p image)))
+
+(defun copy-pixarray (array x y width height bits-per-pixel)
+  (declare (type pixarray array)
+	   (type card16 x y width height)
+	   (type (member 1 4 8 16 24 32) bits-per-pixel))
+  (let* ((bits-per-line (index* bits-per-pixel width))
+	 (padded-bits-per-line
+	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
+	 (padded-width (index-ceiling padded-bits-per-line bits-per-pixel))
+	 (copy (make-array (list height padded-width)
+			   :element-type (array-element-type array))))
+    (declare (type array-index bits-per-line padded-bits-per-line padded-width)
+	     (type pixarray copy))
+    #.(declare-buffun)
+    (unless (fast-copy-pixarray array copy x y width height bits-per-pixel)
+      (macrolet
+	((copy (array-type element-type)
+	   `(let ((array array)
+		  (copy copy))
+	      (declare (type ,array-type array copy))
+	      (do* ((dst-y 0 (index1+ dst-y))
+		    (src-y y (index1+ src-y)))
+		   ((index>= dst-y height))
+		(declare (type card16 dst-y src-y))
+		(do* ((dst-x 0 (index1+ dst-x))
+		      (src-x x (index1+ src-x)))
+		     ((index>= dst-x width))
+		  (declare (type card16 dst-x src-x))
+		  (setf (aref copy dst-y dst-x)
+			(the ,element-type
+			     (aref array src-y src-x))))))))
+	(ecase bits-per-pixel
+	  (1  (copy pixarray-1  pixarray-1-element-type))
+	  (4  (copy pixarray-4  pixarray-4-element-type))
+	  (8  (copy pixarray-8  pixarray-8-element-type))
+	  (16 (copy pixarray-16 pixarray-16-element-type))
+	  (24 (copy pixarray-24 pixarray-24-element-type))
+	  (32 (copy pixarray-32 pixarray-32-element-type)))))
+    copy))
+
+(defun image-xy->image-x (image x y width height)
+  (declare (type image-xy image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((padded-bits-per-line
+	   (index* (index-ceiling width *image-pad*) *image-pad*))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (padded-bytes-per-plane (index* padded-bytes-per-line height))
+	 (bytes-total (index* padded-bytes-per-plane (image-depth image)))
+	 (data (make-array bytes-total :element-type 'card8)))
+    (declare (type array-index padded-bits-per-line padded-bytes-per-line
+		   padded-bytes-per-plane bytes-total)
+	     (type buffer-bytes data))
+    (let ((index 0))
+      (declare (type array-index index))
+      (dolist (bitmap (image-xy-bitmap-list image))
+	(declare (type pixarray-1 bitmap))
+	(unless (fast-write-pixarray
+		  data index bitmap x y width height
+		  padded-bytes-per-line 1)
+	  (write-pixarray-1
+	    data index bitmap x y width height
+	    padded-bytes-per-line))
+	(index-incf index padded-bytes-per-plane)))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data data :format :xy-pixmap :bits-per-pixel 1
+      :bytes-per-line padded-bytes-per-line
+      :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p*
+      :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*)))
+
+(defun image-xy->image-xy (image x y width height)
+  (declare (type image-xy image)
+	   (type card16 x y width height)
+	   (values image-xy))
+  (create-image
+    :width width :height height :depth (image-depth image)
+    :data (mapcar
+	    #'(lambda (array)
+		(declare (type pixarray-1 array))
+		(copy-pixarray array x y width height 1))
+	    (image-xy-bitmap-list image))))
+
+(defun image-xy->image-z (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (ignore image x y width height))
+  (error "Format conversion from ~S to ~S not supported"
+	 :xy-pixmap :z-pixmap))
+
+(defun image-z->image-x (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (values image-x))
+  (let* ((bits-per-line (index* width (image-z-bits-per-pixel image)))
+	 (padded-bits-per-line
+	   (index* (index-ceiling bits-per-line *image-pad*) *image-pad*))
+	 (padded-bytes-per-line (index-ceiling padded-bits-per-line 8))
+	 (bytes-total
+	   (index* padded-bytes-per-line height (image-depth image)))
+	 (data (make-array bytes-total :element-type 'card8)))
+    (declare (type array-index bits-per-line padded-bits-per-line
+		   padded-bytes-per-line bytes-total)
+	     (type buffer-bytes data))
+    (unless (fast-write-pixarray
+	      data 0 (image-z-pixarray image) x y width height
+	      padded-bytes-per-line 
+	      (image-z-bits-per-pixel image))
+      (funcall
+	(ecase (image-z-bits-per-pixel image)
+	  (1 #'write-pixarray-1) (4 #'write-pixarray-4)
+	  (8 #'write-pixarray-8) (16 #'write-pixarray-16)
+	  (24 #'write-pixarray-24) (32 #'write-pixarray-32))
+	data 0 (image-z-pixarray image) x y width height
+	padded-bytes-per-line))
+    (create-image
+      :width width :height height :depth (image-depth image)
+      :data data :format :z-pixmap
+      :bits-per-pixel (image-z-bits-per-pixel image)
+      :bytes-per-line padded-bytes-per-line
+      :unit *image-unit* :byte-lsb-first-p *image-byte-lsb-first-p*
+      :bit-lsb-first-p *image-bit-lsb-first-p* :pad *image-pad*)))
+
+(defun image-z->image-xy (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (ignore image x y width height))
+  (error "Format conversion from ~S to ~S not supported"
+	 :z-pixmap :xy-pixmap))
+
+(defun image-z->image-z (image x y width height)
+  (declare (type image-z image)
+	   (type card16 x y width height)
+	   (values image-z))
+  (create-image
+    :width width :height height :depth (image-depth image)
+    :data (copy-pixarray
+	    (image-z-pixarray image) x y width height
+	    (image-z-bits-per-pixel image))))
+
+(defun copy-image (image &key (x 0) (y 0) width height result-type)
+  ;; Copy with optional sub-imaging and format conversion.
+  ;; result-type defaults to (type-of image)
+  (declare (type image image)
+	   (type card16 x y)
+	   (type (or null card16) width height) ;; Default from image
+	   (type (or null (member image-x image-xy image-z)) result-type))
+  (declare (values image))
+  (let* ((image-width (image-width image))
+	 (image-height (image-height image))
+	 (width (or width image-width))
+	 (height (or height image-height)))
+    (declare (type card16 image-width image-height width height))
+    (unless (index<= 0 x (index1- image-width)) (error "x not inside image"))
+    (unless (index<= 0 y (index1- image-height)) (error "y not inside image"))
+    (setq width (index-min width (index-max (index- image-width x) 0)))
+    (setq height (index-min height (index-max (index- image-height y) 0)))
+    (let ((copy
+	    (etypecase image
+	      (image-x
+		(ecase result-type
+		  ((nil image-x) (image-x->image-x image x y width height))
+		  (image-xy (image-x->image-xy image x y width height))
+		  (image-z  (image-x->image-z  image x y width height))))
+	      (image-xy
+		(ecase result-type
+		  (image-x (image-xy->image-x image x y width height))
+		  ((nil image-xy) (image-xy->image-xy image x y width height))
+		  (image-z  (image-xy->image-z image x y width height))))
+	      (image-z 
+		(ecase result-type
+		  (image-x (image-z->image-x image x y width height))
+		  (image-xy  (image-z->image-xy image x y width height))
+		  ((nil image-z) (image-z->image-z image x y width height)))))))
+      (declare (type image copy))
+      (setf (image-plist copy) (copy-list (image-plist image)))
+      (when (and (image-x-hot image) (not (index-zerop x)))
+	(setf (image-x-hot copy) (index- (image-x-hot image) x)))
+      (when (and (image-y-hot image) (not (index-zerop y)))
+	(setf (image-y-hot copy) (index- (image-y-hot image) y)))
+      copy)))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Image I/O functions
+
+
+(defun read-bitmap-file (pathname)
+  ;; Creates an image from a C include file in standard X11 format
+  (declare (type (or pathname string stream) pathname))
+  (declare (values image))
+  (with-open-file (fstream pathname :direction :input)
+    (let ((line "")
+	  (properties nil)
+	  (name nil)
+	  (name-end nil)
+	  (*package* (find-package 'keyword))
+	  (*read-base* 10))
+      (declare (type string line)
+	       (type stringable name)
+	       (type list properties))
+      ;; Get properties
+      (loop
+	(setq line (read-line fstream))
+	(unless (char= (aref line 0) #\#) (return))
+	(flet ((read-keyword (line start end)
+		 (kintern
+		   (substitute
+		     #\- #\_
+		     (#-excl string-upcase
+		      #+excl correct-case
+		      (subseq line start end))
+		     :test #'char=))))
+	  (when (null name)
+	    (setq name-end (position #\_ line :test #'char= :from-end t)
+		  name (read-keyword line 8 name-end))
+	    (unless (eq name :image)
+	      (setf (getf properties :name) name)))
+	  (let* ((ind-start (index1+ name-end))
+		 (ind-end (position #\Space line :test #'char=
+				    :start ind-start))
+		 (ind (read-keyword line ind-start ind-end))
+		 (val-start (index1+ ind-end))
+		 (val (parse-integer line :start val-start)))
+	    (setf (getf properties ind) val))))
+      ;; Calculate sizes
+      (multiple-value-bind (width height depth left-pad)
+	  (flet ((extract-property (ind &rest default)
+		   (prog1 (apply #'getf properties ind default)
+			  (remf properties ind))))
+	    (values (extract-property :width)
+		    (extract-property :height)
+		    (extract-property :depth 1)
+		    (extract-property :left-pad 0)))
+	(declare (type (or null card16) width height)
+		 (type image-depth depth)
+		 (type card8 left-pad))
+	(unless (and width height) (error "Not a BITMAP file"))
+	(let* ((bits-per-pixel
+		 (cond ((index> depth 24) 32)
+		       ((index> depth 16) 24)
+		       ((index> depth 8)  16)
+		       ((index> depth 4)   8)
+		       ((index> depth 1)   4)
+		       (t                  1)))
+	       (bits-per-line (index* width bits-per-pixel))
+	       (bytes-per-line (index-ceiling bits-per-line 8))
+	       (padded-bits-per-line
+		 (index* (index-ceiling bits-per-line 32) 32))
+	       (padded-bytes-per-line
+		 (index-ceiling padded-bits-per-line 8))
+	       (data (make-array (* padded-bytes-per-line height)
+				 :element-type 'card8))
+	       (line-base 0)
+	       (byte 0))
+	  (declare (type array-index bits-per-line bytes-per-line
+			 padded-bits-per-line padded-bytes-per-line
+			 line-base byte)
+		   (type buffer-bytes data))
+	  (with-vector (data buffer-bytes)
+	    (flet ((parse-hex (char)
+		     (second
+		       (assoc char
+			      '((#\0  0) (#\1  1) (#\2  2) (#\3  3)
+				(#\4  4) (#\5  5) (#\6  6) (#\7  7)
+				(#\8  8) (#\9  6) (#\a 10) (#\b 11)
+				(#\c 12) (#\d 13) (#\e 14) (#\f 15))
+			      :test #'char-equal))))
+	      ;; Read data
+	      ;; Note: using read-line instead of read-char would be 20% faster,
+	      ;;       but would cons a lot of garbage...
+	      (dotimes (i height)
+		(dotimes (j bytes-per-line)
+		  (loop (when (eql (read-char fstream) #\x) (return)))
+		  (setf (aref data (index+ line-base byte))
+			(index+ (index-ash (parse-hex (read-char fstream)) 4)
+				(parse-hex (read-char fstream))))
+		  (incf byte))
+		(setq byte 0
+		      line-base (index+ line-base padded-bytes-per-line)))))
+	  ;; Compensate for left-pad in width and x-hot
+	  (index-decf width left-pad)
+	  (when (getf properties :x-hot)
+	    (index-decf (getf properties :x-hot) left-pad))
+	  (create-image
+	    :width width :height height
+	    :depth depth :bits-per-pixel bits-per-pixel
+	    :data data :plist properties :format :z-pixmap
+	    :bytes-per-line padded-bytes-per-line
+	    :unit 32 :byte-lsb-first-p t :bit-lsb-first-p t
+	    :pad 32 :left-pad left-pad))))))
+
+(defun write-bitmap-file (pathname image &optional name)
+  ;; Writes an image to a C include file in standard X11 format
+  ;; NAME argument used for variable prefixes.  Defaults to "image"
+  (declare (type (or pathname string stream) pathname)
+	   (type image image)
+	   (type (or null stringable) name))
+  (unless (typep image 'image-x)
+    (setq image (copy-image image :result-type 'image-x)))
+  (let* ((plist (image-plist image))
+	 (name (or name (image-name image) 'image))
+	 (left-pad (image-x-left-pad image))
+	 (width (index+ (image-width image) left-pad))
+	 (height (image-height image))
+	 (depth
+	   (if (eq (image-x-format image) :z-pixmap)
+	       (image-depth image)
+	     1))
+	 (bits-per-pixel (image-x-bits-per-pixel image))
+	 (bits-per-line (index* width bits-per-pixel))
+	 (bytes-per-line (index-ceiling bits-per-line 8))
+	 (last (index* bytes-per-line height))
+	 (count 0))
+    (declare (type list plist)
+	     (type stringable name)
+	     (type card8 left-pad)
+	     (type card16 width height)
+	     (type (member 1 4 8 16 24 32) bits-per-pixel)
+	     (type image-depth depth)
+	     (type array-index bits-per-line bytes-per-line count last))
+    ;; Move x-hot by left-pad, if there is an x-hot, so image readers that
+    ;; don't know about left pad get the hot spot in the right place.  We have
+    ;; already increased width by left-pad.
+    (when (getf plist :x-hot)
+      (setq plist (copy-list plist))
+      (index-incf (getf plist :x-hot) left-pad))
+    (with-image-data-buffer (data last)
+      (if (index> bits-per-pixel 1)
+	  (image-swap-z
+	    (image-x-data image) data 0 0 bytes-per-line
+	    (image-x-bytes-per-line image) bytes-per-line
+	    height bits-per-pixel
+	    (image-x-byte-lsb-first-p image) t)
+	(image-swap-xy
+	  (image-x-data image) data 0 0 bytes-per-line
+	  (image-x-bytes-per-line image) bytes-per-line
+	  height 
+	  (image-x-unit image) (image-x-byte-lsb-first-p image)
+	  (image-x-bit-lsb-first-p image)
+	  32 t t))
+      (with-vector (data buffer-bytes)
+	(setq name (string-downcase (string name)))
+	(with-open-file (fstream pathname :direction :output)
+	  (format fstream "#define ~a_width ~d~%" name width)
+	  (format fstream "#define ~a_height ~d~%" name height)
+	  (unless (= depth 1)
+	    (format fstream "#define ~a_depth ~d~%" name depth))
+	  (unless (zerop left-pad)
+	    (format fstream "#define ~a_left_pad ~d~%" name left-pad))
+	  (do ((prop plist (cddr prop)))
+	      ((endp prop))
+	    (when (and (not (member (car prop) '(:width :height)))
+		       (numberp (cadr prop)))
+	      (format fstream "#define ~a_~a ~d~%"
+		      name
+		      (substitute
+			#\_ #\- (string-downcase (string (car prop)))
+			:test #'char=)
+		      (cadr prop))))
+	  (format fstream "static char ~a_bits[] = {" name)
+	  (dotimes (i height)
+	    (dotimes (j bytes-per-line)
+	      (when (zerop (index-mod count 15))
+		(terpri fstream)
+		(write-char #\space fstream))
+	      (write-string "0x" fstream)
+	      ;; Faster than (format fstream "0x~2,'0x," byte)
+	      (let ((byte (aref data count))
+		    (translate "0123456789abcdef"))
+		(declare (type card8 byte))
+		(write-char (char translate (ldb (byte 4 4) byte)) fstream)
+		(write-char (char translate (ldb (byte 4 0) byte)) fstream))
+	      (index-incf count)
+	      (unless (index= count last)
+		(write-char #\, fstream))))
+	  (format fstream "};~%" fstream))))))
+
+(defun bitmap-image (&optional plist &rest patterns)
+  ;; Create an image containg pattern
+  ;; PATTERNS are bit-vector constants (e.g. #*10101)
+  ;; If the first parameter is a list, its used as the image property-list.
+  (declare (type (or list bit-vector) plist)
+	   (type list patterns)) ;; list of bitvector
+  (declare (values image))
+  (unless (listp plist)
+    (push plist patterns)
+    (setq plist nil))
+  (let* ((width (length (first patterns)))
+	 (height (length patterns))
+	 (bitarray (make-array (list height width) :element-type 'bit))
+	 (row 0))
+    (declare (type card16 width height row)
+	     (type pixarray-1 bitarray))
+    (dolist (pattern patterns)
+      (declare (type simple-bit-vector pattern))
+      (dotimes (col width)
+	(declare (type card16 col))
+	(setf (aref bitarray row col) (the bit (aref pattern col))))
+      (incf row))
+    (create-image :width width :height height :plist plist :data bitarray)))
+
+(defun image-pixmap (drawable image &key gcontext width height depth)
+  ;; Create a pixmap containing IMAGE. Size defaults from the image.
+  ;; DEPTH is the pixmap depth.
+  ;; GCONTEXT is used for putting the image into the pixmap.
+  ;; If none is supplied, then one is created, used then freed.
+  (declare (type drawable drawable)
+	   (type image image)
+	   (type (or null gcontext) gcontext)
+	   (type (or null card16) width height)
+	   (type (or null card8) depth))
+  (declare (values pixmap))
+  (let* ((image-width (image-width image))
+	 (image-height (image-height image))
+	 (image-depth (image-depth image))
+	 (width (or width image-width))
+	 (height (or height image-height))
+	 (depth (or depth image-depth))
+	 (pixmap (create-pixmap :drawable drawable
+			       :width width
+			       :height height
+			       :depth depth))
+	 (gc (or gcontext (create-gcontext
+			    :drawable pixmap
+			    :foreground 1
+			    :background 0))))
+    (unless (= depth image-depth)
+      (if (= image-depth 1)
+	  (unless gcontext (xlib::required-arg gcontext))
+	(error "Pixmap depth ~d incompatable with image depth ~d"
+	       depth image-depth)))	       
+    (put-image pixmap gc image :x 0 :y 0 :bitmap-p (and (= image-depth 1) gcontext))
+    ;; Tile when image-width is less than the pixmap width, or
+    ;; the image-height is less than the pixmap height.
+    ;; ??? Would it be better to create a temporary pixmap and 
+    ;; ??? let the server do the tileing?
+    (do ((x image-width (+ x image-width)))
+	((>= x width))
+      (copy-area pixmap gc 0 0 image-width image-height pixmap x 0)
+      (incf image-width image-width))
+    (do ((y image-height (+ y image-height)))
+	((>= y height))
+      (copy-area pixmap gc 0 0 image-width image-height pixmap 0 y)
+      (incf image-height image-height))
+    (unless gcontext (free-gcontext gc))
+    pixmap))
+
diff --git a/clx/input.lisp b/clx/input.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b2ed082209f4d18e969935d1e8d4b2cfa66a20e9
--- /dev/null
+++ b/clx/input.lisp
@@ -0,0 +1,1927 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+;;;
+;;; Change history:
+;;;
+;;;  Date	Author	Description
+;;; -------------------------------------------------------------------------------------
+;;; 12/10/87	LGO	Created
+
+(in-package :xlib)
+
+(export '(
+	  event-listen
+	  queue-event
+	  process-event
+	  make-event-handlers
+	  event-handler
+	  event-case
+	  event-cond
+	  discard-current-event
+	  request-error
+	  value-error
+	  window-error
+	  pixmap-error
+	  atom-error
+	  cursor-error
+	  font-error
+	  match-error
+	  drawable-error
+	  access-error
+	  alloc-error
+	  colormap-error
+	  gcontext-error
+	  id-choice-error
+	  name-error
+	  length-error
+	  implementation-error
+	  request-error
+	  resource-error
+	  unknown-error
+	  access-error
+	  alloc-error
+	  atom-error
+	  colormap-error
+	  cursor-error
+	  drawable-error
+	  font-error
+	  gcontext-error
+	  id-choice-error
+	  illegal-request-error
+	  length-error
+	  match-error
+	  name-error
+	  pixmap-error
+	  value-error
+	  window-error
+	  implementation-error
+	  #-ansi-common-lisp type-error
+	  closed-display
+	  lookup-error
+	  connection-failure
+	  reply-length-error
+	  reply-timeout
+	  sequence-error
+	  unexpected-reply
+	  missing-parameter
+	  invalid-font
+	  device-busy
+	  get-external-event-code
+	  define-extension
+	  extension-opcode
+	  define-error
+	  decode-core-error
+	  declare-event
+	  ))
+
+;; Event Resource
+(defvar *event-free-list* nil) ;; List of unused (processed) events
+
+(eval-when (eval compile load)
+(defconstant *max-events* 64) ;; Maximum number of events supported (the X11 alpha release only has 34)
+(defvar *event-key-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event keys - See define-event")
+)
+(defvar *event-macro-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event handler functions - See declare-event")
+(defvar *event-handler-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event handler functions - See declare-event")
+(defvar *event-send-vector* (make-array *max-events* :initial-element nil)
+  "Vector of event sending functions - See declare-event")
+
+(defun allocate-event ()
+  (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
+      (make-reply-buffer *replysize*)))
+
+(defun deallocate-event (reply-buffer)
+  (declare (type reply-buffer reply-buffer))
+  (setf (reply-size reply-buffer) *replysize*)
+  (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
+
+;; Extensions are handled as follows:
+;; DEFINITION:	Use DEFINE-EXTENSION
+;;
+;; CODE:	Use EXTENSION-CODE to get the X11 opcode for an extension.
+;;		This looks up the code on the display-extension-alist.
+;;
+;; EVENTS:	Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
+;;		at LOAD time to define an internal event-code number
+;;		(stored in the 'event-code property of the event-name)
+;;		used to index the following vectors:
+;;		*event-key-vector* 	Used for getting the event-key
+;;		*event-macro-vector*	Used for getting the event-parameter getting macros
+;;
+;;		The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
+;;		a server event-code into an internal event-code used to index the following
+;;		vectors:
+;;		*event-handler-vector*	Used for getting the event-handler function
+;;		*event-send-vector*	Used for getting the event-sending function
+;;
+;;		The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
+;;		internal event-codes to external (server) codes.
+;;
+;; ERRORS:	Use DEFINE-ERROR to define new error decodings.
+;;
+
+
+;; Any event-code greater than 34 is for an extension
+(defparameter *first-extension-event-code* 35)
+
+(defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
+
+(defmacro define-extension (name &key events errors)
+  ;; Define extension NAME with EVENTS and ERRORS.
+  ;; Note: The case of NAME is important.
+  ;; To define the request, Use:
+  ;;     (with-buffer-request (display (extension-opcode ,name)) ,@body)
+  ;;     See the REQUESTS file for lots of examples.
+  ;; To define event handlers, use declare-event.
+  ;; To define error handlers, use declare-error and define-condition.
+  (declare (type stringable name)
+	   (type list events errors))
+  (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
+	(event-list (mapcar #'canonicalize-event-name events)))
+    `(eval-when (compile load eval)
+       (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
+				(delete ',name-symbol *extensions* :key #'car))))))
+
+(eval-when (compile eval load)
+(defun canonicalize-event-name (event)
+  ;; Returns the event name keyword given an event name stringable
+  (declare (type stringable event))
+  (declare (values event-key))
+  (kintern event))
+) ;; end eval-when
+
+(eval-when (compile eval load)
+(defun allocate-extension-event-code (name)
+  ;; Allocate an event-code for an extension
+  ;; This is executed at COMPILE and LOAD time from DECLARE-EVENT.
+  ;; The event-code is used at compile-time by macros to index the following vectors:
+  ;; *event-key-vector* *event-macro-vector* *event-handler-vector* *event-send-vector*
+  (let ((event-code (get name 'event-code)))
+    (declare (type (or null card8) event-code))
+    (unless event-code
+      ;; First ensure the name is for a declared extension
+      (unless (dolist (extension *extensions*)
+		(when (member name (second extension))
+		  (return t)))
+	(x-type-error name 'event-key))
+      (setq event-code (position nil *event-key-vector*
+				 :start *first-extension-event-code*))
+      (setf (svref *event-key-vector* event-code) name)
+      (setf (get name 'event-code) event-code))
+    event-code))
+) ;; end eval-when
+
+(defun get-internal-event-code (display code)
+  ;; Given an X11 event-code, return the internal event-code.
+  ;; The internal event-code is used for indexing into the following vectors:
+  ;; *event-key-vector* *event-handler-vector* *event-send-vector*
+  ;; Returns NIL when the event-code is for an extension that isn't handled.
+  (declare (type display display)
+	   (type card8 code))
+  (declare (values (or nil card8)))
+  (setq code (logand #x7f code))
+  (if (< code *first-extension-event-code*)
+      code
+    (let* ((code-offset (- code *first-extension-event-code*))
+	   (event-extensions (display-event-extensions display))
+	   (code (if (< code-offset (length event-extensions))
+		     (aref event-extensions code-offset)
+		   0)))
+      (declare (type card8 code-offset code))
+      (when (zerop code)
+	(x-cerror "Ignore the event"
+		  'unimplemented-event :event-code code :display display))
+      code)))
+
+(defun get-external-event-code (display event)
+  ;; Given an X11 event name, return the event-code
+  (declare (type display display)
+	   (type event-key event))
+  (declare (values card8))
+  (let ((code (get-event-code event)))
+    (declare (type (or null card8) code))
+    (when (>= code *first-extension-event-code*)
+      (setq code (+ *first-extension-event-code*
+		    (or (position code (display-event-extensions display))
+			(x-error 'undefined-event :display display :event-name event)))))
+    code))
+
+(defmacro extension-opcode (display name)
+  ;; Returns the major opcode for extension NAME.
+  ;; This is a macro to enable NAME to be interned for fast run-time
+  ;; retrieval. 
+  ;; Note: The case of NAME is important.
+  (declare (type display display)
+	   (type stringable name))
+  (declare (values card8))
+  (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
+    `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
+	 (x-error 'absent-extension :name ',name-symbol :display ,display))))
+
+(defun initialize-extensions (display)
+  ;; Initialize extensions for DISPLAY
+  (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
+	(extension-alist nil))
+    (declare (type vector event-extensions)
+	     (type list extension-alist))
+    (dolist (extension *extensions*)
+      (let ((name (first extension))
+	    (events (second extension)))
+	(declare (type keyword name)
+		 (type list events))
+	(multiple-value-bind (major-opcode first-event first-error)
+	    (query-extension display name)
+	  (declare (type (or null card8) major-opcode first-event first-error))
+	  (when (and major-opcode (plusp major-opcode))
+	    (push (list name major-opcode first-event first-error)
+		  extension-alist)
+	    (when (plusp first-event) ;; When there are extension events
+	      ;; Grow extension vector when needed
+	      (let ((max-event (- (+ first-event (length events))
+				  *first-extension-event-code*)))
+		(declare (type card8 max-event))
+		(when (>= max-event (length event-extensions))
+		  (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
+						    :initial-element 0)))
+		    (declare (type vector new-extensions))
+		    (replace new-extensions event-extensions)
+		    (setq event-extensions new-extensions))))
+	      (dolist (event events)
+		(declare (type symbol event))
+		(setf (aref event-extensions (- first-event *first-extension-event-code*))
+		      (get-event-code event))
+		(incf first-event)))))))
+    (setf (display-event-extensions display) event-extensions)
+    (setf (display-extension-alist display) extension-alist)))
+
+;;
+;; Reply handlers
+;;
+
+(defvar *pending-command-free-list* nil)
+
+(defun start-pending-command (display)
+  (declare (type display display))
+  (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
+						  pending-command-next pending-command)
+			     (make-pending-command))))
+    (declare (type pending-command pending-command))
+    (setf (pending-command-reply-buffer pending-command) nil)
+    (setf (pending-command-process pending-command) (current-process))
+    (setf (pending-command-sequence pending-command)
+	  (ldb (byte 16 0) (1+ (buffer-request-number display))))
+    ;; Add the pending command to the end of the threaded list of pending
+    ;; commands for the display.
+    (with-event-queue-internal (display)
+      (threaded-nconc pending-command (display-pending-commands display)
+		      pending-command-next pending-command))
+    pending-command))
+
+(defun stop-pending-command (display pending-command)
+  (declare (type display display)
+	   (type pending-command pending-command))
+  (with-event-queue-internal (display)
+    ;; Remove the pending command from the threaded list of pending commands
+    ;; for the display.
+    (threaded-delete pending-command (display-pending-commands display)
+		     pending-command-next pending-command)
+    ;; Deallocate any reply buffers in this pending command
+    (loop
+      (let ((reply-buffer
+	      (threaded-pop (pending-command-reply-buffer pending-command)
+			    reply-next reply-buffer)))
+	(declare (type (or null reply-buffer) reply-buffer))
+	(if reply-buffer
+	    (deallocate-reply-buffer reply-buffer)
+	  (return nil)))))
+  ;; Deallocate this pending-command
+  (threaded-atomic-push pending-command *pending-command-free-list*
+			pending-command-next pending-command)
+  nil)
+
+;;;
+
+(defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
+
+(defun allocate-reply-buffer (size)
+  (declare (type array-index size))
+  (if (index<= size *replysize*)
+      (allocate-event)
+    (let ((index (integer-length (index1- size))))
+      (declare (type array-index index))
+      (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
+			       reply-next reply-buffer)
+	  (make-reply-buffer (index-ash 1 index))))))
+
+(defun deallocate-reply-buffer (reply-buffer)
+  (declare (type reply-buffer reply-buffer))
+  (let ((size (reply-size reply-buffer)))
+    (declare (type array-index size))
+    (if (index<= size *replysize*)
+	(deallocate-event reply-buffer)
+      (let ((index (integer-length (index1- size))))
+	(declare (type array-index index))
+	(threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
+			      reply-next reply-buffer)))))
+
+;;;
+
+(defun read-error-input (display sequence reply-buffer token)
+  (declare (type display display)
+	   (type reply-buffer reply-buffer)
+	   (type card16 sequence))
+  (tagbody
+    start
+       (with-event-queue-internal (display)
+	 (let ((command 
+		 ;; Find any pending command with this sequence number.
+		 (threaded-dolist (pending-command (display-pending-commands display)
+						   pending-command-next pending-command)
+		   (when (= (pending-command-sequence pending-command) sequence)
+		     (return pending-command)))))
+	   (declare (type (or null pending-command) command))
+	   (cond ((not (null command))
+		  ;; Give this reply to the pending command
+		  (threaded-nconc reply-buffer (pending-command-reply-buffer command)
+				  reply-next reply-buffer)
+		  (process-wakeup (pending-command-process command)))
+		 ((member :immediately (display-report-asynchronous-errors display))
+		  ;; No pending command and we should report the error immediately
+		  (go report-error))
+		 (t
+		  ;; No pending command found, count this as an asynchronous error
+		  (threaded-nconc reply-buffer (display-asynchronous-errors display)
+				  reply-next reply-buffer)))))
+       (return-from read-error-input nil)
+    report-error
+       (note-input-complete display token)
+       (apply #'report-error display
+	      (prog1 (make-error display reply-buffer t)
+		     (deallocate-event reply-buffer)))))
+
+(defun read-reply-input (display sequence length reply-buffer)
+  (declare (type display display)
+	   (type (or null reply-buffer) reply-buffer)
+	   (type card16 sequence)
+	   (type array-index length))
+  (unwind-protect 
+      (progn
+	(when (index< *replysize* length)
+	  (let ((repbuf nil))
+	    (declare (type (or null reply-buffer) repbuf))
+	    (unwind-protect
+		(progn
+		  (setq repbuf (allocate-reply-buffer length))
+		  (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
+				  0 *replysize*)
+		  (deallocate-event (shiftf reply-buffer repbuf nil)))
+	      (when repbuf
+		(deallocate-reply-buffer repbuf))))
+	  (when (buffer-input display (reply-ibuf8 reply-buffer) *replysize* length)
+	    (return-from read-reply-input t))
+	  (setf (reply-data-size reply-buffer) length))
+	(with-event-queue-internal (display)
+	  ;; Find any pending command with this sequence number.
+	  (let ((command 
+		  (threaded-dolist (pending-command (display-pending-commands display)
+						    pending-command-next pending-command)
+		    (when (= (pending-command-sequence pending-command) sequence)
+		      (return pending-command)))))
+	    (declare (type (or null pending-command) command))
+	    (when command 
+	      ;; Give this reply to the pending command
+	      (threaded-nconc (shiftf reply-buffer nil)
+			      (pending-command-reply-buffer command)
+			      reply-next reply-buffer)
+	      (process-wakeup (pending-command-process command)))))
+	nil)
+    (when reply-buffer
+      (deallocate-reply-buffer reply-buffer))))
+
+(defun read-event-input (display code reply-buffer)
+  (declare (type display display)
+	   (type card8 code)
+	   (type reply-buffer reply-buffer))
+  ;; Push the event in the input buffer on the display's event queue
+  (setf (event-code reply-buffer)
+	(get-internal-event-code display code))
+  (enqueue-event reply-buffer display)
+  nil)
+
+(defun note-input-complete (display token)
+  (declare (type display display))
+  (when (eq (display-input-in-progress display) token)
+    ;; Indicate that input is no longer in progress
+    (setf (display-input-in-progress display) nil)
+    ;; Let the event process get the first chance to do input
+    (let ((process (display-event-process display)))
+      (when (not (null process))
+	(process-wakeup process)))
+    ;; Then give processes waiting for command responses a chance
+    (unless (display-input-in-progress display)
+      (with-event-queue-internal (display)
+	(threaded-dolist (command (display-pending-commands display)
+				  pending-command-next pending-command)
+	  (process-wakeup (pending-command-process command)))))))
+
+(defun read-input (display timeout force-output-p predicate &rest predicate-args)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p)
+	   (dynamic-extent predicate-args))
+  (declare (type function predicate)
+	   (downward-funarg predicate))
+  (let ((reply-buffer nil)
+	(token (or (current-process) (cons nil nil))))
+    (declare (type (or null reply-buffer) reply-buffer))
+    (unwind-protect 
+	(tagbody
+	  loop
+	     (when (display-dead display)
+	       (x-error 'closed-display :display display))
+	     (when (apply predicate predicate-args)
+	       (return-from read-input nil))
+	     ;; Check and see if we have to force output
+	     (when (and force-output-p
+			(or (and (not (eq (display-input-in-progress display) token))
+				 (not (conditional-store
+					(display-input-in-progress display) nil token)))
+			    (null (buffer-listen display))))
+	       (go force-output))
+	     ;; Ensure that ony one process is reading input.
+	     (unless (or (eq (display-input-in-progress display) token)
+			 (conditional-store (display-input-in-progress display) nil token))
+	       (if (eql timeout 0)
+		   (return-from read-input :timeout)
+		 (apply #'process-block "CLX Input Lock"
+			#'(lambda (display predicate &rest predicate-args)
+			    (declare (type display display)
+				     (dynamic-extent predicate-args)
+				     (type function predicate)
+				     (downward-funarg predicate))
+			    (or (apply predicate predicate-args)
+				(null (display-input-in-progress display))
+				(not (null (display-dead display)))))
+			display predicate predicate-args))
+	       (go loop))
+	     ;; Now start gobbling.
+	     (setq reply-buffer (allocate-event))
+	     (with-buffer-input (reply-buffer :sizes (8 16 32))
+	       (let ((type 0))
+		 (declare (type card8 type))
+		 ;; Wait for input before we disallow aborts.
+		 (unless (eql timeout 0)
+		   (let ((eof-p (buffer-input-wait display timeout)))
+		     (when eof-p (return-from read-input eof-p))))
+		 (without-aborts
+		   (let ((eof-p (buffer-input display buffer-bbuf 0 *replysize*
+					      (if force-output-p 0 timeout))))
+		     (when eof-p
+		       (when (eq eof-p :timeout)
+			 (if force-output-p
+			     (go force-output)
+			   (return-from read-input :timeout)))
+		       (setf (display-dead display) t)
+		       (return-from read-input eof-p)))
+		   (setf (reply-data-size reply-buffer) *replysize*)
+		   (when (= (the card8 (setq type (read-card8 0))) 1)
+		     ;; Normal replies can be longer than *replysize*, so we
+		     ;; have to handle them while aborts are still disallowed.
+		     (let ((value
+			     (read-reply-input
+			       display (read-card16 2)
+			       (index+ *replysize* (index* (read-card32 4) 4))
+			       (shiftf reply-buffer nil))))
+		       (when value
+			 (return-from read-input value))
+		       (go loop))))
+		 (if (zerop type)
+		     (read-error-input
+		       display (read-card16 2) (shiftf reply-buffer nil) token)
+		   (read-event-input
+		     display (read-card8 0) (shiftf reply-buffer nil)))))
+	     (go loop)
+	  force-output 
+	     (note-input-complete display token)
+	     (display-force-output display)
+	     (setq force-output-p nil)
+	     (go loop))
+      (when (not (null reply-buffer))
+	(deallocate-reply-buffer reply-buffer))
+      (note-input-complete display token))))
+
+(defun report-asynchronous-errors (display mode)
+  (when (and (display-asynchronous-errors display)
+	     (member mode (display-report-asynchronous-errors display)))
+    (let ((aborted t))
+      (unwind-protect 
+	  (loop
+	    (let ((error
+		    (with-event-queue-internal (display)
+		      (threaded-pop (display-asynchronous-errors display)
+				    reply-next reply-buffer))))
+	      (declare (type (or null reply-buffer) error))
+	      (if error
+		  (apply #'report-error display
+			 (prog1 (make-error display error t)
+				(deallocate-event error)))
+		(return (setq aborted nil)))))
+	;; If we get aborted out of this, deallocate all outstanding asynchronous
+	;; errors.
+	(when aborted 
+	  (with-event-queue-internal (display)
+	    (loop
+	      (let ((reply-buffer
+		      (threaded-pop (display-asynchronous-errors display)
+				    reply-next reply-buffer)))
+		(declare (type (or null reply-buffer) reply-buffer))
+		(if reply-buffer
+		    (deallocate-event reply-buffer)
+		  (return nil))))))))))
+
+(defun wait-for-event (display timeout force-output-p)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p))
+  (let ((event-process-p (not (eql timeout 0))))
+    (declare (type boolean event-process-p))
+    (unwind-protect
+	(loop
+	  (when event-process-p
+	    (conditional-store (display-event-process display) nil (current-process)))
+	  (let ((eof (read-input
+		       display timeout force-output-p 
+		       #'(lambda (display)
+			   (declare (type display display))
+			   (or (not (null (display-new-events display)))
+			       (and (display-asynchronous-errors display)
+				    (member :before-event-handling
+					    (display-report-asynchronous-errors display))
+				    t)))
+		       display)))
+	    (when eof (return eof)))
+	  ;; Report asynchronous errors here if the user wants us to.
+	  (when event-process-p
+	    (report-asynchronous-errors display :before-event-handling))
+	  (when (not (null (display-new-events display)))
+	    (return nil)))
+      (when (and event-process-p
+		 (eq (display-event-process display) (current-process)))
+	(setf (display-event-process display) nil)))))
+
+(defun read-reply (display pending-command)
+  (declare (type display display)
+	   (type pending-command pending-command))
+  (loop
+    (when (read-input display nil nil
+		      #'(lambda (pending-command)
+			  (declare (type pending-command pending-command))
+			  (not (null (pending-command-reply-buffer pending-command))))
+		      pending-command)
+      (x-error 'closed-display :display display))
+    (let ((reply-buffer
+	    (with-event-queue-internal (display)
+	      (threaded-pop (pending-command-reply-buffer pending-command)
+			    reply-next reply-buffer))))
+      (declare (type reply-buffer reply-buffer))
+      ;; Check for error.
+      (with-buffer-input (reply-buffer)
+	(ecase (read-card8 0)
+	  (0 (apply #'report-error display
+		    (prog1 (make-error display reply-buffer nil)
+			   (deallocate-reply-buffer reply-buffer))))
+	  (1 (return reply-buffer)))))))
+
+;;;
+
+(defun event-listen (display &optional (timeout 0))
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (values number-of-events-queued eof-or-timeout))
+  ;; Returns the number of events queued locally, if any, else nil.  Hangs
+  ;; waiting for events, forever if timeout is nil, else for the specified
+  ;; number of seconds.
+  (let* ((current-event-symbol (car (display-current-event-symbol display)))
+	 (current-event (and (boundp current-event-symbol)
+			     (symbol-value current-event-symbol)))
+	 (queue (or current-event (display-event-queue-head display))))
+    (declare (type symbol current-event-symbol)
+	     (type (or null reply-buffer) current-event queue))
+    (if queue
+	(values
+	  (with-event-queue-internal (display :timeout timeout)
+	    (threaded-length (or current-event (display-event-queue-head display))
+			     reply-next reply-buffer))
+	  nil)
+      (with-event-queue (display :timeout timeout :inline t)
+	(let ((eof-or-timeout (wait-for-event display timeout nil)))
+	  (if eof-or-timeout
+	      (values nil eof-or-timeout)
+	    (values 
+	      (with-event-queue-internal (display :timeout timeout)
+		(threaded-length (display-event-queue-head display)
+				 reply-next reply-buffer))
+	      nil)))))))
+
+(defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
+  ;; The event is put at the head of the queue if append-p is nil, else the tail.
+  ;; Additional arguments depend on event-key, and are as specified above with
+  ;; declare-event, except that both resource-ids and resource objects are accepted
+  ;; in the event components.
+  (declare (type display display)
+	   (type event-key event-key)
+	   (type boolean append-p send-event-p)
+	   (dynamic-extent args))
+  (unless (get event-key 'event-code)
+    (x-type-error event-key 'event-key))
+  (let* ((event (allocate-event))
+	 (buffer (reply-ibuf8 event))
+	 (event-code (get event-key 'event-code)))
+    (declare (type reply-buffer event)
+	     (type buffer-bytes buffer)
+	     (type (or null card8) event-code))
+    (unless event-code (x-type-error event-key 'event-key))
+    (setf (event-code event) event-code)
+    (with-display (display)
+      (apply (svref *event-send-vector* event-code) display args)
+      (buffer-replace buffer
+		      (display-obuf8 display)
+		      0
+		      *replysize*
+		      (index+ 12 (buffer-boffset display)))
+      (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
+	    (aref buffer 2) 0
+	    (aref buffer 3) 0))
+    (with-event-queue (display)
+      (if append-p
+	  (enqueue-event event display)
+	(with-event-queue-internal (display)
+	  (threaded-requeue event
+			    (display-event-queue-head display)
+			    (display-event-queue-tail display)
+			    reply-next reply-buffer))))))
+
+(defun enqueue-event (new-event display)
+  (declare (type reply-buffer new-event)
+	   (type display display))
+  ;; Place EVENT at the end of the event queue for DISPLAY
+  (let* ((event-code (event-code new-event))
+	 (event-key (and (index< event-code (length *event-key-vector*))
+			 (svref *event-key-vector* event-code))))
+    (declare (type array-index event-code)
+	     (type (or null keyword) event-key))
+    (if (null event-key)
+	(unwind-protect
+	    (cerror "Ignore this event" "No handler for ~s event" event-key)
+	  (deallocate-event new-event))
+      (with-event-queue-internal (display)
+	(threaded-enqueue new-event
+			  (display-event-queue-head display)
+			  (display-event-queue-tail display)
+			  reply-next reply-buffer)
+	(unless (display-new-events display)
+	  (setf (display-new-events display) new-event))))))
+
+
+(defmacro define-event (name code)
+  `(eval-when (eval compile load)
+     (setf (svref *event-key-vector* ,code) ',name)
+     (setf (get ',name 'event-code) ,code)))
+
+;; Event names.  Used in "type" field in XEvent structures.  Not to be
+;; confused with event masks above.  They start from 2 because 0 and 1
+;; are reserved in the protocol for errors and replies. */
+
+(define-event :key-press 2)
+(define-event :key-release 3)
+(define-event :button-press 4)
+(define-event :button-release 5)
+(define-event :motion-notify 6)
+(define-event :enter-notify 7)
+(define-event :leave-notify 8)
+(define-event :focus-in 9)
+(define-event :focus-out 10)
+(define-event :keymap-notify 11)
+(define-event :exposure 12)
+(define-event :graphics-exposure 13)
+(define-event :no-exposure 14)
+(define-event :visibility-notify 15)
+(define-event :create-notify 16)
+(define-event :destroy-notify 17)
+(define-event :unmap-notify 18)
+(define-event :map-notify 19)
+(define-event :map-request 20)
+(define-event :reparent-notify 21)
+(define-event :configure-notify 22)
+(define-event :configure-request 23)
+(define-event :gravity-notify 24)
+(define-event :resize-request 25)
+(define-event :circulate-notify 26)
+(define-event :circulate-request 27)
+(define-event :property-notify 28)
+(define-event :selection-clear 29)
+(define-event :selection-request 30)
+(define-event :selection-notify 31)
+(define-event :colormap-notify 32)
+(define-event :client-message 33)
+(define-event :mapping-notify 34)
+
+
+(defmacro declare-event (event-codes &body declares)
+  ;; Used to indicate the keyword arguments for handler functions in
+  ;; process-event and event-case.
+  ;; Generates the functions used in SEND-EVENT.
+  ;; A compiler warning is printed when all of EVENT-CODES are not
+  ;; defined by a preceding DEFINE-EXTENSION.
+  ;; The body is a list of declarations, each of which has the form:
+  ;; (type . items)  Where type is a data-type, and items is a list of
+  ;; symbol names.  The item order corresponds to the order of fields
+  ;; in the event sent by the server.  An item may be a list of items.
+  ;; In this case, each item is aliased to the same event field.
+  ;; This is used to give all events an EVENT-WINDOW item.
+  ;; See the INPUT file for lots of examples.
+  (declare (type (or keyword list) event-codes)
+	   (type (alist (field-type symbol) (field-names list))
+                 declares))
+  (when (atom event-codes) (setq event-codes (list event-codes)))
+  (setq event-codes (mapcar #'canonicalize-event-name event-codes))
+  (let* ((keywords nil)
+	 (name (first event-codes))
+	 (get-macro (xintern name '-event-get-macro))
+	 (get-function (xintern name '-event-get))
+	 (put-function (xintern name '-event-put)))
+    (multiple-value-bind (get-code get-index get-sizes)
+	(get-put-items
+	  2 declares nil
+	  #'(lambda (type index item args)
+	      (flet ((event-get (type index item args)
+		       (unless (member type '(pad8 pad16))
+			 `(,(kintern item)
+			   (,(getify type) ,index ,@args)))))
+		(if (atom item)
+		    (event-get type index item args)
+		  (mapcan #'(lambda (item)
+			      (event-get type index item args))
+			  item)))))
+      (declare (ignore get-index))
+      (multiple-value-bind (put-code put-index put-sizes)
+	  (get-put-items
+	    2 declares t
+	    #'(lambda (type index item args)
+		(unless (member type '(pad8 pad16))
+		  (if (atom item)
+		      (progn
+			(push item keywords)
+			`((,(putify type) ,index ,item ,@args)))
+		    (let ((names (mapcar #'(lambda (name) (kintern name))
+					 item)))
+		      (setq keywords (append item keywords))
+		      `((,(putify type) ,index
+			 (check-consistency ',names ,@item) ,@args)))))))
+	(declare (ignore put-index))
+	`(within-definition (,name declare-event)
+	   (defun ,get-macro (display event-key variable)
+	     ;; Note: we take pains to macroexpand the get-code here to enable application
+	     ;; code to be compiled without having the CLX macros file loaded.
+	     (subst display '%buffer
+		    (getf `(:display (the display ,display)
+			    :event-key (the keyword ,event-key)
+			    :event-code (the card8 (logand #x7f (read-card8 0)))
+			    :send-event-p (the boolean (logbitp 7 (read-card8 0)))
+			    ,@',(mapcar #'macroexpand get-code))
+			  variable)))
+
+	   (defun ,get-function (display event handler)
+	     (declare (type display display)
+		      (type reply-buffer event))
+	     (declare (type function handler)
+		      (downward-funarg handler))
+	     (reading-event (event :display display :sizes (8 16 ,@get-sizes))
+	       (funcall handler
+			:display display
+			:event-key (svref *event-key-vector* (event-code event))
+			:event-code (logand #x7f (card8-get 0))
+			:send-event-p (logbitp 7 (card8-get 0))
+			,@get-code)))
+
+	   (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
+				 &allow-other-keys)
+	     (declare (type display display))
+	     ,(when (member 'sequence keywords)
+		`(unless sequence (setq sequence (display-request-number display))))
+	     (with-buffer-output (display :sizes ,put-sizes
+					  :index (index+ (buffer-boffset display) 12))
+	       ,@put-code))
+       
+	   ,@(mapcar #'(lambda (name)
+			 (allocate-extension-event-code name)
+			 `(let ((event-code (or (get ',name 'event-code)
+						(allocate-extension-event-code ',name))))
+			    (setf (svref *event-macro-vector* event-code)
+				  (function ,get-macro))
+			    (setf (svref *event-handler-vector* event-code)
+				  (function ,get-function))
+			    (setf (svref *event-send-vector* event-code)
+				  (function ,put-function))))
+		     event-codes)
+	   ',name)))))
+
+(defun check-consistency (names &rest args)
+  ;; Ensure all args are nil or have the same value.
+  ;; Returns the consistent non-nil value.
+  (let ((value (car args)))
+    (dolist (arg (cdr args))
+      (if value
+	  (when (and arg (not (eq arg value)))
+	    (x-error 'inconsistent-parameters
+		     :parameters (mapcan #'list names args)))
+	(setq value arg)))
+    value))
+
+(declare-event (:key-press :key-release :button-press :button-release)
+  ;; for key-press and key-release, code is the keycode
+  ;; for button-press and button-release, code is the button number
+  (data code)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  (boolean same-screen-p)
+  )
+
+(declare-event :motion-notify
+  ((data boolean) hint-p)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  (boolean same-screen-p))
+
+(declare-event (:enter-notify :leave-notify)
+  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
+  (card16 sequence)
+  (card32 time)
+  (window root (window event-window))
+  ((or null window) child)
+  (int16 root-x root-y x y)
+  (card16 state)
+  ((member8 :normal :grab :ungrab) mode)
+  ((bit 0) focus-p)
+  ((bit 1) same-screen-p))
+
+(declare-event (:focus-in :focus-out)
+  ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
+		  :pointer :pointer-root :none))
+   kind)
+  (card16 sequence)
+  (window (window event-window))
+  ((member8 :normal :while-grabbed :grab :ungrab) mode))
+
+(declare-event :keymap-notify
+  ((bit-vector256 0) keymap))
+
+(declare-event :exposure
+  (card16 sequence)
+  (window (window event-window))
+  (card16 x y width height count))
+
+(declare-event :graphics-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card16 x y width height)
+  (card16 minor)  ;; Minor opcode
+  (card16 count)
+  (card8 major))
+
+(declare-event :no-exposure
+  (card16 sequence)
+  (drawable (drawable event-window))
+  (card16 minor)
+  (card8  major))
+
+(declare-event :visibility-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((member8 :unobscured :partially-obscured :fully-obscured) state))
+
+(declare-event :create-notify
+  (card16 sequence)
+  (window (parent event-window) window)
+  (int16 x y)
+  (card16 width height border-width)
+  (boolean override-redirect-p))
+
+(declare-event :destroy-notify
+  (card16 sequence)
+  (window event-window window))
+
+(declare-event :unmap-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean configure-p))
+
+(declare-event :map-notify
+  (card16 sequence)
+  (window event-window window)
+  (boolean override-redirect-p))
+
+(declare-event :map-request
+  (card16 sequence)
+  (window (parent event-window) window))
+
+(declare-event :reparent-notify
+  (card16 sequence)
+  (window event-window window parent)
+  (int16 x y)
+  (boolean override-redirect-p))
+
+(declare-event :configure-notify
+  (card16 sequence)
+  (window event-window window)
+  ((or null window) above-sibling)
+  (int16 x y)
+  (card16 width height border-width)
+  (boolean override-redirect-p))
+
+(declare-event :configure-request
+  ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
+  (card16 sequence)
+  (window (parent event-window) window)
+  ((or null window) above-sibling)
+  (int16 x y)
+  (card16 width height border-width value-mask))
+
+(declare-event :gravity-notify
+  (card16 sequence)
+  (window event-window window)
+  (int16 x y))
+
+(declare-event :resize-request
+  (card16 sequence)
+  (window (window event-window))
+  (card16 width height))
+
+(declare-event :circulate-notify
+  (card16 sequence)
+  (window event-window window parent)
+  ((member16 :top :bottom) place))
+
+(declare-event :circulate-request
+  (card16 sequence)
+  (window (parent event-window) window)
+  (pad16 1 2)
+  ((member16 :top :bottom) place))
+
+(declare-event :property-notify
+  (card16 sequence)
+  (window (window event-window))
+  (keyword atom) ;; keyword
+  (card32 time)
+  ((member16 :new-value :deleted) state))
+
+(declare-event :selection-clear
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window)) 
+  (keyword selection) ;; keyword
+  )
+
+(declare-event :selection-request
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window) requestor)
+  (keyword selection target)
+  ((or null keyword) property)
+  )
+
+(declare-event :selection-notify
+  (card16 sequence)
+  (card32 time)
+  (window (window event-window))
+  (keyword selection target)
+  ((or null keyword) property)
+  )
+
+(declare-event :colormap-notify
+  (card16 sequence)
+  (window (window event-window))
+  ((or null colormap) colormap)
+  (boolean new-p installed-p))
+
+(declare-event :client-message
+  (data format)
+  (card16 sequence)
+  (window (window event-window))
+  (keyword type)
+  ((client-message-sequence format) data))
+
+(declare-event :mapping-notify
+  (card16 sequence)
+  ((member8 :modifier :keyboard :pointer) request)
+  (card8 start) ;; first key-code
+  (card8 count))
+
+
+;;
+;; EVENT-LOOP
+;;
+
+(defun event-loop-setup (display)
+  (declare (type display display)
+	   (values progv-vars progv-vals
+		   current-event-symbol current-event-discarded-p-symbol))
+  (let* ((progv-vars (display-current-event-symbol display))
+	 (current-event-symbol (first progv-vars))
+	 (current-event-discarded-p-symbol (second progv-vars)))
+    (declare (type list progv-vars)
+	     (type symbol current-event-symbol current-event-discarded-p-symbol))
+    (values
+      progv-vars 
+      (list (if (boundp current-event-symbol)
+		;; The current event is already bound, so bind it to the next
+		;; event.
+		(let ((event (symbol-value current-event-symbol)))
+		  (declare (type (or null reply-buffer) event))
+		  (and event (reply-next (the reply-buffer event))))
+	      ;; The current event isn't bound, so bind it to the head of the
+	      ;; event queue.
+	      (display-event-queue-head display))
+	    nil)
+      current-event-symbol
+      current-event-discarded-p-symbol)))
+
+(defun event-loop-step-before (display timeout force-output-p current-event-symbol)
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean force-output-p)
+	   (type symbol current-event-symbol)
+	   (values event eof-or-timeout))
+  (unless (symbol-value current-event-symbol)
+    (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
+      (when eof-or-timeout
+	(return-from event-loop-step-before (values nil eof-or-timeout))))
+    (setf (symbol-value current-event-symbol) (display-new-events display)))
+  (let ((event (symbol-value current-event-symbol)))
+    (declare (type reply-buffer event))
+    (with-event-queue-internal (display)
+      (when (eq event (display-new-events display))
+	(setf (display-new-events display) (reply-next event))))
+    (values event nil)))
+
+(defvar *event-loop-version* 0)
+
+(defun dequeue-event (display event)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (values next))
+  ;; Remove the current event from the event queue
+  (with-event-queue-internal (display)
+    (let ((next (reply-next event))
+	  (head (display-event-queue-head display)))
+      (declare (type (or null reply-buffer) next head))
+      (when (eq event (display-new-events display))
+	(setf (display-new-events display) next))
+      (cond ((eq event head)
+	     (threaded-dequeue (display-event-queue-head display)
+			       (display-event-queue-tail display)
+			       reply-next reply-buffer))
+	    ((null head)
+	     (setq next nil))
+	    (t
+	     (do* ((previous head current)
+		   (current (reply-next previous) (reply-next previous)))
+		  ((or (null current) (eq event current))
+		   (when (eq event current)
+		     (when (eq current (display-event-queue-tail display))
+		       (setf (display-event-queue-tail display) previous))
+		     (setf (reply-next previous) next)))
+	       (declare (type reply-buffer previous)
+			(type (or null reply-buffer) current)))))
+      next)))
+
+(defun event-loop-step-after
+       (display event discard-p current-event-symbol current-event-discarded-p-symbol
+	&optional aborted)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type boolean discard-p aborted)
+	   (type symbol current-event-symbol current-event-discarded-p-symbol))
+  (when (and discard-p
+	     (not aborted)
+	     (not (symbol-value current-event-discarded-p-symbol)))
+    (discard-current-event display))
+  (let ((next (reply-next event)))
+    (declare (type (or null reply-buffer) next))
+    (when (symbol-value current-event-discarded-p-symbol)
+      (setf (symbol-value current-event-discarded-p-symbol) nil)
+      (ecase *event-loop-version*
+	;; in version 0 discard-current-event dequeues the event.
+	(0 )
+	;; in version 1 event-loop-step-after dequeues the event.
+	(1 (setq next (dequeue-event display event))))
+      (deallocate-event event))
+    (setf (symbol-value current-event-symbol) next)))
+
+(defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
+  ;; Bind EVENT to the events for DISPLAY.
+  ;; This is the "GUTS" of process-event and event-case.
+  `(let ((*event-loop-version* 1)
+	 (.display. ,display)
+	 (.timeout. ,timeout)
+	 (.force-output-p. ,force-output-p)
+	 (.discard-p. ,discard-p))
+     (declare (type display .display.)
+	      (type (or null number) .timeout.)
+	      (type boolean .force-output-p. .discard-p.))
+     (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
+       (multiple-value-bind (.progv-vars. .progv-vals.
+			     .current-event-symbol. .current-event-discarded-p-symbol.)
+	   (event-loop-setup .display.)
+	 (declare (type list .progv-vars. .progv-vals.)
+		  (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
+	 (progv .progv-vars. .progv-vals.
+	   (loop
+	     (multiple-value-bind (.event. .eof-or-timeout.)
+		 (event-loop-step-before
+		   .display. .timeout. .force-output-p.
+		   .current-event-symbol.)
+	       (declare (type (or null reply-buffer) .event.))
+	       (when (null .event.) (return (values nil .eof-or-timeout.)))
+	       (let ((.aborted. t))
+		 (unwind-protect 
+		     (progn
+		       (let ((,event .event.))
+			 (declare (type reply-buffer ,event))
+			 ,@body)
+		       (setq .aborted. nil))
+		   (event-loop-step-after
+		     .display. .event. .discard-p.
+		     .current-event-symbol. .current-event-discarded-p-symbol.
+		     .aborted.))))))))))
+
+(defun discard-current-event (display)
+  ;; Discard the current event for DISPLAY.
+  ;; Returns NIL when the event queue is empty, else T.
+  ;; To ensure events aren't ignored, application code should only call
+  ;; this when throwing out of event-case or process-next-event, or from
+  ;; inside even-case, event-cond or process-event when :peek-p is T and
+  ;; :discard-p is NIL.
+  (declare (type display display)
+	   (values boolean))
+  (let* ((symbols (display-current-event-symbol display))
+	 (event
+	   (let ((current-event-symbol (first symbols)))
+	     (declare (type symbol current-event-symbol))
+	     (when (boundp current-event-symbol)
+	       (symbol-value current-event-symbol)))))
+    (declare (type list symbols)
+	     (type (or null reply-buffer) event))
+    (unless (null event)
+      (ecase *event-loop-version*
+	;; in version 0 discard-current-event dequeues the event.
+	(0 (setf (reply-next (the reply-buffer event))
+		 (dequeue-event display event)))
+	;; in version 1 event-loop-step-after dequeues the event.
+	(1 ))
+      ;; Set the discarded-p flag
+      (let ((current-event-discarded-p-symbol (second symbols)))
+	(declare (type symbol current-event-discarded-p-symbol))
+	(when (boundp current-event-discarded-p-symbol)
+	  (setf (symbol-value current-event-discarded-p-symbol) t)))
+      ;; Return whether the event queue is empty
+      (not (null (reply-next (the reply-buffer event)))))))
+
+;;
+;; PROCESS-EVENT
+;;
+(defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
+  ;; If force-output-p is true, first invokes display-force-output.  Invokes handler
+  ;; on each queued event until handler returns non-nil, and that returned object is
+  ;; then returned by process-event.  If peek-p is true, then the event is not
+  ;; removed from the queue.  If discard-p is true, then events for which handler
+  ;; returns nil are removed from the queue, otherwise they are left in place.  Hangs
+  ;; until non-nil is generated for some event, or for the specified timeout (in
+  ;; seconds, if given); however, it is acceptable for an implementation to wait only
+  ;; once on network data, and therefore timeout prematurely.  Returns nil on
+  ;; timeout.  If handler is a sequence, it is expected to contain handler functions
+  ;; specific to each event class; the event code is used to index the sequence,
+  ;; fetching the appropriate handler.  Handler is called with raw resource-ids, not
+  ;; with resource objects.  The arguments to the handler are described using declare-event.
+  ;;
+  ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
+  ;; from the queue (it is left in place), NIL means the event is removed.
+  
+  (declare (type display display)
+	   (type (or null number) timeout)
+	   (type boolean peek-p discard-p force-output-p))
+  (declare (type t handler)
+	   (downward-funarg #+Genera * #-Genera handler))
+  (event-loop (display event timeout force-output-p discard-p)
+    (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
+	   (event-decoder (and (index< event-code (length *event-handler-vector*))
+			       (svref *event-handler-vector* event-code))))
+      (declare (type array-index event-code)
+	       (type (or null function) event-decoder))
+      (if event-decoder
+	  (let ((event-handler (if (functionp handler)
+				   handler
+				   (and (type? handler 'sequence)
+					(< event-code (length handler))
+					(elt handler event-code)))))
+	    (if event-handler
+		(let ((result (funcall event-decoder display event event-handler)))
+		  (when result
+		    (unless peek-p
+		      (discard-current-event display))
+		    (return result)))
+	      (cerror "Ignore this event"
+		      "No handler for ~s event"
+		      (svref *event-key-vector* event-code))))
+	(cerror "Ignore this event"
+		"Server Error: event with unknown event code ~d received."
+		event-code)))))
+
+(defun make-event-handlers (&key (type 'array) default)
+  (declare (type t type)			;Sequence type specifier
+	   (type function default)
+	   (values sequence))			;Default handler for initial content
+  ;; Makes a handler sequence suitable for process-event
+  (make-sequence type *max-events* :initial-element default))
+   
+(defun event-handler (handlers event-key)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (values function))
+  ;; Accessor for a handler sequence
+  (elt handlers (position event-key *event-key-vector* :test #'eq)))
+
+(defun set-event-handler (handlers event-key handler)
+  (declare (type sequence handlers)
+	   (type event-key event-key)
+	   (type function handler)
+	   (values handler))
+  (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
+
+(defsetf event-handler set-event-handler)
+
+;;
+;; EVENT-CASE
+;; 
+
+(defmacro event-case ((&rest args) &body clauses)
+  ;; If force-output-p is true, first invokes display-force-output.  Executes the
+  ;; matching clause for each queued event until a clause returns non-nil, and that
+  ;; returned object is then returned by event-case.  If peek-p is true, then the
+  ;; event is not removed from the queue.  If discard-p is true, then events for
+  ;; which the clause returns nil are removed from the queue, otherwise they are left
+  ;; in place.  Hangs until non-nil is generated for some event, or for the specified
+  ;; timeout (in seconds, if given); however, it is acceptable for an implementation
+  ;; to wait only once on network data, and therefore timeout prematurely.  Returns
+  ;; nil on timeout.  In each clause, event-or-events is an event-key or a list of
+  ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
+  ;; (but only in the last clause).  The keys are not evaluated, and it is an error
+  ;; for the same key to appear in more than one clause.  Args is the list of event
+  ;; components of interest; corresponding values (if any) are bound to variables
+  ;; with these names (i.e., the args are variable names, not keywords, the keywords
+  ;; are derived from the variable names).  An arg can also be a (keyword var) form,
+  ;; as for keyword args in a lambda lists.  If no t/otherwise clause appears, it is
+  ;; equivalent to having one that returns nil.
+  (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
+		   (event-or-events ((&rest args) |...|) &body body) |...|))
+  ;; Event-case is just event-cond with the whole body in the test-form
+  `(event-cond ,args
+	       ,@(mapcar
+		   #'(lambda (clause)
+		       `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
+		   clauses)))
+
+;;
+;; EVENT-COND
+;; 
+
+(defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
+		      &body clauses)
+  ;; The clauses of event-cond are of the form:
+  ;; (event-or-events binding-list test-form . body-forms)
+  ;;
+  ;; EVENT-OR-EVENTS	event-key or a list of event-keys (but they
+  ;;			need not be typed as keywords) or the symbol t
+  ;;			or otherwise (but only in the last clause).  If
+  ;;			no t/otherwise clause appears, it is equivalent
+  ;;			to having one that returns nil.  The keys are
+  ;;			not evaluated, and it is an error for the same
+  ;;			key to appear in more than one clause.
+  ;;
+  ;; BINDING-LIST	The list of event components of interest.
+  ;;			corresponding values (if any) are bound to
+  ;;			variables with these names (i.e., the binding-list
+  ;;			has variable names, not keywords, the keywords are
+  ;;			derived from the variable names).  An arg can also
+  ;;			be a (keyword var) form, as for keyword args in a
+  ;;			lambda list.
+  ;;
+  ;; The matching TEST-FORM for each queued event is executed until a
+  ;; clause's test-form returns non-nil.  Then the BODY-FORMS are
+  ;; evaluated, returning the (possibly multiple) values of the last
+  ;; form from event-cond.  If there are no body-forms then, if the
+  ;; test-form is non-nil, the value of the test-form is returned as a
+  ;; single value.
+  ;;
+  ;; Options:
+  ;; FORCE-OUTPUT-P	When true, first invoke display-force-output if no
+  ;;		  	input is pending.
+  ;;
+  ;; PEEK-P		When true, then the event is not removed from the queue.
+  ;;
+  ;; DISCARD-P		When true, then events for which the clause returns nil
+  ;; 			are removed from the queue, otherwise they are left in place.
+  ;;
+  ;; TIMEOUT		If NIL, hang until non-nil is generated for some event's
+  ;;			test-form. Otherwise return NIL after TIMEOUT seconds have
+  ;;			elapsed.
+  ;;
+  (declare (arglist (display &key timeout peek-p discard-p force-output-p)
+		   (event-or-events (&rest args) test-form &body body) |...|))
+  (let ((event (gensym))
+	(disp (gensym))
+	(peek (gensym)))
+    `(let ((,disp ,display)
+	   (,peek ,peek-p))
+       (declare (type display ,disp))
+       (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
+	 (event-dispatch (,disp ,event ,peek) ,@clauses)))))
+
+(defun get-event-code (event)
+  ;; Returns the event code given an event-key
+  (declare (type event-key event))
+  (declare (values card8))
+  (or (get event 'event-code)
+      (x-type-error event 'event-key)))
+
+(defun universal-event-get-macro (display event-key variable)
+  (getf
+    `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
+	       (the card8 (logand 127 (read-card8 0))) :send-event-p
+	       (the boolean (logbitp 7 (read-card8 0))))
+    variable))
+
+(defmacro event-dispatch ((display event peek-p) &body clauses)
+  ;; Helper macro for event-case
+  ;; CLAUSES are of the form:
+  ;; (event-or-events binding-list test-form . body-forms)
+  (let ((event-key (gensym))
+	(all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
+    `(reading-event (,event)
+       (let ((,event-key (svref *event-key-vector* (event-code ,event))))
+	 (case ,event-key
+	   ,@(mapcar
+	       #'(lambda (clause)		; Translate event-cond clause to case clause
+		   (let* ((events (first clause))
+			  (arglist (second clause))
+			  (test-form (third clause))
+			  (body-forms (cdddr clause)))
+		     (flet ((event-clause (display peek-p first-form rest-of-forms)
+			      (if rest-of-forms
+				  `(when ,first-form
+				     (unless ,peek-p (discard-current-event ,display))
+				     (return (progn ,@rest-of-forms)))
+				;; No body forms, return the result of the test form
+				(let ((result (gensym)))
+				  `(let ((,result ,first-form))
+				     (when ,result
+				       (unless ,peek-p (discard-current-event ,display))
+				       (return ,result)))))))
+
+		       (if (member events '(otherwise t))
+			   ;; code for OTHERWISE clause.
+			   ;; Find all events NOT used by other clauses
+			   (let ((keys (do ((i 0 (1+ i))
+					    (key nil)
+					    (result nil))
+					   ((>= i *max-events*) result)
+					 (setq key (svref *event-key-vector* i))
+					 (when (and key (zerop (aref all-events i)))
+					   (push key result)))))
+			     `(otherwise
+				(binding-event-values
+				  (,display ,event-key ,(or keys :universal) ,@arglist)
+				  ,(event-clause display peek-p test-form body-forms))))
+
+			 ;; Code for normal clauses
+			 (let (true-events) ;; canonicalize event-names
+			   (if (consp events)
+			       (progn
+				 (setq true-events (mapcar #'canonicalize-event-name events))
+				 (dolist (event true-events)
+				   (setf (aref all-events (get-event-code event)) 1)))
+			     (setf true-events (canonicalize-event-name events)
+				   (aref all-events (get-event-code true-events)) 1))
+			   `(,true-events
+			     (binding-event-values
+			       (,display ,event-key ,true-events ,@arglist)
+			       ,(event-clause display peek-p test-form body-forms))))))))
+	       clauses))))))
+
+(defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
+  ;; Execute BODY with the variables in VALUE-LIST bound to components of the
+  ;; EVENT-KEYS events.
+  (unless (consp event-keys) (setq event-keys (list event-keys)))
+  (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
+	 (var-symbol (var) (if (consp var) (second var) var)))
+    ;; VARS is an alist of:
+    ;;  (component-key ((event-key event-key ...) . extraction-code)
+    ;;		       ((event-key event-key ...) . extraction-code) ...)
+    ;; There should probably be accessor macros for this, instead of things like cdadr.
+    (let ((vars (mapcar #'(lambda (var) (list var)) value-list))
+	  (multiple-p nil))
+      ;; Fill in the VARS alist with event-keys and extraction-code
+      (do ((keys event-keys (cdr keys))
+	   (temp nil))
+	  ((endp keys))
+	(let* ((key (car keys))
+	       (binder (case key
+			 (:universal #'universal-event-get-macro)
+			 (otherwise (svref *event-macro-vector* (get-event-code key))))))
+	  (dolist (var vars)
+	    (let ((code (funcall binder display event-key (var-key (car var)))))
+	      (unless code (warn "~a isn't a component of the ~s event"
+				 (var-key (car var)) key))
+	      (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
+		  (push key (caar temp))
+		(push `((,key) . ,code) (cdr var)))))))
+      ;; Bind all the values
+      `(let ,(mapcar #'(lambda (var)
+			 (if (cddr var) ;; if more than one binding form
+			     (progn (setq multiple-p t)
+				    (var-symbol (car var)))
+			   (list (var-symbol (car var)) (cdadr var))))
+		     vars)
+	 ;; When some values come from different places, generate code to set them
+	 ,(when multiple-p
+	    `(case ,event-key
+	       ,@(do ((keys event-keys (cdr keys))
+		      (clauses nil) ;; alist of (event-keys bindings)
+		      (clause nil nil)
+		      (temp))
+		     ((endp keys)
+		      (dolist (clause clauses)
+			(unless (cdar clause) ;; Atomize single element lists
+			  (setf (car clause) (caar clause))))
+		      clauses)
+		   ;; Gather up all the bindings associated with (car keys)
+		   (dolist (var vars)
+		     (when (cddr var) ;; when more than one binding form
+		       (dolist (events (cdr var))
+			 (when (member (car keys) (car events))
+			   ;; Optimize for event-window being the same as some other binding
+			   (if (setq temp (member (cdr events) clause
+						  :key #'caddr
+						  :test #'equal))
+			       (setq clause
+				     (nconc clause `((setq ,(car var) ,(second (car temp))))))
+			     (push `(setq ,(car var) ,(cdr events)) clause))))))
+		   ;; Merge bindings for (car keys) with other bindings
+		   (when clause
+		     (if (setq temp (member clause clauses :key #'cdr :test #'equal))
+			 (push (car keys) (caar temp))
+		       (push `((,(car keys)) . ,clause) clauses))))))
+	 ,@body))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Error Handling
+;;;-----------------------------------------------------------------------------
+
+(eval-when (eval compile load)
+(defparameter
+  *xerror-vector*
+  '#(unknown-error
+     request-error				; 1  bad request code
+     value-error				; 2  integer parameter out of range
+     window-error				; 3  parameter not a Window
+     pixmap-error				; 4  parameter not a Pixmap
+     atom-error					; 5  parameter not an Atom
+     cursor-error				; 6  parameter not a Cursor
+     font-error					; 7  parameter not a Font
+     match-error				; 8  parameter mismatch
+     drawable-error				; 9  parameter not a Pixmap or Window
+     access-error				; 10 attempt to access private resource"
+     alloc-error				; 11 insufficient resources
+     colormap-error				; 12 no such colormap
+     gcontext-error				; 13 parameter not a GContext
+     id-choice-error				; 14 invalid resource ID for this connection
+     name-error					; 15 font or color name does not exist
+     length-error				; 16 request length incorrect;
+						;    internal Xlib error
+     implementation-error			; 17 server is defective
+     ))
+)
+
+(defun make-error (display event asynchronous)
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type boolean asynchronous))
+  (reading-event (event)
+    (let* ((error-code (read-card8 1))
+	   (error-key (get-error-key display error-code))
+	   (error-decode-function (get error-key 'error-decode-function))
+	   (params (funcall error-decode-function display event)))
+      (list* error-code error-key
+	     :asynchronous asynchronous :current-sequence (display-request-number display)
+	     params))))
+
+(defun report-error (display error-code error-key &rest params)
+  (declare (type display display)
+	   (dynamic-extent params))
+  ;; All errors (synchronous and asynchronous) are processed by calling
+  ;; an error handler in the display.  The handler is called with the display
+  ;; as the first argument and the error-key as its second argument. If handler is
+  ;; an array it is expected to contain handler functions specific to
+  ;; each error; the error code is used to index the array, fetching the
+  ;; appropriate handler. Any results returned by the handler are ignored;;
+  ;; it is assumed the handler either takes care of the error completely,
+  ;; or else signals. For all core errors, additional keyword/value argument
+  ;; pairs are:
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;;    :current-sequence integer
+  ;;    :asynchronous (member t nil)
+  ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
+  ;; errors another pair is:
+  ;;    :resource-id integer
+  ;; For :atom errors, another pair is:
+  ;;    :atom-id integer
+  ;; For :value errors, another pair is:
+  ;;    :value integer
+  (let* ((handler (display-error-handler display))
+	 (handler-function
+	   (if (type? handler 'sequence)
+	       (elt handler error-code)
+	     handler)))
+    (apply handler-function display error-key params)))
+
+(defun request-name (code &optional display)
+  (if (< code (length *request-names*))
+      (svref *request-names* code)
+    (dolist (extension (and display (display-extension-alist display)) "unknown")
+      (when (= code (second extension))
+	(return (first extension))))))
+
+#-(or ansi-common-lisp excl lcl3.0)
+(define-condition request-error (x-error)
+  (display
+   error-key
+   major
+   minor
+   sequence
+   current-sequence
+   asynchronous)
+  (:report report-request-error))
+
+(defun report-request-error (condition stream)
+  (let ((error-key (request-error-error-key condition))
+	(asynchronous (request-error-asynchronous condition))
+	(major (request-error-major condition))
+	(minor (request-error-minor condition))
+	(sequence (request-error-sequence condition))
+	(current-sequence (request-error-current-sequence condition)))		   
+    (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
+	    asynchronous error-key (= sequence current-sequence)
+	    sequence current-sequence major minor
+	    (request-name major (request-error-display condition)))))
+
+;; Since the :report arg is evaluated as (function report-request-error) the
+;; define-condition must come after the function definition.
+#+(or ansi-common-lisp excl lcl3.0)
+(define-condition request-error (x-error)
+  (display
+   error-key
+   major
+   minor
+   sequence
+   current-sequence
+   asynchronous)
+  (:report report-request-error))
+
+(define-condition resource-error (request-error)
+  (resource-id)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " ID #x~x" (resource-error-resource-id condition)))))  
+
+(define-condition unknown-error (request-error)
+  (error-code)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Error Code ~d." (unknown-error-error-code condition)))))
+
+(define-condition access-error (request-error))
+
+(define-condition alloc-error (request-error))
+
+(define-condition atom-error (request-error)
+  (atom-id)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
+
+(define-condition colormap-error (resource-error))
+
+(define-condition cursor-error (resource-error))
+
+(define-condition drawable-error (resource-error))
+
+(define-condition font-error (resource-error))
+
+(define-condition gcontext-error (resource-error))
+
+(define-condition id-choice-error (resource-error))
+
+(define-condition illegal-request-error (request-error))
+
+(define-condition length-error (request-error))
+
+(define-condition match-error (request-error))
+
+(define-condition name-error (request-error))
+
+(define-condition pixmap-error (resource-error))
+
+(define-condition value-error (request-error)
+  (value)
+  (:report (lambda (condition stream)
+	     (report-request-error condition stream)
+	     (format stream " Value ~d." (value-error-value condition)))))
+
+(define-condition window-error (resource-error))
+
+(define-condition implementation-error (request-error))
+
+;;-----------------------------------------------------------------------------
+;; Internal error conditions signaled by CLX
+
+(define-condition x-type-error (type-error)
+  (type-string)
+  (:report (lambda (condition stream)
+	     (format stream "~s isn't a ~a"
+		     (type-error-datum condition)
+		     (or (x-type-error-type-string condition)
+			 (type-error-expected-type condition))))))
+
+(define-condition closed-display (x-error)
+  (display)
+  (:report (lambda (condition stream)
+	     (format stream "Attempt to use closed display ~s"
+		     (closed-display-display condition)))))
+
+(define-condition lookup-error (x-error)
+  (id display type object)
+  (:report (lambda (condition stream)
+	     (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
+		     (lookup-error-id condition)
+		     (lookup-error-display condition)
+		     (lookup-error-type condition)
+		     (lookup-error-object condition)))))  
+
+(define-condition connection-failure (x-error)
+  (major-version
+   minor-version
+   host
+   display
+   reason)
+  (:report (lambda (condition stream)
+	     (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
+		     (connection-failure-major-version condition)
+		     (connection-failure-minor-version condition)
+		     (connection-failure-host condition)
+		     (connection-failure-display condition)
+		     (connection-failure-reason condition)))))
+  
+(define-condition reply-length-error (x-error)
+  (reply-length
+   expected-length
+   display)
+  (:report (lambda (condition stream)
+	     (format stream "Reply length was ~d when ~d words were expected for display ~s"
+		     (reply-length-error-reply-length condition)
+		     (reply-length-error-expected-length condition)
+		     (reply-length-error-display condition)))))  
+
+(define-condition reply-timeout (x-error)
+  (timeout
+   display)
+  (:report (lambda (condition stream)
+	     (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
+		     (reply-timeout-timeout condition)
+		     (reply-timeout-display condition)))))  
+
+(define-condition sequence-error (x-error)
+  (display
+   req-sequence
+   msg-sequence)
+  (:report (lambda (condition stream)
+	     (format stream "Reply out of sequence for display ~s.~%  Expected ~d, Got ~d"
+		     (sequence-error-display condition)
+		     (sequence-error-req-sequence condition)
+		     (sequence-error-msg-sequence condition)))))  
+
+(define-condition unexpected-reply (x-error)
+  (display
+   msg-sequence
+   req-sequence
+   length)
+  (:report (lambda (condition stream)
+	     (format stream "Display ~s received a server reply when none was expected.~@
+		             Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
+		  (unexpected-reply-display condition)
+		  (unexpected-reply-req-sequence condition)
+		  (unexpected-reply-msg-sequence condition)
+		  (unexpected-reply-length condition)))))
+
+(define-condition missing-parameter (x-error)
+  (parameter)
+  (:report (lambda (condition stream)
+	     (let ((parm (missing-parameter-parameter condition)))
+	       (if (consp parm)
+		   (format stream "One or more of the required parameters ~a is missing."
+			   parm)
+		 (format stream "Required parameter ~a is missing or null." parm))))))
+
+;; This can be signalled anywhere a pseudo font access fails.
+(define-condition invalid-font (x-error)
+  (font)
+  (:report (lambda (condition stream)
+	     (format stream "Can't access font ~s" (invalid-font-font condition)))))
+
+(define-condition device-busy (x-error)
+  (display)
+  (:report (lambda (condition stream)
+	     (format stream "Device busy for display ~s"
+		     (device-busy-display condition)))))
+
+(define-condition unimplemented-event (x-error)
+  (display
+   event-code)
+  (:report (lambda (condition stream)
+	     (format stream "Event code ~d not implemented for display ~s"
+		     (unimplemented-event-event-code condition)
+		     (unimplemented-event-display condition)))))
+
+(define-condition undefined-event (x-error)
+  (display
+   event-name)
+  (:report (lambda (condition stream)
+	     (format stream "Event code ~d undefined for display ~s"
+		     (undefined-event-event-name condition)
+		     (undefined-event-display condition)))))
+
+(define-condition absent-extension (x-error)
+  (name display)
+  (:report (lambda (condition stream)
+	     (format stream "Extension ~a isn't defined for display ~s"
+		     (absent-extension-name condition)
+		     (absent-extension-display condition)))))
+
+(define-condition inconsistent-parameters (x-error)
+  (parameters)
+  (:report (lambda (condition stream)
+	     (format stream "inconsistent-parameters:~{ ~s~}"
+		     (inconsistent-parameters-parameters condition)))))
+
+(defun get-error-key (display error-code)
+  (declare (type display display)
+	   (type array-index error-code))
+  ;; Return the error-key associated with error-code
+  (if (< error-code (length *xerror-vector*))
+      (svref *xerror-vector* error-code)
+    ;; Search the extensions for the error
+    (dolist (entry (display-extension-alist display) 'unknown-error)
+      (let* ((event-name (first entry))
+	     (first-error (fourth entry))
+	     (errors (third (assoc event-name *extensions*))))
+	(declare (type keyword event-name)
+		 (type array-index first-error)
+		 (type list errors))
+	(when (and errors
+		   (index<= first-error error-code
+			    (index+ first-error (index- (length errors) 1))))
+	  (return (nth (index- error-code first-error) errors)))))))
+
+(defmacro define-error (error-key function)
+  ;; Associate a function with ERROR-KEY which will be called with
+  ;; parameters DISPLAY and REPLY-BUFFER and
+  ;; returns a plist of keyword/value pairs which will be passed on
+  ;; to the error handler.  A compiler warning is printed when
+  ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
+  ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
+  ;;       macros for getting error fields. See DECODE-CORE-ERROR for
+  ;;       an example.
+  (declare (type symbol error-key)
+	   (type function function))
+  ;; First ensure the name is for a declared extension
+  (unless (or (find error-key *xerror-vector*)
+	      (dolist (extension *extensions*)
+		(when (member error-key (third extension))
+		  (return t))))
+    (x-type-error error-key 'error-key))
+  `(setf (get ',error-key 'error-decode-function) (function ,function)))
+
+;; All core errors use this, so we make it available to extensions.
+(defun decode-core-error (display event &optional arg)
+  ;; All core errors have the following keyword/argument pairs:
+  ;;    :major integer
+  ;;    :minor integer
+  ;;    :sequence integer
+  ;; In addition, many have an additional argument that comes from the
+  ;; same place in the event, but is named differently.  When the ARG
+  ;; argument is specified, the keyword ARG with card32 value starting
+  ;; at byte 4 of the event is returned with the other keyword/argument
+  ;; pairs.
+  (declare (type display display)
+	   (type reply-buffer event)
+	   (type (or null keyword) arg))
+  (declare (values keyword/arg-plist))
+  display
+  (reading-event (event)
+    (let* ((sequence (read-card16 2))
+	   (minor-code (read-card16 8))
+	   (major-code (read-card8 10))
+	   (result (list :major major-code
+			 :minor minor-code
+			 :sequence sequence)))
+      (when arg
+	(setq result (list* arg (read-card32 4) result)))
+      result)))
+
+(defun decode-resource-error (display event)
+  (decode-core-error display event :resource-id))
+
+(define-error unknown-error
+  (lambda (display event)
+    (list* :error-code (aref (reply-ibuf8 event) 1)
+	   (decode-core-error display event))))
+
+(define-error request-error decode-core-error)		; 1  bad request code
+
+(define-error value-error				; 2  integer parameter out of range
+  (lambda (display event)
+    (decode-core-error display event :value)))
+
+(define-error window-error decode-resource-error)	; 3  parameter not a Window
+
+(define-error pixmap-error decode-resource-error)	; 4  parameter not a Pixmap
+
+(define-error atom-error				; 5  parameter not an Atom
+  (lambda (display event)
+    (decode-core-error display event :atom-id)))
+
+(define-error cursor-error decode-resource-error)	; 6  parameter not a Cursor
+
+(define-error font-error decode-resource-error)		; 7  parameter not a Font
+
+(define-error match-error decode-core-error)		; 8  parameter mismatch
+
+(define-error drawable-error decode-resource-error)	; 9  parameter not a Pixmap or Window
+
+(define-error access-error decode-core-error)		; 10 attempt to access private resource"
+
+(define-error alloc-error decode-core-error)		; 11 insufficient resources
+
+(define-error colormap-error decode-resource-error)	; 12 no such colormap
+
+(define-error gcontext-error decode-resource-error)	; 13 parameter not a GContext
+
+(define-error id-choice-error decode-resource-error)	; 14 invalid resource ID for this connection
+
+(define-error name-error decode-core-error)		; 15 font or color name does not exist
+
+(define-error length-error decode-core-error)		; 16 request length incorrect;
+							;    internal Xlib error
+
+(define-error implementation-error decode-core-error)	; 17 server is defective
diff --git a/clx/manager.lisp b/clx/manager.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..96832df3b2116c8af8c4b51758ceb2ee24a8889e
--- /dev/null
+++ b/clx/manager.lisp
@@ -0,0 +1,851 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;;; Window Manager Property functions
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(wm-name		;These are all setf'able accessor functions
+	  wm-icon-name
+	  wm-client-machine
+	  wm-command
+	  wm-hints
+	  wm-normal-hints
+	  icon-sizes
+	  wm-protocols
+	  wm-colormap-windows
+
+	  wm-size-hints
+	  wm-size-hints-p
+	  make-wm-size-hints
+	  wm-size-hints-user-specified-position-p
+	  wm-size-hints-user-specified-size-p
+	  wm-size-hints-min-width
+	  wm-size-hints-min-height
+	  wm-size-hints-max-width
+	  wm-size-hints-max-height
+	  wm-size-hints-width-inc
+	  wm-size-hints-height-inc
+	  wm-size-hints-min-aspect
+	  wm-size-hints-max-aspect
+	  wm-size-hints-base-width
+	  wm-size-hints-base-height
+	  wm-size-hints-win-gravity
+
+	  wm-hints
+	  wm-hints-p
+	  make-wm-hints
+	  wm-hints-input
+	  wm-hints-initial-state
+	  wm-hints-icon-pixmap
+	  wm-hints-icon-window
+	  wm-hints-icon-x
+	  wm-hints-icon-y
+	  wm-hints-icon-mask
+	  wm-hints-window-group
+	  wm-hints-flags
+
+	  transient-for
+
+	  set-wm-properties
+	  iconify-window
+	  withdraw-window
+
+	  get-wm-class
+	  set-wm-class
+	  rgb-colormaps
+
+	  cut-buffer   ;; Setf'able
+	  rotate-cut-buffers
+
+	  ;; Obsolete
+	  wm-zoom-hints
+	  wm-size-hints-x
+	  wm-size-hints-y
+	  wm-size-hints-width
+	  wm-size-hints-height
+	  set-standard-properties
+	  get-standard-colormap
+	  set-standard-colormap
+	  ))
+
+(defun wm-name (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
+
+(defsetf wm-name (window) (name)
+  (declare (type window window))
+  (declare (values string))
+  `(set-string-property ,window :WM_NAME ,name))
+
+(defun set-string-property (window property string)
+  (declare (type window window)
+	   (type keyword property)
+	   (type stringable string))
+  (change-property window property (string string) :STRING 8 :transform #'char->card8)
+  string)
+
+(defun wm-icon-name (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_ICON_NAME :type :STRING
+		:result-type 'string :transform #'card8->char))
+
+(defsetf wm-icon-name (window) (name)
+  `(set-string-property ,window :WM_ICON_NAME ,name))
+
+(defun wm-client-machine (window)
+  (declare (type window window))
+  (declare (values string))
+  (get-property window :WM_CLIENT_MACHINE :type :STRING
+		:result-type 'string :transform #'card8->char))
+
+(defsetf wm-client-machine (window) (name)
+  `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
+
+(defun get-wm-class (window)
+  (declare (type window window))
+  (declare (values (or null name-string) (or null class-string)))
+  (let ((value (get-property window :WM_CLASS :type :STRING
+			     :result-type 'string :transform #'card8->char)))
+    (declare (type (or null string) value))
+    (when value
+      (let* ((name-len (position #.(card8->char 0) (the string value)))
+	     (name (subseq (the string value) 0 name-len))
+	     (class (subseq (the string value) (1+ name-len) (1- (length value)))))
+	(values (and (plusp (length name)) name)
+		(and (plusp (length class)) class))))))
+
+(defun set-wm-class (window resource-name resource-class)
+  (declare (type window window)
+	   (type (or null stringable) resource-name resource-class))
+  (set-string-property window :WM_CLASS
+		       (concatenate 'string
+				    (string (or resource-name ""))
+				    #.(make-string 1 :initial-element (card8->char 0))
+				    (string (or resource-class ""))
+				    #.(make-string 1 :initial-element (card8->char 0))))
+  (values))
+
+(defun wm-command (window)
+  ;; Returns a list whose car is the command and 
+  ;; whose cdr is the list of arguments
+  (declare (type window window))
+  (declare (values list))
+  (do* ((command-string (get-property window :WM_COMMAND :type :STRING
+				      :result-type 'string :transform #'card8->char))
+	(command nil)
+	(start 0 (1+ end))
+	(end 0)
+	(len (length command-string)))
+       ((>= start len) (nreverse command))
+    (setq end (position #.(card8->char 0) command-string :start start))
+    (push (subseq command-string start end) command)))
+
+(defsetf wm-command set-wm-command)
+(defun set-wm-command (window command)
+  ;; Uses PRIN1 to a string-stream with the following bindings:
+  ;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
+  ;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
+  ;; each element of command is seperated with NULL characters.
+  ;; This enables (mapcar #'read-from-string (wm-command window))
+  ;; to recover a lisp command.
+  (declare (type window window)
+	   (type list command))
+  (set-string-property window :WM_COMMAND
+		       (with-output-to-string (stream)
+			 (let ((*print-length* nil)
+			       (*print-level* nil)
+			       (*print-radix* nil)
+			       (*print-base* 10.)
+			       (*print-array* t)
+			       (*package* (find-package 'lisp))
+			       #+ti (ticl:*print-structure* t))
+			   (dolist (c command)
+			     (prin1 c stream)
+			     (write-char #.(card8->char 0) stream)))))
+  command)
+
+;;-----------------------------------------------------------------------------
+;; WM_HINTS
+
+(def-clx-class (wm-hints)
+  (input nil :type (or null (member :off :on)))
+  (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
+  (icon-pixmap nil :type (or null pixmap))
+  (icon-window nil :type (or null window))
+  (icon-x nil :type (or null card16))
+  (icon-y nil :type (or null card16))
+  (icon-mask nil :type (or null pixmap))
+  (window-group nil :type (or null resource-id))
+  (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
+  ;; may be extended in the future
+  )
+
+(defun wm-hints (window)
+  (declare (type window window))
+  (declare (values wm-hints))
+  (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
+    (when prop
+      (decode-wm-hints prop (window-display window)))))
+
+(defsetf wm-hints set-wm-hints)
+(defun set-wm-hints (window wm-hints)
+  (declare (type window window)
+	   (type wm-hints wm-hints))
+  (declare (values wm-hints))
+  (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
+  wm-hints)
+
+(defun decode-wm-hints (vector display)
+  (declare (type (simple-vector 9) vector)
+	   (type display display))
+  (declare (values wm-hints))
+  (let ((input-hint 0)
+	(state-hint 1)
+	(icon-pixmap-hint 2)
+	(icon-window-hint 3)
+	(icon-position-hint 4)
+	(icon-mask-hint 5)
+	(window-group-hint 6))
+    (let ((flags (aref vector 0))
+	  (hints (make-wm-hints))
+	  (%buffer display))
+      (declare (type card32 flags)
+	       (type wm-hints hints)
+	       (type display %buffer))
+      (setf (wm-hints-flags hints) flags)
+      (when (logbitp input-hint flags)
+	(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
+      (when (logbitp state-hint flags)
+	(setf (wm-hints-initial-state hints)
+	      (decode-type (member :dont-care :normal :zoom :iconic :inactive)
+			   (aref vector 2))))
+      (when (logbitp icon-pixmap-hint flags)
+	(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
+      (when (logbitp icon-window-hint flags)
+	(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
+      (when (logbitp icon-position-hint flags)
+	(setf (wm-hints-icon-x hints) (aref vector 5)
+	      (wm-hints-icon-y hints) (aref vector 6)))
+      (when (logbitp icon-mask-hint flags)
+	(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
+      (when (and (logbitp window-group-hint flags) (> (length vector) 7))
+	(setf (wm-hints-window-group hints) (aref vector 8)))
+      hints)))
+
+
+(defun encode-wm-hints (wm-hints)
+  (declare (type wm-hints wm-hints))
+  (declare (values simple-vector))
+  (let ((input-hint         #b1)
+	(state-hint         #b10)
+	(icon-pixmap-hint   #b100)
+	(icon-window-hint   #b1000)
+	(icon-position-hint #b10000)
+	(icon-mask-hint     #b100000)
+	(window-group-hint  #b1000000)
+	(mask               #b1111111)
+	)
+    (let ((vector (make-array 9 :initial-element 0))
+	  (flags 0))
+      (declare (type (simple-vector 9) vector)
+	       (type card16 flags))
+      (when (wm-hints-input wm-hints)
+	(setf flags input-hint
+	      (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
+      (when (wm-hints-initial-state wm-hints)
+	(setf flags (logior flags state-hint)
+	      (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
+					   (wm-hints-initial-state wm-hints))))
+      (when (wm-hints-icon-pixmap wm-hints)
+	(setf flags (logior flags icon-pixmap-hint)
+	      (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
+      (when (wm-hints-icon-window wm-hints)
+	(setf flags (logior flags icon-window-hint)
+	      (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
+      (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
+	(setf flags (logior flags icon-position-hint)
+	      (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
+	      (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
+      (when (wm-hints-icon-mask wm-hints)
+	(setf flags (logior flags icon-mask-hint)
+	      (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
+      (when (wm-hints-window-group wm-hints)
+	(setf flags (logior flags window-group-hint)
+	      (aref vector 8) (wm-hints-window-group wm-hints)))
+      (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
+      vector)))
+
+;;-----------------------------------------------------------------------------
+;; WM_SIZE_HINTS
+
+(def-clx-class (wm-size-hints)
+  ;; Defaulted T to put the burden of remembering these on widget programmers.
+  (user-specified-position-p nil :type boolean) ;; True when user specified x y
+  (user-specified-size-p nil :type boolean)     ;; True when user specified width height
+  (x nil :type (or null int16))			;; Obsolete
+  (y nil :type (or null int16))			;; Obsolete
+  (width nil :type (or null card16))		;; Obsolete
+  (height nil :type (or null card16))		;; Obsolete
+  (min-width nil :type (or null card16))
+  (min-height nil :type (or null card16))
+  (max-width nil :type (or null card16))
+  (max-height nil :type (or null card16))
+  (width-inc nil :type (or null card16))
+  (height-inc nil :type (or null card16))
+  (min-aspect nil :type (or null number))
+  (max-aspect nil :type (or null number))
+  (base-width nil :type (or null card16))
+  (base-height nil :type (or null card16))
+  (win-gravity nil :type (or null win-gravity)))
+
+
+(defun wm-normal-hints (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
+
+(defsetf wm-normal-hints set-wm-normal-hints)
+(defun set-wm-normal-hints (window hints)
+  (declare (type window window)
+	   (type wm-size-hints hints))
+  (declare (values wm-size-hints))
+  (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
+  hints)
+
+;;; OBSOLETE
+(defun wm-zoom-hints (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
+
+;;; OBSOLETE
+(defsetf wm-zoom-hints set-wm-zoom-hints)
+;;; OBSOLETE
+(defun set-wm-zoom-hints (window hints)
+  (declare (type window window)
+	   (type wm-size-hints hints))
+  (declare (values wm-size-hints))
+  (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
+  hints)
+
+(defun decode-wm-size-hints (vector)
+  (declare (type (or null (simple-vector *)) vector))
+  (declare (values (or null wm-size-hints)))
+  (when vector
+    (let ((usposition 0)		;User Specified position
+	  (ussize 1)			;User Specified size
+	  (pposition 2)			;Program specified position
+	  (psize 3)			;Program specified size
+	  (pminsize 4)			;Program specified minimum size
+	  (pmaxsize 5)			;Program specified maximum size
+	  (presizeinc 6)		;Program specified resize increments
+	  (paspect 7)			;Program specfied min and max aspect ratios
+	  (pbasesize 8)			;Program specified base size
+	  (pwingravity 9)		;Program specified window gravity
+	  )
+      (let ((flags (aref vector 0))
+	    (hints (make-wm-size-hints)))
+	(declare (type card16 flags)
+		 (type wm-size-hints hints))
+	(when (or (logbitp usposition flags)
+		  (logbitp pposition flags))
+	  (setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags)
+		(wm-size-hints-x hints) (aref vector 1)
+		(wm-size-hints-y hints) (aref vector 2)))
+	(when (or (logbitp ussize flags)
+		  (logbitp psize flags))
+	  (setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags)
+		(wm-size-hints-width hints) (aref vector 3)
+		(wm-size-hints-height hints) (aref vector 4)))
+	(when (logbitp pminsize flags)
+	  (setf (wm-size-hints-min-width hints) (aref vector 5)
+		(wm-size-hints-min-height hints) (aref vector 6)))
+	(when (logbitp pmaxsize flags)
+	  (setf (wm-size-hints-max-width hints) (aref vector 7)
+		(wm-size-hints-max-height hints) (aref vector 8)))
+	(when (logbitp presizeinc flags)
+	  (setf (wm-size-hints-width-inc hints) (aref vector 9)
+		(wm-size-hints-height-inc hints) (aref vector 10)))
+  	(when (logbitp paspect flags)
+ 	  (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
+ 		(wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
+ 	(when (> (length vector) 15)
+ 	  ;; This test is for backwards compatibility since old Xlib programs
+ 	  ;; can set a size-hints structure that is too small.  See ICCCM.
+  	  (when (logbitp pbasesize flags)
+  	    (setf (wm-size-hints-base-width hints) (aref vector 15)
+  		  (wm-size-hints-base-height hints) (aref vector 16)))
+  	  (when (logbitp pwingravity flags)
+  	    (setf (wm-size-hints-win-gravity hints)
+ 	      (decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
+	hints))))
+
+(defun encode-wm-size-hints (hints)
+  (declare (type wm-size-hints hints))
+  (declare (values simple-vector))
+  (let ((usposition  #b1)		;User Specified position
+	(ussize      #b10)		;User Specified size
+	(pposition   #b100)		;Program specified position
+	(psize       #b1000)		;Program specified size
+	(pminsize    #b10000)		;Program specified minimum size
+	(pmaxsize    #b100000)		;Program specified maximum size
+	(presizeinc  #b1000000)		;Program specified resize increments
+	(paspect     #b10000000)	;Program specfied min and max aspect ratios
+	(pbasesize   #b100000000)	;Program specfied base size
+	(pwingravity #b1000000000)	;Program specfied window gravity
+	)
+    (let ((vector (make-array 18 :initial-element 0))
+	  (flags 0))
+      (declare (type (simple-vector 18) vector)
+	       (type card16 flags))
+      (when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
+	(setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition))
+	(setf (aref vector 1) (wm-size-hints-x hints)
+	      (aref vector 2) (wm-size-hints-y hints)))
+      (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
+	(setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize))
+	      (aref vector 3) (wm-size-hints-width hints)
+	      (aref vector 4) (wm-size-hints-height hints)))
+      
+      (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
+	(setf flags (logior flags pminsize)
+	      (aref vector 5) (wm-size-hints-min-width hints)
+	      (aref vector 6) (wm-size-hints-min-height hints)))
+      (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
+	(setf flags (logior flags pmaxsize)
+	      (aref vector 7) (wm-size-hints-max-width hints)
+	      (aref vector 8) (wm-size-hints-max-height hints)))
+      (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
+	(setf flags (logior flags presizeinc)
+	      (aref vector 9) (wm-size-hints-width-inc hints)
+	      (aref vector 10) (wm-size-hints-height-inc hints)))
+      (let ((min-aspect (wm-size-hints-min-aspect hints))
+	    (max-aspect (wm-size-hints-max-aspect hints)))
+	(when (and min-aspect max-aspect)
+	  (setf flags (logior flags paspect)
+		min-aspect (rationalize min-aspect)
+		max-aspect (rationalize max-aspect)
+		(aref vector 11) (numerator min-aspect)
+		(aref vector 12) (denominator min-aspect)
+		(aref vector 13) (numerator max-aspect)
+		(aref vector 14) (denominator max-aspect))))
+      (when (and (wm-size-hints-base-width hints)
+		 (wm-size-hints-base-height hints))
+	(setf flags (logior flags pbasesize)
+	      (aref vector 15) (wm-size-hints-base-width hints)
+	      (aref vector 16) (wm-size-hints-base-height hints)))
+      (when (wm-size-hints-win-gravity hints)
+	(setf flags (logior flags pwingravity)
+	      (aref vector 17) (encode-type
+				(member-vector *win-gravity-vector*)
+				(wm-size-hints-win-gravity hints))))
+      (setf (aref vector 0) flags)
+      vector)))
+
+;;-----------------------------------------------------------------------------
+;; Icon_Size
+
+;; Use the same intermediate structure as WM_SIZE_HINTS
+
+(defun icon-sizes (window)
+  (declare (type window window))
+  (declare (values wm-size-hints))
+  (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
+    (declare (type (or null (simple-vector 6)) vector))
+    (when vector
+      (make-wm-size-hints
+	:min-width (aref vector 0)
+	:min-height (aref vector 1)
+	:max-width (aref vector 2)
+	:max-height (aref vector 3)
+	:width-inc (aref vector 4)
+	:height-inc (aref vector 5)))))
+  
+(defsetf icon-sizes set-icon-sizes)
+(defun set-icon-sizes (window wm-size-hints)
+  (declare (type window window)
+	   (type wm-size-hints wm-size-hints))
+  (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
+			(wm-size-hints-min-height wm-size-hints)
+			(wm-size-hints-max-width wm-size-hints)
+			(wm-size-hints-max-height wm-size-hints)
+			(wm-size-hints-width-inc wm-size-hints)
+			(wm-size-hints-height-inc wm-size-hints))))
+    (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
+    wm-size-hints))
+
+;;-----------------------------------------------------------------------------
+;; WM-Protocols
+
+(defun wm-protocols (window)
+  (map 'list #'(lambda (id) (atom-name (window-display window) id))
+       (get-property window :WM_PROTOCOLS :type :ATOM)))
+
+(defsetf wm-protocols set-wm-protocols)
+(defun set-wm-protocols (window protocols)
+  (change-property window :WM_PROTOCOLS
+		   (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
+			protocols)
+		   :ATOM 32)
+  protocols)
+
+;;-----------------------------------------------------------------------------
+;; WM-Colormap-windows
+
+(defun wm-colormap-windows (window)
+  (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
+			:transform #'(lambda (id)
+				       (lookup-window (window-display window) id)))))
+
+(defsetf wm-colormap-windows set-wm-colormap-windows)
+(defun set-wm-colormap-windows (window colormap-windows)
+  (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
+		   :transform #'window-id)
+  colormap-windows)
+
+;;-----------------------------------------------------------------------------
+;; Transient-For
+
+(defun transient-for (window)
+  (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
+    (and prop (lookup-window (window-display window) (car prop)))))
+
+(defsetf transient-for set-transient-for)
+(defun set-transient-for (window transient)
+  (declare (type window window transient))
+  (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
+  transient)
+
+;;-----------------------------------------------------------------------------
+;; Set-WM-Properties
+
+(defun set-wm-properties (window &rest options &key 
+			  name icon-name resource-name resource-class command
+			  client-machine hints normal-hints zoom-hints
+			  ;; the following are used for wm-normal-hints
+			  user-specified-position-p
+			  user-specified-size-p
+			  x y width height min-width min-height max-width max-height
+			  width-inc height-inc min-aspect max-aspect
+			  base-width base-height win-gravity
+			  ;; the following are used for wm-hints
+			  input initial-state icon-pixmap icon-window
+			  icon-x icon-y icon-mask window-group)
+  ;; Set properties for WINDOW.
+  (declare (arglist window &rest options &key 
+		   name icon-name resource-name resource-class command
+		   client-machine hints normal-hints
+		   ;; the following are used for wm-normal-hints
+		   user-specified-position-p user-specified-size-p
+		   min-width min-height max-width max-height
+		   width-inc height-inc min-aspect max-aspect
+		   base-width base-height win-gravity
+		   ;; the following are used for wm-hints
+		   input initial-state icon-pixmap icon-window
+		   icon-x icon-y icon-mask window-group))
+  (declare (type window window)
+	   (type (or null stringable) name icon-name resource-name resource-class client-machine)
+	   (type (or null list) command)
+	   (type (or null wm-hints) hints)
+	   (type (or null wm-size-hints) normal-hints zoom-hints)
+	   (type (or null boolean) user-specified-position-p user-specified-size-p)
+	   (type (or null int16) x y)
+	   (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
+	   (type (or null win-gravity) win-gravity)
+	   (type (or null number) min-aspect max-aspect)
+	   (type (or null (member :off :on)) input)
+	   (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
+	   (type (or null pixmap) icon-pixmap icon-mask)
+	   (type (or null window) icon-window)
+	   (type (or null card16) icon-x icon-y)
+	   (type (or null resource-id) window-group)
+	   (dynamic-extent options))
+  (when name (setf (wm-name window) name))
+  (when icon-name (setf (wm-icon-name window) icon-name))
+  (when client-machine (setf (wm-client-machine window) client-machine))
+  (when (or resource-name resource-class)
+    (set-wm-class window resource-name resource-class))
+  (when command (setf (wm-command window) command))
+  ;; WM-HINTS
+  (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
+			    :icon-x :icon-y :icon-mask :window-group))
+	(when (getf options arg) (return t)))
+      (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
+	(when input (setf (wm-hints-input wm-hints) input))
+	(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
+	(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
+	(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
+	(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
+	(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
+	(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
+	(when window-group (setf (wm-hints-input wm-hints) window-group))
+	(setf (wm-hints window) wm-hints))
+      (when hints (setf (wm-hints window) hints)))
+  ;; WM-NORMAL-HINTS
+  (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
+			:width-inc :height-inc :min-aspect :max-aspect
+			:user-specified-position-p :user-specified-size-p
+			:base-width :base-height :win-gravity))
+	(when (getf options arg) (return t)))
+      (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
+	(when x (setf (wm-size-hints-x size) x))
+	(when y (setf (wm-size-hints-y size) y))
+	(when width (setf (wm-size-hints-width size) width))
+	(when height (setf (wm-size-hints-height size) height))
+	(when min-width (setf (wm-size-hints-min-width size) min-width))
+	(when min-height (setf (wm-size-hints-min-height size) min-height))
+	(when max-width (setf (wm-size-hints-max-width size) max-width))
+	(when max-height (setf (wm-size-hints-max-height size) max-height))
+	(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
+	(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
+	(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
+	(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
+	(when base-width (setf (wm-size-hints-base-width size) base-width))
+	(when base-height (setf (wm-size-hints-base-height size) base-height))
+	(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
+	(when user-specified-position-p (setf (wm-size-hints-user-specified-position-p size)
+					      user-specified-position-p))
+	(when user-specified-size-p (setf (wm-size-hints-user-specified-size-p size)
+					  user-specified-size-p))
+	(setf (wm-normal-hints window) size))
+      (when normal-hints (setf (wm-normal-hints window) normal-hints)))
+  (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
+  )
+
+;;; OBSOLETE
+(defun set-standard-properties (window &rest options)
+  (declare (dynamic-extent options))
+  (apply #'set-wm-properties window options))
+
+;;-----------------------------------------------------------------------------
+;; WM Control
+
+(defun iconify-window (window screen)
+  (declare (type window window)
+	   (type screen screen))
+  (let ((root (screen-root screen)))
+    (declare (type window root))
+    (send-event root :client-message '(:substructure-redirect :substructure-notify)
+		:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
+
+(defun withdraw-window (window screen)
+  (declare (type window window)
+	   (type screen screen))
+  (unmap-window window)
+  (let ((root (screen-root screen)))
+    (declare (type window root))
+    (send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
+		:window window :event-window root :configure-p nil)))
+
+
+;;-----------------------------------------------------------------------------
+;; Colormaps
+
+(def-clx-class (standard-colormap (:copier nil) (:predicate nil))
+  (colormap nil :type (or null colormap))
+  (base-pixel 0 :type pixel)
+  (max-color nil :type (or null color))
+  (mult-color nil :type (or null color))
+  (visual nil :type (or null visual-info))
+  (kill nil :type (or (member nil :release-by-freeing-colormap)
+		      drawable gcontext cursor colormap font)))
+
+(defun rgb-colormaps (window property)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
+    (declare (type (or null simple-vector) prop))
+    (when prop
+      (list (make-standard-colormap
+	      :colormap (lookup-colormap (window-display window) (aref prop 0))
+	      :base-pixel (aref prop 7)
+	      :max-color (make-color :red   (card16->rgb-val (aref prop 1))
+				     :green (card16->rgb-val (aref prop 3))
+				     :blue  (card16->rgb-val (aref prop 5)))
+	      :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
+				      :green (card16->rgb-val (aref prop 4))
+				      :blue  (card16->rgb-val (aref prop 6)))
+	      :visual (and (<= 9 (length prop))
+			   (visual-info (window-display window) (aref prop 8)))
+	      :kill (and (<= 10 (length prop))
+			 (let ((killid (aref prop 9)))
+			   (if (= killid 1)
+			       :release-by-freeing-colormap
+			       (lookup-resource-id (window-display window) killid)))))))))
+
+(defsetf rgb-colormaps set-rgb-colormaps)
+(defun set-rgb-colormaps (window property maps)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
+	   (type list maps))
+  (let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
+	(index -1))
+    (dolist (map maps)
+      (setf (aref prop (incf index))
+	    (encode-type colormap (standard-colormap-colormap map)))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-red (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-green (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
+      (setf (aref prop (incf index))
+	    (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
+      (setf (aref prop (incf index))
+	    (standard-colormap-base-pixel map))
+      (setf (aref prop (incf index))
+	    (visual-info-id (standard-colormap-visual map)))
+      (setf (aref prop (incf index))
+	    (let ((kill (standard-colormap-kill map)))
+	      (etypecase kill
+		(symbol
+		  (ecase kill
+		    ((nil) 0)
+		    ((:release-by-freeing-colormap) 1)))
+		(drawable (drawable-id kill))
+		(gcontext (gcontext-id kill))
+		(cursor (cursor-id kill))
+		(colormap (colormap-id kill))
+		(font (font-id kill))))))
+    (change-property window property prop :RGB_COLOR_MAP 32)))
+
+;;; OBSOLETE
+(defun get-standard-colormap (window property)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
+  (declare (values colormap base-pixel max-color mult-color))
+  (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
+    (declare (type (or null simple-vector) prop))
+    (when prop
+      (values (lookup-colormap (window-display window) (aref prop 0))
+	      (aref prop 7)			;Base Pixel
+	      (make-color :red   (card16->rgb-val (aref prop 1))	;Max Color
+			  :green (card16->rgb-val (aref prop 3))
+			  :blue  (card16->rgb-val (aref prop 5)))
+	      (make-color :red   (card16->rgb-val (aref prop 2))	;Mult color
+			  :green (card16->rgb-val (aref prop 4))
+			  :blue  (card16->rgb-val (aref prop 6)))))))
+
+;;; OBSOLETE
+(defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
+  (declare (type window window)
+	   (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
+			 :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
+	   (type colormap colormap)
+	   (type pixel base-pixel)
+	   (type color max-color mult-color))
+  (let ((prop (apply #'vector (encode-type colormap colormap)
+		     (encode-type rgb-val (color-red max-color))
+		     (encode-type rgb-val (color-red mult-color))
+		     (encode-type rgb-val (color-green max-color))
+		     (encode-type rgb-val (color-green mult-color))
+		     (encode-type rgb-val (color-blue max-color))
+		     (encode-type rgb-val (color-blue mult-color))
+		     base-pixel)))
+    (change-property window property prop :RGB_COLOR_MAP 32)))
+
+;;-----------------------------------------------------------------------------
+;; Cut-Buffers
+
+(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
+		   (transform #'card8->char) (start 0) end)
+  ;; Return the contents of cut-buffer BUFFER
+  (declare (type display display)
+	   (type (integer 0 7) buffer)
+	   (type xatom type)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type t result-type)			;a sequence type
+	   (type (or null (function (integer) t)) transform))
+  (declare (values sequence type format bytes-after))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+			 buffer)))
+    (get-property root property :type type :result-type result-type
+		  :start start :end end :transform transform)))
+
+;; Implement the following:
+;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
+;;			        (transform #'char->card8) (start 0) end) (data)
+;; In order to avoid having to pass positional parameters to set-cut-buffer,
+;; We've got to do the following.  WHAT A PAIN...
+(define-setf-method cut-buffer (display &rest option-list)
+  (declare (dynamic-extent option-list))
+  (do* ((options (copy-list option-list))
+	(option options (cddr option))
+	(store (gensym))
+	(dtemp (gensym))
+	(temps (list dtemp))
+	(values (list display)))
+       ((endp option)
+	(values (nreverse temps)
+		(nreverse values)
+		(list store)
+		`(set-cut-buffer ,store ,dtemp ,@options)
+		`(cut-buffer ,@options)))
+    (unless (member (car option) '(:buffer :type :format :start :end :transform))
+      (error "Keyword arg ~s isn't recognized" (car option)))
+    (let ((x (gensym)))
+      (push x temps)
+      (push (cadr option) values)
+      (setf (cadr option) x))))
+
+(defun set-cut-buffer (data display &key (buffer 0) (type :STRING) (format 8)
+		       (start 0) end (transform #'char->card8))
+  (declare (type sequence data)
+	   (type display display)
+	   (type (integer 0 7) buffer)
+	   (type xatom type)
+	   (type (member 8 16 32) format)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type (or null (function (integer) t)) transform))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
+			    :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
+			 buffer)))
+    (change-property root property data type format :transform transform :start start :end end)
+    data))
+
+(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
+  ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
+  ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
+  (declare (type display display)
+	   (type int16 delta)
+	   (type boolean careful-p))
+  (let* ((root (screen-root (first (display-roots display))))
+	 (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
+		     :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
+    (when careful-p
+      (let ((props (list-properties root)))
+	(dotimes (i 8)
+	  (unless (member (aref buffers i) props)
+	    (setf (cut-buffer display :buffer i) "")))))
+    (rotate-properties root buffers delta)))
+
diff --git a/clx/resource.lisp b/clx/resource.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..743c14f46aa5c20c059b2a1495da6d7e0d9398a9
--- /dev/null
+++ b/clx/resource.lisp
@@ -0,0 +1,713 @@
+;;; -*- Mode:Common-Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
+
+;; RESOURCE - Lisp version of XLIB's Xrm resource manager
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(resource-database
+	   resource-database-timestamp
+	   make-resource-database
+	   resource-key
+	   get-resource
+	   get-search-table
+	   get-search-resource
+	   add-resource
+	   delete-resource 
+	   map-resource 
+	   merge-resources
+	   read-resources
+	   write-resources
+	   wm-resources
+	   set-wm-resources
+	   root-resources))
+
+#+clue ;; for CLUE only
+(defparameter *resource-subclassp* nil
+  "When non-nil and no match found, search superclasses.")
+
+;; The C version of this uses a 64 entry hash table at each entry.
+;; Small hash tables lose in Lisp, so we do linear searches on lists.
+
+(defstruct (resource-database (:copier nil) (:predicate nil)
+			      (:print-function print-resource-database)
+			      (:constructor make-resource-database-internal)
+			      #+explorer (:callable-constructors nil)
+			      )
+  (name nil :type stringable :read-only t)
+  (value nil)
+  (tight nil :type list) ;; List of resource-database
+  (loose nil :type list) ;; List of resource-database
+  )
+
+(defun print-resource-database (database stream depth)
+  (declare (type resource-database database)
+	   (ignore depth))
+  (print-unreadable-object (database stream :type t)
+    (princ (resource-database-name database) stream)
+    (when (resource-database-value database)
+      (princ " " stream)
+      (prin1 (resource-database-value database) stream))))
+
+;; The value slot of the top-level resource-database structure is used for a
+;; time-stamp.
+
+(defun make-resource-database ()
+  ;; Make a resource-database with initial timestamp of 0
+  (make-resource-database-internal :name "Top-Level" :value 0))
+
+(defun resource-database-timestamp (database)
+  (declare (type resource-database database))
+  (resource-database-value database))
+
+(defun incf-resource-database-timestamp (database)
+  ;; Increment the timestamp
+  (declare (type resource-database database))
+  (let ((timestamp (resource-database-value database)))
+    (setf (resource-database-value database)
+	  (if (= timestamp most-positive-fixnum)
+	      most-negative-fixnum
+	    (1+ timestamp)))))
+
+;; DEBUG FUNCTION  (not exported)
+(defun print-db (entry &optional (level 0) type)
+  ;; Debug function to print a resource database
+  (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
+	  level
+	  (resource-database-name entry)
+	  (eq type 'loose)
+	  (resource-database-value entry))
+  (when (resource-database-tight entry)
+    (dolist (tight (resource-database-tight entry))
+      (print-db tight (+ 2 level) 'tight)))
+  (when (resource-database-loose entry)
+    (dolist (loose (resource-database-loose entry))
+      (print-db loose (+ 2 level) 'loose))))
+
+;; DEBUG FUNCTION
+#+comment
+(defun print-search-table (table)
+  (terpri)
+  (dolist (dbase-list table)
+    (format t "~%~s" dbase-list)
+    (dolist (db dbase-list)
+      (print-db db)
+      (dolist (dblist table)
+	(unless (eq dblist dbase-list)
+	  (when (member db dblist)
+	    (format t "  duplicate at ~s" db))))
+      )))
+
+(defun resource-key (stringable)
+  ;; Ensure STRINGABLE is a keyword.
+  (declare (type stringable stringable))
+  (if (symbolp stringable)
+      (if (keywordp (the symbol stringable))
+	  stringable
+	(kintern (symbol-name (the symbol stringable))))
+    (kintern (#-excl string-upcase
+	      #+excl correct-case
+	      (the string stringable)))))
+
+(defun stringable-equal (a b)
+  ;; Compare two stringables.
+  ;; Ignore case when comparing to a symbol.
+  (declare (type stringable a b))
+  (declare (values boolean))
+  (if (symbolp a)
+      (if (symbolp b)
+	  (string= (the string (symbol-name (the symbol a)))
+		   (the string (symbol-name (the symbol b))))
+	(string-equal (the string (symbol-name (the symbol a)))
+		      (the string b)))
+    (if (symbolp b)
+	(string-equal (the string a)
+		      (the string (symbol-name (the symbol b))))
+      (string= (the string a)
+	       (the string b)))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Add/delete resource
+
+(defun add-resource (database name-list value)
+  ;; name-list is a list of either strings or symbols. If a symbol, 
+  ;; case-insensitive comparisons will be used, if a string,
+  ;; case-sensitive comparisons will be used.  The symbol '* or
+  ;; string "*" are used as wildcards, matching anything or nothing.
+  (declare (type resource-database database)
+	   (type list name-list) ;; (list stringable)
+	   (type t value))
+  (unless value (error "Null resource values are ignored"))
+  (incf-resource-database-timestamp database)
+  (do* ((list name-list (cdr list))
+	(name (car list) (car list))
+	(node database)
+	(loose-p nil))
+       ((endp list)
+	(setf (resource-database-value node) value))
+    ;; Key is the first name that isn't *
+    (if (stringable-equal name "*")
+	(setq loose-p t)
+      ;; find the entry associated with name
+      (progn
+	(do ((entry (if loose-p
+			(resource-database-loose node)
+		      (resource-database-tight node))
+		    (cdr entry)))
+	    ((endp entry)
+	     ;; Entry not found - create a new one
+	     (setq entry (make-resource-database-internal :name name))
+	     (if loose-p
+		 (push entry (resource-database-loose node))
+	       (push entry (resource-database-tight node)))
+	     (setq node entry))
+	  (when (stringable-equal name (resource-database-name (car entry)))
+	    ;; Found entry - use it
+	    (return (setq node (car entry)))))
+	(setq loose-p nil)))))
+
+
+(defun delete-resource (database name-list)
+  (declare (type resource-database database)
+	   (type list name-list))
+  (incf-resource-database-timestamp database)
+  (delete-resource-internal database name-list))
+
+(defun delete-resource-internal (database name-list)
+  (declare (type resource-database database)
+	   (type list name-list)) ;; (list stringable)
+  (do* ((list name-list (cdr list))
+	(string (car list) (car list))
+	(node database)
+	(loose-p nil))
+       ((endp list) nil)
+    ;; Key is the first name that isn't *
+    (if (stringable-equal string "*")
+	(setq loose-p t)
+      ;; find the entry associated with name
+      (progn 
+	(do* ((first-entry (if loose-p
+			       (resource-database-loose node)
+			     (resource-database-tight node)))
+	      (entry-list first-entry (cdr entry-list))
+	      (entry (car entry-list) (car entry-list)))
+	     ((endp entry-list)
+	      ;; Entry not found - exit
+	      (return-from delete-resource-internal nil))
+	  (when (stringable-equal string (resource-database-name entry))
+	    (when (cdr list) (delete-resource-internal entry (cdr list)))
+	    (when (and (null (resource-database-loose entry))
+		       (null (resource-database-tight entry)))
+	      (if loose-p
+		  (setf (resource-database-loose node)
+			(delete entry (resource-database-loose node)
+				:test #'eq :count 1))
+		(setf (resource-database-tight node)
+		      (delete entry (resource-database-tight node)
+			      :test #'eq :count 1))))
+	    (return-from delete-resource-internal t)))
+	(setq loose-p nil)))))
+
+;;;-----------------------------------------------------------------------------
+;;; Get Resource
+
+(defun get-resource (database value-name value-class full-name full-class)
+  ;; Return the value of the resource in DATABASE whose partial name
+  ;; most closely matches (append full-name (list value-name)) and
+  ;;                      (append full-class (list value-class)).
+  (declare (type resource-database database)
+	   (type stringable value-name value-class)
+	   (type list full-name full-class)) ;; (list stringable)
+  (declare (values value))
+  (let ((names (append full-name (list value-name)))
+	(classes (append full-class (list value-class))))
+    (let* ((result (get-entry (resource-database-tight database)
+			      (resource-database-loose database)
+			      names classes)))
+      (when result
+	(resource-database-value result)))))
+
+(defun get-entry-lookup (table name names classes)
+  (declare (type list table names classes)
+	   (symbol name))
+  (dolist (entry table)
+    (declare (type resource-database entry))
+    (when (stringable-equal name (resource-database-name entry))
+      (if (null (cdr names))
+	  (return entry)
+	(let ((result (get-entry (resource-database-tight entry)
+				 (resource-database-loose entry)
+				 (cdr names) (cdr classes))))
+	  (declare (type (or null resource-database) result))
+	  (when result
+	    (return result)
+	    ))))))
+
+(defun get-entry (tight loose names classes &aux result)
+  (declare (type list tight loose names classes))
+  (let ((name (car names))
+	(class (car classes)))
+    (declare (type symbol name class))
+    (cond ((and tight
+		(get-entry-lookup tight name names classes)))
+	  ((and loose
+		(get-entry-lookup loose name names classes)))
+	  ((and tight
+		(not (stringable-equal name class))
+		(get-entry-lookup tight class names classes)))
+	  ((and loose
+		(not (stringable-equal name class))
+		(get-entry-lookup loose class names classes)))
+	  #+clue ;; for CLUE only
+	  ((and *resource-subclassp*
+		(or loose tight)
+		(dolist (class (cluei::class-all-superclasses class))
+		  (when tight
+		    (when (setq result
+				(get-entry-lookup tight class names classes))
+		      (return result)))
+		  (when loose
+		    (when (setq result
+				(get-entry-lookup loose class names classes))
+		      (return result))))))	
+	  (loose
+	   (loop
+	     (pop names) (pop classes)
+	     (unless (and names classes) (return nil))
+	     (setq name (car names)
+		   class (car classes))
+	     (when (setq result (get-entry-lookup loose name names classes))
+	       (return result))
+	     (when (and (not (stringable-equal name class))
+			(setq result
+			      (get-entry-lookup loose class names classes)))
+	       (return result))
+	     #+clue ;; for CLUE only
+	     (when *resource-subclassp*
+	       (dolist (class (cluei::class-all-superclasses class))
+		 (when (setq result
+			     (get-entry-lookup loose class names classes))
+		   (return-from get-entry result))))
+	     )))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Get-resource with search-table
+
+(defun get-search-resource (table name class)
+  ;; (get-search-resource (get-search-table database full-name full-class) 
+  ;;                      value-name value-class)
+  ;; is equivalent to 
+  ;; (get-resource database value-name value-class full-name full-class)
+  ;; But since most of the work is done by get-search-table,
+  ;; get-search-resource is MUCH faster when getting several resources with
+  ;; the same full-name/full-class
+  (declare (type list table)
+	   (type stringable name class))
+  (let ((do-class (and class (not (stringable-equal name class)))))
+    (dolist (dbase-list table)
+      (declare (type list dbase-list))
+      (dolist (dbase dbase-list)
+	(declare (type resource-database dbase))
+	(when (stringable-equal name (resource-database-name dbase))
+	  (return-from get-search-resource
+	    (resource-database-value dbase))))
+      (when do-class
+	(dolist (dbase dbase-list)
+	  (declare (type resource-database dbase))
+	  (when (stringable-equal class (resource-database-name dbase))
+	    (return-from get-search-resource
+	      (resource-database-value dbase))))))))
+
+(defvar *get-table-result*)
+
+(defun get-search-table (database full-name full-class)
+  ;; Return a search table for use with get-search-resource.
+  (declare (type resource-database database)
+	   (type list full-name full-class)) ;; (list stringable)
+  (declare (values value))
+  (let* ((tight (resource-database-tight database))
+	 (loose (resource-database-loose database))
+	 (result (cons nil nil))
+	 (*get-table-result* result))
+    (declare (type list tight loose)
+	     (type cons result))
+    (when (or tight loose)
+      (when full-name
+	(get-tables tight loose full-name full-class))
+
+      ;; Pick up bindings of the form (* name). These are the elements of
+      ;; top-level loose without further tight/loose databases.
+      ;;
+      ;; (Hack: these bindings belong in ANY search table, so recomputing them
+      ;; is a drag.  True fix involves redesigning entire lookup
+      ;; data-structure/algorithm.)
+      ;;
+      (let ((universal-bindings
+	      (remove nil loose :test-not #'eq
+		      :key #'(lambda (database)
+			       (or (resource-database-tight database)
+				   (resource-database-loose database))))))
+	(when universal-bindings
+	  (setf (cdr *get-table-result*) (list universal-bindings)))))
+    (cdr result)))
+
+(defun get-tables-lookup (dbase name names classes)
+  (declare (type list dbase names classes)
+	   (type symbol name))
+  (declare (optimize speed))
+  (dolist (entry dbase)
+    (declare (type resource-database entry))
+    (when (stringable-equal name (resource-database-name entry))
+      (let ((tight (resource-database-tight entry))
+	    (loose (resource-database-loose entry)))
+	(declare (type list tight loose))
+	(when (or tight loose)
+	  (if (cdr names)
+	      (get-tables tight loose (cdr names) (cdr classes))
+	    (when tight
+	      (let ((result *get-table-result*))
+		;; Put tight at end of *get-table-result*
+		(setf (cdr result)
+		      (setq *get-table-result* (cons tight nil))))))
+	  (when loose
+	    (let ((result *get-table-result*))
+	      ;; Put loose at end of *get-table-result*
+	      (setf (cdr result)
+		    (setq *get-table-result* (cons loose nil))))))))))
+
+(defun get-tables (tight loose names classes)
+  (declare (type list tight loose names classes))
+  (let ((name (car names))
+	(class (car classes)))
+    (declare (type symbol name class))
+    (when tight
+      (get-tables-lookup tight name names classes))
+    (when loose
+      (get-tables-lookup loose name names classes))
+    (when (and tight (not (stringable-equal name class)))
+      (get-tables-lookup tight class names classes))
+    (when (and loose (not (stringable-equal name class)))
+      (get-tables-lookup loose class names classes))
+    #+clue ;; for CLUE only
+    (when *resource-subclassp*
+      (dolist (class (cluei::class-all-superclasses class))
+	(declare (type symbol class))
+	(setq class class)
+	(when tight
+	  (get-tables-lookup tight class names classes))
+	(when loose
+	  (get-tables-lookup loose class names classes))))
+    (when loose
+      (loop
+	(pop names) (pop classes)
+	(unless (and names classes) (return nil))
+	(setq name (car names)
+	      class (car classes))
+	(get-tables-lookup loose name names classes)
+	(unless (stringable-equal name class)
+	  (get-tables-lookup loose class names classes))
+	#+clue ;; for CLUE only
+	(when *resource-subclassp*
+	  (dolist (class (cluei::class-all-superclasses class))
+	    (get-tables-lookup loose class names classes)))
+	))))
+
+
+;;;-----------------------------------------------------------------------------
+;;; Utility functions
+
+(defun map-resource (database function &rest args)
+  ;; Call FUNCTION on each resource in DATABASE.
+  ;; FUNCTION is called with arguments (name-list value . args)
+  (declare (type resource-database database)
+	   (type (function (list t &rest t) t) function)
+	   (downward-funarg function)
+	   (dynamic-extent args))
+  (declare (values nil))
+  (labels ((map-resource-internal (database function args name)
+	     (declare (type resource-database database)
+		      (type (function (list t &rest t) t) function)
+		      (type list name)
+		      (downward-funarg function))		      
+	     (let ((tight (resource-database-tight database))
+		   (loose (resource-database-loose database)))
+	       (declare (type list tight loose))
+	       (dolist (resource tight)
+		 (declare (type resource-database resource))
+		 (let ((value (resource-database-value resource))
+		       (name (append
+			       name
+			       (list (resource-database-name resource)))))
+		   (if value
+		       (apply function name value args)
+		     (map-resource-internal resource function args name))))
+	       (dolist (resource loose)
+		 (declare (type resource-database resource))
+		 (let ((value (resource-database-value resource))
+		       (name (append
+			       name
+			       (list "*" (resource-database-name resource)))))
+		   (if value
+		       (apply function name value args)
+		     (map-resource-internal resource function args name)))))))
+    (map-resource-internal database function args nil)))
+
+(defun merge-resources (database with-database)
+  (declare (type resource-database database with-database))
+  (declare (values resource-database))
+  (map-resource #'add-resource database with-database)
+  with-database)
+
+(defun char-memq (key char)
+  ;; Used as a test function for POSITION
+  (declare (type string-char char))
+  (member char key))
+
+(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
+  ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
+  ;; stream
+  (let ((abortp (gensym))
+	(streamp (gensym)))
+    `(let* ((,abortp t)
+	    (,streamp (streamp pathname))
+	    (,stream (if ,streamp pathname (open ,pathname ,@options))))
+       (unwind-protect
+	   (progn
+	     ,@body
+	     (setq ,abortp nil))
+	 (unless ,streamp
+	   (close stream :abort ,abortp))))))
+
+(defun read-resources (database pathname &key key test test-not)
+  ;; Merges resources from a file in standard X11 format with DATABASE.
+  ;; KEY is a function used for converting value-strings, the default is
+  ;; identity.  TEST and TEST-NOT are predicates used for filtering
+  ;; which resources to include in the database.  They are called with
+  ;; the name and results of the KEY function.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (declare (values resource-database))
+  (resource-with-open-file (stream pathname)
+    (loop
+      (let ((string (read-line stream nil :eof)))
+	(declare (type string string))
+	(when (eq string :eof) (return database))
+	(let* ((end (length string))
+	       (i (position '(#\tab #\space) string
+			    :test-not #'char-memq :end end))
+	       (term nil))
+	  (declare (type array-index end)
+		   (type (or null array-index) i term))
+	  (when i ;; else blank line
+	    (case (char string i)
+	      (#\! nil)  ;; Comment - skip
+	      (#.(card8->char 0) nil) ;; terminator for C strings - skip
+	      (#\#       ;; Include
+	       (setq term (position '(#\tab #\space) string :test #'char-memq
+				    :start i :end end))
+	       (if (not (string-equal string "#INCLUDE" :start1 i :end1 term))
+		   (format t "~%Resource File error. Ignoring: ~a" string)
+		 (let ((path (merge-pathnames
+			       (subseq string (1+ term)) (truename stream))))
+		   (read-resources database path
+				   :key key :test test :test-not test-not))))
+	      (otherwise
+	       (multiple-value-bind (name-list value)
+		   (parse-resource string i end)
+		 (when key (setq value (funcall key value)))
+		 (when
+		   (cond (test (funcall test name-list value))
+			 (test-not (not (funcall test-not name-list value)))
+			 (t t))
+		   (add-resource database name-list value)))))))))))
+
+(defun parse-resource (string &optional (start 0) end)
+  ;; Parse a resource specfication string into a list of names and a value
+  ;; string
+  (declare (type string string)
+	   (type array-index start)
+	   (type (or null array-index) end))
+  (declare (values name-list value))
+  (do ((i start)
+       (end (or end (length string)))
+       (term)
+       (name-list))
+      ((>= i end))
+    (declare (type array-index end)
+	     (type (or null array-index) i term))
+    (setq term (position '(#\. #\* #\:) string
+			 :test #'char-memq :start i :end end))
+    (case (and term (char string term))
+      ;; Name seperator
+      (#\. (when (> term i)
+	     (push (subseq string i term) name-list)))
+      ;; Wildcard seperator
+      (#\* (when (> term i)
+	     (push (subseq string i term) name-list))
+	   (push '* name-list))
+      ;; Value separator
+      (#\:
+       (push (subseq string i term) name-list)
+       (return
+	 (values
+	   (nreverse name-list)
+	   (string-trim '(#\tab #\space) (subseq string (1+ term)))))))
+    (setq i (1+ term))))
+
+(defun write-resources (database pathname &key write test test-not)
+  ;; Write resources to PATHNAME in the standard X11 format.
+  ;; WRITE is a function used for writing values, the default is #'princ
+  ;; TEST and TEST-NOT are predicates used for filtering which resources
+  ;; to include in the database.  They are called with the name and value.
+  (declare (type resource-database database)
+	   (type (or pathname string stream) pathname)
+	   (type (or null (function (string stream) t)) write)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (resource-with-open-file (stream pathname :direction :output)
+    (map-resource
+      database
+      #'(lambda (name-list value stream write test test-not)
+	  (when
+	    (cond (test (funcall test name-list value))
+		  (test-not (not (funcall test-not name-list value)))
+		  (t t))
+	    (let ((previous (car name-list)))
+	      (princ previous stream)
+	      (dolist (name (cdr name-list))
+		(unless (or (stringable-equal name "*")
+			    (stringable-equal previous "*"))
+		  (write-char #\. stream))
+		(setq previous name)
+		(princ name stream)))
+	    (write-string ":	" stream)
+	    (funcall write value stream)
+	    (terpri stream)))
+      stream (or write #'princ) test test-not))
+  database)
+
+(defun wm-resources (database window &key key test test-not)
+  ;; Takes the resources associated with the RESOURCE_MANAGER property
+  ;; of WINDOW (if any) and merges them with DATABASE.
+  ;; KEY is a function used for converting value-strings, the default is
+  ;; identity.  TEST and TEST-NOT are predicates used for filtering
+  ;; which resources to include in the database.  They are called with
+  ;; the name and results of the KEY function.
+  (declare (type resource-database database)
+	   (type window window)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (declare (values resource-database))
+  (let ((string (get-property window :RESOURCE_MANAGER :type :STRING
+			      :result-type 'string
+			      :transform #'xlib::card8->char)))
+    (when string
+      (with-input-from-string (stream string)
+	(read-resources database stream
+			:key key :test test :test-not test-not)))))
+
+(defun set-wm-resources (database window &key write test test-not)
+  ;; Sets the resources associated with the RESOURCE_MANAGER property
+  ;; of WINDOW.
+  ;; WRITE is a function used for writing values, the default is #'princ
+  ;; TEST and TEST-NOT are predicates used for filtering which resources
+  ;; to include in the database.  They are called with the name and value.
+  (declare (type resource-database database)
+	   (type window window)
+	   (type (or null (function (string stream) t)) write)
+	   (type (or null (function (list t) boolean))
+                 test test-not))
+  (xlib::set-string-property
+    window :RESOURCE_MANAGER
+    (with-output-to-string (stream)
+      (write-resources database stream :write write
+		       :test test :test-not test-not))))
+
+(defun root-resources (screen &key database key test test-not)
+  "Returns a resource database containing the contents of the root window
+   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
+   then its default screen is used. If an existing DATABASE is given, then
+   resource values are merged with the DATABASE and the modified DATABASE is
+   returned.
+
+   TEST and TEST-NOT are predicates for selecting which resources are
+   read.  Arguments are a resource name list and a resource value. The KEY
+   function, if given, is called to convert a resource value string to the
+   value given to TEST or TEST-NOT."
+
+  (declare (type (or screen display) screen)
+	   (type (or null resource-database) database)
+	   (type (or null (function (string) t)) key)
+	   (type (or null (function (list t) boolean)) test test-not)
+	   (values resource-database))
+  (let* ((screen (if (type? screen 'display)
+		     (display-default-screen screen)
+		   screen))
+	 (window (screen-root screen))
+	 (database (or database (make-resource-database))))
+    (wm-resources database window :key key :test test :test-not test-not)
+    database))
+
+(defun set-root-resources (screen &key test test-not (write 'princ) database)
+  "Changes the contents of the root window RESOURCE_MANAGER property for the
+   given SCREEN. If SCREEN is a display, then its default screen is used. 
+
+   TEST and TEST-NOT are predicates for selecting which resources from the
+   DATABASE are written.  Arguments are a resource name list and a resource
+   value.  The WRITE function is used to convert a resource value into a
+   string stored in the property."
+
+  (declare (type (or screen display) screen)
+	(type (or null resource-database) database)
+	(type (or null (function (list t) boolean)) test test-not)
+	(type (or null (function (string stream) t)) write)
+	(values resource-database))
+  (let* ((screen (if (type? screen 'display)
+		     (display-default-screen screen)
+		   screen))
+	 (window (screen-root screen)))
+    (set-wm-resources database window
+		      :write write :test test :test-not test-not)
+    database))
+
+(defsetf root-resources set-root-resources)
+
+(defun initialize-resource-database (display)
+  ;; This function is (supposed to be) equivalent to the Xlib initialization
+  ;; code.
+  (declare (type display display))
+  (let ((rdb (make-resource-database))
+	(rootwin (screen-root (car (display-roots display)))))
+    ;; First read the server defaults if present, otherwise from the default
+    ;; resource file
+    (if (get-property rootwin :RESOURCE_MANAGER)
+	(xlib:wm-resources rdb rootwin)
+      (let ((path (default-resources-pathname)))
+	(when (and path (probe-file path))
+	  (read-resources rdb path))))
+    ;; Next read from the resources file 
+    (let ((path (resources-pathname)))
+      (when (and path (probe-file path))
+	(read-resources rdb path)))
+    (setf (display-xdefaults display) rdb)))
diff --git a/clx/text.lisp b/clx/text.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..59415101c25ec69c862d076d8662653e2aec0417
--- /dev/null
+++ b/clx/text.lisp
@@ -0,0 +1,1083 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+
+;;; CLX text keyboard and pointer requests
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(
+	  translation-function
+	  translate-default
+	  text-extents
+	  text-width
+	  draw-glyph
+	  draw-glyphs
+	  draw-image-glyph
+	  draw-image-glyphs
+	  display-keycode-range
+	  set-modifier-mapping
+	  modifier-mapping
+	  keysym
+	  change-keyboard-mapping
+	  keyboard-mapping
+	  keyboard-mapping
+	  ))
+
+;; Strings are broken up into chunks of this size
+(defparameter *max-string-size* 254)
+
+;; In the functions below, the transform is used to convert an element of the
+;; sequence into a font index.  The transform is applied to each element of the
+;; (sub)sequence, until either the transform returns nil or the end of the
+;; (sub)sequence is reached.  If transform returns nil for an element, the
+;; index of that element in the sequence is returned, otherwise nil is
+;; returned.
+
+(deftype translation-function ()
+  #+explorer t
+  #-explorer
+  '(function (sequence array-index array-index (or null font) vector array-index)
+	     (values array-index (or null int16 font) (or null int32))))
+
+;; In the functions below, if width is specified, it is assumed to be the pixel
+;; width of whatever string of glyphs is actually drawn.  Specifying width will
+;; allow for appending the output of subsequent calls to the same protocol
+;; request, provided gcontext has not been modified in the interim.  If width
+;; is not specified, appending of subsequent output might not occur.
+;; Specifying width is simply a hint, for performance.  Note that specifying
+;; width may be difficult if transform can return nil.
+
+(defun translate-default (src src-start src-end font dst dst-start)
+  ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
+  ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
+  ;; on context.  font is the current font, if known.  The function should
+  ;; translate as many elements of src as possible into indexes in the current
+  ;; font, and store them into dst.
+  ;;
+  ;; The first return value should be the src index of the first untranslated
+  ;; element.  If no further elements need to be translated, the second return
+  ;; value should be nil.  If a horizontal motion is required before further
+  ;; translation, the second return value should be the delta in x coordinate.
+  ;; If a font change is required for further translation, the second return
+  ;; value should be the new font.  If known, the pixel width of the translated
+  ;; text can be returned as the third value; this can allow for appending of
+  ;; subsequent output to the same protocol request, if no overall width has
+  ;; been specified at the higher level.
+  ;; (returns values: ending-index
+  ;;                  (OR null horizontal-motion font)
+  ;;                  (OR null translated-width))
+  (declare (type sequence src)
+	   (type array-index src-start src-end dst-start)
+	   (type (or null font) font)
+	   (type vector dst)
+	   (inline graphic-char-p))
+  (declare (values integer (or null integer font) (or null integer)))
+  font ;;not used
+  (if (stringp src)
+      (do ((i src-start (index+ i 1))
+	   (j dst-start (index+ j 1))
+	   (char))
+	  ((index>= i src-end)
+	   i)
+	(declare (type array-index i j))
+	(if (graphic-char-p (setq char (char src i)))
+	    (setf (aref dst j) (char->card8 char))
+	  (return i)))
+      (do ((i src-start (index+ i 1))
+	   (j dst-start (index+ j 1))
+	   (elt))
+	  ((index>= i src-end)
+	   i)
+	(declare (type array-index i j))
+	(setq elt (elt src i))
+	(cond ((and (characterp elt) (graphic-char-p elt))
+	       (setf (aref dst j) (char->card8 elt)))
+	      ((integerp elt)
+	       (setf (aref dst j) elt))
+	      (t
+	       (return i))))))
+
+;; There is a question below of whether translate should always be required, or
+;; if not, what the default should be or where it should come from.  For
+;; example, the default could be something that expected a string as src and
+;; translated the CL standard character set to ASCII indexes, and ignored fonts
+;; and bits.  Or the default could expect a string but otherwise be "system
+;; dependent".  Or the default could be something that expected a vector of
+;; integers and did no translation.  Or the default could come from the
+;; gcontext (but what about text-extents and text-width?).
+
+(defun text-extents (font sequence &key (start 0) end translate)
+  ;; If multiple fonts are involved, font-ascent and font-descent will be the
+  ;; maximums.  If multiple directions are involved, the direction will be nil.
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values width ascent descent left right
+		  font-ascent font-descent direction
+		  (or null array-index)))
+  (when (type? font 'gcontext)
+    (force-gcontext-changes font)
+    (setq font (gcontext-font font t)))
+  (check-type font font)
+  (let* ((left-bearing 0)
+	 (right-bearing 0)
+	 ;; Sum of widths
+	 (width 0)
+	 (ascent 0)
+	 (descent 0)
+	 (overall-ascent (font-ascent font))
+	 (overall-descent (font-descent font))
+	 (overall-direction (font-direction font))	 
+	 (next-start nil)
+	 (display (font-display font)))
+    (declare (type int16 ascent descent overall-ascent overall-descent)
+	     (type int32 left-bearing right-bearing width)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-display (display)
+      (do* ((wbuf (display-tbuf16 display))
+	    (src-end (or end (length sequence)))
+	    (src-start start end)
+	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
+		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (buf-end 0)
+	    (new-font)
+	    (font-ascent 0)
+	    (font-descent 0)
+	    (font-direction)
+	    (stop-p nil))
+	   ((or stop-p (index>= src-start src-end))
+	    (when (index< src-start src-end)
+	      (setq next-start src-start)))
+	(declare (type buffer-text16 wbuf)
+		 (type array-index src-start src-end end buf-end)
+		 (type int16 font-ascent font-descent)
+		 (type boolean stop-p))
+	;; Translate the text
+	(multiple-value-setq (buf-end new-font)
+	  (funcall (or translate #'translate-default)
+		   sequence src-start end font wbuf 0))
+	(setq buf-end (- buf-end src-start))
+	(cond ((null new-font) (setq stop-p t))
+	      ((integerp new-font) (incf width (the int32 new-font)))
+	      ((type? new-font 'font) (setq font new-font)))
+	
+	(let (w a d l r)
+	  (if (or (font-char-infos-internal font) (font-local-only-p font))
+	      ;; Calculate text extents locally
+	      (progn
+		(multiple-value-setq (w a d l r)
+		  (text-extents-local font wbuf 0 buf-end nil))
+		(setq font-ascent (the int16 (font-ascent font))
+		      font-descent (the int16 (font-descent font))
+		      font-direction (font-direction font)))
+	    ;; Let the server calculate text extents
+	    (multiple-value-setq
+	      (w a d l r font-ascent font-descent font-direction)
+	      (text-extents-server font wbuf 0 buf-end)))
+	  (incf width (the int32 w))
+	  (cond ((index= src-start start)
+		 (setq left-bearing (the int32 l))
+		 (setq right-bearing (the int32 r))
+		 (setq ascent (the int16 a))
+		 (setq descent (the int16 d)))
+		(t
+		 (setq left-bearing (the int32 (min left-bearing (the int32 l))))
+		 (setq right-bearing (the int32 (max right-bearing (the int32 r))))
+		 (setq ascent (the int16 (max ascent (the int16 a))))
+		 (setq descent (the int16 (max descent (the int16 d)))))))
+	
+	(setq overall-ascent (the int16 (max overall-ascent font-ascent)))
+	(setq overall-descent (the int16 (max overall-descent font-descent)))
+	(case overall-direction
+	  (:unknown (setq overall-direction font-direction))
+	  (:left-to-right (unless (eq font-direction :left-to-right)
+			    (setq overall-direction nil)))
+	  (:right-to-left (unless (eq font-direction :right-to-left)
+			    (setq overall-direction nil))))))
+    
+    (values width
+	    ascent
+	    descent
+	    left-bearing
+	    right-bearing
+	    overall-ascent
+	    overall-descent
+	    overall-direction
+	    next-start)))
+
+(defun text-width (font sequence &key (start 0) end translate)
+  ;; Translate will always be called with a 16-bit dst buffer.
+  (declare (type sequence sequence)
+	   (type (or font gcontext) font)
+	   (type array-index start)
+	   (type (or null array-index) end))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values integer (or null integer)))
+  (when (type? font 'gcontext)
+    (force-gcontext-changes font)
+    (setq font (gcontext-font font t)))
+  (check-type font font)
+  (let* ((width 0)
+	 (next-start nil)
+	 (display (font-display font)))
+    (declare (type int32 width)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-display (display)
+      (do* ((wbuf (display-tbuf16 display))
+	    (src-end (or end (length sequence)))
+	    (src-start start end)
+	    (end (index-min src-end (index+ src-start *buffer-text16-size*))
+		 (index-min src-end (index+ src-start *buffer-text16-size*)))
+	    (buf-end 0)
+	    (new-font)
+	    (stop-p nil))
+	   ((or stop-p (index>= src-start src-end))
+	    (when (index< src-start src-end)
+	      (setq next-start src-start)))
+	(declare (type buffer-text16 wbuf)
+		 (type array-index src-start src-end end buf-end)
+		 (type boolean stop-p))
+	;; Translate the text
+	(multiple-value-setq (buf-end new-font)
+	  (funcall (or translate #'translate-default)
+		   sequence src-start end font wbuf 0))
+	(setq buf-end (- buf-end src-start))
+	(cond ((null new-font) (setq stop-p t))
+	      ((integerp new-font) (incf width (the int32 new-font)))
+	      ((type? new-font 'font) (setq font new-font)))
+	
+	(incf width
+	      (if (or (font-char-infos-internal font) (font-local-only-p font))
+		  (text-extents-local font wbuf 0 buf-end :width-only)
+		(text-width-server font wbuf 0 buf-end)))))
+    (values width next-start)))
+
+#+clx-little-endian
+(defun byte-swap-card16 (card16)
+  (declare (type card16 card16))
+  (declare (values card16))
+  (dpb card16 (byte 8 8) (ash card16 -8)))  
+
+(defun text-extents-server (font string start end)
+  (declare (type font font)
+	   (type string string)
+	   (type array-index start end))
+  (declare (values width ascent descent left right font-ascent font-descent direction))
+  (let ((display (font-display font))
+	(length (index- end start))
+	(font-id (font-id font)))
+    (declare (type display display)
+	     (type array-index length)
+	     (type resource-id font-id))
+    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes (8 16 32))
+	 (((data boolean) (oddp length))
+	  (length (index+ (index-ceiling length 2) 2))
+	  (resource-id font-id)
+	  ((sequence :format card16 :start start :end end :appending t
+		     #+clx-little-endian :transform
+		     #+clx-little-endian ;; Byte swap for little-endian
+		     #'byte-swap-card16)
+	   string))
+      (values
+	(integer-get 16)
+	(int16-get 12)
+	(int16-get 14)
+	(integer-get 20)
+	(integer-get 24)
+	(int16-get 8)
+	(int16-get 10)
+	(member8-get 1 :left-to-right :right-to-left)))))
+
+(defun text-width-server (font string start end)
+  (declare (type (or font gcontext) font)
+	   (type string string)
+	   (type array-index start end))
+  (declare (values integer))
+  (let ((display (font-display font))
+	(length (index- end start))
+	(font-id (font-id font)))
+    (declare (type display display)
+	     (type array-index length)
+	     (type resource-id font-id))
+    (with-buffer-request-and-reply (display *x-querytextextents* 28 :sizes 32)
+	 (((data boolean) (oddp length))
+	  (length (index+ (index-ceiling length 2) 2))
+	  (resource-id font-id)
+	  ((sequence :format card16 :start start :end end :appending t
+		     #+clx-little-endian :transform
+		     #+clx-little-endian ;; Byte swap for little-endian
+		     #'byte-swap-card16)
+	   string))
+      (values (integer-get 16)))))
+
+(defun text-extents-local (font sequence start end width-only-p)
+  (declare (type font font)
+	   (type sequence sequence)
+	   (type integer start end)
+	   (type boolean width-only-p))
+  (declare (values width ascent descent overall-left overall-right))
+  (let* ((char-infos (font-char-infos font))
+	 (font-info (font-font-info font)))
+    (declare (type font-info font-info))
+    (declare (type (simple-array int16 (*)) char-infos)
+	     (array-register char-infos))
+    (if (zerop (length char-infos))
+	;; Fixed width font
+	(let* ((font-width (max-char-width font))
+	       (font-ascent (max-char-ascent font))
+	       (font-descent (max-char-descent font))
+	       (width (* (index- end start) font-width)))
+	  (declare (type int16 font-width font-ascent font-descent)
+		   (type int32 width))
+	  (if width-only-p
+	      width
+	    (values width
+		    font-ascent
+		    font-descent
+		    (max-char-left-bearing font)
+		    (+ width (- font-width) (max-char-right-bearing font)))))
+      
+      ;; Variable-width font
+      (let* ((first-col (font-info-min-byte2 font-info))
+	     (num-cols (1+ (- (font-info-max-byte2 font-info) first-col)))
+	     (first-row (font-info-min-byte1 font-info))
+	     (last-row (font-info-max-byte1 font-info))
+	     (num-rows (1+ (- last-row first-row))))
+	(declare (type card8 first-col first-row last-row)
+		 (type card16 num-cols num-rows))
+	(if (or (plusp first-row) (plusp last-row))
+	    
+	    ;; Matrix (16 bit) font
+	    (macrolet ((char-info-elt (sequence elt)
+			 `(let* ((char (the card16 (elt ,sequence ,elt)))
+				 (row (- (ash char -8) first-row))
+				 (col (- (logand char #xff) first-col)))
+			    (declare (type card16 char)
+				     (type int16 row col))
+			    (if (and (< -1 row num-rows) (< -1 col num-cols))
+				(index* 6 (index+ (index* row num-cols) col))
+			      -1))))
+	      (if width-only-p
+		  (do ((i start (index1+ i))
+		       (width 0))
+		      ((index>= i end) width)
+		    (declare (type array-index i)
+			     (type int32 width))
+		    (let ((n (char-info-elt sequence i)))
+		      (declare (type fixnum n))
+		      (unless (minusp n)  ;; Ignore characters not in the font
+			(incf width (the int16 (aref char-infos (index+ 2 n)))))))
+		;; extents
+		(do ((i start (index1+ i))
+		     (width 0)
+		     (ascent 0)
+		     (descent 0)
+		     (left #x7fff)
+		     (right 0))
+		    ((index>= i end)
+		     (values width ascent descent left right))
+		  (declare (type array-index i)
+			   (type int16 ascent descent)
+			   (type int32 width left right))
+		  (let ((n (char-info-elt sequence i)))
+		    (declare (type fixnum n))
+		    (unless (minusp n) ;; Ignore characters not in the font
+		      (setq left (min left (+ width (aref char-infos n))))
+		      (setq right (max right (+ width (aref char-infos (index1+ n)))))
+		      (incf width (aref char-infos (index+ 2 n)))
+		      (setq ascent (max ascent (aref char-infos (index+ 3 n))))
+		      (setq descent (max descent (aref char-infos (index+ 4 n)))))))))
+	  
+	  ;; Non-matrix (8 bit) font
+	  ;; The code here is identical to the above, except for the following macro:
+	  (macrolet ((char-info-elt (sequence elt)
+		       `(let ((col (- (the card16 (elt ,sequence ,elt)) first-col)))
+			  (declare (type int16 col))
+			  (if (< -1 col num-cols)
+			      (index* 6 col)
+			    -1))))
+	    (if width-only-p
+		(do ((i start (index1+ i))
+		     (width 0))
+		    ((index>= i end) width)
+		  (declare (type array-index i)
+			   (type int32 width))
+		  (let ((n (char-info-elt sequence i)))
+		    (declare (type fixnum n))
+		    (unless (minusp n) ;; Ignore characters not in the font
+		      (incf width (the int16 (aref char-infos (index+ 2 n)))))))
+	      ;; extents
+	      (do ((i start (index1+ i))
+		   (width 0)
+		   (ascent 0)
+		   (descent 0)
+		   (left #x7fff)
+		   (right 0))
+		  ((index>= i end)
+		   (values width ascent descent left right))
+		(declare (type array-index i)
+			 (type int16 ascent descent)
+			 (type int32 width left right))
+		(let ((n (char-info-elt sequence i)))
+		  (declare (type fixnum n))
+		  (unless (minusp n) ;; Ignore characters not in the font
+		    (setq left (min left (+ width (aref char-infos n))))
+		    (setq right (max right (+ width (aref char-infos (index1+ n)))))
+		    (incf width (aref char-infos (index+ 2 n)))
+		    (setq ascent (max ascent (aref char-infos (index+ 3 n))))
+		    (setq descent (max descent (aref char-infos (index+ 4 n)))))
+		  ))))
+	  )))))
+
+;;-----------------------------------------------------------------------------
+
+;; This controls the element size of the dst buffer given to translate.  If
+;; :default is specified, the size will be based on the current font, if known,
+;; and otherwise 16 will be used.  [An alternative would be to pass the buffer
+;; size to translate, and allow it to return the desired size if it doesn't
+;; like the current size.  The problem is that the protocol doesn't allow
+;; switching within a single request, so to allow switching would require
+;; knowing the width of text, which isn't necessarily known.  We could call
+;; text-width to compute it, but perhaps that is doing too many favors?]  [An
+;; additional possibility is to allow an index-size of :two-byte, in which case
+;; translate would be given a double-length 8-bit array, and translate would be
+;; expected to store first-byte/second-byte instead of 16-bit integers.]
+
+(deftype index-size () '(member :default 8 16))
+
+;; In the functions below, if width is specified, it is assumed to be the total
+;; pixel width of whatever string of glyphs is actually drawn.  Specifying
+;; width will allow for appending the output of subsequent calls to the same
+;; protocol request, provided gcontext has not been modified in the interim.
+;; If width is not specified, appending of subsequent output might not occur
+;; (unless translate returns the width).  Specifying width is simply a hint,
+;; for performance.
+
+(defun draw-glyph (drawable gcontext x y elt
+		   &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values boolean (or null int32)))
+  (let* ((display (gcontext-display gcontext))
+	 (result t)
+	 (opcode *x-polytext8*))
+    (declare (type display display))
+    (let ((vector (allocate-gcontext-state)))
+      (declare (type gcontext-state vector))
+      (setf (aref vector 0) elt)
+      (multiple-value-bind (new-start new-font translate-width)
+	  (funcall (or translate #'translate-default)
+		   vector 0 1 (gcontext-font gcontext t) vector 1)
+	;; Allow translate to set a new font
+	(when (type? new-font 'font) 
+	  (setf (gcontext-font gcontext) new-font)
+	  (multiple-value-setq (new-start new-font translate-width)
+	    (funcall translate vector 0 1 new-font vector 1)))
+	;; If new-start is zero, translate refuses to output it
+	(setq result (index-plusp new-start)
+	      elt (aref vector 1))
+	(deallocate-gcontext-state vector)
+	(when translate-width (setq width translate-width))))
+    (when result
+      (when (eql size 16)
+	(setq opcode *x-polytext16*)
+	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
+      (with-buffer-request (display opcode :gc-force gcontext)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(card8 1 0)
+	(card8 (ldb (byte 8 0) elt))
+	(card8 (ldb (byte 8 8) elt)))
+      (values t width))))
+  
+(defun draw-glyphs (drawable gcontext x y sequence
+		    &key (start 0) end translate width (size :default))
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values (or null array-index) (or null int32)))
+  (unless end (setq end (length sequence)))
+  (ecase size
+    ((:default 8) (draw-glyphs8 drawable gcontext x y sequence start end
+				(or translate #'translate-default) width))
+    (16 (draw-glyphs16 drawable gcontext x y sequence start end
+		       (or translate #'translate-default) width))))
+
+(defun draw-glyphs8 (drawable gcontext x y sequence start end translate width)
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int32 x y width)
+	   (type array-index start end)
+	   (type sequence sequence))
+  (declare (values (or null array-index) (or null int32)))
+  (declare (type translation-function translate)
+	   (downward-funarg translate)) 
+  (let* ((src-start start)
+	 (src-end (or end (length sequence)))
+	 (next-start nil)
+	 (length (index- src-end src-start))
+	 (request-length (* length 2))		; Leave lots of room for font shifts.
+	 (display (gcontext-display gcontext))
+	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	 (font (gcontext-font gcontext t)))
+    (declare (type array-index src-start src-end length)
+	     (type (or null array-index) next-start)
+	     (type display display))
+    (with-buffer-request (display *x-polytext8* :gc-force gcontext :length request-length)
+      (drawable drawable)
+      (gcontext gcontext)
+      (int16 x y)
+      (progn
+	;; Don't let any flushes happen since we manually set the request
+	;; length when we're done.
+	(with-buffer-flush-inhibited (display)
+	  (do* ((boffset (index+ buffer-boffset 16))
+		(src-chunk 0)
+		(dst-chunk 0)
+		(offset 0)
+		(overall-width 0)
+		(stop-p nil))
+	       ((or stop-p (zerop length))
+		;; Ensure terminated with zero bytes
+		(do ((end (the array-index (lround boffset))))
+		    ((index>= boffset end))
+		  (setf (aref buffer-bbuf boffset) 0)
+		  (index-incf boffset))
+		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
+		(setf (buffer-boffset display) boffset)
+		(unless (index-zerop length) (setq next-start src-start))
+		(when overall-width (setq width overall-width)))
+
+	    (declare (type array-index src-chunk dst-chunk offset)
+		     (type (or null int32) overall-width)
+		     (type boolean stop-p))
+	    (setq src-chunk (index-min length *max-string-size*))
+	    (multiple-value-bind (new-start new-font translated-width)
+		(funcall translate
+			 sequence src-start (index+ src-start src-chunk)
+			 font buffer-bbuf (index+ boffset 2))
+	      (setq dst-chunk (index- new-start src-start)
+		    length (index- length dst-chunk)
+		    src-start new-start)
+	      (if translated-width
+		  (when overall-width (incf overall-width translated-width))
+		(setq overall-width nil))
+	      (when (index-plusp dst-chunk)
+		(setf (aref buffer-bbuf boffset) dst-chunk)
+		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
+		(incf boffset (index+ dst-chunk 2)))
+	      (setq offset 0)
+	      (cond ((null new-font)
+		     ;; Don't stop if translate copied whole chunk
+		     (unless (index= src-chunk dst-chunk)
+		       (setq stop-p t)))
+		    ((integerp new-font) (setq offset new-font))
+		    ((type? new-font 'font)
+		     (setq font new-font)
+		     (let ((font-id (font-id font))
+			   (buffer-boffset boffset))
+		       (declare (type resource-id font-id)
+				(type array-index buffer-boffset))
+		       ;; This changes the gcontext font in the server
+		       ;; Update the gcontext cache (both local and server state)
+		       (let ((local-state (gcontext-local-state gcontext))
+			     (server-state (gcontext-server-state gcontext)))
+			 (declare (type gcontext-state local-state server-state))
+			 (setf (gcontext-internal-font-obj server-state) font
+			       (gcontext-internal-font server-state) font-id)
+			 (without-interrupts
+			   (setf (gcontext-internal-font-obj local-state) font
+				 (gcontext-internal-font local-state) font-id)))
+		       (card8-put 0 #xff)
+		       (card8-put 1 (ldb (byte 8 24) font-id))
+		       (card8-put 2 (ldb (byte 8 16) font-id))
+		       (card8-put 3 (ldb (byte 8 8) font-id))
+		       (card8-put 4 (ldb (byte 8 0) font-id)))
+		     (index-incf boffset 5)))
+	      )))))
+    (values next-start width)))
+
+;; NOTE: After the first font change by the TRANSLATE function, characters are no-longer
+;;       on 16bit boundaries and this function garbles the bytes.
+(defun draw-glyphs16 (drawable gcontext x y sequence start end translate width)
+  ;; First result is new start, if end was not reached.  Second result is
+  ;; overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start end)
+	   (type int32 width)
+	   (type sequence sequence))
+  (declare (values (or null array-index) (or null int32)))
+  (declare (type translation-function translate)
+	   (downward-funarg translate))
+  (let* ((src-start start)
+	 (src-end (or end (length sequence)))
+	 (next-start nil)
+	 (length (index- src-end src-start))
+	 (request-length (* length 3))		; Leave lots of room for font shifts.
+	 (display (gcontext-display gcontext))
+	 ;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	 (font (gcontext-font gcontext t))
+	 (buffer (display-tbuf16 display)))
+    (declare (type array-index src-start src-end length)
+	     (type (or null array-index) next-start)
+	     (type display display)
+	     (type buffer-text16 buffer))
+    (with-buffer-request (display *x-polytext16* :gc-force gcontext :length request-length)
+      (drawable drawable)
+      (gcontext gcontext)
+      (int16 x y)
+      (progn
+	;; Don't let any flushes happen since we manually set the request
+	;; length when we're done.
+	(with-buffer-flush-inhibited (display)
+	  (do* ((boffset (index+ buffer-boffset 16))
+		(src-chunk 0)
+		(dst-chunk 0)
+		(offset 0)
+		(overall-width 0)
+		(stop-p nil))
+	       ((or stop-p (zerop length))
+		;; Ensure terminated with zero bytes
+		(do ((end (lround boffset)))
+		    ((index>= boffset end))
+		  (setf (aref buffer-bbuf boffset) 0)
+		  (index-incf boffset))
+		(length-put 2 (index-ash (index- boffset buffer-boffset) -2))
+		(setf (buffer-boffset display) boffset)
+		(unless (zerop length) (setq next-start src-start))
+		(when overall-width (setq width overall-width)))
+
+	    (declare (type array-index boffset src-chunk dst-chunk offset)
+		     (type (or null int32) overall-width)
+		     (type boolean stop-p))
+	    (setq src-chunk (index-min length *max-string-size*))
+	    (multiple-value-bind (new-start new-font translated-width)
+		(funcall translate
+			 sequence src-start (index+ src-start src-chunk)
+			 font buffer 0)
+	      (setq dst-chunk (index- new-start src-start)
+		    length (index- length dst-chunk)
+		    src-start new-start)
+	      (write-sequence-card16 display (index+ boffset 2) buffer 0 dst-chunk
+				     #+clx-little-endian ;; Byte swap for little-endian
+				     #'byte-swap-card16)
+	      (if translated-width
+		  (when overall-width (incf overall-width translated-width))
+		(setq overall-width nil))
+	      (when (index-plusp dst-chunk)
+		(setf (aref buffer-bbuf boffset) dst-chunk)
+		(setf (aref buffer-bbuf (index+ boffset 1)) offset)
+		(index-incf boffset (index+ dst-chunk dst-chunk 2)))
+	      (setq offset 0)
+	      (cond ((null new-font)
+		     ;; Don't stop if translate copied whole chunk
+		     (unless (index= src-chunk dst-chunk) 
+		       (setq stop-p t)))
+		    ((integerp new-font) (setq offset new-font))
+		    ((type? new-font 'font)
+		     (setq font new-font)
+		     (let ((font-id (font-id font))
+			   (buffer-boffset boffset))
+		       (declare (type resource-id font-id)
+				(type array-index buffer-boffset))
+		       ;; This changes the gcontext font in the SERVER
+		       ;; Update the gcontext cache (both local and server state)
+		       (let ((local-state (gcontext-local-state gcontext))
+			     (server-state (gcontext-server-state gcontext)))
+			 (declare (type gcontext-state local-state server-state))
+			 (setf (gcontext-internal-font-obj server-state) font
+			       (gcontext-internal-font server-state) font-id)
+			 (without-interrupts
+			   (setf (gcontext-internal-font-obj local-state) font
+				 (gcontext-internal-font local-state) font-id)))
+		       (card8-put 0 #xff)
+		       (card8-put 1 (ldb (byte 8 24) font-id))
+		       (card8-put 2 (ldb (byte 8 16) font-id))
+		       (card8-put 3 (ldb (byte 8 8) font-id))
+		       (card8-put 4 (ldb (byte 8 0) font-id)))
+		     (index-incf boffset 5)))
+	      )))))
+    (values next-start width)))
+
+(defun draw-image-glyph (drawable gcontext x y elt
+			 &key translate width (size :default))
+  ;; Returns true if elt is output, nil if translate refuses to output it.
+  ;; Second result is overall width, if known.  An initial font change is
+  ;; allowed from translate.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values boolean (or null int32)))
+  (let* ((display (gcontext-display gcontext))
+	 (result t)
+	 (opcode *x-imagetext8*))
+    (declare (type display display))
+    (let ((vector (allocate-gcontext-state)))
+      (declare (type gcontext-state vector))
+      (setf (aref vector 0) elt)
+      (multiple-value-bind (new-start new-font translate-width)
+	  (funcall (or translate #'translate-default)
+		   vector 0 1 (gcontext-font gcontext t) vector 1)
+	;; Allow translate to set a new font
+	(when (type? new-font 'font) 
+	  (setf (gcontext-font gcontext) new-font)
+	  (multiple-value-setq (new-start new-font translate-width)
+	    (funcall translate vector 0 1 new-font vector 1)))
+	;; If new-start is zero, translate refuses to output it
+	(setq result (index-plusp new-start)
+	      elt (aref vector 1))
+	(deallocate-gcontext-state vector)
+	(when translate-width (setq width translate-width))))
+    (when result
+      (when (eql size 16)
+	(setq opcode *x-imagetext16*)
+	(setq elt (dpb elt (byte 8 8) (ldb (byte 8 8) elt))))
+      (with-buffer-request (display opcode :gc-force gcontext)
+	(drawable drawable)
+	(gcontext gcontext)
+	(data 1) ;; 1 character
+	(int16 x y)
+	(card8 (ldb (byte 8 0) elt))
+	(card8 (ldb (byte 8 8) elt)))
+      (values t width))))
+
+(defun draw-image-glyphs (drawable gcontext x y sequence
+			  &key (start 0) end width translate (size :default))
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type (or null array-index) end)
+	   (type sequence sequence)
+	   (type (or null int32) width)
+	   (type index-size size))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg #+Genera * #-Genera translate))
+  (declare (values (or null array-index) (or null int32)))
+  (unless end (setq end (length sequence)))
+  (ecase size
+    ((:default 8)
+     (draw-image-glyphs8 drawable gcontext x y sequence start end width translate))
+    (16
+     (draw-image-glyphs16 drawable gcontext x y sequence start end width translate))))
+
+(defun draw-image-glyphs8 (drawable gcontext x y sequence start end width translate)
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width)) 
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg translate))
+  (declare (values (or null array-index) (or null int32)))
+  (do* ((display (gcontext-display gcontext))
+	(length (index- end start))
+	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	(font (gcontext-font gcontext t))
+	(font-change nil)
+	(new-start) (translated-width) (chunk))
+       (nil) ;; forever
+    (declare (type display display)
+	     (type array-index length)
+	     (type (or null array-index) new-start chunk))
+    
+    (when font-change
+      (setf (gcontext-font gcontext) font))
+    (block change-font
+      (with-buffer-request (display *x-imagetext8* :gc-force gcontext :length length)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(progn
+	  ;; Don't let any flushes happen since we manually set the request
+	  ;; length when we're done.
+	  (with-buffer-flush-inhibited (display)
+	    ;; Translate the sequence into the buffer
+	    (multiple-value-setq (new-start font translated-width)
+	      (funcall (or translate #'translate-default) sequence start end
+		       font buffer-bbuf (index+ buffer-boffset 16)))
+	    ;; Number of glyphs translated
+	    (setq chunk (index- new-start start))		
+	    ;; Check for initial font change
+	    (when (and (index-zerop chunk) (type? font 'font))
+	      (setq font-change t) ;; Loop around changing font
+	      (return-from change-font))
+	    ;; Quit when nothing translated
+	    (when (index-zerop chunk)
+	      (return-from draw-image-glyphs8 new-start))
+	    ;; Update buffer pointers
+	    (data-put 1 chunk)
+	    (let ((blen (lround (index+ 16 chunk))))
+	      (length-put 2 (index-ash blen -2))
+	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
+      ;; Normal exit
+      (return-from draw-image-glyphs8
+	(values (if (index= chunk length) nil new-start)
+		(or translated-width width))))))
+
+(defun draw-image-glyphs16 (drawable gcontext x y sequence start end width translate)
+  ;; An initial font change is allowed from translate, but any subsequent font
+  ;; change or horizontal motion will cause termination (because the protocol
+  ;; doesn't support chaining).  [Alternatively, font changes could be accepted
+  ;; as long as they are accompanied with a width return value, or always
+  ;; accept font changes and call text-width as required.  However, horizontal
+  ;; motion can't really be accepted, due to semantics.]  First result is new
+  ;; start, if end was not reached.  Second result is overall width, if known.
+  (declare (type drawable drawable)
+	   (type gcontext gcontext)
+	   (type int16 x y)
+	   (type array-index start)
+	   (type sequence sequence)
+	   (type (or null array-index) end)
+	   (type (or null int32) width))
+  (declare (type (or null translation-function) translate)
+	   (downward-funarg translate))
+  (declare (values (or null array-index) (or null int32)))
+  (do* ((display (gcontext-display gcontext))
+	(length (index- end start))
+	;; Should metrics-p be T?  Don't want to pass a NIL font into translate...
+	(font (gcontext-font gcontext t)) 
+	(font-change nil)
+	(new-start) (translated-width) (chunk)
+	(buffer (buffer-tbuf16 display)))
+       (nil) ;; forever
+    
+    (declare (type display display)
+	     (type array-index length)
+	     (type (or null array-index) new-start chunk)
+	     (type buffer-text16 buffer))
+    (when font-change
+      (setf (gcontext-font gcontext) font))
+
+    (block change-font
+      (with-buffer-request (display *x-imagetext16* :gc-force gcontext :length length)
+	(drawable drawable)
+	(gcontext gcontext)
+	(int16 x y)
+	(progn
+	  ;; Don't let any flushes happen since we manually set the request
+	  ;; length when we're done.
+	  (with-buffer-flush-inhibited (display)
+	    ;; Translate the sequence into the buffer
+	    (multiple-value-setq (new-start font translated-width)
+	      (funcall (or translate #'translate-default) sequence start end
+		       font buffer 0))
+	    ;; Number of glyphs translated
+	    (setq chunk (index- new-start start))
+	    ;; Check for initial font change
+	    (when (and (index-zerop chunk) (type? font 'font))
+	      (setq font-change t) ;; Loop around changing font
+	      (return-from change-font))
+	    ;; Quit when nothing translated
+	    (when (index-zerop chunk)
+	      (return-from draw-image-glyphs16 new-start))
+	    (write-sequence-card16 display (index+ buffer-boffset 16) buffer 0 chunk
+				   #+clx-little-endian ;; Byte swap for little-endian
+				   #'byte-swap-card16)
+	    ;; Update buffer pointers
+	    (data-put 1 chunk)
+	    (let ((blen (lround (index+ 16 (index-ash chunk 1)))))
+	      (length-put 2 (index-ash blen -2))
+	      (setf (buffer-boffset display) (index+ buffer-boffset blen))))))
+      ;; Normal exit
+      (return-from draw-image-glyphs16
+	(values (if (index= chunk length) nil new-start)
+		(or translated-width width))))))
+
+
+;;-----------------------------------------------------------------------------
+
+(defun display-keycode-range (display)
+  (declare (type display display))
+  (declare (values min max))
+  (values (display-min-keycode display)
+	  (display-max-keycode display)))
+
+;; Should this signal device-busy like the pointer-mapping setf, and return a
+;; boolean instead (true for success)?  Alternatively, should the
+;; pointer-mapping setf be changed to set-pointer-mapping with a (member
+;; :success :busy) result?
+
+(defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
+  ;; Setf ought to allow multiple values.
+  (declare (type display display)
+	   (type sequence shift lock control mod1 mod2 mod3 mod4 mod5))
+  (declare (values (member :success :busy :failed)))
+  (let* ((keycodes-per-modifier (index-max (length shift)
+					   (length lock)
+					   (length control)
+					   (length mod1)
+					   (length mod2)
+					   (length mod3)
+					   (length mod4)
+					   (length mod5)))
+	 (data (make-array (index* 8 keycodes-per-modifier)
+			   :element-type 'card8
+			   :initial-element 0)))
+    (replace data shift)
+    (replace data lock :start1 keycodes-per-modifier)
+    (replace data control :start1 (index* 2 keycodes-per-modifier))
+    (replace data mod1 :start1 (index* 3 keycodes-per-modifier))
+    (replace data mod2 :start1 (index* 4 keycodes-per-modifier))
+    (replace data mod3 :start1 (index* 5 keycodes-per-modifier))
+    (replace data mod4 :start1 (index* 6 keycodes-per-modifier))
+    (replace data mod5 :start1 (index* 7 keycodes-per-modifier))
+    (with-buffer-request-and-reply (display *x-setmodifiermapping* 4 :sizes 8)
+	 ((data keycodes-per-modifier)
+	  ((sequence :format card8) data))
+      (values (member8-get 1 :success :busy :failed)))))
+
+(defun modifier-mapping (display)
+  ;; each value is a list of integers
+  (declare (type display display))
+  (declare (values shift lock control mod1 mod2 mod3 mod4 mod5))
+  (let ((lists nil))
+    (with-buffer-request-and-reply (display *x-getmodifiermapping* nil :sizes 8)
+	 ()
+      (do* ((keycodes-per-modifier (card8-get 1))
+	    (advance-by *replysize* keycodes-per-modifier)
+	    (keys nil nil)
+	    (i 0 (index+ i 1)))
+	   ((index= i 8))
+	(advance-buffer-offset advance-by)
+	(dotimes (j keycodes-per-modifier)
+	  (let ((key (read-card8 j)))
+	    (unless (zerop key)
+	      (push key keys))))
+	(push (nreverse keys) lists)))
+    (values-list (nreverse lists))))
+
+;; Either we will want lots of defconstants for well-known values, or perhaps
+;; an integer-to-keyword translation function for well-known values.
+
+(defun change-keyboard-mapping
+       (display keysyms &key (start 0) end (first-keycode start))
+  ;; start/end give subrange of keysyms
+  ;; first-keycode is the first-keycode to store at
+  (declare (type display display)
+	   (type array-index start)
+	   (type card8 first-keycode)
+	   (type (or null array-index) end)
+	   (type (array * (* *)) keysyms))
+  (let* ((keycode-end (or end (array-dimension keysyms 0)))
+	 (keysyms-per-keycode (array-dimension keysyms 1))
+	 (length (index- keycode-end start))
+	 (size (index* length keysyms-per-keycode))
+	 (request-length (index+ size 2)))
+    (declare (type array-index keycode-end keysyms-per-keycode length request-length))
+    (with-buffer-request (display *x-setkeyboardmapping*
+				  :length (index-ash request-length 2)
+				  :sizes (32))
+      (data length)
+      (length request-length)
+      (card8 first-keycode keysyms-per-keycode)
+      (progn
+	(do ((limit (index-ash (buffer-size display) -2))
+	     (w (index+ 2 (index-ash buffer-boffset -2)))
+	     (i start (index+ i 1)))
+	    ((index>= i keycode-end)
+	     (setf (buffer-boffset display) (index-ash w 2)))
+	  (declare (type array-index limit w i))
+	  (when (index> w limit)
+	    (buffer-flush display)
+	    (setq w (index-ash (buffer-boffset display) -2)))
+	  (do ((j 0 (index+ j 1)))
+	      ((index>= j keysyms-per-keycode))
+	    (declare (type array-index j))
+	    (card29-put (index* w 4) (aref keysyms i j))
+	    (index-incf w))))))) 
+
+(defun keyboard-mapping (display &key first-keycode start end data)
+  ;; First-keycode specifies which keycode to start at (defaults to min-keycode).
+  ;; Start specifies where (in result) to put first-keycode. (defaults to first-keycode)
+  ;; (- end start) is the number of keycodes to get. (End defaults to (1+ max-keycode)).
+  ;; If DATA is specified, the results are put there.
+  (declare (type display display)
+	   (type (or null card8) first-keycode)
+	   (type (or null array-index) start end)
+	   (type (or null (array * (* *))) data))
+  (declare (values (array * (* *))))
+  (unless first-keycode (setq first-keycode (display-min-keycode display)))
+  (unless start (setq start first-keycode))
+  (unless end (setq end (1+ (display-max-keycode display))))
+  (with-buffer-request-and-reply (display *x-getkeyboardmapping* nil :sizes (8 32))
+       ((card8 first-keycode (index- end start)))
+    (do* ((keysyms-per-keycode (card8-get 1))
+	  (bytes-per-keycode (* keysyms-per-keycode 4))
+	  (advance-by *replysize* bytes-per-keycode)
+	  (keycode-count (floor (card32-get 4) keysyms-per-keycode)
+			 (index- keycode-count 1))
+	  (result (if (and (arrayp data)
+			   (= (array-rank data) 2)
+			   (>= (array-dimension data 0) (index+ start keycode-count))
+			   (>= (array-dimension data 1) keysyms-per-keycode))
+		      data
+		    (make-array `(,(index+ start keycode-count) ,keysyms-per-keycode)
+				:element-type 'keysym :initial-element 0)))
+	  (i start (1+ i)))
+	 ((zerop keycode-count) (setq data result))
+      (advance-buffer-offset advance-by)
+      (dotimes (j keysyms-per-keycode)
+	(setf (aref result i j) (card29-get (* j 4))))))
+  data)
diff --git a/clx/translate.lisp b/clx/translate.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..18434e4ba55512f02e99bdeb91a7008988bcd3c9
--- /dev/null
+++ b/clx/translate.lisp
@@ -0,0 +1,619 @@
+;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
+
+;;;
+;;;			 TEXAS INSTRUMENTS INCORPORATED
+;;;				  P.O. BOX 2909
+;;;			       AUSTIN, TEXAS 78769
+;;;
+;;; Copyright (C) 1987 Texas Instruments Incorporated.
+;;;
+;;; Permission is granted to any individual or institution to use, copy, modify,
+;;; and distribute this software, provided that this complete copyright and
+;;; permission notice is maintained, intact, in all copies and supporting
+;;; documentation.
+;;;
+;;; Texas Instruments Incorporated provides this software "as is" without
+;;; express or implied warranty.
+;;;
+
+(in-package :xlib)
+
+(export '(define-keysym-set
+	  keysym-set
+	  define-keysym
+	  undefine-keysym
+	  default-keysym-translate
+	  keysym
+	  character->keysyms
+	  keycode->keysym 
+	  keysym->character
+	  default-keysym-index
+	  keycode->character
+	  state-keysym-p
+	  mapping-notify
+	  keysym-in-map-p
+	  character-in-map-p
+	  keysym->keycodes
+	  ))
+
+(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
+
+(defun define-keysym-set (set first-keysym last-keysym)
+  ;; Define all keysyms from first-keysym up to and including
+  ;; last-keysym to be in SET (returned from the keysym-set function).
+  ;; Signals an error if the keysym range overlaps an existing set.
+ (declare (type keyword set)
+	  (type keysym first-keysym last-keysym))
+  (when (> first-keysym last-keysym)
+    (rotatef first-keysym last-keysym))
+  (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
+  (dolist (set *keysym-sets*)
+    (let ((first (second set))
+	  (last (third set)))
+      (when (or (<= first first-keysym last)
+		(<= first last-keysym last))
+	(error "Keysym range overlaps existing set ~s" set))))
+  (push (list set first-keysym last-keysym) *keysym-sets*)
+  set)
+
+(defun keysym-set (keysym)
+  ;; Return the character code set name of keysym
+  (declare (type keysym keysym)
+	   (values keyword))
+  (dolist (set *keysym-sets*)
+    (let ((first (second set))
+	  (last (third set)))
+      (when (<= first keysym last)
+	(return (first set))))))
+
+(eval-when (compile eval load) ;; Required for Vaxlisp ...
+(defmacro keysym (keysym &rest bytes)
+  ;; Build a keysym.
+  ;; If KEYSYM is an integer, it is used as the most significant bits of
+  ;; the keysym, and BYTES are used to specify low order bytes. The last
+  ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
+  ;; integer, the keysym associated with KEYSYM is returned.
+  ;;
+  ;; This is a macro and not a function macro to promote compile-time
+  ;; lookup. All arguments are evaluated.
+  (declare (type t keysym)
+	   (type list bytes)
+	   (values keysym))
+  (typecase keysym
+    ((integer 0)
+     (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
+    (otherwise
+     (or (car (character->keysyms keysym))
+	 (error "~s Isn't the name of a keysym" keysym)))))
+)
+
+(defvar *keysym->character-map*
+	(make-hash-table :test (keysym->character-map-test) :size 400))
+
+;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
+;; With the following accessor macros. Everything after OBJECT is optional.
+
+(defmacro keysym-mapping-object (keysym-mapping)
+  ;; Parameter to translate
+  `(first ,keysym-mapping))
+
+(defmacro keysym-mapping-translate (keysym-mapping)
+  ;; Function to be called with parameters (display state OBJECT)
+  ;; when translating KEYSYM and modifiers and mask are satisfied.
+  `(second ,keysym-mapping))
+
+(defmacro keysym-mapping-lowercase (keysym-mapping)
+  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
+  ;; is the associated lowercase keysym.
+  `(third ,keysym-mapping))
+
+(defmacro keysym-mapping-modifiers (keysym-mapping)
+  ;; MODIFIERS is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying when to use this
+  ;; keysym-translation.
+  `(fourth ,keysym-mapping))
+
+(defmacro keysym-mapping-mask (keysym-mapping)
+  ;; MASK is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying which modifiers to look at
+  ;; (i.e.  modifiers not specified are don't-cares)
+  `(fifth ,keysym-mapping))
+
+(defvar *default-keysym-translate-mask*
+	(the (or (member :modifiers) mask16 list)	; (list (or keysym state-mask-key))
+	     (logand #xff (lognot (make-state-mask :lock))))
+  "Default keysym state mask to use during keysym-translation.")
+
+(defun define-keysym (object keysym &key lowercase translate modifiers mask display)	              
+  ;; Define the translation from keysym/modifiers to a (usually
+  ;; character) object.  ANy previous keysym definition with
+  ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
+  ;;
+  ;; MODIFIERS is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying when to use this
+  ;; keysym-translation.  The default is NIL.
+  ;;
+  ;; MASK is either a modifier-mask or list containing intermixed
+  ;; keysyms and state-mask-keys specifying which modifiers to look at
+  ;; (i.e.  modifiers not specified are don't-cares).
+  ;; If mask is :MODIFIERS then the mask is the same as the modifiers
+  ;; (i.e.  modifiers not specified by modifiers are don't cares)
+  ;; The default mask is *default-keysym-translate-mask*
+  ;;
+  ;; If DISPLAY is specified, the translation will be local to DISPLAY,
+  ;; otherwise it will be the default translation for all displays.
+  ;;
+  ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
+  ;; is the associated lowercase keysym.  This information is used
+  ;; by the keysym-both-case-p predicate (for caps-lock computations)
+  ;; and by the keysym-downcase function.
+  ;;
+  ;; TRANSLATE will be called with parameters (display state OBJECT)
+  ;; when translating KEYSYM and modifiers and mask are satisfied.
+  ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
+  ;;                     (or modifiers 0)))
+  ;;      when mask and modifiers aren't lists of keysyms]
+  ;; The default is #'default-keysym-translate
+  ;;
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key))
+	         mask)
+	   (type (or null display) display)
+           (type (or null keysym) lowercase)
+	   (type (function (display card16 t) t) translate))
+  (flet ((merge-keysym-mappings (new old)
+	   ;; Merge new keysym-mapping with list of old mappings.
+	   ;; Ensure that the mapping with no modifiers or mask comes first.
+	   (let* ((key (keysym-mapping-modifiers new))
+		  (merge (delete key old :key #'cadddr :test #'equal)))
+	     (if key
+		 (nconc merge (list new))
+	       (cons new merge))))
+	 (mask-check (mask)
+	   (unless (or (numberp mask)
+		       (dolist (element mask t)
+			 (unless (or (find element *state-mask-vector*)
+				     (gethash element *keysym->character-map*))
+			   (return nil))))
+	     (x-type-error mask '(or mask16 (list (or modifier-key modifier-keysym)))))))
+    (let ((entry
+	    ;; Create with a single LIST call, to ensure cdr-coding
+	    (cond
+	      (mask
+	       (unless (eq mask :modifiers)
+		 (mask-check mask))
+	       (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
+		 (error "Mask with no modifiers"))
+	       (list object translate lowercase modifiers mask))
+	      (modifiers (mask-check modifiers)
+			 (list object translate lowercase modifiers))
+	      (lowercase	(list object translate lowercase))
+	      (translate	(list object translate))
+	      (t	(list object)))))
+      (if display
+	  (let ((previous (assoc keysym (display-keysym-translation display))))
+	    (if previous
+		(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
+	      (push (list keysym entry) (display-keysym-translation display))))
+	(setf (gethash keysym *keysym->character-map*)
+	      (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
+    object))
+
+(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)	              
+  ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
+  ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
+  (declare (type (or string-char t) object)
+	   (type keysym keysym)
+	   (type (or null mask16 list) ;; (list (or keysym state-mask-key))
+	         modifiers)
+	   (type (or null display) display))
+  (flet ((match (key entry)
+	   (let ((object (car key))
+		 (modifiers (cdr key)))
+	     (or (eql object (keysym-mapping-object entry))
+		 (equal modifiers (keysym-mapping-modifiers entry))))))
+    (let* (entry
+	   (previous (if display
+			 (cdr (setq entry (assoc keysym (display-keysym-translation display))))
+		       (gethash keysym *keysym->character-map*)))
+	   (key (cons object modifiers)))
+      (when (and previous (find key previous :test #'match))
+	(setq previous (delete key previous :test #'match))
+	(if display
+	    (setf (cdr entry) previous)
+	  (setf (gethash keysym *keysym->character-map*) previous))))))
+
+(defun keysym-downcase (keysym)
+  ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
+  (declare (type keysym keysym))
+  (declare (values keysym))
+  (let ((translations (gethash keysym *keysym->character-map*)))
+    (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
+
+(defun keysym-uppercase-alphabetic-p (keysym)
+  ;; Returns T if keysym is uppercase-alphabetic.
+  ;; I.E. If it has a lowercase equivalent.
+  (declare (type keysym keysym))
+  (declare (values (or null keysym)))
+  (let ((translations (gethash keysym *keysym->character-map*)))
+    (and translations
+	 (keysym-mapping-lowercase (first translations)))))
+
+(defun character->keysyms (character &optional display)
+  ;; Given a character, return a list of all matching keysyms.
+  ;; If DISPLAY is given, translations specific to DISPLAY are used,
+  ;; otherwise only global translations are used.
+  ;; Implementation dependent function.
+  ;; May be slow [i.e. do a linear search over all known keysyms]
+  (declare (type t character)
+	   (type (or null display) display)
+	   (values (list keysym)))
+  (let ((result nil))
+    (when display
+      (dolist (mapping (display-keysym-translation display))
+	(when (eql character (second mapping))
+	  (push (first mapping) result))))
+    (maphash #'(lambda (keysym mappings)
+		 (dolist (mapping mappings)
+		   (when (eql (keysym-mapping-object mapping) character)
+		     (pushnew keysym result))))
+	     *keysym->character-map*)
+    result))
+
+(eval-when (compile eval load) ;; Required for Symbolics...
+(defconstant character-set-switch-keysym (keysym 255 126))
+(defconstant left-shift-keysym (keysym 255 225))
+(defconstant right-shift-keysym (keysym 255 226))
+(defconstant left-control-keysym (keysym 255 227))
+(defconstant right-control-keysym (keysym 255 228))
+(defconstant caps-lock-keysym (keysym 255 229))
+(defconstant shift-lock-keysym (keysym 255 230))
+(defconstant left-meta-keysym (keysym 255 231))
+(defconstant right-meta-keysym (keysym 255 232))
+(defconstant left-alt-keysym (keysym 255 233))
+(defconstant right-alt-keysym (keysym 255 234))
+(defconstant left-super-keysym (keysym 255 235))
+(defconstant right-super-keysym (keysym 255 236))
+(defconstant left-hyper-keysym (keysym 255 237))
+(defconstant right-hyper-keysym (keysym 255 238))
+) ;; end eval-when
+
+
+;;-----------------------------------------------------------------------------
+;; Keysym mapping functions
+
+(defun display-keyboard-mapping (display)
+  (declare (type display display))
+  (declare (values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
+  (or (display-keysym-mapping display)
+      (setf (display-keysym-mapping display) (keyboard-mapping display))))
+
+(defun keycode->keysym (display keycode keysym-index)
+  (declare (type display display)
+	   (type card8 keycode)
+	   (type card8 keysym-index)
+	   (values keysym))
+  (let* ((mapping (display-keyboard-mapping display))
+	 (keysym (aref mapping keycode keysym-index)))
+    (declare (type (simple-array keysym (* *)) mapping)
+	     (type keysym keysym))
+    ;; The keysym-mapping is brain dammaged.
+    ;; Mappings for both-case alphabetic characters have the
+    ;; entry for keysym-index zero set to the uppercase keysym
+    ;; (this is normally where the lowercase keysym goes), and the
+    ;; entry for keysym-index one is zero.
+    (cond ((zerop keysym-index)			; Lowercase alphabetic keysyms
+	   (keysym-downcase keysym))
+	  ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
+	   (aref mapping keycode 0))
+	  (t keysym))))
+
+(defun keysym->character (display keysym &optional (state 0))
+  ;; Find the character associated with a keysym.
+  ;; STATE is used for adding char-bits to character as follows:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type card16 state))
+  (declare (values (or null character)))
+  (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
+	 (mapping (or ;; Find the matching display mapping
+		      (dolist (mapping display-mappings)
+			(when (mapping-matches-p display state mapping)
+			  (return mapping)))
+		      ;; Find the matching static mapping
+		      (dolist (mapping (gethash keysym *keysym->character-map*))
+			(when (mapping-matches-p display state mapping)
+			  (return mapping))))))
+    (when mapping
+      (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
+	       display state (keysym-mapping-object mapping)))))
+
+(defun mapping-matches-p (display state mapping)
+  ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
+  (declare (type display display)
+	   (type mask16 state)
+	   (type list mapping))
+  (declare (values boolean))
+  (flet
+    ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
+       ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
+       ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
+       ;; otherwise ignore unknown modifiers.
+       (declare (type list display-mapping)	; Alist of (keysym . mask)
+		(type (or mask16 list) modifiers)
+		(type mask16 mask))
+       (declare (values (or null mask16)))
+       (if (numberp modifiers)
+	   modifiers
+	 (dolist (modifier modifiers mask)
+	   (declare (type symbol modifier))
+	   (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
+	     (setq mask
+		   (logior mask
+			   (if bit
+			       (ash 1 bit)
+			     (or (cdr (assoc modifier display-mapping))
+				 ;; bad modifier
+				 (if errorp
+				     (return-from modifiers->mask nil)
+				   0))))))))))
+
+    (let* ((display-mapping (get-display-modifier-mapping display))
+	   (mapping-modifiers (keysym-mapping-modifiers mapping))
+	   (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
+			  (return-from mapping-matches-p nil)))
+	   (mapping-mask (or (keysym-mapping-mask mapping)	; If no mask, use the default.
+			     (if mapping-modifiers	        ; If no modifiers, match anything.
+				 *default-keysym-translate-mask*
+			       0)))
+	   (mask (if (eq mapping-mask :modifiers)
+		     modifiers
+		   (modifiers->mask display-mapping mapping-mask nil))))
+      (declare (type mask16 modifiers mask))
+      (= (logand state mask) modifiers))))
+
+(defun default-keysym-translate (display state object)
+  ;; If object is a character, char-bits are set from state.
+  ;;
+  ;; [the following isn't implemented (should it be?)]
+  ;; If object is a list, it is an alist with entries:
+  ;; (string-char [modifiers] [mask-modifiers])
+  ;; When MODIFIERS are specified, this character translation
+  ;; will only take effect when the specified modifiers are pressed.
+  ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
+  ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
+  ;; In ambiguous cases, the most specific translation is used.
+  (declare (type display display)
+	   (type card16 state)
+	   (type t object))
+  (declare (values t)) ;; Object returned by keycode->character
+  (macrolet ((keystate-p (state keyword)
+			 `(the boolean
+			       (logbitp ,(position keyword *state-mask-vector*)
+					,state))))
+    (when (characterp object)
+      (when (keystate-p state :control)
+	(setf (char-bit object :control) 1))
+      (when (state-keysymp display state left-meta-keysym)
+	(setf (char-bit object :meta) 1))
+      (when (state-keysymp display state left-super-keysym)
+	(setf (char-bit object :super) 1))
+      (when (state-keysymp display state left-hyper-keysym)
+	(setf (char-bit object :hyper) 1))))
+  object)
+
+(defun default-keysym-index (display keycode state)
+  ;; Returns a keysym-index for use with keycode->character
+  (declare (values card8))
+  (macrolet ((keystate-p (state keyword)
+	       `(the boolean
+		     (logbitp ,(position keyword *state-mask-vector*)
+			      ,state))))
+    (let* ((mapping (display-keyboard-mapping display))
+	   (keysyms-per-keycode (array-dimension mapping 1))
+	   (symbolp (and (> keysyms-per-keycode 2)
+			 (state-keysymp display state character-set-switch-keysym)))
+	   (result (if symbolp 2 0)))
+      (declare (type (simple-array keysym (* *)) mapping)
+	       (type boolean symbolp)
+	       (type card8 keysyms-per-keycode result))
+      (when (and (< result keysyms-per-keycode)
+		 (keysym-shift-p display state (keysym-uppercase-alphabetic-p
+						 (aref mapping keycode 0))))
+	(incf result))
+      result)))
+
+(defun keysym-shift-p (display state uppercase-alphabetic-p &key
+		       shift-lock-xors
+		       (control-modifiers
+			 '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
+  (declare (type display display)
+	   (type card16 state)
+	   (type boolean uppercase-alphabetic-p)
+	   (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
+	                                  ;;; as neither if the character is alphabetic.
+  (declare (values boolean))
+  (macrolet ((keystate-p (state keyword)
+	       `(the boolean
+		     (logbitp ,(position keyword *state-mask-vector*)
+			      ,state))))
+    (let* ((controlp (or (keystate-p state :control)
+			 (dolist (modifier control-modifiers)
+			   (when (state-keysymp display state modifier)
+			     (return t)))))
+	   (shiftp (keystate-p state :shift))
+	   (lockp  (keystate-p state :lock))
+	   (alphap (or uppercase-alphabetic-p
+		       (not (state-keysymp display #.(make-state-mask :lock)
+					   caps-lock-keysym)))))
+      (declare (type boolean controlp shiftp lockp alphap))
+      ;; Control keys aren't affected by lock
+      (unless controlp
+	;; Not a control character - check state of lock modifier
+	(when (and lockp
+		   alphap
+		   (or (not shiftp) shift-lock-xors))	; Lock doesn't unshift unless shift-lock-xors
+	  (setq shiftp (not shiftp))))
+      shiftp)))
+
+;;; default-keysym-index implements the following tables:
+;;;
+;;; control shift caps-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\8
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\*
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-8
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-*
+;;;
+;;; control shift shift-lock character               character
+;;;   0       0       0       #\a                      #\8
+;;;   0       0       1       #\A                      #\*
+;;;   0       1       0       #\A                      #\*
+;;;   0       1       1       #\A                      #\8
+;;;   1       0       0       #\control-A              #\control-8
+;;;   1       0       1       #\control-A              #\control-*
+;;;   1       1       0       #\control-shift-a        #\control-*
+;;;   1       1       1       #\control-shift-a        #\control-8
+
+(defun keycode->character (display keycode state &key keysym-index
+	                   (keysym-index-function #'default-keysym-index))
+  ;; keysym-index defaults to the result of keysym-index-function which
+  ;; is called with the following parameters:
+  ;; (char0 state caps-lock-p keysyms-per-keycode)
+  ;; where char0 is the "character" object associated with keysym-index 0 and
+  ;; caps-lock-p is non-nil when the keysym associated with the lock
+  ;; modifier is for caps-lock.
+  ;; STATE is also used for setting char-bits:
+  ;;    control -> char-control-bit
+  ;;    mod-1 -> char-meta-bit
+  ;;    mod-2 -> char-super-bit
+  ;;    mod-3 -> char-hyper-bit
+  ;; Implementation dependent function.
+  (declare (type display display)
+	   (type card8 keycode)
+	   (type card16 state)
+	   (type (or null card8) keysym-index)
+	   (type (or null (function (string-char card16 boolean card8) card8))
+		 keysym-index-function))
+  (declare (values (or null character)))
+  (let* ((index (or keysym-index
+		    (funcall keysym-index-function display keycode state)))
+	 (keysym (if index (keycode->keysym display keycode index) 0)))
+    (declare (type (or null card8) index)
+	     (type keysym keysym))
+    (when (plusp keysym)
+      (keysym->character display keysym state))))
+
+(defun get-display-modifier-mapping (display)
+  (labels ((keysym-replace (display modifiers mask &aux result)
+	     (dolist (modifier modifiers result)
+	       (push (cons (keycode->keysym display modifier 0) mask) result))))
+    (or (display-modifier-mapping display)
+	(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
+	    (modifier-mapping display)
+	  (setf (display-modifier-mapping display)
+		(nconc (keysym-replace display shift #.(make-state-mask :shift))
+		       (keysym-replace display lock #.(make-state-mask :lock))
+		       (keysym-replace display control #.(make-state-mask :control))
+		       (keysym-replace display mod1 #.(make-state-mask :mod-1))
+		       (keysym-replace display mod2 #.(make-state-mask :mod-2))
+		       (keysym-replace display mod3 #.(make-state-mask :mod-3))
+		       (keysym-replace display mod4 #.(make-state-mask :mod-4))
+		       (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
+
+(defun state-keysymp (display state keysym)
+  ;; Returns T when a modifier key associated with KEYSYM is on in STATE
+  (declare (type display display)
+	   (type card16 state)
+	   (type keysym keysym))
+  (declare (values boolean))
+  (let* ((mapping (get-display-modifier-mapping display))
+	 (mask (assoc keysym mapping)))
+    (and mask (plusp (logand state (cdr mask))))))
+
+(defun mapping-notify (display request start count)
+  ;; Called on a mapping-notify event to update
+  ;; the keyboard-mapping cache in DISPLAY
+  (declare (type display display)
+	   (type (member :modifier :keyboard :pointer) request)
+	   (type card8 start count)
+	   (ignore count start))
+  ;; Invalidate the keyboard mapping to force the next key translation to get it
+  (case request
+    (:modifier 
+     (setf (display-modifier-mapping display) nil))
+    (:keyboard
+     (setf (display-keysym-mapping display) nil))))
+
+(defun keysym-in-map-p (display keysym keymap)
+  ;; Returns T if keysym is found in keymap
+  (declare (type display display)
+	   (type keysym keysym)
+	   (type (bit-vector 256) keymap))
+  (declare (values boolean))
+  ;; The keysym may appear in the keymap more than once,
+  ;; So we have to search the entire keysym map.
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(map (display-keyboard-mapping display))
+	(jmax (min 2 (array-dimension map 1)))
+	(i min (1+ i)))
+      ((> i max))
+    (declare (type card8 min max jmax)
+	     (type (simple-array keysym (* *)) map))
+    (when (and (plusp (aref keymap i))
+	       (dotimes (j jmax)
+		 (when (= keysym (aref map i j)) (return t))))
+      (return t))))
+
+(defun character-in-map-p (display character keymap)
+  ;; Implementation dependent function.
+  ;; Returns T if character is found in keymap
+  (declare (type display display)
+	   (type character character)
+	   (type (bit-vector 256) keymap))
+  (declare (values boolean))
+  ;; Check all one bits in keymap
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(jmax (array-dimension (display-keyboard-mapping display) 1))
+	(i min (1+ i)))
+      ((> i max))
+    (declare (type card8 min max jmax))
+    (when (and (plusp (aref keymap i))
+	       ;; Match when character is in mapping for this keycode
+	       (dotimes (j jmax)
+		 (when (eql character (keycode->character display i 0 :keysym-index j))
+		   (return t))))
+      (return t))))
+
+(defun keysym->keycodes (display keysym)
+  ;; Return keycodes for keysym, as multiple values
+  (declare (type display display)
+	   (type keysym keysym))
+  (declare (values (or null keycode) (or null keycode) (or null keycode)))
+  ;; The keysym may appear in the keymap more than once,
+  ;; So we have to search the entire keysym map.
+  (do* ((min (display-min-keycode display))
+	(max (display-max-keycode display))
+	(map (display-keyboard-mapping display))
+	(jmax (min 2 (array-dimension map 1)))
+	(i min (1+ i))
+	(result nil))
+      ((> i max) (values-list result))
+    (declare (type card8 min max jmax)
+	     (type (simple-array keysym (* *)) map))
+    (dotimes (j jmax)
+      (when (= keysym (aref map i j))
+	(push i result)))))
diff --git a/hemlock/abbrev.lisp b/hemlock/abbrev.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a314b76b605400e55fa0f37cbd4344f5a6f16bb5
--- /dev/null
+++ b/hemlock/abbrev.lisp
@@ -0,0 +1,682 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;		     Hemlock Word Abbreviation Mode
+;;;		          by Jamie W. Zawinski
+;;;		           24 September 1985
+;;;
+(in-package "HEMLOCK")
+
+;;;; These Things are Here:
+
+;;; C-X C-A    Add Mode Word Abbrev 
+;;;               Define a mode abbrev for the word before point.
+;;; C-X +      Add Global Word Abbrev 
+;;;               Define a global abbrev for the word before point.
+;;; C-X C-H    Inverse Add Mode Word Abbrev
+;;;               Define expansion for mode abbrev before point.
+;;; C-X -      Inverse Add Global Word Abbrev
+;;;               Define expansion for global abbrev before point.
+;;; Alt Space  Abbrev Expand Only
+;;;               Expand abbrev without inserting anything.
+;;; M-'        Word Abbrev Prefix Mark
+;;;               Mark a prefix to be glued to an abbrev following.
+;;; C-X U      Unexpand Last Word
+;;;               Unexpands last abbrev or undoes C-X U.
+
+;;; List Word Abbrevs                 Shows definitions of all word abbrevs.
+;;; Edit Word Abbrevs                 Lets you edit the definition list directly.
+;;; Read Word Abbrev File <filename>  Define word abbrevs from a definition file.
+;;; Write Word Abbrev File            Make a definition file from current abbrevs.
+
+;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
+;;; Delete All Word Abbrevs                      Wipes them all.
+;;; Delete Mode Word Abbrev                      Kills all Mode abbrev.
+;;; Delete Global Word Abbrev                    Kills all Global abbrev.
+
+;;; Insert Word Abbrevs          Inserts a list of current definitions in the
+;;;                                format that Define Word Abbrevs uses.
+;;; Define Word Abbrevs          Defines set of abbrevs from a definition list in 
+;;;                                the buffer.
+;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
+;;;                                definition, or mode.
+
+;;; Append Incremental Word Abbrev File           Appends to a file changed abbrev
+;;;                                                 definitions since last dumping.
+
+(defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0)
+
+
+(defvar *Global-Abbrev-Table* (make-hash-table :test #'equal)
+  "Hash table holding global abbrev definitions.")
+
+(defhvar "Abbrev Pathname Defaults"
+  "Holds the name of the last Abbrev-file written."
+  :value (pathname "abbrev.defns"))
+
+(defvar *new-abbrevs* ()
+ "holds a list of abbrevs (and their definitions and modes) changed since saving.")
+
+
+;;; C-X C-H    Inverse Add Mode Word Abbrev 
+;;;               Define a mode expansion for the word before point.
+
+(defcommand "Inverse Add Mode Word Abbrev" (p)
+  "Defines a mode word abbrev expansion for the word before the point."
+  "Defines a mode word abbrev expansion for the word before the point."
+  (declare (ignore p))
+  (let ((word (prev-word 1 (current-point)))
+	(mode (buffer-major-mode (current-buffer))))
+    (make-word-abbrev-command nil word nil mode)))
+
+
+;;; C-X C-A    Add Mode Word Abbrev
+;;;               Define mode abbrev for word before point.
+
+(defcommand "Add Mode Word Abbrev" (p)
+  "Defines a mode word abbrev for the word before the point.
+  With a positive argument, uses that many preceding words as the expansion.
+  With a zero argument, uses the region as the expansion.  With a negative
+  argument, prompts for a word abbrev to delete in the current mode."
+  "Defines or deletes a mode word abbrev."
+  (if (and p (minusp p))
+      (delete-mode-word-abbrev-command nil)
+      (let* ((val (if (eql p 0)
+		      (region-to-string (current-region nil))
+		      (prev-word (or p 1) (current-point))))
+	     (mode (buffer-major-mode (current-buffer))))
+	(make-word-abbrev-command nil nil val mode))))
+
+
+
+;;; C-X -    Inverse Add Global Word Abbrev
+;;;               Define global expansion for word before point.
+
+(defcommand "Inverse Add Global Word Abbrev" (p)
+  "Defines a Global expansion for the word before point."
+  "Defines a Global expansion for the word before point."
+  (declare (ignore p))
+  (let ((word (prev-word 1 (current-point))))
+    (make-word-abbrev-command nil word nil "Global")))
+
+
+
+;;; C-X +      Add Global Word Abbrev
+;;;               Define global Abbrev for word before point.
+
+(defcommand "Add Global Word Abbrev" (p)
+  "Defines a global word abbrev for the word before the point.
+  With a positive argument, uses that many preceding words as the expansion.
+  With a zero argument, uses the region as the expansion.  With a negative
+  argument, prompts for a global word abbrev to delete."
+  "Defines or deletes a global word abbrev."
+  (if (and p (minusp p))
+      (delete-global-word-abbrev-command nil)
+      (let ((val (if (eql p 0)
+		     (region-to-string (current-region nil))
+		     (prev-word (or p 1) (current-point)))))
+	(make-word-abbrev-command nil nil val "Global"))))
+
+
+;;;; Defining Abbrevs
+
+;;; Make Word Abbrev <abbrev><expansion><mode>  More General form of C-X C-A, etc.
+
+(defvar *global-abbrev-string-table*
+  (make-string-table :initial-contents '(("Global" . nil))))
+
+(defcommand "Make Word Abbrev" (p &optional abbrev expansion mode)
+  "Defines an arbitrary word abbreviation.
+  Prompts for abbrev, expansion, and mode."
+  "Makes Abbrev be a word abbreviation for Expansion when in Mode.  If
+  mode is \"Global\" then make a global abbrev."
+  (declare (ignore p))
+  (unless mode
+    (setq mode
+	  (prompt-for-keyword
+	   (list *mode-names* *global-abbrev-string-table*)
+	   :prompt "Mode of abbrev to add: "
+	   :default "Global"
+	   :help 
+	   "Type the mode of the Abbrev you want to add, or confirm for Global.")))
+  (let ((globalp (string-equal mode "Global")))
+    (unless (or globalp (mode-major-p mode))
+      (editor-error "~A is not a major mode." mode))
+    (unless abbrev
+      (setq abbrev
+	    (prompt-for-string
+	     :trim t
+	     :prompt
+	     (list "~A abbreviation~@[ of ~S~]: " mode expansion)
+	     :help
+	     (list "Define a ~A word abbrev." mode))))
+    (when (zerop (length abbrev))
+      (editor-error "Abbreviation must be at least one character long."))
+    (unless (every #'(lambda (ch)
+		       (zerop (character-attribute :word-delimiter ch)))
+		   (the simple-string abbrev))
+      (editor-error "Word Abbrevs must be a single word."))
+    (unless expansion
+      (setq expansion
+	    (prompt-for-string
+	     :prompt (list "~A expansion for ~S: " mode abbrev)
+	     :help (list "Define the ~A expansion of ~S." mode abbrev))))
+    (setq abbrev (string-downcase abbrev))
+    (let* ((table (cond (globalp *global-abbrev-table*)
+			((hemlock-bound-p 'Mode-Abbrev-Table :mode mode)
+			 (variable-value 'Mode-Abbrev-Table :mode mode))
+			(t
+			 (let ((new (make-hash-table :test #'equal)))
+			   (defhvar "Mode Abbrev Table"
+			     "Hash Table of Mode Abbrevs"
+			     :value new :mode mode)
+			   new))))
+	   (old (gethash abbrev table)))
+      (when (or (not old)
+		(prompt-for-y-or-n
+		 :prompt
+		 (list "Current ~A definition of ~S is ~S.~%Redefine?"
+		       mode abbrev old)
+		 :default t
+		 :help (list "Redefine the expansion of ~S." abbrev)))
+	(setf (gethash abbrev table) expansion)
+	(push (list abbrev expansion (if globalp nil mode))
+	      *new-abbrevs*)))))
+
+
+;;; Alt Space  Abbrev Expand Only
+;;;               Expand abbrev without inserting anything.
+
+(defcommand "Abbrev Expand Only" (p)
+  "This command expands the word before point into its abbrev definition 
+  (if indeed it has one)."
+  "This command expands the word before point into its abbrev definition 
+  (if indeed it has one)."
+  (declare (ignore p))
+  (let* ((word (prev-word 1 (current-point)))
+	 (glob (gethash (string-downcase word) *global-abbrev-table*))
+	 (mode (if (hemlock-bound-p 'Mode-Abbrev-Table)
+		   (gethash (string-downcase word)
+			    (value Mode-Abbrev-Table))))
+	 (end-word (reverse-find-attribute (copy-mark (current-point)
+						      :right-inserting)
+					   :word-delimiter #'zerop))
+	 (result (if mode mode glob)))
+    (when (or mode glob)
+      (delete-characters end-word (- (length word)))
+      (cond ((equal word (string-capitalize word))
+	     (setq result (string-capitalize result)))
+	    ((equal word (string-upcase word))
+	     (setq result (string-upcase result))))
+      (insert-string end-word result)
+      (unless (hemlock-bound-p 'last-expanded)
+	(defhvar "last expanded"
+            "Holds a mark, the last expanded abbrev, and its expansion in a list."
+            :buffer (current-buffer)))
+      (setf (value last-expanded)
+	    (list (copy-mark (current-point) :right-inserting)
+		  word result)))
+    (delete-mark end-word))
+  (when (and (hemlock-bound-p 'prefix-mark)
+	     (value prefix-mark))
+    (delete-characters (value prefix-mark) 1)
+    (delete-mark (value prefix-mark))
+    (setf (value prefix-mark) nil)))
+
+
+
+;;; This function returns the n words immediately before the mark supplied.
+
+(defun prev-word (n mark)
+  (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary)
+					 :word-delimiter #'zerop))
+	 (mark-2 (copy-mark mark-1)))
+    (dotimes (x n (region-to-string (region mark-2 mark-1)))
+      (reverse-find-attribute (mark-before mark-2) :word-delimiter))))
+
+
+
+;;; M-'        Word Abbrev Prefix Mark
+;;;               Mark a prefix to be glued to an abbrev following.
+
+;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander)
+;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately
+;;; after prefix-mark.
+
+(defcommand "Word Abbrev Prefix Mark" (p)
+  "Marks a prefix to be glued to an abbrev following." 
+  "Marks a prefix to be glued to an abbrev following."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'prefix-mark)
+    (defhvar "prefix mark"
+             "Holds a mark (or not) pointing to the current Prefix Mark."
+             :buffer (current-buffer)))
+  (when (value prefix-mark)
+    (delete-mark (value prefix-mark)))
+  (setf (value prefix-mark) (copy-mark (current-point) :right-inserting))
+  (insert-character (value prefix-mark) #\-))
+
+
+;;; C-X U     Unexpand Last Word
+;;;              Unexpands last abbrev or undoes last C-X U.
+
+(defcommand "Unexpand Last Word" (p)
+  "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\".
+  Only one abbrev may be undone."
+  "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"."
+  (declare (ignore p))
+  (unless (or (not (hemlock-bound-p 'last-expanded))
+	      (value last-expanded))
+    (editor-error "Nothing to Undo."))
+  (let ((mark (car (value last-expanded)))
+	(word1 (second (value last-expanded)))
+	(word2 (third (value last-expanded))))
+    (unless (string= word2
+		     (region-to-string
+		      (region (character-offset (copy-mark mark :temporary)
+						(- (length word2)))
+			      mark)))
+      (editor-error "The last expanded Abbrev has been altered in the text."))
+    (delete-characters mark (- (length word2)))
+    (insert-string mark word1)
+    (character-offset mark (length word1))
+    (setf (value last-expanded) (list mark word2 word1))))
+
+ 
+  
+;;; Delete Mode Word Abbrev                       Kills some Mode abbrevs.
+
+(defcommand "Delete Mode Word Abbrev"
+	    (p &optional abbrev
+	       (mode (buffer-major-mode (current-buffer))))
+  "Prompts for a word abbrev and deletes the mode expansion in the current mode.
+  If called with a prefix argument, deletes all word abbrevs define in the
+  current mode."
+  "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true."
+  (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode)))
+    (if p
+	(when boundp
+	  (delete-variable 'Mode-Abbrev-Table :mode mode))
+	(let ((down
+	       (string-downcase
+		(or abbrev
+		    (prompt-for-string
+		     :prompt (list "~A abbrev to delete: " mode)
+		     :help
+ (list "Give the name of a ~A mode word abbrev to delete." mode)
+		     :trim t))))
+	      (table (and boundp (variable-value 'mode-abbrev-table :mode mode))))
+	  (unless (and table (gethash down table))
+	    (editor-error "~S is not the name of an abbrev in ~A mode."
+			  down mode))
+	  (remhash down table)))))
+
+
+;;; Delete Global Word Abbrevs                    Kills some Global abbrevs.
+
+(defcommand "Delete Global Word Abbrev" (p &optional abbrev)
+  "Prompts for a word abbrev and delete the global expansion.
+  If called with a prefix argument, deletes all global abbrevs."
+  "Deletes the global word abbreviation named Abbrev.  If P is true,
+  deletes all global abbrevs."
+  (declare (ignore p))
+  (if p
+      (setq *global-abbrev-table* (make-hash-table :test #'equal))
+      (let ((down 
+	     (string-downcase
+	      (or abbrev
+		  (prompt-for-string
+		   :prompt "Global abbrev to delete: "
+		   :help "Give the name of a global word abbrev to delete."
+		   :trim t)))))
+	(unless (gethash down *global-abbrev-table*)
+	  (editor-error "~S is not the name of a global word abbrev." down))
+	(remhash down *global-abbrev-table*))))
+	
+;;; Delete All Word Abbrevs                       Wipes them all.
+
+(defcommand "Delete All Word Abbrevs" (p)
+  "Deletes all currently defined Word Abbrevs"
+  "Deletes all currently defined Word Abbrevs"
+  (declare (ignore p))
+  (Delete-Global-Word-Abbrev-Command 1)
+  (Delete-Mode-Word-Abbrev-Command 1))
+
+
+;;;; Abbrev I/O
+
+;;; List Word Abbrevs                 Shows definitions of all word abbrevs.
+
+(defcommand "List Word Abbrevs" (p)
+  "Lists all of the currently defined Word Abbrevs."
+  "Lists all of the currently defined Word Abbrevs."
+  (word-abbrev-apropos-command p ""))
+
+
+;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
+;;;                                definition, or mode.
+
+(defcommand "Word Abbrev Apropos" (p &optional search-string)
+  "Lists all of the currently defined Word Abbrevs which contain a given string
+  in their abbrev. definition, or mode."
+  "Lists all of the currently defined Word Abbrevs which contain a given string
+  in their abbrev. definition, or mode."
+  (declare (ignore p))
+  (unless search-string
+    (setq search-string
+	  (string-downcase
+	   (prompt-for-string
+	    :prompt "Apropos string: "
+	    :help "The string to search word abbrevs and definitions for."))))
+  (multiple-value-bind (count mode-tables) (count-abbrevs)
+    (with-pop-up-display (s :height (min (1+ count) 30))
+      (unless (zerop (hash-table-count *global-abbrev-table*))
+	(maphash #'(lambda (key val)
+		     (when (or (search search-string (string-downcase key))
+			       (search search-string (string-downcase val)))
+		       (write-abbrev key val nil s t)))
+		 *global-abbrev-table*))
+      (dolist (modename mode-tables)
+	(let ((table (variable-value 'Mode-Abbrev-Table :mode modename)))
+	  (if (search search-string (string-downcase modename))
+	      (maphash #'(lambda (key val)
+			   (write-abbrev key val modename s t))
+		       table)
+	      (maphash #'(lambda (key val)
+			   (when (or (search search-string (string-downcase key))
+				     (search search-string (string-downcase val)))
+			     (write-abbrev key val modename s t)))
+		       table))))
+      (terpri s))))
+
+
+
+(defun count-abbrevs ()
+  (let* ((count (hash-table-count *global-abbrev-table*))
+	 (mode-tables nil))
+    (do-strings (which x *mode-names*)
+      (declare (ignore x))
+      (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which)
+	(let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table
+							     :mode which))))
+	  (unless (zerop table-count)
+	    (incf count table-count)
+	    (push which mode-tables)))))
+    (values count mode-tables)))
+
+
+;;; Edit Word Abbrevs                 Lets you edit the definition list directly.
+
+(defcommand "Edit Word Abbrevs" (p)
+  "Allows direct editing of currently defined Word Abbrevs."
+  "Allows direct editing of currently defined Word Abbrevs."
+  (declare (ignore p))
+  (when (getstring "Edit Word Abbrevs" *buffer-names*)
+    (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*)))
+  (let ((old-buf (current-buffer))
+	(new-buf (make-buffer "Edit Word Abbrevs")))
+    (change-to-buffer new-buf)
+    (unwind-protect
+      (progn
+       (insert-word-abbrevs-command nil)
+       (do-recursive-edit)
+       (unless (equal #\newline (previous-character (buffer-end (current-point))))
+	 (insert-character (current-point) #\newline))
+       (delete-all-word-abbrevs-command nil)
+       (define-word-abbrevs-command nil))
+      (progn
+       (change-to-buffer old-buf)
+       (delete-buffer new-buf)))))
+
+
+
+;;; Insert Word Abbrevs          Inserts a list of current definitions in the
+;;;                                format that Define Word Abbrevs uses.
+
+(defcommand "Insert Word Abbrevs" (p)
+  "Inserts into the current buffer a list of all currently defined abbrevs in the
+  format used by \"Define Word Abbrevs\"."
+  "Inserts into the current buffer a list of all currently defined abbrevs in the
+  format used by \"Define Word Abbrevs\"."
+  
+  (declare (ignore p))
+  (multiple-value-bind (x mode-tables)
+		       (count-abbrevs)
+    (declare (ignore x))
+    (with-output-to-mark (stream (current-point) :full)
+      (maphash #'(lambda (key val)
+		   (write-abbrev key val nil stream))
+	       *global-abbrev-table*)
+      
+      (dolist (mode mode-tables)
+	(let ((modename (if (listp mode) (car mode) mode)))
+	  (maphash #'(lambda (key val)
+		       (write-abbrev key val modename stream))
+		   (variable-value 'Mode-Abbrev-Table :mode modename)))))))
+
+
+
+;;; Define Word Abbrevs          Defines set of abbrevs from a definition list in 
+;;;                                the buffer.
+
+(defcommand "Define Word Abbrevs" (p)
+  "Defines Word Abbrevs from the definition list in the current buffer.  The 
+  definition list must be in the format produced by \"Insert Word Abbrevs\"."
+  "Defines Word Abbrevs from the definition list in the current buffer.  The
+  definition list must be in the format produced by \"Insert Word Abbrevs\"."
+  
+  (declare (ignore p))
+  (with-input-from-region (file (buffer-region (current-buffer)))
+    (read-abbrevs file)))
+
+
+;;; Read Word Abbrev file <filename>   Define word abbrevs from a definition file.
+
+;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is
+;;; the minimum number of characters possible to define an abbrev.  It thinks the 
+;;; current abbrev "wraps" if there is no #\" at the end of the line or there are
+;;; two #\"s at the end of the line (unless that is the entire definition string,
+;;; i.e, a null-abbrev).
+
+;;; The format of the Abbrev files is 
+;;;
+;;;                   ABBREV<tab><tab>"ABBREV DEFINITION"
+;;;
+;;; for Global Abbrevs, and
+;;;
+;;;                   ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION"
+;;;
+;;; for Modal Abbrevs.  
+;;; Double-quotes contained within the abbrev definition are doubled.  If the first
+;;; line of an abbrev definition is not closed by a single double-quote, then
+;;; the subsequent lines are read in until a single double-quote is found.
+
+(defcommand "Read Word Abbrev File" (p &optional filename)
+  "Reads in a file of previously defined abbrev definitions."
+  "Reads in a file of previously defined abbrev definitions."
+  (declare (ignore p))
+  (setf (value abbrev-pathname-defaults)
+	(if filename
+	    filename
+	    (prompt-for-file
+	     :prompt "Name of abbrev file: "
+	     :help "The name of the abbrev file to load."
+	     :default (value abbrev-pathname-defaults)
+	     :must-exist nil)))
+  (with-open-file (file (value abbrev-pathname-defaults) :direction :input
+			:element-type 'string-char :if-does-not-exist :error)
+    (read-abbrevs file)))
+
+
+;;; Does the actual defining of abbrevs from a given stream, expecting tabs and
+;;; doubled double-quotes.
+
+(defun read-abbrevs (file)
+  (do ((line (read-line file nil nil)
+	     (read-line file nil nil)))
+      ((null line))
+    (unless (< (length line) 4)
+      (let* ((tab (position #\tab line))
+	     (tab2 (position #\tab line :start (1+ tab)))
+	     (abbrev (subseq line 0 tab))
+	     (modename (subseq line (1+ tab) tab2))
+	     (expansion (do* ((last (1+ (position #\" line))
+				    (if found (min len (1+ found)) 0))
+			      (len (length line))
+			      (found (if (position #\" line :start last)
+					 (1+ (position #\" line :start last)))
+				     (if (position #\" line :start last)
+					 (1+ (position #\" line :start last))))
+			      (expansion (subseq line last (if found found len))
+					 (concatenate 'simple-string expansion
+						      (subseq line last
+							      (if found found
+								  len)))))
+			     ((and (or (null found) (= found len))
+				   (equal #\" (char line (1- len)))
+				   (or (not (equal #\" (char line (- len 2))))
+				       (= (- len 3) tab2)))
+			      (subseq expansion 0 (1- (length expansion))))
+			  
+			  (when (null found)
+			    (setq line (read-line file nil nil)
+				  last 0
+				  len (length line)
+				  found (if (position #\" line)
+					    (1+ (position #\" line)))
+				  expansion (format nil "~A~%~A" expansion
+						    (subseq line 0 (if found
+								       found
+								       0))))))))
+	
+	(cond ((equal modename "")
+	       (setf (gethash abbrev *global-abbrev-table*)
+		     expansion))
+	      (t (setq modename (subseq modename 1 (1- (length modename))))
+		 (unless (hemlock-bound-p 'Mode-Abbrev-Table
+					  :mode modename)
+		   (defhvar "Mode Abbrev Table"
+    			    "Hash Table of Mode Abbrevs"
+    			    :value (make-hash-table :test #'equal)
+  			    :mode modename))
+		 (setf (gethash abbrev (variable-value
+					'Mode-Abbrev-Table :mode modename))
+		       expansion)))))))
+
+
+;;; Write Word Abbrev File            Make a definition file from current abbrevs.
+
+(defcommand "Write Word Abbrev File" (p &optional filename)
+  "Saves the currently defined Abbrevs to a file."
+  "Saves the currently defined Abbrevs to a file."
+  (declare (ignore p))
+  (unless filename
+    (setq filename
+	  (prompt-for-file
+	   :prompt "Write abbrevs to file: "
+	   :default (value abbrev-pathname-defaults)
+	   :help "Name of the file to write current abbrevs to."
+	   :must-exist nil)))
+  (with-open-file (file filename :direction :output
+			:element-type 'string-char :if-exists :supersede
+			:if-does-not-exist :create)
+    (multiple-value-bind (x mode-tables) (count-abbrevs)
+      (declare (ignore x))
+      (maphash #'(lambda (key val)
+		   (write-abbrev key val nil file))
+	       *global-abbrev-table*)
+      
+      (dolist (modename mode-tables)
+	(let ((mode (if (listp modename) (car modename) modename)))
+	  (maphash #'(lambda (key val)
+		       (write-abbrev key val mode file))
+		   (variable-value 'Mode-Abbrev-Table :mode mode))))))
+  (let ((tn (truename filename)))
+    (setf (value abbrev-pathname-defaults) tn)
+    (message "~A written." (namestring tn))))
+
+
+
+;;; Append to Word Abbrev File          Appends to a file changed abbrev 
+;;;                                     definitions since last dumping.
+
+(defcommand "Append to Word Abbrev File" (p &optional filename)
+  "Appends Abbrevs defined or redefined since the last save to a file."
+  "Appends Abbrevs defined or redefined since the last save to a file."
+  (declare (ignore p))
+  (cond
+   (*new-abbrevs*
+    (unless filename
+      (setq filename
+	    (prompt-for-file
+	     :prompt
+	     "Append incremental abbrevs to file: "
+	     :default (value abbrev-pathname-defaults)
+	     :must-exist nil
+	     :help "Filename to append recently defined Abbrevs to.")))
+    (write-incremental :append filename))
+   (t
+    (message "No Abbrev definitions have been changed since the last write."))))
+
+
+(defun write-incremental (mode filename)
+  (with-open-file (file filename :direction :output :element-type 'string-char
+			:if-exists mode :if-does-not-exist :create)
+    (dolist (def *new-abbrevs*)
+      (let ((abb (car def))
+	    (val (second def))
+	    (mode (third def)))
+	(write-abbrev abb val mode file))))
+  (let ((tn (truename filename)))
+    (setq *new-abbrevs* nil)
+    (setf (value abbrev-pathname-defaults) tn)
+    (message "~A written." (namestring tn))))
+
+
+;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function
+;;; writes to the stream with doubled double-quotes and stuff.
+;;; If the flag is true, then the output is in a pretty format (like "List Word
+;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word 
+;;; Abbrev File" uses).
+
+(defun write-abbrev (abbrev expansion modename file &optional flag)
+  (if flag
+      (if modename
+	  (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format
+	  (format file "~5t~A~35t\"" abbrev))                ; pretty format
+      (cond (modename
+	     (write-string abbrev file)
+	     (write-char #\tab file)
+	     (format file "(~A)" modename)                   ; "~A<tab>(~A)<tab>\""
+	     (write-char #\tab file)
+	     (write-char #\" file))
+	    (t
+	     (write-string abbrev file)
+	     (write-char #\tab file)                         ; "~A<tab><tab>\""
+	     (write-char #\tab file)
+	     (write-char #\" file))))
+  (do* ((prev 0 found)
+	(found (position #\" expansion)
+	       (position #\" expansion :start found)))
+       ((not found)
+	(write-string expansion file :start prev)
+	(write-char #\" file)
+	(terpri file))
+    (incf found)
+    (write-string expansion file :start prev :end found)
+    (write-char #\" file)))
+
+
+(defcommand "Abbrev Mode" (p)
+  "Put current buffer in Abbrev mode." 
+  "Put current buffer in Abbrev mode."  
+  (declare (ignore p))
+  (setf (buffer-minor-mode (current-buffer) "Abbrev")
+	(not (buffer-minor-mode (current-buffer) "Abbrev"))))
diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3aeebd36e8c0ea2779dda41d57cd824ac0a0e53d
--- /dev/null
+++ b/hemlock/bit-stream.lisp
@@ -0,0 +1,146 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Some stuff to make streams that write out on bitmap hunks.
+;;;
+;;; Written by Rob MacLachlan.
+;;; Modified by Bill Chiles to run under X on the IBM RT.
+;;;
+(in-package 'hemlock-internals)
+
+
+;;; These streams have an associated bitmap-hunk that is used for its
+;;; font-family, foreground and background color, and X window pointer.
+;;; The hunk need not be associated with any Hemlock window, and the low
+;;; level painting routines that use hunk dimensions are not used for
+;;; output.  Only BITMAP-HUNK-WRITE-STRING is used.  The hunk is not
+;;; registered for any event service, so resizing the associated X window
+;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the
+;;; hunk's input and changed handler slots are not set.
+;;;
+(defstruct (bitmap-hunk-output-stream (:include stream
+						(out #'bitmap-hunk-out)
+						(sout #'bitmap-hunk-sout)
+						(misc #'bitmap-hunk-misc))
+				      (:constructor
+				       make-bitmap-hunk-output-stream (hunk)))
+  hunk			; bitmap-hunk we display on.
+  (cursor-x 0)		; Character position of output cursor.
+  (cursor-y 0)
+  (buffer (make-string hunk-width-limit) :type simple-string)
+  (old-bottom 0))	; # of lines of scrolling before next "--More--" prompt.
+
+;;; Bitmap-Hunk-Stream-Newline  --  Internal
+;;;
+;;;    Flush the stream's output buffer and then move the cursor down
+;;; or scroll the window up if there is no room left.
+;;;
+(defun bitmap-hunk-stream-newline (stream)
+  (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
+	 (height (bitmap-hunk-char-height hunk))
+	 (y (bitmap-hunk-output-stream-cursor-y stream)))
+    (when (zerop (bitmap-hunk-output-stream-old-bottom stream))
+      (hunk-write-string hunk 0 y "--More--" 0 8)
+      (let ((device (device-hunk-device hunk)))
+	(when (device-force-output device)
+	  (funcall (device-force-output device))))
+      (wait-for-more)
+      (hunk-clear-lines hunk y 1)
+      (setf (bitmap-hunk-output-stream-old-bottom stream) (1- height)))
+    (hunk-write-string hunk 0 y (bitmap-hunk-output-stream-buffer stream) 0 
+		       (bitmap-hunk-output-stream-cursor-x stream))
+    (setf (bitmap-hunk-output-stream-cursor-x stream) 0)
+    (decf (bitmap-hunk-output-stream-old-bottom stream))
+    (incf y)
+    (when (= y height)
+      (decf y)
+      (hunk-copy-lines hunk 1 0 y)
+      (hunk-clear-lines hunk y 1))
+    (setf (bitmap-hunk-output-stream-cursor-y stream) y)))
+
+;;; Bitmap-Hunk-Misc  --  Internal
+;;;
+;;;    This is the misc method for bitmap-hunk-output-streams.  It just
+;;; writes out the contents of the buffer, and does the element type.
+;;;
+(defun bitmap-hunk-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos
+     (values (bitmap-hunk-output-stream-cursor-x stream)
+	     (bitmap-hunk-output-stream-cursor-y stream)))
+    ((:finish-output :force-output)
+     (hunk-write-string (bitmap-hunk-output-stream-hunk stream)
+			0 (bitmap-hunk-output-stream-cursor-y stream) 
+			(bitmap-hunk-output-stream-buffer stream) 0
+			(bitmap-hunk-output-stream-cursor-x stream))
+     (let ((device (device-hunk-device (bitmap-hunk-output-stream-hunk stream))))
+       (when (device-force-output device)
+	 (funcall (device-force-output device)))))
+    (:line-length
+     (bitmap-hunk-char-width (bitmap-hunk-output-stream-hunk stream)))
+    (:element-type 'string-char)))
+
+
+;;; Bitmap-Hunk-Out  --  Internal
+;;;
+;;;    Throw a character in a bitmap-hunk-stream's buffer.  If we wrap or hit a 
+;;; newline then call bitmap-hunk-stream-newline.
+;;;
+(defun bitmap-hunk-out (stream character)
+  (let ((hunk (bitmap-hunk-output-stream-hunk stream))
+	(x (bitmap-hunk-output-stream-cursor-x stream)))
+    (cond ((char= character #\newline)
+	   (bitmap-hunk-stream-newline stream)
+	   (return-from bitmap-hunk-out nil))
+	  ((= x (bitmap-hunk-char-width hunk))
+	   (setq x 0)
+	   (bitmap-hunk-stream-newline stream)))
+    (setf (schar (bitmap-hunk-output-stream-buffer stream) x) character)
+    (setf (bitmap-hunk-output-stream-cursor-x stream) (1+ x))))
+
+
+;;; Bitmap-Hunk-Sout  --  Internal
+;;;
+;;;    Write a string out to a bitmap-hunk, calling ourself recursively if the
+;;; string contains newlines.
+;;;
+(defun bitmap-hunk-sout (stream string start end)
+  (let* ((hunk (bitmap-hunk-output-stream-hunk stream))
+	 (buffer (bitmap-hunk-output-stream-buffer stream))
+	 (x (bitmap-hunk-output-stream-cursor-x stream))
+	 (dst-end (+ x (- end start)))
+	 (width (bitmap-hunk-char-width hunk)))
+    (cond ((%primitive find-character string start end #\newline)
+	   (do ((current (%primitive find-character string start end #\newline)
+			 (%primitive find-character string (1+ current)
+				     end #\newline))
+		(previous start (1+ current)))
+	       ((null current)
+		(bitmap-hunk-sout stream string previous end))
+	     (bitmap-hunk-sout stream string previous current)
+	     (bitmap-hunk-stream-newline stream)))
+	  ((> dst-end width)
+	   (let ((new-start (+ start (- width x))))
+	     (%primitive byte-blt string start buffer x width)
+	     (setf (bitmap-hunk-output-stream-cursor-x stream) width)
+	     (bitmap-hunk-stream-newline stream)
+	     (do ((idx (+ new-start width) (+ idx width))
+		  (prev new-start idx))
+		 ((>= idx end)
+		  (let ((dst-end (- end prev)))
+		    (%primitive byte-blt string prev buffer 0 dst-end)
+		    (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))
+	       (%primitive byte-blt string prev buffer 0 width)
+	       (setf (bitmap-hunk-output-stream-cursor-x stream) width)
+	       (bitmap-hunk-stream-newline stream))))
+	  (t
+	   (%primitive byte-blt string start buffer x dst-end)
+	   (setf (bitmap-hunk-output-stream-cursor-x stream) dst-end)))))
diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..204fc109c72a4eead84f86196928858e1c2dd9db
--- /dev/null
+++ b/hemlock/charmacs.lisp
@@ -0,0 +1,204 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Implementation specific character-hacking macros and constants.
+;;;
+(in-package 'hemlock-internals)
+(export ' (syntax-char-code-limit command-char-bits-limit
+	   command-char-code-limit search-char-code-limit
+	   do-alpha-chars))
+
+;;; This file contains various constants and macros which are
+;;; implementation or ASCII dependant.  In particular it contains
+;;; all the character implementation parameters such as
+;;; Command-Char-Bits-Limit, and contains various versions
+;;; of char-code which don't check types and omit the top bit
+;;; so that various structures can be allocated 128 long instead
+;;; of 256, and we don't get errors if a loser visits a binary file.
+
+;;; There are so many different constants and macros that do the same
+;;; thing because in principle the char-code-limit for the syntax
+;;; functions is independant of that for the searching functions, etc.
+
+;;; This file also contains code which adds any implementation specific
+;;; character names to the char file's Char-Name-Alist so that there
+;;; is a reasonable read-syntax and print-representation for all
+;;; characters a user might run across.
+
+
+;;; All the meaningful bit names in this implementation.
+;;; 
+(defconstant all-bit-names '(:control :meta :super :hyper))
+
+
+;;;; Stuff for the Syntax table functions (syntax)
+;;;
+(defconstant syntax-char-code-limit 128
+  "The highest char-code which a character argument to the syntax
+  table functions may have.")
+(defconstant syntax-char-code-mask #x+7f
+  "Mask we AND with characters given to syntax table functions to blow away
+  bits we don't want.")
+(defmacro syntax-char-code (char)
+  `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char)))
+
+;;;; Stuff for the command interpreter (interp)
+;;;
+;;;    On the Perq we have bits for command bindings, on the VAX there 
+;;; aren't.  The code to interpret them is conditionally compiled
+;;; so that the VAX isnt't slowed down.
+;;;
+;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes.
+(defconstant command-char-code-limit 256
+  "The upper bound on character codes supported for key bindings.")
+(defconstant command-char-bits-limit 16
+  "The maximum value of character bits supported for key bindings.")
+(defmacro key-char-bits (char)
+  `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8))
+(defmacro key-char-code (char)
+  `(char-code ,char))
+;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes.
+
+
+;;;; Stuff used by the searching primitives (search)
+;;;
+(defconstant search-char-code-limit 128
+  "The exclusive upper bound on significant char-codes for searching.")
+(defmacro search-char-code (ch)
+  `(logand (lisp::%sp-make-fixnum ,ch) #x+7F))
+;;;
+;;;    search-hash-code must be a function with the following properties:
+;;; given any character it returns a number between 0 and 
+;;; search-char-code-limit, and the same hash code must be returned 
+;;; for the upper and lower case forms of each character.
+;;;    In ASCII this is can be done by ANDing out the 5'th bit.
+;;;
+(defmacro search-hash-code (ch)
+  `(logand (lisp::%sp-make-fixnum ,ch) #x+5F))
+
+;;; Doesn't do anything special, but it should fast and not waste any time
+;;; checking type and whatnot.
+(defmacro search-char-upcase (ch)
+  `(lisp::fast-char-upcase ,ch))
+
+
+;;; Specal RT and Sun keys:
+
+(eval-when (compile load eval)
+
+(push (cons "DELETE" #\delete) lisp::char-name-alist)
+(push (cons "ESCAPE" #\escape) lisp::char-name-alist)
+(push (cons "F1" (code-char 1)) lisp::char-name-alist)
+(push (cons "F2" (code-char 2)) lisp::char-name-alist)
+(push (cons "F3" (code-char 3)) lisp::char-name-alist)
+(push (cons "F4" (code-char 4)) lisp::char-name-alist)
+(push (cons "F5" (code-char 5)) lisp::char-name-alist)
+(push (cons "F6" (code-char 6)) lisp::char-name-alist)
+(push (cons "F7" (code-char 7)) lisp::char-name-alist)
+(push (cons "F8" (code-char 11)) lisp::char-name-alist)
+(push (cons "F9" (code-char 12)) lisp::char-name-alist)
+(push (cons "F10" (code-char 14)) lisp::char-name-alist)
+(push (cons "F11" (code-char 17)) lisp::char-name-alist)
+(push (cons "F12" (code-char 18)) lisp::char-name-alist)
+(push (cons "LEFTARROW" (code-char 19)) lisp::char-name-alist)
+(push (cons "RIGHTARROW" (code-char 20)) lisp::char-name-alist)
+(push (cons "UPARROW" (code-char 22)) lisp::char-name-alist)
+(push (cons "DOWNARROW" (code-char 23)) lisp::char-name-alist)
+(push (cons "LEFTDOWN" (code-char 24)) lisp::char-name-alist)
+(push (cons "MIDDLEDOWN" (code-char 25)) lisp::char-name-alist)
+(push (cons "RIGHTDOWN" (code-char 128)) lisp::char-name-alist)
+(push (cons "LEFTUP" (code-char 129)) lisp::char-name-alist)
+(push (cons "MIDDLEUP" (code-char 130)) lisp::char-name-alist)
+(push (cons "RIGHTUP" (code-char 131)) lisp::char-name-alist)
+(push (cons "INSERT" (code-char 132)) lisp::char-name-alist)
+(push (cons "PRINTSCREEN" (code-char 133)) lisp::char-name-alist)
+(push (cons "PAUSE" (code-char 134)) lisp::char-name-alist)
+(push (cons "HOME" (code-char 135)) lisp::char-name-alist)
+(push (cons "END" (code-char 136)) lisp::char-name-alist)
+(push (cons "PAGEUP" (code-char 137)) lisp::char-name-alist)
+(push (cons "PAGEDOWN" (code-char 138)) lisp::char-name-alist)
+(push (cons "NUMLOCK" (code-char 139)) lisp::char-name-alist)
+(push (cons "F13" (code-char 140)) lisp::char-name-alist)
+(push (cons "F14" (code-char 141)) lisp::char-name-alist)
+(push (cons "F15" (code-char 142)) lisp::char-name-alist)
+(push (cons "F16" (code-char 143)) lisp::char-name-alist)
+(push (cons "F17" (code-char 144)) lisp::char-name-alist)
+(push (cons "F18" (code-char 145)) lisp::char-name-alist)
+(push (cons "F19" (code-char 146)) lisp::char-name-alist)
+(push (cons "F20" (code-char 147)) lisp::char-name-alist)
+(push (cons "F21" (code-char 148)) lisp::char-name-alist)
+(push (cons "F22" (code-char 149)) lisp::char-name-alist)
+(push (cons "F23" (code-char 150)) lisp::char-name-alist)
+(push (cons "F24" (code-char 151)) lisp::char-name-alist)
+(push (cons "F25" (code-char 152)) lisp::char-name-alist)
+(push (cons "F26" (code-char 153)) lisp::char-name-alist)
+(push (cons "F27" (code-char 154)) lisp::char-name-alist)
+(push (cons "F28" (code-char 155)) lisp::char-name-alist)
+(push (cons "F29" (code-char 156)) lisp::char-name-alist)
+(push (cons "F30" (code-char 157)) lisp::char-name-alist)
+(push (cons "F31" (code-char 158)) lisp::char-name-alist)
+(push (cons "F32" (code-char 159)) lisp::char-name-alist)
+(push (cons "F33" (code-char 160)) lisp::char-name-alist)
+(push (cons "F34" (code-char 161)) lisp::char-name-alist)
+(push (cons "F35" (code-char 162)) lisp::char-name-alist)
+;; ALTERNATE key on Sun keyboard.
+(push (cons "BREAK" (code-char 163)) lisp::char-name-alist)
+
+) ;eval-when (compile load eval)
+
+;;; Stick them on the end so that they don't print this way.
+;;; Use two separate EVAL-WHEN forms, so the #\f<13-35> characters can be
+;;; read at this point.
+;;;
+(eval-when (compile load eval)
+(setq lisp::char-name-alist
+      (append lisp::char-name-alist
+	      '(("ENTER" . #\return) ("ACTION" . #\linefeed)
+
+		("L1" . #\F11) ("L2" . #\F12) ("L3" . #\F13) ("L4" . #\F14)
+		("L5" . #\F15) ("L6" . #\F16) ("L7" . #\F17) ("L8" . #\F18)
+		("L9" . #\F19) ("L10" . #\F20)
+
+		("R1" . #\F21) ("R2" . #\F22) ("R3" . #\F23) ("R4" . #\F24)
+		("R5" . #\F25) ("R6" . #\F26) ("R7" . #\F27) ("R8" . #\F28)
+		("R9" . #\F29) ("R10" . #\F30) ("R11" . #\F31) ("R12" . #\F32)
+		("R13" . #\F33) ("R14" . #\F34) ("R15" . #\F35))))
+) ;eval-when
+
+
+;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var
+;;; to the alphabetic characters and executing body.  Note that the manual
+;;; guarantees lower and upper case char codes to be separately in order,
+;;; but other characters may be interspersed within that ordering.
+(defmacro alpha-chars-loop (var start-char end-char result body)
+  (let ((n (gensym))
+	(end-char-code (gensym)))
+    `(do ((,n (char-code ,start-char) (1+ ,n))
+	  (,end-char-code (char-code ,end-char)))
+	 ((> ,n ,end-char-code) ,result)
+       (let ((,var (code-char ,n)))
+	 (when (alpha-char-p ,var)
+	   ,@body)))))
+
+(defmacro do-alpha-chars ((var kind &optional result) &rest forms)
+  "(do-alpha-chars (var kind [result]) . body).  Kind is one of
+   :lower, :upper, or :both, and var is bound to each character in
+   order as specified under character relations in the manual.  When
+   :both is specified, lowercase letters are processed first."
+  (case kind
+    (:both
+     `(progn (alpha-chars-loop ,var #\a #\z nil ,forms)
+	     (alpha-chars-loop ,var #\A #\Z ,result ,forms)))
+    (:lower
+     `(alpha-chars-loop ,var #\a #\z ,result ,forms))
+    (:upper
+     `(alpha-chars-loop ,var #\A #\Z ,result ,forms))
+    (t (error "Kind argument not one of :lower, :upper, or :both -- ~S."
+	      kind))))
diff --git a/hemlock/cursor.lisp b/hemlock/cursor.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d90265bd5838f505295908179fa2eb7153024384
--- /dev/null
+++ b/hemlock/cursor.lisp
@@ -0,0 +1,409 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Rob MacLachlan
+;;;
+;;; Cursor: Routines for cursor positioning and recentering
+;;;
+(in-package 'hemlock-internals)
+(export '(mark-to-cursorpos center-window displayed-p scroll-window
+			    mark-column cursorpos-to-mark move-to-column))
+
+
+;;;; Mark-To-Cursorpos
+;;;
+;;; Since performance analysis showed that HALF of the time in the editor
+;;; was being spent in this function, I threw all of the tricks in the
+;;; book at it to try and make it tenser.
+;;;
+;;; The algorithm is roughly as follows:
+;;;
+;;;    1) Eliminate the annoying boundry condition of the mark being
+;;; off the end of the window, if it is return NIL now.
+;;;    2) If the charpos is on or immediately after the last character
+;;; in the line, then find the last dis-line on which the line is
+;;; displayed.  We know that the mark is at the end of this dis-line
+;;; because it is known to be on the screen.  X position is trivially
+;;; derived from the dis-line-length.
+;;;    3) Call Real-Line-Length or Cached-Real-Line-Length to get the
+;;; X position and number of times wrapped.
+
+(proclaim '(special the-sentinel))
+
+(eval-when (compile eval)
+;;; find-line
+;;;
+;;;    Find a dis-line which line is displayed on which starts before
+;;; charpos, setting ypos and dis-line to the dis-line and it's index.
+;;; Offset is expected to be the mark-charpos of the display-start for
+;;; the window initially, and is set to offset within line that
+;;; Dis-Line begins.  Charpos is the mark-charpos of the mark we want
+;;; to find.  Check if same as *redisplay-favorite-line* and then scan
+;;; if not.
+;;;
+(defmacro find-line (line offset charpos ypos dis-lines dis-line)
+  `(cond
+    ;; No lines at all, fail.
+    ((eq ,dis-lines the-sentinel) nil)
+    ;; On the first line, offset is already set, so just set dis-line and
+    ;; ypos and fall through.
+    ((eq (dis-line-line (car ,dis-lines)) ,line)
+     (setq ,dis-line ,dis-lines  ,ypos 0))
+    ;; Look farther down. 
+    ((do ((l (cdr ,dis-lines) (cdr l)))
+	 ((eq l the-sentinel))
+       (when (eq (dis-line-line (car l)) ,line)
+	 (setq ,dis-line l  ,ypos (dis-line-position (car l)) ,offset 0)
+	 (return t))))
+    (t
+     (error "Horrible flaming lossage, Sorry Man."))))
+
+;;; find-last 
+;;;
+;;;    Find the last dis-line on which line is displayed, set ypos and 
+;;; dis-line.
+;;;
+(defmacro find-last (line ypos dis-line)
+  `(do ((trail ,dis-line dl)
+	(dl (cdr ,dis-line) (cdr dl)))
+       ((not (eq (dis-line-line (car dl)) ,line))
+	(setq ,dis-line (car trail)  ,ypos (dis-line-position ,dis-line)))))
+
+;;; find-charpos
+;;;
+;;;    Special-Case mark at end of line, if not punt out to real-line-length 
+;;; function.  Return the correct values.
+;;;
+(defmacro find-charpos (line offset charpos length ypos dis-line width
+			     fun chars)
+  `(cond
+    ((= ,charpos ,length)
+     (find-last ,line ,ypos ,dis-line)
+     (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos))
+    ((= ,charpos (1- ,length))
+     (multiple-value-bind (x dy)
+			  (,fun ,line (1- ,width) ,offset ,charpos)
+       (if (and (not (zerop dy)) (zerop x))
+	   (values (1- ,width) (1- (+ ,ypos dy)))
+	   (values x (+ ,ypos dy)))))
+    (t
+     (multiple-value-bind (x dy)
+			  (,fun ,line (1- ,width) ,offset ,charpos)
+	  (values x (+ ,ypos dy))))))
+
+); eval-when (compile eval)
+
+;;; real-line-length 
+;;;
+;;;    Return as values the X position and the number of times wrapped if
+;;; one to display the characters from Start to End of Line starting at an
+;;; X position of 0 wrapping Width wide.
+;;; %SP-Find-Character-With-Attribute is used to find charaters 
+;;; with funny representation much as in Compute-Line-Image.
+;;;
+(defun real-line-length (line width start end)
+  (declare (fixnum width start end))
+  (do ((xpos 0)
+       (ypos 0)
+       (chars (line-chars line)) losing dy)
+      ((= start end) (values xpos ypos))
+    (declare (fixnum xpos ypos losing dy) (simple-string chars))
+    (setq losing (%fcwa chars start end losing-char))
+    (when (null losing)
+      (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width))
+      (return (values xpos (+ ypos dy))))
+    (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width))
+    (setq ypos (+ ypos dy)  start losing)
+    (do ((last (or (%fcwa chars start end winning-char) end)) str)
+	((= start last))
+      (declare (fixnum last))
+      (setq str (get-rep (schar chars start)))
+      (incf start)
+      (unless (simple-string-p str) (setq str (funcall str xpos)))
+      (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width))
+      (setq ypos (+ ypos dy)))))
+
+;;; cached-real-line-length
+;;;
+;;;    The same as Real-Line-Length, except does it for the cached line.
+;;; the line argument is ignored, but present to make the arglists the
+;;; same.
+;;;
+(defun cached-real-line-length (line width start end)
+  (declare (fixnum width start end) (ignore line))
+  (let ((offset (- right-open-pos left-open-pos)) bound)
+    (declare (fixnum offset bound))
+    (cond
+     ((>= start left-open-pos)
+      (setq start (+ start offset)  bound (setq end (+ end offset))))
+     ((> end left-open-pos)
+      (setq bound left-open-pos  end (+ end offset)))
+     (t
+      (setq bound end)))
+    
+    (do ((xpos 0)
+	 (ypos 0) losing dy)
+	(())
+      (declare (fixnum xpos ypos losing dy))
+      (when (= start bound)
+	(when (= start end) (return (values xpos ypos)))
+	(setq start right-open-pos  bound end))
+      (setq losing (%fcwa open-chars start bound losing-char))
+      (cond
+       (losing
+	(multiple-value-setq (dy xpos)
+	  (truncate (+ xpos (- losing start)) width))
+	(setq ypos (+ ypos dy)  start losing)
+	(do ((last (or (%fcwa open-chars start bound winning-char) bound)) str)
+	    ((= start last))
+	  (declare (fixnum last))
+	  (setq str (get-rep (schar open-chars start)))
+	  (incf start)
+	  (unless (simple-string-p str) (setq str (funcall str xpos)))
+	  (multiple-value-setq (dy xpos)
+	    (truncate (+ xpos (strlen str)) width))
+	  (setq ypos (+ ypos dy))))
+       (t
+	(multiple-value-setq (dy xpos)
+	  (truncate (+ xpos (- bound start)) width))
+	(setq ypos (+ ypos dy)  start bound))))))
+
+;;; mark-to-cursorpos  --  Public
+;;;
+;;;    Return as multiple values the x and y position within window of
+;;; mark.  NIL is returned if the mark is not displayed in the window given
+;;;
+;;;
+(defun mark-to-cursorpos (mark window)
+  "Return the (x, y) position of mark within window, or NIL if not displayed."
+  (let* ((line (mark-line mark))
+	 (number (line-number line))
+	 (charpos (mark-charpos mark))
+	 (dis-lines (cdr (window-first-line window)))
+	 (width (window-width window))
+	 (start (window-display-start window))
+	 (offset (mark-charpos start))
+	 (start-number (line-number (mark-line start)))
+	 (end (window-display-end window))
+	 (end-number (line-number (mark-line end))) ypos dis-line)
+    (declare (fixnum width charpos ypos number end-number)
+	     (simple-vector dis-lines))
+    (cond
+     ((or (< number start-number)
+	  (and (= number start-number) (< charpos offset))
+	  (> number end-number)
+	  (and (= number end-number) (> charpos (mark-charpos end)))) nil)
+     (t
+      (find-line line offset charpos ypos dis-lines dis-line)
+      (cond
+       ((eq line open-line)
+	(let ((len (- line-cache-length (- right-open-pos left-open-pos))))
+	  (declare (fixnum len))
+	  (find-charpos line offset charpos len ypos dis-line width
+			cached-real-line-length open-chars)))
+       (t
+	(let* ((chars (line-chars line))
+	       (len (strlen chars)))
+	  (declare (fixnum len) (simple-string chars))
+	  (find-charpos line offset charpos len ypos dis-line width
+			real-line-length chars))))))))
+
+;;; Dis-Line-Offset-Guess  --  Internal
+;;;
+;;;    Move Mark by Offset display lines.  The mark is assumed to be at the
+;;; beginning of a display line, and we attempt to leave it at one.  We assume
+;;; all characters print one wide.  Width is the width of the window we are
+;;; displaying in.
+;;;
+(defun dis-line-offset-guess (mark offset width)
+  (let ((w (1- width)))
+    (if (minusp offset)
+	(dotimes (i (- offset) t)
+	  (let ((pos (mark-charpos mark)))
+	    (if (>= pos w)
+		(character-offset mark (- w))
+		(let ((prev (line-previous (mark-line mark))))
+		  (unless prev (return nil))
+		  (multiple-value-bind
+		      (lines chars)
+		      (truncate (line-length prev) w)
+		    (move-to-position mark
+				      (cond ((zerop lines) 0)
+					    ((< chars 2)
+					     (* w (1- lines)))
+					    (t
+					     (* w lines)))
+				      prev))))))
+	(dotimes (i offset t)
+	  (let ((left (- (line-length (mark-line mark))
+			 (mark-charpos mark))))
+	    (if (> left width)
+		(character-offset mark w)
+		(unless (line-offset mark 1 0)
+		  (return nil))))))))
+
+;;; maybe-recenter-window  --  Internal
+;;;
+;;;     Update the dis-lines for Window and recenter if the point is off
+;;; the screen.
+;;;
+(defun maybe-recenter-window (window)
+  (unless (%displayed-p (buffer-point (window-buffer window)) window)
+    (center-window window (buffer-point (window-buffer window)))
+    t))
+
+;;; center-window  --  Public
+;;;
+;;;    Try to move the start of window so that Mark is on a line in the 
+;;; center.
+;;;
+(defun center-window (window mark)
+  "Adjust the start of Window so that Mark is displayed on the center line."
+  (let ((height (window-height window))
+	(start (window-display-start window)))
+    (move-mark start mark)
+    (unless (dis-line-offset-guess start (- (truncate height 2))
+				   (window-width window))
+      (move-mark start (buffer-start-mark (window-buffer window))))
+    (update-window-image window)
+    ;; If that doesn't work, panic and make the start the point.
+    (unless (%displayed-p mark window)
+      (move-mark start mark)
+      (update-window-image window))))
+
+
+;;; %Displayed-P  --  Internal
+;;;
+;;;    If Mark is within the displayed bounds in Window, then return true,
+;;; otherwise false.  We assume the window image is up to date.
+;;;
+(defun %displayed-p (mark window)
+  (let ((start (window-display-start window))
+	(end (window-display-end window)))
+    (not (or (mark< mark start) (mark> mark end)
+	     (if (mark= mark end)
+		 (let ((ch (next-character end)))
+		   (and ch (char/= ch #\newline)))
+		 nil)))))
+
+
+;;; Displayed-p  --  Public
+;;;
+;;;    Update the window image and then check if the mark is displayed.
+;;;
+(defun displayed-p (mark window)
+  "Return true if Mark is displayed on Window, false otherwise."
+  (update-window-image window)
+  (%displayed-p mark window))
+
+
+;;; scroll-window  --  Public
+;;;
+;;;    This is not really right, since it uses dis-line-offset-guess.
+;;; Probably if there is any screen overlap then we figure it out
+;;; exactly.
+;;;
+(defun scroll-window (window n)
+  "Scroll Window down N lines, up if negative."
+  (let ((start (window-display-start window))
+	(point (window-point window))
+	(width (window-width window))
+	(height (window-height window)))
+    (cond ((dis-line-offset-guess start n width))
+	  ((minusp n)
+	   (buffer-start start))
+	  (t
+	   (buffer-end start)
+	   (let ((fraction (- (truncate height 3) height)))
+	     (dis-line-offset-guess start fraction width))))
+    (update-window-image window)
+    (let ((iscurrent (eq window *current-window*))
+	  (bpoint (buffer-point (window-buffer window))))
+      (when iscurrent (move-mark point bpoint))
+      (unless (%displayed-p point window)
+	(move-mark point start)
+	(dis-line-offset-guess point (truncate (window-height window) 2)
+			       width)
+      (when iscurrent (move-mark bpoint point)))))
+  t)
+
+;;; Mark-Column  --  Public
+;;;
+;;;    Find the X position of a mark supposing that it were displayed
+;;; in an infinitely wide screen.
+;;;
+(defun mark-column (mark)
+  "Find the X position at which Mark would be displayed if it were on
+  an infinitely wide screen.  This takes into account tabs and control
+  characters."
+  (let ((charpos (mark-charpos mark))
+	(line (mark-line mark)))
+    (if (eq line open-line)
+	(values (cached-real-line-length line 10000 0 charpos))
+	(values (real-line-length line 10000 0 charpos)))))
+
+;;; Find-Position  --  Internal
+;;;
+;;;    Return the charpos which corresponds to the specified X position
+;;; within Line.  If there is no such position between Start and End then
+;;; rutne NIL.
+;;;
+(defun find-position (line position start end width)
+  (do* ((cached (eq line open-line))
+	(lo start)
+	(hi (1- end))
+	(probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2)))
+       ((> lo hi)
+	(if (= lo end) nil hi))
+    (let ((val (if cached
+		   (cached-real-line-length line width start probe)
+		   (real-line-length line width start probe))))
+      (cond ((= val position) (return probe))
+	    ((< val position) (setq lo (1+ probe)))
+	    (t (setq hi (1- probe)))))))
+
+;;; Cursorpos-To-Mark  --  Public
+;;;
+;;;    Find the right dis-line, then zero in on the correct position
+;;; using real-line-length.
+;;;
+(defun cursorpos-to-mark (x y window)
+  (check-type window window)
+  (let ((width (window-width window))
+	(first (window-first-line window)))
+    (when (>= x width)
+      (return-from cursorpos-to-mark nil))
+    (do* ((prev first dl)
+	  (dl (cdr first) (cdr dl))
+	  (ppos (mark-charpos (window-display-start window))
+		(if (eq (dis-line-line (car dl)) (dis-line-line (car prev)))
+		    (dis-line-end (car prev)) 0)))
+	((eq dl the-sentinel)
+	 (copy-mark (window-display-end window) :temporary))
+      (when (= (dis-line-position (car dl)) y)
+	(let* ((line (dis-line-line (car dl)))
+	       (end (dis-line-end (car dl))))
+	  (return (mark line (or (find-position line x ppos end width) end))))))))
+
+;;; Move-To-Column  --  Public
+;;;
+;;;    Just look up the charpos using find-position...
+;;;
+(defun move-to-column (mark column &optional (line (mark-line mark)))
+  "Move Mark to the specified Column on Line.  This function is analogous
+  to Move-To-Position, but it deals with the physical screen position
+  as returned by Mark-Column; the mark is moved to before the character
+  which would be displayed in Column if the line were displayed on
+  an infinitely wide screen.  If the column specified is greater than
+  the column of the last character, then Nil is returned and the mark
+  is not modified."
+  (let ((res (find-position line column 0 (line-length line) 10000)))
+    (if res
+	(move-to-position mark res line))))
diff --git a/hemlock/dired.lisp b/hemlock/dired.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..2ae2b8ea81a100ee21741b57428363e31401298e
--- /dev/null
+++ b/hemlock/dired.lisp
@@ -0,0 +1,691 @@
+;;; -*- Log: hemlock.log; Package: dired -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains site dependent code for dired.
+;;; Written by Bill Chiles.
+;;;
+
+(in-package "DIRED")
+
+(shadow '(rename-file delete-file))
+
+(export '(copy-file rename-file find-file delete-file make-directory
+	  *update-default* *clobber-default* *recursive-default*
+	  *report-function* *error-function* *yesp-function*
+	  pathnames-from-pattern))
+
+
+
+;;;; Exported parameters.
+
+(defparameter *update-default* nil
+  "Update arguments to utilities default to this value.")
+
+(defparameter *clobber-default* t
+  "Clobber arguments to utilities default to this value.")
+
+(defparameter *recursive-default* nil
+  "Recursive arguments to utilities default to this value.")
+
+
+
+;;;; WILDCARDP
+
+(defconstant wildcard-char #\*
+  "Wildcard designator for file names will match any substring.")
+
+(defmacro wildcardp (file-namestring)
+  `(position wildcard-char (the simple-string ,file-namestring) :test #'char=))
+
+
+
+;;;; User interaction functions, variable declarations, and their defaults.
+
+(defun default-error-function (string &rest args)
+  (apply #'error string args))
+;;;
+(defvar *error-function* #'default-error-function
+  "This function is called when an error is encountered in dired code.")
+
+(defun default-report-function (string &rest args)
+  (apply #'format t string args))
+;;;
+(defvar *report-function* #'default-report-function
+  "This function is called when the user needs to be informed of something.")
+
+(defun default-yesp-function (string &rest args)
+  (apply #'format t string args)
+  (let ((answer (nstring-downcase (string-trim '(#\space #\tab) (read-line)))))
+    (declare (simple-string answer))
+    (or (string= answer "")
+	(string= answer "y")
+	(string= answer "yes")
+	(string= answer "ye"))))
+;;;
+(defvar *yesp-function* #'default-yesp-function
+  "Function to query the user about clobbering an already existent file.")
+
+
+
+;;;; Copy-File
+
+;;; WILD-MATCH objects contain information about wildcard matches.  File is the
+;;; Sesame namestring of the file matched, and substitute is a substring of the
+;;; file-namestring of file.
+;;;
+(defstruct (wild-match (:print-function print-wild-match)
+		       (:constructor make-wild-match (file substitute)))
+  file
+  substitute)
+
+(defun print-wild-match (obj str n)
+  (declare (ignore n))
+  (format str "#<Wild-Match  ~S  ~S>"
+	  (wild-match-file obj) (wild-match-substitute obj)))
+
+
+(defun copy-file (spec1 spec2 &key (update *update-default*)
+				   (clobber *clobber-default*)
+				   (directory () directoryp))
+  "Copy file spec1 to spec2.  A single wildcard is acceptable, and directory
+   names may be used.  If spec1 and spec2 are both directories, then a
+   recursive copy is done of the files and subdirectory structure of spec1;
+   if spec2 is in the subdirectory structure of spec1, the recursion will
+   not descend into it.  Use spec1/* to copy only the files in spec1 to
+   directory spec2.  If spec2 is a directory, and spec1 is a file, then
+   spec1 is copied into spec2 with the same pathname-name.  Files are
+   copied maintaining the source's write date.  If :update is non-nil, then
+   files are only copied if the source is newer than the destination, still
+   maintaining the source's write date; the user is not warned if the
+   destination is newer (not the same write date) than the source.  If
+   :clobber and :update are nil, then if any file spec2 already exists, the
+   user will be asked whether it should be overwritten or not."
+  (cond
+   ((not directoryp)
+    (multiple-value-bind (ses-name1 exists1p)
+			 (lisp::predict-name spec1 t)
+      (let* ((ses-name2 (lisp::predict-name spec2 nil))
+	     (pname1 (pathname ses-name1))
+	     (pname2 (pathname ses-name2))
+	     (dirp1 (directoryp pname1))
+	     (dirp2 (directoryp pname2))
+	     (wildp1 (wildcardp (file-namestring pname1)))
+	     (wildp2 (wildcardp (file-namestring pname2))))
+	(when (and dirp1 wildp1)
+	  (funcall *error-function*
+		   "Cannot have wildcards in directory names -- ~S." pname1))
+	(when (and dirp2 wildp2)
+	  (funcall *error-function*
+		   "Cannot have wildcards in directory names -- ~S." pname2))
+	(when (and dirp1 (not dirp2))
+	  (funcall *error-function*
+		   "Cannot handle spec1 being a directory and spec2 a file."))
+	(when (and wildp2 (not wildp1))
+	  (funcall *error-function*
+		   "Cannot handle destination having wildcards without ~
+		   source having wildcards."))
+	(when (and wildp1 (not wildp2) (not dirp2))
+	  (funcall *error-function*
+		   "Cannot handle source with wildcards and destination ~
+		   without, unless destination is a directory."))
+	(cond ((and dirp1 dirp2)
+	       (unless (directory-existsp ses-name1)
+		 (funcall *error-function*
+			  "Directory does not exist -- ~S." pname1))
+	       (unless (directory-existsp ses-name2)
+		 (enter-directory ses-name2))
+	       (recursive-copy pname1 pname2 update clobber pname2
+			       ses-name1 ses-name2))
+	      (dirp2
+	       ;; merge pname2 with pname1 to pick up a similar file-namestring.
+	       (copy-file-1 pname1 wildp1 exists1p
+			    (merge-pathnames pname2 pname1)
+			    wildp1 update clobber))
+	      (t (copy-file-1 pname1 wildp1 exists1p
+			      pname2 wildp2 update clobber))))))
+    (directory
+     (when (pathname-directory spec1)
+       (funcall *error-function*
+		"Spec1 is just a pattern when supplying directory -- ~S."
+		spec1))
+     (let* ((pname2 (pathname (lisp::predict-name spec2 nil)))
+	    (dirp2 (directoryp pname2))
+	    (wildp1 (wildcardp spec1))
+	    (wildp2 (wildcardp (file-namestring pname2))))
+       (unless wildp1
+	 (funcall *error-function*
+		  "Pattern, ~S, does not contain a wildcard."
+		  spec1))
+       (when (and (not wildp2) (not dirp2))
+	 (funcall *error-function*
+		  "Cannot handle source with wildcards and destination ~
+		   without, unless destination is a directory."))
+       (copy-wildcard-files spec1 wildp1
+			    (if dirp2 (merge-pathnames pname2 spec1) pname2)
+			    (if dirp2 wildp1 wildp2)
+			    update clobber directory))))
+  (values))
+
+;;; RECURSIVE-COPY takes two pathnames that represent directories, and
+;;; the files in pname1 are copied into pname2, recursively descending into
+;;; subdirectories.  If a subdirectory of pname1 does not exist in pname2,
+;;; it is created.  Pname1 is known to exist.  Forbidden-dir is originally
+;;; the same as pname2; this keeps us from infinitely recursing if pname2
+;;; is in the subdirectory structure of pname1.  Returns t if some file gets
+;;; copied.
+;;; 
+(defun recursive-copy (pname1 pname2 update clobber
+		       forbidden-dir ses-name1 ses-name2)
+  (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2)
+  (dolist (spec (directory (directory-namestring pname1)))
+    (let ((spec-ses-name (namestring spec)))
+      (if (directoryp spec)
+	  (unless (equal (pathname spec-ses-name) forbidden-dir)
+	    (let* ((dir2-pname (merge-dirs spec pname2))
+		   (dir2-ses-name (namestring dir2-pname)))
+	      (unless (directory-existsp dir2-ses-name)
+		(enter-directory dir2-ses-name))
+	      (recursive-copy spec dir2-pname update clobber forbidden-dir
+			      spec-ses-name dir2-ses-name)
+	      (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1
+		       ses-name2)))
+	  (copy-file-2 spec-ses-name
+		       (namestring (merge-pathnames pname2 spec))
+		       update clobber)))))
+
+;;; MERGE-DIRS picks out the last directory name in the pathname pname1 and
+;;; adds it to the end of the sequence of directory names from pname2, returning
+;;; a pathname.
+;;;
+(defun merge-dirs (pname1 pname2)
+  (let* ((dirs1 (pathname-directory pname1))
+	 (dirs2 (pathname-directory pname2))
+	 (dirs2-len (length dirs2))
+	 (new-dirs2 (make-array (1+ dirs2-len))))
+    (declare (simple-vector dirs1 dirs2 new-dirs2))
+    (replace new-dirs2 dirs2)
+    (setf (svref new-dirs2 dirs2-len)
+	  (svref dirs1 (1- (length dirs1))))
+    (make-pathname :directory new-dirs2 :device :absolute)))
+
+;;; COPY-FILE-1 takes pathnames which either both contain a single wildcard
+;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the
+;;; file-namestring of pname1 and pname2, respectively, indicating the position
+;;; of the wildcard character.  If there is no wildcard, then simply call
+;;; COPY-FILE-2; otherwise, resolve the wildcard and copy those matching files.
+;;;
+(defun copy-file-1 (pname1 wildp1 exists1p pname2 wildp2 update clobber)
+  (if wildp1 
+      (copy-wildcard-files pname1 wildp1 pname2 wildp2 update clobber)
+      (let ((ses-name1 (namestring pname1)))
+	(unless exists1p (funcall *error-function*
+				  "~S does not exist." ses-name1))
+	(copy-file-2 ses-name1 (namestring pname2) update clobber))))
+
+(defun copy-wildcard-files (pname1 wildp1 pname2 wildp2 update clobber
+				   &optional directory)
+  (multiple-value-bind (dst-before dst-after)
+		       (before-wildcard-after (file-namestring pname2) wildp2)
+    (dolist (match (resolve-wildcard pname1 wildp1 directory))
+      (copy-file-2 (wild-match-file match)
+		   (namestring (concatenate 'simple-string
+					    (directory-namestring pname2)
+					    dst-before
+					    (wild-match-substitute match)
+					    dst-after))
+		   update clobber))))
+
+;;; COPY-FILE-2 copies ses-name1 to ses-name2 depending on the values of update
+;;; and clobber, with respect to the documentation of COPY-FILE.  If ses-name2
+;;; doesn't exist, then just copy it; otherwise, if update, then only copy it
+;;; if the destination's write date precedes the source's, and if not clobber
+;;; and not update, then ask the user before doing the copy.
+;;;
+(defun copy-file-2 (ses-name1 ses-name2 update clobber)
+  (let ((secs1 (get-write-date ses-name1)))
+    (cond ((not (probe-file ses-name2))
+	   (do-the-copy ses-name1 ses-name2 secs1))
+	  (update
+	   (let ((secs2 (get-write-date ses-name2)))
+	     (cond (clobber
+		    (do-the-copy ses-name1 ses-name2 secs1))
+		   ((and (> secs2 secs1)
+			 (funcall *yesp-function*
+				  "~&~S  ==>  ~S~%  ~
+				  ** Destination is newer than source.  ~
+				  Overwrite it? "
+				  ses-name1 ses-name2))
+		    (do-the-copy ses-name1 ses-name2 secs1))
+		   ((< secs2 secs1)
+		    (do-the-copy ses-name1 ses-name2 secs1)))))
+	  ((not clobber)
+	   (when (funcall *yesp-function*
+			  "~&~S  ==>  ~S~%  ** Destination already exists.  ~
+			  Overwrite it? "
+			  ses-name1 ses-name2)
+	     (do-the-copy ses-name1 ses-name2 secs1)))
+	  (t (do-the-copy ses-name1 ses-name2 secs1)))))
+
+(defun do-the-copy (ses-name1 ses-name2 secs1)
+  (let* ((fd (open-file ses-name1)))
+    (unwind-protect
+	(multiple-value-bind (data byte-count mode)
+			     (read-file fd ses-name1)
+	  (unwind-protect (write-file ses-name2 data byte-count mode)
+	    (dispose-storage data byte-count)))
+      (close-file fd)))
+  (set-write-date ses-name2 secs1)
+  (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2))
+
+
+;;;; Rename-File
+
+(defun rename-file (spec1 spec2 &key (clobber *clobber-default*)
+			  (directory () directoryp))
+  "Rename file spec1 to spec2.  A single wildcard is acceptable, and spec2 may
+   be a directory with the result spec being the merging of spec2 with spec1.
+   If clobber is nil and spec2 exists, then the user will be asked to confirm
+   the renaming.  As with Unix mv, if you are renaming a directory, don't
+   specify the trailing slash."
+  (cond
+   ((not directoryp)
+    (multiple-value-bind (ses-name1 exists1p)
+			 (lisp::predict-name spec1 t)
+      (let* ((ses-name2 (lisp::predict-name spec2 nil))
+	     (pname1 (pathname ses-name1))
+	     (pname2 (pathname ses-name2))
+	     (dirp2 (directoryp pname2))
+	     (wildp1 (wildcardp (file-namestring pname1)))
+	     (wildp2 (wildcardp (file-namestring pname2))))
+	(if (and dirp2 wildp2)
+	    (funcall *error-function*
+		     "Cannot have wildcards in directory names -- ~S." pname2))
+	(if (and wildp2 (not wildp1))
+	    (funcall *error-function*
+		     "Cannot handle destination having wildcards without ~
+		      source having wildcards."))
+	(if (and wildp1 (not wildp2) (not dirp2))
+	    (funcall *error-function*
+		     "Cannot handle source with wildcards and destination ~
+		     without, unless destination is a directory."))
+	(if dirp2
+	    (rename-file-1 pname1 wildp1 exists1p (merge-pathnames pname2
+								   pname1)
+			   wildp1 clobber)
+	    (rename-file-1 pname1 wildp1 exists1p pname2 wildp2 clobber)))))
+    (directory
+     (when (pathname-directory spec1)
+       (funcall *error-function*
+		"Spec1 is just a pattern when supplying directory -- ~S."
+		spec1))
+
+     (let* ((pname2 (pathname (lisp::predict-name spec2 nil)))
+	    (dirp2 (directoryp pname2))
+	    (wildp1 (wildcardp spec1))
+	    (wildp2 (wildcardp (file-namestring pname2))))
+       (unless wildp1
+	 (funcall *error-function*
+		  "Pattern, ~S, does not contain a wildcard."
+		  spec1))
+       (when (and (not wildp2) (not dirp2))
+	 (funcall *error-function*
+		  "Cannot handle source with wildcards and destination ~
+		   without, unless destination is a directory."))
+       (rename-wildcard-files spec1 wildp1
+			      (if dirp2 (merge-pathnames pname2 spec1) pname2)
+			      (if dirp2 wildp1 wildp2)
+			      clobber directory))))
+  (values))
+
+;;; RENAME-FILE-1 takes pathnames which either both contain a single wildcard
+;;; or none.  Wildp1 and Wildp2 are either nil or indexes into the
+;;; file-namestring of pname1 and pname2, respectively, indicating the position
+;;; of the wildcard character.  If there is no wildcard, then simply call
+;;; RENAME-FILE-2; otherwise, resolve the wildcard and rename those matching files.
+;;;
+(defun rename-file-1 (pname1 wildp1 exists1p pname2 wildp2 clobber)
+  (if wildp1
+      (rename-wildcard-files pname1 wildp1 pname2 wildp2 clobber)
+      (let ((ses-name1 (namestring pname1)))
+	(unless exists1p (funcall *error-function*
+				  "~S does not exist." ses-name1))
+	(rename-file-2 ses-name1 (namestring pname2) clobber))))
+
+(defun rename-wildcard-files (pname1 wildp1 pname2 wildp2 clobber
+				   &optional directory)
+  (multiple-value-bind (dst-before dst-after)
+		       (before-wildcard-after (file-namestring pname2) wildp2)
+    (dolist (match (resolve-wildcard pname1 wildp1 directory))
+      (rename-file-2 (wild-match-file match)
+		     (namestring (concatenate 'simple-string
+					      (directory-namestring pname2)
+					      dst-before
+					      (wild-match-substitute match)
+					      dst-after))
+		     clobber))))
+
+(defun rename-file-2 (ses-name1 ses-name2 clobber)
+  (cond ((and (probe-file ses-name2) (not clobber))
+	 (when (funcall *yesp-function*
+			"~&~S  ==>  ~S~%  ** Destination already exists.  ~
+			Overwrite it? "
+			ses-name1 ses-name2)
+	   (sub-rename-file ses-name1 ses-name2)
+	   (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2)))
+	(t (sub-rename-file ses-name1 ses-name2)
+	   (funcall *report-function* "~&~S  ==>~%  ~S~%" ses-name1 ses-name2))))
+
+
+
+;;;; Find-File
+
+(defun find-file (file-name &optional (directory "")
+			    (find-all-p nil find-all-suppliedp))
+  "Find the file with file-namestring file recursively looking in directory.
+   If find-all-p is non-nil, then do not stop searching upon finding the first
+   occurance of file.  File may contain a single wildcard, which causes
+   find-all-p to default to t instead of nil."
+  (let* ((file (coerce file-name 'simple-string))
+	 (wildp (wildcardp file))
+	 (find-all-p (if find-all-suppliedp find-all-p wildp)))
+    (declare (simple-string file))
+    (catch 'found-file
+      (if wildp
+	  (multiple-value-bind (before after)
+			       (before-wildcard-after file wildp)
+	    (find-file-aux file directory find-all-p before after))
+	  (find-file-aux file directory find-all-p))))
+  (values))
+
+(defun find-file-aux (the-file directory find-all-p &optional before after)
+  (declare (simple-string the-file))
+  (dolist (spec (directory directory))
+    (let* ((spec-ses-name (namestring spec))
+	   (spec-file-name (file-namestring spec-ses-name)))
+      (declare (simple-string spec-ses-name spec-file-name))
+      (if (directoryp spec)
+	  (find-file-aux the-file spec find-all-p before after)
+	  (when (if before
+		    (find-match before after spec-file-name :no-cons)
+		    (string-equal the-file spec-file-name))
+	    (print spec-ses-name)
+	    (unless find-all-p (throw 'found-file t)))))))
+
+
+
+;;;; Delete-File
+
+;;; DELETE-FILE
+;;;    If spec is a directory, but recursive is nil, just pass the directory
+;;; down through, letting LISP:DELETE-FILE signal an error if the directory
+;;; is not empty.
+;;; 
+(defun delete-file (spec &key (recursive *recursive-default*)
+			      (clobber *clobber-default*))
+  "Delete spec asking confirmation on each file if clobber is nil.  A single
+   wildcard is acceptable.  If recursive is non-nil, then a directory spec may
+   be given to recursively delete the entirety of the directory and its
+   subdirectory structure.  An empty directory may be specified without
+   recursive being non-nil.  When specifying a directory, the trailing slash
+   must be included."
+  (let* ((ses-name (lisp::predict-name spec t))
+	 (pname (pathname ses-name)) 
+	 (wildp (wildcardp (file-namestring pname)))
+	 (dirp (directoryp pname)))
+    (if dirp
+	(if recursive
+	    (recursive-delete pname ses-name clobber)
+	    (delete-file-2 ses-name clobber))
+	(delete-file-1 pname ses-name wildp clobber)))
+  (values))
+
+(defun recursive-delete (directory dir-ses-name clobber)
+  (dolist (spec (directory (directory-namestring directory)))
+    (let ((spec-ses-name (namestring spec)))
+      (if (directoryp spec)
+	  (recursive-delete (pathname spec-ses-name) spec-ses-name clobber)
+	  (delete-file-2 spec-ses-name clobber))))
+  (delete-file-2 dir-ses-name clobber))
+
+(defun delete-file-1 (pname ses-name wildp clobber)
+  (if wildp
+      (dolist (match (resolve-wildcard pname wildp))
+	(delete-file-2 (wild-match-file match) clobber))
+      (delete-file-2 ses-name clobber)))
+
+(defun delete-file-2 (ses-name clobber)
+  (when (or clobber (funcall *yesp-function* "~&Delete ~S? " ses-name))
+    (if (directoryp ses-name)
+	(delete-directory ses-name)
+	(lisp:delete-file ses-name))
+    (funcall *report-function* "~&~A~%" ses-name)))
+
+
+
+;;;; Wildcard resolution
+
+(defun pathnames-from-pattern (pattern files)
+  "Return a list of pathnames from files whose file-namestrings match
+   pattern.  Pattern must be a non-empty string and contains only one
+   asterisk.  Files contains no directories."
+  (declare (simple-string pattern))
+  (when (string= pattern "")
+    (funcall *error-function* "Must be a non-empty pattern."))
+  (unless (= (count wildcard-char pattern :test #'char=) 1)
+    (funcall *error-function* "Pattern must contain one asterisk."))
+  (multiple-value-bind (before after)
+		       (before-wildcard-after pattern (wildcardp pattern))
+    (let ((result nil))
+      (dolist (f files result)
+	(let* ((ses-namestring (namestring f))
+	       (f-namestring (file-namestring ses-namestring))
+	       (match (find-match before after f-namestring)))
+	  (when match (push f result)))))))
+
+
+;;; RESOLVE-WILDCARD takes a pathname with a wildcard and the position of the
+;;; wildcard character in the file-namestring and returns a list of wild-match
+;;; objects.  When directory is supplied, pname is just a pattern, or a
+;;; file-namestring.  It is an error for directory to be anything other than
+;;; absolute pathnames in the same directory.  Each wild-match object contains
+;;; the Sesame namestring of a file in the same directory as pname, or
+;;; directory, and a simple-string representing what the wildcard matched.
+;;;
+(defun resolve-wildcard (pname wild-pos &optional directory)
+  (multiple-value-bind (before after)
+		       (before-wildcard-after (if directory
+						  pname
+						  (file-namestring pname))
+					      wild-pos)
+    (let (result)
+      (dolist (f (or directory (directory (directory-namestring pname)))
+		 (nreverse result))
+	(unless (directoryp f)
+	  (let* ((ses-namestring (namestring f))
+		 (f-namestring (file-namestring ses-namestring))
+		 (match (find-match before after f-namestring)))
+	    (if match
+		(push (make-wild-match ses-namestring match) result))))))))
+
+;;; FIND-MATCH takes a "before wildcard" and "after wildcard" string and a
+;;; file-namestring.  If before and after match a substring of file-namestring
+;;; and are respectively left bound and right bound, then anything left in
+;;; between is the match returned.  If no match is found, nil is returned.
+;;; NOTE: if version numbers ever really exist, then this code will have to be
+;;; changed since the file-namestring of a pathname contains the version number.
+;;; 
+(defun find-match (before after file-namestring &optional no-cons)
+  (declare (simple-string before after file-namestring))
+  (let ((before-len (length before))
+	(after-len (length after))
+	(name-len (length file-namestring)))
+    (if (>= name-len (+ before-len after-len))
+	(let* ((start (if (string= before file-namestring
+				   :end1 before-len :end2 before-len)
+			  before-len))
+	       (end (- name-len after-len))
+	       (matchp (and start
+			    (string= after file-namestring :end1 after-len
+				     :start2 end :end2 name-len))))
+	  (if matchp
+	      (if no-cons
+		  t
+		  (subseq file-namestring start end)))))))
+
+(defun before-wildcard-after (file-namestring wild-pos)
+  (declare (simple-string file-namestring))
+  (values (subseq file-namestring 0 wild-pos)
+	  (subseq file-namestring (1+ wild-pos) (length file-namestring))))
+
+
+
+;;;; Miscellaneous Utilities (e.g., MAKEDIR).
+
+(defun make-directory (name)
+  "Creates directory name.  If name exists, then an error is signaled."
+  (multiple-value-bind (ses-name existsp)
+		       (lisp::predict-name name nil)
+    (when existsp (funcall *error-function*
+			   "Name already exists -- ~S" ses-name))
+    (enter-directory ses-name))
+  t)
+
+
+
+;;;; Mach Operations
+
+(defun open-file (ses-name)
+  (multiple-value-bind (fd err)
+		       (mach:unix-open ses-name mach:o_rdonly 0)
+    (unless fd
+      (funcall *error-function* "Opening ~S failed: ~A." ses-name err))
+    fd))
+
+(defun close-file (fd)
+  (mach:unix-close fd))
+
+(defun read-file (fd ses-name)
+  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)
+		       (mach:unix-fstat fd)
+    (declare (ignore ino nlink uid gid rdev))
+    (unless winp (funcall *error-function*
+			  "Opening ~S failed: ~A."  ses-name dev-or-err))
+    (let ((storage (lisp::fixnum-to-sap (allocate-storage size))))
+      (multiple-value-bind (read-bytes err)
+			   (mach:unix-read fd storage size)
+	(when (or (null read-bytes) (not (= size read-bytes)))
+	  (dispose-storage storage size)
+	  (funcall *error-function*
+		   "Reading file ~S failed: ~A." ses-name err)))
+      (values storage size mode))))
+
+(defun dispose-storage (storage size)
+  (mach::vm_deallocate lisp::*task-self*
+		       (lisp::sap-to-fixnum storage)
+		       size))
+
+(defun allocate-storage (size)
+  (lisp::do-validate 0 size -1))
+
+(defun write-file (ses-name data byte-count mode)
+  (multiple-value-bind (fd err) (mach:unix-creat ses-name #o644)
+    (unless fd
+      (funcall *error-function* "Couldn't create file ~S: ~A"
+	       ses-name (mach:get-unix-error-msg err)))
+    (multiple-value-bind (winp err) (mach:unix-write fd data 0 byte-count)
+      (unless winp
+	(funcall *error-function* "Writing file ~S failed: ~A"
+	       ses-name
+	       (mach:get-unix-error-msg err))))
+    (mach:unix-fchmod fd (logand mode #o777))
+    (mach:unix-close fd)))
+
+(defvar *utimes-buffer* (make-list 4 :initial-element 0))
+
+(defun set-write-date (ses-name secs)
+  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
+		       (mach:unix-stat ses-name)
+    (declare (ignore ino mode nlink uid gid rdev size))
+    (unless winp (funcall *error-function*
+			  "Couldn't stat file ~S failed: ~A."  ses-name
+			  dev-or-err))
+    (setf (car *utimes-buffer*) atime)
+    (setf (caddr *utimes-buffer*) secs))
+  (multiple-value-bind (winp err) (mach:unix-utimes ses-name *utimes-buffer*)
+    (unless winp
+      (funcall *error-function* "Couldn't set write date of file ~S: ~A"
+	       ses-name
+	       (mach:get-unix-error-msg err)))))
+
+(defun get-write-date (ses-name)
+  (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size
+			atime mtime)
+ 		       (mach:unix-stat ses-name)
+    (declare (ignore ino mode nlink uid gid rdev size atime))
+    (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."
+			  ses-name dev-or-err))
+    mtime))
+
+;;; SUB-RENAME-FILE must exist because we can't use Common Lisp's RENAME-FILE.
+;;; This is because it merges the new name with the old name to pick up
+;;; defaults, and this conflicts with Unix-oid names.  For example, renaming
+;;; "foo.bar" to ".baz" causes a result of "foo.baz"!  This routine doesn't
+;;; have this problem.
+;;;
+(defun sub-rename-file (ses-name1 ses-name2)
+  (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2)
+    (unless res
+      (funcall *error-function* "Failed to rename ~A to ~A: ~A."
+	       ses-name1 ses-name2 (mach:get-unix-error-msg err)))))
+
+(defun directory-existsp (ses-name)
+  (multiple-value-bind (winp type)
+		       (mach:unix-subtestname ses-name)
+    (and winp (eq type :entry_directory))))
+
+(defun enter-directory (ses-name)
+  (declare (simple-string ses-name))
+  (let* ((length-1 (1- (length ses-name)))
+	 (name (if (= (position #\/ ses-name :test #'char= :from-end t)
+		      length-1)
+		   (subseq ses-name 0 (1- (length ses-name)))
+		   ses-name)))
+    (multiple-value-bind (winp err) (mach:unix-mkdir name #o755)
+      (unless winp
+	(funcall *error-function* "Couldn't make directory ~S: ~A"
+		 name
+		 (mach:get-unix-error-msg err))))))
+
+(defun delete-directory (ses-name)
+  (declare (simple-string ses-name))
+  (multiple-value-bind (winp err)
+		       (mach:unix-rmdir (subseq ses-name 0
+						(1- (length ses-name))))
+    (unless winp
+      (funcall *error-function* "Couldn't delete directory ~S: ~A"
+	       ses-name
+	       (mach:get-unix-error-msg err)))))
+
+
+
+;;;; Misc. Utility Utilities
+
+;;; NSEPARATE-FILES destructively returns a list of file specs from listing.
+(defun nseparate-files (listing)
+  (do (files hold)
+      ((null listing) files)
+    (setf hold (cdr listing))
+    (unless (directoryp (car listing))
+      (setf (cdr listing) files)
+      (setf files listing))
+    (setf listing hold)))
+
+
+(defun directoryp (p)
+  (not (or (pathname-name p) (pathname-type p))))
diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7a95ef0339fd9525358444728b1482639328ebf1
--- /dev/null
+++ b/hemlock/diredcoms.lisp
@@ -0,0 +1,879 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; Simple directory editing support.
+;;; This file contains site dependent calls.
+;;;
+;;; Written by Blaine Burks and Bill Chiles.
+;;;
+
+(in-package "HEMLOCK")
+
+
+(defmode "Dired" :major-p t
+  :documentation
+  "Dired permits convenient directory browsing and file operations including
+   viewing, deleting, copying, renaming, and wildcard specifications.")
+
+
+(defstruct (dired-information (:print-function print-dired-information)
+			      (:conc-name dired-info-))
+  pathname		; Pathname of directory.
+  pattern		; FILE-NAMESTRING with wildcard possibly.
+  dot-files-p		; Whether to include UNIX dot files. 
+  write-date		; Write date of directory.
+  files			; Simple-vector of dired-file structures.
+  file-list)		; List of pathnames for files, excluding directories.
+
+(defun print-dired-information (obj str n)
+  (declare (ignore n))
+  (format str "#<Dired Info ~S>" (namestring (dired-info-pathname obj))))
+
+
+(defstruct (dired-file (:print-function print-dired-file)
+		       (:constructor make-dired-file (pathname)))
+  pathname
+  (deleted-p nil)
+  (write-date nil))
+
+(defun print-dired-file (obj str n)
+  (declare (ignore n))
+  (format str "#<Dired-file ~A>" (namestring (dired-file-pathname obj))))
+
+
+
+;;;; "Dired" command.
+     
+;;; *pathnames-to-dired-buffers* is an a-list mapping directory namestrings to
+;;; buffers that display their contents.
+;;;
+(defvar *pathnames-to-dired-buffers* ())
+
+(make-modeline-field
+ :name :dired-cmds :width 20
+ :function
+ #'(lambda (buffer window)
+     (declare (ignore buffer window))
+     "  Type ? for help.  "))
+
+(defcommand "Dired" (p &optional directory)
+  "Prompt for a directory and edit it.  If a dired for that directory already
+   exists, go to that buffer, otherwise create one.  With an argument, include
+   UNIX dot files."
+  "Prompt for a directory and edit it.  If a dired for that directory already
+   exists, go to that buffer, otherwise create one.  With an argument, include
+   UNIX dot files."
+  (let ((info (if directory (value dired-information))))
+    (dired-guts nil
+		;; Propagate dot-files property to subdirectory edits.
+		(or (and info (dired-info-dot-files-p info))
+		    p)
+		directory)))
+
+(defcommand "Dired with Pattern" (p)
+  "Do a dired, prompting for a pattern which may include a single *.  With an
+   argument, include UNIX dit files."
+  "Do a dired, prompting for a pattern which may include a single *.  With an
+   argument, include UNIX dit files."
+  (dired-guts t p nil))
+
+(defun dired-guts (patternp dot-files-p directory)
+  (let* ((dpn (value pathname-defaults))
+	 (directory (dired-directorify
+		     (or directory
+			 (prompt-for-file
+			  :prompt "Edit Directory: "
+			  :help "Pathname to edit."
+			  :default (make-pathname
+				    :device (pathname-device dpn)
+				    :directory (pathname-directory dpn))
+			  :must-exist nil))))
+	 (pattern (if patternp
+		      (prompt-for-string
+		       :prompt "Filename pattern: "
+		       :help "Type a filename with a single asterisk."
+		       :trim t)))
+	 (full-name (namestring (if pattern
+				    (merge-pathnames directory pattern)
+				    directory)))
+	 (name (concatenate 'simple-string "Dired " full-name))
+	 (buffer (cdr (assoc full-name *pathnames-to-dired-buffers*
+			     :test #'string=))))
+    (declare (simple-string full-name))
+    (setf (value pathname-defaults) (merge-pathnames directory dpn))
+    (change-to-buffer
+     (cond (buffer
+	    (when (and dot-files-p
+		       (not (dired-info-dot-files-p
+			     (variable-value 'dired-information
+					     :buffer buffer))))
+	      (setf (dired-info-dot-files-p (variable-value 'dired-information
+							    :buffer buffer))
+		    t)
+	      (update-dired-buffer directory pattern buffer))
+	    buffer)
+	   (t
+	    (let ((buffer (make-buffer
+			   name :modes '("Dired")
+			   :modeline-fields
+			   (append (value default-modeline-fields)
+				   (list (modeline-field :dired-cmds)))
+			   :delete-hook (list 'dired-buffer-delete-hook))))
+	      (unless (initialize-dired-buffer directory pattern
+					       dot-files-p buffer)
+		(delete-buffer-if-possible buffer)
+		(editor-error "No entries for ~A." full-name))
+	      (push (cons full-name buffer) *pathnames-to-dired-buffers*)
+	      buffer))))))
+
+;;; INITIALIZE-DIRED-BUFFER gets a dired in the buffer and defines some
+;;; variables to make it usable as a dired buffer.  If there are no file
+;;; satisfying directory, then this returns nil, otherwise t.
+;;;
+(defun initialize-dired-buffer (directory pattern dot-files-p buffer)
+  (multiple-value-bind (pathnames dired-files)
+		       (dired-in-buffer directory pattern dot-files-p buffer)
+    (if (zerop (length dired-files))
+	nil
+	(defhvar "Dired Information"
+	  "Contains the information neccessary to manipulate dired buffers."
+	  :buffer buffer
+	  :value (make-dired-information :pathname directory
+					 :pattern pattern
+					 :dot-files-p dot-files-p
+					 :write-date (file-write-date directory)
+					 :files dired-files
+					 :file-list pathnames)))))
+
+;;; CALL-PRINT-DIRECTORY gives us a nice way to report PRINT-DIRECTORY errors
+;;; to the user and to clean up the dired buffer.
+;;;
+(defun call-print-directory (directory mark dot-files-p)
+  (handler-case (with-output-to-mark (s mark :full)
+		  (print-directory directory s
+				   :all dot-files-p :verbose t :return-list t))
+    (error (condx)
+      (delete-buffer-if-possible (line-buffer (mark-line mark)))
+      (editor-error "~A" condx))))
+
+;;; DIRED-BUFFER-DELETE-HOOK is called on dired buffers upon deletion.  This
+;;; removes the buffer from the pathnames mapping, and it deletes and buffer
+;;; local variables referring to it.
+;;;
+(defun dired-buffer-delete-hook (buffer)
+  (setf *pathnames-to-dired-buffers*
+	(delete buffer *pathnames-to-dired-buffers* :test #'eq :key #'cdr)))
+
+
+
+;;;; Dired deletion and undeletion.
+
+(defcommand "Dired Delete File" (p)
+  "Marks a file for deletion; signals an error if not in a dired buffer.
+   With an argument, this prompts for a pattern that may contain at most one
+   wildcard, an asterisk, and all names matching the pattern will be flagged
+   for deletion."
+  "Marks a file for deletion; signals an error if not in a dired buffer."
+  (dired-frob-deletion p t))
+
+(defcommand "Dired Undelete File" (p)
+  "Removes a mark for deletion; signals and error if not in a dired buffer.
+   With an argument, this prompts for a pattern that may contain at most one
+   wildcard, an asterisk, and all names matching the pattern will be unflagged
+   for deletion."
+  "Removes a mark for deletion; signals and error if not in a dired buffer."
+  (dired-frob-deletion p nil))
+
+(defcommand "Dired Delete File and Down Line" (p)
+  "Marks file for deletion and moves down a line.
+   See \"Dired Delete File\"."
+  "Marks file for deletion and moves down a line.
+   See \"Dired Delete File\"."
+  (declare (ignore p))
+  (dired-frob-deletion nil t)
+  (dired-down-line (current-point)))
+
+(defcommand "Dired Undelete File and Down Line" (p)
+  "Marks file undeleted and moves down a line.
+   See \"Dired Delete File\"."
+  "Marks file undeleted and moves down a line.
+   See \"Dired Delete File\"."
+  (declare (ignore p))
+  (dired-frob-deletion nil nil)
+  (dired-down-line (current-point)))
+
+(defcommand "Dired Delete File with Pattern" (p)
+  "Prompts for a pattern and marks matching files for deletion.
+   See \"Dired Delete File\"."
+  "Prompts for a pattern and marks matching files for deletion.
+   See \"Dired Delete File\"."
+  (declare (ignore p))
+  (dired-frob-deletion t t)
+  (dired-down-line (current-point)))
+
+(defcommand "Dired Undelete File with Pattern" (p)
+  "Prompts for a pattern and marks matching files undeleted.
+   See \"Dired Delete File\"."
+  "Prompts for a pattern and marks matching files undeleted.
+   See \"Dired Delete File\"."
+  (declare (ignore p))
+  (dired-frob-deletion t nil)
+  (dired-down-line (current-point)))
+
+;;; DIRED-FROB-DELETION takes arguments indicating whether to prompt for a
+;;; pattern and whether to mark the file deleted or undeleted.  This uses
+;;; CURRENT-POINT and CURRENT-BUFFER, and if not in a dired buffer, signal
+;;; an error.
+;;; 
+(defun dired-frob-deletion (patternp deletep)
+  (unless (hemlock-bound-p 'dired-information)
+    (editor-error "Not in Dired buffer."))
+  (with-mark ((mark (current-point) :left-inserting))
+    (let* ((dir-info (value dired-information))
+	   (files (dired-info-files dir-info))
+	   (del-files
+	    (if patternp
+		(dired:pathnames-from-pattern
+		 (prompt-for-string
+		  :prompt "Filename pattern: "
+		  :help "Type a filename with a single asterisk."
+		  :trim t)
+		 (dired-info-file-list dir-info))
+		(list (dired-file-pathname
+		       (array-element-from-mark mark files)))))
+	   (note-char (if deletep #\D #\space)))
+      (with-writable-buffer ((current-buffer))
+	(dolist (f del-files)
+	  (let* ((pos (position f files :test #'equal
+				:key #'dired-file-pathname))
+		 (dired-file (svref files pos)))
+	    (buffer-start mark)
+	    (line-offset mark pos 0)
+	    (setf (dired-file-deleted-p dired-file) deletep)
+	    (if deletep
+		(setf (dired-file-write-date dired-file)
+		      (file-write-date (dired-file-pathname dired-file)))
+		(setf (dired-file-write-date dired-file) nil))
+	    (setf (next-character mark) note-char)))))))
+
+(defun dired-down-line (point)
+  (line-offset point 1)
+  (when (blank-line-p (mark-line point))
+    (line-offset point -1)))
+
+
+
+;;;; Dired file finding and going to dired buffers.
+
+(defcommand "Dired Edit File" (p)
+  "Read in file or recursively \"Dired\" a directory."
+  "Read in file or recursively \"Dired\" a directory."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
+    (let ((pathname (dired-file-pathname
+		     (array-element-from-mark
+		      point (dired-info-files (value dired-information))))))
+      (if (directoryp pathname)
+	  (dired-command nil (directory-namestring pathname))
+	  (change-to-buffer (find-file-buffer pathname))))))
+
+(defcommand "Dired View File" (p)
+  "Read in file as if by \"View File\" or recursively \"Dired\" a directory.
+   This associates the file's buffer with the dired buffer."
+  "Read in file as if by \"View File\".
+   This associates the file's buffer with the dired buffer."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (when (blank-line-p (mark-line point)) (editor-error "Not on a file line."))
+    (let ((pathname (dired-file-pathname
+		     (array-element-from-mark
+		      point (dired-info-files (value dired-information))))))
+      (if (directoryp pathname)
+	  (dired-command nil (directory-namestring pathname))
+	  (let* ((dired-buf (current-buffer))
+		 (buffer (view-file-command nil pathname)))
+	    (push #'(lambda (buffer)
+		      (declare (ignore buffer))
+		      (setf dired-buf nil))
+		  (buffer-delete-hook dired-buf))
+	    (setf (variable-value 'view-return-function :buffer buffer)
+		  #'(lambda ()
+		      (if dired-buf
+			  (change-to-buffer dired-buf)
+			  (dired-from-buffer-pathname-command nil)))))))))
+
+(defcommand "Dired from Buffer Pathname" (p)
+  "Invokes \"Dired\" on the directory part of the current buffer's pathname.
+   With an argument, also prompt for a file pattern within that directory."
+  "Invokes \"Dired\" on the directory part of the current buffer's pathname.
+   With an argument, also prompt for a file pattern within that directory."
+  (let ((pathname (buffer-pathname (current-buffer))))
+    (if pathname
+	(dired-command p (directory-namestring pathname))
+	(editor-error "No pathname associated with buffer."))))
+
+
+
+;;;; Dired misc. commands -- update, help, line motion.
+
+(defcommand "Dired Update Buffer" (p)
+  "Recompute the contents of a dired buffer.
+   This maintains delete flags for files that have not been modified."
+  "Recompute the contents of a dired buffer.
+   This maintains delete flags for files that have not been modified."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'dired-information)
+    (editor-error "Not in Dired buffer."))
+  (let ((buffer (current-buffer))
+	(dir-info (value dired-information)))
+    (update-dired-buffer (dired-info-pathname dir-info)
+			 (dired-info-pattern dir-info)
+			 buffer)))
+
+;;; UPDATE-DIRED-BUFFER updates buffer with a dired of directory, deleting
+;;; whatever is in the buffer already.  This assumes buffer was previously
+;;; used as a dired buffer having necessary variables bound.  The new files
+;;; are compared to the old ones propagating any deleted flags if the name
+;;; and the write date is the same for both specifications.
+;;;
+(defun update-dired-buffer (directory pattern buffer)
+  (with-writable-buffer (buffer)
+    (delete-region (buffer-region buffer))
+    (let ((dir-info (variable-value 'dired-information :buffer buffer)))
+      (multiple-value-bind (pathnames new-dired-files)
+			   (dired-in-buffer directory pattern
+					    (dired-info-dot-files-p dir-info)
+					    buffer)
+	(let ((point (buffer-point buffer))
+	      (old-dired-files (dired-info-files dir-info)))
+	  (declare (simple-vector old-dired-files))
+	  (dotimes (i (length old-dired-files))
+	    (let ((old-file (svref old-dired-files i)))
+	      (when (dired-file-deleted-p old-file)
+		(let ((pos (position (dired-file-pathname old-file)
+				     new-dired-files :test #'equal
+				     :key #'dired-file-pathname)))
+		  (when pos
+		    (let* ((new-file (svref new-dired-files pos))
+			   (write-date (file-write-date
+					(dired-file-pathname new-file))))
+		      (when (= (dired-file-write-date old-file) write-date)
+			(setf (dired-file-deleted-p new-file) t)
+			(setf (dired-file-write-date new-file) write-date)
+			(setf (next-character
+			       (line-offset (buffer-start point) pos 0))
+			      #\D))))))))
+	  (setf (dired-info-files dir-info) new-dired-files)
+	  (setf (dired-info-file-list dir-info) pathnames)
+	  (setf (dired-info-write-date dir-info)
+		(file-write-date directory))
+	  (move-mark point (buffer-start-mark buffer)))))))
+
+;;; DIRED-IN-BUFFER inserts a dired listing of directory in buffer returning
+;;; two values: a list of pathnames of files only, and an array of dired-file
+;;; structures.  This uses FILTER-REGION to insert a space for the indication
+;;; of whether the file is flagged for deletion.  Then we clean up extra header
+;;; and trailing lines known to be in the output (into every code a little
+;;; slime must fall).
+;;;
+(defun dired-in-buffer (directory pattern dot-files-p buffer)
+  (let ((point (buffer-point buffer)))
+    (with-writable-buffer (buffer)
+      (let* ((pathnames (call-print-directory
+			 (if pattern
+			     (merge-pathnames directory pattern)
+			     directory)
+			 point
+			 dot-files-p))
+	     (dired-files (make-array (length pathnames))))
+	(declare (list pathnames) (simple-vector dired-files))
+	(filter-region #'(lambda (str)
+			   (concatenate 'simple-string "  " str))
+		       (buffer-region buffer))
+	(delete-characters point -2)
+	(delete-region (line-to-region (mark-line (buffer-start point))))
+	(delete-characters point)
+	(do ((p pathnames (cdr p))
+	     (i 0 (1+ i)))
+	    ((null p))
+	  (setf (svref dired-files i) (make-dired-file (car p))))
+	(values (delete-if #'directoryp pathnames) dired-files)))))
+
+
+(defcommand "Dired Help" (p)
+  "How to use dired."
+  "How to use dired."
+  (declare (ignore p))
+  (describe-mode-command nil "Dired"))
+
+(defcommand "Dired Next File" (p)
+  "Moves to next undeleted file."
+  "Moves to next undeleted file."
+  (declare (ignore p))
+  (unless (dired-line-offset (current-point) (or p 1))
+    (editor-error "Not enough lines.")))
+
+(defcommand "Dired Previous File" (p)
+  "Moves to previous undeleted file."
+  "Moves to next undeleted file."
+  (declare (ignore p))
+  (unless (dired-line-offset (current-point) (or p -1))
+    (editor-error "Not enough lines.")))
+
+;;; DIRED-LINE-OFFSET moves mark n undeleted file lines, returning mark.  If
+;;; there are not enough lines, mark remains unmoved, this returns nil.
+;;;
+(defun dired-line-offset (mark n)
+  (with-mark ((m mark))
+    (let ((step (if (plusp n) 1 -1)))
+      (dotimes (i (abs n) (move-mark mark m))
+	(loop
+	  (unless (line-offset m step 0)
+	    (return-from dired-line-offset nil))
+	  (when (blank-line-p (mark-line m))
+	    (return-from dired-line-offset nil))
+	  (when (char= (next-character m) #\space)
+	    (return)))))))
+
+
+
+;;;; Dired user interaction functions.
+
+(defun dired-error-function (string &rest args)
+  (apply #'editor-error string args))
+
+(defun dired-report-function (string &rest args)
+  (clear-echo-area)
+  (apply #'message string args))
+
+(defun dired-yesp-function (string &rest args)
+  (prompt-for-y-or-n :prompt (cons string args) :default t))
+
+
+
+;;;; Dired expunging and quitting.
+
+(defcommand "Dired Expunge Files" (p)
+  "Expunges files marked for deletion.
+   Query the user if value of \"Dired File Expunge Confirm\" is non-nil.  Do
+   the same with directories and the value of \"Dired Directory Expunge
+   Confirm\"."
+  "Expunges files marked for deletion.
+   Query the user if value of \"Dired File Expunge Confirm\" is non-nil.  Do
+   the same with directories and the value of \"Dired Directory Expunge
+   Confirm\"."
+  (declare (ignore p)) 
+  (when (expunge-dired-files)
+    (dired-update-buffer-command nil))
+  (maintain-dired-consistency))
+
+(defcommand "Dired Quit" (p)
+  "Expunges the files in a dired buffer and then exits."
+  "Expunges the files in a dired buffer and then exits."
+  (declare (ignore p))
+  (expunge-dired-files)
+  (delete-buffer-if-possible (current-buffer)))
+
+(defhvar "Dired File Expunge Confirm"
+  "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
+   for confirmation before deleting the marked files."
+  :value t)
+
+(defhvar "Dired Directory Expunge Confirm"
+  "When set (the default), \"Dired Expunge Files\" and \"Dired Quit\" will ask
+   for confirmation before deleting each marked directory."
+  :value t)
+
+(defun expunge-dired-files ()
+  (multiple-value-bind (marked-files marked-dirs) (get-marked-dired-files)
+    (let ((dired:*error-function* #'dired-error-function)
+	  (dired:*report-function* #'dired-report-function)
+	  (dired:*yesp-function* #'dired-yesp-function)
+	  (we-did-something nil))
+      (when (and marked-files
+		 (or (not (value dired-file-expunge-confirm))
+		     (prompt-for-y-or-n :prompt "Really delete files? "
+					:default t
+					:must-exist t
+					:default-string "Y")))
+	(setf we-did-something t)
+	(dolist (file-info marked-files)
+	  (let ((pathname (car file-info))
+		(write-date (cdr file-info)))
+	    (if (= write-date (file-write-date pathname))
+		(dired:delete-file (namestring pathname) :clobber t
+				   :recursive nil)
+		(message "~A has been modified, it remains unchanged."
+			 (namestring pathname))))))
+      (when marked-dirs
+	(dolist (dir-info marked-dirs)
+	  (let ((dir (car dir-info))
+		(write-date (cdr dir-info)))
+	    (if (= write-date (file-write-date dir))
+		(when (or (not (value dired-directory-expunge-confirm))
+			  (prompt-for-y-or-n
+			   :prompt (list "~a is a directory. Delete it? "
+					 (directory-namestring dir))
+			   :default t
+			   :must-exist t
+			   :default-string "Y"))
+		  (dired:delete-file (directory-namestring dir) :clobber t
+				     :recursive t)
+		  (setf we-did-something t))
+		(message "~A has been modified, it remains unchanged.")))))
+      we-did-something)))
+
+
+
+;;;; Dired copying and renaming.
+
+(defhvar "Dired Copy File Confirm"
+  "Can be either t, nil, or :update.  T means always query before clobbering an
+   existing file, nil means don't query before clobbering an existing file, and
+   :update means only ask if the existing file is newer than the source."
+  :value T)
+
+(defhvar "Dired Rename File Confirm"
+  "When non-nil, dired will query before clobbering an existing file."
+  :value T)
+
+(defcommand "Dired Copy File" (p)
+  "Copy the file under the point"
+  "Copy the file under the point"
+  (declare (ignore p))
+  (let* ((point (current-point))
+	 (confirm (value dired-copy-file-confirm))
+	 (source (dired-file-pathname
+		  (array-element-from-mark
+		   point (dired-info-files (value dired-information)))))
+	 (dest (prompt-for-file
+		:prompt (if (directoryp source)
+			    "Destination Directory Name: "
+			    "Destination Filename: ")
+		:help "Name of new file."
+		:default source
+		:must-exist nil))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*report-function* #'dired-report-function)
+	 (dired:*yesp-function* #'dired-yesp-function))
+    (dired:copy-file source dest :update (if (eq confirm :update) t nil)
+		     :clobber (not confirm)))
+  (maintain-dired-consistency))
+
+(defcommand "Dired Rename File" (p)
+  "Rename the file or directory under the point"
+  "Rename the file or directory under the point"
+  (declare (ignore p))
+  (let* ((point (current-point))
+	 (source (dired-namify (dired-file-pathname
+				(array-element-from-mark
+				 point
+				 (dired-info-files (value dired-information))))))
+	 (dest (prompt-for-file
+		:prompt "New Filename: "
+		:help "The new name for this file."
+		:default source
+		:must-exist nil))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*report-function* #'dired-report-function)
+	 (dired:*yesp-function* #'dired-yesp-function))
+    ;; ARRAY-ELEMENT-FROM-MARK moves mark to line start.
+    (dired:rename-file source dest :clobber (value dired-rename-file-confirm)))
+  (maintain-dired-consistency))
+
+(defcommand "Dired Copy with Wildcard" (p)
+  "Copy files that match a pattern containing ONE wildcard."
+  "Copy files that match a pattern containing ONE wildcard."
+  (declare (ignore p))
+  (let* ((dir-info (value dired-information))
+	 (confirm (value dired-copy-file-confirm))
+	 (pattern (prompt-for-string
+		   :prompt "Filename pattern: "
+		   :help "Type a filename with a single asterisk."
+		   :trim t))
+	 (destination (namestring
+		       (prompt-for-file
+			:prompt "Destination Spec: "
+			:help "Destination spec.  May contain ONE asterisk."
+			:default (dired-info-pathname dir-info)
+			:must-exist nil)))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*yesp-function* #'dired-yesp-function)
+	 (dired:*report-function* #'dired-report-function))
+    (dired:copy-file pattern destination :update (if (eq confirm :update) t nil)
+		     :clobber (not confirm)
+		     :directory (dired-info-file-list dir-info)))
+  (maintain-dired-consistency))
+
+(defcommand "Dired Rename with Wildcard" (p)
+  "Rename files that match a pattern containing ONE wildcard."
+  "Rename files that match a pattern containing ONE wildcard."
+  (declare (ignore p))
+  (let* ((dir-info (value dired-information))
+	 (pattern (prompt-for-string
+		   :prompt "Filename pattern: "
+		   :help "Type a filename with a single asterisk."
+		   :trim t))
+	 (destination (namestring
+		       (prompt-for-file
+			:prompt "Destination Spec: "
+			:help "Destination spec.  May contain ONE asterisk."
+			:default (dired-info-pathname dir-info)
+			:must-exist nil)))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*yesp-function* #'dired-yesp-function)
+	 (dired:*report-function* #'dired-report-function))
+    (dired:rename-file pattern destination
+		       :clobber (not (value dired-rename-file-confirm))
+		       :directory (dired-info-file-list dir-info)))
+  (maintain-dired-consistency))
+
+(defcommand "Delete File" (p)
+  "Delete a file.  Specify directories with a trailing slash."
+  "Delete a file.  Specify directories with a trailing slash."
+  (declare (ignore p))
+  (let* ((spec (namestring
+		(prompt-for-file
+		 :prompt "Delete File: "
+		 :help '("Name of File or Directory to delete.  ~
+			  One wildcard is permitted.")
+		 :must-exist nil)))
+	 (directoryp (directoryp spec))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*report-function* #'dired-report-function)
+	 (dired:*yesp-function* #'dired-yesp-function))
+    (when (or (not directoryp)
+	      (not (value dired-directory-expunge-confirm))
+	      (prompt-for-y-or-n
+	       :prompt (list "~A is a directory. Delete it? "
+			     (directory-namestring spec))
+	       :default t :must-exist t :default-string "Y")))
+    (dired:delete-file spec :recursive t
+		       :clobber (or directoryp
+				    (value dired-file-expunge-confirm))))
+  (maintain-dired-consistency))
+
+(defcommand "Copy File" (p)
+  "Copy a file, allowing ONE wildcard."
+  "Copy a file, allowing ONE wildcard."
+  (declare (ignore p))
+  (let* ((confirm (value dired-copy-file-confirm))
+	 (source (namestring
+		  (prompt-for-file
+		   :prompt "Source Filename: "
+		   :help "Name of File to copy.  One wildcard is permitted."
+		   :must-exist nil)))
+	 (dest (namestring
+		(prompt-for-file
+		 :prompt (if (directoryp source)
+			     "Destination Directory Name: "
+			     "Destination Filename: ")
+		 :help "Name of new file."
+		 :default source
+		 :must-exist nil)))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*report-function* #'dired-report-function)
+	 (dired:*yesp-function* #'dired-yesp-function))
+    (dired:copy-file source dest :update (if (eq confirm :update) t nil)
+		     :clobber (not confirm)))
+  (maintain-dired-consistency))
+
+(defcommand "Rename File" (p)
+  "Rename a file, allowing ONE wildcard."
+  "Rename a file, allowing ONE wildcard."
+  (declare (ignore p))
+  (let* ((source (namestring
+		  (prompt-for-file
+		   :prompt "Source Filename: "
+		   :help "Name of file to rename.  One wildcard is permitted."
+		   :must-exist nil)))
+	 (dest (namestring
+		(prompt-for-file
+		 :prompt (if (directoryp source)
+			     "Destination Directory Name: "
+			     "Destination Filename: ")
+		 :help "Name of new file."
+		 :default source
+		 :must-exist nil)))
+	 (dired:*error-function* #'dired-error-function)
+	 (dired:*report-function* #'dired-report-function)
+	 (dired:*yesp-function* #'dired-yesp-function))
+    (dired:rename-file source dest
+		       :clobber (not (value dired-rename-file-confirm))))
+  (maintain-dired-consistency))
+
+(defun maintain-dired-consistency ()
+  (dolist (info *pathnames-to-dired-buffers*)
+    (let* ((directory (directory-namestring (car info)))
+	   (buffer (cdr info))
+	   (dir-info (variable-value 'dired-information :buffer buffer))
+	   (write-date (file-write-date directory)))
+      (unless (= (dired-info-write-date dir-info) write-date)
+	(update-dired-buffer directory (dired-info-pattern dir-info) buffer)))))
+
+
+
+;;;; Dired utilities.
+
+;;; GET-MARKED-DIRED-FILES returns as multiple values a list of file specs
+;;; and a list of directory specs that have been marked for deletion.  This
+;;; assumes the current buffer is a "Dired" buffer.
+;;;
+(defun get-marked-dired-files ()
+  (let* ((files (dired-info-files (value dired-information)))
+	 (length (length files))
+	 (marked-files ())
+	 (marked-dirs ()))
+    (unless files (editor-error "Not in Dired buffer."))
+    (do ((i 0 (1+ i)))
+	((= i length) (values (nreverse marked-files) (nreverse marked-dirs)))
+      (let* ((thing (svref files i))
+	     (pathname (dired-file-pathname thing)))
+	(when (dired-file-deleted-p thing)
+	  (if (directoryp pathname)
+	      (push (cons pathname (file-write-date pathname)) marked-dirs)
+	      (push (cons pathname (file-write-date pathname))
+		    marked-files)))))))
+
+;;; ARRAY-ELEMENT-FROM-MARK counts the lines between it and the beginning
+;;; of the buffer.  The number is used to index vector as if each line
+;;; mapped to an element starting with the zero'th element (lines are
+;;; numbered starting at 1).
+;;;
+(defun array-element-from-mark (mark vector
+				&optional (error-msg "Invalid line."))
+  (when (blank-line-p (mark-line mark)) (editor-error error-msg))
+  (svref vector
+	 (1- (count-lines (region
+			   (buffer-start-mark (line-buffer (mark-line mark)))
+			   mark)))))
+
+;;; DIRED-NAMIFY and DIRED-DIRECTORIFY are implementation dependent slime.
+;;;
+(defun dired-namify (pathname)
+  (let* ((string (namestring pathname))
+	 (last (1- (length string))))
+    (if (char= (schar string last) #\/)
+	(subseq string 0 last)
+	string)))
+;;;
+;;; This is necessary to derive a canonical representation for directory
+;;; names, so "Dired" can map various strings naming one directory to that
+;;; one directory.
+;;;
+(defun dired-directorify (pathname)
+  (let ((directory (lisp::predict-name pathname t)))
+    (if (directoryp directory)
+	directory
+	(pathname (concatenate 'simple-string (namestring directory) "/")))))
+
+
+
+;;;; View Mode.
+
+(defmode "View" :major-p nil
+  :setup-function 'setup-view-mode
+  :cleanup-function 'cleanup-view-mode
+  :precedence 5.0
+  :documentation
+  "View mode scrolls forwards and backwards in a file with the buffer read-only.
+   Scrolling off the end optionally deletes the buffer.")
+
+(defun setup-view-mode (buffer)
+  (defhvar "View Return Function"
+    "Function that gets called when quitting or returning from view mode."
+    :value nil
+    :buffer buffer)
+  (setf (buffer-writable buffer) nil))
+;;;
+(defun cleanup-view-mode (buffer)
+  (delete-variable 'view-return-function :buffer buffer)
+  (setf (buffer-writable buffer) t))
+
+(defcommand "View File" (p &optional pathname)
+  "Reads a file in as if by \"Find File\", but read-only.  Commands exist
+   for scrolling convenience."
+  "Reads a file in as if by \"Find File\", but read-only.  Commands exist
+   for scrolling convenience."
+  (declare (ignore p))
+  (let* ((pn (or pathname
+		 (prompt-for-file 
+		  :prompt "View File: " :must-exist t
+		  :help "Name of existing file to read into its own buffer."
+		  :default (buffer-default-pathname (current-buffer)))))
+	 (buffer (make-buffer (format nil "View File ~A" (gensym)))))
+    (visit-file-command nil pn buffer)
+    (setf (buffer-minor-mode buffer "View") t)
+    (change-to-buffer buffer)
+    buffer))
+
+(defcommand "View Return" (p)
+  "Return to a parent buffer, if it exists."
+  "Return to a parent buffer, if it exists."
+  (declare (ignore p))
+  (unless (call-view-return-fun)
+    (editor-error "No View return method for this buffer.")))
+
+(defcommand "View Quit" (p)
+  "Delete a buffer in view mode."
+  "Delete a buffer in view mode, invoking VIEW-RETURN-FUNCTION if it exists for
+   this buffer."
+  (declare (ignore p))
+  (let* ((buf (current-buffer))
+	 (funp (call-view-return-fun)))
+    (delete-buffer-if-possible buf)
+    (unless funp (editor-error "No View return method for this buffer."))))
+
+;;; CALL-VIEW-RETURN-FUN returns nil if there is no current
+;;; view-return-function.  If there is one, it calls it and returns t.
+;;;
+(defun call-view-return-fun ()
+  (if (hemlock-bound-p 'view-return-function)
+      (let ((fun (value view-return-function)))
+	(cond (fun
+	       (funcall fun)
+	       t)))))
+
+
+(defhvar "View Scroll Deleting Buffer"
+  "When this is set, \"View Scroll Down\" deletes the buffer when the end
+   of the file is visible."
+  :value t)
+
+(defcommand "View Scroll Down" (p)
+  "Scroll the current window down through its buffer.
+   If the end of the file is visible, then delete the buffer if \"View Scroll
+   Deleting Buffer\" is set.  If the buffer is associated with a dired buffer,
+   this returns there instead of to the previous buffer."
+  "Scroll the current window down through its buffer.
+   If the end of the file is visible, then delete the buffer if \"View Scroll
+   Deleting Buffer\" is set.  If the buffer is associated with a dired buffer,
+   this returns there instead of to the previous buffer."
+  (if (and (not p)
+	   (displayed-p (buffer-end-mark (current-buffer))
+			(current-window))
+	   (value view-scroll-deleting-buffer))
+      (view-quit-command nil)
+      (scroll-window-down-command p)))
+
+(defcommand "View Edit File" (p)
+  "Turn off \"View\" mode in this buffer."
+  "Turn off \"View\" mode in this buffer."
+  (declare (ignore p))
+  (let ((buf (current-buffer)))
+    (setf (buffer-minor-mode buf "View") nil)
+    (warn-about-visit-file-buffers buf)))
+
+(defcommand "View Help" (p)
+  "Shows \"View\" mode help message."
+  "Shows \"View\" mode help message."
+  (declare (ignore p))
+  (describe-mode-command nil "View"))
diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a171aa7d3caa46f2b02d3edcea15298219d00d16
--- /dev/null
+++ b/hemlock/echocoms.lisp
@@ -0,0 +1,315 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Echo area commands.
+;;;
+;;; Written by Rob MacLachlan and Skef Wholey.
+;;;
+(in-package 'hemlock)
+
+(defhvar "Beep on Ambiguity"
+  "If non-NIL, beep when completion of a parse is ambiguous."
+  :value t)
+
+(defhvar "Ignore File Types"
+  "File types to ignore when trying to complete a filename."
+  :value
+  (list "fasl" "err"			    ; Lisp
+	"BAK" "CKP"			    ; Backups & Checkpoints
+	"PS" "ps" "press" "otl" "dvi" "toc" ; Formatting
+	"bbl" "lof" "idx" "lot" "aux"	    ; Formatting
+	"mo" "elc"			    ; Other editors
+	"bin" "lbin"			    ; Obvious binary extensions.
+	"o" "a" "aout"			    ; UNIXY stuff
+	"bm" "onx" "snf"		    ; X stuff
+	"UU" "uu" "arc" "Z" "tar"	    ; Binary encoded files
+	))
+
+
+;;; Field separator characters separate fields for TOPS-20 ^F style 
+;;; completion.
+(defattribute "Parse Field Separator"
+  "A value of 1 for this attribute indicates that the corresponding character
+  should be considered to be a field separator by the prompting commands.")
+(setf (character-attribute :parse-field-separator #\space) 1)
+
+
+;;; Find-All-Completions  --  Internal
+;;;
+;;;    Return as a list of all the possible completions of String in the
+;;; list of string-tables Tables.
+;;;
+(defun find-all-completions (string tables)
+  (do ((table tables (cdr table))
+       (res () 
+	    (merge 'list (find-ambiguous string (car table)) 
+		   res #'string-lessp)))
+      ((null table) res)))
+
+(defcommand "Help on Parse" (p)
+  "Display help for parse in progress.
+  If there are a limited number of options then display them."
+  "Display the *Parse-Help* and any possibly completions of the current
+  input."
+  (declare (ignore p))
+  (let ((help (typecase *parse-help*
+		(list (unless *parse-help* (error "There is no parse help."))
+		      (apply #'format nil *parse-help*))
+		(string *parse-help*)
+		(t (error "Parse help is not a string or list: ~S" *parse-help*))))
+	(input (region-to-string *parse-input-region*)))
+    (cond
+     ((eq *parse-type* :keyword)
+      (let ((strings (find-all-completions input *parse-string-tables*)))
+	(with-pop-up-display (s :height (+ (length strings) 2))
+	  (write-line help s)
+	  (cond (strings
+		 (write-line "Possible completions of what you have typed:" s)
+		 (dolist (string strings)
+		   (write-line string s)))
+		(t
+		 (write-line 
+ "There are no possible completions of what you have typed." s))))))
+     ((and (eq *parse-type* :file) (not (zerop (length input))))
+      (let ((pns (ambiguous-files (region-to-string *parse-input-region*)
+				  *parse-default*)))
+	(declare (list pns))
+	(with-pop-up-display(s :height (+ (length pns) 2))
+	  (write-line help s)
+	  (cond (pns
+		 (write-line "Possible completions of what you have typed:" s)
+		 (dolist (pn pns)
+		   (format s " ~A~25T ~A~%" (file-namestring pn)
+			   (directory-namestring pn))))
+		(t
+		 (write-line 
+ "There are no possible completions of what you have typed." s))))))
+     (t
+      (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting))
+	(insert-string m help)
+	(insert-character m #\newline))))))
+
+(defun file-completion-action (typein)
+  (declare (simple-string typein))
+  (when (zerop (length typein)) (editor-error))
+  (multiple-value-bind
+      (result win)
+      (complete-file typein
+		     :defaults (directory-namestring *parse-default*)
+		     :ignore-types (value ignore-file-types))
+    (when result
+      (delete-region *parse-input-region*)
+      (insert-string (region-start *parse-input-region*)
+		     (namestring result)))
+    (when (and (not win) (value beep-on-ambiguity))
+      (editor-error))))
+
+(defcommand "Complete Keyword" (p)
+  "Trys to complete the text being read in the echo area as a string in
+  *parse-string-tables*"
+  "Complete the keyword being parsed as far as possible.
+  If it is ambiguous and ``Beep On Ambiguity'' true beep."
+  (declare (ignore p))
+  (let ((typein (region-to-string *parse-input-region*)))
+    (declare (simple-string typein))
+    (case *parse-type*
+      (:keyword
+       (multiple-value-bind
+	   (prefix key value field ambig)
+	   (complete-string typein *parse-string-tables*)
+	 (declare (ignore value field))
+	 (when prefix
+	   (delete-region *parse-input-region*)
+	   (insert-string (region-start *parse-input-region*) prefix)
+	   (when (eq key :ambiguous)
+	     (let ((point (current-point)))
+	       (move-mark point (region-start *parse-input-region*))
+	       (unless (character-offset point ambig)
+		 (buffer-end point)))))
+	 (when (and (or (eq key :ambiguous) (eq key :none))
+		    (value beep-on-ambiguity))
+	   (editor-error))))
+      (:file
+       (file-completion-action typein))
+      (t
+       (editor-error "Cannot complete input for this prompt.")))))
+
+(defun field-separator-p (x)
+  (plusp (character-attribute :parse-field-separator x)))
+
+(defcommand "Complete Field" (p)
+  "Complete a field in a parse.
+  Fields are defined by the :field separator attribute,
+  the text being read in the echo area as a string in *parse-string-tables*"
+  "Complete a field in a keyword.
+  If it is ambiguous and ``Beep On Ambiguity'' true beep.  Fields are
+  separated by characters having a non-zero :parse-field-separator attribute,
+  and this command should only be bound to characters having that attribute."
+  (let ((typein (region-to-string *parse-input-region*)))
+    (declare (simple-string typein))
+    (case *parse-type*
+      (:string
+       (self-insert-command p))
+      (:file
+       (file-completion-action typein))
+      (:keyword
+       (let ((point (current-point)))
+	 (unless (blank-after-p point)
+	   (insert-character point *last-character-typed*)))
+       (multiple-value-bind
+	   (prefix key value field ambig)
+	   (complete-string typein *parse-string-tables*)
+	 (declare (ignore value ambig))
+	 (when (eq key :none) (editor-error "No possible completion."))
+	 (delete-region *parse-input-region*)
+	 (let ((new-typein (if (and (eq key :unique) (null field))
+			       (subseq prefix 0 field)
+			       (concatenate 'string
+					    (subseq prefix 0 field)
+					    (string *last-character-typed*)))))
+	   (insert-string (region-start *parse-input-region*) new-typein))))
+      (t
+       (editor-error "Cannot complete input for this prompt.")))))
+
+
+(defvar *echo-area-history* (make-ring 10)
+  "This ring-buffer contains strings which were previously input in the
+  echo area.")
+
+(defvar *echo-history-pointer* 0
+  "This is our current position to the ring during a historical exploration.")
+
+(defcommand "Confirm Parse" (p)
+  "Terminate echo-area input.
+  If the input is invalid then an editor-error will signalled."
+  "If no input has been given, exits the recursive edit with the default,
+  otherwise calls the verification function."
+  (declare (ignore p))
+  (let* ((string (region-to-string *parse-input-region*))
+	 (empty (zerop (length string))))
+    (declare (simple-string string))
+    (if empty
+	(when *parse-default* (setq string *parse-default*))
+	(when (or (zerop (ring-length *echo-area-history*))
+		  (string/= string (ring-ref *echo-area-history* 0)))
+	  (ring-push string *echo-area-history*)))
+    (multiple-value-bind (res flag)
+			 (funcall *parse-verification-function* string)
+      (unless (or res flag) (editor-error))
+      (exit-recursive-edit res))))
+
+(defcommand "Previous Parse" (p)
+  "Rotate the echo-area history forward.
+  If current input is non-empty and different from what is on the top
+  of the ring then push it on the ring before inserting the new input."
+  "Pop the *echo-area-history* ring buffer."
+  (let ((length (ring-length *echo-area-history*))
+	(p (or p 1)))
+    (declare (simple-string current))
+    (when (zerop length) (editor-error))
+    (cond
+     ((eq (last-command-type) :echo-history)
+      (let ((base (mod (+ *echo-history-pointer* p) length)))
+	(delete-region *parse-input-region*)
+	(insert-string (region-end *parse-input-region*)
+		       (ring-ref *echo-area-history* base))
+	(setq *echo-history-pointer* base)))
+     (t
+      (let ((current (region-to-string *parse-input-region*))
+	    (base (mod (if (minusp p) p (1- p)) length)))
+	(delete-region *parse-input-region*)
+	(insert-string (region-end *parse-input-region*)
+		       (ring-ref *echo-area-history* base))	
+	(when (and (plusp (length current))
+		   (string/= (ring-ref *echo-area-history* 0) current))
+	  (ring-push current *echo-area-history*)
+	  (incf base))
+	(setq *echo-history-pointer* base))))
+    (setf (last-command-type) :echo-history)))
+
+(defcommand "Next Parse" (p)
+  "Rotate the echo-area history backward.
+  If current input is non-empty and different from what is on the top
+  of the ring then push it on the ring before inserting the new input."
+  "Push the *echo-area-history* ring buffer."
+  (previous-parse-command (- (or p 1))))
+
+(defcommand "Illegal" (p)
+  "This signals an editor-error.
+  It is useful for making commands locally unbound."
+  "Just signals an editor-error."
+  (declare (ignore p))
+  (editor-error))
+
+(defcommand "Beginning Of Parse" (p)
+  "Moves to immediately after the prompt when in the echo area."
+  "Move the point of the echo area buffer to *parse-starting-mark*."
+  (declare (ignore p))
+  (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*))
+
+(defcommand "Echo Area Delete Previous Character" (p)
+  "Delete the previous character.
+  Don't let the luser rub out the prompt."
+  "Signal an editor-error if we would nuke the prompt,
+  otherwise do a normal delete."
+  (with-mark ((tem (buffer-point *echo-area-buffer*)))
+    (unless (character-offset tem (- (or p 1))) (editor-error))
+    (when (mark< tem *parse-starting-mark*) (editor-error))
+    (delete-previous-character-command p)))
+
+(defcommand "Echo Area Kill Previous Word" (p)
+  "Kill the previous word.
+  Don't let the luser rub out the prompt."
+  "Signal an editor-error if we would mangle the prompt, otherwise
+  do a normal kill-previous-word."
+  (with-mark ((tem (buffer-point *echo-area-buffer*)))
+    (unless (word-offset tem (- (or p 1))) (editor-error))
+    (when (mark< tem *parse-starting-mark*) (editor-error))
+    (kill-previous-word-command p)))
+
+(proclaim '(special *kill-ring*))
+
+(defcommand "Kill Parse" (p)
+  "Kills any input so far."
+  "Kills *parse-input-region*."
+  (declare (ignore p))
+  (if (end-line-p (current-point))
+      (kill-region *parse-input-region* :kill-backward)
+      (ring-push (delete-and-save-region *parse-input-region*)
+		 *kill-ring*)))
+
+(defcommand "Insert Parse Default" (p)
+  "Inserts the default for the parse in progress.
+  The text is inserted at the point."
+  "Inserts *parse-default* at the point of the *echo-area-buffer*.
+  If there is no default an editor-error is signalled."
+  (declare (ignore p))
+  (unless *parse-default* (editor-error))
+  (insert-string (buffer-point *echo-area-buffer*) *parse-default*))
+
+(defcommand "Echo Area Backward Character" (p)
+  "Go back one character.
+  Don't let the luser move into the prompt."
+  "Signal an editor-error if we try to go into the prompt, otherwise
+  do a backward-character command."
+  (backward-character-command p)
+  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
+    (beginning-of-parse-command ())
+    (editor-error)))
+
+(defcommand "Echo Area Backward Word" (p)
+  "Go back one word.
+  Don't let the luser move into the prompt."
+  "Signal an editor-error if we try to go into the prompt, otherwise
+  do a backward-word command."
+  (backward-word-command p)
+  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
+    (beginning-of-parse-command ())
+    (editor-error)))
diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..00b18161aaed5df926a478f691adf33a67037737
--- /dev/null
+++ b/hemlock/eval-server.lisp
@@ -0,0 +1,981 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; This file contains code for connecting to eval servers and some command
+;;; level stuff too.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HEMLOCK")
+
+
+
+;;;; Structures.
+
+(defstruct (server-info (:print-function print-server-info))
+  name			      ; String name of this server.
+  wire			      ; Wire connected to this server.
+  notes			      ; List of note objects for operations
+			      ;  which have not yet completed.
+  slave-info		      ; Ts-Info used in "Slave Lisp" buffer
+			      ;  (formerly the "Lisp Listener" buffer).
+  slave-buffer		      ; "Slave Lisp" buffer for slave's *terminal-io*.
+  background-info	      ; Ts-Info structure of typescript we use in
+			      ;  "background" buffer.
+  background-buffer	      ; Buffer "background" typescript is in.
+  (errors		      ; Array of errors while compiling
+   (make-array 16
+	       :adjustable t
+	       :fill-pointer 0))
+  error-index)		      ; Index of current error.
+;;;
+(defun print-server-info (obj stream n)
+  (declare (ignore n))
+  (format stream "#<Server-info for ~A>" (server-info-name obj)))
+
+
+(defstruct (error-info (:print-function print-error-info))
+  buffer		      ; Buffer this error is for.
+  message		      ; Error Message
+  line			      ; Pointer to message in log buffer.
+  region)		      ; Region of faulty text
+;;;
+(defun print-error-info (obj stream n)
+  (declare (ignore n))
+  (format stream "#<Error: ~A>" (error-info-message obj)))
+
+
+(defvar *server-names* (make-string-table)
+  "A string-table of the name of all Eval servers and their corresponding
+   server-info structures.")
+
+(defvar *abort-operations* nil
+  "T iff we should ignore any operations sent to us.")
+
+(defvar *inside-operation* nil
+  "T iff we are currenly working on an operation. A catcher for the tag 
+   abort-operation will be established whenever this is T.")
+
+(defconstant *slave-connect-wait* 300)
+
+;;; Used internally for communications.
+;;;
+(defvar *newly-created-slave* nil)
+(defvar *compiler-wire* nil)
+(defvar *compiler-error-stream* nil)
+(defvar *compiler-note* nil)
+
+
+
+;;;; Hemlock Variables
+
+(defhvar "Current Eval Server"
+  "The Server-Info object for the server currently used for evaluation and
+   compilation."
+  :value nil)
+
+(defhvar "Current Compile Server"
+  "The Server-Info object for the server currently used for compilation
+   requests."
+  :value nil)
+
+(defhvar "Current Package"
+  "This variable holds the name of the package currently used for Lisp
+   evaluation and compilation.  If it is Nil, the value of *Package* is used
+   instead."
+  :value nil)
+
+(defhvar "Slave Utility"
+  "This is the pathname of the utility to fire up slave Lisps.  It defaults
+   to /usr/misc/.lisp/bin/lisp."
+  :value "/usr/misc/.lisp/bin/lisp")
+
+(defhvar "Slave Utility Switches"
+  "These are additional switches to pass to the Slave Utility.
+   For example, (list \"-core\" <core-file-name>).  The -slave
+   switch and the editor name are always supplied, and they should
+   not be present in this variable."
+  :value nil)
+
+(defhvar "Ask About Old Servers"
+  "When set (the default), Hemlock will prompt for an existing server's name
+   in preference to prompting for a new slave's name and creating it."
+  :value t)
+
+(defhvar "Confirm Slave Creation"
+  "When set (the default), Hemlock always confirms a slave's creation for
+   whatever reason."
+  :value t)
+
+
+
+;;;; Slave destruction.
+
+;;; WIRE-DIED -- Internal.
+;;;
+;;; The routine is called whenever a wire dies.  We roll through all the
+;;; servers looking for any that use this wire and nuke them with server-died.
+;;;
+(defun wire-died (wire)
+  (let ((servers nil))
+    (do-strings (name info *server-names*)
+      (declare (ignore name))
+      (when (eq wire (server-info-wire info))
+	(push info servers)))
+    (dolist (server servers)
+      (server-died server))))
+
+;;; SERVER-DIED -- Internal.
+;;;
+;;; Clean up the server. Remove any references to it from variables, etc.
+;;;
+(defun server-died (server)
+  (let ((name (server-info-name server)))
+    (delete-string name *server-names*)
+    (message "Server ~A just died." name))
+  (when (server-info-wire server)
+    (let ((fd (wire:wire-fd (server-info-wire server))))
+      (system:invalidate-descriptor fd)
+      (mach:unix-close fd))
+    (setf (server-info-wire server) nil))
+  (when (server-info-slave-info server)
+    (ts-buffer-wire-died (server-info-slave-info server))
+    (setf (server-info-slave-info server) nil))
+  (when (server-info-background-info server)
+    (ts-buffer-wire-died (server-info-background-info server))
+    (setf (server-info-background-info server) nil))
+  (clear-server-errors server)
+  (when (eq server (variable-value 'current-eval-server :global))
+    (setf (variable-value 'current-eval-server :global) nil))
+  (when (eq server (variable-value 'current-compile-server :global))
+    (setf (variable-value 'current-compile-server :global) nil))
+  (dolist (buffer *buffer-list*)
+    (dolist (var '(current-eval-server current-compile-server server-info))
+      (when (and (hemlock-bound-p var :buffer buffer)
+		 (eq (variable-value var :buffer buffer) server))
+	(delete-variable var :buffer buffer)))))
+
+;;; SERVER-CLEANUP -- Internal.
+;;;
+;;; This routine is called as a buffer delete hook.  It takes care of any
+;;; per-buffer cleanup that is necessary.  It clears out all references to the
+;;; buffer from server-info structures and that any errors that refer to this
+;;; buffer are finalized.
+;;;
+(defun server-cleanup (buffer)
+  (let ((info (if (hemlock-bound-p 'server-info :buffer buffer)
+		  (variable-value 'server-info :buffer buffer))))
+    (when info
+      (when (eq buffer (server-info-slave-buffer info))
+	(setf (server-info-slave-buffer info) nil)
+	(setf (server-info-slave-info info) nil))
+      (when (eq buffer (server-info-background-buffer info))
+	(setf (server-info-background-buffer info) nil)
+	(setf (server-info-background-info info) nil))))
+  (do-strings (string server *server-names*)
+    (declare (ignore string))
+    (clear-server-errors server
+			 #'(lambda (error)
+			     (eq (error-info-buffer error) buffer)))))
+;;;
+(add-hook delete-buffer-hook 'server-cleanup)
+
+;;; CLEAR-SERVER-ERRORS -- Public.
+;;;
+;;; Clears all known errors for the given server and resets it so more can
+;;; accumulate.
+;;;
+(defun clear-server-errors (server &optional test-fn)
+  "This clears compiler errors for server cleaning up any pointers for GC
+   purposes and allowing more errors to register."
+  (let ((array (server-info-errors server))
+	(current nil))
+    (dotimes (i (fill-pointer array))
+      (let ((error (aref array i)))
+	(when (or (null test-fn)
+		  (funcall test-fn error))
+	  (let ((region (error-info-region error)))
+	    (when (regionp region)
+	      (delete-mark (region-start region))
+	      (delete-mark (region-end region))))
+	  (setf (aref array i) nil))))
+    (let ((index (server-info-error-index server)))
+      (when index
+	(setf current
+	      (or (aref array index)
+		  (find-if-not #'null array
+			       :from-end t
+			       :end current)))))
+    (delete nil array)
+    (setf (server-info-error-index server)
+	  (position current array))))
+
+
+
+;;;; Slave creation.
+
+;;; INITIALIZE-SERVER-STUFF -- Internal.
+;;;
+;;; Reinitialize stuff when a core file is saved.
+;;;
+(defun initialize-server-stuff ()
+  (clrstring *server-names*))
+
+
+(defvar *editor-name* nil "Name of this editor.")
+(defvar *accept-connections* nil
+  "When set, allow slaves to connect to the editor.")
+
+;;; GET-EDITOR-NAME -- Internal.
+;;;
+;;; Pick a name for the editor.  Names consist of machine-name:port-number.  If
+;;; in ten tries we can't get an unused port, choak.  We don't save the result
+;;; of WIRE:CREATE-REQUEST-SERVER because we don't think the editor needs to
+;;; ever kill the request server, and we can always inhibit connection with
+;;; "Accept Connections".
+;;;
+(defun get-editor-name ()
+  (if *editor-name*
+      *editor-name*
+      (let ((random-state (make-random-state t)))
+	(dotimes (tries 10 (error "Could not create an internet listener."))
+	  (let ((port (+ 2000 (random 10000 random-state))))
+	    (when (handler-case (wire:create-request-server
+				 port
+				 #'(lambda (wire addr)
+				     (declare (ignore addr))
+				     (values *accept-connections*
+					     #'(lambda () (wire-died wire)))))
+		    (error () nil))
+	      (return (setf *editor-name*
+			    (format nil "~A:~D" (machine-instance) port)))))))))
+
+
+;;; MAKE-BUFFERS-FOR-TYPESCRIPT -- Internal.
+;;;
+;;; This function returns no values because it is called remotely for value by
+;;; connecting slaves.  Though we know the system will propagate nil back to
+;;; the slave, we indicate here that nil is meaningless.
+;;;
+(defun make-buffers-for-typescript (slave-name background-name)
+  "Make the interactive and background buffers slave-name and background-name.
+   If either is nil, then prompt the user."
+  (multiple-value-bind (slave-name background-name)
+		       (if (and slave-name background-name)
+			   (values slave-name background-name)
+			   (pick-slave-buffer-names))
+    (let* ((slave-buffer (or (getstring slave-name *buffer-names*)
+			     (make-buffer slave-name :modes '("Lisp"))))
+	   (background-buffer (or (getstring background-name *buffer-names*)
+				  (make-buffer background-name
+					       :modes '("Lisp"))))
+	   (server-info (make-server-info :name slave-name
+					  :wire wire:*current-wire*
+					  :slave-buffer slave-buffer
+					  :background-buffer background-buffer))
+	   (slave-info (typescriptify-buffer slave-buffer server-info
+					     wire:*current-wire*))
+	   (background-info (typescriptify-buffer background-buffer server-info
+						  wire:*current-wire*)))
+      (setf (server-info-slave-info server-info) slave-info)
+      (setf (server-info-background-info server-info) background-info)
+      (setf (getstring slave-name *server-names*) server-info)
+      (unless (variable-value 'current-eval-server :global)
+	(setf (variable-value 'current-eval-server :global) server-info))
+      (wire:remote-value
+       wire:*current-wire*
+       (made-buffers-for-typescript (wire:make-remote-object slave-info)
+				    (wire:make-remote-object background-info)))
+      (setf *newly-created-slave* server-info)
+      (values))))
+
+
+;;; CREATE-SLAVE -- Public.
+;;;
+(defun create-slave (&optional name)
+  "This creates a slave that tries to connect to the editor.  When the slave
+   connects to the editor, this returns a slave-information structure.  Name is
+   the name of the interactive buffer.  If name is nil, this generates a name.
+   If name is supplied, and a buffer with that name already exists, this
+   signals an error.  In case the slave never connects, this will eventually
+   timeout and signal an editor-error."
+  (when (and name (getstring name *buffer-names*))
+    (editor-error "Buffer ~A is already in use." name))
+  (multiple-value-bind (slave background)
+		       (if name
+			   (values name (format nil "Background ~A" name))
+			   (pick-slave-buffer-names))
+    (when (value confirm-slave-creation)
+       (setf slave (prompt-for-string
+		    :prompt "New slave name? "
+		    :help "Enter the name to use for the newly created slave."
+		    :default slave
+		    :default-string slave))
+       (setf background (format nil "Background ~A" slave))
+       (when (getstring slave *buffer-names*)
+	 (editor-error "Buffer ~A is already in use." slave))
+       (when (getstring background *buffer-names*)
+	 (editor-error "Buffer ~A is already in use." background)))
+    (message "Spawning slave ... ")
+    (unless (ext:run-program (namestring (truename (value slave-utility)))
+			     `("-slave" ,(get-editor-name)
+			       ,@(if slave (list "-slave-buffer" slave))
+			       ,@(if background
+				     (list "-background-buffer" background))
+			       ,@(value slave-utility-switches))
+			     :wait nil
+			     :output "/dev/null"
+			     :if-output-exists :append)
+      (editor-error "Could not start slave."))
+    (let ((*accept-connections* t)
+	  (*newly-created-slave* nil))
+      (dotimes (i *slave-connect-wait*
+		  (editor-error "Client Lisp is still unconnected.  ~
+				 You must use \"Accept Slave Connections\" to ~
+				 allow the slave to connect at this point."))
+	(system:serve-event 1)
+	(when *newly-created-slave*
+	  (message "DONE")
+	  (return *newly-created-slave*))))))
+
+;;; MAYBE-CREATE-SERVER -- Internal interface.
+;;;
+(defun maybe-create-server ()
+  "If there is an existing server and \"Ask about Old Servers\" is set, then
+   prompt for a server's name and return that server's info.  Otherwise,
+   create a new server."
+  (if (value ask-about-old-servers)
+      (multiple-value-bind (first-server-name first-server-info)
+			   (do-strings (name info *server-names*)
+			     (return (values name info)))
+	(if first-server-info
+	    (multiple-value-bind
+		(name info)
+		(prompt-for-keyword (list *server-names*)
+				    :prompt "Existing server name: "
+				    :default first-server-name
+				    :default-string first-server-name
+				    :help
+				    "Enter the name of an existing eval server."
+				    :must-exist t)
+	      (declare (ignore name))
+	      (or info (create-slave)))
+	    (create-slave)))
+      (create-slave)))
+
+
+(defvar *next-slave-index* 0
+  "Number to use when creating the next slave.")
+
+;;; PICK-SLAVE-BUFFER-NAMES -- Internal.
+;;;
+;;; Return two unused names to use for the slave and background buffers.
+;;;
+(defun pick-slave-buffer-names ()
+  (loop
+    (let ((slave (format nil "Slave ~D" (incf *next-slave-index*)))
+	  (background (format nil "Background Slave ~D" *next-slave-index*)))
+      (unless (or (getstring slave *buffer-names*)
+		  (getstring background *buffer-names*))
+	(return (values slave background))))))
+
+
+
+;;;; Slave selection.
+
+;;; GET-CURRENT-EVAL-SERVER -- Public.
+;;;
+(defun get-current-eval-server (&optional errorp)
+  "Returns the server-info struct for the current eval server.  If there is
+   none, and errorp is non-nil, then signal an editor error.  If there is no
+   current server, and errorp is nil, then create one, prompting the user for
+   confirmation.  Also, set the current server to be the newly created one."
+  (let ((info (value current-eval-server)))
+    (cond (info)
+	  (errorp
+	   (editor-error "No current eval server."))
+	  (t
+	   (setf (value current-eval-server) (maybe-create-server))))))
+
+;;; GET-CURRENT-COMPILE-SERVER -- Public.
+;;;
+;;; If a current compile server is defined, return it, otherwise return the
+;;; current eval server using get-current-eval-server.
+;;;
+(defun get-current-compile-server (&optional errorp)
+  "Returns the server-info struct for the current compile server. If there is
+   no current compile server, return the current eval server."
+  (or (value current-compile-server)
+      (get-current-eval-server errorp)))
+
+
+
+;;;; Server Manipulation commands.
+
+(defcommand "Select Slave" (p)
+  "Switch to the current slave's buffer.  When given an argument, create a new
+   slave."
+  "Switch to the current slave's buffer.  When given an argument, create a new
+   slave."
+  (let* ((info (if p (create-slave) (get-current-eval-server)))
+	 (slave (server-info-slave-buffer info)))
+    (unless slave
+      (editor-error "The current eval server doesn't have a slave buffer!"))
+    (change-to-buffer slave)))
+
+(defcommand "Select Background" (p)
+  "Switch to the current slave's background buffer. When given an argument, use
+   the current compile server instead of the current eval server."
+  "Switch to the current slave's background buffer. When given an argument, use
+   the current compile server instead of the current eval server."
+  (let* ((info (if p
+		 (get-current-compile-server t)
+		 (get-current-eval-server t)))
+	 (background (server-info-background-buffer info)))
+    (unless background
+      (editor-error "The current ~A server doesn't have a background buffer!"
+		    (if p "compile" "eval")))
+    (change-to-buffer background)))
+
+(defcommand "Kill Slave" (p)
+  "This aborts any operations in the slave, tells the slave to QUIT, and shuts
+   down the connection to the specified eval server.  This makes no attempt to
+   assure the eval server actually dies."
+  "This aborts any operations in the slave, tells the slave to QUIT, and shuts
+   down the connection to the specified eval server.  This makes no attempt to
+   assure the eval server actually dies."
+  (declare (ignore p))
+  (let ((default (and (value current-eval-server)
+		      (server-info-name (value current-eval-server)))))
+    (multiple-value-bind
+	(name info)
+	(prompt-for-keyword
+	 (list *server-names*)
+	 :prompt "Kill Slave: "
+	 :help "Enter the name of the eval server you wish to destroy."
+	 :must-exist t
+	 :default default
+	 :default-string default)
+      (declare (ignore name))
+      (let ((wire (server-info-wire info)))
+	(when wire
+	  (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
+	  (wire:remote wire (ext:quit))
+	  (wire:wire-force-output wire)))
+      (server-died info))))
+
+(defcommand "Kill Slave and Buffers" (p)
+  "This is the same as \"Kill Slave\", but it also deletes the slaves
+   interaction and background buffers."
+  "This is the same as \"Kill Slave\", but it also deletes the slaves
+   interaction and background buffers."
+  (declare (ignore p))
+  (let ((default (and (value current-eval-server)
+		      (server-info-name (value current-eval-server)))))
+    (multiple-value-bind
+	(name info)
+	(prompt-for-keyword
+	 (list *server-names*)
+	 :prompt "Kill Slave: "
+	 :help "Enter the name of the eval server you wish to destroy."
+	 :must-exist t
+	 :default default
+	 :default-string default)
+      (declare (ignore name))
+      (let ((wire (server-info-wire info)))
+	(when wire
+	  (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
+	  (wire:remote wire (ext:quit))
+	  (wire:wire-force-output wire)))
+      (let ((buffer (server-info-slave-buffer info)))
+	(when buffer (delete-buffer-if-possible buffer)))
+      (let ((buffer (server-info-background-buffer info)))
+	(when buffer (delete-buffer-if-possible buffer)))
+      (server-died info))))
+
+(defcommand "Accept Slave Connections" (p)
+  "This causes Hemlock to accept slave connections and displays the port of
+   the editor's connections request server.  This is suitable for use with the
+   Lisp's -slave switch.  Given an argument, this inhibits slave connections."
+  "This causes Hemlock to accept slave connections and displays the port of
+   the editor's connections request server.  This is suitable for use with the
+   Lisp's -slave switch.  Given an argument, this inhibits slave connections."
+  (let ((accept (not p)))
+    (setf *accept-connections* accept)
+    (message "~:[Inhibiting~;Accepting~] connections to ~S"
+	     accept (get-editor-name))))
+
+
+
+;;;; Slave initialization junk.
+
+(defvar *original-beep-function* nil
+  "Handle on original beep function.")
+
+(defvar *original-gc-notify-before* nil
+  "Handle on original before-GC notification function.")
+
+(defvar *original-gc-notify-after* nil
+  "Handle on original after-GC notification function.")
+
+(defvar *original-terminal-io* nil
+  "Handle on original *terminal-io* so we can restore it.")
+
+(defvar *original-standard-input* nil
+  "Handle on original *standard-input* so we can restore it.")
+
+(defvar *original-standard-output* nil
+  "Handle on original *standard-output* so we can restore it.")
+
+(defvar *original-error-output* nil
+  "Handle on original *error-output* so we can restore it.")
+
+(defvar *original-debug-io* nil
+  "Handle on original *debug-io* so we can restore it.")
+
+(defvar *original-query-io* nil
+  "Handle on original *query-io* so we can restore it.")
+
+(defvar *original-trace-output* nil
+  "Handle on original *trace-output* so we can restore it.")
+
+(defvar *background-io* nil
+  "Stream connected to the editor's background buffer in case we want to use it
+  in the future.")
+
+;;; CONNECT-STREAM -- internal
+;;;
+;;; Run in the slave to create a new stream and connect it to the supplied
+;;; buffer.  Returns the stream.
+;;; 
+(defun connect-stream (remote-buffer)
+  (let ((stream (make-ts-stream wire:*current-wire* remote-buffer)))
+    (wire:remote wire:*current-wire*
+      (ts-buffer-set-stream remote-buffer
+			    (wire:make-remote-object stream)))
+    stream))
+
+;;; MADE-BUFFERS-FOR-TYPESCRIPT -- Internal Interface.
+;;;
+;;; Run in the slave by the editor with the two buffers' info structures,
+;;; actually remote-objects in the slave.  Does any necessary stream hacking.
+;;; Return nil to make sure no weird objects try to go back over the wire
+;;; since the editor calls this in the slave for value.  The editor does this
+;;; for synch'ing, not for values.
+;;;
+(defun made-buffers-for-typescript (slave-info background-info)
+  (macrolet ((frob (symbol new-value)
+	       `(setf ,(intern (concatenate 'simple-string
+					    "*ORIGINAL-"
+					    (subseq (string symbol) 1)))
+		      ,symbol
+		      ,symbol ,new-value)))
+    (let ((wire wire:*current-wire*))
+      (frob system:*beep-function*
+	    #'(lambda (&optional stream)
+		(declare (ignore stream))
+		(wire:remote-value wire (beep))))
+      (frob ext:*gc-notify-before*
+	    #'(lambda (bytes-in-use)
+		(wire:remote wire
+		  (slave-gc-notify-before
+		   slave-info
+		   (format nil
+			   "~%[GC threshold exceeded with ~:D bytes in use.  ~
+			   Commencing GC.]~%"
+			   bytes-in-use)))
+		(wire:wire-force-output wire)))
+      (frob ext:*gc-notify-after*
+	    #'(lambda (bytes-retained bytes-freed new-trigger)
+		(wire:remote wire
+		  (slave-gc-notify-after
+		   slave-info
+		   (format nil
+			   "[GC completed with ~:D bytes retained and ~:D ~
+			   bytes freed.]~%[GC will next occur when at least ~
+			   ~:D bytes are in use.]~%"
+			   bytes-retained bytes-freed new-trigger)))
+		(wire:wire-force-output wire))))
+    (frob *terminal-io* (connect-stream slave-info))
+    (frob *standard-input* (make-synonym-stream '*terminal-io*))
+    (frob *standard-output* *standard-input*)
+    (frob *error-output* *standard-input*)
+    (frob *debug-io* *standard-input*)
+    (frob *query-io* *standard-input*)
+    (frob *trace-output* *standard-input*))
+  (setf *background-io* (connect-stream background-info))
+  nil)
+
+;;; SLAVE-GC-NOTIFY-BEFORE and SLAVE-GC-NOTIFY-AFTER -- internal
+;;;
+;;; These two routines are run in the editor by the slave's gc notify routines.
+;;; 
+(defun slave-gc-notify-before (remote-ts message)
+  (let ((ts (wire:remote-object-value remote-ts)))
+    (ts-buffer-output-string ts message t)
+    (message "~A is GC'ing." (buffer-name (ts-data-buffer ts)))
+    (system:beep)))
+(defun slave-gc-notify-after (remote-ts message)
+  (let ((ts (wire:remote-object-value remote-ts)))
+    (ts-buffer-output-string ts message t)
+    (message "~A is done GC'ing." (buffer-name (ts-data-buffer ts)))
+    (system:beep)))
+
+;;; EDITOR-DIED -- internal
+;;;
+;;; Run in the slave when the editor goes belly up.
+;;; 
+(defun editor-died ()
+  (macrolet ((frob (symbol)
+	       (let ((orig (intern (concatenate 'simple-string
+						"*ORIGINAL-"
+						(subseq (string symbol) 1)))))
+		 `(when ,orig
+		    (setf ,symbol ,orig)))))
+    (frob system:*beep-function*)
+    (frob ext:*gc-notify-before*)
+    (frob ext:*gc-notify-after*)
+    (frob *terminal-io*)
+    (frob *standard-input*)
+    (frob *standard-output*)
+    (frob *error-output*)
+    (frob *debug-io*)
+    (frob *query-io*)
+    (frob *trace-output*))
+  (setf *background-io* nil)
+  (format t "~2&Connection to editor died.~%")
+  (ext:quit))
+
+;;; START-SLAVE -- internal
+;;;
+;;; Initiate the process by which a lisp becomes a slave.
+;;; 
+(defun start-slave (editor)
+  (declare (simple-string editor))
+  (let ((seperator (position #\: editor :test #'char=)))
+    (unless seperator
+      (error "Editor name ~S invalid. ~
+              Must be of the form \"MachineName:PortNumber\"."
+	     editor))
+    (let ((machine (subseq editor 0 seperator))
+	  (port (parse-integer editor :start (1+ seperator))))
+      (format t "Connecting to ~A:~D~%" machine port)
+      (connect-to-editor machine port))))
+
+;;; CONNECT-TO-EDITOR -- internal
+;;;
+;;; Do the actual connect to the editor.
+;;; 
+(defun connect-to-editor (machine port
+			  &optional
+			  (slave (find-eval-server-switch "slave-buffer"))
+			  (background (find-eval-server-switch
+				       "background-buffer")))
+  (let ((wire (wire:connect-to-remote-server machine port 'editor-died)))
+    (ext:add-oob-handler (wire:wire-fd wire)
+			  #\B
+			  #'(lambda ()
+			      (system:without-hemlock
+			       (system:with-interrupts
+				(break "Software Interrupt")))))
+    (ext:add-oob-handler (wire:wire-fd wire)
+			  #\T
+			  #'(lambda ()
+			      (when lisp::*in-top-level-catcher*
+				(throw 'lisp::top-level-catcher nil))))
+    (ext:add-oob-handler (wire:wire-fd wire)
+			  #\A
+			  #'abort)
+    (ext:add-oob-handler (wire:wire-fd wire)
+			  #\N
+			  #'(lambda ()
+			      (setf *abort-operations* t)
+			      (when *inside-operation*
+				(throw 'abort-operation
+				       (if debug::*in-the-debugger*
+					   :was-in-debugger)))))
+    (wire:remote-value wire
+      (make-buffers-for-typescript slave background))))
+
+
+;;;; Eval server evaluation functions.
+
+(defvar *eval-form-stream*
+  (make-two-way-stream
+   (lisp::make-stream
+    :in #'(lambda (&rest junk)
+	    (declare (ignore junk))
+	    (error "You cannot read when handling an eval_form request.")))
+   (make-broadcast-stream)))
+
+;;; SERVER-EVAL-FORM -- Public.
+;;;   Evaluates the given form (which is a string to be read from in the given
+;;; package) and returns the results as a list.
+;;;
+(defun server-eval-form (package form)
+  (declare (simple-string package form))
+  (handler-bind
+      ((error #'(lambda (condition)
+		  (wire:remote wire:*current-wire*
+			       (eval-form-error (format nil "~A~&" condition)))
+		  (return-from server-eval-form nil))))
+    (let ((*package* (if package
+			 (lisp::package-or-lose package)
+			 *package*))
+	  (*terminal-io* *eval-form-stream*))
+      (stringify-list (multiple-value-list (eval (read-from-string form)))))))
+
+
+;;; DO-OPERATION -- Internal.
+;;;   Checks to see if we are aborting operations. If not, do the operation
+;;; wrapping it with operation-started and operation-completed calls. Also
+;;; deals with setting up *terminal-io* and *package*.
+;;;
+(defmacro do-operation ((note package terminal-io) &body body)
+  `(let ((aborted t)
+	 (*terminal-io* (if ,terminal-io
+			  (wire:remote-object-value ,terminal-io)
+			  *terminal-io*))
+	 (*package* (maybe-make-package ,package)))
+     (unwind-protect
+	 (unless *abort-operations*
+	   (when (eq :was-in-debugger
+		     (catch 'abort-operation
+		       (let ((*inside-operation* t))
+			 (wire:remote wire:*current-wire*
+				      (operation-started ,note))
+			 (wire:wire-force-output wire:*current-wire*)
+			 ,@body
+			 (setf aborted nil))))
+	     (format t
+		     "~&[Operation aborted.  ~
+		      You are no longer in this instance of the debugger.]~%")))
+       (wire:remote wire:*current-wire*
+	 (operation-completed ,note aborted))
+       (wire:wire-force-output wire:*current-wire*))))
+
+
+;;; unique-thingie is a unique eof-value for READ'ing.  Its a parameter, so
+;;; we can reload the file.
+;;;
+(defparameter unique-thingie (gensym)
+  "Used as eof-value in reads to check for the end of a file.")
+
+;;; SERVER-EVAL-TEXT -- Public.
+;;;
+;;;   Evaluate all the forms read from text in the given package, and send the
+;;; results back.  The error handler bound does not handle any errors.  It
+;;; simply notifies the client that an error occurred and then returns.
+;;;
+(defun server-eval-text (note package text terminal-io)
+  (do-operation (note package terminal-io)
+    (with-input-from-string (stream text)
+      (let ((last-pos 0))
+	(handler-bind
+	    ((error
+	      #'(lambda (condition)
+		  (wire:remote wire:*current-wire*
+			       (lisp-error note last-pos
+					   (file-position stream)
+					   (format nil "~A~&" condition))))))
+	  (loop
+	    (let ((form (read stream nil unique-thingie)))
+	      (when (eq form unique-thingie)
+		(return nil))
+	      (let* ((values (stringify-list (multiple-value-list (eval form))))
+		     (pos (file-position stream)))
+		(wire:remote wire:*current-wire*
+		  (eval-text-result note last-pos pos values))
+		(setf last-pos pos)))))))))
+
+(defun stringify-list (list)
+  (mapcar #'prin1-to-string list))
+#|
+(defun stringify-list (list)
+  (mapcar #'(lambda (thing)
+	      (with-output-to-string (stream)
+		(write thing
+		       :stream stream :radix nil :base 10 :circle t
+		       :pretty nil :level nil :length nil :case :upcase
+		       :array t :gensym t)))
+	  list))
+|#
+
+
+;;;; Eval server compilation stuff.
+
+;;; DO-COMPILER-OPERATION -- Internal.
+;;;
+;;; Useful macro that does the operation with *compiler-note* and
+;;; *compiler-wire* bound.
+;;;
+(defmacro do-compiler-operation ((note package terminal-io error) &body body)
+  `(let ((*compiler-note* ,note)
+	 (*compiler-error-stream* ,error)
+	 (*compiler-wire* wire:*current-wire*)
+	 (clc:*compiler-notification-function* #'compiler-note-in-editor))
+     (do-operation (*compiler-note* ,package ,terminal-io)
+		   (unwind-protect
+		       (handler-bind ((error #'compiler-error-handler))
+			 ,@body)
+		     (when *compiler-error-stream*
+		       (force-output *compiler-error-stream*))))))
+
+;;; COMPILER-NOTIFICATION -- Internal.
+;;;
+;;; DO-COMPILER-OPERATION binds clc:*compiler-notification-function to this, so
+;;; interesting observations in the compilation can be propagated back to the
+;;; editor.  If there is a notification point defined, we send information
+;;; about the position and kind of error.  The actual error text is written out
+;;; using typescript operations.
+;;;
+;;; Start and End are the compiler's best guess at the file position where the
+;;; error occurred.  Function is the symbolic name of the function in which the
+;;; error occurred.  We PRIN1 this to a string because sending the symbol back
+;;; to the editor could easily result in the editor trying to fetch a symbol
+;;; off the wire into a non-existing package.  We expect packages to exist in
+;;; the developing Lisp environment that are missing in the editor's Lisp.
+;;;
+(defun compiler-note-in-editor (severity function)
+  (when *compiler-wire*
+    (force-output *compiler-error-stream*)
+    (multiple-value-bind (start end)
+			 (clc:current-form-position)
+      (wire:remote *compiler-wire*
+	(compiler-error *compiler-note* start end
+			(prin1-to-string function)
+			severity)))
+    (wire:wire-force-output *compiler-wire*)))
+
+;;; COMPILER-ERROR-HANDLER -- Internal.
+;;;
+;;;    The error handler function for the compiler interfaces.
+;;; DO-COMPILER-OPERATION binds this as an error handler while evaluating the
+;;; compilation form.
+;;;
+(defun compiler-error-handler (condition)
+  (when *compiler-wire*
+    (multiple-value-bind (start end)
+			 (clc:current-form-position)
+      (wire:remote *compiler-wire*
+	(lisp-error *compiler-note* start end
+		    (format nil "~A~&" condition))))))
+
+
+
+
+;;; SERVER-COMPILE-TEXT -- Public.
+;;;
+;;;    Similar to server-eval-text, except that the stuff is compiled.
+;;;
+(defun server-compile-text (note package text defined-from
+			    terminal-io error-output)
+  (let ((error-output (if error-output
+			(wire:remote-object-value error-output))))
+    (do-compiler-operation (note package terminal-io error-output)
+      (with-input-from-string (input-stream text)
+	(terpri error-output)
+	(compile-from-stream input-stream
+			     :error-stream error-output
+			     :defined-from-pathname defined-from)))))
+
+;;; SERVER-COMPILE-FILE -- Public.
+;;;
+;;;    Compiles the file sending error info back to the editor.
+;;;
+(defun server-compile-file (note package input output error lap
+			    load terminal background)
+  (macrolet ((frob (x)
+	       `(if (wire:remote-object-p ,x)
+		  (wire:remote-object-value ,x)
+		  ,x)))
+    (let ((error-stream (frob background)))
+      (do-compiler-operation (note package terminal error-stream)
+	(compile-file (frob input)
+		      :output-file (frob output)
+		      :error-file (frob error)
+		      :lap-file (frob lap)
+		      :load load
+		      :errors-to-terminal error-stream)))))
+
+
+;;;; Other random eval server stuff.
+
+;;; MAYBE-MAKE-PACKAGE -- Internal.
+;;;
+;;; Returns a package for a name.  Creates it if it doesn't already exist.
+;;;
+(defun maybe-make-package (name)
+  (cond ((null name) *package*)
+	((find-package name))
+	(t
+	 (wire:remote-value (ts-stream-wire *terminal-io*)
+	   (ts-buffer-output-string
+	    (ts-stream-typescript *terminal-io*)
+	    (format nil "~&Creating package ~A.~%" name)
+	    t))
+	 (make-package name))))
+
+;;; SERVER-SET-PACKAGE -- Public.
+;;;
+;;;   Serves package setting requests.  It simply sets
+;;; *package* to an already existing package or newly created one.
+;;;
+(defun server-set-package (package)
+  (setf *package* (maybe-make-package package)))
+
+;;; SERVER-ACCEPT-OPERATIONS -- Public.
+;;;
+;;;   Start accepting operations again.
+;;;
+(defun server-accept-operations ()
+  (setf *abort-operations* nil))
+
+
+
+;;;; Command line switches.
+
+;;; FIND-EVAL-SERVER-SWITCH -- Internal.
+;;;
+;;; This is special to the switches supplied by CREATE-SLAVE and fetched by
+;;; CONNECT-EDITOR-SERVER, so we can use STRING=.
+;;;
+(defun find-eval-server-switch (string)
+  (let ((switch (find string ext:*command-line-switches*
+		      :test #'string=
+		      :key #'ext:cmd-switch-name)))
+    (if switch
+	(or (ext:cmd-switch-value switch)
+	    (car (ext:cmd-switch-words switch))))))
+
+
+(defun slave-switch-demon (switch)
+  (let ((editor (ext:cmd-switch-arg switch)))
+    (unless editor
+      (error "Editor to connect to unspesified."))
+    (start-slave editor)))
+;;;
+(defswitch "slave" 'slave-switch-demon)
+(defswitch "slave-buffer")
+(defswitch "background-buffer")
+
+
+(defun edit-switch-demon (switch)
+  (declare (ignore switch))
+#|  (let ((arg (or (ext:cmd-switch-value switch)
+		 (car (ext:cmd-switch-words switch)))))
+    (when (stringp arg) (setq *editor-name* arg)))|#
+  (let ((initp (not (ext:get-command-line-switch "noinit"))))
+    (if (stringp (car ext:*command-line-words*))
+	(ed (car ext:*command-line-words*) :init initp)
+	(ed nil :init initp))))
+;;;
+(defswitch "edit" 'edit-switch-demon)
diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..443c9c0895c7e36258e2569ac414acf4b6f05656
--- /dev/null
+++ b/hemlock/filecoms.lisp
@@ -0,0 +1,1039 @@
+;;; -*- Package: Hemlock; Log: hemlock.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains file/buffer manipulating commands.
+;;;
+(in-package "HEMLOCK")
+
+
+
+;;;; PROCESS-FILE-OPTIONS.
+
+(defvar *mode-option-handlers* ()
+  "Do not modify this; use Define-File-Option instead.")
+
+(defvar *file-type-hooks* ()
+  "Do not modify this; use Define-File-Type-Hook instead.")  
+
+(defun trim-subseq (string start end)
+  (declare (simple-string string))
+  (string-trim '(#\Space #\Tab) (subseq string start end)))
+
+;;; PROCESS-FILE-OPTIONS checks the first line of buffer for the file options
+;;; indicator "-*-".  IF it finds this, then it enters a do-file-options block.
+;;; If any parsing errors occur while picking out options, we return from this
+;;; block.  Staying inside this function at this point, allows us to still set
+;;; a major mode if no file option specified one.
+;;;
+;;; We also cater to old style mode comments:
+;;;    -*- Lisp -*-
+;;;    -*- Text -*-
+;;; This kicks in if we find no colon on the file options line.
+;;;
+(defun process-file-options (buffer &optional
+				    (pathname (buffer-pathname buffer)))
+  "Checks for file options and invokes handlers if there are any.  If no
+   \"Mode\" mode option is specified, then this tries to invoke the appropriate
+   file type hook."
+  (let* ((string
+	  (line-string (mark-line (buffer-start-mark buffer))))
+	 (found (search "-*-" string))
+	 (no-major-mode t)
+	 (type (if pathname (pathname-type pathname))))
+    (declare (simple-string string))
+    (when found
+      (block do-file-options
+	(let* ((start (+ found 3))
+	       (end (search "-*-" string :start2 start)))
+	  (unless end
+	    (loud-message "No closing \"-*-\".  Aborting file options.")
+	    (return-from do-file-options))
+	  (cond
+	   ((find #\: string :start start :end end)
+	    (do ((opt-start start (1+ semi)) colon semi)
+		(nil)
+	      (setq colon (position #\: string :start opt-start :end end))
+	      (unless colon
+		(loud-message "Missing \":\".  Aborting file options.")
+		(return-from do-file-options))
+	      (setq semi (or (position #\; string :start colon :end end) end))
+	      (let* ((option (nstring-downcase
+			      (trim-subseq string opt-start colon)))
+		     (handler (assoc option *mode-option-handlers*
+				     :test #'string=)))
+		(declare (simple-string option))
+		(cond
+		 (handler
+		  (let ((result (funcall (cdr handler) buffer
+					 (trim-subseq string (1+ colon) semi))))
+		    (when (string= option "mode")
+		      (setq no-major-mode (not result)))))
+		 (t (message "Unknown file option: ~S" option)))
+		(when (= semi end) (return nil)))))
+	   (t
+	    ;; Old style mode comment.
+	    (setq no-major-mode nil)
+	    (funcall (cdr (assoc "mode" *mode-option-handlers* :test #'string=))
+		     buffer (trim-subseq string start end)))))))
+    (when (and no-major-mode type)
+      (let ((hook (assoc (string-downcase type) *file-type-hooks*
+			 :test #'string=)))
+	(when hook (funcall (cdr hook) buffer type))))))
+
+
+
+;;;; File options and file type hooks.
+
+(defmacro define-file-option (name lambda-list &body body)
+  "Define-File-Option Name (Buffer Value) {Form}*
+   Defines a new file option to be user in the -*- line at the top of a file.
+   The body is evaluated with Buffer bound to the buffer the file has been read
+   into and Value to the string argument to the option."
+  (let ((name (string-downcase name)))
+    `(setf (cdr (or (assoc ,name *mode-option-handlers*  :test #'string=)
+		    (car (push (cons ,name nil) *mode-option-handlers*))))
+	   #'(lambda ,lambda-list ,@body))))
+
+(define-file-option "Mode" (buffer str)
+  (let ((seen-major-mode-p nil)
+	(lastpos 0))
+    (loop
+      (let* ((pos (position #\, str :start lastpos))
+	     (substr (trim-subseq str lastpos pos)))
+	(cond ((getstring substr *mode-names*)
+	       (cond ((mode-major-p substr)
+		      (when seen-major-mode-p
+			(loud-message
+			 "Major mode already processed. Using ~S now."
+			 substr))
+		      (setf seen-major-mode-p t)
+		      (setf (buffer-major-mode buffer) substr))
+		     (t
+ 		      (setf (buffer-minor-mode buffer substr) t))))
+	      (t
+	       (loud-message "~S is not a defined mode -- ignored." substr)))
+	(unless pos
+	  (return seen-major-mode-p))
+	(setf lastpos (1+ pos))))))
+
+
+(defmacro define-file-type-hook (type-list (buffer type) &body body)
+  "Define-File-Type-Hook ({Type}*) (Buffer Type) {Form}*
+  Define some code to be evaluated when a file having one of the specified
+  Types is read by a file command.  Buffer is bound to the buffer the
+  file is in, and Type is the actual type read."
+  (let ((fun (gensym)) (str (gensym)))
+    `(flet ((,fun (,buffer ,type) ,@body))
+       (dolist (,str ',(mapcar #'string-downcase type-list))
+	 (setf (cdr (or (assoc ,str *file-type-hooks*  :test #'string=)
+			(car (push (cons ,str nil) *file-type-hooks*))))
+	       #',fun)))))
+
+(define-file-type-hook ("pas" "pasmac" "macro" "defs" "spc" "bdy")
+  		       (buffer type)
+  (declare (ignore type))
+  (setf (buffer-major-mode buffer) "Pascal"))
+
+(define-file-type-hook ("lisp" "slisp" "l" "lsp" "mcl") (buffer type)
+  (declare (ignore type))
+  (setf (buffer-major-mode buffer) "Lisp"))
+
+(define-file-type-hook ("txt" "text" "tx") (buffer type)
+  (declare (ignore type))
+  (setf (buffer-major-mode buffer) "Text"))
+
+
+
+;;;; Support for file hacking commands:
+
+(defhvar "Pathname Defaults"
+  "This variable contains a pathname which is used to supply defaults
+   when we don't have anything better."
+  :value (pathname "gazonk.del"))
+
+(defhvar "Last Resort Pathname Defaults"
+  "This variable contains a pathname which is used to supply defaults when
+   we don't have anything better, but unlike \"Pathname Defaults\", this is
+   never set to some buffer's pathname."
+  :value (pathname "gazonk"))
+
+(defhvar "Last Resort Pathname Defaults Function"
+  "This variable contains a function that is called when a default pathname is
+   needed, the buffer has no pathname, and the buffer's name is not entirely
+   composed of alphanumerics.  The default value is a function that simply
+   returns \"Last Resort Pathname Defaults\".  The function must take a buffer
+   as an argument, and it must return some pathname."
+  :value #'(lambda (buffer)
+	     (declare (ignore buffer))
+	     (merge-pathnames (value last-resort-pathname-defaults)
+			      (value pathname-defaults))))
+
+(defun buffer-default-pathname (buffer)
+  "Returns \"Buffer Pathname\" if it is bound.  If it is not, and buffer's name
+   is composed solely of alphnumeric characters, then return a pathname formed
+   from the buffer's name.  If the buffer's name has other characters in it,
+   then return the value of \"Last Resort Pathname Defaults Function\" called
+   on buffer."
+  (or (buffer-pathname buffer)
+      (if (every #'alphanumericp (the simple-string (buffer-name buffer)))
+	  (merge-pathnames (make-pathname :name (buffer-name buffer))
+			   (value pathname-defaults))
+	  (funcall (value last-resort-pathname-defaults-function) buffer))))
+
+
+(defun pathname-to-buffer-name (pathname)
+  "Returns a simple-string using components from pathname."
+  (let ((pathname (pathname pathname)))
+    (concatenate 'simple-string
+		 (file-namestring pathname)
+		 " "
+		 (directory-namestring pathname))))
+
+
+
+;;;; File hacking commands.
+
+(defcommand "Process File Options" (p)
+  "Reprocess this buffer's file options."
+  "Reprocess this buffer's file options."
+  (declare (ignore p))
+  (process-file-options (current-buffer)))
+
+(defcommand "Insert File" (p &optional pathname (buffer (current-buffer)))
+  "Inserts a file which is prompted for into the current buffer at the point.
+  The prefix argument is ignored."
+  "Inserts the file named by Pathname into Buffer at the point."
+  (declare (ignore p))
+  (let* ((pn (or pathname
+		 (prompt-for-file :default (buffer-default-pathname buffer)
+				  :prompt "Insert File: "
+				  :help "Name of file to insert")))
+	 (point (buffer-point buffer))
+	 ;; start and end will be deleted by undo stuff
+	 (start (copy-mark point :right-inserting))
+	 (end (copy-mark point :left-inserting))
+	 (region (region start end)))
+    (setv pathname-defaults pn)
+    (push-buffer-mark (copy-mark end))
+    (read-file pn end)
+    (make-region-undo :delete "Insert File" region)))
+
+(defcommand "Write Region" (p &optional pathname)
+  "Writes the current region to a file. "
+  "Writes the current region to a file. "
+  (declare (ignore p))
+  (let ((region (current-region))
+	(pn (or pathname
+		(prompt-for-file :prompt "File to Write: "
+				 :help "The name of the file to write the region to. "
+				 :default (buffer-default-pathname
+					   (current-buffer))
+				 :must-exist nil))))
+    (write-file region pn)
+    (message "~A written." (namestring (truename pn)))))
+
+
+
+;;;; Visiting and reverting files.
+
+(defcommand "Visit File" (p &optional pathname (buffer (current-buffer)))
+  "Replaces the contents of Buffer with the file Pathname.  The prefix
+   argument is ignored.  The buffer is set to be writable, so its region
+   can be deleted."
+  "Replaces the contents of the current buffer with the text in the file
+   which is prompted for.  The prefix argument is, of course, ignored p times."
+  (declare (ignore p))
+  (when (and (buffer-modified buffer)
+	     (prompt-for-y-or-n :prompt "Buffer is modified, save it? "))
+    (save-file-command () buffer))
+  (let ((pn (or pathname
+		(prompt-for-file :prompt "Visit File: "
+				 :must-exist nil
+				 :help "Name of file to visit."
+				 :default (buffer-default-pathname buffer)))))
+    (setf (buffer-writable buffer) t)
+    (read-buffer-file pn buffer)
+    (let ((n (pathname-to-buffer-name (buffer-pathname buffer))))
+      (unless (getstring n *buffer-names*)
+	(setf (buffer-name buffer) n))
+      (warn-about-visit-file-buffers buffer))))
+
+(defun warn-about-visit-file-buffers (buffer)
+  (let ((buffer-pn (buffer-pathname buffer)))
+    (dolist (b *buffer-list*)
+      (unless (eq b buffer)
+	(let ((bpn (buffer-pathname b)))
+	  (when (equal bpn buffer-pn)
+	    (message "Buffer ~A also contains ~A."
+		     (buffer-name b) (namestring buffer-pn))
+	    (return)))))))
+
+
+(defhvar "Revert File Confirm"
+  "If this is true, Revert File will prompt before reverting."
+  :value t)
+
+(defcommand "Revert File" (p)
+  "Unless in Save Mode, reads in the last saved version of the file in
+  the current buffer. When in Save Mode, reads in the last checkpoint or
+  the last saved version, whichever is more recent. An argument will always
+  force Revert File to use the last saved version. In either case, if the
+  buffer has been modified and \"Revert File Confirm\" is true, then Revert
+  File will ask for confirmation beforehand. An attempt is made to maintain
+  the point's relative position."
+  "With an argument reverts to the last saved version of the file in the
+  current buffer. Without, reverts to the last checkpoint or last saved
+  version, whichever is more recent."
+  (let* ((buffer (current-buffer))
+	 (buffer-pn (buffer-pathname buffer))
+	 (point (current-point))
+	 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
+    (multiple-value-bind (revert-pn used-checkpoint)
+			 (if p buffer-pn (revert-pathname buffer))
+      (unless revert-pn
+	(editor-error "No file associated with buffer to revert to!"))
+      (when (or (not (value revert-file-confirm))
+		(not (buffer-modified buffer))
+		(prompt-for-y-or-n
+		 :prompt
+		 "Buffer contains changes, are you sure you want to revert? "
+		 :help (list
+ "Reverting the file will undo any changes by reading in the last ~
+ ~:[saved version~;checkpoint file~]." used-checkpoint)
+		 :default t))
+	(read-buffer-file revert-pn buffer)
+	(when used-checkpoint
+	  (setf (buffer-modified buffer) t)
+	  (setf (buffer-pathname buffer) buffer-pn)
+	  (message "Reverted to checkpoint file ~A." (namestring revert-pn)))
+	(unless (line-offset point lines)
+	  (buffer-end point))))))
+
+;;; REVERT-PATHNAME -- Internal
+;;;
+;;; If in Save Mode, return either the checkpoint pathname or the buffer
+;;; pathname whichever is more recent. Otherwise return the buffer-pathname
+;;; if it exists. If neither file exists, return NIL.
+;;; 
+(defun revert-pathname (buffer)
+  (let* ((buffer-pn (buffer-pathname buffer))
+	 (buffer-pn-date (file-write-date buffer-pn))
+	 (checkpoint-pn (get-checkpoint-pathname buffer))
+	 (checkpoint-pn-date (file-write-date checkpoint-pn)))
+    (cond (checkpoint-pn-date
+	   (if (> checkpoint-pn-date (or buffer-pn-date 0))
+	       (values checkpoint-pn t)
+	       (values buffer-pn nil)))
+	  (buffer-pn-date (values buffer-pn nil))
+	  (t (values nil nil)))))
+
+
+
+;;;; Find file.
+
+(defcommand "Find File" (p &optional pathname)
+  "Visit a file in its own buffer.
+  If the file is already in some buffer, select that buffer,
+  otherwise make a new buffer with the same name as the file and
+  read the file into it."
+  "Make a buffer containing the file Pathname current, creating a buffer
+  if necessary.  The buffer is returned."
+  (declare (ignore p))
+  (let* ((pn (or pathname
+		 (prompt-for-file 
+		  :prompt "Find File: "
+		  :must-exist nil
+		  :help "Name of file to read into its own buffer."
+		  :default (buffer-default-pathname (current-buffer)))))
+	 (buffer (find-file-buffer pn)))
+    (change-to-buffer buffer)
+    buffer))
+
+(defun find-file-buffer (pathname)
+  "Return a buffer assoicated with the file Pathname, reading the file into a
+   new buffer if necessary.  The second value is T if we created a buffer, NIL
+   otherwise.  If the file has already been read, we check to see if the file
+   has been modified on disk since it was read, giving the user various
+   recovery options."
+  (let* ((pathname (pathname pathname))
+	 (trial-pathname (or (probe-file pathname)
+			     (merge-pathnames pathname (default-directory))))
+	 (found (find trial-pathname (the list *buffer-list*)
+		     :key #'buffer-pathname :test #'equal)))
+    (cond ((not found)
+	   (let* ((name (pathname-to-buffer-name trial-pathname))
+		  (buffer (getstring name *buffer-names*))
+		  (use (if buffer
+			   (prompt-for-buffer
+			    :prompt "Buffer to use: "
+			    :help
+  "Buffer name in use; give another buffer name, or confirm to reuse."
+			    :default buffer :must-exist nil)
+			   (make-buffer name)))
+		  (buffer (if (stringp use) (make-buffer use) use)))
+	     (when (and (buffer-modified buffer)
+			(prompt-for-y-or-n :prompt
+					   "Buffer is modified, save it? "))
+	       (save-file-command () buffer))
+	     (read-buffer-file pathname buffer)
+	     (values buffer (stringp use))))
+	  ((check-disk-version-consistent pathname found)
+	   (values found nil))
+	  (t
+	   (read-buffer-file pathname found)
+	   (values found nil)))))
+
+;;; Check-Disk-Version-Consistent  --  Internal
+;;;
+;;;    Check that Buffer contains a valid version of the file Pathname,
+;;; harrassing the user if not.  We return true if the buffer is O.K., and
+;;; false if the file should be read. 
+;;;
+(defun check-disk-version-consistent (pathname buffer)
+  (let ((ndate (file-write-date pathname))
+	(odate (buffer-write-date buffer)))
+    (cond ((not (and ndate odate (/= ndate odate)))
+	   t)
+	  ((buffer-modified buffer)
+	   (beep)
+	   (clear-input)
+	   (command-case (:prompt (list
+ "File has been changed on disk since it was read and you have made changes too!~
+ ~%Read in the disk version of ~A? [Y] " (namestring pathname))
+			  :help
+ "The file in disk has been changed since Hemlock last saved it, meaning that
+ someone else has probably overwritten it.  Since the version read into Hemlock
+ has been changed as well, the two versions may have inconsistent changes.  If
+ this is the case, it would be a good idea to save your changes in another file
+ and compare the two versions.
+ 
+ Type one of the following commands:")
+	     ((:confirm :yes)
+ "Prompt for a file to write the buffer out to, then read in the disk version."
+	      (write-buffer-file
+	       buffer
+	       (prompt-for-file
+		:prompt "File to save changes in: "
+		:help (list "Save buffer ~S to this file before reading ~A."
+			    (buffer-name buffer) (namestring pathname))
+		:must-exist nil
+		:default (buffer-default-pathname buffer)))
+	      nil)
+	     (:no
+	      "Change to the buffer without reading the new version."
+	      t)
+	     (#\R
+	      "Read in the new version, clobbering the changes in the buffer."
+	      nil)))
+	   (t
+	    (not (prompt-for-yes-or-no :prompt
+				       (list
+ "File has been changed on disk since it was read.~
+ ~%Read in the disk version of ~A? "
+					(namestring pathname))
+				       :help
+ "Type Y to read in the new version or N to just switch to the buffer."
+				       :default t))))))
+
+
+(defhvar "Read File Hook"
+  "These functions are called when a file is read into a buffer.  Each function
+   must take two arguments -- the buffer the file was read into and whether the
+   file existed (non-nil) or not (nil).")
+
+(defun read-buffer-file (pathname buffer)
+  "Delete the buffer's region, and uses READ-FILE to read pathname into it.
+   If the file exists, set the buffer's write date to the file's; otherwise,
+   MESSAGE that this is a new file and set the buffer's write date to nil.
+   Move buffer's point to the beginning, set the buffer unmodified.  If the
+   file exists, set the buffer's pathname to the probed pathname; else, set it
+   to pathname merged with DEFAULT-DIRECTORY.  Set \"Pathname Defaults\" to the
+   same thing.  Process the file options, and then invoke \"Read File Hook\"."
+  (delete-region (buffer-region buffer))
+  (let* ((pathname (pathname pathname))
+	 (probed-pathname (probe-file pathname)))
+    (cond (probed-pathname
+	   (read-file probed-pathname (buffer-point buffer))
+	   (setf (buffer-write-date buffer) (file-write-date probed-pathname)))
+	  (t
+	   (message "(New File)")
+	   (setf (buffer-write-date buffer) nil)))
+    (buffer-start (buffer-point buffer))
+    (setf (buffer-modified buffer) nil)
+    (let ((stored-pathname (or probed-pathname
+			       (merge-pathnames pathname (default-directory)))))
+      (setf (buffer-pathname buffer) stored-pathname)
+      (setf (value pathname-defaults) stored-pathname)
+      (process-file-options buffer stored-pathname)
+      (invoke-hook read-file-hook buffer probed-pathname))))
+
+
+
+;;;; File writing.
+
+(defhvar "Add Newline at EOF on Writing File"
+  "This controls whether WRITE-BUFFER-FILE adds a newline at the end of the
+   file when it ends at the end of a non-empty line.  When set, this may be
+   :ask-user and WRITE-BUFFER-FILE will prompt; otherwise, just add one and
+   inform the user.  When nil, never add one and don't ask."
+  :value :ask-user)
+
+(defhvar "Keep Backup Files"
+  "When set, .BAK files will be saved upon file writing.  This defaults to nil."
+  :value nil)
+
+(defhvar "Write File Hook"
+  "These functions are called when a buffer has been written.  Each function
+   must take the buffer as an argument.")
+
+(defun write-buffer-file (buffer pathname)
+  "Write's buffer to pathname.  This assumes pathname is somehow related to
+   the buffer's pathname, and if the buffer's write date is not the same as
+   pathname's, then this prompts the user for confirmation before overwriting
+   the file.  This consults \"Add Newline at EOF on Writing File\" and
+   interacts with the user if necessary.  This sets \"Pathname Defaults\", and
+   the buffer is marked unmodified.  The buffer's pathname and write date are
+   updated, and the buffer is renamed according to the new pathname if possible.
+   This invokes \"Write File Hook\"."
+  (let ((buffer-pn (buffer-pathname buffer)))
+    (let ((date (buffer-write-date buffer))
+	  (file-date (when (probe-file pathname) (file-write-date pathname))))
+      (when (and buffer-pn date file-date
+		 (equal (make-pathname :version nil :defaults buffer-pn)
+			(make-pathname :version nil :defaults pathname))
+		 (/= date file-date))
+	(unless (prompt-for-yes-or-no :prompt (list
+ "File has been changed on disk since it was read.~%Overwrite ~A anyway? "
+ (namestring buffer-pn))
+				      :help
+				      "Type No to abort writing the file or Yes to overwrite the disk version."
+				      :default nil)
+	  (editor-error "Write aborted."))))
+    (let ((val (value add-newline-at-eof-on-writing-file)))
+      (when val
+	(let ((end (buffer-end-mark buffer)))
+	  (unless (start-line-p end)
+	    (when (if (eq val :ask-user)
+		      (prompt-for-y-or-n
+		       :prompt
+		       (list "~A~%File does not have a newline at EOF, add one? "
+			     (buffer-name buffer))
+		       :default t)
+		      t)
+	      (insert-character end #\newline)
+	      (message "Added newline at EOF."))))))
+    (setv pathname-defaults pathname)
+    (write-file (buffer-region buffer) pathname)
+    (let ((tn (truename pathname)))
+      (message "~A written." (namestring tn))
+      (setf (buffer-modified buffer) nil)
+      (unless (equal tn buffer-pn)
+	(setf (buffer-pathname buffer) tn))
+      (setf (buffer-write-date buffer) (file-write-date tn))
+      (let ((name (pathname-to-buffer-name tn)))
+	(unless (getstring name *buffer-names*)
+	  (setf (buffer-name buffer) name)))))
+  (invoke-hook write-file-hook buffer))
+ 
+(defcommand "Write File" (p &optional pathname (buffer (current-buffer)))
+  "Writes the contents of Buffer, which defaults to the current buffer to
+  the file named by Pathname.  The prefix argument is ignored."
+  "Prompts for a file to write the contents of the current Buffer to.
+  The prefix argument is ignored."
+  (declare (ignore p))
+  (write-buffer-file
+   buffer
+   (or pathname
+       (prompt-for-file :prompt "Write File: "
+			:must-exist nil
+			:help "Name of file to write to"
+			:default (buffer-default-pathname buffer)))))
+
+(defcommand "Save File" (p &optional (buffer (current-buffer)))
+  "Writes the contents of the current buffer to the associated file.  If there
+  is no associated file, once is prompted for."
+  "Writes the contents of the current buffer to the associated file."
+  (declare (ignore p))
+  (when (or (buffer-modified buffer)
+	    (prompt-for-y-or-n 
+	     :prompt "Buffer is unmodified, write it anyway? "
+	     :default t))
+    (write-buffer-file
+     buffer
+     (or (buffer-pathname buffer)
+	 (prompt-for-file :prompt "Save File: "
+			  :help "Name of file to write to"
+			  :default (buffer-default-pathname buffer)
+			  :must-exist nil)))))
+
+(defhvar "Save All Files Confirm"
+  "When non-nil, prompts for confirmation before writing each modified buffer."
+  :value t)
+
+(defcommand "Save All Files" (p)
+  "Saves all modified buffers in their associated files.
+  If a buffer has no associated file it is ignored even if it is modified.."
+  "Saves each modified buffer that has a file."
+  (declare (ignore p))
+  (let ((saved-count 0))
+    (dolist (b *buffer-list*)
+      (let ((pn (buffer-pathname b))
+	    (name (buffer-name b)))
+	(when
+	    (and (buffer-modified b)
+		 pn
+		 (or (not (value save-all-files-confirm))
+		     (prompt-for-y-or-n
+		      :prompt (list
+			       "Write ~:[buffer ~A as file ~S~;file ~*~S~], ~
+			       Y or N: "
+			       (string= (pathname-to-buffer-name pn) name)
+			       name (namestring pn))
+		      :default t)))
+	  (write-buffer-file b pn)
+	  (incf saved-count))))
+    (if (zerop saved-count)
+	(message "No files were saved.")
+	(message "Saved ~S file~:P." saved-count))))
+
+(defcommand "Save All Files and Exit" (p)
+  "Save all modified buffers in their associated files and exit;
+  a combination of \"Save All Files\" and \"Exit Hemlock\"."
+  "Do a save-all-files-command and then an exit-hemlock."
+  (declare (ignore p))
+  (save-all-files-command ())
+  (exit-hemlock))
+
+(defcommand "Backup File" (p)
+  "Write the buffer to a file without changing the associated name."
+  "Write the buffer to a file without changing the associated name."
+  (declare (ignore p))
+  (let ((file (prompt-for-file :prompt "Backup to File: "
+			       :help
+ "Name of a file to backup the current buffer in."
+			       :default (buffer-default-pathname (current-buffer))
+			       :must-exist nil)))
+    (write-file (buffer-region (current-buffer)) file)
+    (message "~A written." (namestring (truename file)))))
+
+
+
+;;;; Buffer hacking commands:
+
+(defvar *buffer-history* ()
+  "A list of buffers, in order from most recently to least recently selected.")
+
+(defun previous-buffer ()
+  "Returns some previously selected buffer that is not the current buffer.
+   Returns nil if no such buffer exists."
+  (let ((b (car *buffer-history*)))
+    (or (if (eq b (current-buffer)) (cadr *buffer-history*) b)
+	(find-if-not #'(lambda (x)
+			 (or (eq x (current-buffer))
+			     (eq x *echo-area-buffer*)))
+		     (the list *buffer-list*)))))
+
+;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by
+;;; "Circulate Buffers" even if it has never been before.
+;;;
+(defun add-buffer-history-hook (buffer)
+  (let ((ele (last *buffer-history*))
+	(new-stuff (list buffer)))
+    (if ele
+	(setf (cdr ele) new-stuff)
+	(setf *buffer-history* new-stuff))))
+;;;
+(add-hook make-buffer-hook 'add-buffer-history-hook)
+
+;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer.
+;;;
+(defun delete-buffer-history-hook (buffer)
+  (setq *buffer-history* (delq buffer *buffer-history*)))
+;;;
+(add-hook delete-buffer-hook 'delete-buffer-history-hook)
+  
+(defun change-to-buffer (buffer)
+  "Switches to buffer in the current window maintaining *buffer-history*."
+  (setq *buffer-history*
+	(cons (current-buffer) (delq (current-buffer) *buffer-history*)))
+  (setf (current-buffer) buffer)
+  (setf (window-buffer (current-window)) buffer))
+
+(defun delete-buffer-if-possible (buffer)
+  "Deletes a buffer if at all possible.  If buffer is the only buffer, other
+   than the echo area, signals an error.  Otherwise, find some recently current
+   buffer, and make all of buffer's windows display this recent buffer.  If
+   buffer is current, set the current buffer to be this recently current
+   buffer."
+  (let ((new-buf (flet ((frob (b)
+			  (or (eq b buffer) (eq b *echo-area-buffer*))))
+		   (or (find-if-not #'frob (the list *buffer-history*))
+		       (find-if-not #'frob (the list *buffer-list*))))))
+    (unless new-buf
+      (error "Cannot delete only buffer ~S." buffer))
+    (dolist (w (buffer-windows buffer))
+      (setf (window-buffer w) new-buf))
+    (when (eq buffer (current-buffer))
+      (setf (current-buffer) new-buf)))
+  (delete-buffer buffer))
+
+
+(defvar *create-buffer-count* 0)
+
+(defcommand "Create Buffer" (p &optional buffer-name)
+  "Create a new buffer.  If a buffer with the specified name already exists,
+   then go to it."
+  "Create or go to the buffer with the specifed name."
+  (declare (ignore p))
+  (let ((name (or buffer-name
+		  (prompt-for-buffer :prompt "Create Buffer: "
+				     :default-string
+				     (format nil "Buffer ~D"
+					     (incf *create-buffer-count*))
+				     :must-exist nil))))
+    (if (bufferp name)
+	(change-to-buffer name)
+	(change-to-buffer (or (getstring name *buffer-names*)
+			      (make-buffer name))))))
+
+(defcommand "Select Buffer" (p)
+  "Select a different buffer.
+   The buffer to go to is prompted for."
+  "Select a different buffer.
+   The buffer to go to is prompted for."
+  (declare (ignore p))
+  (let ((buf (prompt-for-buffer :prompt "Select Buffer: "
+				:default (previous-buffer))))
+    (when (eq buf *echo-area-buffer*)
+      (editor-error "Cannot select Echo Area buffer."))
+    (change-to-buffer buf)))
+
+
+(defvar *buffer-history-ptr* ()
+  "The successively previous buffer to the current buffer.")
+
+(defcommand "Select Previous Buffer" (p)
+  "Select the buffer selected before this one.  If called repeatedly
+   with an argument, select the successively previous buffer to the
+   current one leaving the buffer history as it is."
+  "Select the buffer selected before this one."
+  (if p
+      (circulate-buffers-command nil)
+      (let ((b (previous-buffer)))
+	(unless b (editor-error "No previous buffer."))
+	(change-to-buffer b)
+	;;
+	;; If the pointer goes to nil, then "Circulate Buffers" will keep doing
+	;; "Select Previous Buffer".
+	(setf *buffer-history-ptr* (cddr *buffer-history*))
+	(setf (last-command-type) :previous-buffer))))
+
+(defcommand "Circulate Buffers" (p)
+  "Advance through buffer history, selecting successively previous buffer."
+  "Advance through buffer history, selecting successively previous buffer."
+  (declare (ignore p))
+  (if (and (eq (last-command-type) :previous-buffer)
+	   *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER.
+      (let ((b (pop *buffer-history-ptr*)))
+	(when (eq b (current-buffer))
+	  (setf b (pop *buffer-history-ptr*)))
+	(unless b
+	  (setf *buffer-history-ptr*
+		(or (cdr *buffer-history*) *buffer-history*))
+	  (setf b (car *buffer-history*)))
+	(setf (current-buffer) b)
+	(setf (window-buffer (current-window)) b)
+	(setf (last-command-type) :previous-buffer))
+      (select-previous-buffer-command nil)))
+  
+
+(defcommand "Buffer Not Modified" (p)
+  "Make the current buffer not modified."
+  "Make the current buffer not modified."
+  (declare (ignore p))
+  (setf (buffer-modified (current-buffer)) nil)
+  (message "Buffer marked as unmodified."))
+
+(defcommand "Check Buffer Modified" (p)
+  "Say whether the buffer is modified or not."
+  "Say whether the current buffer is modified or not."
+  (declare (ignore p))
+  (clear-echo-area)
+  (message "Buffer ~S ~:[is not~;is~] modified."
+	   (buffer-name (current-buffer)) (buffer-modified (current-buffer))))
+
+(defcommand "Set Buffer Read-Only" (p)
+  "Toggles the read-only flag for the current buffer."
+  "Toggles the read-only flag for the current buffer."
+  (declare (ignore p))
+  (let ((buffer (current-buffer)))
+    (message "Buffer ~S is now ~:[read-only~;writable~]."
+	     (buffer-name buffer)
+	     (setf (buffer-writable buffer) (not (buffer-writable buffer))))))
+
+(defcommand "Kill Buffer" (p &optional buffer-name)
+  "Prompts for a buffer to delete.
+  If the buffer is modified, then let the user save the file before doing so.
+  When deleting the current buffer, prompts for a new buffer to select.  If
+  a buffer other than the current one is deleted then any windows into it
+  are deleted."
+  "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed
+  or current."
+  (declare (ignore p))
+  (let ((buffer (if buffer-name
+		    (getstring buffer-name *buffer-names*)
+		    (prompt-for-buffer :prompt "Kill Buffer: "
+				       :default (current-buffer)))))
+    (if (not buffer)
+	(editor-error "No buffer named ~S" buffer-name))
+    (if (and (buffer-modified buffer)
+	     (prompt-for-y-or-n :prompt "Save it first? "))
+	(save-file-command () buffer))
+    (if (eq buffer (current-buffer))
+	(let ((new (prompt-for-buffer :prompt "New Buffer: "
+				      :default (previous-buffer)
+ :help "Buffer to change to after the current one is killed.")))
+	  (when (eq new buffer)
+	    (editor-error "You must select a different buffer."))
+	  (dolist (w (buffer-windows buffer))
+	    (setf (window-buffer w) new))
+	  (setf (current-buffer) new))
+	(dolist (w (buffer-windows buffer))
+	  (delete-window w)))
+    (delete-buffer buffer)))
+
+(defcommand "Rename Buffer" (p)
+  "Change the current buffer's name.
+  The name, which is prompted for, defaults to the name of the associated
+  file."
+  "Change the name of the current buffer."
+  (declare (ignore p))
+  (let* ((buf (current-buffer))
+	 (pn (buffer-pathname buf))
+	 (name (if pn (pathname-to-buffer-name pn) (buffer-name buf)))
+	 (new (prompt-for-string :prompt "New Name: "
+				 :help "Give a new name for the current buffer"
+				 :default name)))
+    (multiple-value-bind (entry foundp) (getstring new *buffer-names*)
+      (cond ((or (not foundp) (eq entry buf))
+	     (setf (buffer-name buf) new))
+	    (t (editor-error "Name ~S already in use." new))))))
+
+
+(defcommand "Insert Buffer" (p)
+  "Insert the contents of a buffer.
+  The name of the buffer to insert is prompted for."
+  "Prompt for a buffer to insert at the point."
+  (declare (ignore p))
+  (let ((point (current-point))
+	(region (buffer-region (prompt-for-buffer
+				:default (previous-buffer) 
+				:help 
+				"Type the name of a buffer to insert."))))
+    ;;
+    ;; start and end will be deleted by undo stuff
+    (let ((save (region (copy-mark point :right-inserting)
+			(copy-mark point :left-inserting))))
+      (push-buffer-mark (copy-mark point))
+      (insert-region point region)
+      (make-region-undo :delete "Insert Buffer" save))))
+
+
+
+;;;; File utility commands:
+
+(defcommand "Directory" (p)
+  "Do a directory into a pop-up window.  If an argument is supplied, then
+   dot files are listed too (as with ls -a).  Prompts for a pathname which
+   may contain wildcards in the name and type."
+  "Do a directory into a pop-up window."
+  (let* ((dpn (value pathname-defaults))
+	 (pn (prompt-for-file
+	      :prompt "Directory: "
+	      :help "Pathname to do directory on."
+	      :default (make-pathname :device (pathname-device dpn)
+				      :directory (pathname-directory dpn))
+	      :must-exist nil)))
+    (setf (value pathname-defaults) (merge-pathnames pn dpn))
+    (with-pop-up-display (s)
+      (print-directory pn s :all p))))
+
+(defcommand "Verbose Directory" (p)
+  "Do a directory into a pop-up window.  If an argument is supplied, then
+   dot files are listed too (as with ls -a).  Prompts for a pathname which
+   may contain wildcards in the name and type."
+  "Do a directory into a pop-up window."
+  (let* ((dpn (value pathname-defaults))
+	 (pn (prompt-for-file
+	      :prompt "Verbose Directory: "
+	      :help "Pathname to do directory on."
+	      :default (make-pathname :device (pathname-device dpn)
+				      :directory (pathname-directory dpn))
+	      :must-exist nil)))
+    (setf (value pathname-defaults) (merge-pathnames pn dpn))
+    (with-pop-up-display (s)
+      (print-directory pn s :verbose t :all p))))
+
+
+
+;;;; Change log stuff:
+
+(define-file-option "Log" (buffer value)
+  (defhvar "Log File Name"
+    "The name of the file for the change log for the file in this buffer."
+    :buffer buffer  :value value))
+
+(defhvar "Log Entry Template"
+  "The format string used to generate the template for a change-log entry.
+  Three arguments are given: the file, the date (create if available, now
+  otherwise) and the file author, or NIL if not available.  The last \"@\"
+  is deleted and the point placed where it was."
+  :value "~A, ~A, Edit by ~:[???~;~:*~:(~A~)~].~%  @~2%")
+
+(defmode "Log"
+  :major-p t
+  :setup-function
+  #'(lambda (buffer)
+      (setf (buffer-minor-mode buffer "Fill") t))
+  :cleanup-function
+  #'(lambda (buffer)
+      (setf (buffer-minor-mode buffer "Fill") nil)))
+
+(defhvar "Fill Prefix" "The fill prefix in Log mode."
+  :value "  "  :mode "Log")
+
+(define-file-type-hook ("log") (buffer type)
+  (declare (ignore type))
+  (setf (buffer-major-mode buffer) "Log"))
+
+(defun universal-time-to-string (ut)
+  (multiple-value-bind (sec min hour day month year)
+		       (decode-universal-time ut)
+    (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
+	    day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
+			  "Sep" "Oct" "Nov" "Dec")
+		       (1- month))
+	    (rem year 100)
+	    hour min sec)))
+
+(defvar *back-to-@-pattern* (new-search-pattern :character :backward #\@))
+(defcommand "Log Change" (p)
+  "Make an entry in the change-log file for this buffer.
+  Saves the file in the current buffer if it is modified, then finds the file
+  specified in the \"Log\" file option, adds the template for a change-log
+  entry at the beginning, then does a recursive edit, saving the log file on
+  exit."
+  "Find the change-log file as specified by \"Log File Name\" and edit it."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'log-file-name)
+    (editor-error "No log file defined."))
+  (let* ((buffer (current-buffer))
+	 (pathname (buffer-pathname buffer)))
+    (when (or (buffer-modified buffer) (null pathname))
+      (save-file-command ()))
+    (unwind-protect
+	(progn
+	  (find-file-command nil (merge-pathnames
+				  (value log-file-name)
+				  (buffer-default-pathname buffer)))
+	  (let ((point (current-point)))
+	    (buffer-start point)
+	    (with-output-to-mark (s point :full)
+	      (format s (value log-entry-template)
+		      (namestring pathname)
+		      (universal-time-to-string
+		       (or (file-write-date pathname)
+			   (get-universal-time)))
+		      (file-author pathname)))
+	    (when (find-pattern point *back-to-@-pattern*)
+	      (delete-characters point 1)))
+	  (do-recursive-edit)
+	  (when (buffer-modified (current-buffer)) (save-file-command ())))
+      (if (member buffer *buffer-list* :test #'eq)
+	  (change-to-buffer buffer)
+	  (editor-error "Old buffer has been deleted.")))))
+
+
+
+;;;; Window hacking commands:
+
+(defcommand "Next Window" (p)
+  "Change the current window to be the next window and the current buffer
+  to be it's buffer."
+  "Go to the next window.
+  If the next window is the bottom window then wrap around to the top window."
+  (declare (ignore p))
+  (let* ((next (next-window (current-window)))
+	 (buffer (window-buffer next)))
+    (setf (current-buffer) buffer  (current-window) next)))
+
+(defcommand "Previous Window" (p)
+  "Change the current window to be the previous window and the current buffer
+  to be it's buffer."
+  "Go to the previous window.
+  If the Previous window is the top window then wrap around to the bottom."
+  (declare (ignore p))
+  (let* ((previous (previous-window (current-window)))
+	 (buffer (window-buffer previous)))
+    (setf (current-buffer) buffer  (current-window) previous)))
+
+(defcommand "Split Window" (p)
+  "Make a new window by splitting the current window.
+   The new window is made the current window and displays starting at
+   the same place as the current window."
+  "Create a new window which displays starting at the same place
+   as the current window."
+  (declare (ignore p))
+  (let ((new (make-window (window-display-start (current-window)))))
+    (unless new (editor-error "Could not make a new window."))
+    (setf (current-window) new)))
+
+(defcommand "New Window" (p)
+  "Make a new window and go to it.
+   The window will display the same buffer as the current one."
+  "Create a new window which displays starting at the same place
+   as the current window."
+  (declare (ignore p))
+  (let ((new (make-window (window-display-start (current-window))
+			  :ask-user t)))
+    (unless new (editor-error "Could not make a new window."))
+    (setf (current-window) new)))
+
+(defcommand "Delete Window" (p)
+  "Delete the current window, going to the previous window."
+  "Delete the window we are in, going to the previous window."
+  (declare (ignore p))
+  (let ((window (current-window)))
+    (previous-window-command ())
+    (when (eq (current-window) window)
+      (editor-error "Cannot delete current window."))
+    (delete-window window)))
+
+(defcommand "Line to Top of Window" (p)
+  "Move current line to top of window."
+  "Move current line to top of window."
+  (declare (ignore p))
+  (with-mark ((mark (current-point)))
+    (move-mark (window-display-start (current-window)) (line-start mark))))
+
+(defcommand "Delete Next Window" (p)
+  "Deletes the next window on display."
+  "Deletes then next window on display."
+  (declare (ignore p))
+  (if (eq (next-window (current-window))
+	  (current-window))
+      (editor-error "Cannot delete only window")
+      (delete-window (next-window (current-window)))))
+
+(defcommand "Line to Center of Window" (p)
+  "Moves current line to the center of the window."
+  "Moves current line to the center of the window."
+  (declare (ignore p))
+  (center-window (current-window) (current-point)))
diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3733b034d956b9478df716d5f5d44d4fe46cf2a1
--- /dev/null
+++ b/hemlock/fill.lisp
@@ -0,0 +1,738 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;
+;;; This file contains the implementation of Auto Fill Mode.  Also,
+;;;   paragraph and region filling stuff is here.
+;;;
+
+(in-package "HEMLOCK")
+
+
+;;; Fill Mode should be defined with some transparent bindings (linefeed and
+;;; return) but with some that are not (space), so until this is possible, we
+;;; kludge this effect by altering Auto Fill Linefeed and Auto Fill Return.
+(defmode "Fill")
+
+
+
+;;;; -- Variables --
+
+(defhvar "Fill Column"
+  "Used to determine at what column to force text to the next line."
+  :value 75)
+
+(defhvar "Fill Prefix"
+  "String to put before each line when filling."
+  :value ())
+
+(defhvar "Auto Fill Space Indent"
+  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
+   \"New Line\".  However, if there is a fill prefix, it is still preferred."
+  :value nil)
+
+
+
+;;;; -- New Attributes --
+
+(defattribute "Paragraph Delimiter"
+  "is a character that delimits a paragraph by beginning a line."
+  '(mod 2)
+  0)
+
+
+;;; (setf (character-attribute :paragraph-delimiter #\@) 1)
+;;; (setf (character-attribute :paragraph-delimiter #\\) 1)
+;;; (setf (character-attribute :paragraph-delimiter #\/) 1)
+;;; (setf (character-attribute :paragraph-delimiter #\-) 1)
+;;; (setf (character-attribute :paragraph-delimiter #\') 1)
+;;; (setf (character-attribute :paragraph-delimiter #\.) 1)
+;;;    These are useful for making certain text formatting command lines
+;;; delimit paragraphs.  Anyway, this is what EMACS documentation states,
+;;; and #\' and #\. are always paragraph delimiters (don't ask me).
+
+(setf (character-attribute :paragraph-delimiter #\space) 1)
+(setf (character-attribute :paragraph-delimiter #\linefeed) 1)
+(setf (character-attribute :paragraph-delimiter #\formfeed) 1)
+(setf (character-attribute :paragraph-delimiter #\tab) 1)
+(setf (character-attribute :paragraph-delimiter #\newline) 1)
+
+
+
+(defattribute "Sentence Closing Char"
+  "is a delimiting character that may follow a sentence terminator
+   such as quotation marks and parentheses."
+  '(mod 2)
+  0)
+
+
+(setf (character-attribute :sentence-closing-char #\") 1)
+(setf (character-attribute :sentence-closing-char #\') 1)
+(setf (character-attribute :sentence-closing-char #\)) 1)
+(setf (character-attribute :sentence-closing-char #\]) 1)
+(setf (character-attribute :sentence-closing-char #\|) 1)
+(setf (character-attribute :sentence-closing-char #\>) 1)
+
+
+
+;;;; -- Commands --
+
+(defcommand "Auto Fill Mode" (p)
+  "Breaks lines between words at the right margin.
+   A positive argument turns Fill mode on, while zero or a negative
+   argument turns it off.  With no arguments, it is toggled.  When space
+   is typed, text that extends past the right margin is put on the next
+   line.  The right column is controlled by Fill Column."
+  "Determine if in Fill mode or not and set the mode accordingly."
+  (setf (buffer-minor-mode (current-buffer) "Fill")
+	(if p
+	    (plusp p)
+	    (not (buffer-minor-mode (current-buffer) "Fill")))))
+
+
+;;; This command should not have a transparent binding since it sometimes does
+;;; not insert a spaces, and transparency would propagate to "Self Insert".
+(defcommand "Auto Fill Space" (p)
+  "Insert space and a CRLF if text extends past margin.
+   If arg is 0, then may break line but will not insert the space.
+   If arg is positive, then inserts that many spaces without filling."
+  "Insert space and CRLF if text extends past margin.
+   If arg is 0, then may break line but will not insert the space.
+   If arg is positive, then inserts that many spaces without filling."
+  (let ((point (current-point)))
+    (check-fill-prefix (value fill-prefix) (value fill-column) point)
+    (cond ((and p (plusp p))
+	   (dotimes (x p) (insert-character point #\space)))
+	  ((and p (zerop p)) (%auto-fill-space point nil))
+	  (t (%auto-fill-space point t)))))
+
+
+(defcommand "Auto Fill Linefeed" (p)
+  "Does an immediate CRLF inserting Fill Prefix if it exists."
+  "Does an immediate CRLF inserting Fill Prefix if it exists."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (check-fill-prefix (value fill-prefix) (value fill-column) point)
+    (%auto-fill-space point nil)
+    ;; The remainder of this function should go away when
+    ;; transparent key bindings are per binding instead of
+    ;; per mode.
+    (multiple-value-bind (command t-bindings)
+			 (get-command #\linefeed :current)
+      (declare (ignore command)) ;command is this one, so don't invoke it
+      (dolist (c t-bindings) (funcall *invoke-hook* c p)))
+    (indent-new-line-command nil)))
+
+
+
+(defcommand "Auto Fill Return" (p)
+  "Does an Auto Fill Space with a prefix argument of 0
+   followed by a newline."
+  "Does an Auto Fill Space with a prefix argument of 0
+   followed by a newline."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (check-fill-prefix (value fill-prefix) (value fill-column) point)
+    (%auto-fill-space point nil)
+    ;; The remainder of this function should go away when
+    ;; transparent key bindings are per binding instead of
+    ;; per mode.
+    (multiple-value-bind (command t-bindings)
+			 (get-command #\return :current)
+      (declare (ignore command)) ;command is this one, so don't invoke it
+      (dolist (c t-bindings) (funcall *invoke-hook* c p)))
+    (new-line-command nil)))
+
+
+
+(defcommand "Fill Paragraph" (p)
+  "Fill this or next paragraph.
+   Point stays fixed, but text may move past it due to filling.
+   A paragraph is delimited by a blank line, a line beginning with a
+   special character (@,\,-,',and .), or it is begun with a line with at
+   least one whitespace character starting it.  Prefixes are ignored or
+   skipped over before determining if a line starts or delimits a
+   paragraph."
+  "Fill this or next paragraph.
+   Point stays fixed, but text may move past it due to filling."
+  (let* ((prefix (value fill-prefix))
+	 (prefix-len (length prefix))
+	 (column (if p (abs p) (value fill-column)))
+	 (point (current-point)))
+    (with-mark ((m point))
+      (let ((paragraphp (paragraph-offset m 1)))
+	(unless (or paragraphp
+		    (and (last-line-p m)
+			 (end-line-p m)
+			 (not (blank-line-p (mark-line m)))))
+	  (editor-error))
+	;;
+	;; start and end get deleted by the undo cleanup function
+	(let ((start (copy-mark m :right-inserting))
+	      (end (copy-mark m :left-inserting)))
+	  (%fill-paragraph-start start prefix prefix-len)
+	  (let* ((region (region start end))
+		 (undo-region (copy-region region)))
+	    (fill-region region prefix column)
+	    (make-region-undo :twiddle "Fill Paragraph" region undo-region)))))))
+
+
+(defcommand "Fill Region" (p)
+  "Fill text from point to mark."
+  "Fill text from point to mark."
+  (declare (ignore p))
+  (let* ((region (current-region))
+	 (prefix (value fill-prefix))
+	 (column (if p (abs p) (value fill-column))))
+    (check-fill-prefix prefix column (current-point))
+    (check-region-query-size region)
+    (fill-region-by-paragraphs region prefix column)))
+
+
+
+(defcommand "Set Fill Column" (p)
+  "Set Fill Column to current column or argument.
+   If argument is provided use its absolute value."
+  "Set Fill Column to current column or argument.
+   If argument is provided use its absolute value."
+  (let ((new-column (or (and p (abs p))
+			(mark-column (current-point)))))
+    (defhvar "Fill Column" "This buffer's fill column"
+      :value new-column  :buffer (current-buffer))
+    (message "Fill Column = ~D" new-column)))
+
+
+(defcommand "Set Fill Prefix" (p) 
+  "Define Fill Prefix from the current line.
+   All of the current line up to point is the prefix.  This may be
+   turned off by placing point at the beginning of a line when setting."
+  "Define Fill Prefix from the current line.
+   All of the current line up to point is the prefix.  This may be
+   turned off by placing point at the beginning of a line when setting."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (with-mark ((mark point))
+      (line-start mark)
+      (let ((val (if (mark/= mark point) (region-to-string (region mark point)))))
+	(defhvar "Fill Prefix" "This buffer's fill prefix"
+	  :value val  :buffer (current-buffer))
+	(message "Fill Prefix now ~:[empty~;~:*~S~]" val)))))
+
+
+;;;; -- Auto Filling --
+
+;;;      %AUTO-FILL-SPACE takes a point and an argument indicating
+;;; whether it should insert a space or not.  If point is past Fill
+;;; Column then text is filled. Usually  the else clause of the if
+;;; will be executed.  If the then clause is executed, then the first
+;;; branch of the COND will usually be executed.  The first branch
+;;; handles the case of the end of a word extending past Fill Column
+;;; while the second handles whitespace preceded by non-whitespace
+;;; extending past the Fill Column.  The last branch is for those who
+;;; like to whitespace out a blank line.
+
+(defun %auto-fill-space (point insertp)
+  "Insert space, but CRLF if text extends past margin.
+   If arg is 0, then may break line but will not insert the space.
+   If arg is positive, then inserts that many spaces without filling."
+  (if (> (mark-column point) (value fill-column))
+      (with-mark ((mark1 point :left-inserting))
+	(let ((not-all-blank (reverse-find-attribute mark1 :whitespace #'zerop))
+	      (prefix (value fill-prefix))
+	      (column (value fill-column)))
+	  (cond ((and not-all-blank (mark= point mark1))
+		 (%auto-fill-word-past-column point mark1 insertp prefix column))
+		((and not-all-blank (same-line-p mark1 point))
+		 (delete-region (region mark1 point))
+		 (if (> (mark-column point) column)
+		     (%auto-fill-word-past-column point mark1 insertp prefix column)
+		     (%filling-set-next-line point nil prefix)))
+		(t
+		 (line-start mark1 (mark-line point))
+		 (delete-region (region mark1 point))
+		 (%filling-set-next-line point nil prefix)))))
+      (if insertp (insert-character point #\space))))
+
+
+
+;;;      %AUTO-FILL-WORD-PAST-COLUMN takes a point, a second mark that is
+;;; mark= at the end of some word, and an indicator of whether a space
+;;; should be inserted or not.  First, point is moved before the previous
+;;; "word."  If the word is effectively the only word on the line, it
+;;; should not be moved down to the next line as it will leave a blank
+;;; line.  The third branch handles when the typing began in the middle of
+;;; some line (that is, right in front of some word).  Note that the else
+;;; clause is the usual case.
+
+(defun %auto-fill-word-past-column (point mark1 insertp prefix column)
+  (let ((point-moved-p (reverse-find-attribute point :whitespace)))
+    (with-mark ((mark2 point :left-inserting))
+      (cond ((or (not point-moved-p)
+		 (%auto-fill-blank-before-p point prefix))
+	     (move-mark point mark1)
+	     (%filling-set-next-line point nil prefix))
+	    ((%auto-fill-line-as-region-p point mark2 column)
+	     (if (and insertp
+		      (not (or (end-line-p mark1)
+			       (whitespace-attribute-p (next-character mark1)))))
+		 (insert-character mark1 #\space))
+	     (auto-fill-line-as-region point (move-mark mark2 point) prefix column)
+	     (move-mark point mark1)
+	     (if (and insertp (end-line-p point))
+		 (insert-character point #\space)))
+	    ((not (or (end-line-p mark1)
+		      (whitespace-attribute-p (next-character mark1))))
+	     (insert-character mark1 #\space)
+	     (%filling-set-next-line point nil prefix)
+	     (mark-after point)
+	     (%auto-fill-clean-previous-line mark1 mark2))
+	    (t
+	     (%filling-set-next-line point insertp prefix)
+	     (%auto-fill-clean-previous-line mark1 mark2))))))
+
+
+
+;;; AUTO-FILL-LINE-AS-REGION basically grabs a line as a region and fills
+;;; it.  However, it knows about comments and makes auto filling a comment
+;;; line as a region look the same as a typical "back up a word and break
+;;; the line."  When there is a comment, then region starts where the
+;;; comment starts instead of the beginning of the line, but the presence
+;;; of a prefix overrides all this.
+
+(defun auto-fill-line-as-region (point mark prefix column)
+  (let* ((start (value comment-start))
+	 (begin (value comment-begin))
+	 (end (value comment-end)))
+    (line-start mark)
+    (cond ((and (not prefix) start (to-line-comment mark start))
+	   (fill-region (region mark (line-end point))
+			(gen-comment-prefix mark start begin)
+			column)
+	   (when end
+	     (line-start point)
+	     (do ()
+		 ((mark>= mark point))
+	       (if (not (to-comment-end mark end)) (insert-string mark end))
+	       (line-offset mark 1 0))))	   
+	  (t (fill-region (region mark (line-end point)) prefix column)))))
+
+
+
+(defun %auto-fill-blank-before-p (point prefix)
+  "is true if whitespace only precedes point except for the prefix."
+  (or (blank-before-p point)
+      (with-mark ((temp point))
+	(reverse-find-attribute temp :whitespace #'zerop)
+	(<= (mark-column temp) (length prefix)))))
+
+
+
+;;;      %AUTO-FILL-LINE-AS-REGION-P determines if the line point and mark2
+;;; sit on is so long that it might as well be filled as if it were a
+;;; region.  Mark2 is mark= to point at the beginning of the last word on
+;;; the line and is then moved over the whitespace before point.  If the
+;;; word end prior the last word on the line is on the same line and not
+;;; before column, then fill the line as a region.
+
+(defun %auto-fill-line-as-region-p (point mark2 column)
+  (reverse-find-attribute mark2 :whitespace #'zerop)
+  (and (same-line-p mark2 point)
+       (> (mark-column mark2) column)))
+
+
+
+(defun %auto-fill-clean-previous-line (mark1 mark2)
+  (when (line-offset mark1 -1)
+    (line-end mark1)
+    (move-mark mark2 mark1)
+    (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
+		 (same-line-p mark1 mark2))
+      (line-start mark1 (mark-line mark2)))
+    (delete-region (region mark1 mark2))))
+
+
+
+;;; %FILLING-SET-NEXT-LINE gets a new blank line and sets it up with the
+;;; prefix and places the point correctly.  The argument point must alias
+;;; (current-point).
+
+(defun %filling-set-next-line (point insertp prefix)
+  (cond ((and (value auto-fill-space-indent) (not prefix))
+	 (indent-new-comment-line-command nil))
+	(t (new-line-command nil)
+	   (if prefix (insert-string point prefix))))
+  (if (not (find-attribute point :whitespace)) (line-end point))
+  (if insertp (insert-character point #\space)))
+
+
+
+;;;; -- Paragraph Filling --
+
+
+;;;      %FILL-PARAGRAPH-START takes a mark that has just been moved
+;;; forward over some paragraph.  After moving to the beginning of it, we
+;;; place the mark appropriately for filling the paragraph as a region.
+
+(defun %fill-paragraph-start (mark prefix prefix-len)
+  (paragraph-offset mark -1)
+  (skip-prefix-if-here mark prefix prefix-len)
+  (if (text-blank-line-p mark)
+      (line-offset mark 1 0)
+      (line-start mark)))
+
+
+
+;;;; -- Region Filling --
+
+
+;;;      FILL-REGION-BY-PARAGRAPHS finds paragraphs and uses region filling
+;;; primitives to fill them.  Tmark2 is only used for the first paragraph; we
+;;; need a mark other than start in case start is in the middle of a paragraph
+;;; instead of between two.
+;;;
+(defun fill-region-by-paragraphs (region &optional
+					 (prefix (value fill-prefix))
+					 (column (value fill-column)))
+  "Finds paragraphs in region and fills them as distinct regions using
+   FILL-REGION."
+  (with-mark ((start (region-start region) :left-inserting))
+    (with-mark ((tmark1 start :left-inserting)
+		(tmark2 start :left-inserting)) ;only used for first para.
+      (let ((region (region (copy-mark (region-start region)) ;deleted by undo.
+			    (copy-mark (region-end region))))
+	    (undo-region (copy-region region))
+	    (end (region-end region))
+	    (prefix-len (length prefix))
+	    (paragraphp (paragraph-offset tmark1 1)))
+	(when paragraphp
+	  (%fill-paragraph-start (move-mark tmark2 tmark1) prefix prefix-len)
+	  (if (mark>= tmark2 start) (move-mark start tmark2))
+	  (cond ((mark>= tmark1 end)
+		 (fill-region-aux start end prefix prefix-len column))
+		(t
+		 (fill-region-aux start tmark1 prefix prefix-len column)
+		 (do ((paragraphp (mark-paragraph start tmark1)
+				  (mark-paragraph start tmark1)))
+		     ((not paragraphp))
+		   (if (mark> start end)
+		       (return)
+		       (cond ((mark>= tmark1 end)
+			      (fill-region-aux start end prefix
+					       prefix-len column)
+			      (return))
+			     (t (fill-region-aux start tmark1
+						 prefix prefix-len column))))))))
+	(make-region-undo :twiddle "Fill Region" region undo-region)))))
+
+(defun fill-region (region &optional
+			   (prefix (value fill-prefix))
+			   (column (value fill-column)))
+  "Fills a region using the given prefix and column."
+  (let ((prefix (if (and prefix (string= prefix "")) () prefix)))
+    (with-mark ((start (region-start region) :left-inserting))
+      (check-fill-prefix prefix column start)
+      (fill-region-aux start (region-end region)
+		       prefix (length prefix) column))))
+
+
+
+;;;      FILL-REGION-AUX grinds over a region between fill-mark and
+;;; end-mark deleting blank lines and filling lines.  For each line, the
+;;; extra whitespace between words is collapsed to one space, and at the
+;;; end and beginning of the line it is deleted.  We do not return after
+;;; realizing that fill-mark is after end-mark if the line needs to be
+;;; broken; it may be the case that there are several filled line lengths
+;;; of material before end-mark on the current line.
+
+(defun fill-region-aux (fill-mark end-mark prefix prefix-len column)
+  (if (and (start-line-p fill-mark) prefix)
+      (fill-region-prefix-line fill-mark prefix prefix-len))
+  (with-mark ((mark1 fill-mark :left-inserting)
+	      (cmark fill-mark :left-inserting))
+    (do ((collapse-p t))
+	(nil)
+      (line-end fill-mark)
+      (line-start (move-mark mark1 fill-mark))
+      (skip-prefix-if-here mark1 prefix prefix-len)
+      (cond ((mark>= fill-mark end-mark)
+	     (if (mark= fill-mark end-mark)
+		 (fill-region-clear-eol fill-mark))
+	     (cond ((> (mark-column end-mark) column)
+		    (when collapse-p
+		      (fill-region-collapse-whitespace cmark end-mark)
+		      (setf collapse-p nil))
+		    (fill-region-break-line fill-mark prefix
+					    prefix-len end-mark column))
+		   (t (return))))
+	    ((blank-after-p mark1)
+	     (fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
+	     (cond ((mark< fill-mark end-mark)
+		    (if prefix
+			(fill-region-prefix-line fill-mark prefix prefix-len))
+		    (fill-region-clear-bol fill-mark)
+		    (move-mark cmark fill-mark))
+		   (t (return)))
+	     (setf collapse-p t))
+	    (t (fill-region-clear-eol fill-mark)
+	       (if collapse-p (fill-region-collapse-whitespace cmark fill-mark))
+	       (cond ((> (mark-column fill-mark) column)
+		      (fill-region-break-line fill-mark prefix
+					      prefix-len end-mark column)
+		      (setf collapse-p nil))
+		     (t (fill-region-get-next-line fill-mark column
+						   prefix prefix-len end-mark)
+			(move-mark cmark fill-mark)
+			(setf collapse-p t))))))
+    (move-mark fill-mark end-mark)))
+
+
+
+;;;      FILL-REGION-BREAK-LINE breaks lines as close to the low side
+;;; column as possible.  The first branch handles a word lying across
+;;; column while the second takes care of whitespace passing column.  If
+;;; FILL-REGION-WORD-PAST-COLUMN encountered a single word stretching over
+;;; column, it would leave an extra opened line that needs to be cleaned up
+;;; or filled up.
+
+(defun fill-region-break-line (fill-mark prefix prefix-length
+					  end-mark column)
+  (with-mark ((mark1 fill-mark :left-inserting))
+    (move-to-column mark1 column)
+    (cond ((not (whitespace-attribute-p (next-character mark1)))
+	   (if (not (find-attribute mark1 :whitespace))
+	       (line-end mark1))
+	   (move-mark fill-mark mark1)
+	   (if (eq (fill-region-word-past-column fill-mark mark1 prefix)
+		   :handled-oversized-word)
+	       (if (mark>= fill-mark end-mark)
+		   (delete-characters (line-start fill-mark)
+				      prefix-length)
+		   (delete-characters fill-mark 1))))
+	  (t (move-mark fill-mark mark1)
+	     (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
+			  (same-line-p mark1 fill-mark))
+	       (line-start mark1 (mark-line fill-mark)))
+	     ;; forward find must move mark because of cond branch we are in.
+	     (find-attribute fill-mark :whitespace #'zerop)
+	     (unless (same-line-p mark1 fill-mark)
+	       (line-end fill-mark (mark-line mark1)))
+	     (delete-region (region mark1 fill-mark))
+	     (insert-character fill-mark #\newline)
+	     (if prefix (insert-string fill-mark prefix))))))
+
+
+
+;;;      FILL-REGION-WORD-PAST-COLUMN takes a point and a second mark that
+;;; is mark= at the end of some word.  First, point is moved before the
+;;; previous "word."  If the word is effectively the only word on the line,
+;;; it should not be moved down to the next line as it will leave a blank
+;;; line.
+
+(defun fill-region-word-past-column (point mark1 prefix)
+  (with-mark ((mark2 (copy-mark point :left-inserting)))
+    (let ((point-moved-p (reverse-find-attribute point :whitespace))
+	  (hack-for-fill-region :handled-normal-case))
+      (cond ((or (not point-moved-p)
+		 (%auto-fill-blank-before-p point prefix))
+	     (setf hack-for-fill-region :handled-oversized-word)
+	     (move-mark point mark1)
+	     (fill-region-set-next-line point prefix))
+	    (t (fill-region-set-next-line point prefix)
+	       (%auto-fill-clean-previous-line mark1 mark2)))
+      hack-for-fill-region)))
+
+(defun fill-region-set-next-line (point prefix)
+  (insert-character point #\newline)
+  (if prefix (insert-string point prefix))
+  (if (not (find-attribute point :whitespace)) (line-end point)))
+
+
+
+;;;      FILL-REGION-GET-NEXT-LINE gets another line when the current one
+;;; is short of the fill column.  It cleans extraneous whitespace from the
+;;; beginning of the next line to fill.  To save typical redisplay the
+;;; length of the first word is added to the ending column of the current
+;;; line to see if it extends past the fill column; if it does, then the
+;;; fill-mark is left on the new line instead of merging the new line with
+;;; the current one.  The fill-mark is left after a prefix (if there is one)
+;;; on a new line, before the first word brought up to the current line, or
+;;; after the end mark.
+
+(defun fill-region-get-next-line (fill-mark column prefix prefix-len end-mark)
+  (let ((prev-end-pos (mark-column fill-mark))
+	(two-spaces-p (fill-region-insert-two-spaces-p fill-mark)))
+    (with-mark ((tmark fill-mark :left-inserting))
+      (fill-region-find-next-line fill-mark prefix prefix-len end-mark)
+      (move-mark tmark fill-mark)
+      (cond ((mark< fill-mark end-mark)
+	     (skip-prefix-if-here tmark prefix prefix-len)
+	     (fill-region-clear-bol tmark)
+	     (let ((beginning-pos (mark-column tmark)))
+	       (find-attribute tmark :whitespace)
+	       (cond ((> (+ prev-end-pos (if two-spaces-p 2 1)
+			    (- (mark-column tmark) beginning-pos))
+			 column)
+		      (if prefix
+			  (fill-region-prefix-line fill-mark prefix prefix-len)))
+		     (t
+		      (if (and prefix
+			       (%line-has-prefix-p fill-mark prefix prefix-len))
+			  (delete-characters fill-mark prefix-len))
+		      (delete-characters fill-mark -1)
+		      (insert-character fill-mark #\space)
+		      (if two-spaces-p (insert-character fill-mark #\space))))))
+	    (t
+	     (mark-after fill-mark))))))
+
+
+
+;;;      FILL-REGION-FIND-NEXT-LINE finds the next non-blank line, modulo
+;;; fill prefixes, and deletes the intervening lines.  Fill-mark is left at
+;;; the beginning of the next line.
+
+(defun fill-region-find-next-line (fill-mark prefix prefix-len end-mark)
+  (line-offset fill-mark 1 0)
+  (when (mark< fill-mark end-mark)
+    (skip-prefix-if-here fill-mark prefix prefix-len)
+    (if (blank-after-p fill-mark)
+	(fill-region-delete-blank-lines fill-mark end-mark prefix prefix-len)
+	(line-start fill-mark))))
+
+
+
+;;;      FILL-REGION-DELETE-BLANK-LINES deletes the blank line mark is on
+;;; and all successive blank lines.  Mark is left at the beginning of the
+;;; first non-blank line by virtue of its placement and region deletions.
+
+(defun fill-region-delete-blank-lines (mark end-mark prefix prefix-len)
+  (line-start mark)
+  (with-mark ((tmark mark :left-inserting))
+    (do ((linep (line-offset tmark 1 0) (line-offset tmark 1 0)))
+	((not linep)
+	 (move-mark tmark end-mark)
+	 (delete-region (region mark tmark)))
+      (skip-prefix-if-here tmark prefix prefix-len)
+      (when (mark>= tmark end-mark)
+	(move-mark tmark end-mark)
+	(delete-region (region mark tmark))
+	(return))
+      (unless (blank-after-p tmark)
+	(line-start tmark)
+	(delete-region (region mark tmark))
+	(return)))))
+
+
+
+;;;      FILL-REGION-CLEAR-BOL clears the initial whitespace on a line
+;;; known to be non-blank.  Note that the fill prefix is not considered, so
+;;; the mark must have been moved over it already if there is one.
+
+(defun fill-region-clear-bol (mark)
+  (with-mark ((tmark mark :left-inserting))
+    (find-attribute tmark :whitespace #'zerop)
+    (unless (mark= mark tmark)
+      (delete-region (region mark tmark)))))
+
+
+
+;;;      FILL-REGION-COLLAPSE-WHITESPACE deletes extra whitespace between
+;;; blocks of non-whitespace characters from mark1 to mark2.  Tabs are
+;;; converted into a single space.  Mark2 must be on the same line as mark1
+;;; since there is no concern of newlines, prefixes on a new line, blank
+;;; lines between blocks of non-whitespace characters, etc.
+
+(defun fill-region-collapse-whitespace (mark1 mark2)
+  (with-mark ((tmark mark1 :left-inserting))
+    ;; skip whitespace at beginning of line or single space between words
+    (find-attribute mark1 :whitespace #'zerop)
+    (unless (mark>= mark1 mark2)
+      (do ()
+	  (nil)
+	(if (not (find-attribute mark1 :whitespace)) ;not end of buffer
+	    (return))
+	(if (mark>= mark1 mark2) (return))
+	(if (char/= (next-character mark1) #\space)
+	    ;; since only on one line, must be tab or space
+	    (setf (next-character mark1) #\space))
+	(move-mark tmark mark1)
+	(if (mark= (mark-after mark1) mark2) (return))
+	(let ((char (next-character mark1)))
+	  (when (and (fill-region-insert-two-spaces-p tmark)
+		     (char= char #\space))
+	    ;; if at the end of a sentence, don't blow away the second space
+	    (if (mark= (mark-after mark1) mark2)
+		(return)
+		(setf char (next-character mark1))))
+	  (when (whitespace-attribute-p char) ;more whitespace than necessary
+	    (find-attribute (move-mark tmark mark1) :whitespace #'zerop)
+	    (if (mark>= tmark mark2) (move-mark tmark mark2))
+	    (delete-region (region mark1 tmark))))))))
+
+
+
+;;;      FILL-REGION-CLEAR-EOL must check the result of
+;;; REVERSE-FIND-ATTRIBUTE because if fill-mark did not move, then we are
+;;; only whitespace away from the beginning of the buffer.
+
+(defun fill-region-clear-eol (fill-mark)
+  (with-mark ((mark1 fill-mark :left-inserting))
+    (unless (and (reverse-find-attribute mark1 :whitespace #'zerop)
+		 (same-line-p mark1 fill-mark))
+      (line-start mark1 (mark-line fill-mark)))
+    (delete-region (region mark1 fill-mark))))
+
+
+
+(defun fill-region-prefix-line (fill-mark prefix prefix-length)
+  (if (%line-has-prefix-p fill-mark prefix prefix-length)
+      (character-offset fill-mark prefix-length)
+      (insert-string fill-mark prefix)))
+
+
+
+(defun %line-has-prefix-p (mark prefix prefix-length)
+  (declare (simple-string prefix))
+  (if (>= (line-length (mark-line mark)) prefix-length)
+      (string= prefix (the simple-string (line-string (mark-line mark)))
+	       :end2 prefix-length)))
+
+
+
+;;;      FILL-REGION-INSERT-TWO-SPACES-P returns true if a sentence
+;;; terminator is followed by any number of "closing characters" such as
+;;; ",',),etc.  If there is a sentence terminator at the end of the current
+;;; line, it must be assumed to be the end of a sentence as opposed to an
+;;; abbreviation.  Why?  Because EMACS does, and besides, what would Lisp
+;;; code be without heuristics.
+
+(defun fill-region-insert-two-spaces-p (mark)
+  (do ((n 0 (1+ n)))
+      ((not (sentence-closing-char-attribute-p (previous-character mark)))
+       (cond ((sentence-terminator-attribute-p (previous-character mark))
+	      (character-offset mark n))
+	     (t (character-offset mark n) nil)))
+    (mark-before mark)))
+
+
+
+(defun check-fill-prefix (prefix column mark)
+  (when prefix
+    (insert-character mark #\newline)
+    (insert-character mark #\newline)
+    (mark-before mark)
+    (insert-string mark prefix)
+    (let ((pos (mark-column mark)))
+      (declare (simple-string prefix))
+      (mark-after mark)
+      (delete-characters mark (- (+ (length prefix) 2)))
+      (if (>= pos column)
+	  (editor-error
+	   "The fill prefix length is longer than the fill column.")))))
diff --git a/hemlock/group.lisp b/hemlock/group.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e962d5259ec31eb03408c4a8b0f39fb0f447b118
--- /dev/null
+++ b/hemlock/group.lisp
@@ -0,0 +1,234 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.  If
+;;; you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; File group stuff for Hemlock.
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+;;;    The "Compile Group" and "List Compile Group" commands in lispeval
+;;;    also know about groups.
+;;;
+;;; This file provides Hemlock commands for manipulating groups of files
+;;; that make up a larger system.  A file group is a set of files whose
+;;; names are listed in some other file.  At any given time one group of
+;;; files is the Active group.  The Select Group command makes a group the
+;;; Active group, prompting for the name of a definition file if the group
+;;; has not been selected before.  Once a group has been selected once, the
+;;; name of the definition file associated with that group is retained.  If
+;;; one wishes to change the name of the definition file after a group has
+;;; been selected, one should call Select Group with a prefix argument.
+
+(in-package 'hemlock)
+
+(defvar *file-groups* (make-string-table)
+  "A string table of file groups.")
+
+(defvar *active-file-group* ()
+  "The list of files in the currently active group.")
+
+(defvar *active-file-group-name* ()
+  "The name of the currently active group.")
+
+
+
+;;;; Selecting the active group.
+
+(defcommand "Select Group" (p)
+  "Makes a group the active group.  With a prefix argument, changes the
+  definition file associated with the group."
+  "Makes a group the active group."
+  (let* ((group-name
+	  (prompt-for-keyword
+	   (list *file-groups*)
+	   :must-exist nil
+	   :prompt "Select Group: "
+	   :help
+	   "Type the name of the file group you wish to become the active group."))
+	 (old (getstring group-name *file-groups*))
+	 (pathname
+	  (if (and old (not p))
+	      old
+	      (prompt-for-file :must-exist t
+			       :prompt "From File: "
+			       :default (merge-pathnames
+					 (make-pathname
+					  :name group-name
+					  :type "upd")
+					 (value pathname-defaults))))))
+    (setq *active-file-group-name* group-name)
+    (setq *active-file-group* (nreverse (read-file-group pathname nil)))
+    (setf (getstring group-name *file-groups*) pathname)))
+
+
+;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
+;;; of the files named in that file.  This guy knows about @@ indirection and
+;;; ignores empty lines and lines that begin with @ but not @@.  A simpler
+;;; scheme could be used for non-Spice implementations, but all this hair is
+;;; probably useful, so Update format may as well be a standard for this sort
+;;; of thing.
+;;;
+(defun read-file-group (pathname tail)
+  (with-open-file (file pathname)
+    (do* ((name (read-line file nil nil) (read-line file nil nil))
+	  (length (if name (length name)) (if name (length name))))
+	 ((null name) tail)
+      (declare (simple-string name))
+      (cond ((zerop length))
+	    ((char= (char name 0) #\@)
+	     (when (and (> length 1) (char= (char name 1) #\@))
+	       (setq tail (read-file-group
+			   (merge-pathnames (subseq name 2)
+					    pathname)
+			   tail))))
+	    (t
+	     (push (merge-pathnames (pathname name) pathname) tail))))))
+
+
+
+;;;; DO-ACTIVE-GROUP.
+
+(defhvar "Group Find File"
+  "If true, group commands use \"Find File\" to read files, otherwise
+  non-resident files are read into the \"Group Search\" buffer."
+  :value nil)
+
+(defhvar "Group Save File Confirm"
+  "If true, then the group commands will ask for confirmation before saving
+  a modified file." :value t)
+
+(defmacro do-active-group (&rest forms)
+  "This iterates over the active file group executing forms once for each
+   file.  When forms are executed, the file will be in the current buffer,
+   and the point will be at the start of the file."
+  (let ((n-buf (gensym))
+	(n-start-buf (gensym))
+	(n-save (gensym)))
+    `(progn
+       (unless *active-file-group*
+	 (editor-error "There is no active file group."))
+
+       (let ((,n-start-buf (current-buffer))
+	     (,n-buf nil))
+	 (unwind-protect
+	     (dolist (file *active-file-group*)
+	       (catch 'file-not-found
+		 (setq ,n-buf (group-read-file file ,n-buf))
+		 (with-mark ((,n-save (current-point) :right-inserting))
+		   (unwind-protect
+		       (progn
+			 (buffer-start (current-point))
+			 ,@forms)
+		     (move-mark (current-point) ,n-save)))
+		 (group-save-file)))
+	   (if (member ,n-start-buf *buffer-list*)
+	       (setf (current-buffer) ,n-start-buf
+		     (window-buffer (current-window)) ,n-start-buf)
+	       (editor-error "Original buffer deleted!")))))))
+
+;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
+;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
+;;; already been read, to get files in, and then we delete the buffer if it is
+;;; newly created and "Group Find File" is false.  This lets FIND-FILE-BUFFER
+;;; do all the work.  We don't actually use the "Find File" command, so the
+;;; buffer history isn't affected.
+;;;
+;;; Search-Buffer is any temporary search buffer left over from the last file
+;;; that we want deleted.  We don't do the deletion if the buffer is modified.
+;;;
+(defun group-read-file (name search-buffer)
+  (unless (probe-file name)
+    (message "File ~A not found." name)
+    (throw 'file-not-found nil))
+  (multiple-value-bind (buffer created-p)
+		       (find-file-buffer name)
+    (setf (current-buffer) buffer)
+    (setf (window-buffer (current-window)) buffer)
+
+    (when (and search-buffer (not (buffer-modified search-buffer)))
+      (dolist (w (buffer-windows search-buffer))
+	(setf (window-buffer w) (current-buffer)))
+      (delete-buffer search-buffer))
+
+    (if (and created-p (not (value group-find-file)))
+	(current-buffer) nil)))
+
+;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
+;;;
+(defun group-save-file ()
+  (let* ((buffer (current-buffer))
+	 (pn (buffer-pathname buffer))
+	 (name (namestring pn)))
+    (when (and (buffer-modified buffer)
+	       (or (not (value group-save-file-confirm))
+		   (prompt-for-y-or-n
+		    :prompt (list "Save changes in ~A? " name)
+		    :default t)))
+      (save-file-command ()))))
+
+
+
+;;;; Searching and Replacing commands.
+
+(defcommand "Group Search" (p)
+  "Searches the active group for a specified string, which is prompted for."
+  "Searches the active group for a specified string."
+  (declare (ignore p))
+  (let ((string (prompt-for-string :prompt "Group Search: "
+				   :help "String to search for in active file group"
+				   :default *last-search-string*)))
+    (get-search-pattern string :forward)
+    (do-active-group
+     (do ((won (find-pattern (current-point) *last-search-pattern*)
+	       (find-pattern (current-point) *last-search-pattern*)))
+	 ((not won))
+       (character-offset (current-point) won)
+       (command-case
+	   (:prompt "Group Search: "
+		    :help "Type a character indicating the action to perform."
+		    :change-window nil)
+	 (:no "Search for the next occurrence.")
+	 (:do-all "Go on to the next file in the group."
+	  (return nil))
+	 ((:exit :yes) "Exit the search."
+	  (return-from group-search-command))
+	 (:recursive-edit "Enter a recursive edit."
+	  (do-recursive-edit)
+	  (get-search-pattern string :forward)))))
+    (message "All files in group ~S searched." *active-file-group-name*)))
+
+(defcommand "Group Replace" (p)
+  "Replaces one string with another in the active file group."
+  "Replaces one string with another in the active file group."
+  (declare (ignore p))
+  (let* ((target (prompt-for-string :prompt "Group Replace: "
+				    :help "Target string"
+				    :default *last-search-string*))
+	 (replacement (prompt-for-string :prompt "With: "
+					 :help "Replacement string")))
+    (do-active-group
+     (query-replace-function nil target replacement
+			     "Group Replace on previous file" t))
+    (message "Replacement done in all files in group ~S."
+	     *active-file-group-name*)))
+
+(defcommand "Group Query Replace" (p)
+  "Query Replace for the active file group."
+  "Query Replace for the active file group."
+  (declare (ignore p))
+  (let ((target (prompt-for-string :prompt "Group Query Replace: "
+				   :help "Target string"
+				   :default *last-search-string*)))
+    (let ((replacement (prompt-for-string :prompt "With: "
+					  :help "Replacement string")))
+      (do-active-group
+       (unless (query-replace-function
+		nil target replacement "Group Query Replace on previous file")
+	 (return nil)))
+      (message "Replacement done in all files in group ~S."
+	       *active-file-group-name*))))
diff --git a/hemlock/htext2.lisp b/hemlock/htext2.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..edfd0a8380dda27685e57998d50a12118d85462e
--- /dev/null
+++ b/hemlock/htext2.lisp
@@ -0,0 +1,498 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; More Hemlock Text-Manipulation functions.
+;;; Written by Skef Wholey.
+;;;
+;;; The code in this file implements the non-insert/delete functions in the
+;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(region-to-string string-to-region line-to-region
+			   previous-character next-character count-lines
+			   count-characters line-start line-end buffer-start
+			   buffer-end move-mark mark-before mark-after
+			   character-offset line-offset region-bounds
+			   set-region-bounds *print-region*))
+
+
+
+(defun region-to-string (region)
+  "Returns a string containing the characters in the given Region."
+  (close-line)
+  (let* ((dst-length (count-characters region))
+	 (string (make-string dst-length))
+	 (start-mark (region-start region))
+	 (end-mark (region-end region))
+	 (start-line (mark-line start-mark))
+	 (end-line (mark-line end-mark))
+	 (start-charpos (mark-charpos start-mark)))
+    (declare (simple-string string))
+    (if (eq start-line end-line)
+	(%sp-byte-blt (line-chars start-line) start-charpos string 0
+		      dst-length)
+	(let ((index ()))
+	  (let* ((line-chars (line-chars start-line))
+		 (dst-end (- (length line-chars) start-charpos)))
+	    (declare (simple-string line-chars))
+	    (%sp-byte-blt line-chars start-charpos string 0 dst-end)
+	    (setf (char string dst-end) #\newline)
+	    (setq index (1+ dst-end)))
+	  (do* ((line (line-next start-line) (line-next line))
+		(chars (line-chars line) (line-chars line)))
+	       ((eq line end-line)
+		(%sp-byte-blt (line-chars line) 0 string index dst-length))
+	    (declare (simple-string chars))
+	    (%sp-byte-blt (line-chars line) 0 string index
+			  (incf index (length chars)))
+	    (setf (char string index) #\newline)
+	    (setq index (1+ index)))))
+    string))
+
+(defun string-to-region (string)
+  "Returns a region containing the characters in the given String."
+  (let* ((string (if (simple-string-p string)
+		     string (coerce string 'simple-string)))
+	 (end (length string)))
+    (declare (simple-string string))
+    (do* ((index 0)
+	  (buffer (incf *disembodied-buffer-counter*))
+	  (previous-line)
+	  (line (make-line :%buffer buffer))
+	  (first-line line))
+	 (())
+      (let ((right-index (%sp-find-character string index end #\newline)))
+	(cond (right-index
+	       (let* ((length (- right-index index))
+		      (chars (make-string length)))
+		 (%sp-byte-blt string index chars 0 length)
+		 (setf (line-chars line) chars))
+	       (setq index (1+ right-index))
+	       (setq previous-line line)
+	       (setq line (make-line :%buffer buffer))
+	       (setf (line-next previous-line) line)
+	       (setf (line-previous line) previous-line))
+	      (t
+	       (let* ((length (- end index))
+		      (chars (make-string length)))
+		 (%sp-byte-blt string index chars 0 length)
+		 (setf (line-chars line) chars))
+	       (return (renumber-region
+			(internal-make-region
+			 (mark first-line 0 :right-inserting)
+			 (mark line (length (line-chars line))
+			       :left-inserting))))))))))
+
+(defun line-to-region (line)
+  "Returns a region containing the specified line."
+  (internal-make-region (mark line 0 :right-inserting)
+			(mark line (line-length* line) :left-inserting)))
+
+(defun previous-character (mark)
+  "Returns the character immediately before the given Mark."
+  (let ((line (mark-line mark))
+	(charpos (mark-charpos mark)))
+    (if (= charpos 0)
+	(if (line-previous line)
+	    #\newline
+	    nil)
+	(if (eq line open-line)
+	    (char (the simple-string open-chars)
+		  (if (<= charpos left-open-pos)
+		      (1- charpos)
+		      (1- (+ right-open-pos (- charpos left-open-pos)))))
+	    (schar (line-chars line) (1- charpos))))))
+
+(defun next-character (mark)
+  "Returns the character immediately after the given Mark."
+  (let ((line (mark-line mark))
+	(charpos (mark-charpos mark)))
+    (if (eq line open-line)
+	(if (= charpos (- line-cache-length (- right-open-pos left-open-pos)))
+	    (if (line-next line)
+		#\newline
+		nil)
+	    (schar open-chars
+		   (if (< charpos left-open-pos)
+		       charpos
+		       (+ right-open-pos (- charpos left-open-pos)))))
+	(let ((chars (line-chars line)))
+	  (if (= charpos (strlen chars))
+	      (if (line-next line)
+		  #\newline
+		  nil)
+	      (schar chars charpos))))))
+
+;;; %Set-Next-Character  --  Internal
+;;;
+;;;    This is the setf form for Next-Character.  Since we may change a
+;;; character to or from a newline, we must be prepared to split and
+;;; join lines.  We cannot just delete  a character and insert the new one
+;;; because the marks would not be right.
+;;;
+(defun %set-next-character (mark character)
+  (let* ((line (mark-line mark))
+	 (buffer (line-%buffer line))
+	 (next (line-next line)))
+    (modifying-buffer buffer
+      (modifying-line line mark)
+      (cond ((= right-open-pos line-cache-length)
+	     ;; The mark is at the end of the line.
+	     (unless next
+	       (error "~S has no next character, so it cannot be set." mark))
+	     (unless (char= character #\newline)
+	       ;; If the character is no longer a newline then mash two
+	       ;; lines together.
+	       (let ((chars (line-chars next)))
+		 (declare (simple-string chars))
+		 (setq right-open-pos (- line-cache-length (length chars)))
+		 (when (<= right-open-pos left-open-pos)
+		   (grow-open-chars (* (+ (length chars) left-open-pos 1) 2)))
+		 (%sp-byte-blt chars 0 open-chars right-open-pos 
+			       line-cache-length)
+		 (setf (schar open-chars left-open-pos) character)
+		 (incf left-open-pos))
+	       (move-some-marks (charpos next line) 
+				(+ charpos left-open-pos))
+	       (setq next (line-next next))
+	       (setf (line-next line) next)
+	       (when next (setf (line-previous next) line))))
+	    ((char= character #\newline)
+	     ;; The char is being changed to a newline, so we must split lines.
+	     (incf right-open-pos)
+	     (let* ((len (- line-cache-length right-open-pos))	   
+		    (chars (make-string len))
+		    (new (make-line :chars chars  :previous line 
+				    :next next  :%buffer buffer)))
+	       (%sp-byte-blt open-chars right-open-pos chars 0 len)
+	       (maybe-move-some-marks* (charpos line new) left-open-pos
+				       (- charpos left-open-pos 1))
+	       (setf (line-next line) new)
+	       (when next (setf (line-previous next) new))
+	       (setq right-open-pos line-cache-length)
+	       (number-line new)))
+	    (t
+	     (setf (char (the simple-string open-chars) right-open-pos)
+		   character)))))
+  character)
+
+;;; %Set-Previous-Character  --  Internal
+;;;
+;;;    The setf form for Previous-Character.  We just Temporarily move the
+;;; mark back one and call %Set-Next-Character.
+;;;
+(defun %set-previous-character (mark character)
+  (unless (mark-before mark)
+    (error "~S has no previous character, so it cannot be set." mark))
+  (%set-next-character mark character)
+  (mark-after mark)
+  character)
+
+(defun count-lines (region)
+  "Returns the number of lines in the region, first and last lines inclusive."
+  (do ((line (mark-line (region-start region)) (line-next line))
+       (count 1 (1+ count))
+       (last-line (mark-line (region-end region))))
+      ((eq line last-line) count)))
+
+(defun count-characters (region)
+  "Returns the number of characters in the region."
+  (let* ((start (region-start region))
+	 (end (region-end region))
+	 (first-line (mark-line start))
+	 (last-line (mark-line end)))
+    (if (eq first-line last-line)
+	(- (mark-charpos end) (mark-charpos start))
+	(do ((line (line-next first-line) (line-next line))
+	     (count (1+ (- (line-length* first-line) (mark-charpos start)))))
+	    ((eq line last-line)
+	     (+ count (mark-charpos end)))
+	  (setq count (+ 1 count (line-length* line)))))))
+
+(defun line-start (mark &optional line)
+  "Changes the Mark to point to the beginning of the Line and returns it.
+  Line defaults to the line Mark is on."
+  (when line
+    (change-line mark line))
+  (setf (mark-charpos mark) 0)
+  mark)
+
+(defun line-end (mark &optional line)
+  "Changes the Mark to point to the end of the line and returns it.
+  Line defaults to the line Mark is on."
+  (if line
+      (change-line mark line)
+      (setq line (mark-line mark)))
+  (setf (mark-charpos mark) (line-length* line))
+  mark)
+
+(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark))))
+  "Change Mark to point to the beginning of Buffer, which defaults to
+  the buffer Mark is currently in."
+  (unless buffer (error "Mark ~S does not point into a buffer."))
+  (move-mark mark (buffer-start-mark buffer)))
+
+(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark))))
+  "Change Mark to point to the end of Buffer, which defaults to
+  the buffer Mark is currently in."
+  (unless buffer (error "Mark ~S does not point into a buffer."))
+  (move-mark mark (buffer-end-mark buffer)))
+
+(defun move-mark (mark new-position)
+  "Changes the Mark to point to the same position as New-Position."
+  (let ((line (mark-line new-position)))
+    (change-line mark line))
+  (setf (mark-charpos mark) (mark-charpos new-position))
+  mark)
+
+(defun mark-before (mark)
+  "Changes the Mark to point one character before where it currently points.
+  NIL is returned if there is no previous character."
+  (let ((charpos (mark-charpos mark)))
+    (cond ((zerop charpos)
+	   (let ((prev (line-previous (mark-line mark))))
+	     (when prev
+	       (always-change-line mark prev)
+	       (setf (mark-charpos mark) (line-length* prev))
+	       mark)))
+	  (t
+	   (setf (mark-charpos mark) (1- charpos))
+	   mark))))
+
+(defun mark-after (mark)
+  "Changes the Mark to point one character after where it currently points.
+  NIL is returned if there is no previous character."
+  (let ((line (mark-line mark))
+	(charpos (mark-charpos mark)))
+    (cond ((= charpos (line-length* line))
+	   (let ((next (line-next line)))
+	     (when next
+	       (always-change-line mark next)
+	       (setf (mark-charpos mark) 0)
+	       mark)))
+	  (t
+	   (setf (mark-charpos mark) (1+ charpos))
+	   mark))))
+
+(defun character-offset (mark n)
+  "Changes the Mark to point N characters after (or -N before if N is negative)
+  where it currently points.  If there aren't N characters before (or after)
+  the mark, Nil is returned."
+  (let ((charpos (mark-charpos mark)))
+    (if (< n 0)
+	(let ((n (- n)))
+	  (if (< charpos n)
+	      (do ((line (line-previous (mark-line mark)) (line-previous line))
+		   (n (- n charpos 1)))
+		  ((null line) nil)
+		(let ((length (line-length* line)))
+		  (cond ((<= n length)
+			 (always-change-line mark line)
+			 (setf (mark-charpos mark) (- length n))
+			 (return mark))
+			(t
+			 (setq n (- n (1+ length)))))))
+	      (progn (setf (mark-charpos mark) (- charpos n))
+		     mark)))
+	(let* ((line (mark-line mark))
+	       (length (line-length* line)))
+	  (if (> (+ charpos n) length)
+	      (do ((line (line-next line) (line-next line))
+		   (n (- n (1+ (- length charpos)))))
+		  ((null line) nil)
+		(let ((length (line-length* line)))
+		  (cond ((<= n length)
+			 (always-change-line mark line)
+			 (setf (mark-charpos mark) n)
+			 (return mark))
+			(t
+			 (setq n (- n (1+ length)))))))
+	      (progn (setf (mark-charpos mark) (+ charpos n))
+		     mark))))))
+
+(defun line-offset (mark n &optional charpos)
+  "Changes to Mark to point N lines after (-N before if N is negative) where
+  it currently points.  If there aren't N lines after (or before) the Mark,
+  Nil is returned."
+  (if (< n 0)
+      (do ((line (mark-line mark) (line-previous line))
+	   (n n (1+ n)))
+	  ((null line) nil)
+	(when (= n 0)
+	  (always-change-line mark line)
+	  (setf (mark-charpos mark)
+		(if charpos
+		    (min (line-length line) charpos)
+		    (min (line-length line) (mark-charpos mark))))
+	  (return mark)))
+      (do ((line (mark-line mark) (line-next line))
+	   (n n (1- n)))
+	  ((null line) nil)
+	(when (= n 0)
+	  (change-line mark line)
+	  (setf (mark-charpos mark)
+		(if charpos
+		    (min (line-length line) charpos)
+		    (min (line-length line) (mark-charpos mark))))
+	  (return mark)))))
+
+;;; region-bounds  --  Public
+;;;
+(defun region-bounds (region)
+  "Return as multiple-value the start and end of Region."
+  (values (region-start region) (region-end region)))
+
+(defun set-region-bounds (region start end)
+  "Set the start and end of Region to the marks Start and End."
+  (let ((sl (mark-line start))
+	(el (mark-line end)))
+    (when (or (neq (line-%buffer sl) (line-%buffer el))
+	      (> (line-number sl) (line-number el))
+	      (and (eq sl el) (> (mark-charpos start) (mark-charpos end))))
+      (error "Marks ~S and ~S cannot be made into a region." start end))
+    (setf (region-start region) start  (region-end region) end))
+  region)
+
+
+;;;; Debugging stuff.
+
+(defun slf (string)
+  "For a good time, figure out what this function does, and why it was written."
+  (delete #\linefeed (the simple-string string)))
+
+(defun %print-whole-line (structure stream)
+  (cond ((eq structure open-line)
+	 (write-string open-chars stream :end left-open-pos)
+	 (write-string open-chars stream :start right-open-pos
+		       :end line-cache-length))
+	(t
+	 (write-string (line-chars structure) stream))))
+
+(defun %print-before-mark (mark stream)
+  (if (mark-line mark)
+      (let* ((line (mark-line mark))
+	     (chars (line-chars line))
+	     (charpos (mark-charpos mark))
+	     (length (line-length line)))
+	(declare (simple-string chars))
+	(cond ((or (> charpos length) (< charpos 0))
+	       (write-string "{bad mark}" stream))
+	      ((eq line open-line)
+	       (cond ((< charpos left-open-pos)
+		      (write-string open-chars stream :end charpos))
+		     (t
+		      (write-string open-chars stream :end left-open-pos)
+		      (let ((p (+ charpos (- right-open-pos left-open-pos))))
+			(write-string open-chars stream  :start right-open-pos
+				      :end p)))))
+	      (t
+	       (write-string chars stream :end charpos))))
+      (write-string "{deleted mark}" stream)))
+
+
+(defun %print-after-mark (mark stream)
+  (declare (ignore d))
+  (if (mark-line mark)
+      (let* ((line (mark-line mark))
+	     (chars (line-chars line))
+	     (charpos (mark-charpos mark))
+	     (length (line-length line)))
+	(declare (simple-string chars))
+	(cond ((or (> charpos length) (< charpos 0))
+	       (write-string "{bad mark}" stream))
+	      ((eq line open-line)
+	       (cond ((< charpos left-open-pos)
+		      (write-string open-chars stream  :start charpos
+				    :end left-open-pos)
+		      (write-string open-chars stream  :start right-open-pos
+				    :end line-cache-length))
+		     (t
+		      (let ((p (+ charpos (- right-open-pos left-open-pos))))
+			(write-string open-chars stream :start p
+				      :end line-cache-length)))))
+	      (t
+	       (write-string chars stream  :start charpos  :end length))))
+      (write-string "{deleted mark}" stream)))
+
+(defun %print-hline (structure stream d)
+  (declare (ignore d))
+  (write-string "#<Hemlock Line \"" stream)
+  (%print-whole-line structure stream)
+  (write-string "\">" stream))
+
+(defun %print-hmark (structure stream d)
+  (declare (ignore d))
+  (write-string "#<Hemlock Mark \"" stream)
+  (%print-before-mark structure stream)
+  (write-string "/\\" stream)
+  (%print-after-mark structure stream)
+  (write-string "\">" stream))  
+
+(defvar *print-region* 10
+  "The number of lines to print out of a region, or NIL if none.")
+
+(defun %print-hregion (region stream d)
+  (declare (ignore d))
+  (write-string "#<Hemlock Region \"" stream)
+  (let* ((start (region-start region))
+	 (end (region-end region))
+	 (first-line (mark-line start))
+	 (last-line (mark-line end)))
+    (cond
+     ((not (and (linep first-line) (linep last-line)
+		(eq (line-%buffer first-line) (line-%buffer last-line))
+		(mark<= start end)))
+      (write-string "{bad region}" stream))
+     (*print-region*
+      (cond ((eq first-line last-line)
+	     (let ((cs (mark-charpos start))
+		   (ce (mark-charpos end))
+		   (len (line-length first-line)))
+	       (cond
+		((or (< cs 0) (> ce len))
+		 (write-string "{bad region}" stream))
+		((eq first-line open-line)
+		 (let ((gap (- right-open-pos left-open-pos)))
+		   (cond
+		    ((<= ce left-open-pos)
+		     (write-string open-chars stream  :start cs  :end ce))
+		    ((>= cs left-open-pos)
+		     (write-string open-chars stream  :start (+ cs gap)
+				   :end (+ ce gap)))
+		    (t
+		     (write-string open-chars stream :start cs
+				   :end left-open-pos)
+		     (write-string open-chars stream :start right-open-pos
+				   :end (+ gap ce))))))
+		(t
+		 (write-string (line-chars first-line) stream  :start cs
+			       :end ce)))))
+	    (t
+	     (%print-after-mark start stream)
+	     (write-char #\/ stream)
+	     (do ((line (line-next first-line) (line-next line))
+		  (last-line (mark-line end))
+		  (cnt *print-region* (1- cnt)))
+		 ((or (eq line last-line)
+		      (when (zerop cnt) (write-string "..." stream) t))
+		  (%print-before-mark end stream))
+	       (%print-whole-line line stream)
+	       (write-char #\/ stream)))))
+     (t
+      (write-string "{mumble}" stream))))
+  (write-string "\">" stream))
+
+(defun %print-hbuffer (structure stream d)
+  (declare (ignore d))
+  (write-string "#<Hemlock Buffer \"" stream)
+  (write-string (buffer-name structure) stream)
+  (write-string "\">" stream))
diff --git a/hemlock/htext3.lisp b/hemlock/htext3.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..21c5fa4dfb7a425d5fa5f80791f07b30e032c081
--- /dev/null
+++ b/hemlock/htext3.lisp
@@ -0,0 +1,236 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; More Hemlock Text-Manipulation functions.
+;;; Written by Skef Wholey.
+;;;
+;;; The code in this file implements the insert functions in the
+;;; "Doing Stuff and Going Places" chapter of the Hemlock Design document.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(insert-character insert-string insert-region ninsert-region))
+
+
+
+(defun insert-character (mark character)
+  "Inserts the Character at the specified Mark."
+  (unless (and character (string-char-p character))
+    (error "Character must be non-nil and a string-char -- ~S" character))
+  (let* ((line (mark-line mark))
+	 (buffer (line-%buffer line)))
+    (modifying-buffer buffer
+      (modifying-line line mark)
+      (cond ((char= character #\newline)
+	     (let* ((next (line-next line))
+		    (new-chars (subseq (the simple-string open-chars)
+				       0 left-open-pos))
+		    (new-line (make-line :%buffer buffer
+					 :chars (decf *cache-modification-tick*)
+					 :previous line
+					 :next next)))
+	       (maybe-move-some-marks (charpos line new-line) left-open-pos
+				      (- charpos left-open-pos))
+	       (setf (line-%chars line) new-chars)
+	       (setf (line-next line) new-line)
+	       (if next (setf (line-previous next) new-line))
+	       (number-line new-line)
+	       (setq open-line new-line  left-open-pos 0)))
+	    (t
+	     (if (= right-open-pos left-open-pos)
+		 (grow-open-chars))
+	     
+	     (maybe-move-some-marks (charpos line) left-open-pos
+				    (1+ charpos))
+	     
+	     (cond
+	      ((eq (mark-%kind mark) :right-inserting)
+	       (decf right-open-pos)
+	       (setf (char (the simple-string open-chars) right-open-pos)
+		     character))
+	      (t
+	       (setf (char (the simple-string open-chars) left-open-pos)
+		     character)
+	       (incf left-open-pos))))))))
+
+
+(defun insert-string (mark string &optional (start 0) (end (length string)))
+  "Inserts the String at the Mark.  Do not use Start and End unless you
+  know what you're doing!"
+  (let* ((line (mark-line mark))
+	 (buffer (line-%buffer line))
+	 (string (coerce string 'simple-string)))
+    (declare (simple-string string))
+    (unless (zerop (- end start))
+      (modifying-buffer buffer
+	(modifying-line line mark)
+	(if (%sp-find-character string start end #\newline)
+	    (with-mark ((mark mark :left-inserting))
+	      (do ((left-index start (1+ right-index))
+		   (right-index
+		    (%sp-find-character string start end #\newline)
+		    (%sp-find-character string (1+ right-index) end #\newline)))
+		  ((null right-index)
+		   (if (/= left-index end)
+		       (insert-string mark string left-index end)))
+		(insert-string mark string left-index right-index)
+		(insert-character mark #\newline)))
+	    (let ((length (- end start)))
+	      (if (<= right-open-pos (+ left-open-pos end))
+		  (grow-open-chars (* (+ line-cache-length end) 2)))
+	      
+	      (maybe-move-some-marks (charpos line) left-open-pos
+				     (+ charpos length))
+	      (cond
+	       ((eq (mark-%kind mark) :right-inserting)
+		(let ((new (- right-open-pos length)))
+		  (%sp-byte-blt string start open-chars new right-open-pos)
+		  (setq right-open-pos new)))
+	       (t
+		(let ((new (+ left-open-pos length)))
+		  (%sp-byte-blt string start open-chars left-open-pos new)
+		  (setq left-open-pos new))))))))))
+
+
+(defconstant line-number-interval-guess 8
+  "Our first guess at how we should number an inserted region's lines.")
+
+(defun insert-region (mark region)
+  "Inserts the given Region at the Mark."
+  (let* ((start (region-start region))
+	 (end (region-end region))
+	 (first-line (mark-line start))
+	 (last-line (mark-line end))
+	 (first-charpos (mark-charpos start))
+	 (last-charpos (mark-charpos end)))
+    (cond
+     ((eq first-line last-line)
+      ;; simple case -- just BLT the characters in with insert-string
+      (if (eq first-line open-line) (close-line))
+      (insert-string mark (line-chars first-line) first-charpos last-charpos))
+     (t
+      (close-line)
+      (let* ((line (mark-line mark))
+	     (next (line-next line))
+	     (charpos (mark-charpos mark))
+	     (buffer (line-%buffer line))
+	     (old-chars (line-chars line)))
+	(declare (simple-string old-chars))
+	(modifying-buffer buffer
+	  ;;hack marked line's chars
+	  (let* ((first-chars (line-chars first-line))
+		 (first-length (length first-chars))
+		 (new-length (+ charpos (- first-length first-charpos)))
+		 (new-chars (make-string new-length)))
+	    (declare (simple-string first-chars new-chars))
+	    (%sp-byte-blt old-chars 0 new-chars 0 charpos)
+	    (%sp-byte-blt first-chars first-charpos new-chars charpos new-length)
+	    (setf (line-chars line) new-chars))
+	  
+	  ;; Copy intervening lines.  We don't link the lines in until we are
+	  ;; done in case the mark is within the region we are inserting.
+	  (do* ((this-line (line-next first-line) (line-next this-line))
+		(number (+ (line-number line) line-number-interval-guess)
+			(+ number line-number-interval-guess))
+		(first (%copy-line this-line  :previous line
+				   :%buffer buffer  :number number))
+		(previous first)
+		(new-line first (%copy-line this-line  :previous previous
+					    :%buffer buffer  :number number)))
+	       ((eq this-line last-line)
+		;;make last line
+		(let* ((last-chars (line-chars new-line))
+		       (old-length (length old-chars))
+		       (new-length (+ last-charpos (- old-length charpos)))
+		       (new-chars (make-string new-length)))
+		  (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
+		  (%sp-byte-blt old-chars charpos new-chars last-charpos
+				new-length)
+		  (setf (line-next line) first)
+		  (setf (line-chars new-line) new-chars)
+		  (setf (line-next previous) new-line)
+		  (setf (line-next new-line) next)
+		  (when next
+		    (setf (line-previous next) new-line)
+		    (if (<= (line-number next) number)
+			(renumber-region-containing new-line)))
+		  ;;fix up the marks
+		  (maybe-move-some-marks (this-charpos line new-line) charpos
+		    (+ last-charpos (- this-charpos charpos)))))
+	    (setf (line-next previous) new-line  previous new-line))))))))
+
+(defun ninsert-region (mark region)
+  "Inserts the given Region at the Mark, possibly destroying the Region.
+  Region may not be a part of any buffer's region."
+  (let* ((start (region-start region))
+	 (end (region-end region))
+	 (first-line (mark-line start))
+	 (last-line (mark-line end))
+	 (first-charpos (mark-charpos start))
+	 (last-charpos (mark-charpos end)))
+    (cond
+     ((eq first-line last-line)
+      ;; Simple case -- just BLT the characters in with insert-string.
+      (if (eq first-line open-line) (close-line))
+      (insert-string mark (line-chars first-line) first-charpos last-charpos))
+     (t
+      (when (bufferp (line-%buffer first-line))
+	(error "Region is linked into Buffer ~S." (line-%buffer first-line)))
+      (close-line)
+      (let* ((line (mark-line mark))
+	     (second-line (line-next first-line))
+	     (next (line-next line))
+	     (charpos (mark-charpos mark))
+	     (buffer (line-%buffer line))
+	     (old-chars (line-chars line)))
+	(declare (simple-string old-chars))
+	(modifying-buffer buffer
+	  ;; Make new chars for first and last lines.
+	  (let* ((first-chars (line-chars first-line))
+		 (first-length (length first-chars))
+		 (new-length (+ charpos (- first-length first-charpos)))
+		 (new-chars (make-string new-length)))
+	    (declare (simple-string first-chars new-chars))
+	    (%sp-byte-blt old-chars 0 new-chars 0 charpos)
+	    (%sp-byte-blt first-chars first-charpos new-chars charpos
+			  new-length)
+	    (setf (line-chars line) new-chars))
+	  (let* ((last-chars (line-chars last-line))
+		 (old-length (length old-chars))
+		 (new-length (+ last-charpos (- old-length charpos)))
+		 (new-chars (make-string new-length)))
+	    (%sp-byte-blt last-chars 0 new-chars 0 last-charpos)
+	    (%sp-byte-blt old-chars charpos new-chars last-charpos new-length)
+	    (setf (line-chars last-line) new-chars))
+	  
+	  ;;; Link stuff together.
+	  (setf (line-next last-line) next)
+	  (setf (line-next line) second-line)
+	  (setf (line-previous second-line) line)
+
+	  ;;Number the inserted stuff and mash any marks.
+	  (do ((line second-line (line-next line))
+	       (number (+ (line-number line) line-number-interval-guess)
+		       (+ number line-number-interval-guess)))
+	      ((eq line next)
+	       (when next
+		 (setf (line-previous next) last-line)	       
+		 (if (<= (line-number next) number)
+		     (renumber-region-containing last-line))))
+	    (when (line-marks line)
+	      (dolist (m (line-marks line))
+		(setf (mark-line m) nil))
+	      (setf (line-marks line) nil))
+	    (setf (line-number line) number  (line-%buffer line) buffer))
+	  
+	  ;; Fix up the marks in the line inserted into.
+	  (maybe-move-some-marks (this-charpos line last-line) charpos
+	    (+ last-charpos (- this-charpos charpos)))))))))
diff --git a/hemlock/killcoms.lisp b/hemlock/killcoms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..52359a858e3a95db0327c92414e17da72c2bf002
--- /dev/null
+++ b/hemlock/killcoms.lisp
@@ -0,0 +1,487 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Killing and unkilling things.
+;;;
+;;; Written by Bill Chiles and Rob MacLachlan.
+;;;
+
+(in-package "HEMLOCK")
+
+(defvar *kill-ring* (make-ring 10) "The Hemlock kill ring.")
+
+
+
+;;;; Active Regions.
+
+(defhvar "Active Regions Enabled"
+  "When set, some commands that affect the current region only work when the
+   region is active."
+  :value t)
+
+(defhvar "Highlight Active Region"
+  "When set, the active region will be highlighted on the display if possible."
+  :value t)
+
+
+(defvar *active-region-p* nil)
+(defvar *active-region-buffer* nil)
+(defvar *ephemerally-active-command-types* (list :ephemerally-active)
+  "This is a list of command types that permit the current region to be active
+   for the immediately following command.")
+
+(proclaim '(inline activate-region deactivate-region region-active-p))
+
+(defun activate-region ()
+  "Make the current region active."
+  (let ((buffer (current-buffer)))
+    (setf *active-region-p* (buffer-signature buffer))
+    (setf *active-region-buffer* buffer)))
+
+(defun deactivate-region ()
+  "Make the current region not active."
+  (setf *active-region-p* nil)
+  (setf *active-region-buffer* nil))
+
+(defun region-active-p ()
+  "Returns t or nil, depending on whether the current region is active."
+  (or (and *active-region-buffer*
+	   (eql *active-region-p* (buffer-signature *active-region-buffer*)))
+      (member (last-command-type) *ephemerally-active-command-types*
+	      :test #'equal)))
+
+(defun check-region-active ()
+  "Signals an error when active regions are enabled and the current region
+   is not active."
+  (when (and (value active-regions-enabled) (not (region-active-p)))
+    (editor-error "The current region is not active.")))
+
+(defun current-region (&optional (error-if-not-active t)
+				 (deactivate-region t))
+  "Returns a region formed by CURRENT-MARK and CURRENT-POINT, optionally
+   signalling an editor error if the current region is not active.  A new
+   region is cons'ed on each call.  This optionally deactivates the region."
+  (when error-if-not-active (check-region-active))
+  (when deactivate-region (deactivate-region))
+  (let ((point (current-point))
+	(mark (current-mark)))
+    (if (mark< mark point) (region mark point) (region point mark))))
+
+
+(defcommand "Activate Region" (p)
+  "Make the current region active.  ^G deactivates the region."
+  "Make the current region active."
+  (declare (ignore p))
+  (activate-region))
+
+
+;;; The following are hook functions for keeping things righteous.
+;;; 
+
+(defun set-buffer-deactivate-region (buffer)
+  (declare (ignore buffer))
+  (deactivate-region))
+;;;
+(add-hook set-buffer-hook 'set-buffer-deactivate-region)
+
+(defun set-window-deactivate-region (window)
+  (declare (ignore window))
+  (unless (or (eq window *echo-area-window*)
+	      (eq (current-window) *echo-area-window*))
+    (deactivate-region)))
+;;;
+(add-hook set-window-hook 'set-window-deactivate-region)
+
+(defun control-g-deactivate-region ()
+  (deactivate-region))
+;;;
+(add-hook abort-hook 'control-g-deactivate-region)
+
+
+
+;;;; Buffer-Mark primitives and commands.
+
+;;; See Command.Lisp for #'hcmd-make-buffer-hook-fun which makes the
+;;; stack for each buffer.
+
+(defun current-mark ()
+  "Returns the top of the current buffer's mark stack."
+  (ring-ref (value buffer-mark-ring) 0))
+
+(defun buffer-mark (buffer)
+  "Returns the top of buffer's mark stack."
+  (ring-ref (variable-value 'buffer-mark-ring :buffer buffer) 0))
+
+(defun pop-buffer-mark ()
+  "Pops the current buffer's mark stack, returning the mark.  If the stack
+   becomes empty, a mark is push on the stack pointing to the buffer's start.
+   This always makes the current region not active."
+  (let* ((ring (value buffer-mark-ring))
+	 (mark (ring-pop ring)))
+    (deactivate-region)
+    (if (zerop (ring-length ring))
+	(ring-push (copy-mark
+		    (buffer-start-mark (current-buffer)) :right-inserting)
+		   ring))
+    mark))
+
+(defun push-buffer-mark (mark &optional (activate-region nil))
+  "Pushes mark into buffer's mark ring, ensuring that the mark is in the right
+   buffer and :right-inserting.  Optionally, the current region is made active.
+   This never deactivates the current region.  Mark is returned."
+  (cond ((eq (line-buffer (mark-line mark)) (current-buffer))
+	 (setf (mark-kind mark) :right-inserting)
+	 (ring-push mark (value buffer-mark-ring)))
+	(t (error "Mark not in the current buffer.")))
+  (when activate-region (activate-region))
+  mark)
+
+(defcommand "Set/Pop Mark" (p)
+  "Set or Pop the mark ring.
+   With no C-U's, pushes point as the mark, activating the current region.
+   With one C-U's, pops the mark into point, de-activating the current region.
+   With two C-U's, pops the mark and throws it away, de-activating the current
+   region."
+  "Set or Pop the mark ring."
+  (cond ((not p)
+	 (push-buffer-mark (copy-mark (current-point)) t)
+	 (when (interactive)
+	   (message "Mark pushed.")))
+	((= p (value universal-argument-default))
+	 (pop-and-goto-mark-command nil))
+	((= p (expt (value universal-argument-default) 2))
+	 (delete-mark (pop-buffer-mark)))
+	(t (editor-error))))
+
+(defcommand "Pop and Goto Mark" (p)
+  "Pop mark into point, de-activating the current region."
+  "Pop mark into point."
+  (declare (ignore p))
+  (let ((mark (pop-buffer-mark)))
+    (move-mark (current-point) mark)
+    (delete-mark mark)))
+
+(defcommand "Pop Mark" (p)
+  "Pop mark and throw it away, de-activating the current region."
+  "Pop mark and throw it away."
+  (declare (ignore p))
+  (delete-mark (pop-buffer-mark)))
+
+(defcommand "Exchange Point and Mark" (p)
+  "Swap the positions of the point and the mark."
+  "Swap the positions of the point and the mark."
+  (declare (ignore p))
+  (let ((point (current-point))
+	(mark (current-mark)))
+    (with-mark ((temp point))
+      (move-mark point mark)
+      (move-mark mark temp))))
+
+(defcommand "Mark Whole Buffer"  (p)
+  "Set the region around the whole buffer, activating the region.
+   Pushes the point on the mark ring first, so two pops get it back.
+   With prefix argument, put mark at beginning and point at end."
+  "Put point at beginning and part at end of current buffer.
+  If P, do it the other way around."
+  (let* ((region (buffer-region (current-buffer)))
+	 (start (region-start region))
+	 (end (region-end region))
+	 (point (current-point)))
+    (push-buffer-mark (copy-mark point))
+    (cond (p (push-buffer-mark (copy-mark start) t)
+	     (move-mark point end))
+	  (t (push-buffer-mark (copy-mark end) t)
+	     (move-mark point start)))))
+
+
+
+;;;; KILL-REGION and KILL-CHARACTERS primitives.
+
+(proclaim '(special *delete-char-region*))
+
+;;; KILL-REGION first checks for any characters that may need to be added to
+;;; the region.  If there are some, we possibly push a region onto *kill-ring*,
+;;; and we use the top of *kill-ring*.  If there are no characters to deal
+;;; with, then we make sure the ring isn't empty; if it is, just push our
+;;; region.  If there is some region in *kill-ring*, then see if the last
+;;; command type was a region kill.  Otherwise, just push the region.
+;;;
+(defun kill-region (region current-type)
+  "Kills the region saving it in *kill-ring*.  Current-type is either
+   :kill-forward or :kill-backward.  When LAST-COMMAND-TYPE is one of these,
+   region is appended or prepended, respectively, to the top of *kill-ring*.
+   The killing of the region is undo-able with \"Undo\".  LAST-COMMAND-TYPE
+   is set to current-type.  This interacts with KILL-CHARACTERS."
+  (let ((last-type (last-command-type))
+	(insert-mark (copy-mark (region-start region) :left-inserting)))
+    (cond ((or (eq last-type :char-kill-forward)
+	       (eq last-type :char-kill-backward))
+	   (when *delete-char-region*
+	     (ring-push *delete-char-region* *kill-ring*)
+	     (setf *delete-char-region* nil))
+	   (setf region (kill-region-top-of-ring region current-type)))
+	  ((zerop (ring-length *kill-ring*))
+	   (setf region (delete-and-save-region region))
+	   (ring-push region *kill-ring*))
+	  ((or (eq last-type :kill-forward) (eq last-type :kill-backward))
+	   (setf region (kill-region-top-of-ring region current-type)))
+	  (t
+	   (setf region (delete-and-save-region region))
+	   (ring-push region *kill-ring*)))
+    (make-region-undo :insert "kill" (copy-region region) insert-mark)
+    (setf (last-command-type) current-type)))
+
+(defun kill-region-top-of-ring (region current-type)
+  (let ((r (ring-ref *kill-ring* 0)))
+    (ninsert-region (if (eq current-type :kill-forward)
+			(region-end r)
+			(region-start r))
+		    (delete-and-save-region region))
+    r))
+
+(defhvar "Character Deletion Threshold"
+  "When this many characters are deleted contiguously via KILL-CHARACTERS,
+   they are saved on the kill ring -- for example, \"Delete Next Character\",
+   \"Delete Previous Character\", or \"Delete Previous Character Expanding
+   Tabs\"."
+  :value 5)
+
+(defvar *delete-char-region* nil)
+(defvar *delete-char-count* 0)
+
+;;; KILL-CHARACTERS makes sure there are count characters with CHARACTER-OFFSET.
+;;; If the last command type was a region kill, we just use the top region
+;;; in *kill-ring* by making KILL-CHAR-REGION believe *delete-char-count* is
+;;; over the threshold.  We don't call KILL-REGION in this case to save making
+;;; undo's -- no good reason.  If we were just called, then increment our
+;;; global counter.  Otherwise, make an empty region to keep KILL-CHAR-REGION
+;;; happy and increment the global counter.
+;;;
+(defun kill-characters (mark count)
+  "Kills count characters after mark if positive, before mark if negative.
+   If called multiple times contiguously such that the sum of the count values
+   equals \"Character Deletion Threshold\", then the characters are saved on
+   *kill-ring*.  This relies on setting LAST-COMMAND-TYPE, and it interacts
+   with KILL-REGION.  If there are not count characters in the appropriate
+   direction, no characters are deleted, and nil is returned; otherwise, mark
+   is returned."
+  (if (zerop count)
+      mark
+      (with-mark ((temp mark :left-inserting))
+	(if (character-offset temp count)
+	    (let ((current-type (if (plusp count)
+				    :char-kill-forward
+				    :char-kill-backward))
+		  (last-type (last-command-type))
+		  (del-region (if (mark< temp mark)
+				  (region temp mark)
+				  (region mark temp))))
+	      (cond ((or (eq last-type :kill-forward)
+			 (eq last-type :kill-backward))
+		     (setf *delete-char-count*
+			   (value character-deletion-threshold))
+		     (setf *delete-char-region* nil))
+		    ((or (eq last-type :char-kill-backward)
+			 (eq last-type :char-kill-forward))
+		     (incf *delete-char-count* (abs count)))
+		    (t
+		     (setf *delete-char-region* (make-empty-region))
+		     (setf *delete-char-count* (abs count))))
+	      (kill-char-region del-region current-type)
+	      mark)
+	    nil))))
+
+(defun kill-char-region (region current-type)
+  (let ((deleted-region (delete-and-save-region region)))
+    (cond ((< *delete-char-count* (value character-deletion-threshold))
+	   (ninsert-region (if (eq current-type :char-kill-forward)
+			       (region-end *delete-char-region*)
+			       (region-start *delete-char-region*))
+			   deleted-region)
+	   (setf (last-command-type) current-type))
+	  (t
+	   (when *delete-char-region*
+	     (ring-push *delete-char-region* *kill-ring*)
+	     (setf *delete-char-region* nil))
+	   (let ((r (ring-ref *kill-ring* 0)))
+	     (ninsert-region (if (eq current-type :char-kill-forward)
+				 (region-end r)
+				 (region-start r))
+			     deleted-region))
+	   (setf (last-command-type)
+		 (if (eq current-type :char-kill-forward)
+		     :kill-forward
+		     :kill-backward))))))
+
+
+
+;;;; Commands.
+
+(defcommand "Kill Region" (p)
+  "Kill the region, pushing on the kill ring.
+   If the region is not active nor the last command a yank, signal an error."
+  "Kill the region, pushing on the kill ring."
+  (declare (ignore p))
+  (kill-region (current-region)
+		(if (mark< (current-mark) (current-point))
+		    :kill-backward
+		    :kill-forward)))
+
+(defcommand "Save Region" (p)
+  "Insert the region into the kill ring.
+   If the region is not active nor the last command a yank, signal an error."
+  "Insert the region into the kill ring."
+  (declare (ignore p))
+  (ring-push (copy-region (current-region)) *kill-ring*))
+
+(defcommand "Kill Next Word" (p)
+  "Kill a word at the point.
+  With prefix argument delete that many words.  The text killed is
+  appended to the text currently at the top of the kill ring if it was
+  next to the text being killed."
+  "Kill p words at the point"
+  (let ((point (current-point))
+	(num (or p 1)))
+    (with-mark ((mark point :temporary))
+      (if (word-offset mark num)
+	  (if (minusp num)
+	      (kill-region (region mark point) :kill-backward)
+	      (kill-region (region point mark) :kill-forward))
+	  (editor-error)))))
+
+(defcommand "Kill Previous Word" (p)
+  "Kill a word before the point.
+  With prefix argument kill that many words before the point.  The text
+  being killed is appended to the text currently at the top of the kill
+  ring if it was next to the text being killed."
+  "Kill p words before the point"
+  (kill-next-word-command (- (or p 1))))
+
+
+(defcommand "Kill Line" (p)
+  "Kills the characters to the end of the current line.
+  If the line is empty then the line is deleted.  With prefix argument,
+  deletes that many lines past the point (or before if the prefix is negative)."
+  "Kills p lines after the point."
+  (let* ((point (current-point))
+	 (line (mark-line point)))
+    (with-mark ((mark point))
+      (cond 
+       (p
+	(when (and (/= (mark-charpos point) 0) (minusp p))
+	  (incf p))
+	(unless (line-offset mark p 0)
+	  (if (plusp p)
+	      (kill-region (region point (buffer-end mark)) :kill-forward)
+	      (kill-region (region (buffer-start mark) point) :kill-backward))
+	  (editor-error))
+	(if (plusp p)
+	    (kill-region (region point mark) :kill-forward)
+	    (kill-region (region mark point) :kill-backward)))
+       (t
+	(cond ((not (blank-after-p mark))
+	       (line-end mark))
+	      ((line-next line)
+	       (line-start mark (line-next line)))
+	      ((not (end-line-p mark))
+	       (line-end mark))
+	      (t 
+	       (editor-error)))
+	(kill-region (region point mark) :kill-forward))))))
+
+(defcommand "Backward Kill Line" (p)
+  "Kill from the point to the beginning of the line.
+  If at the beginning of the line, kill the newline and any trailing space
+  on the previous line.  With prefix argument, call \"Kill Line\" with
+  the argument negated."
+  "Kills p lines before the point."
+  (if p
+      (kill-line-command (- p))
+      (with-mark ((m (current-point)))
+	(cond ((zerop (mark-charpos m))
+	       (mark-before m)
+	       (unless (reverse-find-attribute m :space #'zerop)
+		 (buffer-start m)))
+	       (t
+		(line-start m)))
+	(kill-region (region m (current-point)) :kill-backward))))
+
+
+(defcommand "Delete Blank Lines" (p)
+  "On a blank line, deletes all surrounding blank lines, leaving just
+  one. On an isolated blank line, deletes that one. On a non-blank line,
+  deletes all blank following that one."
+  "Kill blank lines around the point"
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (with-mark ((beg-mark point :left-inserting)
+		(end-mark point :right-inserting))
+      ;; handle case when the current line is blank
+      (when (blank-line-p (mark-line point))
+	;; back up to last non-whitespace character
+	(reverse-find-attribute beg-mark :whitespace #'zerop)
+	(when (previous-character beg-mark)
+	  ;; that is, we didn't back up to the beginning of the buffer
+	  (unless (same-line-p beg-mark end-mark)
+	    (line-offset beg-mark 1 0)))
+	;; if isolated, zap the line else zap the blank ones above
+	(cond ((same-line-p beg-mark end-mark)
+	       (line-offset end-mark 1 0))
+	      (t
+	       (line-start end-mark)))
+	(delete-region (region beg-mark end-mark)))
+      ;; always delete all blank lines after the current line
+      (move-mark beg-mark point)
+      (when (line-offset beg-mark 1 0)
+	(move-mark end-mark beg-mark)
+	(find-attribute end-mark :whitespace #'zerop)
+	(when (next-character end-mark)
+	  ;; that is, we didn't go all the way to the end of the buffer
+	  (line-start end-mark))
+	(delete-region (region beg-mark end-mark))))))
+
+
+(defcommand "Un-Kill" (p)
+  "Inserts the top item in the kill-ring at the point.
+  The mark is left mark before the insertion and the point after.  With prefix
+  argument inserts the prefix'th most recent item."
+  "Inserts the item with index p in the kill ring at the point, leaving 
+  the mark before and the point after."
+  (let ((idx (1- (or p 1))))
+    (cond ((> (ring-length *kill-ring*) idx -1)
+	   (let* ((region (ring-ref *kill-ring* idx))
+		  (point (current-point))
+		  (mark (copy-mark point)))
+	     (push-buffer-mark mark)
+	     (insert-region point region)
+	     (make-region-undo :delete "Un-Kill"
+			       (region (copy-mark mark) (copy-mark point))))
+	   (setf (last-command-type) :unkill))
+	  (t (editor-error)))))
+;;;
+(push :unkill *ephemerally-active-command-types*)
+
+(defcommand "Rotate Kill Ring" (p)
+  "Replace un-killed text with previously killed text.
+  Kills the current region, rotates the kill ring, and inserts the new top
+  item.  With prefix argument rotates the kill ring that many times."
+  "This function will not behave in any reasonable fashion when
+  called as a lisp function."
+  (let ((point (current-point))
+	(mark (current-mark)))
+    (cond ((or (not (eq (last-command-type) :unkill))
+	       (zerop (ring-length *kill-ring*)))
+	   (editor-error))
+	  (t (delete-region (region mark point))
+	     (rotate-ring *kill-ring* (or p 1))
+	     (insert-region point (ring-ref *kill-ring* 0))
+	     (make-region-undo :delete "Un-Kill"
+			       (region (copy-mark mark) (copy-mark point)))
+	     (setf (last-command-type) :unkill)))))
diff --git a/hemlock/line.lisp b/hemlock/line.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..f5eb2e963fd49b1e67322441ce4d6b2d4b173fa0
--- /dev/null
+++ b/hemlock/line.lisp
@@ -0,0 +1,167 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains definitions for the Line structure, and some 
+;;; functions and macros to manipulate them.
+;;;
+;;;    This stuff was allowed to become implementation dependant because
+;;; you make thousands of lines, so speed is real important.  In some
+;;; implementations (the Perq for example) it may be desirable to 
+;;; not actually cons the strings in the line objects until someone
+;;; touches them, and just keep a pointer in the line to where the file 
+;;; is mapped in memory.  Such lines are called "buffered".  This stuff
+;;; links up with the file-reading stuff and the line-image building stuff.
+;;;
+(in-package 'hemlock-internals)
+(export '(line linep line-previous line-next line-plist line-signature))
+
+(setf (documentation 'linep 'function)
+  "Returns true if its argument is a Hemlock line object, Nil otherwise.")
+(setf (documentation 'line-previous 'function)
+  "Return the Hemlock line that precedes this one, or Nil if there is no
+  previous line.")
+(setf (documentation 'line-next 'function)
+  "Return the Hemlock line that follows this one, or Nil if there is no
+  next line.")
+(setf (documentation 'line-plist 'function)
+  "Return a line's property list.  This may be manipulated with Setf and Getf.")
+
+
+;;;; The line object:
+
+(defstruct (line (:print-function %print-hline)
+		 (:predicate linep)
+		 (:constructor nil))
+  "A Hemlock line object.  See Hemlock design document for details."
+  ;;
+  ;; Something that represents the contents of the line.  This is
+  ;; guaranteed to change (as compared by EQL) whenver the contents of the
+  ;; line changes, but might at arbitarary other times.  There are
+  ;; currently about three different cases:
+  ;;
+  ;; Normal:
+  ;;    A simple string holding the contents of the line.
+  ;;
+  ;; A cached line:
+  ;;    The line is eq to Open-Line, and the actual contents are in the
+  ;;    line cache.  The %Chars may be either the original contents or a
+  ;;    negative fixnum.
+  ;;
+  ;; A buffered line:
+  ;;    The line hasn't been touched since it was read from a file, and the
+  ;;    actual contents are in some system I/O area.  This is indicated by
+  ;;    the Line-Buffered-P slot being true.  In buffered lines on the RT,
+  ;;    the %Chars slot contains the system-area-pointer to the beginning
+  ;;    of the characters.
+  (%chars "")
+  ;;
+  ;; Pointers to the next and previous lines in the doubly linked list of
+  ;; line structures.
+  previous
+  next
+  ;;
+  ;; A list of all the permanent marks pointing into this line.
+  (marks ())
+  ;;
+  ;; The buffer to which this line belongs, or a *disembodied-buffer-count*
+  ;; if the line is not in any buffer.
+  %buffer
+  ;;
+  ;; A non-negative integer (fixnum) that represents the ordering of lines
+  ;; within continguous range of lines (a buffer or disembuffered region).
+  ;; The number of the Line-Next is guaranteed to be strictly greater than
+  ;; our number, and the Line-Previous is guaranteed to be strictly less.
+  (number 0)
+  ;;
+  ;; The line property list, used by user code to annotate the text.
+  plist
+  ;;
+  ;; A slot that indicates whether this line is a buffered line, and if so
+  ;; contains information about how the text is stored.  On the RT, this is
+  ;; the length of the text pointed to by the Line-%Chars.
+  #+Buffered-Lines
+  (buffered-p ()))
+
+;;; Make Line-Chars the same as Line-%Chars on implementations without
+;;; buffered lines.
+;;;
+#-Buffered-Lines
+(defmacro line-chars (x)
+  `(line-%chars ,x))
+
+
+;;; If buffered lines are supported, then we create the string
+;;; representation for the characters when someone uses Line-Chars.  People
+;;; who are prepared to handle buffered lines or who just want a signature
+;;; for the contents can use Line-%chars directly.
+;;;
+#+Buffered-Lines
+(defmacro line-chars (line)
+  `(the simple-string (if (line-buffered-p ,line)
+			  (read-buffered-line ,line)
+			  (line-%chars ,line))))
+;;;
+#+Buffered-Lines
+(defsetf line-chars %set-line-chars)
+;;;
+#+Buffered-Lines
+(defmacro %set-line-chars (line chars)
+  `(setf (line-%chars ,line) ,chars))
+
+
+;;; Line-Signature  --  Public
+;;;
+;;;    We can just return the Line-%Chars.
+;;;
+(proclaim '(inline line-signature))
+(defun line-signature (line)
+  "This function returns an object which serves as a signature for a line's
+  contents.  It is guaranteed that any modification of text on the line will
+  result in the signature changing so that it is not EQL to any previous value.
+  Note that the signature may change even when the text hasn't been modified, but
+  this probably won't happen often."
+  (line-%chars line))
+
+
+;;; Fast version of Make-Line does keyword hacking at compile time.
+;;;
+(defmacro make-line (&key chars previous next marks %buffer number
+			  plist #+Buffered-Lines buffered-p)
+  `(lisp::%sp-set-vector-subtype
+    (vector 'line
+	    ,chars
+	    ,previous
+	    ,next
+	    ,marks
+	    ,%buffer
+	    ,number
+	    ,plist
+	    #+Buffered-Lines ,buffered-p)
+    1))
+
+;;; Return a copy of Line in buffer Buffer with the same chars.  We use
+;;; this macro where we want to copy a line because it takes care of
+;;; the case where the line is buffered.
+;;;
+(defmacro %copy-line (line &key previous number %buffer)
+  `(make-line :chars (line-%chars ,line)
+	      :previous ,previous
+	      :number ,number
+	      :%buffer ,%buffer
+	      #+Buffered-Lines :buffered-p
+	      #+Buffered-Lines (line-buffered-p ,line)))
+
+(defmacro line-length* (line)
+  "Returns the number of characters on the line, but it's a macro!"
+  `(cond ((eq ,line open-line)
+	  (+ left-open-pos (- line-cache-length right-open-pos)))
+	 ((line-buffered-p ,line))
+	 (t
+	  (length (the simple-string (line-%chars ,line))))))
diff --git a/hemlock/linimage.lisp b/hemlock/linimage.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..504aedfedf406672ed47b6936cf6d43a31bf88bf
--- /dev/null
+++ b/hemlock/linimage.lisp
@@ -0,0 +1,508 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Rob MacLachlan
+;;;
+;;; This file contains functions related to building line images.
+;;;
+(in-package 'hemlock-internals)
+
+;;;    The code in here is factored out in this way because it is more
+;;; or less implementation dependant.  The reason this code is 
+;;; implementation dependant is not because it is not written in 
+;;; Common Lisp per se, but because it uses this thing called 
+;;; %SP-Find-Character-With-Attribute to find any characters that
+;;; are to be displayed on the line which do not print as themselves.
+;;; This permits us to have an arbitrary string or even string-valued
+;;; function to as the representation for such a "Funny" character
+;;; with minimal penalty for the normal case.  This function can be written 
+;;; in lisp, and is included commented-out below, but if this function
+;;; is not real fast then redisplay performance will suffer.
+;;;
+;;;    Theres also code in here that special-cases "Buffered" lines,
+;;; which is not exactly Common Lisp, but if you aren't on a perq,
+;;; you won't have to worry about it.
+;;;
+;(defun %sp-find-character-with-attribute (string start end table mask)
+;  (declare (type (simple-array (mod 256) char-code-max) table))
+;  (declare (simple-string string))
+;  (declare (fixnum start end))
+;  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
+;  The codes of the characters of String from Start to End are used as indices
+;  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
+;  up from the table bitwise ANDed with Mask is non-zero, the current
+;  index into the String is returned. The corresponds to SCANC on the Vax."
+;  (do ((index start (1+ index)))
+;      ((= index end) nil)
+;    (declare (fixnum index))
+;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
+;	(return index))))
+;
+;(defun %sp-reverse-find-character-with-attribute (string start end table
+;							  mask)
+;  (declare (type (simple-array (mod 256) char-code-max) table))
+;  (declare (simple-string string))
+;  (declare (fixnum start end))
+;  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
+;  (do ((index (1- end) (1- index)))
+;      ((< index start) nil)
+;    (declare (fixnum index))
+;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
+;	(return index))))
+
+(defconstant winning-char #b01 "Bit for a char that prints normally")
+(defconstant losing-char #b10 "Bit for char with funny representation.")
+(defvar *losing-character-mask*
+  (make-array char-code-limit :element-type '(mod 256)
+	      :initial-element winning-char)
+  "This is a character set used by redisplay to find funny chars.")
+(defvar *print-representation-vector* nil
+  "Redisplay's handle on the :print-representation attribute")
+
+;;;  Do a find-character-with-attribute on the *losing-character-mask*.
+(defmacro %fcwa (str start end mask)
+  `(%sp-find-character-with-attribute
+    ,str ,start ,end *losing-character-mask* ,mask))
+
+;;; Get the print-representation of a character.
+(defmacro get-rep (ch)
+  `(svref *print-representation-vector* (char-code ,ch)))
+
+
+
+(proclaim '(special *character-attributes*))
+
+;;; %init-line-image  --  Internal
+;;;
+;;;    Set up the print-representations for funny chars.  We make the
+;;; attribute vector by hand and do funny stuff so that chars > 127
+;;; will have a losing print-representation, so redisplay will not
+;;; die if you visit a binary file or do something stupid like that.
+;;;
+(defun %init-line-image ()
+  (defattribute "Print Representation"
+    "The value of this attribute determines how a character is displayed
+    on the screen.  If the value is a string this string is literally
+    displayed.  If it is a function, then that function is called with
+    the current X position to get the string to display.")
+  (setq *print-representation-vector* (make-array char-code-limit))
+  (setf (attribute-descriptor-vector
+	 (gethash :print-representation *character-attributes*))
+	*print-representation-vector*)
+  (do ((code syntax-char-code-limit (1+ code))
+       (str (make-string 4) (make-string 4)))
+      ((= code char-code-limit))
+    (setf (aref *losing-character-mask* code) losing-char)
+    (setf (aref *print-representation-vector* code) str)
+    (setf (schar str 0) #\<)
+    (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
+    (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
+    (setf (schar str 3) #\>))
+
+  (add-hook ed::character-attribute-hook
+	    #'redis-set-char-attribute-hook-fun)
+  (do ((i (1- (char-code #\space)) (1- i)) str)
+      ((minusp i))
+    (setq str (make-string 2))
+    (setf (elt (the simple-string str) 0) #\^)
+    (setf (elt (the simple-string str) 1)
+	  (code-char (+ i (char-code #\@))))
+    (setf (character-attribute :print-representation (code-char i)) str))
+  (setf (character-attribute :print-representation (code-char #o177)) "^?")
+  (setf (character-attribute :print-representation #\tab)
+	#'redis-tab-display-fun))
+
+;;; redis-set-char-attribute-hook-fun
+;;;
+;;;    Keep track of which characters have funny representations.
+;;;
+(defun redis-set-char-attribute-hook-fun (attribute char new-value)
+  (when (eq attribute :print-representation)
+    (cond
+     ((simple-string-p new-value)
+      (if (and (= (length (the simple-string new-value)) 1)
+	       (char= char (elt (the simple-string new-value) 0)))
+	  (setf (aref *losing-character-mask* (char-code char)) winning-char)
+	  (setf (aref *losing-character-mask* (char-code char))
+		losing-char)))
+     ((functionp new-value)
+      (setf (aref *losing-character-mask* (char-code char)) losing-char))
+     (t (error "Bad print representation: ~S" new-value)))))
+
+;;; redis-tab-display-fun
+;;;
+;;;    This function is initially the :print-representation for tab.
+;;;
+(defun redis-tab-display-fun (xpos)
+  (svref '#("        "
+	    "       "
+	    "      "
+	    "     "
+	    "    "
+	    "   "
+	    "  "
+	    " ")
+	 (logand xpos 7)))
+
+
+;;;; The actual line image computing functions.
+;;;;
+
+(eval-when (compile eval)
+;;; display-some-chars  --  internal
+;;;
+;;;    Put some characters into a window.  Characters from src-start 
+;;; to src-end in src are are put in the window's dis-line's.  Lines
+;;; are wrapped as necessary.  dst is the dis-line-chars of the dis-line 
+;;; currently being written.  Dis-lines is the window's vector of dis-lines.
+;;; dis-line is the dis-line currently being written.  Line is the index
+;;; into dis-lines of the current dis-line.  dst-start is the index to
+;;; start writing chars at.  Height and width are the height and width of the 
+;;; window.  src-start, dst, dst-start, line and dis-line are updated.
+;;; Done-P indicates whether there are more characters after this sequence.
+;;;
+(defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
+  `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
+     (declare (fixnum dst-end))
+     (cond
+      ((>= dst-end ,width)
+       (cond 
+	((and ,done-p (= dst-end ,width))
+	 (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
+	 (setq ,dst-start dst-end  ,src-start ,src-end))
+	(t
+	 (let ((1-width (1- ,width)))
+	   (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
+	   (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
+	   (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
+	   (setq ,dst-start nil)))))
+      (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
+	 (setq ,dst-start dst-end  ,src-start ,src-end)))))
+
+;;; These macros are given as args to display-losing-chars to get the
+;;; print representation of whatever is in the data vector.
+(defmacro string-get-rep (string index)
+  `(get-rep (schar ,string ,index)))
+
+(defmacro u-vec-get-rep (u-vec index)
+  `(svref *print-representation-vector*
+	  (%primitive 8bit-system-ref ,u-vec ,index)))
+
+;;; display-losing-chars  --  Internal
+;;;
+;;;    This macro is called by the compute-line-image functions to
+;;; display a group of losing characters.
+;;;
+(defmacro display-losing-chars (line-chars index end dest xpos width
+					   string underhang access-fun
+					   &optional (done-p `(= ,index ,end)))
+  `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
+	str len zero)
+       (())
+     (declare (fixnum last len zero))
+     (setq str (,access-fun ,line-chars ,index))
+     (unless (simple-string-p str) (setq str (funcall str ,xpos)))
+     (setq len (strlen str)  zero 0)
+     (incf ,index)
+     (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
+     (cond ((not ,xpos)
+	    ;; We wrapped in the middle of a losing char.	       
+	    (setq ,underhang zero  ,string str)
+	    (return nil))
+	   ((= ,index last)
+	    ;; No more losing chars in this bunch.
+	    (return nil)))))
+
+(defmacro update-and-punt (dis-line length string underhang end)
+  `(progn (setf (dis-line-length ,dis-line) ,length)
+	  (return (values ,string ,underhang
+			  (setf (dis-line-end ,dis-line) ,end)))))
+
+); eval-when (compile eval)
+
+;;; compute-normal-line-image  --  Internal
+;;;
+;;;    Compute the screen representation of Line starting at Start 
+;;; putting it in Dis-Line beginning at Xpos.  Width is the width of the 
+;;; window we are displaying in.  If the line will wrap then we display 
+;;; as many chars as we can then put in *line-wrap-char*.  The values 
+;;; returned are described in Compute-Line-Image, which tail-recursively 
+;;; returns them.  The length slot in Dis-Line is updated.
+;;;
+;;; We use the *losing-character-mask* to break the line to be displayed
+;;; up into chunks of characters with normal print representation and
+;;; those with funny representations.
+;;;
+(defun compute-normal-line-image (line start dis-line xpos width)
+  (declare (fixnum start xpos width))
+  (do* ((index start)
+	(line-chars (line-%chars line))
+	(end (strlen line-chars))
+	(dest (dis-line-chars dis-line)) losing underhang string)
+       (())
+    (declare (fixnum index end losing)
+	     (simple-string line-chars dest))
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang index))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ((= index end)
+      (update-and-punt dis-line xpos nil nil index)))
+    (setq losing (%fcwa line-chars index end losing-char))
+    (when (null losing)
+      (display-some-chars line-chars index end dest xpos width t)
+      (if (or xpos (= index end))
+	  (update-and-punt dis-line xpos nil nil index)
+	  (update-and-punt dis-line width nil 0 index)))
+    (display-some-chars line-chars index losing dest xpos width nil)
+    (cond
+     ;; Did we wrap?
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ;; Are we about to cause the line to wrap? If so, wrap before
+     ;; it's too late.
+     ((= xpos width)
+      (setf (char dest (1- width)) *line-wrap-char*)
+      (update-and-punt dis-line width nil 0 index))
+     (t
+      (display-losing-chars line-chars index end dest xpos width string
+			    underhang string-get-rep)))))
+
+;;; compute-buffered-line-image  --  Internal
+;;;
+;;;    Compute the line image for a "Buffered" line, that is, one whose 
+;;; chars have not been consed yet.
+
+(defun compute-buffered-line-image (line start dis-line xpos width)
+  (declare (fixnum start xpos width))
+  (do* ((index start)
+	(line-chars (line-%chars line))
+	(end (line-buffered-p line))
+	(dest (dis-line-chars dis-line)) losing underhang string)
+       (())
+    (declare (fixnum index end losing)
+	     (simple-string line-chars dest))
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang index))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ((= index end)
+      (update-and-punt dis-line xpos nil nil index)))
+    (setq losing (%fcwa line-chars index end losing-char))
+    (when (null losing)
+      (display-some-chars line-chars index end dest xpos width t)
+      (if (or xpos (= index end))
+	  (update-and-punt dis-line xpos nil nil index)
+	  (update-and-punt dis-line width nil 0 index)))
+    (display-some-chars line-chars index losing dest xpos width nil)
+    (cond
+     ;; Did we wrap?
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ;; Are we about to cause the line to wrap? If so, wrap before
+     ;; it's too late.
+     ((= xpos width)
+      (setf (char dest (1- width)) *line-wrap-char*)
+      (update-and-punt dis-line width nil 0 index))
+     (t
+      (display-losing-chars line-chars index end dest xpos width string
+			    underhang u-vec-get-rep)))))
+
+;;; compute-cached-line-image  --  Internal
+;;;
+;;;    Like compute-normal-line-image, only works on the cached line.
+;;;
+(defun compute-cached-line-image (index dis-line xpos width)
+  (declare (fixnum start xpos width))
+  (prog ((gap (- right-open-pos left-open-pos))
+	 (dest (dis-line-chars dis-line))
+	 (done-p (= right-open-pos line-cache-length))
+	 losing string underhang)
+    (declare (fixnum index gap losing) (simple-string dest))
+   LEFT-LOOP
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang index))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ((>= index left-open-pos)
+      (go RIGHT-START)))
+    (setq losing (%fcwa open-chars index left-open-pos losing-char))
+    (cond
+     (losing
+      (display-some-chars open-chars index losing dest xpos width nil)
+      ;; If we we didn't wrap then display some losers...
+      (if xpos
+	  (display-losing-chars open-chars index left-open-pos dest xpos
+				width string underhang string-get-rep
+				(and done-p (= index left-open-pos)))
+	  (update-and-punt dis-line width nil 0 index)))
+     (t
+      (display-some-chars open-chars index left-open-pos dest xpos width done-p)))
+    (go LEFT-LOOP)
+
+   RIGHT-START
+    (setq index (+ index gap))
+   RIGHT-LOOP
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang (- index gap)))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 (- index gap)))
+     ((= index line-cache-length)
+      (update-and-punt dis-line xpos nil nil (- index gap))))
+    (setq losing (%fcwa open-chars index line-cache-length losing-char))
+    (cond
+     (losing
+      (display-some-chars open-chars index losing dest xpos width nil)
+      (cond
+       ;; Did we wrap?
+       ((null xpos)
+	(update-and-punt dis-line width nil 0 (- index gap)))
+       (t
+	(display-losing-chars open-chars index line-cache-length dest xpos
+			      width string underhang string-get-rep))))
+     (t
+      (display-some-chars open-chars index line-cache-length dest xpos width t)))
+    (go RIGHT-LOOP))) 
+
+(defun make-some-font-changes ()
+  (do ((res nil (make-font-change res))
+       (i 42 (1- i)))
+      ((zerop i) res)))
+
+(defvar *free-font-changes* (make-some-font-changes)
+  "Font-Change structures that nobody's using at the moment.")
+
+(defmacro alloc-font-change (x font mark)
+  `(progn
+    (unless *free-font-changes*
+      (setq *free-font-changes* (make-some-font-changes)))
+    (let ((new-fc *free-font-changes*))
+      (setq *free-font-changes* (font-change-next new-fc))
+      (setf (font-change-x new-fc) ,x
+	    (font-change-font new-fc) ,font
+	    (font-change-next new-fc) nil
+	    (font-change-mark new-fc) ,mark)
+      new-fc)))
+		     
+;;;
+;;; compute-line-image  --  Internal
+;;;
+;;;    This function builds a full line image from some characters in
+;;; a line and from some characters which may be left over from the previous
+;;; line.
+;;;
+;;; Parameters:
+;;;    String - This is the string which contains the characters left over
+;;; from the previous line.  This is NIL if there are none.
+;;;    Underhang - Characters from here to the end of String are put at the
+;;; beginning of the line image.
+;;;    Line - This is the line to display characters from.
+;;;    Offset - This is the index of the first character to display in Line.
+;;;    Dis-Line - This is the dis-line to put the line-image in.  The only
+;;; slots affected are the chars and the length.
+;;;    Width - This is the width of the field to display in.
+;;;
+;;; Three values are returned:
+;;;    1) The new overhang string, if none this is NIL.
+;;;    2) The new underhang, if this is NIL then the entire line was
+;;; displayed.  If the entire line was not displayed, but there was no
+;;; underhang, then this is 0.
+;;;    3) The index in line after the last character displayed.
+;;;
+(defun compute-line-image (string underhang line offset dis-line width)
+  ;;
+  ;; Release any old font-changes.
+  (let ((changes (dis-line-font-changes dis-line)))
+    (when changes
+      (do ((prev changes current)
+	   (current (font-change-next changes)
+		    (font-change-next current)))
+	  ((null current)
+	   (setf (dis-line-font-changes dis-line) nil)
+	   (shiftf (font-change-next prev) *free-font-changes* changes))
+	(setf (font-change-mark current) nil))))
+  ;;
+  ;; If the line has any Font-Marks, add Font-Changes for them.
+  (let ((marks (line-marks line)))
+    (when (dolist (m marks nil)
+	    (when (fast-font-mark-p m) (return t)))
+      (let ((prev nil))
+	;;
+	;; Find the last Font-Mark with charpos less than Offset.  If there is
+	;; such a Font-Mark, then there is a font-change to this font at X = 0.
+	(let ((max -1)
+	      (max-mark nil))
+	  (dolist (m marks)
+	    (when (fast-font-mark-p m)
+	      (let ((charpos (mark-charpos m)))
+		(when (and (< charpos offset) (> charpos max))
+		  (setq max charpos  max-mark m)))))
+	  (when max-mark
+	    (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
+	    (setf (dis-line-font-changes dis-line) prev)))
+	;;
+	;; Repeatedly scan through marks, adding a font-change for the
+	;; smallest Font-Mark with a charpos greater than Bound, until
+	;; we find no such mark.
+	(do ((bound (1- offset) min)
+	     (min most-positive-fixnum most-positive-fixnum)
+	     (min-mark nil nil))
+	    (())
+	  (dolist (m marks)
+	    (when (fast-font-mark-p m)
+	      (let ((charpos (mark-charpos m)))
+		(when (and (> charpos bound) (< charpos min))
+		  (setq min charpos  min-mark m)))))
+	  (unless min-mark (return nil))
+	  (let ((len (if (eq line open-line)
+			 (cached-real-line-length line 10000 offset min)
+			 (real-line-length line 10000 offset min))))
+	    (when (< len width)
+	      (let ((new (alloc-font-change
+			  (+ len
+			     (if string
+				 (- (length (the simple-string string)) underhang)
+				 0))
+			  (font-mark-font min-mark)
+			  min-mark)))
+		(if prev
+		    (setf (font-change-next prev) new)
+		    (setf (dis-line-font-changes dis-line) new))
+		(setq prev new))))))))
+  ;;
+  ;; Recompute the line image.
+  (cond
+   (string
+    (let ((len (strlen string))
+	  (chars (dis-line-chars dis-line))
+	  (xpos 0))
+      (declare (fixnum xpos len) (simple-string chars))
+      (display-some-chars string underhang len chars xpos width nil)
+      (cond
+       ((null xpos)
+	(values string underhang offset))	   
+       ((eq line open-line)
+	(compute-cached-line-image offset dis-line xpos width))
+       #+Buffered-Lines
+       ((line-buffered-p line)
+	(compute-buffered-line-image line offset dis-line xpos width))
+       (t
+ 	(compute-normal-line-image line offset dis-line xpos width)))))
+   ((eq line open-line)
+    (compute-cached-line-image offset dis-line 0 width))
+   #+Buffered-Lines
+   ((line-buffered-p line)
+    (compute-buffered-line-image line offset dis-line 0 width))
+   (t
+    (compute-normal-line-image line offset dis-line 0 width))))
diff --git a/hemlock/lispbuf.lisp b/hemlock/lispbuf.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3def78bff75313afcc7b4d54ba4ca71c4b7785ed
--- /dev/null
+++ b/hemlock/lispbuf.lisp
@@ -0,0 +1,766 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Stuff to do a little lisp hacking in the editor's Lisp environment.
+;;;
+
+(in-package "HEMLOCK")
+
+
+(defmacro in-lisp (&body body)
+  "Evaluates body inside HANDLE-LISP-ERRORS.  *package* is bound to the package
+   named by \"Current Package\" if it is non-nil."
+  (let ((name (gensym)) (package (gensym)))
+    `(handle-lisp-errors
+      (let* ((,name (value current-package))
+	     (,package (and ,name (find-package ,name))))
+	(progv (if ,package '(*package*)) (if ,package (list ,package))
+	  ,@body)))))
+
+
+(define-file-option "Package" (buffer value)
+  (defhvar "Current Package"
+    "The package used for evaluation of Lisp in this buffer."
+    :buffer buffer
+    :value
+    (let* ((eof (list nil))
+	   (thing (read-from-string value nil eof)))
+      (when (eq thing eof) (error "Bad package file option value."))
+      (cond
+       ((stringp thing)
+	thing)
+       ((symbolp thing)
+	(symbol-name thing))
+       ((and (characterp thing) (string-char-p thing))
+	(string thing))
+       (t
+	(message
+	 "Ignoring \"package\" file option -- cannot convert to a string."))))))
+
+
+;;;; Eval Mode Interaction.
+
+(proclaim '(special * ** *** - + ++ +++ / // /// *prompt*))
+
+(defun setup-eval-mode (buffer)
+  (let ((point (buffer-point buffer)))
+    (setf (buffer-minor-mode buffer "Eval") t)
+    (setf (buffer-minor-mode buffer "Editor") t)
+    (setf (buffer-major-mode buffer) "Lisp")
+    (buffer-end point)
+    (defhvar "Current Package"
+      "This variable holds the name of the package currently used for Lisp
+       evaluation and compilation.  If it is Nil, the value of *Package* is used
+       instead."
+      :value nil
+      :buffer buffer)
+    (unless (hemlock-bound-p 'buffer-input-mark :buffer buffer)
+      (defhvar "Buffer Input Mark"
+	"Mark used for Eval Mode input."
+	:buffer buffer
+	:value (copy-mark point :right-inserting))
+      (defhvar "Eval Output Stream"
+	"Output stream used for Eval Mode output in this buffer."
+	:buffer buffer
+	:value (make-hemlock-output-stream point))
+      (defhvar "Interactive History"
+	"A ring of the regions input to an interactive mode (Eval or Typescript)."
+	:buffer buffer
+	:value (make-ring (value interactive-history-length)))
+      (defhvar "Interactive Pointer"
+	"Pointer into \"Interactive History\"."
+	:buffer buffer
+	:value 0)
+      (defhvar "Searching Interactive Pointer"
+	"Pointer into \"Interactive History\"."
+	:buffer buffer
+	:value 0))
+    (let ((*standard-output*
+	   (variable-value 'eval-output-stream :buffer buffer)))
+      (fresh-line)
+      (princ (if (functionp *prompt*)
+		 (funcall *prompt*)
+		 *prompt*)))
+    (move-mark (variable-value 'buffer-input-mark :buffer buffer) point)))
+
+(defmode "Eval" :major-p nil :setup-function #'setup-eval-mode)
+
+(defun eval-mode-lisp-mode-hook (buffer on)
+  "Turn on Lisp mode when we go into Eval Mode."
+  (when on
+    (setf (buffer-major-mode buffer) "Lisp")))
+;;;
+(add-hook eval-mode-hook 'eval-mode-lisp-mode-hook)
+
+(defhvar "Editor Definition Info"
+  "When this is non-nil, the editor Lisp is used to determine definition
+   editing information; otherwise, the slave Lisp is used."
+  :value t
+  :mode "Eval")
+
+
+(defvar *selected-eval-buffer* nil)
+
+(defcommand "Select Eval Buffer" (p)
+  "Goto buffer in \"Eval\" mode, creating one if necessary."
+  "Goto buffer in \"Eval\" mode, creating one if necessary."
+  (declare (ignore p))
+  (unless *selected-eval-buffer*
+    (when (getstring "Eval" *buffer-names*)
+      (editor-error "There is already a buffer named \"Eval\"!"))
+    (setf *selected-eval-buffer*
+	  (make-buffer "Eval"
+		       :delete-hook
+		       (list #'(lambda (buf)
+				 (declare (ignore buf))
+				 (setf *selected-eval-buffer* nil)))))
+    (setf (buffer-minor-mode *selected-eval-buffer* "Eval") t))
+  (change-to-buffer *selected-eval-buffer*))
+
+
+(defvar lispbuf-eof '(nil))
+
+(defhvar "Unwedge Interactive Input Confirm"
+  "When set (the default), trying to confirm interactive input when the
+   point is not after the input mark causes Hemlock to ask the user if he
+   needs to be unwedged.  When not set, an editor error is signaled
+   informing the user that the point is before the input mark."
+  :value t)
+
+(defun unwedge-eval-buffer ()
+  (abort-eval-input-command nil))
+
+(defhvar "Unwedge Interactive Input Fun"
+  "Function to call when input is confirmed, but the point is not past the
+   input mark."
+  :value #'unwedge-eval-buffer
+  :mode "Eval")
+
+(defhvar "Unwedge Interactive Input String"
+  "String to add to \"Point not past input mark.  \" explaining what will
+   happen if the the user chooses to be unwedged."
+  :value "Prompt again at the end of the buffer? "
+  :mode "Eval")
+
+(defcommand "Confirm Eval Input" (p)
+  "Evaluate Eval Mode input between point and last prompt."
+  "Evaluate Eval Mode input between point and last prompt."
+  (declare (ignore p))
+  (let ((input-region (get-interactive-input)))
+    (when input-region
+      (let* ((output (value eval-output-stream))
+	     (*standard-output* output)
+	     (*error-output* output)
+	     (*trace-output* output))
+	(fresh-line)
+	(in-lisp
+	 ;; Copy the region to keep the output and input streams from interacting
+	 ;; since input-region is made of permanent marks into the buffer.
+	 (with-input-from-region (stream (copy-region input-region))
+	   (loop
+	     (let ((form (read stream nil lispbuf-eof)))
+	       (when (eq form lispbuf-eof)
+		 ;; Move the buffer's input mark to the end of the buffer.
+		 (move-mark (region-start input-region)
+			    (region-end input-region))
+		 (return))
+	       (setq +++ ++ ++ + + - - form)
+	       (let ((this-eval (multiple-value-list (eval form))))
+		 (fresh-line)
+		 (dolist (x this-eval) (prin1 x) (terpri))
+		 (princ (if (functionp *prompt*)
+			    (funcall *prompt*)
+			    *prompt*))
+		 (setq /// // // / / this-eval)
+		 (setq *** ** ** * * (car this-eval)))))))))))
+
+(defcommand "Abort Eval Input" (p)
+  "Move to the end of the buffer and prompt."
+  "Move to the end of the buffer and prompt."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (buffer-end point)
+    (insert-character point #\newline)
+    (insert-string point "Aborted.")
+    (insert-character point #\newline)
+    (insert-string point
+		   (if (functionp *prompt*)
+		       (funcall *prompt*)
+		       *prompt*))
+    (move-mark (value buffer-input-mark) point)))
+
+
+
+;;;; General interactive commands used in eval and typescript buffers.
+
+(defun get-interactive-input ()
+  "Tries to return a region.  When the point is not past the input mark, and
+   the user has \"Unwedge Interactive Input Confirm\" set, the buffer is
+   optionally fixed up, and nil is returned.  Otherwise, an editor error is
+   signalled.  When a region is returned, the start is the current buffer's
+   input mark, and the end is the current point moved to the end of the buffer."
+  (let ((point (current-point))
+	(mark (value buffer-input-mark)))
+    (cond
+     ((mark>= point mark)
+      (buffer-end point)
+      (let* ((input-region (region mark point))
+	     (string (region-to-string input-region))
+	     (ring (value interactive-history)))
+	(when (and (or (zerop (ring-length ring))
+		       (string/= string (region-to-string (ring-ref ring 0))))
+		   (> (length string) (value minimum-interactive-input-length)))
+	  (ring-push (copy-region input-region) ring))
+	input-region))
+     ((value unwedge-interactive-input-confirm)
+      (beep)
+      (when (prompt-for-y-or-n
+	     :prompt (concatenate 'simple-string
+				  "Point not past input mark.  "
+				  (value unwedge-interactive-input-string))
+	     :must-exist t :default t :default-string "yes")
+	(funcall (value unwedge-interactive-input-fun))
+	(message "Unwedged."))
+      nil)
+     (t
+      (editor-error "Point not past input mark.")))))
+
+(defhvar "Interactive History Length"
+  "This is the length used for the history ring in interactive buffers.
+   It must be set before turning on the mode."
+  :value 10)
+
+(defhvar "Minimum Interactive Input Length"
+  "When the number of characters in an interactive buffer exceeds this value,
+   it is pushed onto the interactive history, otherwise it is lost forever."
+  :value 2)
+
+
+(defvar *previous-input-search-string* "ignore")
+
+(defvar *previous-input-search-pattern*
+  ;; Give it a bogus string since you can't give it the empty string.
+  (new-search-pattern :string-insensitive :forward "ignore"))
+
+(defun get-previous-input-search-pattern (string)
+  (if (string= *previous-input-search-string* string)
+      *previous-input-search-pattern*
+      (new-search-pattern :string-insensitive :forward 
+			  (setf *previous-input-search-string* string)
+			  *previous-input-search-pattern*)))
+
+(defcommand "Search Previous Interactive Input" (p)
+  "Search backward through the interactive history using the current input as
+   a search string.  Consecutive invocations repeat the previous search."
+  "Search backward through the interactive history using the current input as
+   a search string.  Consecutive invocations repeat the previous search."
+  (declare (ignore p))
+  (let* ((mark (value buffer-input-mark))
+	 (ring (value interactive-history))
+	 (point (current-point))
+	 (just-invoked (eq (last-command-type) :searching-interactive-input)))
+    (when (mark<= point mark)
+      (editor-error "Point not past input mark."))
+    (when (zerop (ring-length ring))
+      (editor-error "No previous input in this buffer."))
+    (unless just-invoked
+      (get-previous-input-search-pattern (region-to-string (region mark point))))
+    (let ((found-it (find-previous-input ring just-invoked)))
+      (unless found-it 
+	(editor-error "Couldn't find ~a." *previous-input-search-string*))
+      (delete-region (region mark point))
+      (insert-region point (ring-ref ring found-it))
+      (setf (value searching-interactive-pointer) found-it))
+  (setf (last-command-type) :searching-interactive-input)))
+
+(defun find-previous-input (ring againp)
+  (let ((ring-length (ring-length ring))
+	(base (if againp
+		  (+ (value searching-interactive-pointer) 1)
+		  0)))
+      (loop
+	(when (= base ring-length)
+	  (if againp
+	      (setf base 0)
+	      (return nil)))
+	(with-mark ((m (region-start (ring-ref ring base))))
+	  (when (find-pattern m *previous-input-search-pattern*)
+	    (return base)))
+	(incf base))))
+
+(defcommand "Previous Interactive Input" (p)
+  "Insert the previous input in an interactive mode (Eval or Typescript).
+   If repeated, keep rotating the history.  With prefix argument, rotate
+   that many times."
+  "Pop the *interactive-history* at the point."
+  (let* ((point (current-point))
+	 (mark (value buffer-input-mark))
+	 (ring (value interactive-history))
+	 (length (ring-length ring))
+	 (p (or p 1)))
+    (declare (simple-string current))
+    (when (or (mark< point mark) (zerop length)) (editor-error))
+    (cond
+     ((eq (last-command-type) :interactive-history)
+      (let ((base (mod (+ (value interactive-pointer) p) length)))
+	(delete-region (region mark point))
+	(insert-region point (ring-ref ring base))
+	(setf (value interactive-pointer) base)))
+     (t
+      (let ((base (mod (if (minusp p) p (1- p)) length))
+	    (region (delete-and-save-region (region mark point))))
+	(insert-region point (ring-ref ring base))
+	(when (mark/= (region-start region) (region-end region))
+	  (ring-push region ring)
+	  (incf base))
+	(setf (value interactive-pointer) base)))))
+  (setf (last-command-type) :interactive-history))
+
+(defcommand "Next Interactive Input" (p)
+  "Rotate the interactive history backwards.  The region is left around the
+   inserted text.  With prefix argument, rotate that many times."
+  "Call previous-interactive-input-command with negated arg."
+  (previous-interactive-input-command (- (or p 1))))
+
+(defcommand "Kill Interactive Input" (p)
+  "Kill any input to an interactive mode (Eval or Typescript)."
+  "Kill any input to an interactive mode (Eval or Typescript)."
+  (declare (ignore p))
+  (let ((point (buffer-point (current-buffer)))
+	(mark (value buffer-input-mark)))
+    (when (mark< point mark) (editor-error))
+    (kill-region (region mark point) :kill-backward)))
+
+(defcommand "Interactive Beginning of Line" (p)
+  "If on line with current prompt, go to after it, otherwise do what
+  \"Beginning of Line\" always does."
+  "Go to after prompt when on prompt line."
+  (let ((mark (value buffer-input-mark))
+	(point (current-point)))
+    (if (and (same-line-p point mark) (or (not p) (= p 1)))
+	(move-mark point mark)
+	(beginning-of-line-command p))))
+
+(defcommand "Reenter Interactive Input" (p)
+  "Copies the form to the left of point to be after the interactive buffer's
+   input mark.  When the current region is active, it is copied instead."
+  "Copies the form to the left of point to be after the interactive buffer's
+   input mark.  When the current region is active, it is copied instead."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'buffer-input-mark)
+    (editor-error "Not in an interactive buffer."))
+  (let ((point (current-point)))
+    (let ((region (if (region-active-p)
+		      ;; Copy this, so moving point doesn't affect the region.
+		      (copy-region (current-region))
+		      (with-mark ((start point)
+				  (end point))
+			(pre-command-parse-check start)
+			(unless (form-offset start -1)
+			  (editor-error "Not after complete form."))
+			(region (copy-mark start) (copy-mark end))))))
+      (buffer-end point)
+      (push-buffer-mark (copy-mark point))
+      (insert-region point region)
+      (setf (last-command-type) :ephemerally-active))))
+
+
+
+;;; Other stuff.
+
+(defmode "Editor")
+
+(defcommand "Editor Mode" (p)
+  "Turn on \"Editor\" mode in the current buffer.  If it is already on, turn it
+  off.  When in editor mode, most lisp compilation and evaluation commands
+  manipulate the editor process instead of the current eval server."
+  "Toggle \"Editor\" mode in the current buffer."
+  (declare (ignore p))
+  (setf (buffer-minor-mode (current-buffer) "Editor")
+	(not (buffer-minor-mode (current-buffer) "Editor"))))
+
+(define-file-option "Editor" (buffer value)
+  (declare (ignore value))
+  (setf (buffer-minor-mode buffer "Editor") t))
+
+(defhvar "Editor Definition Info"
+  "When this is non-nil, the editor Lisp is used to determine definition
+   editing information; otherwise, the slave Lisp is used."
+  :value t
+  :mode "Editor")
+
+(defcommand "Editor Compile Defun" (p)
+  "Compiles the current or next top-level form in the editor Lisp.
+   First the form is evaluated, then the result of this evaluation
+   is passed to compile.  If the current region is active, this
+   compiles the region."
+  "Evaluates the current or next top-level form in the editor Lisp."
+  (declare (ignore p))
+  (if (region-active-p)
+      (editor-compile-region (current-region))
+      (editor-compile-region (defun-region (current-point)) t)))
+
+(defcommand "Editor Compile Region" (p)
+  "Compiles lisp forms between the point and the mark in the editor Lisp."
+  "Compiles lisp forms between the point and the mark in the editor Lisp."
+  (declare (ignore p))
+  (editor-compile-region (current-region)))
+
+(defun defun-region (mark)
+  "This returns a region around the current or next defun with respect to mark.
+   Mark is not used to form the region.  If there is no appropriate top level
+   form, this signals an editor-error.  This calls PRE-COMMAND-PARSE-CHECK."
+  (with-mark ((start mark)
+	      (end mark))
+    (pre-command-parse-check start)
+    (cond ((not (mark-top-level-form start end))
+	   (editor-error "No current or next top level form."))
+	  (t (region start end)))))
+
+(defun editor-compile-region (region &optional quiet)
+  (unless quiet (message "Compiling region ..."))
+  (in-lisp
+   (with-input-from-region (stream region)
+     (with-pop-up-display (*error-output* :height 19)
+       (compile-from-stream stream
+			    :defined-from-pathname
+			    (buffer-pathname (current-buffer)))))))
+
+
+(defcommand "Editor Evaluate Defun" (p)
+  "Evaluates the current or next top-level form in the editor Lisp.
+   If the current region is active, this evaluates the region."
+  "Evaluates the current or next top-level form in the editor Lisp."
+  (declare (ignore p))
+  (if (region-active-p)
+      (editor-evaluate-region-command nil)
+      (with-input-from-region (stream (defun-region (current-point)))
+	(clear-echo-area)
+	(in-lisp
+	 (message "Editor Evaluation returned ~S"
+		  (eval (read stream)))))))
+
+(defcommand "Editor Evaluate Region" (p)
+  "Evaluates lisp forms between the point and the mark in the editor Lisp."
+  "Evaluates lisp forms between the point and the mark in the editor Lisp."
+  (declare (ignore p))
+  (with-input-from-region (stream (current-region))
+    (clear-echo-area)
+    (write-string "Evaluating region in the editor ..." *echo-area-stream*)
+    (finish-output *echo-area-stream*)
+    (in-lisp
+     (do ((object (read stream nil lispbuf-eof) 
+		  (read stream nil lispbuf-eof)))
+	 ((eq object lispbuf-eof))
+       (eval object)))
+    (message "Evaluation complete.")))
+           
+(defcommand "Editor Re-evaluate Defvar" (p)
+  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
+   form as if the variable is not bound.  This occurs in the editor Lisp."
+  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
+   form as if the variable is not bound.  This occurs in the editor Lisp."
+  (declare (ignore p))
+  (with-input-from-region (stream (defun-region (current-point)))
+    (clear-echo-area)
+    (in-lisp
+     (let ((form (read stream)))
+       (unless (eq (car form) 'defvar) (editor-error "Not a DEFVAR."))
+       (makunbound (cadr form))
+       (message "Evaluation returned ~S" (eval form))))))
+
+(defcommand "Editor Macroexpand Expression" (p)
+  "Show the macroexpansion of the current expression in the null environment.
+   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
+  "Show the macroexpansion of the current expression in the null environment.
+   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
+  (let ((point (buffer-point (current-buffer))))
+    (with-mark ((start point))
+      (pre-command-parse-check start)
+      (with-mark ((end start))
+        (unless (form-offset end 1) (editor-error))
+	(in-lisp
+	 (with-pop-up-display (rts)
+	   (write-string (with-input-from-region (s (region start end))
+			   (prin1-to-string (funcall (if p
+							 'macroexpand
+							 'macroexpand-1)
+						     (read s))))
+			 rts)))))))
+
+(defcommand "Editor Evaluate Expression" (p)
+  "Prompt for an expression to evaluate in the editor Lisp."
+  "Prompt for an expression to evaluate in the editor Lisp."
+  (declare (ignore p))
+  (in-lisp
+   (multiple-value-call #'message "=> ~@{~#[~;~S~:;~S, ~]~}"
+     (eval (prompt-for-expression
+	    :prompt "Editor Eval: "
+	    :help "Expression to evaluate")))))
+
+(defcommand "Editor Evaluate Buffer" (p)
+  "Evaluates the text in the current buffer in the editor Lisp."
+  "Evaluates the text in the current buffer redirecting *Standard-Output* to
+   the echo area.  This occurs in the editor Lisp.  The prefix argument is
+   ignored."
+  (declare (ignore p))
+  (clear-echo-area)
+  (write-string "Evaluating buffer in the editor ..." *echo-area-stream*)
+  (finish-output *echo-area-stream*)
+  (with-input-from-region (stream (buffer-region (current-buffer)))
+    (let ((*standard-output* *echo-area-stream*))
+      (in-lisp
+       (do ((object (read stream nil lispbuf-eof) 
+		    (read stream nil lispbuf-eof)))
+	   ((eq object lispbuf-eof))
+	 (eval object))))
+    (message "Evaluation complete.")))
+
+
+
+;;; With-Output-To-Window  --  Internal
+;;;
+;;;
+(defmacro with-output-to-window ((stream name) &body forms)
+  "With-Output-To-Window (Stream Name) {Form}*
+  Bind Stream to a stream that writes into the buffer named Name a la
+  With-Output-To-Mark.  The buffer is created if it does not exist already
+  and a window is created to display the buffer if it is not displayed.
+  For the duration of the evaluation this window is made the current window."
+  (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) 
+	(window (gensym)) (old-window (gensym)))
+    `(let* ((,nam ,name)
+	    (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam)))
+	    (,point (buffer-end (buffer-point ,buffer)))
+	    (,window (or (car (buffer-windows ,buffer)) (make-window ,point)))
+	    (,old-window (current-window)))
+       (unwind-protect
+	 (progn (setf (current-window) ,window)
+		(buffer-end ,point)
+		(with-output-to-mark (,stream ,point) ,@forms))
+	 (setf (current-window) ,old-window)))))
+
+(defcommand "Editor Compile File" (p)
+  "Prompts for file to compile in the editor Lisp.  Does not compare source
+   and binary write dates.  Does not check any buffer for that file for
+   whether the buffer needs to be saved."
+  "Prompts for file to compile."
+  (declare (ignore p))
+  (let ((pn (prompt-for-file :default
+			     (buffer-default-pathname (current-buffer))
+			     :prompt "File to compile: ")))
+    (with-output-to-window (*error-output* "Compiler Warnings")
+      (in-lisp (compile-file (namestring pn) :error-file nil)))))
+
+(defcommand "Editor Compile Buffer File" (p)
+  "Compile the file in the current buffer in the editor Lisp if its associated
+   binary file (of type .fasl) is older than the source or doesn't exist.  When
+   the binary file is up to date, the user is asked if the source should be
+   compiled anyway.  When the prefix argument is supplied, compile the file
+   without checking the binary file.  When \"Compile Buffer File Confirm\" is
+   set, this command will ask for confirmation when it otherwise would not."
+  "Compile the file in the current buffer in the editor Lisp if the fasl file
+   isn't up to date.  When p, always do it."
+  (let* ((buf (current-buffer))
+	 (pn (buffer-pathname buf)))
+    (unless pn (editor-error "Buffer has no associated pathname."))
+    (cond ((buffer-modified buf)
+	   (when (or (not (value compile-buffer-file-confirm))
+		     (prompt-for-y-or-n
+		      :default t :default-string "Y"
+		      :prompt (list "Save and compile file ~A? "
+				    (namestring pn))))
+	     (write-buffer-file buf pn)
+	     (with-output-to-window (*error-output* "Compiler Warnings")
+	       (in-lisp (compile-file (namestring pn) :error-file nil)))))
+	  ((older-or-non-existent-fasl-p pn p)
+	   (when (or (not (value compile-buffer-file-confirm))
+		     (prompt-for-y-or-n
+		      :default t :default-string "Y"
+		      :prompt (list "Compile file ~A? " (namestring pn))))
+	     (with-output-to-window (*error-output* "Compiler Warnings")
+	       (in-lisp (compile-file (namestring pn) :error-file nil)))))
+	  (t (when (or p
+		       (prompt-for-y-or-n
+			:default t :default-string "Y"
+			:prompt
+			"Fasl file up to date, compile source anyway? "))
+	       (with-output-to-window (*error-output* "Compiler Warnings")
+		 (in-lisp (compile-file (namestring pn) :error-file nil))))))))
+
+(defcommand "Editor Compile Group" (p)
+  "Compile each file in the current group which needs it in the editor Lisp.
+   If a file has type LISP and there is a curresponding file with type
+   FASL which has been written less recently (or it doesn't exit), then
+   the file is compiled, with error output directed to the \"Compiler Warnings\"
+   buffer.  If a prefix argument is provided, then all the files are compiled.
+   All modified files are saved beforehand."
+  "Do a Compile-File in each file in the current group that seems to need it
+   in the editor Lisp."
+  (save-all-files-command ())
+  (unless *active-file-group* (editor-error "No active file group."))
+  (dolist (file *active-file-group*)
+    (when (string-equal (pathname-type file) "lisp")
+      (let ((tn (probe-file file)))
+	(cond ((not tn)
+	       (message "File ~A not found." (namestring file)))
+	      ((older-or-non-existent-fasl-p tn p)
+	       (with-output-to-window (*error-output* "Compiler Warnings")
+		 (in-lisp (compile-file (namestring tn) :error-file nil)))))))))
+
+(defcommand "List Compile Group" (p)
+  "List any files that would be compiled by \"Compile Group\".  All Modified
+   files are saved before checking to generate a consistent list."
+  "Do a Compile-File in each file in the current group that seems to need it."
+  (declare (ignore p))
+  (save-all-files-command ())
+  (unless *active-file-group* (editor-error "No active file group."))
+  (with-pop-up-display (s)
+    (write-line "\"Compile Group\" would compile the following files:" s)
+    (force-output s)
+    (dolist (file *active-file-group*)
+      (when (string-equal (pathname-type file) "lisp")
+	(let ((tn (probe-file file)))
+	  (cond ((not tn)
+		 (format s "File ~A not found.~%" (namestring file)))
+		((older-or-non-existent-fasl-p tn)
+		 (write-line (namestring tn) s)))
+	  (force-output s))))))
+
+(defhvar "Load Pathname Defaults"
+  "The default pathname used by the load command.")
+
+(defcommand "Editor Load File" (p)
+  "Prompt for a file to load into Editor Lisp."
+  "Prompt for a file to load into the Editor Lisp."
+  (declare (ignore p))
+  (let ((name (truename (prompt-for-file
+			 :default
+			 (or (value load-pathname-defaults)
+			     (buffer-default-pathname (current-buffer)))
+			 :prompt "Editor file to load: "
+			 :help "The name of the file to load"))))
+    (setv load-pathname-defaults name)
+    (in-lisp (load name))))
+
+
+
+;;;; Lisp documentation stuff.
+
+;;; FUNCTION-TO-DESCRIBE is used in "Editor Describe Function Call" and
+;;; "Describe Function Call".
+;;;
+(defmacro function-to-describe (var error-name)
+  `(cond ((not (symbolp ,var))
+	  (,error-name "~S is not a symbol." ,var))
+	 ((macro-function ,var))
+	 ((fboundp ,var)
+	  (if (listp (symbol-function ,var))
+	      ,var
+	      (symbol-function ,var)))
+	 (t
+	  (,error-name "~S is not a function." ,var))))
+
+(defcommand "Editor Describe Function Call" (p)
+  "Describe the most recently typed function name in the editor Lisp."
+  "Describe the most recently typed function name in the editor Lisp."
+  (declare (ignore p))
+  (with-mark ((mark1 (current-point))
+	      (mark2 (current-point)))
+    (pre-command-parse-check mark1)
+    (unless (backward-up-list mark1) (editor-error))
+    (form-offset (move-mark mark2 (mark-after mark1)) 1)
+    (with-input-from-region (s (region mark1 mark2))
+      (in-lisp
+       (let* ((sym (read s))
+	      (fun (function-to-describe sym editor-error)))
+	 (with-pop-up-display (*standard-output*)
+	   (editor-describe-function fun sym)))))))
+
+
+(defcommand "Editor Describe Symbol" (p)
+  "Describe the previous s-expression if it is a symbol in the editor Lisp."
+  "Describe the previous s-expression if it is a symbol in the editor Lisp."
+  (declare (ignore p))
+  (with-mark ((mark1 (current-point))
+	      (mark2 (current-point)))
+    (mark-symbol mark1 mark2)
+    (with-input-from-region (s (region mark1 mark2))
+      (in-lisp
+       (let ((thing (read s)))
+	 (if (symbolp thing)
+	     (with-pop-up-display (*standard-output*)
+	       (describe thing))
+	     (if (and (consp thing)
+		      (or (eq (car thing) 'quote)
+			  (eq (car thing) 'function))
+		      (symbolp (cadr thing)))
+		 (with-pop-up-display (*standard-output*)
+		   (describe (cadr thing)))
+		 (editor-error "~S is not a symbol, or 'symbol, or #'symbol."
+			       thing))))))))
+
+;;; MARK-SYMBOL moves mark1 and mark2 around the previous or current symbol.
+;;; However, if the marks are immediately before the first constituent char
+;;; of the symbol name, we use the next symbol since the marks probably
+;;; correspond to the point, and Hemlock's cursor display makes it look like
+;;; the point is within the symbol name.  This also tries to ignore :prefix
+;;; characters such as quotes, commas, etc.
+;;;
+(defun mark-symbol (mark1 mark2)
+  (pre-command-parse-check mark1)
+  (with-mark ((tmark1 mark1)
+	      (tmark2 mark1))
+    (cond ((and (form-offset tmark1 1)
+		(form-offset (move-mark tmark2 tmark1) -1)
+		(or (mark= mark1 tmark2)
+		    (and (find-attribute tmark2 :lisp-syntax
+					 #'(lambda (x) (not (eq x :prefix))))
+			 (mark= mark1 tmark2))))
+	   (form-offset mark2 1))
+	  (t
+	   (form-offset mark1 -1)
+	   (find-attribute mark1 :lisp-syntax
+			   #'(lambda (x) (not (eq x :prefix))))
+	   (form-offset (move-mark mark2 mark1) 1)))))
+
+
+(defcommand "Editor Describe" (p)
+  "Call Describe on a Lisp object.
+  Prompt for an expression which is evaluated to yield the object."
+  "Prompt for an object to describe."
+  (declare (ignore p))
+  (in-lisp
+   (let* ((exp (prompt-for-expression
+		:prompt "Object: "
+		:help "Expression to evaluate to get object to describe."))
+	  (obj (eval exp)))
+     (with-pop-up-display (*standard-output*)
+       (describe obj)))))
+
+(defcommand "Filter Region" (p)
+  "Apply a Lisp function to each line of the region.
+  An expression is prompted for which should evaluate to a Lisp function
+  from a string to a string.  The function must neither modify its argument
+  nor modify the return value after it is returned."
+  "Call prompt for a function, then call Filter-Region with it and the region."
+  (declare (ignore p))
+  (let* ((exp (prompt-for-expression
+	       :prompt "Function: "
+	       :help "Expression to evaluate to get function to use as filter."))
+	 (fun (in-lisp (eval exp)))
+	 (region (current-region)))
+    (check-region-query-size region)
+    (let* ((start (copy-mark (region-start region) :left-inserting))
+	   (end (copy-mark (region-end region) :left-inserting))
+	   (region (region start end))
+	   (undo-region (copy-region region)))
+      (filter-region fun region)
+      (make-region-undo :twiddle "Filter Region" region undo-region))))
diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3d27b6652a4ae4b5d92fc835c9f6ad8463ca8970
--- /dev/null
+++ b/hemlock/lispeval.lisp
@@ -0,0 +1,974 @@
+;;; -*- Package: Hemlock; Log: hemlock.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; This file contains code for sending requests to eval servers and the
+;;; commands based on that code.
+;;;
+;;; Written by William Lott and Rob MacLachlan.
+;;;
+
+(in-package "HEMLOCK")
+
+
+;;; The note structure holds everything we need to know about an
+;;; operation.  Not all operations use all the available fields.
+;;;
+(defstruct (note (:print-function %print-note))
+  (state :unsent)	      ; :unsent, :pending, :running, :aborted or :dead.
+  server		      ; Server-Info for the server this op is on.
+  context		      ; Short string describing what this op is doing.
+  kind			      ; Either :eval, :compile, or :compile-file
+  buffer		      ; Buffer source came from.
+  region		      ; Region of request
+  package		      ; Package or NIL if none
+  text			      ; string containing request
+  input-file		      ; File to compile or where stuff was found
+  net-input-file	      ; Net version of above.
+  output-file		      ; Temporary output file for compiler fasl code.
+  net-output-file	      ; Net version of above
+  output-date		      ; Temp-file is created before calling compiler,
+			      ;  and this is its write date.
+  lap-file		      ; The lap file for compiles
+  error-file		      ; The file to dump errors into
+  load			      ; Load compiled file or not?
+  (errors 0)		      ; Count of compiler errors.
+  (warnings 0))		      ; Count of compiler warnings.
+;;;
+(defun %print-note (note stream d)
+  (declare (ignore d))
+  (format stream "#<Eval-Server-Note for ~A [~A]>"
+	  (note-context note)
+	  (note-state note)))
+
+
+
+;;;; Note support routines.
+
+;;; QUEUE-NOTE -- Internal.
+;;;
+;;; This queues note for server.  SERVER-INFO-NOTES keeps notes in stack order,
+;;; not queue order.  We also link the note to the server and try to send it
+;;; to the server.  If we didn't send this note, we tell the user the server
+;;; is busy and that we're queuing his note to be sent later.
+;;;
+(defun queue-note (note server)
+  (push note (server-info-notes server))
+  (setf (note-server note) server)
+  (maybe-send-next-note server)
+  (when (eq (note-state note) :unsent)
+    (message "Server ~A busy, ~A queued."
+	     (server-info-name server)
+	     (note-context note))))
+
+;;; MAYBE-SEND-NEXT-NOTE -- Internal.
+;;;
+;;; Loop over all notes in server.  If we see any :pending or :running, then
+;;; punt since we can't send one.  Otherwise, by the end of the list, we may
+;;; have found an :unsent one, and if we did, next will be the last :unsent
+;;; note.  Remember, SERVER-INFO-NOTES is kept in stack order not queue order.
+;;;
+(defun maybe-send-next-note (server)
+  (let ((busy nil)
+	(next nil))
+    (dolist (note (server-info-notes server))
+      (ecase (note-state note)
+	((:pending :running)
+	 (setf busy t)
+	 (return))
+	(:unsent
+	 (setf next note))
+	(:aborted :dead)))
+    (when (and (not busy) next)
+      (send-note next))))
+
+(defun send-note (note)
+  (let* ((remote (wire:make-remote-object note))
+	 (server (note-server note))
+	 (ts (server-info-slave-info server))
+	 (bg (server-info-background-info server))
+	 (wire (server-info-wire server)))
+    (setf (note-state note) :pending)
+    (message "Sending ~A." (note-context note))
+    (case (note-kind note)
+      (:eval
+       (wire:remote wire
+	 (server-eval-text remote
+			   (note-package note)
+			   (note-text note)
+			   (and ts (ts-data-stream ts)))))
+      (:compile
+       (wire:remote wire
+	 (server-compile-text remote
+			      (note-package note)
+			      (note-text note)
+			      (note-input-file note)
+			      (and ts (ts-data-stream ts))
+			      (and bg (ts-data-stream bg)))))
+      (:compile-file
+       (macrolet ((frob (x)
+		    `(if (pathnamep ,x)
+		       (namestring ,x)
+		       ,x)))
+	 (wire:remote wire
+	   (server-compile-file remote
+				(note-package note)
+				(frob (or (note-net-input-file note)
+					  (note-input-file note)))
+				(frob (or (note-net-output-file note)
+					  (note-output-file note)))
+				(frob (note-error-file note))
+				(frob (note-lap-file note))
+				(note-load note)
+				(and ts (ts-data-stream ts))
+				(and bg (ts-data-stream bg))))))
+      (t
+       (error "Unknown note kind ~S" (note-kind note))))
+    (wire:wire-force-output wire)))
+
+
+;;;; Server Callbacks.
+
+(defun operation-started (note)
+  (let ((note (wire:remote-object-value note)))
+    (setf (note-state note) :running)
+    (message "The ~A started." (note-context note)))
+  (values))
+
+(defun eval-form-error (message)
+  (editor-error message))
+
+(defun lisp-error (note start end msg)
+  (declare (ignore start end))
+  (let ((note (wire:remote-object-value note)))
+    (loud-message "During ~A: ~A"
+		  (note-context note)
+		  msg))
+  (values))
+
+(defun compiler-error (note start end function severity)
+  (let* ((note (wire:remote-object-value note))
+	 (server (note-server note))
+	 (line (mark-line
+		(buffer-end-mark
+		 (server-info-background-buffer server))))
+	 (message (format nil "~:(~A~) in ~A during ~A."
+			  severity
+			  function
+			  (note-context note)))
+	 (error (make-error-info :buffer (note-buffer note)
+				 :message message
+				 :line line)))
+    (message "~A" message)
+    (let ((region (case (note-kind note)
+		    (:compile
+		     (note-region note))
+		    (:compile-file
+		     (buffer-region (note-buffer note)))
+		    (t
+		     (error "Compiler error in ~S?" note)))))
+      (when region
+	(let* ((region-end (region-end region))
+	       (m1 (copy-mark (region-start region) :left-inserting))
+	       (m2 (copy-mark m1 :left-inserting)))
+	  (when start
+	    (character-offset m1 start)
+	    (when (mark> m1 region-end)
+	      (move-mark m1 region-end)))
+	  (unless (and end (character-offset m2 end))
+	    (move-mark m2 region-end))
+	  
+	  (setf (error-info-region error)
+		(region m1 m2)))))
+
+    (vector-push-extend error (server-info-errors server)))
+
+  (values))
+
+(defun eval-text-result (note start end values)
+  (declare (ignore note start end))
+  (message "=> ~{~#[~;~A~:;~A, ~]~}" values)
+  (values))
+
+(defun operation-completed (note abortp)
+  (let* ((note (wire:remote-object-value note))
+	 (server (note-server note))
+	 (file (note-output-file note)))
+    (wire:forget-remote-translation note)
+    (setf (note-state note) :dead)
+    (setf (server-info-notes server)
+	  (delete note (server-info-notes server)
+		  :test #'eq))
+    (setf (note-server note) nil)
+
+    (if abortp
+      (loud-message "The ~A aborted." (note-context note))
+      (let ((errors (note-errors note))
+	    (warnings (note-warnings note)))
+	(message "The ~A complete.~@[ ~D error~:P~]~@[ ~D warning~:P~]"
+		 (note-context note)
+		 (and (plusp errors) errors)
+		 (and (plusp warnings) warnings))))
+
+    (let ((region (note-region note)))
+      (when (regionp region)
+	(delete-mark (region-start region))
+	(delete-mark (region-end region))
+	(setf (note-region note) nil)))
+
+    (when (and (eq (note-kind note)
+		   :compile-file)
+	       (not (eq file t))
+	       file)
+      (if (> (file-write-date file)
+	     (note-output-date note))
+	(let ((new-name (make-pathname :type "fasl"
+				       :defaults (note-input-file note))))
+	  (rename-file file new-name)
+	  (mach:unix-chmod (namestring new-name) #o644))
+	(delete-file file)))
+    (maybe-send-next-note server))
+  (values))
+
+
+;;;; Stuff to send noise to the server.
+
+;;; EVAL-FORM-IN-SERVER -- Public.
+;;;
+(defun eval-form-in-server (server-info form
+			    &optional (package (value current-package)))
+  "This evals form, a simple-string, in the server for server-info.  Package
+   is the name of the package in which the server reads form, and it defaults
+   to the value of \"Current Package\".  If package is nil, then the slave uses
+   the value of *package*.  If server is busy with other requests, this signals
+   an editor-error to prevent commands using this from hanging.  If the server
+   dies while evaluating form, then this signals an editor-error.  This returns
+   a list of strings which are the printed representation of all the values
+   returned by form in the server."
+  (declare (simple-string form))
+  (when (server-info-notes server-info)
+    (editor-error "Server ~S is currently busy.  See \"List Operations\"."
+		  (server-info-name server-info)))
+  (multiple-value-bind (values error)
+		       (wire:remote-value (server-info-wire server-info)
+			 (server-eval-form package form))
+    (when error
+      (editor-error "The server died before finishing"))
+    values))
+
+;;; EVAL-FORM-IN-SERVER-1 -- Public.
+;;;
+;;; We use VALUES to squelch the second value of READ-FROM-STRING.
+;;;
+(defun eval-form-in-server-1 (server-info form
+			      &optional (package (value current-package)))
+  "This calls EVAL-FORM-IN-SERVER and returns the result of READ'ing from
+   the first string EVAL-FORM-IN-SERVER returns."
+  (values (read-from-string
+	   (car (eval-form-in-server server-info form package)))))
+
+(defun string-eval (string
+		    &key
+		    (server (get-current-eval-server))
+		    (package (value current-package))
+		    (context (format nil
+				     "evaluation of ~S"
+				     string)))
+  "Queues the evaluation of string on an eval server.  String is a simple
+   string.  If package is not supplied, the string is eval'ed in the slave's
+   current package."
+  (declare (simple-string string))
+  (queue-note (make-note :kind :eval
+			 :context context
+			 :package package
+			 :text string)
+	      server)
+  (values))
+
+(defun region-eval (region
+		    &key
+		    (server (get-current-eval-server))
+		    (package (value current-package))
+		    (context (region-context region "evaluation")))
+  "Queues the evaluation of a region of text on an eval server.  If package
+   is not supplied, the string is eval'ed in the slave's current package."
+  (let ((region (region (copy-mark (region-start region) :left-inserting)
+			(copy-mark (region-end region) :left-inserting))))
+    (queue-note (make-note :kind :eval
+			   :context context
+			   :region region
+			   :package package
+			   :text (region-to-string region))
+		server))
+  (values))
+
+(defun region-compile (region
+		       &key
+		       (server (get-current-eval-server))
+		       (package (value current-package)))
+  "Queues a compilation on an eval server.  If package is not supplied, the
+   string is eval'ed in the slave's current package."
+  (let* ((region (region (copy-mark (region-start region) :left-inserting)
+			 (copy-mark (region-end region) :left-inserting)))
+	 (buf (line-buffer (mark-line (region-start region))))
+	 (defined-from (and buf
+			    (namestring (buffer-pathname buf)))))
+    (queue-note (make-note :kind :compile
+			   :context (region-context region "compilation")
+			   :buffer (and region
+					(region-start region)
+					(mark-line (region-start region))
+					(line-buffer (mark-line
+						      (region-start region))))
+			   :region region
+			   :package package
+			   :text (region-to-string region)
+			   :input-file defined-from)
+		server))
+  (values))
+
+
+
+;;;; File compiling noise.
+
+(defhvar "Remote Compile File"
+  "When set (the default), this causes slave file compilations to assume the
+   compilation is occurring on a remote machine.  This means the source file
+   must be world readable.  Unsetting this, causes no file accesses to go
+   through the super root."
+  :value nil)
+
+;;; FILE-COMPILE compiles files in a client Lisp.  Because of Unix file
+;;; protection, one cannot write files over the net unless they are publicly
+;;; writeable.  To get around this, we create a temporary file that is
+;;; publicly writeable for compiler output.  This file is renamed to an
+;;; ordinary output name if the compiler wrote anything to it, or deleted
+;;; otherwise.  No temporary file is created when output-file is not t.
+;;;
+
+(defun file-compile (file
+		     &key
+		     buffer
+		     (output-file t)
+		     error-file
+		     lap-file
+		     load
+		     (server (get-current-compile-server))
+		     (package (value current-package)))
+  "Compiles file in a client Lisp.  When output-file is t, a temporary
+   output file is used that is publicly writeable in case the client is on
+   another machine.  This file is renamed or deleted after compilation.
+   Setting \"Remote Compile File\" to nil, inhibits this.  If package is not
+   supplied, the string is eval'ed in the slave's current package."
+
+  (let* ((file (truename file)) ; in case of search-list in pathname.
+	 (namestring (namestring file))
+	 (note (make-note
+		:kind :compile-file
+		:context (format nil "compilation of ~A" namestring)
+		:buffer buffer
+		:region nil
+		:package package
+		:input-file file
+		:output-file output-file
+		:error-file error-file
+		:lap-file lap-file
+		:load load)))
+
+    (when (and (value remote-compile-file)
+	       (eq output-file t))
+      (multiple-value-bind (net-infile ofile net-ofile date)
+			   (file-compile-temp-file file)
+	(setf (note-net-input-file note) net-infile)
+	(setf (note-output-file note) ofile)
+	(setf (note-net-output-file note) net-ofile)
+	(setf (note-output-date note) date)))
+
+    (clear-server-errors server
+			 #'(lambda (error)
+			     (eq (error-info-buffer error)
+				 buffer)))
+    (queue-note note server)))
+
+;;; FILE-COMPILE-TEMP-FILE creates a a temporary file that is publicly
+;;; writable in the directory file is in and with a .fasl type.  Four values
+;;; are returned -- a pathname suitable for referencing file remotely, the
+;;; pathname of the temporary file created, a pathname suitable for referencing
+;;; the temporary file remotely, and the write date of the temporary file.
+;;; 
+
+(defun file-compile-temp-file (file)
+  (let ((ofile (loop (let* ((sym (gensym))
+			    (f (merge-pathnames
+				(format nil "compile-file-~A.fasl" sym)
+				file)))
+		       (unless (probe-file f) (return f))))))
+    (multiple-value-bind (fd err)
+			 (mach:unix-open (namestring ofile)
+					 mach:o_creat #o666)
+      (unless fd
+	(editor-error "Couldn't create compiler temporary output file:~%~
+	~A" (mach:get-unix-error-msg err)))
+      (mach:unix-fchmod fd #o666)
+      (mach:unix-close fd))
+    (let ((net-ofile (pathname-for-remote-access ofile)))
+      (values (make-pathname :directory (pathname-directory net-ofile)
+			     :defaults file)
+	      ofile
+	      net-ofile
+	      (file-write-date ofile)))))
+
+(defun pathname-for-remote-access (file)
+  (let* ((machine (machine-instance))
+	 (usable-name (nstring-downcase
+		       (the simple-string
+			    (subseq machine 0 (position #\. machine))))))
+    (declare (simple-string machine usable-name))
+    (make-pathname :directory (concatenate 'simple-string
+					   "/../"
+					   usable-name
+					   (directory-namestring file))
+		   :defaults file)))
+
+;;; REGION-CONTEXT -- internal
+;;;
+;;;    Return a string which describes the code in a region.  Thing is the
+;;; thing being done to the region.  "compilation" or "evaluation"...
+
+(defun region-context (region thing)
+  (declare (simple-string thing))
+  (pre-command-parse-check (region-start region))
+  (let ((start (region-start region)))
+    (with-mark ((m1 start))
+      (unless (start-defun-p m1)
+	(top-level-offset m1 1))
+      (with-mark ((m2 m1))
+	(mark-after m2)
+	(form-offset m2 2)
+	(format nil
+		"~A of ~S"
+		thing
+		(if (eq (mark-line m1) (mark-line m2))
+		  (region-to-string (region m1 m2))
+		  (concatenate 'simple-string
+			       (line-string (mark-line m1))
+			       "...")))))))
+
+
+;;;; Commands (Gosh, wow gee!)
+
+(defcommand "Editor Server Name" (p)
+  "Echos the editor server's name which can be supplied with the -slave switch
+   to connect to a designated editor."
+  "Echos the editor server's name which can be supplied with the -slave switch
+   to connect to a designated editor."
+  (declare (ignore p))
+  (if *editor-name*
+    (message "This editor is named ~S." *editor-name*)
+    (message "This editor is not currently named.")))
+
+(defcommand "Set Buffer Package" (p)
+  "Set the package to be used by Lisp evaluation and compilation commands
+   while in this buffer.  When in a slave's interactive buffers, do NOT
+   set the editor's package variable, but changed the slave's *package*."
+  "Prompt for a package to make into a buffer-local variable current-package."
+  (declare (ignore p))
+  (let* ((name (string (prompt-for-expression
+			:prompt "Package name: "
+			:help "Name of package to associate with this buffer.")))
+	 (buffer (current-buffer))
+	 (info (value current-eval-server)))
+    (cond ((and info
+		(or (eq (server-info-slave-buffer info) buffer)
+		    (eq (server-info-background-buffer info) buffer)))
+	   (wire:remote (server-info-wire info)
+	     (server-set-package name))
+	   (wire:wire-force-output (server-info-wire info)))
+	  ((eq buffer *selected-eval-buffer*)
+	   (setf *package* (maybe-make-package name)))
+	  (t
+	   (defhvar "Current Package"
+	     "The package used for evaluation of Lisp in this buffer."
+	     :buffer buffer  :value name)))
+    (when (buffer-modeline-field-p buffer :package)
+      (dolist (w (buffer-windows buffer))
+	(update-modeline-field buffer w :package)))))
+
+(defcommand "Current Compile Server" (p)
+  "Echos the current compile server's name.  With prefix argument,
+   shows global one.  Does not signal an error or ask about creating a slave."
+  "Echos the current compile server's name.  With prefix argument,
+  shows global one."
+  (let ((info (if p
+		  (variable-value 'current-compile-server :global)
+		  (value current-compile-server))))
+    (if info
+	(message "~A" (server-info-name info))
+	(message "No ~:[current~;global~] compile server." p))))
+
+(defcommand "Set Compile Server" (p)
+  "Specifies the name of the server used globally for file compilation requests."
+  "Call select-current-compile-server."
+  (declare (ignore p))
+  (hlet ((ask-about-old-servers t))
+    (setf (variable-value 'current-compile-server :global)
+	  (maybe-create-server))))
+
+(defcommand "Set Buffer Compile Server" (p)
+  "Specifies the name of the server used for file compilation requests in
+   the current buffer."
+  "Call select-current-compile-server after making a buffer local variable."
+  (declare (ignore p))
+  (hlet ((ask-about-old-servers t))
+    (defhvar "Current Compile Server"
+      "The Server-Info object for the server currently used for compilation requests."
+      :buffer (current-buffer)
+      :value (maybe-create-server))))
+
+(defcommand "Current Eval Server" (p)
+  "Echos the current eval server's name.  With prefix argument, shows
+   global one.  Does not signal an error or ask about creating a slave."
+  "Echos the current eval server's name.  With prefix argument, shows
+   global one.  Does not signal an error or ask about creating a slave."
+  (let ((info (if p
+		  (variable-value 'current-eval-server :global)
+		  (value current-eval-server))))
+    (if info
+	(message "~A" (server-info-name info))
+	(message "No ~:[current~;global~] eval server." p))))
+
+(defcommand "Set Eval Server" (p)
+  "Specifies the name of the server used globally for evaluation and
+   compilation requests."
+  "Call select-current-server."
+  (declare (ignore p))
+  (hlet ((ask-about-old-servers t))
+    (setf (variable-value 'current-eval-server :global)
+	  (maybe-create-server))))
+
+(defcommand "Set Buffer Eval Server" (p)
+  "Specifies the name of the server used for evaluation and compilation
+   requests in the current buffer."
+  "Call select-current-server after making a buffer local variable."
+  (declare (ignore p))
+  (hlet ((ask-about-old-servers t))
+    (defhvar "Current Eval Server"
+      "The Server-Info for the eval server used in this buffer."
+      :buffer (current-buffer)
+      :value (maybe-create-server))))
+
+#+ :IGNORETHIS
+(defcommand "Connect Registered Eval Server" (p)
+  "Tries to connect to a registered eval server.  Prompts for name."
+  "Tries to connect to a registered eval server.  Prompts for name."
+  (declare (ignore p))
+  (connect-registered-eval-server
+   (prompt-for-string :prompt "Name to lookup: "
+		      :help "Registered eval server to connect to.")
+   (prompt-for-string
+    :prompt "Local server name: "
+    :help "Editor's name for server and \"Background <name>\" buffer.")))
+
+(defcommand "Evaluate Defun" (p)
+  "Evaluates the current or next top-level form.
+   If the current region is active, then evaluate it."
+  "Evaluates the current or next top-level form."
+  (declare (ignore p))
+  (if (region-active-p)
+      (evaluate-region-command nil)
+      (region-eval (defun-region (current-point)))))
+
+(defcommand "Re-evaluate Defvar" (p)
+  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
+   form as if the variable is not bound."
+  "Evaluate the current or next top-level form if it is a DEFVAR.  Treat the
+   form as if the variable is not bound."
+  (declare (ignore p))
+  (let* ((form (defun-region (current-point)))
+	 (start (region-start form)))
+    (with-mark ((var-start start)
+		(var-end start))
+      (mark-after var-start)
+      (form-offset var-start 1)
+      (form-offset (move-mark var-end var-start) 1)
+      (let ((exp (concatenate 'simple-string
+			      "(makunbound '"
+			      (region-to-string (region var-start var-end))
+			      ")")))
+	(eval-form-in-server (get-current-eval-server) exp)))
+    (region-eval form)))
+
+;;; We use Prin1-To-String in the client so that the expansion gets pretty
+;;; printed.  Since the expansion can contain unreadable stuff, we can't expect
+;;; to be able to read that string back in the editor.  We shove the region
+;;; at the client Lisp as a string, so it can read from the string with the
+;;; right package environment.
+;;;
+
+(defcommand "Macroexpand Expression" (p)
+  "Show the macroexpansion of the current expression in the null environment.
+   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
+  "Show the macroexpansion of the current expression in the null environment.
+   With an argument, use MACROEXPAND instead of MACROEXPAND-1."
+  (let ((point (current-point)))
+    (with-mark ((start point))
+      (pre-command-parse-check start)
+      (with-mark ((end start))
+        (unless (form-offset end 1) (editor-error))
+	(with-pop-up-display (s)
+	  (write-string
+	   (eval-form-in-server-1
+	    (get-current-eval-server)
+	    (format nil "(prin1-to-string (~S (read-from-string ~S)))"
+		    (if p 'macroexpand 'macroexpand-1)
+		    (region-to-string (region start end))))
+	   s))))))
+
+(defcommand "Evaluate Expression" (p)
+  "Prompt for an expression to evaluate."
+  "Prompt for an expression to evaluate."
+  (declare (ignore p))
+  (let ((exp (prompt-for-string
+	      :prompt "Eval: "
+	      :help "Expression to evaluate.")))
+    (message "=> ~{~#[~;~A~:;~A, ~]~}"
+	     (eval-form-in-server (get-current-eval-server) exp))))
+
+(defcommand "Compile Defun" (p)
+  "Compiles the current or next top-level form.
+   First the form is evaluated, then the result of this evaluation
+   is passed to compile.  If the current region is active, compile
+   the region."
+  "Evaluates the current or next top-level form."
+  (declare (ignore p))
+  (if (region-active-p)
+      (compile-region-command nil)
+      (region-compile (defun-region (current-point)))))
+
+(defcommand "Compile Region" (p)
+  "Compiles lisp forms between the point and the mark."
+  "Compiles lisp forms between the point and the mark."
+  (declare (ignore p))
+  (region-compile (current-region)))
+
+(defcommand "Evaluate Region" (p)
+  "Evaluates lisp forms between the point and the mark."
+  "Evaluates lisp forms between the point and the mark."
+  (declare (ignore p))
+  (region-eval (current-region)))
+           
+(defcommand "Evaluate Buffer" (p)
+  "Evaluates the text in the current buffer."
+  "Evaluates the text in the current buffer redirecting *Standard-Output* to
+  the echo area.  The prefix argument is ignored."
+  (declare (ignore p))
+  (let ((b (current-buffer)))
+    (region-eval (buffer-region b)
+		 :context (format nil
+				  "evaluation of buffer ``~A''"
+				  (buffer-name b)))))
+
+(defcommand "Load File" (p)
+  "Prompt for a file to load into the current eval server."
+  "Prompt for a file to load into the current eval server."
+  (declare (ignore p))
+  (let ((name (truename (prompt-for-file
+			 :default
+			 (or (value load-pathname-defaults)
+			     (buffer-default-pathname (current-buffer)))
+			 :prompt "File to load: "
+			 :help "The name of the file to load"))))
+    (setv load-pathname-defaults name)
+    (string-eval (format nil "(load ~S)"
+			 (namestring (pathname-for-remote-access name))))))
+
+(defcommand "Compile File" (p)
+  "Prompts for file to compile.  Does not compare source and binary write
+   dates.  Does not check any buffer for that file for whether the buffer
+   needs to be saved."
+  "Prompts for file to compile."
+  (declare (ignore p))
+  (let ((pn (prompt-for-file :default
+			     (buffer-default-pathname (current-buffer))
+			     :prompt "File to compile: ")))
+    (file-compile pn)))
+
+(defhvar "Compile Buffer File Confirm"
+  "When set, \"Compile Buffer File\" prompts before doing anything."
+  :value t)
+
+(defcommand "Compile Buffer File" (p)
+  "Compile the file in the current buffer if its associated binary file
+   (of type .fasl) is older than the source or doesn't exist.  When the
+   binary file is up to date, the user is asked if the source should be
+   compiled anyway.  When the prefix argument is supplied, compile the
+   file without checking the binary file.  When \"Compile Buffer File
+   Confirm\" is set, this command will ask for confirmation when it
+   otherwise would not."
+  "Compile the file in the current buffer if the fasl file isn't up to date.
+   When p, always do it."
+  (let* ((buf (current-buffer))
+	 (pn (buffer-pathname buf)))
+    (unless pn (editor-error "Buffer has no associated pathname."))
+    (cond ((buffer-modified buf)
+	   (when (or (not (value compile-buffer-file-confirm))
+		     (prompt-for-y-or-n
+		      :default t :default-string "Y"
+		      :prompt (list "Save and compile file ~A? "
+				    (namestring pn))))
+	     (write-buffer-file buf pn)
+	     (file-compile pn :buffer buf)))
+	  ((older-or-non-existent-fasl-p pn p)
+	   (when (or (not (value compile-buffer-file-confirm))
+		     (prompt-for-y-or-n
+		      :default t :default-string "Y"
+		      :prompt (list "Compile file ~A? " (namestring pn))))
+	     (file-compile pn :buffer buf)))
+	  ((or p
+	       (prompt-for-y-or-n
+		:default t :default-string "Y"
+		:prompt
+		"Fasl file up to date, compile source anyway? "))
+	   (file-compile pn :buffer buf)))))
+
+(defcommand "Compile Group" (p)
+  "Compile each file in the current group which needs it.
+  If a file has type LISP and there is a curresponding file with type
+  FASL which has been written less recently (or it doesn't exit), then
+  the file is compiled, with error output directed to the \"Compiler Warnings\"
+  buffer.  If a prefix argument is provided, then all the files are compiled.
+  All modified files are saved beforehand."
+  "Do a Compile-File in each file in the current group that seems to need it."
+  (save-all-files-command ())
+  (unless *active-file-group* (editor-error "No active file group."))
+  (dolist (file *active-file-group*)
+    (when (string-equal (pathname-type file) "lisp")
+      (let ((tn (probe-file file)))
+	(cond ((not tn)
+	       (message "File ~A not found." (namestring file)))
+	      ((older-or-non-existent-fasl-p tn p)
+	       (file-compile tn)))))))
+
+(defun older-or-non-existent-fasl-p (pathname &optional definitely)
+  (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname))))
+    (or definitely
+	(not obj-pn)
+	(< (file-write-date obj-pn) (file-write-date pathname)))))
+
+
+
+;;;; Error hacking stuff.
+
+(defcommand "Flush Compiler Error Information" (p)
+  "Flushes all infomation about errors encountered while compiling using the
+   current server"
+  "Flushes all infomation about errors encountered while compiling using the
+   current server"
+  (declare (ignore p))
+  (clear-server-errors (get-current-compile-server t)))
+
+(defcommand "Next Compiler Error" (p)
+  "Move to the next compiler error for the current server.  If an argument is 
+   given, advance that many errors."
+  "Move to the next compiler error for the current server.  If an argument is 
+   given, advance that many errors."
+  (let* ((server (get-current-compile-server t))
+	 (errors (server-info-errors server))
+	 (fp (fill-pointer errors)))
+    (when (zerop fp)
+      (editor-error "There are no compiler errors."))
+    (let* ((old-index (server-info-error-index server))
+	   (new-index (+ (or old-index -1) (or p 1))))
+      (when (< new-index 0)
+	(if old-index
+	    (editor-error "Can't back up ~R, only at the ~:R compiler error."
+			  (- p) (1+ old-index))
+	    (editor-error "Not even at the first compiler error.")))
+      (when (>= new-index fp)
+	(if (= (1+ (or old-index -1)) fp)
+	    (editor-error "No more compiler errors.")
+	    (editor-error "Only ~R remaining compiler error~:P."
+			  (- fp old-index 1))))
+      (setf (server-info-error-index server) new-index)
+      ;; Display the silly error.
+      (let ((error (aref errors new-index)))
+	(let ((region (error-info-region error)))
+	  (if region
+	      (let* ((start (region-start region))
+		     (buffer (line-buffer (mark-line start))))
+		(change-to-buffer buffer)
+		(move-mark (buffer-point buffer) start))
+	      (message "Hmm, no region for this error.")))
+	(let* ((line (error-info-line error))
+	       (buffer (line-buffer line)))
+	  (if (and line (bufferp buffer))
+	      (let ((mark (mark line 0)))
+		(unless (buffer-windows buffer)
+		  (let ((window (find-if-not
+				 #'(lambda (window)
+				     (or (eq window (current-window))
+					 (eq window *echo-area-window*)))
+				 *window-list*)))
+		    (if window
+			(setf (window-buffer window) buffer)
+			(make-window mark))))
+		(move-mark (buffer-point buffer) mark)
+		(dolist (window (buffer-windows buffer))
+		  (move-mark (window-display-start window) mark)
+		  (move-mark (window-point window) mark))
+		(delete-mark mark))
+	      (message "Hmm, no line for this error.")))))))
+
+(defcommand "Previous Compiler Error" (p)
+  "Move to the previous compiler error. If an argument is given, move back
+   that many errors."
+  "Move to the previous compiler error. If an argument is given, move back
+   that many errors."
+  (next-compiler-error-command (- (or p 1))))
+
+
+
+;;;; Operation management commands:
+
+(defcommand "Abort Operations" (p)
+  "Abort all operations on current eval server connection."
+  "Abort all operations on current eval server connection."
+  (declare (ignore p))
+  (let* ((server (get-current-eval-server))
+	 (wire (server-info-wire server)))
+    ;; Tell the slave to abort the current operation and to ignore any further
+    ;; operations.
+    (dolist (note (server-info-notes server))
+      (setf (note-state note) :aborted))
+    (ext:send-character-out-of-band (wire:wire-fd wire) #\N)
+    (wire:remote-value wire (server-accept-operations))
+    ;; Synch'ing with server here, causes any operations queued at the socket or
+    ;; in the server to be ignored, and the last thing evaluated is an
+    ;; instruction to go on accepting operations.
+    (wire:wire-force-output wire)
+    (dolist (note (server-info-notes server))
+      (when (eq (note-state note) :pending)
+	;; The WIRE:REMOTE-VALUE call should have allowed a handshake to
+	;; tell the editor anything :pending was aborted.
+	(error "Operation ~S is still around after we aborted it?" note)))
+    ;; Forget anything queued in the editor.
+    (setf (server-info-notes server) nil)))
+
+(defcommand "List Operations" (p)
+  "List all eval server operations which have not yet completed."
+  "List all eval server operations which have not yet completed."
+  (declare (ignore p))
+  (let ((notes nil))
+    ;; Collect all notes, reversing them since they act like a queue but
+    ;; are not in queue order.
+    (do-strings (str val *server-names*)
+      (declare (ignore str))
+      (setq notes (nconc notes (reverse (server-info-notes val)))))
+    (if notes
+	(with-pop-up-display (s)
+	  (dolist (note notes)
+	    (format s "~@(~8A~) ~A on ~A.~%"
+		    (note-state note)
+		    (note-context note)
+		    (server-info-name (note-server note)))))
+	(message "No uncompleted operations.")))
+  (values))
+
+
+;;;; Describing in the client lisp.
+
+;;; "Describe Function Call" gets the function name from the current form
+;;; as a string.  This string is used as the argument to a call to
+;;; DESCRIBE-FUNCTION-CALL-AUX which is eval'ed in the client lisp.  The
+;;; auxiliary function's name is qualified since it is read in the client
+;;; Lisp with *package* bound to the buffer's package.  The result comes
+;;; back as a list of strings, so we read the first string to get out the
+;;; string value returned by DESCRIBE-FUNCTION-CALL-AUX in the client Lisp.
+;;;
+(defcommand "Describe Function Call" (p)
+  "Describe the current function call."
+  "Describe the current function call."
+  (let ((info (value current-eval-server)))
+    (cond
+     ((not info)
+      (message "Describing from the editor Lisp ...")
+      (editor-describe-function-call-command p))
+     (t
+      (with-mark ((mark1 (current-point))
+		  (mark2 (current-point)))
+	(pre-command-parse-check mark1)
+	(unless (backward-up-list mark1) (editor-error))
+	(form-offset (move-mark mark2 (mark-after mark1)) 1)
+	(let* ((package (value current-package))
+	       (package-exists
+		(eval-form-in-server-1
+		 info
+		 (format nil
+			 "(if (find-package ~S) t (package-name *package*))"
+			 package)
+		 nil)))
+	  (unless (eq package-exists t)
+	    (message "Using package ~S in ~A since ~
+		      ~:[there is no current package~;~:*~S does not exist~]."
+		     package-exists (server-info-name info) package))
+	  (with-pop-up-display (s)
+	    (write-string (eval-form-in-server-1
+			   info
+			   (format nil "(ed::describe-function-call-aux ~S)"
+				   (region-to-string (region mark1 mark2)))
+			   (if (eq package-exists t) package nil))
+			   s))))))))
+
+;;; DESCRIBE-FUNCTION-CALL-AUX is always evaluated in a client Lisp to some
+;;; editor, relying on the fact that the cores have the same functions.  String
+;;; is the name of a function that is read (in the client Lisp).  The result is
+;;; a string of all the output from EDITOR-DESCRIBE-FUNCTION.
+;;;
+(defun describe-function-call-aux (string)
+  (let* ((sym (read-from-string string))
+	 (fun (function-to-describe sym error)))
+    (with-output-to-string (*standard-output*)
+      (editor-describe-function fun sym))))
+
+;;; "Describe Symbol" gets the symbol name and quotes it as the argument to a
+;;; call to DESCRIBE-SYMBOL-AUX which is eval'ed in the client lisp.  The
+;;; auxiliary function's name is qualified since it is read in the client Lisp
+;;; with *package* bound to the buffer's package.  The result comes back as a
+;;; list of strings, so we read the first string to get out the string value
+;;; returned by DESCRIBE-SYMBOL-AUX in the client Lisp.
+;;;
+
+(defcommand "Describe Symbol" (p)
+  "Describe the previous s-expression if it is a symbol."
+  "Describe the previous s-expression if it is a symbol."
+  (declare (ignore p))
+  (let ((info (value current-eval-server)))
+    (cond
+     ((not info)
+      (message "Describing from the editor Lisp ...")
+      (editor-describe-symbol-command nil))
+     (t
+      (with-mark ((mark1 (current-point))
+		  (mark2 (current-point)))
+	(mark-symbol mark1 mark2)
+	(with-pop-up-display (s)
+	  (write-string (eval-form-in-server-1
+			 info
+			 (format nil "(ed::describe-symbol-aux '~A)"
+				 (region-to-string (region mark1 mark2))))
+			s)))))))
+
+(defun describe-symbol-aux (thing)
+  (with-output-to-string (*standard-output*)
+    (describe (if (and (consp thing)
+		       (or (eq (car thing) 'quote)
+			   (eq (car thing) 'function))
+		       (symbolp (cadr thing)))
+		  (cadr thing)
+		  thing))))
diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..99978ec810765a142808503b5f4ca803fee304be
--- /dev/null
+++ b/hemlock/lispmode.lisp
@@ -0,0 +1,1453 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Hemlock LISP Mode commands
+;;;
+;;; Written by Ivan Vazquez and Bill Maddox.
+;;;
+
+(in-package "HEMLOCK")
+
+
+
+;;;;  ####  VARIABLES  ####
+;;;
+;;; These routines are used to define, for standard LISP mode, the start and end
+;;; of a block to parse.  If these need to be changed for a minor mode that sits
+;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the
+;;; name of the function to use instead of START-OF-PARSE-BLOCK and 
+;;; END-OF-PARSE-BLOCK.
+;;; 
+
+(defhvar "Parse Start Function"
+  "Take a mark and move it to the top of a block for paren parsing."
+  :value 'start-of-parse-block)
+
+(defhvar "Parse End Function"
+  "Take a mark and move it to the bottom of a block for paren parsing."
+  :value 'end-of-parse-block)
+
+	    
+;;;; #### STRUCTURES ####
+;;; 
+;;; LISP-INFO is the structure used to store the data about the line in its Plist.
+;;; 
+;;;     -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether
+;;;        or not a line's begining and/or ending are quoted.
+;;; 
+;;;     -> RANGES-TO-IGNORE is a list of cons cells, each having the form
+;;;        ( [begining-charpos] [end-charpos] ) each of these cells indicating
+;;;        a range to ignore.  End is exclusive.
+;;; 
+;;;     -> NET-OPEN-PARENS, NET-CLOSE-PARENS integers that are the number of 
+;;;        unmatched opening and closing parens that there are on a line.
+;;; 
+;;;     -> SIGNATURE-SLOT ...
+;;; 
+
+(defstruct (lisp-info (:constructor make-lisp-info ()))
+  (begins-quoted nil)		; (or t nil)
+  (ending-quoted nil)		; (or t nil)
+  (ranges-to-ignore nil)	; (or t nil)
+  (net-open-parens 0 :type fixnum)
+  (net-close-parens 0 :type fixnum)
+  (signature-slot))
+
+
+
+;;;;  ####  MACROS  ####
+;;; 
+;;; The following Macros exist to make it easy to acces the Syntax primitives
+;;; without uglifying the code.  They were originally written by Maddox.
+;;; 
+
+(defmacro scan-char (mark attribute values)
+  `(find-attribute ,mark ',attribute ,(attr-predicate values)))
+
+(defmacro rev-scan-char (mark attribute values)
+  `(reverse-find-attribute ,mark ',attribute ,(attr-predicate values)))
+
+(defmacro test-char (char attribute values)
+  `(let ((x (character-attribute ',attribute ,char)))
+     ,(attr-predicate-aux values)))
+
+(eval-when (compile load eval)
+(defun attr-predicate (values)
+  (cond ((eq values 't)
+	 '#'plusp)
+	((eq values 'nil)
+	 '#'zerop)
+	(t `#'(lambda (x) ,(attr-predicate-aux values)))))
+
+(defun attr-predicate-aux (values)
+  (cond ((eq values t)
+	 '(plusp x))
+	((eq values nil)
+	 '(zerop x))
+	((symbolp values)
+	 `(eq x ',values))
+	((and (listp values) (member (car values) '(and or not)))
+	 (cons (car values) (mapcar #'attr-predicate-aux (cdr values))))
+	(t (error "Illegal form in attribute pattern - ~S" values))))
+
+); Eval-When (Compile Load Eval)
+
+;;; 
+;;; FIND-LISP-CHAR
+
+(defmacro find-lisp-char (mark)
+  "Move MARK to next :LISP-SYNTAX character, if one isn't found, return NIL."
+  `(find-attribute ,mark :lisp-syntax
+		   #'(lambda (x)
+		       (member x '(:open-paren :close-paren :newline :comment
+					       :char-quote :string-quote))))) 
+;;; 
+;;; PUSH-RANGE
+
+(defmacro push-range (new-range info-struct)
+  "Insert NEW-RANGE into the LISP-INFO-RANGES-TO-IGNORE slot of the INFO-STRUCT."
+  `(when ,new-range
+     (setf (lisp-info-ranges-to-ignore ,info-struct) 
+	   (cons ,new-range (lisp-info-ranges-to-ignore ,info-struct)))))
+;;; 
+;;; SCAN-DIRECTION
+
+(defmacro scan-direction (mark forwardp &rest forms)
+  "Expand to a form that scans either backward or forward according to Forwardp."
+  (if forwardp
+      `(scan-char ,mark ,@forms)
+      `(rev-scan-char ,mark ,@forms)))
+;;; 
+;;; DIRECTION-CHAR
+
+(defmacro direction-char (mark forwardp)
+  "Expand to a form that returns either the previous or next character according
+  to Forwardp."
+  (if forwardp
+      `(next-character ,mark)
+      `(previous-character ,mark)))
+
+;;; 
+;;; NEIGHBOR-MARK
+
+(defmacro neighbor-mark (mark forwardp)
+  "Expand to a form that moves MARK either backward or forward one character, 
+  depending on FORWARDP."
+  (if forwardp
+      `(mark-after ,mark)
+      `(mark-before ,mark)))
+
+;;; 
+;;; NEIGHBOR-LINE
+
+(defmacro neighbor-line (line forwardp)
+  "Expand to return the next or previous line, according to Forwardp."
+  (if forwardp
+      `(line-next ,line)
+      `(line-previous ,line)))
+
+
+;;;; #### PARSING FUNCTIONS ###
+;;;
+;;; PRE-COMMAND-PARSE-CHECK
+
+(defun pre-command-parse-check (mark &optional (fer-sure-parse nil))
+  "Parse the area before the command is actually executed."
+  (with-mark ((top mark)
+	      (bottom mark))
+    (funcall (value parse-start-function) top)
+    (funcall (value parse-end-function) bottom)
+    (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse)))
+
+;;; 
+;;; PARSE-OVER-BLOCK
+
+(defun parse-over-block (start-line end-line &optional (fer-sure-parse nil))
+  "Parse over an area indicated from END-LINE to START-LINE."
+  (let ((test-line start-line)
+	prev-line-info)
+    
+    (with-mark ((mark (mark test-line 0)))
+      
+      ; Set the pre-begining and post-ending lines to delimit the range
+      ; of action any command will take.  This means set the lisp-info of the 
+      ; lines immediately before and after the block to Nil.
+      
+      (when (line-previous start-line)
+	(setf (getf (line-plist (line-previous start-line)) 'lisp-info) nil))
+      (when (line-next end-line)
+	(setf (getf (line-plist (line-next end-line)) 'lisp-info) nil))
+      
+      (loop
+       (let ((line-info (getf (line-plist test-line) 'lisp-info)))
+	 
+	 ;;    Reparse the line when any of the following are true:
+	 ;;
+	 ;;      FER-SURE-PARSE is T
+	 ;;
+	 ;;      LINE-INFO or PREV-LINE-INFO are Nil.
+	 ;;
+	 ;;      If the line begins quoted and the previous one wasn't 
+	 ;;      ended quoted.
+	 ;;
+	 ;;      The Line's signature slot is invalid (the line has changed).
+	 ;;
+	 
+	 (when (or fer-sure-parse      
+		   (not line-info)     
+		   (not prev-line-info)
+		   
+		   (not (eq (lisp-info-begins-quoted line-info) 
+			    (lisp-info-ending-quoted prev-line-info)))
+		   
+		   (not (eql (line-signature test-line)     
+			     (lisp-info-signature-slot line-info))))
+	   
+	   (move-to-position mark 0 test-line)
+	   
+	   (unless line-info
+	     (setf line-info (make-lisp-info))
+	     (setf (getf (line-plist test-line) 'lisp-info) line-info))
+	   
+	   (parse-lisp-line-info mark line-info prev-line-info))
+	 
+	 (when (eq end-line test-line)
+	   (return nil))
+	 
+	 (setq prev-line-info line-info)
+	 
+	 (setq test-line (line-next test-line)))))))
+
+
+;;;;  ####  PARSE BLOCK FINDERS  ####
+;;; 
+
+(defhvar "Minimum Lines Parsed"
+  "The minimum number of lines before and after the point parsed by Lisp mode."
+  :value 50)
+(defhvar "Maximum Lines Parsed"
+  "The maximum number of lines before and after the point parsed by Lisp mode."
+  :value 500)
+(defhvar "Defun Parse Goal"
+  "Lisp mode parses the region obtained by skipping this many defuns forward
+   and backward from the point unless this falls outside of the range specified
+   by \"Minimum Lines Parsed\" and \"Maximum Lines Parsed\"."
+  :value 2)
+
+
+(macrolet ((frob (step end)
+	     `(let ((min (value minimum-lines-parsed))
+		    (max (value maximum-lines-parsed))
+		    (goal (value defun-parse-goal))
+		    (last-defun nil))
+		(declare (fixnum min max goal))
+		(do ((line (mark-line mark) (,step line))
+		     (count 0 (1+ count)))
+		    ((null line)
+		     (,end mark))
+		  (declare (fixnum count))
+		  (when (char= (line-character line 0) #\()
+		    (setq last-defun line)
+		    (decf goal)
+		    (when (and (<= goal 0) (>= count min))
+		      (line-start mark line)
+		      (return)))
+		  (when (> count max)
+		    (line-start mark (or last-defun line))
+		    (return))))))
+
+  (defun start-of-parse-block (mark)
+    (frob line-previous buffer-start))
+
+  (defun end-of-parse-block (mark)
+    (frob line-next buffer-end)))
+
+;;; 
+;;; START-OF-SEARCH-LINE
+
+(defun start-of-search-line (line)
+  "Set LINE to the begining line of the block of text to parse."
+  (with-mark ((mark (mark line 0)))
+    (funcall (value 'Parse-Start-Function) mark)
+    (setq line (mark-line mark))))
+
+;;; 
+;;; END-OF-SEACH-LINE
+
+(defun end-of-search-line (line)
+  "Set LINE to the ending line of the block of text to parse."
+  (with-mark ((mark (mark line 0)))
+    (funcall (value 'Parse-End-Function) mark)
+    (setq line (mark-line mark))))
+
+
+;;; PARSE-LISP-LINE-INFO parses through the line doing the following things:
+;;; 
+;;;      Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS.
+;;; 
+;;;      Making all areas of the line that should be invalid (comments,
+;;;      char-quotes, and the inside of strings) and such be in
+;;;      RANGES-TO-IGNORE.
+;;;
+;;;      Set BEGINS-QUOTED and ENDING-QUOTED 
+;;; 
+
+(defun parse-lisp-line-info (mark line-info prev-line-info)
+  "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS,
+RANGES-TO-INGORE, and ENDING-QUOTED."
+  (let ((net-open-parens 0)
+	(net-close-parens 0))
+    (declare (fixnum net-open-parens net-close-parens))
+    
+    ;; Re-set the slots necessary
+    
+    (setf (lisp-info-ranges-to-ignore line-info) nil)
+    
+    ;; The only way the current line begins quoted is when there
+    ;; is a previous line and it's ending was quoted.
+    
+    (setf (lisp-info-begins-quoted line-info)
+	  (and prev-line-info 
+	       (lisp-info-ending-quoted prev-line-info)))
+    
+    (if (lisp-info-begins-quoted line-info)
+	(deal-with-string-quote mark line-info)
+	(setf (lisp-info-ending-quoted line-info) nil))
+    
+    (unless (lisp-info-ending-quoted line-info)
+      (loop 
+	(find-lisp-char mark)
+	(ecase (character-attribute :lisp-syntax (next-character mark))
+	  
+	  (:open-paren
+	   (setq net-open-parens (1+ net-open-parens))
+	   (mark-after mark))
+	  
+	  (:close-paren
+	   (if (zerop net-open-parens)
+	       (setq net-close-parens (1+ net-close-parens))
+	       (setq net-open-parens (1- net-open-parens)))
+	   (mark-after mark))
+	  
+	  (:newline
+	   (setf (lisp-info-ending-quoted line-info) nil)
+	   (return t))
+	  
+	  (:comment
+	   (push-range (cons (mark-charpos mark) (line-length (mark-line mark)))
+		       line-info)
+	   (setf (lisp-info-ending-quoted line-info) nil)
+	   (return t))
+	  
+	  (:char-quote
+	   (mark-after mark)
+	   (push-range (cons (mark-charpos mark) (1+ (mark-charpos mark)))
+		       line-info)
+	   (mark-after mark))
+	  
+	  (:string-quote
+	   (mark-after mark)
+	   (unless (deal-with-string-quote mark line-info)
+	     (setf (lisp-info-ending-quoted line-info) t)
+	     (return t))))))
+    
+    (setf (lisp-info-net-open-parens line-info) net-open-parens)
+    (setf (lisp-info-net-close-parens line-info) net-close-parens)
+    (setf (lisp-info-signature-slot line-info) 
+	  (line-signature (mark-line mark)))))
+
+;;;;  #### STRING QUOTE UTILITIES ####
+;;; 
+;;; 
+ 
+;;; 
+;;; VALID-STRING-QUOTE-P
+
+(defmacro valid-string-quote-p (mark forwardp)
+  "Return T if the string-quote indicated by MARK is valid."
+  (let ((test-mark (gensym)))
+    `(with-mark ((,test-mark ,mark))
+       
+       ,(unless forwardp              ; TEST-MARK should always be right before the
+	  `(mark-before ,test-mark))   ; String-quote to be checked.
+       
+       (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote)
+	 
+	 (let ((slash-count 0))
+	   
+	   (loop
+	     (mark-before ,test-mark)
+	     (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote)
+		 (incf slash-count)
+		 (return t)))
+	   (not (oddp slash-count)))))))
+
+;;; 
+;;; FIND-VALID-STRING-QUOTE
+
+(defmacro find-valid-string-quote (mark &key forwardp (cease-at-eol nil))
+  "Expand to a form that will leave MARK before a valid string-quote character,
+  in either a forward or backward direction, according to FORWARDP.  If 
+  CEASE-AT-EOL is T then it will return nil if encountering the EOL before a
+  valid string-quote."
+  (let ((e-mark (gensym)))
+    `(with-mark ((,e-mark ,mark))
+       
+       (loop
+	(unless (scan-direction ,e-mark ,forwardp :lisp-syntax 
+				,(if cease-at-eol 
+				     `(or :newline :string-quote)
+				     `:string-quote))
+	  (return nil))
+	
+	,@(if cease-at-eol
+	      `((when (test-char (direction-char ,e-mark ,forwardp) :lisp-syntax
+				 :newline)
+		  (return nil))))
+	
+	(when (valid-string-quote-p ,e-mark ,forwardp)
+	  (move-mark ,mark ,e-mark)
+	  (return t))
+	
+	(neighbor-mark ,e-mark ,forwardp)))))
+
+;;; DEAL-WITH-STRING-QUOTE 
+;;; 
+;;; Called when a string is begun (i.e. parse hits a #\").  It checks for a
+;;; matching quote on the line that MARK points to, and puts the
+;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing
+;;; after this area.  The "appropriate area" is from MARK to the end of the
+;;; line or the matching string-quote, whichever comes first.
+
+(defun deal-with-string-quote (mark info-struct)
+  "Alter the current line's info struct as necessary as due to encountering a
+string quote character."
+  (with-mark ((e-mark mark))
+    
+    (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t)
+    
+	   ;; If matching quote is on this line then mark the area between 
+	   ;; the first quote (MARK) and the matching quote as invalid by 
+	   ;; pushing its begining and ending into the IGNORE-RANGE.
+	   
+	   (push-range (cons (mark-charpos mark) (mark-charpos e-mark))
+		       info-struct)
+		       
+	   (setf (lisp-info-ending-quoted info-struct) nil)
+	   (mark-after e-mark)
+	   (move-mark mark e-mark))
+	   
+	  ;; If the EOL has been hit before the matching quote then mark
+	  ;; the area from MARK to the EOL as invalid.
+	  
+	  (t
+	   (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark))))
+		       info-struct)
+			 
+	   ;; The Ending is marked as still being quoted. 
+
+	   (setf (lisp-info-ending-quoted info-struct) t)
+	   (line-end mark)
+	   nil))))
+	     
+
+;;;; Character validity checking:
+
+;;; Find-Ignore-Region  --  Internal
+;;;
+;;;    If the character in the specified direction from Mark is in an ignore
+;;; region, then return the region and the line that the region is in as
+;;; values.  If there is no ignore region, then return NIL and the Mark-Line.
+;;; If the line is not parsed, or there is no character (because of being at
+;;; the buffer beginning or end), then return both values NIL.
+;;;
+(defun find-ignore-region (mark forwardp)
+  (declare (fixnum pos))
+  (flet ((scan (line pos)
+	   (declare (fixnum pos))
+	   (let ((info (getf (line-plist line) 'lisp-info)))
+	     (if info
+		 (dolist (range (lisp-info-ranges-to-ignore info)
+				(values nil line))
+		   (let ((start (car range))
+			 (end (cdr range)))
+		     (declare (fixnum start end))
+		     (when (and (>= pos start) (< pos end))
+		       (return (values range line)))))
+		 (values nil nil)))))
+    (let ((pos (mark-charpos mark))
+	  (line (mark-line mark)))
+      (declare (fixnum pos))
+      (cond (forwardp (scan line pos))
+	    ((> pos 0) (scan line (1- pos)))
+	    (t
+	     (let ((prev (line-previous line)))
+	       (if prev
+		   (scan prev (line-length prev))
+		   (values nil nil))))))))
+
+
+;;; Valid-Spot  --  Public
+;;;
+(defun valid-spot (mark forwardp)
+  "Return true if the character pointed to by Mark is not in a quoted context,
+  false otherwise.  If Forwardp is true, we use the next character, otherwise
+  we use the previous."
+  (multiple-value-bind (region line)
+		       (find-ignore-region mark forwardp)
+    (and line (not region))))
+
+
+;;; Scan-Direction-Valid  --  Internal
+;;;
+;;;    Like scan-direction, but only stop on valid characters.
+;;;
+(defmacro scan-direction-valid (mark forwardp &rest forms)
+  (let ((n-mark (gensym))
+	(n-line (gensym))
+	(n-region (gensym))
+	(n-won (gensym)))
+    `(let ((,n-mark ,mark) (,n-won nil))
+       (loop
+	 (multiple-value-bind (,n-region ,n-line)
+			      (find-ignore-region ,n-mark ,forwardp)
+	   (unless ,n-line (return nil))
+	   (if ,n-region
+	       (move-to-position ,n-mark
+				 ,(if forwardp
+				      `(cdr ,n-region) 
+				      `(car ,n-region))
+				 ,n-line)
+	       (when ,n-won (return t)))
+	   ;;
+	   ;; Peculiar condition when a quoting character terminates a line.
+	   ;; The ignore region is off the end of the line causing %FORM-OFFSET
+	   ;; to infinitely loop.
+	   (when (> (mark-charpos ,n-mark) (line-length ,n-line))
+	     (line-offset ,n-mark 1 0))
+	   (unless (scan-direction ,n-mark ,forwardp ,@forms)
+	     (return nil))
+	   (setq ,n-won t))))))
+
+
+;;;; #### LIST-OFFSETING ####
+;;; 
+;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built
+;;; with the same existing structure, with the altering of one variable.
+;;; This one variable being FORWARDP.
+;;; 
+(defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) )
+  "Expand to code that will go forward one list either backward or forward, 
+according to the FORWARDP flag."
+  (let ((mark (gensym)))
+    `(let ((paren-count ,extra-parens))
+       (declare (fixnum paren-count))
+       (with-mark ((,mark ,actual-mark))
+	 (loop
+	   (scan-direction ,mark ,forwardp :lisp-syntax
+			   (or :close-paren :open-paren :newline))
+	   (let ((ch (direction-char ,mark ,forwardp)))
+	     (unless ch (return nil))
+	     (when (valid-spot ,mark ,forwardp)
+	       (case (character-attribute :lisp-syntax ch)
+		 (:close-paren
+		  (decf paren-count)
+		  ,(when forwardp               ; When going forward, an unmatching
+		     `(when (<= paren-count 0)  ; close-paren means the end of list.
+			(neighbor-mark ,mark ,forwardp)
+			(move-mark ,actual-mark ,mark)
+			(return t))))
+		 (:open-paren
+		  (incf paren-count)
+		  ,(unless forwardp             ; Same as above only end of list
+		     `(when (>= paren-count 0)  ; is opening parens.
+			(neighbor-mark ,mark ,forwardp)
+			(move-mark ,actual-mark ,mark)
+			(return t))))
+		 
+		 (:newline 
+		  ;; When a #\Newline is hit, then the matching paren must lie on
+		  ;; some other line so drop down into the multiple line balancing
+		  ;; function:  QUEST-FOR-BALANCING-PAREN
+		  ;; If no paren seen yet, keep going.
+		  (cond ((zerop paren-count))
+			((quest-for-balancing-paren ,mark paren-count ,forwardp)
+			 (move-mark ,actual-mark ,mark)
+			 (return t))
+			(t
+			 (return nil)))))))
+	   
+	   (neighbor-mark ,mark ,forwardp))))))
+
+;;; 
+;;; QUEST-FOR-BALANCING-PAREN
+
+(defmacro quest-for-balancing-paren (mark paren-count forwardp)
+  "Expand to a form that finds the the balancing paren for however many opens or
+  closes are registered by Paren-Count."
+  `(let* ((line (mark-line ,mark)))
+     (loop
+       (setq line (neighbor-line line ,forwardp))
+       (unless line (return nil))
+       (let ((line-info (getf (line-plist line) 'lisp-info))
+	     (unbal-paren ,paren-count))
+	 (unless line-info (return nil))
+	 
+	 ,(if forwardp
+	      `(decf ,paren-count (lisp-info-net-close-parens line-info))
+	      `(incf ,paren-count (lisp-info-net-open-parens line-info)))
+	 
+	 (when ,(if forwardp
+		    `(<= ,paren-count 0)
+		    `(>= ,paren-count 0))
+	   ,(if forwardp
+		`(line-start ,mark line)
+		`(line-end ,mark line))
+	   (return (goto-correct-paren-char ,mark unbal-paren ,forwardp)))
+
+	 ,(if forwardp
+	      `(incf ,paren-count (lisp-info-net-open-parens line-info))
+	      `(decf ,paren-count (lisp-info-net-close-parens line-info)))))))
+		   
+
+;;; 
+;;; GOTO-CORRECT-PAREN-CHAR
+
+(defmacro goto-correct-paren-char (mark paren-count forwardp)
+  "Expand to a form that will leave MARK on the correct balancing paren matching 
+   however many are indicated by COUNT." 
+  `(with-mark ((m ,mark))
+     (let ((count ,paren-count))
+       (loop
+	 (scan-direction m ,forwardp :lisp-syntax 
+			 (or :close-paren :open-paren :newline))
+	 (when (valid-spot m ,forwardp)
+	   (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
+	     (:close-paren 
+	      (decf count)
+	      ,(when forwardp
+		 `(when (zerop count)
+		    (neighbor-mark m ,forwardp)
+		    (move-mark ,mark m)
+		    (return t))))
+	     
+	     (:open-paren 
+	      (incf count)
+	      ,(unless forwardp
+		 `(when (zerop count)
+		    (neighbor-mark m ,forwardp)
+		    (move-mark ,mark m)
+		    (return t))))))
+	 (neighbor-mark m ,forwardp)))))
+
+
+(defun list-offset (mark offset)
+  (if (plusp offset)
+      (dotimes (i offset t)
+	(unless (%list-offset mark t) (return nil)))
+      (dotimes (i (- offset) t)
+	(unless (%list-offset mark nil) (return nil)))))
+
+(defun forward-up-list (mark)
+  "Moves mark just past the closing paren of the immediately containing list."
+  (%list-offset mark t :extra-parens 1))
+
+(defun backward-up-list (mark)
+  "Moves mark just before the opening paren of the immediately containing list."
+  (%list-offset mark nil :extra-parens -1))
+
+
+
+;;;; Top level form location hacks (open parens beginning lines).
+
+;;; NEIGHBOR-TOP-LEVEL is used only in TOP-LEVEL-OFFSET.
+;;; 
+(eval-when (compile eval)
+(defmacro neighbor-top-level (line forwardp)
+  `(loop
+     (when (test-char (line-character ,line 0) :lisp-syntax :open-paren)
+       (return t))
+     (setf ,line ,(if forwardp `(line-next ,line) `(line-previous ,line)))
+     (unless ,line (return nil))))
+) ;eval-when
+
+(defun top-level-offset (mark offset)
+  "Go forward or backward offset number of top level forms.  Mark is
+   returned if offset forms exists, otherwise nil."
+  (declare (fixnum offset))
+  (let* ((line (mark-line mark))
+	 (at-start (test-char (line-character line 0) :lisp-syntax :open-paren)))
+    (cond ((zerop offset) mark)
+	  ((plusp offset)
+	   (do ((offset (if at-start offset (1- offset))
+			(1- offset)))
+	       (nil)
+	     (declare (fixnum offset))
+	     (unless (neighbor-top-level line t) (return nil))
+	     (when (zerop offset) (return (line-start mark line)))
+	     (unless (setf line (line-next line)) (return nil))))
+	  (t
+	   (do ((offset (if (and at-start (start-line-p mark))
+			    offset
+			    (1+ offset))
+			(1+ offset)))
+		(nil)
+	     (declare (fixnum offset))
+	     (unless (neighbor-top-level line nil) (return nil))
+	     (when (zerop offset) (return (line-start mark line)))
+	     (unless (setf line (line-previous line)) (return nil)))))))
+
+
+(defun mark-top-level-form (mark1 mark2)
+  "Moves mark1 and mark2 to the beginning and end of the current or next defun.
+   Mark1 one is used as a reference.  The marks may be altered even if
+   unsuccessful.  if successful, return mark2, else nil."
+  (let ((winp (cond ((inside-defun-p mark1)
+		     (cond ((not (top-level-offset mark1 -1)) nil)
+			   ((not (form-offset (move-mark mark2 mark1) 1)) nil)
+			   (t mark2)))
+		    ((start-defun-p mark1)
+		     (form-offset (move-mark mark2 mark1) 1))
+		    ((and (top-level-offset (move-mark mark2 mark1) -1)
+			  (start-defun-p mark2)
+			  (form-offset mark2 1)
+			  (same-line-p mark1 mark2))
+		     (form-offset (move-mark mark1 mark2) -1)
+		     mark2)
+		    ((top-level-offset mark1 1)
+		     (form-offset (move-mark mark2 mark1) 1)))))
+    (when winp
+      (when (blank-after-p mark2) (line-offset mark2 1 0))
+      mark2)))
+
+(defun inside-defun-p (mark)
+  "T if the current point is (supposedly) in a top level form."
+  (with-mark ((m mark))
+    (when (top-level-offset m -1)
+      (form-offset m 1)
+      (mark> m mark))))
+
+(defun start-defun-p (mark)
+  "Returns t if mark is sitting before an :open-paren at the beginning of a
+   line."
+  (and (start-line-p mark)
+       (test-char (next-character mark) :lisp-syntax :open-paren)))
+
+
+
+;;;; #### FORM OFFSETING ####
+
+(defmacro %form-offset (mark forwardp)
+  `(with-mark ((m ,mark))
+     (when (scan-direction-valid m ,forwardp :lisp-syntax
+				 (or :open-paren :close-paren
+				     :char-quote :string-quote
+				     :constituent))
+       (ecase (character-attribute :lisp-syntax (direction-char m ,forwardp))
+	 (:open-paren
+	  (when ,(if forwardp `(list-offset m 1) `(mark-before m))
+	    ,(unless forwardp
+	       '(scan-direction m nil :lisp-syntax (not :prefix)))
+	    (move-mark ,mark m)
+	    t))
+	 (:close-paren
+	  (when ,(if forwardp `(mark-after m) `(list-offset m -1))
+	    ,(unless forwardp
+	       '(scan-direction m nil :lisp-syntax (not :prefix)))
+	    (move-mark ,mark m)
+	    t))
+	 ((:constituent :char-quote)
+	  (scan-direction-valid m ,forwardp :lisp-syntax
+				(not (or :constituent :char-quote)))
+	  ,(if forwardp
+	       `(scan-direction-valid m t :lisp-syntax
+				      (not (or :constituent :char-quote)))
+	       `(scan-direction-valid m nil :lisp-syntax
+				      (not (or :constituent :char-quote
+					       :prefix))))
+	  (move-mark ,mark m)
+	  t)
+	 (:string-quote
+	  (cond ((valid-spot m ,(not forwardp))
+		 (neighbor-mark m ,forwardp)
+		 (when (scan-direction-valid m ,forwardp :lisp-syntax
+					     :string-quote)
+		   (neighbor-mark m ,forwardp)
+		   (move-mark ,mark m)
+		   t))
+		(t (neighbor-mark m ,forwardp)
+		   (move-mark ,mark m)
+		   t)))))))
+
+
+(defun form-offset (mark offset)
+  "Move mark offset number of forms, after if positive, before if negative.
+   Mark is always moved.  If there weren't enough forms, returns nil instead of
+   mark."
+  (if (plusp offset)
+      (dotimes (i offset t)
+	(unless (%form-offset mark t) (return nil)))
+      (dotimes (i (- offset) t)
+	(unless (%form-offset mark nil) (return nil)))))
+
+
+
+;;; Table of special forms with special indenting requirements.
+
+
+(defhvar "Indent Defanything"
+  "This is the number of special arguments implicitly assumed to be supplied
+   in calls to functions whose names begin with \"DEF\".  If set to NIL, this
+   feature is disabled."
+  :value 2)
+
+(defvar *special-forms* (make-hash-table :test #'equal))
+
+(defun defindent (fname args)
+  "Define Fname to have Args special arguments.  If args is null then remove
+   any special arguments information."
+  (check-type fname string)
+  (let ((fname (string-upcase fname)))
+    (cond ((null args) (remhash fname *special-forms*))
+	  (t
+	   (check-type args integer)
+	   (setf (gethash fname *special-forms*) args)))))
+
+
+;;; Hemlock forms.
+;;; 
+(defindent "with-mark" 1)
+(defindent "with-random-typeout" 1)
+(defindent "with-pop-up-display" 1)
+(defindent "defhvar" 1)
+(defindent "hlet" 1)
+(defindent "defcommand" 2)
+(defindent "defattribute" 1)
+(defindent "command-case" 1)
+(defindent "with-input-from-region" 1)
+(defindent "with-output-to-mark" 1)
+(defindent "with-output-to-window" 1)
+(defindent "do-strings" 1)
+(defindent "save-for-undo" 1)
+(defindent "do-alpha-chars" 1)
+(defindent "do-headers-buffers" 1)
+(defindent "do-headers-lines" 1)
+(defindent "with-headers-mark" 1)
+(defindent "frob" 1) ;cover silly FLET and MACROLET names for Rob and Bill.
+(defindent "with-writable-buffer" 1)
+
+;;; Common Lisp forms.
+;;; 
+(defindent "block" 1)
+(defindent "case" 1)
+(defindent "catch" 1)
+(defindent "ccase" 1)			   
+(defindent "compiler-let" 1)
+(defindent "ctypecase" 1)
+(defindent "defconstant" 1)
+(defindent "define-setf-method" 2)
+(defindent "defmacro" 2)
+(defindent "defparameter" 1)
+(defindent "defstruct" 1)
+(defindent "deftype" 2)
+(defindent "defun" 2)
+(defindent "defvar" 1)
+(defindent "do" 2)
+(defindent "do*" 2)
+(defindent "do-all-symbols" 1)
+(defindent "do-external-symbols" 1)
+(defindent "do-symbols" 1)
+(defindent "dolist" 1)
+(defindent "dotimes" 1)
+(defindent "ecase" 1)
+(defindent "etypecase" 1)
+(defindent "eval-when" 1)
+(defindent "flet" 1)
+(defindent "labels" 1)
+(defindent "lambda" 1)
+(defindent "let" 1)
+(defindent "let*" 1)
+(defindent "loop" 0)
+(defindent "macrolet" 1)
+(defindent "multiple-value-bind" 2)
+(defindent "multiple-value-call" 1)
+(defindent "multiple-value-prog1" 1)
+(defindent "multiple-value-setq" 1)
+(defindent "prog1" 1)
+(defindent "progv" 2)
+(defindent "progn" 0)
+(defindent "typecase" 1)
+(defindent "unless" 1)
+(defindent "unwind-protect" 1)
+(defindent "when" 1)
+(defindent "with-input-from-string" 1)
+(defindent "with-open-file" 1)
+(defindent "with-open-stream" 1)
+(defindent "with-output-to-string" 1)
+
+;;; Error/condition system forms.
+;;; 
+(defindent "define-condition" 2)
+(defindent "handler-bind" 1)
+(defindent "handler-case" 1)
+(defindent "restart-bind" 1)
+(defindent "restart-case" 1)
+(defindent "with-simple-restart" 1)
+;;; These are for RESTART-CASE branch formatting.
+(defindent "store-value" 1)
+(defindent "use-value" 1)
+(defindent "muffle-warning" 1)
+(defindent "abort" 1)
+(defindent "continue" 1)
+
+;;; Xlib forms.
+;;;
+(defindent "with-gcontext" 1)
+(defindent "xlib:with-gcontext" 1)
+(defindent "with-state" 1)
+(defindent "xlib:with-state" 1)
+(defindent "with-display" 1)
+(defindent "xlib:with-display" 1)
+(defindent "with-event-queue" 1)
+(defindent "xlib:with-event-queue" 1)
+(defindent "with-server-grabbed" 1)
+(defindent "xlib:with-server-grabbed" 1)
+(defindent "event-case" 1)
+(defindent "xlib:event-case" 1)
+
+;;; CLOS forms.
+;;; 
+(defindent "with-slots" 1)
+(defindent "with-slots*" 2)
+(defindent "with-accessors*" 2)
+(defindent "defclass" 2)
+
+;;; System forms.
+;;;
+(defindent "alien-bind" 1)
+(defindent "def-c-record" 1)
+(defindent "defrecord" 1)
+
+
+
+;;; Compute number of spaces which mark should be indented according to
+;;; local context and lisp grinding conventions.
+
+(defun lisp-indentation (mark)
+  (with-mark ((m mark)
+	      (temp mark))
+    (unless (valid-spot m nil)
+      (return-from lisp-indentation
+		   (lisp-generic-indentation m)))
+    (unless (backward-up-list m)
+      (return-from lisp-indentation 0))
+    (mark-after m)
+    (with-mark ((start m))
+      (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote)))
+		   (test-char (next-character m) :lisp-syntax :constituent))
+	(return-from lisp-indentation (mark-column start)))
+      (with-mark ((fstart m))
+	(scan-char m :lisp-syntax (not :constituent))
+	(let* ((fname (nstring-upcase (region-to-string (region fstart m))))
+	       (special-args (or (gethash fname *special-forms*)
+				 (and (> (length fname) 2)
+				      (string= fname "DEF" :end1 3)
+				      (value indent-defanything)))))
+	  (declare (simple-string fname))
+	  (cond (special-args
+		 (with-mark ((spec m))
+		   (cond ((and (form-offset spec special-args)
+			       (mark<= spec mark))
+			  (1+ (mark-column start)))
+			 ((skip-valid-space m)
+			  (mark-column m))
+			 (t
+			  (+ (mark-column start) 3)))))
+		((and (form-offset temp -1)
+		      (or (blank-before-p temp)
+			  (not (same-line-p temp fstart)))
+		      (not (same-line-p temp mark)))
+		 (unless (blank-before-p temp)
+		   (line-start temp)
+		   (find-attribute temp :space #'zerop))
+		 (mark-column temp))
+		((skip-valid-space m)
+		 (mark-column m))
+		(t
+		 (mark-column start))))))))
+
+(defun lisp-generic-indentation (mark)
+  (let* ((line (mark-line mark))
+	 (prev (do ((line (line-previous line) (line-previous line)))
+		   ((or (null line) (not (blank-line-p line))) line))))
+    (cond (prev 
+	   (line-start mark prev)
+	   (find-attribute mark :space #'zerop)
+	   (mark-column mark))
+	  (t 0))))
+
+;;; Skip-Valid-Space  --  Internal
+;;;
+;;;    Skip over any space on the line Mark is on, stopping at the first valid
+;;; non-space character.  If there is none on the line, return nil.
+;;;
+(defun skip-valid-space (mark)
+  (loop
+    (scan-char mark :lisp-syntax (not :space))
+    (let ((val (character-attribute :lisp-syntax
+				    (next-character mark))))
+      (cond ((eq val :newline) (return nil))
+	    ((valid-spot mark t) (return mark))))
+    (mark-after mark)))
+
+
+;;;; LISP Mode commands
+
+(defcommand "Defindent" (p)
+  "Define the Lisp indentation for the current function.
+  The indentation is a non-negative integer which is the number
+  of special arguments for the form.  Examples: 2 for Do, 1 for Dolist.
+  If a prefix argument is supplied, then delete the indentation information."
+  "Do a defindent, man!"
+  (declare (ignore p))
+  (with-mark ((m (current-point)))
+    (pre-command-parse-check m)
+    (unless (backward-up-list m) (editor-error))
+    (mark-after m)
+    (with-mark ((n m))
+      (scan-char n :lisp-syntax (not :constituent))
+      (let ((s (region-to-string (region m n))))
+	(declare (simple-string s))
+	(when (zerop (length s)) (editor-error))
+	(if p
+	    (defindent s nil)
+	    (let ((i (prompt-for-integer
+		      :prompt (format nil "Indentation for ~A: " s)
+		      :help "Number of special arguments.")))
+	      (when (minusp i)
+		(editor-error "Indentation must be non-negative."))
+	      (defindent s i))))))
+  (indent-command ()))
+
+(defcommand "Beginning of Defun" (p)
+  "Move the point to the beginning of a top-level form.
+  with an argument, skips the previous p top-level forms."
+  "Move the point to the beginning of a top-level form."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (if (minusp count)
+	(end-of-defun-command (- count))
+	(unless (top-level-offset point (- count))
+	  (editor-error)))))
+
+;;; "End of Defun", with a positive p (the normal case), does something weird.
+;;; Get a mark at the beginning of the defun, and then offset it forward one
+;;; less top level form than we want.  This sets us up to use FORM-OFFSET which
+;;; allows us to leave the point immediately after the defun.  If we used
+;;; TOP-LEVEL-OFFSET one less than p on the mark at the end of the current
+;;; defun, point would be left at the beginning of the p+1'st form instead of
+;;; at the end of the p'th form.
+;;;
+(defcommand "End of Defun" (p)
+  "Move the point to the end of a top-level form.
+   With an argument, skips the next p top-level forms."
+  "Move the point to the end of a top-level form."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (if (minusp count)
+	(beginning-of-defun-command (- count))
+	(with-mark ((m point)
+		    (dummy point))
+	  (cond ((not (mark-top-level-form m dummy))
+		 (editor-error "No current or next top level form."))
+		(t 
+		 (unless (top-level-offset m (1- count))
+		   (editor-error "Not enough top level forms."))
+		 ;; We might be one unparsed for away.
+		 (pre-command-parse-check m)
+		 (unless (form-offset m 1)
+		   (editor-error "Not enough top level forms."))
+		 (when (blank-after-p m) (line-offset m 1 0))
+		 (move-mark point m)))))))
+
+(defcommand "Forward List" (p)
+  "Skip over the next Lisp list.
+  With argument, skips the next p lists."
+  "Skip over the next Lisp list."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (unless (list-offset point count) (editor-error))))
+
+(defcommand "Backward List" (p)
+  "Skip over the previous Lisp list.
+  With argument, skips the previous p lists."
+  "Skip over the previous Lisp list."
+  (let ((point (current-point))
+	(count (- (or p 1))))
+    (pre-command-parse-check point)
+    (unless (list-offset point count) (editor-error))))
+
+(defcommand "Forward Form" (p)
+  "Skip over the next Form.
+  With argument, skips the next p Forms."
+  "Skip over the next Form."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (unless (form-offset point count) (editor-error))))
+
+(defcommand "Backward Form" (p)
+  "Skip over the previous Form.
+  With argument, skips the previous p Forms."
+  "Skip over the previous Form."
+  (let ((point (current-point))
+	(count (- (or p 1))))
+    (pre-command-parse-check point)
+    (unless (form-offset point count) (editor-error))))
+
+(defcommand "Mark Form" (p)
+  "Set the mark at the end of the next Form.
+   With a positive argument, set the mark after the following p
+   Forms. With a negative argument, set the mark before
+   the preceding -p Forms."
+  "Set the mark at the end of the next Form."
+  (with-mark ((m (current-point)))
+    (pre-command-parse-check m)
+    (let ((count (or p 1))
+	  (mark (push-buffer-mark (copy-mark m) t)))
+      (if (form-offset m count)
+	  (move-mark mark m)
+	  (editor-error)))))
+
+(defcommand "Mark Defun" (p)
+  "Puts the region around the next or containing top-level form.
+   The point is left before the form and the mark is placed immediately
+   after it."
+  "Puts the region around the next or containing top-level form."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (pre-command-parse-check point)
+    (with-mark ((start point)
+		(end point))
+      (cond ((not (mark-top-level-form start end))
+	     (editor-error "No current or next top level form."))
+	    (t
+	     (move-mark point start)
+	     (move-mark (push-buffer-mark (copy-mark point) t) end))))))
+
+(defcommand "Forward Kill Form" (p)
+  "Kill the next Form.
+   With a positive argument, kills the next p Forms.
+   Kills backward with a negative argument."
+  "Kill the next Form."
+  (with-mark ((m1 (current-point))
+	      (m2 (current-point)))
+    (pre-command-parse-check m1)
+    (let ((count (or p 1)))
+      (unless (form-offset m1 count) (editor-error))
+      (if (minusp count)
+	  (kill-region (region m1 m2) :kill-backward)
+	  (kill-region (region m2 m1) :kill-forward)))))
+
+(defcommand "Backward Kill Form" (p)
+  "Kill the previous Form.
+  With a positive argument, kills the previous p Forms.
+  Kills forward with a negative argument."
+  "Kill the previous Form."
+  (forward-kill-form-command (- (or p 1))))
+
+(defcommand "Extract List" (p)
+  "Extract the current list.
+  The current list replaces the surrounding list.  The entire affected
+  area is pushed on the kill-ring.  With prefix argument, remove that
+  many surrounding lists."
+  "Replace the P containing lists with the current one."
+  (let ((point (current-point)))
+    (pre-command-parse-check point)
+    (with-mark ((lstart point :right-inserting)
+		(lend point))
+      (if (eq (character-attribute :lisp-syntax (next-character lstart))
+	      :open-paren)
+	  (mark-after lend)
+	  (unless (backward-up-list lstart) (editor-error)))
+      (unless (forward-up-list lend) (editor-error))
+      (with-mark ((rstart lstart)
+		  (rend lend))
+	(dotimes (i (or p 1))
+	  (unless (and (forward-up-list rend) (backward-up-list rstart))
+	    (editor-error)))
+	(let ((r (copy-region (region lstart lend))))
+	  (ring-push (delete-and-save-region (region rstart rend))
+		     *kill-ring*)
+	  (ninsert-region point r)
+	  (move-mark point lstart))))))
+
+(defcommand "Transpose Forms" (p)
+  "Transpose Forms immediately preceding and following the point.
+  With a zero argument, tranposes the Forms at the point and the mark.
+  With a positive argument, transposes the Form preceding the point
+  with the p-th one following it.  With a negative argument, transposes the
+  Form following the point with the p-th one preceding it."
+  "Transpose Forms immediately preceding and following the point."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (if (zerop count)
+	(let ((mark (current-mark)))
+	  (with-mark ((s1 mark :left-inserting)
+		      (s2 point :left-inserting))
+	    (scan-char s1 :whitespace nil)
+	    (scan-char s2 :whitespace nil)
+	    (with-mark ((e1 s1 :right-inserting)
+			(e2 s2 :right-inserting))
+	      (unless (form-offset e1 1) (editor-error))
+	      (unless (form-offset e2 1) (editor-error))
+	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
+	      (ninsert-region s2 (delete-and-save-region (region s1 e1))))))
+	(let ((fcount (if (plusp count) count 1))
+	      (bcount (if (plusp count) 1 count)))
+	  (with-mark ((s1 point :left-inserting)
+		      (e2 point :right-inserting))
+	    (dotimes (i bcount)
+	      (unless (form-offset s1 -1) (editor-error)))
+	    (dotimes (i fcount)
+	      (unless (form-offset e2 1) (editor-error)))
+	    (with-mark ((e1 s1 :right-inserting)
+			(s2 e2 :left-inserting))
+	      (unless (form-offset e1 1) (editor-error))
+	      (unless (form-offset s2 -1) (editor-error))
+	      (ninsert-region s1 (delete-and-save-region (region s2 e2)))
+	      (ninsert-region s2 (delete-and-save-region (region s1 e1)))
+	      (move-mark point s2)))))))
+
+
+(defcommand "Indent Form" (p)
+  "Indent Lisp code in the next form."
+  "Indent Lisp code in the next form."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (pre-command-parse-check point)
+    (with-mark ((m point))
+      (unless (form-offset m 1) (editor-error))
+      (lisp-indent-region (region point m) "Indent Form"))))
+
+;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive
+;;; redundant computation.  We parse the entire region once, then scan through
+;;; doing indentation on each line.  We forcibly reparse each line that we
+;;; indent so that the list operations done to determine indentation of
+;;; subsequent lines will work.  This is done undoably with save1, save2,
+;;; buf-region, and undo-region.
+;;;
+(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting"))
+  (check-region-query-size region)
+  (let ((start (region-start region))
+	(end (region-end region)))
+    (with-mark ((m1 start)
+		(m2 end))
+      (funcall (value parse-start-function) m1)
+      (funcall (value parse-end-function) m2)
+      (parse-over-block (mark-line m1) (mark-line m2)))
+    (let* ((first-line (mark-line start))
+	   (last-line (mark-line end))
+	   (prev (line-previous first-line))
+	   (prev-line-info
+	    (and prev (getf (line-plist prev) 'lisp-info)))
+	   (save1 (line-start (copy-mark start :right-inserting)))
+	   (save2 (line-end (copy-mark end :left-inserting)))
+	   (buf-region (region save1 save2))
+	   (undo-region (copy-region buf-region)))
+      (with-mark ((bol start :left-inserting))
+	(do ((line first-line (line-next line)))
+	    (nil)
+	  (line-start bol line)
+	  (insert-lisp-indentation bol)
+	  (let ((line-info (getf (line-plist line) 'lisp-info)))
+	    (parse-lisp-line-info bol line-info prev-line-info)
+	    (setq prev-line-info line-info))
+	  (when (eq line last-line) (return nil))))
+      (make-region-undo :twiddle undo-text buf-region undo-region))))
+
+;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode.
+;;;
+(defun indent-for-lisp (mark)
+  (line-start mark)
+  (pre-command-parse-check mark)
+  (insert-lisp-indentation mark))
+
+(defun insert-lisp-indentation (m)
+  (delete-horizontal-space m)
+  (funcall (value indent-with-tabs) m (lisp-indentation m)))
+
+
+(defcommand "Insert ()" (p)
+  "Insert a pair of parentheses ().
+   With positive argument, puts parentheses around the next p
+   Forms.  The point is positioned after the open parenthesis."
+  "Insert a pair of parentheses ()."
+  (let ((point (current-point))
+	(count (or p 0)))
+    (pre-command-parse-check point)
+    (cond ((not (minusp count))
+	   (insert-character point #\()
+	   (with-mark ((tmark point))
+	     (unless (form-offset tmark count) (editor-error))
+	     (cond ((mark= tmark point)
+		    (insert-character point #\))
+		    (mark-before point))
+		   (t (insert-character tmark #\))))))
+	  (t (editor-error)))))
+
+
+(defcommand "Move Over )" (p)
+  "Move past the next close parenthesis, and start a new line.
+  Any indentation preceding the preceding the parenthesis is deleted,
+  and the new line is indented."
+  "Move past the next close parenthesis, and start a new line."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (pre-command-parse-check point)
+    (with-mark ((m point))
+      (cond ((scan-char m :lisp-syntax :close-paren)
+	     (delete-horizontal-space m)
+	     (mark-after m)
+	     (move-mark point m)
+	     (indent-new-line-command 1))
+	    (t (editor-error))))))
+
+
+(defcommand "Forward Up List" (p)
+  "Move forward past a one containing )."
+  "Move forward past a one containing )."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (if (minusp count)
+	(backward-up-list-command (- count))
+	(with-mark ((m point))
+	  (dotimes (i count (move-mark point m))
+	    (unless (forward-up-list m) (editor-error)))))))
+
+
+(defcommand "Backward Up List" (p)
+  "Move backward past a one containing (."
+  "Move backward past a one containing (."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (if (minusp count)
+	(forward-up-list-command (- count))
+	(with-mark ((m point))
+	  (dotimes (i count (move-mark point m))
+	    (unless (backward-up-list m) (editor-error)))))))
+
+
+(defcommand "Down List" (p)
+  "Move down a level in list structure.
+  With argument, moves down p levels."
+  "Move down a level in list structure."
+  (let ((point (current-point))
+	(count (or p 1)))
+    (pre-command-parse-check point)
+    (with-mark ((m point))
+      (dotimes (i count (move-mark point m))
+	(unless (and (scan-char m :lisp-syntax :open-paren)
+		     (mark-after m))
+	  (editor-error))))))
+
+
+
+;;;; "Lisp Mode".
+
+(defcommand "LISP Mode" (p)
+  "Put current buffer in LISP mode." 
+  "Put current buffer in LISP mode."  
+  (declare (ignore p))
+  (setf (buffer-major-mode (current-buffer)) "LISP"))
+
+
+(defmode "Lisp" :major-p t :setup-function 'setup-lisp-mode)
+
+(defun setup-lisp-mode (buffer)
+  (unless (hemlock-bound-p 'current-package :buffer buffer)
+    (defhvar "Current Package"
+      "The package used for evaluation of Lisp in this buffer."
+      :buffer buffer
+      :value "USER")))
+
+
+
+;;;; Matching parenthesis display.
+
+(defhvar "Paren Pause Period"
+  "This is how long commands that deal with \"brackets\" shows the cursor at
+   the matching \"bracket\" for this number of seconds."
+  :value 0.5)
+
+(defcommand "Lisp Insert )" (p)
+  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
+  "Inserts a \")\" and briefly positions the cursor at the matching \"(\"."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (insert-character point #\))
+    (pre-command-parse-check point)
+    (when (valid-spot point nil) 
+      (with-mark ((m point))
+	(if (list-offset m -1)
+	    (let ((pause (value paren-pause-period))
+		  (win (current-window)))
+	      (if pause
+		  (unless (show-mark m win pause)
+		    (clear-echo-area)
+		    (message "~A" (line-string (mark-line m))))
+		  (unless (displayed-p m (current-window))
+		    (clear-echo-area)
+		    (message "~A" (line-string (mark-line m))))))
+	    (editor-error))))))
+
+;;; Since we use paren highlighting in Lisp mode, we do not want paren
+;;; flashing too.
+;;; 
+(defhvar "Paren Pause Period"
+  "This is how long commands that deal with \"brackets\" shows the cursor at
+   the matching \"bracket\" for this number of seconds."
+  :value nil
+  :mode "Lisp")
+;;;
+(defhvar "Highlight Open Parens"
+  "When non-nil, causes open parens to be displayed in a different font when
+   the cursor is directly to the right of the corresponding close paren."
+  :value t
+  :mode "Lisp")
+
+
+
+;;;; Some mode variables to coordinate with other stuff.
+
+(defhvar "Auto Fill Space Indent"
+  "When non-nil, uses \"Indent New Comment Line\" to break lines instead of
+   \"New Line\"."
+  :mode "Lisp" :value t)
+
+(defhvar "Comment Start"
+  "String that indicates the start of a comment."
+  :mode "Lisp" :value ";")
+
+(defhvar "Comment Begin"
+  "String that is inserted to begin a comment."
+  :mode "Lisp" :value "; ")
+
+(defhvar "Indent Function"
+  "Indentation function which is invoked by \"Indent\" command.
+   It must take one argument that is the prefix argument."
+  :value 'indent-for-lisp
+  :mode "Lisp")
diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8f018c28b0195eb656f8e404f4421c1b61cd894f
--- /dev/null
+++ b/hemlock/morecoms.lisp
@@ -0,0 +1,825 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Written by Bill Chiles and Rob MacLachlan.
+;;;
+;;; Even more commands...
+
+(in-package "HEMLOCK")
+
+(defhvar "Region Query Size"
+  "A number-of-lines threshold that destructive, undoable region commands
+   should ask the user about when the indicated region is too big."
+  :value 30)
+
+(defun check-region-query-size (region)
+  "Checks the number of lines in region against \"Region Query Size\" and
+   asks the user if the region crosses this threshold.  If the user responds
+   negatively, then an editor error is signaled."
+  (let ((threshold (or (value region-query-size) 0)))
+    (if (and (plusp threshold)
+	     (>= (count-lines region) threshold)
+	     (not (prompt-for-y-or-n
+		   :prompt "Region size exceeds \"Region Query Size\".  Confirm: "
+		   :must-exist t)))
+	(editor-error))))
+
+
+
+;;;; Casing commands...
+
+(defcommand "Uppercase Word" (p)
+  "Uppercase a word at point.
+   With prefix argument uppercase that many words."
+  "Uppercase p words at the point."
+  (filter-words p (current-point) #'string-upcase))
+
+(defcommand "Lowercase Word" (p)
+  "Uppercase a word at point.
+   With prefix argument uppercase that many words."
+  "Uppercase p words at the point."
+  (filter-words p (current-point) #'string-downcase))
+
+;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word".
+;;;
+(defun filter-words (p point function)
+  (let ((arg (or p 1)))
+    (with-mark ((mark point))
+      (if (word-offset (if (minusp arg) mark point) arg)
+	  (filter-region function (region mark point))
+	  (editor-error "Not enough words.")))))
+
+;;; "Capitalize Word" is different than uppercasing and lowercasing because
+;;; the differences between Hemlock's notion of what a word is and Common
+;;; Lisp's notion are too annoying.
+;;;
+(defcommand "Capitalize Word" (p)
+  "Lowercase a word capitalizing the first character.  With a prefix
+  argument, capitalize that many words.  A negative argument capitalizes
+  words before the point, but leaves the point where it was."
+  "Capitalize p words at the point."
+  (let ((point (current-point))
+	(arg (or p 1)))
+    (with-mark ((start point :left-inserting)
+		(end point))
+      (when (minusp arg)
+	(unless (word-offset start arg) (editor-error "No previous word.")))
+      (do ((region (region start end))
+	   (cnt (abs arg) (1- cnt)))
+	  ((zerop cnt) (move-mark point end))
+	(unless (find-attribute start :word-delimiter #'zerop)
+	  (editor-error "No next word."))
+	(move-mark end start)
+	(find-attribute end :word-delimiter)
+	(loop
+	  (when (mark= start end)
+	    (move-mark point end)
+	    (editor-error "No alphabetic characters in word."))
+	  (when (alpha-char-p (next-character start)) (return))
+	  (character-offset start 1))
+	(setf (next-character start) (char-upcase (next-character start)))
+	(mark-after start)
+	(filter-region #'string-downcase region)))))
+
+(defcommand "Uppercase Region" (p)
+  "Uppercase words from point to mark."
+  "Uppercase words from point to mark."
+  (declare (ignore p))
+  (twiddle-region (current-region) #'string-upcase "Uppercase Region"))
+
+(defcommand "Lowercase Region" (p)
+  "Lowercase words from point to mark."
+  "Lowercase words from point to mark."
+  (declare (ignore p))
+  (twiddle-region (current-region) #'string-downcase "Lowercase Region"))
+
+;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region".
+;;;
+(defun twiddle-region (region function name)
+  (let* (;; don't delete marks start and end since undo stuff will.
+	 (start (copy-mark (region-start region) :left-inserting))
+	 (end (copy-mark (region-end region) :left-inserting)))
+    (let* ((region (region start end))
+	   (undo-region (copy-region region)))
+      (check-region-query-size region)
+      (filter-region function region)
+      (make-region-undo :twiddle name region undo-region))))
+
+
+
+;;;; More stuff.
+
+(defcommand "Delete Previous Character Expanding Tabs" (p)
+  "Delete the previous character.
+  When deleting a tab pretend it is the equivalent number of spaces.
+  With prefix argument, do it that many times."
+  "Delete the P previous characters, expanding tabs into spaces."
+  (let ((point (current-point))
+        (n (or p 1)))
+    (when (minusp n)
+      (editor-error "Delete Previous Character Expanding Tabs only accepts ~
+                     positive arguments."))
+    (let ((errorp nil))
+      (with-mark ((mark point :left-inserting))
+	(dotimes (i n)
+	  (cond ((char= (previous-character mark) #\tab)
+		 (let ((pos (mark-column mark)))
+		   (delete-characters mark -1)
+		   (dotimes (i (- pos (mark-column mark)))
+		     (insert-character mark #\space))
+		   (mark-before mark)))
+		((mark-before mark))
+		(t (return)))))
+      (kill-characters point (- n))
+      (when errorp
+	(editor-error "There were not ~D characters before point." n)))))
+
+
+(defvar *scope-table*
+  (list (make-string-table :initial-contents
+			   '(("Global" . :global)
+			     ("Buffer" . :buffer)
+			     ("Mode" . :mode)))))
+
+(defun prompt-for-place (prompt help)
+  (multiple-value-bind (word val)
+		       (prompt-for-keyword *scope-table* :prompt prompt
+					   :help help :default "Global")
+    (declare (ignore word))
+    (case val
+      (:buffer
+       (values :buffer (prompt-for-buffer :help "Buffer to be local to."
+					  :default (current-buffer))))
+      (:mode
+       (values :mode (prompt-for-keyword 
+		      (list *mode-names*)
+		      :prompt "Mode: "
+		      :help "Mode to be local to."
+		      :default (buffer-major-mode (current-buffer)))))
+      (:global :global))))
+
+(defcommand "Bind Key" (p)
+  "Bind a command to a key.
+  The command, key and place to make the binding are prompted for."
+  "Prompt for stuff to do a bind-key."
+  (declare (ignore p))
+  (multiple-value-call #'bind-key 
+    (values (prompt-for-keyword 
+	     (list *command-names*)
+	     :prompt "Command to bind: "
+	     :help "Name of command to bind to a key."))
+    (values (prompt-for-key 
+	     :prompt "Bind to: "  :must-exist nil
+	     :help "Key to bind command to, confirm to complete."))
+    (prompt-for-place "Kind of binding: "
+		      "The kind of binding to make.")))	    	    
+
+(defcommand "Delete Key Binding" (p)
+  "Delete a key binding.
+  The key and place to remove the binding are prompted for."
+  "Prompt for stuff to do a delete-key-binding."
+  (declare (ignore p))
+  (let ((key (prompt-for-key 
+	      :prompt "Delete binding: " :must-exist nil 
+	      :help "Key to delete binding from.")))
+    (multiple-value-bind (kind where)
+			 (prompt-for-place "Kind of binding: "
+					   "The kind of binding to make.")
+      (unless (get-command key kind where) 
+	(editor-error "No such binding: ~S" key))
+      (delete-key-binding key kind where))))
+
+
+(defcommand "Set Variable" (p)
+  "Prompt for a Hemlock variable and a new value."
+  "Prompt for a Hemlock variable and a new value."
+  (declare (ignore p))
+  (multiple-value-bind (name var)
+		       (prompt-for-variable
+			:prompt "Variable: "
+			:help "The name of a variable to set.")
+    (declare (ignore name))
+    (setf (variable-value var)
+	  (handle-lisp-errors
+	   (eval (prompt-for-expression
+		  :prompt "Value: "
+		  :help "Expression to evaluate for new value."))))))
+
+(defcommand "Defhvar" (p)
+  "Define a hemlock variable in some location.  If the named variable exists
+   currently, its documentation is propagated to the new instance, but this
+   never prompts for documentation."
+  "Define a hemlock variable in some location."
+  (declare (ignore p))
+  (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil)))
+	 (var (string-to-variable name))
+	 (doc (if (hemlock-bound-p var)
+		  (variable-documentation var)
+		  ""))
+	 (hooks (if (hemlock-bound-p var) (variable-hooks var)))
+	 (val (prompt-for-expression :prompt "Variable value: "
+				     :help "Value for the variable.")))
+    (multiple-value-bind
+	(kind where)
+	(prompt-for-place
+	 "Kind of binding: "
+	 "Whether the variable is global, mode, or buffer specific.")
+      (if (eq kind :global)
+	  (defhvar name doc :value val :hooks hooks)
+	  (defhvar name doc kind where :value val :hooks hooks)))))
+
+
+(defcommand "List Buffers" (p)
+  "Show a list of all buffers.
+   If the buffer is modified then a * is displayed before the name.  If there
+   is an associated file then it's name is displayed last.  With prefix
+   argument, only list modified buffers."
+  "Display the names of all buffers in a with-random-typeout window."
+  (with-pop-up-display (s)
+    (do-strings (n b *buffer-names*)
+      (declare (simple-string n))
+      (unless (or (eq b *echo-area-buffer*)
+		  (assoc b *random-typeout-buffers* :test #'eq))
+	(let ((modified (buffer-modified b))
+	      (buffer-pathname (buffer-pathname b)))
+	  (when (or (not p) modified)
+	    (write-char (if modified #\* #\space) s)
+	    (if buffer-pathname
+		(format s "~A  ~25T~A~:[~68T~A~;~]~%"
+			(file-namestring buffer-pathname)
+			(directory-namestring buffer-pathname)
+			(string= (pathname-to-buffer-name buffer-pathname) n)
+			n)
+		(format s "~A~68T~D Line~:P~%"
+			n (count-lines (buffer-region b))))))))))
+
+(defcommand "Select Random Typeout Buffer" (p)
+  "Select last random typeout buffer."
+  "Select last random typeout buffer."
+  (declare (ignore p))
+  (if *random-typeout-buffers*
+      (change-to-buffer (caar *random-typeout-buffers*))
+      (editor-error "There are no random typeout buffers.")))
+
+
+(defcommand "Room" (p)
+  "Display stats on allocated storage."
+  "Run Room into a With-Random-Typeout window."
+  (declare (ignore p))
+  (with-pop-up-display (*standard-output* :height 19)
+    (room)))
+
+
+;;; This is used by the :edit-level modeline field which is defined in Main.Lisp.
+;;;
+(defvar *recursive-edit-count* 0)
+
+(defun do-recursive-edit ()
+  "Does a recursive edit, wrapping []'s around the modeline of the current
+  window during its execution.  The current window and buffer are saved
+  beforehand and restored afterward.  If they have been deleted by the
+  time the edit is done then an editor-error is signalled."
+  (let* ((win (current-window))
+	 (buf (current-buffer)))
+    (unwind-protect
+	(let ((*recursive-edit-count* (1+ *recursive-edit-count*)))
+	  (update-modeline-field *echo-area-buffer* *echo-area-window*
+				 (modeline-field :edit-level))
+	  (recursive-edit))
+      (update-modeline-field *echo-area-buffer* *echo-area-window*
+			     (modeline-field :edit-level))
+      (unless (and (memq win *window-list*) (memq buf *buffer-list*))
+	(editor-error "Old window or buffer has been deleted."))
+      (setf (current-window) win)
+      (unless (eq (window-buffer win) buf)
+	(setf (window-buffer win) buf))
+      (setf (current-buffer) buf))))
+
+(defcommand "Exit Recursive Edit" (p)
+  "Exit a level of recursive edit.  Signals an error when not in a
+   recursive edit."
+  "Exit a level of recursive edit.  Signals an error when not in a
+   recursive edit."
+  (declare (ignore p))
+  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
+  (exit-recursive-edit ()))
+
+(defcommand "Abort Recursive Edit" (p)
+  "Abort the current recursive edit.  Signals an error when not in a
+   recursive edit."
+  "Abort the current recursive edit.  Signals an error when not in a
+   recursive edit."
+  (declare (ignore p))
+  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
+  (abort-recursive-edit "Recursive edit aborted."))
+
+
+;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current
+;;; region is not active and to get start2 and end2 in proper order.  Delete1,
+;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the
+;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which
+;;; marks to dispose of at the end of all this stuff.  When we actually get to
+;;; swapping the regions, we must delete both up front if they both are to be
+;;; deleted since we don't know what kind of marks are in start1, start2, end1,
+;;; and end2, and the marks will be moving around unpredictably as we insert
+;;; text at them.  We copy point into ipoint for insertion purposes since one
+;;; of our four marks is the point.
+;;; 
+(defcommand "Transpose Regions" (p)
+  "Transpose two regions with endpoints defined by the mark stack and point.
+   To use:  mark start of region1, mark end of region1, mark start of region2,
+   and place point at end of region2.  Invoking this immediately following
+   one use will put the regions back, but you will have to activate the
+   current region."
+  "Transpose two regions with endpoints defined by the mark stack and point."
+  (declare (ignore p))
+  (unless (>= (ring-length (value buffer-mark-ring)) 3)
+    (editor-error "Need two marked regions to do Transpose Regions."))
+  (let* ((region (current-region))
+	 (end2 (region-end region))
+	 (start2 (region-start region))
+	 (delete1 (pop-buffer-mark))
+	 (end1 (pop-buffer-mark))
+	 (delete2 end1)
+	 (start1 (pop-buffer-mark))
+	 (delete3 start1))
+    ;;get marks in the right order, to simplify the code that follows
+    (unless (mark<= start1 end1) (rotatef start1 end1))
+    (unless (mark<= start1 start2)
+      (rotatef start1 start2)
+      (rotatef end1 end2))
+    ;;order now guaranteed:  <Buffer Start> start1 end1 start2 end2 <Buffer End>
+    (unless (mark<= end1 start2)
+      (editor-error "Can't transpose overlapping regions."))
+    (let* ((adjacent-p (mark= end1 start2))
+	   (region1 (delete-and-save-region (region start1 end1)))
+	   (region2 (unless adjacent-p
+		      (delete-and-save-region (region start2 end2))))
+	   (point (current-point)))
+      (with-mark ((ipoint point :left-inserting))
+	(let ((save-end2-loc (push-buffer-mark (copy-mark end2))))
+	  (ninsert-region (move-mark ipoint end2) region1)
+	  (push-buffer-mark (copy-mark ipoint))
+	  (cond (adjacent-p
+		 (push-buffer-mark (copy-mark start2))
+		 (move-mark point save-end2-loc))
+		(t (push-buffer-mark (copy-mark end1))
+		   (ninsert-region (move-mark ipoint end1) region2)
+		   (move-mark point ipoint))))))
+    (delete-mark delete1)
+    (delete-mark delete2)
+    (delete-mark delete3)))
+
+
+(defcommand "Goto Absolute Line" (p)
+  "Goes to the indicated line, if you counted them starting at the beginning
+   of the buffer with the number one.  If a prefix argument is supplied, that
+   is the line numbe; otherwise, the user is prompted."
+  "Go to a user perceived line number."
+  (let ((p (or p (prompt-for-expression
+		  :prompt "Line number: "
+		  :help "Enter an absolute line number to goto."))))
+    (unless (and (integerp p) (plusp p))
+      (editor-error "Must supply a positive integer."))
+    (let ((point (current-point)))
+      (with-mark ((m point))
+	(unless (line-offset (buffer-start m) (1- p) 0)
+	  (editor-error "Not enough lines in buffer."))
+	(move-mark point m)))))
+
+
+
+;;;; Mouse Commands.
+
+(defcommand "Do Nothing" (p)
+  "Do nothing.
+  With prefix argument, do it that many times."
+  "Do nothing p times."
+  (dotimes (i (or p 1)))
+  (setf (last-command-type) (last-command-type)))
+
+(defun maybe-change-window (window)
+  (unless (eq window (current-window))
+    (when (or (eq window *echo-area-window*)
+	      (eq (current-window) *echo-area-window*)
+	      (member window *random-typeout-buffers*
+		      :key #'(lambda (cons)
+			       (hi::random-typeout-stream-window (cdr cons)))))
+      (supply-generic-pointer-up-function #'lisp::do-nothing)
+      (editor-error "I'm afraid I can't let you do that Dave."))
+    (setf (current-window) window)
+    (let ((buffer (window-buffer window)))
+      (unless (eq (current-buffer) buffer)
+	(setf (current-buffer) buffer)))))
+
+(defcommand "Top Line to Here" (p)
+  "Move the top line to the line the mouse is on.
+  If in the first two columns then scroll continuously until the button is
+  released."
+  "Move the top line to the line the mouse is on."
+  (declare (ignore p))
+  (multiple-value-bind (x y window)
+		       (last-key-event-cursorpos)
+    (unless y (editor-error))
+    (cond ((< x 2)
+	   (do ((ch (read-char-no-hang *editor-input*)
+		    (read-char-no-hang *editor-input*)))
+	       (ch)
+	     (scroll-window window -1)
+	     (redisplay)
+	     (editor-finish-output window)))
+	  (t
+	   (scroll-window window (- y))))))
+
+(defcommand "Here to Top of Window" (p)
+  "Move the line the mouse is on to the top of the window.
+  If in the first two columns then scroll continuously until the button is
+  released."
+  "Move the line the mouse is on to the top of the window."
+  (declare (ignore p))
+  (multiple-value-bind (x y window)
+		       (last-key-event-cursorpos)
+    (unless y (editor-error))
+    (cond ((< x 2)
+	   (do ((ch (read-char-no-hang *editor-input*)
+		    (read-char-no-hang *editor-input*)))
+	       (ch)
+	     (scroll-window window 1)
+	     (redisplay)
+	     (editor-finish-output window)))
+	  (t
+	   (scroll-window window y)))))
+
+
+(defvar *generic-pointer-up-fun* nil
+  "This is the function for the \"Generic Pointer Up\" command that defines
+   its action.  Other commands set this in preparation for this command's
+   invocation.")
+;;;
+(defun supply-generic-pointer-up-function (fun)
+  "This provides the action \"Generic Pointer Up\" command performs."
+  (check-type fun function)
+  (setf *generic-pointer-up-fun* fun))
+
+(defcommand "Generic Pointer Up" (p)
+  "Other commands determine this command's action by supplying functions that
+   this command invokes.  The following built-in commands supply the following
+   generic up actions:
+      \"Point to Here\"
+         When the position of the pointer is different than the current
+	 point, the action pushes a buffer mark at point and moves point
+         to the pointer's position.
+      \"Bufed Goto and Quit\"
+         The action is a no-op."
+  "Invoke whatever is on *generic-pointer-up-fun*."
+  (declare (ignore p))
+  (unless *generic-pointer-up-fun*
+    (editor-error "No commands have supplied a \"Generic Pointer Up\" action."))
+  (funcall *generic-pointer-up-fun*))
+
+
+(defcommand "Point to Here" (p)
+  "Move the point to the position of the mouse.
+   If in the modeline, move to the absolute position in the file indicated by
+   the position within the modeline, pushing the old position on the mark
+   stack.  This supplies a function \"Generic Pointer Up\" invokes if it runs
+   without any intervening generic pointer up predecessors running.  If the
+   position of the pointer is different than the current point when the user
+   invokes \"Generic Pointer Up\", then this function pushes a buffer mark at
+   point and moves point to the pointer's position.  This allows the user to
+   mark off a region with the mouse."
+  "Move the point to the position of the mouse."
+  (declare (ignore p))
+  (multiple-value-bind (x y window)
+		       (last-key-event-cursorpos)
+    (unless x (editor-error))
+    (maybe-change-window window)
+    (if y
+	(let ((m (cursorpos-to-mark x y window)))
+	  (unless m (editor-error))
+	  (move-mark (current-point) m))
+	(let* ((buffer (window-buffer window))
+	       (region (buffer-region buffer))
+	       (point (buffer-point buffer)))
+	  (push-buffer-mark (copy-mark point))
+	  (move-mark point (region-start region))
+	  (line-offset point (round (* (1- (count-lines region)) x)
+				    (1- (window-width window)))))))
+  (supply-generic-pointer-up-function #'point-to-here-up-action))
+
+(defun point-to-here-up-action ()
+  (multiple-value-bind (x y window)
+		       (last-key-event-cursorpos)
+    (unless x (editor-error))
+    (when y
+      (maybe-change-window window)
+      (let ((m (cursorpos-to-mark x y window)))
+	(unless m (editor-error))
+	(when (eq (line-buffer (mark-line (current-point)))
+		  (line-buffer (mark-line m)))
+	  (unless (mark= m (current-point))
+	    (push-buffer-mark (copy-mark (current-point)) t)))
+	(move-mark (current-point) m)))))
+
+
+(defcommand "Insert Kill Buffer" (p)
+  "Move current point to the mouse location and insert the kill buffer."
+  "Move current point to the mouse location and insert the kill buffer."
+  (declare (ignore p))
+  (multiple-value-bind (x y window)
+		       (last-key-event-cursorpos)
+    (unless x (editor-error))
+    (maybe-change-window window)
+    (if y
+	(let ((m (cursorpos-to-mark x y window)))
+	  (unless m (editor-error))
+	  (move-mark (current-point) m)
+	  (un-kill-command nil))
+	(editor-error "Can't insert kill buffer in modeline."))))
+
+
+
+;;;; Page commands & stuff.
+
+(defvar *goto-page-last-num* 0)
+(defvar *goto-page-last-string* "")
+
+(defcommand "Goto Page" (p)
+  "Go to an absolute page number (argument).  If no argument, then go to
+  next page.  A negative argument moves back that many pages if possible.
+  If argument is zero, prompt for string and goto page with substring
+  in title."
+  "Go to an absolute page number (argument).  If no argument, then go to
+  next page.  A negative argument moves back that many pages if possible.
+  If argument is zero, prompt for string and goto page with substring
+  in title."
+  (let ((point (current-point)))
+    (cond ((not p)
+	   (page-offset point 1))
+	  ((zerop p)
+	   (let* ((againp (eq (last-command-type) :goto-page-zero))
+		  (name (prompt-for-string :prompt "Substring of page title: "
+					   :default (if againp
+							*goto-page-last-string*
+							*parse-default*)))
+		  (dir (page-directory (current-buffer)))
+		  (i 1))
+	     (declare (simple-string name))
+	     (cond ((not againp)
+		    (push-buffer-mark (copy-mark point)))
+		   ((string-equal name *goto-page-last-string*)
+		    (setf dir (nthcdr *goto-page-last-num* dir))
+		    (setf i (1+ *goto-page-last-num*))))
+	     (loop 
+	       (when (null dir)
+		 (editor-error "No page title contains ~S." name))
+	       (when (search name (the simple-string (car dir))
+			     :test #'char-equal)
+		 (goto-page point i)
+		 (setf (last-command-type) :goto-page-zero)
+		 (setf *goto-page-last-num* i)
+		 (setf *goto-page-last-string* name)
+		 (return t))
+	       (incf i)
+	       (setf dir (cdr dir)))))
+	    ((minusp p)
+	     (page-offset point p))
+	    (t (goto-page point p)))
+    (line-start (move-mark (window-display-start (current-window)) point))))
+
+(defun goto-page (mark i)
+  (with-mark ((m mark))
+    (buffer-start m)
+    (unless (page-offset m (1- i))
+      (editor-error "No page numbered ~D." i))
+    (move-mark mark m)))
+
+			   
+(defcommand "View Page Directory" (p)
+  "Print a listing of the first non-blank line after each page mark
+   in a pop-up window."
+  "Print a listing of the first non-blank line after each page mark
+   in a pop-up window."
+  (declare (ignore p))
+  (let ((dir (page-directory (current-buffer))))
+    (declare (list dir))
+    (with-pop-up-display (s :height (1+ (the fixnum (length dir))))
+      (display-page-directory s dir))))
+
+(defcommand "Insert Page Directory" (p)
+  "Insert a listing of the first non-blank line after each page mark at
+   the beginning of the buffer.  A mark is dropped before going to the
+   beginning of the buffer.  If an argument is supplied, insert the page
+   directory at point."
+  "Insert a listing of the first non-blank line after each page mark at
+   the beginning of the buffer."
+  (declare (ignore p))
+  (let ((point (current-point)))
+    (unless p
+      (push-buffer-mark (copy-mark point))
+      (buffer-start point))
+    (push-buffer-mark (copy-mark point))
+    (display-page-directory (make-hemlock-output-stream point :full)
+			    (page-directory (current-buffer))))
+  (setf (last-command-type) :ephemerally-active))
+
+(defun display-page-directory (stream directory)
+  "This writes the list of strings, directory, to stream, enumerating them
+   in a field of three characters.  The number and string are separated by
+   two spaces, and the first line contains headings for the numbers and
+   strings columns."
+  (write-line "Page    First Non-blank Line" stream)
+  (do ((dir directory (cdr dir))
+       (count 1 (1+ count)))
+      ((null dir))
+    (declare (fixnum count))
+    (format stream "~3D  " count)
+    (write-line (car dir) stream)))
+
+(defun page-directory (buffer)
+  "Return a list of strings where each is the first non-blank line
+   following a :page-delimiter in buffer."
+  (with-mark ((m (buffer-point buffer)))
+    (buffer-start m)
+    (let ((end-of-buffer (buffer-end-mark buffer)) result)
+      (loop ;over pages.
+	(loop ;for first non-blank line.
+	  (cond ((not (blank-after-p m))
+		 (let* ((str (line-string (mark-line m)))
+			(len (length str)))
+		   (declare (simple-string str))
+		   (push (if (and (> len 1)
+				  (= (character-attribute :page-delimiter
+							  (schar str 0))
+				     1))
+			     (subseq str 1)
+			     str)
+			 result))
+		 (unless (page-offset m 1)
+		   (return-from page-directory (nreverse result)))
+		 (when (mark= m end-of-buffer)
+		   (return-from page-directory (nreverse result)))
+		 (return))
+		((not (line-offset m 1 0))
+		 (return-from page-directory (nreverse result)))
+		((= (character-attribute :page-delimiter (next-character m))
+		    1)
+		 (push "" result)
+		 (mark-after m)
+		 (return))))))))
+
+
+(defcommand "Previous Page" (p)
+  "Move to the beginning of the current page.
+  With prefix argument move that many pages."
+  "Move backward P pages."
+  (let ((point (current-point)))
+    (unless (page-offset point (- (or p 1)))
+      (editor-error "No such page."))
+    (line-start (move-mark (window-display-start (current-window)) point))))
+
+(defcommand "Next Page" (p)
+  "Move to the beginning of the next page.
+  With prefix argument move that many pages."
+  "Move forward P pages."
+  (let ((point (current-point)))
+    (unless (page-offset point (or p 1))
+      (editor-error "No such page."))
+    (line-start (move-mark (window-display-start (current-window)) point))))
+
+(defcommand "Mark Page" (p)
+  "Put point at beginning, mark at end of current page.
+   With prefix argument, mark the page that many pages after the current one."
+  "Mark the P'th page after the current one."
+  (let ((point (current-point)))
+    (if p
+	(unless (page-offset point (1+ p)) (editor-error "No such page."))
+	(page-offset point 1)) ;If this loses, we're at buffer-end.
+    (with-mark ((m point))
+      (unless (page-offset point -1)
+	(editor-error "No such page."))
+      (push-buffer-mark (copy-mark m) t)
+      (line-start (move-mark (window-display-start (current-window)) point)))))
+
+(defun page-offset (mark n)
+  "Move mark past n :page-delimiters that are in the zero'th line position.
+   If a :page-delimiter is the immediately next character after mark in the
+   appropriate direction, then skip it before starting."
+  (cond ((plusp n)
+	 (find-attribute mark :page-delimiter #'zerop)
+	 (dotimes (i n mark)
+	   (unless (next-character mark) (return nil))
+	   (loop
+	     (unless (find-attribute mark :page-delimiter)
+	       (return-from page-offset nil))
+	     (unless (mark-after mark)
+	       (return (if (= i (1- n)) mark)))
+	     (when (= (mark-charpos mark) 1) (return)))))
+	(t
+	 (reverse-find-attribute mark :page-delimiter #'zerop)
+	 (prog1
+	  (dotimes (i (- n) mark)
+	    (unless (previous-character mark) (return nil))
+	    (loop
+	      (unless (reverse-find-attribute mark :page-delimiter)
+		(return-from page-offset nil))
+	      (mark-before mark)
+	      (when (= (mark-charpos mark) 0) (return))))
+	  (let ((buffer (line-buffer (mark-line mark))))
+	    (unless (or (not buffer) (mark= mark (buffer-start-mark buffer)))
+	      (mark-after mark)))))))
+
+
+
+;;;; Counting some stuff
+
+(defcommand "Count Lines Page" (p)
+  "Display number of lines in current page and position within page.
+   With prefix argument do on entire buffer."
+  "Count some lines, Man."
+  (let ((point (current-point)))
+    (if p
+	(let ((r (buffer-region (current-buffer))))
+	  (count-lines-function "Buffer" (region-start r) point (region-end r)))
+	(with-mark ((m1 point)
+		    (m2 point))
+	  (unless (and (= (character-attribute :page-delimiter
+					       (previous-character m1))
+			  1)
+		       (= (mark-charpos m1) 1))
+	    (page-offset m1 -1))
+	  (unless (and (= (character-attribute :page-delimiter
+					       (next-character m2))
+			  1)
+		       (= (mark-charpos m2) 0))
+	    (page-offset m2 1))
+	  (count-lines-function "Page" m1 point m2)))))
+
+(defun count-lines-function (msg start mark end)
+  (let ((before (1- (count-lines (region start mark))))
+	(after (count-lines (region mark end))))
+    (message "~A: ~D lines, ~D/~D" msg (+ before after) before after)))
+
+(defcommand "Count Lines" (p)
+  "Display number of lines in the region."
+  "Display number of lines in the region."
+  (declare (ignore p))
+  (multiple-value-bind (region activep) (get-count-region)
+    (message "~:[After point~;Active region~]: ~A lines"
+	     activep (count-lines region))))
+
+(defcommand "Count Words" (p)
+  "Prints in the Echo Area the number of words in the region
+   between the point and the mark by using word-offset. The
+   argument is ignored."
+  "Prints Number of Words in the Region"
+  (declare (ignore p))
+  (multiple-value-bind (region activep) (get-count-region)
+    (let ((end-mark (region-end region)))
+      (with-mark ((beg-mark (region-start region)))
+	(let ((word-count 0))
+	  (loop
+	    (when (mark>= beg-mark end-mark)
+	      (return))
+	    (unless (word-offset beg-mark 1)
+	      (return))
+	    (incf word-count))
+	  (message "~:[After point~;Active region~]: ~D Word~:P"
+		   activep word-count))))))
+
+;;; GET-COUNT-REGION -- Internal Interface.
+;;;
+;;; Returns the active region or the region between point and end-of-buffer.
+;;; As a second value, it returns whether the region was active.
+;;;
+;;; Some searching commands use this routine.
+;;;
+(defun get-count-region ()
+  (if (region-active-p)
+      (values (current-region) t)
+      (values (region (current-point) (buffer-end-mark (current-buffer)))
+	      nil)))
+
+
+
+;;;; Some modes:
+
+(defcommand "Fundamental Mode" (p)
+  "Put the current buffer into \"Fundamental\" mode."
+  "Put the current buffer into \"Fundamental\" mode."
+  (declare (ignore p))
+  (setf (buffer-major-mode (current-buffer)) "Fundamental"))
+
+(defmode "Text" :major-p t)
+(defcommand "Text Mode" (p)
+  "Put the current buffer into \"Text\" mode."
+  "Put the current buffer into \"Text\" mode."
+  (declare (ignore p))
+  (setf (buffer-major-mode (current-buffer)) "Text"))
diff --git a/hemlock/pop-up-stream.lisp b/hemlock/pop-up-stream.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..48b548f242e87344886abe6742f821681d8386ad
--- /dev/null
+++ b/hemlock/pop-up-stream.lisp
@@ -0,0 +1,225 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contatins the stream operations for pop-up-displays.
+;;;
+;;; Written by Blaine Burks.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+
+
+;;;; Line-buffered Stream Methods.
+
+(defun random-typeout-line-out (stream char)
+  (insert-character (random-typeout-stream-mark stream) char)
+  (when (and (char= char #\newline)
+	     (not (random-typeout-stream-no-prompt stream)))
+    (funcall (device-random-typeout-line-more
+	      (device-hunk-device
+	       (window-hunk (random-typeout-stream-window stream))))
+	     stream 1)))
+
+(defun random-typeout-line-sout (stream string start end)
+  (declare (ignore start end))
+  (insert-string (random-typeout-stream-mark stream) string start end)
+  (unless (random-typeout-stream-no-prompt stream)
+    (let ((count (count #\newline string)))
+      (when count
+	(funcall (device-random-typeout-line-more
+		  (device-hunk-device
+		   (window-hunk (random-typeout-stream-window stream))))
+		 stream count)))))
+
+(defun random-typeout-line-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    ((:force-output :finish-output)
+     (random-typeout-redisplay (random-typeout-stream-window stream)))
+    (:charpos
+     (mark-charpos (random-typeout-stream-mark stream)))))
+
+
+;;; Bitmap line-buffered support.
+
+;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
+;;; a line-buffered-random-typeout-stream on the bitmap.  It does a lot of
+;;; checking to make sure that strings of characters longer than the width of
+;;; the window don't screw us.  The code is a little wierd, so a brief
+;;; explanation is below.
+;;;
+;;; The more-mark is how we tell when we will next need to more.  Each time
+;;; we do a more-prompt, we point the mark at the last visible character in
+;;; the random typeout window.  That way, when the mark is no longer
+;;; DISPLAYED-P, we know it's time to do another more prompt.
+;;;
+;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
+;;; if there was at least one newline in the last batch of output.  If we
+;;; haven't done a more prompt yet (indicated by a value of T for
+;;; first-more-p), then since we know the end of the buffer isn't visible, we
+;;; need to do a more-prompt.  If neither of the first two tests returns T,
+;;; then we can only need to do a more-prompt if our more-mark has scrolled
+;;; off the top of the screen.  If it hasn't, everything is peechy-keen, so
+;;; we scroll the screen one line and redisplay.
+;;;
+(defun update-bitmap-line-buffered-stream (stream newline-count)
+  (let* ((window (random-typeout-stream-window stream))
+	 (count 0))
+    (when (plusp newline-count) (random-typeout-redisplay window))
+    (loop
+      (cond ((no-text-past-bottom-p window)
+	     (return))
+	    ((or (random-typeout-stream-first-more-p stream)
+		 (not (displayed-p (random-typeout-stream-more-mark stream)
+				   window)))
+	     (do-bitmap-more-prompt stream)
+	     (return))
+	    (t
+	     (scroll-window window 1)
+	     (random-typeout-redisplay window)))
+      (when (= (incf count) newline-count) (return)))))
+
+;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
+;;; in the random-typeout window.  It does this by first making sure there is a
+;;; line past the WINDOW-DISPLAY-END of the window.  If there is, this line
+;;; must be empty, and BUFFER-END-MARK must be on this line.  The final test is
+;;; that the window-end is displayed within the window.  If it is not, then the
+;;; last line wraps past the end of the window, and there is text past the
+;;; bottom.
+;;;
+;;; Win-end is bound after the call to DISPLAYED-P because it updates the
+;;; window's image moving WINDOW-DISPLAY-END.  We want this updated value for
+;;; the display end.
+;;;
+(defun no-text-past-bottom-p (window)
+  (let* ((window-end (window-display-end window))
+	 (window-end-displayed-p (displayed-p window-end window)))
+    (with-mark ((win-end window-end))
+      (let ((one-after-end (line-offset win-end 1)))
+	(if one-after-end
+	    (and (empty-line-p win-end)
+		 (same-line-p win-end (buffer-end-mark (window-buffer window)))
+		 window-end-displayed-p)
+	    window-end-displayed-p)))))
+
+(defun reset-more-mark (stream)
+  (let* ((window (random-typeout-stream-window stream))
+	 (more-mark (random-typeout-stream-more-mark stream))
+	 (end (window-display-end window)))
+    (move-mark more-mark end)
+    (unless (displayed-p end window) (character-offset more-mark -1))))
+
+;;; DO-BITMAP-MORE-PROMPT is the function that atually displays the more prompt
+;;; and reacts to it.  Things are pretty clear.  The loop is neccessary because
+;;; someone could screw us by never outputting newlines.  Improbable, but
+;;; possible.
+;;;
+(defun do-bitmap-more-prompt (stream)
+  (let* ((window (random-typeout-stream-window stream))
+	 (height (window-height window)))
+    (setf (random-typeout-stream-first-more-p stream) nil)
+    (reset-more-mark stream)
+    (loop
+      (when (no-text-past-bottom-p window) (return))
+      (display-more-prompt stream)
+      (do ((i 0 (1+ i)))
+	  ((or (= i height) (no-text-past-bottom-p window)))
+	(scroll-window window 1)
+	(random-typeout-redisplay window)))
+    (unless (displayed-p (random-typeout-stream-more-mark stream) window)
+      (reset-more-mark stream))))
+
+
+;;; Tty line-buffered support.
+
+;;; UPDATE-TTY-LINE-BUFFERED-STREAM is called when anything is written to
+;;; a line-buffered-random-typeout-stream on the tty.  It just makes sure
+;;; hemlock doesn't choke on extra-long strings.
+;;;
+(defun update-tty-line-buffered-stream (stream newline-count)
+  (let ((window (random-typeout-stream-window stream)))
+    (when (plusp newline-count) (random-typeout-redisplay window))
+    (loop
+      (when (no-text-past-bottom-p window) (return))
+      (display-more-prompt stream)
+      (scroll-window window (window-height window))
+      (random-typeout-redisplay window))))
+
+
+;;;; Full-buffered Stream Methods.
+
+(defun random-typeout-full-out (stream char)
+  (insert-character (random-typeout-stream-mark stream) char))
+
+(defun random-typeout-full-sout (stream string start end)
+  (declare (ignore start end))
+  (insert-string (random-typeout-stream-mark stream) string start end))
+
+(defun random-typeout-full-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos
+     (mark-charpos (random-typeout-stream-mark stream)))))
+
+
+;;; Bitmap full-buffered support.
+
+;;; DO-BITMAP-FULL-MORE and DO-TTY-FULL-MORE scroll through the fresh text in
+;;; random typeout buffer.  The bitmap function does some checking so that
+;;; we don't overshoot the end of the buffer.
+;;;
+(defun do-bitmap-full-more (stream)
+  (let* ((window (random-typeout-stream-window stream))
+	 (buffer (window-buffer window))
+	 (height (window-height window)))
+    (with-mark ((end-check (buffer-end-mark buffer)))
+      (when (and (mark/= (buffer-start-mark buffer) end-check)
+		 (empty-line-p end-check))
+	(line-end (line-offset end-check -1)))
+      (loop
+	(when (displayed-p end-check window)
+	  (return))
+	(display-more-prompt stream)
+	(do ((i 0 (1+ i)))
+	    ((or (= i height) (displayed-p end-check window)))
+	  (scroll-window window 1)
+	  (random-typeout-redisplay window))))))
+
+
+;;; Tty full-buffered support.
+
+(defun do-tty-full-more (stream)
+  (let* ((window (random-typeout-stream-window stream))
+	 (buffer (window-buffer window)))
+    (with-mark ((end-check (buffer-end-mark buffer)))
+      (when (and (mark/= (buffer-start-mark buffer) end-check)
+		 (empty-line-p end-check))
+	(line-end (line-offset end-check -1)))
+      (loop
+	(when (displayed-p end-check window)
+	  (return))
+	(display-more-prompt stream)
+	(scroll-window window (window-height window))))))
+
+
+;;; Proclaim this special so the compiler doesn't warn me.  I hate that.
+;;;
+(proclaim '(special *more-prompt-action*))
+
+(defun display-more-prompt (stream)
+  (unless (random-typeout-stream-no-prompt stream)
+    (let ((window (random-typeout-stream-window stream))
+	  (*more-prompt-action* :more))
+      (update-modeline-field (window-buffer window) window :more-prompt)
+      (random-typeout-redisplay window)
+      (wait-for-more stream)
+      (let ((*more-prompt-action* :empty))
+	(update-modeline-field (window-buffer window) window :more-prompt)))))
diff --git a/hemlock/register.lisp b/hemlock/register.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..eb49e71ebb2f2fe1bf2821fe9a7863a735ec117f
--- /dev/null
+++ b/hemlock/register.lisp
@@ -0,0 +1,181 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Registers for holding text and positions.
+;;;
+;;; Written by Dave Touretzky.
+;;; Modified by Bill Chiles for Hemlock consistency.
+;;;
+(in-package 'hemlock)
+
+
+
+;;;; Registers implementation.
+
+;;; Registers are named by characters.  Each register refers to a mark or
+;;; a cons of a region and the buffer it came from.
+;;; 
+(defvar *registers* (make-hash-table))
+
+(defun register-count ()
+  (hash-table-count *registers*))
+
+(defun register-value (reg-name)
+  (gethash reg-name *registers*))
+
+(defsetf register-value (reg-name) (new-value)
+  (let ((name (gensym))
+	(value (gensym))
+	(old-value (gensym)))
+    `(let* ((,name ,reg-name)
+	    (,value ,new-value)
+	    (,old-value (gethash ,name *registers*)))
+       (when (and ,old-value (markp ,old-value))
+	 (delete-mark ,old-value))
+       (setf (gethash ,name *registers*) ,value))))
+
+(defun prompt-for-register (&optional (prompt "Register: ") must-exist)
+  (let ((reg-name (char-upcase (prompt-for-character :prompt prompt))))
+    (unless (or (not must-exist) (gethash reg-name *registers*))
+      (editor-error "Register ~A is empty." reg-name))
+    reg-name))
+
+     
+(defmacro do-registers ((name value &optional sorted) &rest body)
+  (if sorted
+      (let ((sorted-regs (gensym))
+	    (reg (gensym)))
+	`(let ((,sorted-regs nil))
+	   (declare (list ,sorted-regs))
+	   (maphash #'(lambda (,name ,value)
+			(push (cons ,name ,value) ,sorted-regs))
+		    *registers*)
+	   (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car))
+	   (dolist (,reg ,sorted-regs)
+	     (let ((,name (car ,reg))
+		   (,value (cdr ,reg)))
+	       ,@body))))
+      `(maphash #'(lambda (,name ,value)
+		    ,@body)
+		*registers*)))
+
+
+;;; Hook to clean things up if a buffer is deleted while registers point to it.
+;;; 
+(defun flush-reg-references-to-deleted-buffer (buffer)
+  (do-registers (name value)
+    (declare (ignore name))
+    (etypecase value
+      (mark (when (eq (line-buffer (mark-line value)) buffer)
+	      (free-register name)))
+      (cons (free-register-value value buffer)))))
+;;;
+(add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer)
+
+
+(defun free-register (name)
+  (let ((value (register-value name)))
+    (when value (free-register-value value)))
+  (remhash name *registers*))
+
+(defun free-register-value (value &optional buffer)
+  (etypecase value
+    (mark
+     (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer))
+       (delete-mark value)))
+    (cons
+     (when (and buffer (eq (cdr value) buffer))
+       (setf (cdr value) nil)))))
+
+
+
+;;;; Commands.
+
+;;; These commands all stash marks and regions with marks that point into some
+;;; buffer, and they assume that the register values have the same property.
+;;; 
+
+(defcommand "Save Position" (p)
+  "Saves the current location in a register.  Prompts for register name."
+  "Saves the current location in a register.  Prompts for register name."
+  (declare (ignore p))
+  (let ((reg-name (prompt-for-register)))
+    (setf (register-value reg-name)
+	  (copy-mark (current-point) :left-inserting))))
+
+(defcommand "Jump to Saved Position" (p)
+  "Moves the point to a location previously saved in a register."
+  "Moves the point to a location previously saved in a register."
+  (declare (ignore p))
+  (let* ((reg-name (prompt-for-register "Jump to Register: " t))
+	 (val (register-value reg-name)))
+    (unless (markp val)
+      (editor-error "Register ~A does not hold a location." reg-name))
+    (change-to-buffer (line-buffer (mark-line val)))
+    (move-mark (current-point) val)))
+
+(defcommand "Kill Register" (p)
+  "Kill a regist er.  Prompts for the name."
+  "Kill a register.  Prompts for the name."
+  (declare (ignore p))
+  (free-register (prompt-for-register "Register to kill: ")))
+
+(defcommand "List Registers" (p)
+  "Lists all registers in a pop-up window."
+  "Lists all registers in a pop-up window."
+  (declare (ignore p))
+  (with-pop-up-display (f :height (* 2 (register-count)))
+    (do-registers (name val :sorted)
+      (write-string "Reg " f)
+      (print-pretty-character name f)
+      (write-string ":  " f)
+      (etypecase val
+	(mark
+	 (let* ((line (mark-line val))
+		(buff (line-buffer line))
+		(len (line-length line)))
+	   (format f "Line ~S, col ~S in buffer ~A~%   ~A~:[~;...~]~%"
+		   (count-lines (region (buffer-start-mark buff) val))
+		   (mark-column val)
+		   (buffer-name buff)
+		   (subseq (line-string line) 0 (min 61 len))
+		   (> len 60))))
+	(cons
+	 (let* ((str (region-to-string (car val)))
+		(nl (position #\newline str :test #'char=))
+		(len (length str))
+		(buff (cdr val)))
+	   (declare (simple-string str))
+	   (format f "Text~@[ from buffer ~A~]~%   ~A~:[~;...~]~%"
+		   (if buff (buffer-name buff))
+		   (subseq str 0 (if nl (min 61 len nl) (min 61 len)))
+		   (> len 60))))))))
+
+(defcommand "Put Register" (p)
+  "Copies a region into a register.  Prompts for register name."
+  "Copies a region into a register.  Prompts for register name."
+  (declare (ignore p))
+  (let ((region (current-region)))
+    ;; Bind the region before prompting in case the region isn't active.
+    (setf (register-value (prompt-for-register))
+	  (cons (copy-region region) (current-buffer)))))
+
+(defcommand "Get Register" (p)
+  "Copies a region from a register to the current point."
+  "Copies a region from a register to the current point."
+  (declare (ignore p))
+  (let* ((reg-name (prompt-for-register "Register from which to get text: " t))
+	 (val (register-value reg-name)))
+    (unless (and (consp val) (regionp (car val)))
+      (editor-error "Register ~A does not hold a region." reg-name))
+    (let ((point (current-point)))
+      (push-buffer-mark (copy-mark point))
+      (insert-region (current-point) (car val))))
+  (setf (last-command-type) :ephemerally-active))
diff --git a/hemlock/ring.lisp b/hemlock/ring.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6dccacb3d03df64e5987a62e420fd4523d594ffd
--- /dev/null
+++ b/hemlock/ring.lisp
@@ -0,0 +1,204 @@
+;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Rob MacLachlan
+;;;
+;;;  This file defines a ring-buffer type and access functions.
+;;;
+(in-package 'hemlock-internals)
+(export '(ring ringp make-ring ring-push ring-pop ring-length ring-ref
+	       rotate-ring))
+
+
+(defun %print-hring (obj stream depth)
+  (declare (ignore depth obj))
+  (write-string "#<Hemlock Ring>" stream))
+
+;;;; The ring data structure:
+;;;
+;;;    An empty ring is indicated by an negative First value.
+;;; The Bound is made (1- (- Size)) to make length work.  Things are
+;;; pushed at high indices first.
+;;;
+(defstruct (ring (:predicate ringp)
+		 (:constructor internal-make-ring)
+		 (:print-function %print-hring))
+  "Used with Ring-Push and friends to implement ring buffers."
+  (first -1 :type fixnum)	   ;The index of the first position used.
+  (bound () :type fixnum)	   ;The index after the last element.
+  delete-function		   ;The function  to be called on deletion. 
+  (vector () :type simple-vector)) ;The vector.
+
+;;; make-ring  --  Public
+;;;
+;;;    Make a new empty ring with some maximum size and type.
+;;;
+(defun make-ring (size &optional (delete-function #'identity))
+  "Make a ring-buffer which can hold up to Size objects.  Delete-Function
+  is a function which is called with each object that falls off the
+  end."
+  (unless (and (fixnump size) (> size 0))
+    (error "Ring size, ~S is not a positive fixnum." size))
+  (internal-make-ring :delete-function delete-function
+		      :vector (make-array size)
+		      :bound  (1- (- size))))
+
+;;; ring-push  --  Public
+;;;
+;;;    Decrement first modulo the maximum size, delete any old
+;;; element, and add the new one.
+;;;
+(defun ring-push (object ring)
+  "Push an object into a ring, deleting an element if necessary."
+  (let ((first (ring-first ring))
+	(vec (ring-vector ring)) victim)
+    (declare (simple-vector vec) (fixnum first victim))
+    (cond
+     ;; If zero, wrap around to end.
+     ((zerop first)
+      (setq victim (1- (length vec))))
+     ;; If empty then fix up pointers.
+     ((minusp first)
+      (setf (ring-bound ring) 0)
+      (setq victim (1- (length vec))))
+     (t
+      (setq victim (1- first))))
+    (when (= first (ring-bound ring))
+      (funcall (ring-delete-function ring) (aref vec victim))
+      (setf (ring-bound ring) victim))
+    (setf (ring-first ring) victim)
+    (setf (aref vec victim) object)))
+
+
+;;; ring-pop  --  Public
+;;;
+;;;    Increment first modulo the maximum size.
+;;;
+(defun ring-pop (ring)
+  "Pop an object from a ring and return it."
+  (let* ((first (ring-first ring))
+	 (vec (ring-vector ring))
+	 (new (if (= first (1- (length vec))) 0 (1+ first)))
+	 (bound (ring-bound ring)))
+    (declare (fixnum first new bound) (simple-vector vec))
+    (cond
+     ((minusp bound)
+      (error "Cannot pop from an empty ring."))
+     ((= new bound)
+      (setf (ring-first ring) -1  (ring-bound ring) (1- (- (length vec)))))
+     (t
+      (setf (ring-first ring) new)))
+    (shiftf (aref vec first) nil)))
+
+
+;;; ring-length  --  Public
+;;;
+;;;    Return the current and maximum size.
+;;;
+(defun ring-length (ring)
+  "Return as values the current and maximum size of a ring."
+  (let ((diff (- (ring-bound ring) (ring-first ring)))
+	(max (length (ring-vector ring))))
+    (declare (fixnum diff max))
+    (values (if (plusp diff) diff (+ max diff)) max)))
+
+;;; ring-ref  --  Public
+;;;
+;;;    Do modulo arithmetic to find the correct element.
+;;;
+(defun ring-ref (ring index)
+  (declare (fixnum index))
+  "Return the index'th element of a ring.  This can be set with Setf."
+  (let ((first (ring-first ring)))
+    (declare (fixnum first))
+    (cond
+     ((and (zerop index) (not (minusp first)))
+      (aref (ring-vector ring) first))
+     (t
+      (let* ((diff (- (ring-bound ring) first))
+	     (sum (+ first index))
+	     (vec (ring-vector ring))
+	     (max (length vec)))
+	(declare (fixnum diff max sum) (simple-vector vec))
+	(when (or (>= index (if (plusp diff) diff (+ max diff)))
+		  (minusp index))
+	  (error "Ring index ~D out of bounds." index))
+	(aref vec (if (>= sum max) (- sum max) sum)))))))
+
+
+;;; %set-ring-ref  --  Internal
+;;;
+;;;    Setf form for ring-ref, set a ring element.
+;;;
+(defun %set-ring-ref (ring index value)
+  (declare (fixnum index))
+  (let* ((first (ring-first ring))
+	 (diff (- (ring-bound ring) first))
+	 (sum (+ first index))
+	 (vec (ring-vector ring))
+	 (max (length vec)))
+    (declare (fixnum diff first max) (simple-vector vec))
+    (when (or (>= index (if (plusp diff) diff (+ max diff))) (minusp index))
+      (error "Ring index ~D out of bounds." index))
+    (setf (aref vec (if (>= sum max) (- sum max) sum)) value)))
+
+(eval-when (compile eval)
+(defmacro 1+m (exp base)
+  `(if (= ,exp ,base) 0 (1+ ,exp)))
+(defmacro 1-m (exp base)
+  `(if (zerop ,exp) ,base (1- ,exp)))
+) ;eval-when (compile eval)
+
+;;; rotate-ring  --  Public
+;;;
+;;;    Rotate a ring, blt'ing elements as necessary.
+;;;
+(defun rotate-ring (ring offset)
+  "Rotate a ring forward, i.e. second -> first, with positive offset,
+  or backwards with negative offset."
+  (declare (fixnum offset))
+  (let* ((first (ring-first ring))
+	 (bound (ring-bound ring))
+	 (vec (ring-vector ring))
+	 (max (length vec)))
+    (declare (fixnum first bound max) (simple-vector vec))
+    (cond
+     ((= first bound)
+      (let ((new (rem (+ offset first) max)))
+	(declare (fixnum new))
+	(if (minusp new) (setq new (+ new max)))
+	(setf (ring-first ring) new)
+	(setf (ring-bound ring) new)))
+     ((not (minusp first))
+      (let* ((diff (- bound first))
+	     (1-max (1- max))
+	     (length (if (plusp diff) diff (+ max diff)))
+	     (off (rem offset length)))
+	(declare (fixnum diff length off 1-max))
+	(cond
+	 ((minusp offset)
+	  (do ((dst (1-m first 1-max) (1-m dst 1-max))
+	       (src (1-m bound 1-max) (1-m src 1-max))
+	       (cnt off (1+ cnt)))
+	      ((zerop cnt)
+	       (setf (ring-first ring) (1+m dst 1-max))
+	       (setf (ring-bound ring) (1+m src 1-max)))
+	    (declare (fixnum dst src cnt))
+	    (shiftf (aref vec dst) (aref vec src) nil)))
+	 (t
+	  (do ((dst bound (1+m dst 1-max))
+	       (src first (1+m src 1-max))
+	       (cnt off (1- cnt)))
+	      ((zerop cnt)
+	       (setf (ring-first ring) src)
+	       (setf (ring-bound ring) dst))
+	    (declare (fixnum dst src cnt))
+	    (shiftf (aref vec dst) (aref vec src) nil))))))))
+  ring)
diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6bef157eee7a1835e98ca4a4053fde79f1a733e6
--- /dev/null
+++ b/hemlock/rompsite.lisp
@@ -0,0 +1,1538 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; "Site dependent" stuff for the editor while on the IBM RT PC machine.
+;;;
+
+(in-package "SYSTEM")
+
+(export '(without-hemlock))
+
+
+(in-package "HEMLOCK-INTERNALS" :nicknames '("HI"))
+
+(export '(show-mark editor-sleep text-character print-pretty-character
+	  *input-transcript* *real-editor-input* input-waiting
+	  fun-defined-from-pathname editor-describe-function pause-hemlock
+	  store-cut-string fetch-cut-string schedule-event
+	  remove-scheduled-event enter-window-autoraise directoryp
+	  last-key-event-cursorpos merge-relative-pathnames *editor-input*
+	  *last-character-typed* *character-history*
+	  ;;
+	  ;; Export default-font to prevent a name conflict that occurs due to
+	  ;; the Hemlock variable "Default Font" defined in SITE-INIT below.
+	  ;;
+	  default-font))
+
+
+;;; SYSTEM:WITHOUT-HEMLOCK -- Public.
+;;;
+;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and
+;;; eval-server.lisp.
+;;; 
+(defmacro system:without-hemlock (&body body)
+  "When in the editor and not in the debugger, call the exit method of Hemlock's
+   device, so we can type.  Do the same thing on exit but call the init method."
+  `(progn
+     (when (and *in-the-editor* (not debug::*in-the-debugger*))
+       (let ((device (device-hunk-device (window-hunk (current-window)))))
+	 (funcall (device-exit device) device)))
+     ,@body
+     (when (and *in-the-editor* (not debug::*in-the-debugger*))
+       (let ((device (device-hunk-device (window-hunk (current-window)))))
+	 (funcall (device-init device) device)))))
+
+
+
+;;;; SITE-INIT.
+
+;;; *character-history* is defined much later in this file, but it needs to
+;;; be set in SITE-INIT, since MAKE-RING doesn't exist at load time for this
+;;; file.
+;;;
+(proclaim '(special *character-history*))
+
+;;; SITE-INIT  --  Internal
+;;;
+;;;    This function is called at init time to set up any site stuff.
+;;;
+(defun site-init ()
+  (defhvar "Beep Border Width"
+    "Width in pixels of the border area inverted by beep."
+    :value 20)
+  (defhvar "Default Window Width"
+    "This is used to make a window when prompting the user.  The value is in
+     characters."
+    :value 80)
+  (defhvar "Default Window Height"
+    "This is used to make a window when prompting the user.  The value is in
+     characters."
+    :value 24)
+  (defhvar "Default Initial Window Width"
+    "This is used when Hemlock first starts up to make its first window.
+     The value is in characters."
+    :value 80)
+  (defhvar "Default Initial Window Height"
+    "This is used when Hemlock first starts up to make its first window.
+     The value is in characters."
+    :value 24)
+  (defhvar "Default Initial Window X"
+    "This is used when Hemlock first starts up to make its first window.
+     The value is in pixels."
+    :value nil)
+  (defhvar "Default Initial Window Y"
+    "This is used when Hemlock first starts up to make its first window.
+     The value is in pixels."
+    :value nil)
+  (defhvar "Bell Style"
+    "This controls what beeps do in Hemlock.  Acceptable values are :border-flash
+     (which is the default), :feep, :border-flash-and-feep, :flash,
+     :flash-and-feep, and NIL (do nothing)."
+    :value :border-flash)
+  (defhvar "Reverse Video"
+    "Paints white on black in window bodies, black on white in modelines."
+    :value nil
+    :hooks '(reverse-video-hook-fun))
+  (defhvar "Cursor Bitmap File"
+    "File to read to setup cursors for Hemlock windows.  The mask is found by
+     merging this name with \".mask\"."
+    :value "/usr/misc/.lisp/lib/hemlock11.cursor")
+  (defhvar "Enter Window Hook"
+    "When the mouse enters an editor window, this hook is invoked.  These
+     functions take the Hemlock Window as an argument."
+    :value nil)
+  (defhvar "Exit Window Hook"
+    "When the mouse exits an editor window, this hook is invoked.  These
+     functions take the Hemlock Window as an argument."
+    :value nil)
+  (defhvar "Set Window Autoraise"
+    "When non-nil, setting the current window will automatically raise that
+     window via a function on \"Set Window Hook\".  If the value is :echo-only
+     (the default), then only the echo area window will be raised
+     automatically upon becoming current."
+    :value :echo-only)
+  (defhvar "Default Font"
+    "The string name of the font to be used for Hemlock -- buffer text,
+     modelines, random typeout, etc.  The font is loaded when initializing
+     Hemlock."
+    :value "8x13")
+  (defhvar "Thumb Bar Meter"
+    "When non-nil (the default), windows will be created to be displayed with
+     a ruler in the bottom border of the window."
+    :value t)
+
+  (setf *character-history* (make-ring 60))
+  nil)
+
+
+
+;;;; Some generally useful file-system functions.
+
+;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or
+;;; relative to default-dir, merging it as appropriate and returning a definite
+;;; directory pathname.  If the component comes back with a trailing slash, we
+;;; have to remove it to get the MERGE-PATHNAMES to work correctly.  The result
+;;; must have a trailing slash.
+;;; 
+(defun merge-relative-pathnames (pathname default-directory)
+  "Merges pathname with default-directory.  If pathname is not absolute, it
+   is assumed to be relative to default-directory.  The result is always a
+   directory."
+  (setf pathname (pathname pathname))
+  (flet ((return-with-slash (pathname)
+	   (let ((ns (namestring pathname)))
+	     (declare (simple-string ns))
+	     (if (char= #\/ (schar ns (1- (length ns))))
+		 pathname
+		 (pathname (concatenate 'simple-string ns "/"))))))
+    (let ((dir (pathname-directory pathname)))
+      (if dir
+	  (let ((dev (pathname-device pathname)))
+	    (if (eq dev :absolute)
+		(return-with-slash pathname)
+		(return-with-slash
+		    (make-pathname :device (pathname-device default-directory)
+				   :directory
+				   (concatenate
+				    'simple-vector
+				    (pathname-directory default-directory)
+				    dir)
+				   :defaults pathname))))
+	  (return-with-slash (merge-pathnames pathname default-directory))))))
+
+(defun directoryp (pathname)
+  (not (or (pathname-name pathname) (pathname-type pathname))))
+
+
+
+;;;; I/O specials and initialization
+
+(defvar *editor-input* nil
+  "Input stream to get unechoed unbuffered terminal input.")
+
+(defvar *real-editor-input* ()
+  "The real editor input stream.  Useful when we want to read from the
+  terminal when *editor-input* is rebound.")
+
+
+;;; File descriptor for the terminal.
+;;; 
+(defvar *editor-file-descriptor*)
+
+
+;;; This is a hack, so screen can tell how to initialize screen management
+;;; without re-opening the display.  It is set in INIT-RAW-IO and referenced
+;;; in WINDOWED-MONITOR-P.
+;;; 
+(defvar *editor-windowed-input* nil)
+
+
+;;; These are used for selecting X events.
+;;; 
+;;; This says to send :key-press, :button-press, :button-release, :enter-notify,
+;;; and :leave-notify events.
+;;;
+(defconstant input/boundary-xevents-selection-keys
+  '(:key-press :button-press :button-release :enter-window :leave-window))
+(defconstant input/boundary-xevents-mask
+  (apply #'xlib:make-event-mask input/boundary-xevents-selection-keys))
+;;;
+;;; This says to send :exposure, :destroy-notify, :unmap-notify, :map-notify,
+;;; :reparent-notify, :configure-notify, :gravity-notify, and :circulate-notify
+;;; in addition to the above events.  Of those enumerated here, we only care
+;;; about :exposure and :configure-notify.
+;;;
+(defconstant interesting-xevents-receive-keys
+  '(:key-press :button-press :button-release :enter-notify :leave-notify
+    :exposure :graphics-exposure :configure-notify :destroy-notify :unmap-notify
+    :map-notify :reparent-notify :gravity-notify :circulate-notify))
+(defconstant interesting-xevents-mask
+  (apply #'xlib:make-event-mask
+	 (append input/boundary-xevents-selection-keys
+		 '(:exposure :structure-notify))))
+
+(defconstant random-typeout-xevents-mask
+  (apply #'xlib:make-event-mask
+	 (append input/boundary-xevents-selection-keys
+		 '(:exposure))))
+
+
+(proclaim '(special ed::*open-paren-highlight-font*
+		    ed::*active-region-highlight-font*))
+
+(defparameter lisp-fonts-pathnames
+  '("/usr/misc/.lisp/lib/fonts/"
+    "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/"))
+
+
+;;; INIT-RAW-IO  --  Internal
+;;;
+;;;    This function should be called whenever the editor is entered in a new
+;;; lisp.  It sets up process specific data structures.
+;;;
+(defun init-raw-io (display)
+  (setf *editor-windowed-input* nil)
+  (cond (display
+	 (setf *editor-windowed-input* (ext:open-clx-display display))
+	 (setf *editor-input* (make-editor-window-input-stream))
+	 (ext:carefully-add-font-paths *editor-windowed-input*
+				       lisp-fonts-pathnames)
+	 (setup-font-family *editor-windowed-input*
+			    (variable-value 'ed::default-font)
+			    "8x13u" "8x13bold"))
+	(t ;; The editor's file descriptor is Unix standard input (0).
+	   ;; We don't need to affect system:*file-input-handlers* here
+	   ;; because the init and exit methods for tty redisplay devices
+	   ;; take care of this.
+	   ;;
+	 (setf *editor-file-descriptor* 0)
+	 (setf *editor-input* (make-editor-tty-input-stream 0))))
+  (setf *real-editor-input* *editor-input*)
+  *editor-windowed-input*)
+
+;;; Stop flaming from compiler due to CLX macros expanding into illegal
+;;; declarations.
+;;;
+(proclaim '(declaration values))
+(proclaim '(special *default-font-family*))
+
+;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
+;;; assume it to be special, issuing a nasty warning.
+;;;
+(defconstant font-map-size 16
+  "The number of possible fonts in a font-map.")
+
+
+;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names
+;;; passed in.  The font family structure is filled in from the first argument.
+;;; Actually, this ignores default-highlight-font and default-open-paren-font
+;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting
+;;; Font" when these are defined.
+;;;
+(defun setup-font-family (display default-font default-highlight-font
+				  default-open-paren-font)
+  (let* ((font-family (make-font-family :map (make-array font-map-size
+							 :initial-element 0)
+					:cursor-x-offset 0
+					:cursor-y-offset 0))
+	 (font-family-map (font-family-map font-family)))
+    (declare (simple-vector font-family-map))
+    (setf *default-font-family* font-family)
+    (let ((font (xlib:open-font display default-font)))
+      (unless font (error "Cannot open font -- ~S" default-font))
+      (fill font-family-map font)
+      (let ((width (xlib:max-char-width font)))
+	(setf (font-family-width font-family) width)
+	(setf (font-family-cursor-width font-family) width))
+      (let* ((baseline (xlib:font-ascent font))
+	     (height (+ baseline (xlib:font-descent font))))
+	(setf (font-family-height font-family) height)
+	(setf (font-family-cursor-height font-family) height)
+	(setf (font-family-baseline font-family) baseline)))
+    (setup-one-font display
+		    (or (variable-value 'ed::open-paren-highlighting-font)
+			default-open-paren-font)
+		    font-family-map
+		    ed::*open-paren-highlight-font*)
+    (setup-one-font display
+		    (or (variable-value 'ed::active-region-highlighting-font)
+			default-highlight-font)
+		    font-family-map
+		    ed::*active-region-highlight-font*)))
+
+;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in
+;;; font-family-map at index.  XLIB:OPEN-FONT will return font stuff regardless
+;;; if the request is valid or not, so we finish the output to get synch'ed
+;;; with the server which will cause any errors to get signaled.  At this
+;;; level, we want to deal with this error here returning nil if the font
+;;; couldn't be opened.
+;;;
+(defun setup-one-font (display font-name font-family-map index)
+  (handler-case (let ((font (xlib:open-font display (namestring font-name))))
+		  (xlib:display-finish-output display)
+		  (setf (svref font-family-map index) font))
+    (xlib:name-error ()
+     (warn "Cannot open font -- ~S" font-name)
+     nil)))
+
+
+
+;;;; HEMLOCK-BEEP.
+
+(defvar *editor-bell* (make-string 1 :initial-element #\bell))
+
+;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal.
+;;; Send a #\bell to unix standard output.
+;;;
+(defun tty-beep (&optional device stream)
+  (declare (ignore device stream))
+  (when (variable-value 'ed::bell-style)
+    (mach:unix-write 1 *editor-bell* 0 1)))
+
+(proclaim '(special *current-window*))
+
+;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed
+;;; input.
+;;;
+(defun bitmap-beep (display stream)
+  (declare (ignore stream))
+  (ecase (variable-value 'ed::bell-style)
+    (:border-flash
+     (flash-window-border *current-window*))
+    (:feep
+     (xlib:bell display)
+     (xlib:display-force-output display))
+    (:border-flash-and-feep
+     (xlib:bell display)
+     (xlib:display-force-output display)
+     (flash-window-border *current-window*))
+    (:flash
+     (flash-window *current-window*))
+    (:flash-and-feep
+     (xlib:bell display)
+     (xlib:display-force-output display)
+     (flash-window *current-window*))
+    ((nil) ;Do nothing.
+     )))
+
+(proclaim '(special *foreground-background-xor*))
+
+(defun flash-window-border (window)
+  (let* ((hunk (window-hunk window))
+	 (xwin (bitmap-hunk-xwindow hunk))
+	 (gcontext (bitmap-hunk-gcontext hunk))
+	 (display (bitmap-device-display (device-hunk-device hunk)))
+	 (border (variable-value 'ed::beep-border-width))
+	 (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk)))
+	 (top-border (min (ash h -1) border))
+	 (w (bitmap-hunk-width hunk))
+	 (side-border (min (ash w -1) border))
+	 (top-width (max 0 (- w (ash side-border 1))))
+	 (right-x (- w side-border))
+	 (bottom-y (- h top-border)))
+    (xlib:with-gcontext (gcontext :function xlib::boole-xor
+				  :foreground *foreground-background-xor*)
+      (dotimes (i 8)
+	(xlib:draw-rectangle xwin gcontext 0 0 side-border h t)
+	(xlib:display-force-output display)
+	(xlib:draw-rectangle xwin gcontext side-border bottom-y
+			     top-width top-border t)
+	(xlib:display-force-output display)
+	(xlib:draw-rectangle xwin gcontext right-x 0 side-border h t)
+	(xlib:display-force-output display)
+	(xlib:draw-rectangle xwin gcontext side-border 0 top-width top-border t)
+	(xlib:display-force-output display)))))
+
+(defun flash-window (window)
+  (let* ((hunk (window-hunk window))
+	 (xwin (bitmap-hunk-xwindow hunk))
+	 (gcontext (bitmap-hunk-gcontext hunk))
+	 (display (bitmap-device-display (device-hunk-device hunk)))
+	 (width (bitmap-hunk-width hunk))
+	 (height (or (bitmap-hunk-modeline-pos hunk)
+		     (bitmap-hunk-height hunk))))
+    (xlib:with-gcontext (gcontext :function xlib::boole-xor
+				  :foreground *foreground-background-xor*)
+      (xlib:draw-rectangle xwin gcontext 0 0 width height t)
+      (xlib:display-force-output display)
+      (xlib:draw-rectangle xwin gcontext 0 0 width height t)
+      (xlib:display-force-output display))))
+
+
+
+(defun hemlock-beep (stream)
+  "Using the current window, calls the device's beep function on stream."
+  (let ((device (device-hunk-device (window-hunk (current-window)))))
+    (funcall (device-beep device) (bitmap-device-display device) stream)))
+
+
+
+;;;; GC messages.
+
+;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC
+;;; notifications when Hemlock is not running under X11.  It cannot affect
+;;; its window's without using its display connection.  Since GC can occur
+;;; inside CLX request functions, using the same display confuses CLX.
+;;;
+
+(defun hemlock-gc-notify-before (bytes-in-use)
+  (let ((control "~%[GC threshold exceeded with ~:D bytes in use.  ~
+  		  Commencing GC.]~%"))
+    (cond ((not hi::*editor-windowed-input*)
+	   (beep)
+	   #|(message control bytes-in-use)|#)
+	  (t
+	   ;; Can't call BEEP since it would use Hemlock's display connection.
+	   (lisp::default-beep-function *standard-output*)
+	   (format t control bytes-in-use)
+	   (finish-output)))))
+
+(defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger)
+  (let ((control
+	 "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~
+	  [GC will next occur when at least ~:D bytes are in use.]~%"))
+    (cond ((not hi::*editor-windowed-input*)
+	   (beep)
+	   #|(message control bytes-retained bytes-freed)|#)
+	  (t
+	   ;; Can't call BEEP since it would use Hemlock's display connection.
+	   (lisp::default-beep-function *standard-output*)
+	   (format t control bytes-retained bytes-freed trigger)
+	   (finish-output)))))
+
+
+
+;;;; Site-Wrapper-Macro and standard device init/exit functions.
+
+(defun in-hemlock-standard-input-read (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "You cannot read off this stream while in Hemlock -- ~S"
+	 stream))
+
+(defvar *illegal-read-stream*
+  (lisp::make-stream :in #'in-hemlock-standard-input-read))
+
+(defmacro site-wrapper-macro (&body body)
+  `(unwind-protect
+     (progn
+       (when *editor-has-been-entered*
+	 (let ((device (device-hunk-device (window-hunk (current-window)))))
+	   (funcall (device-init device) device)))
+       (let ((*beep-function* #'hemlock-beep)
+	     (*gc-notify-before* #'hemlock-gc-notify-before)
+	     (*gc-notify-after* #'hemlock-gc-notify-after)
+	     (*standard-input* *illegal-read-stream*)
+	     (*query-io* *illegal-read-stream*))
+	 (cond ((not *editor-windowed-input*)
+		,@body)
+	       (t
+		(ext:with-clx-event-handling
+		    (*editor-windowed-input* #'ext:object-set-event-handler)
+		  ,@body)))))
+     (let ((device (device-hunk-device (window-hunk (current-window)))))
+       (funcall (device-exit device) device))))
+
+(defun standard-device-init ()
+  (setup-input))
+
+(defun standard-device-exit ()
+  (reset-input))
+
+(proclaim '(special *echo-area-window*))
+
+;;; Maybe bury/unbury hemlock window when we go to and from Lisp.
+;;; This should do something more sophisticated when we know what that is.
+;;; 
+(defun default-hemlock-window-mngt (display on)
+  (let ((win (bitmap-hunk-xwindow (window-hunk *current-window*)))
+	(ewin (bitmap-hunk-xwindow (window-hunk *echo-area-window*))))
+    (cond (on (setf (xlib:window-priority ewin) :above)
+	      (clear-input *editor-input*)
+	      (setf (xlib:window-priority win) :above))
+	  (t (setf (xlib:window-priority ewin) :below)
+	     (setf (xlib:window-priority win) :below))))
+  (xlib:display-force-output display))
+
+(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt
+  "This function is called by HEMLOCK-WINDOW, passing its arguments.  This may
+   be nil.")
+
+(defun hemlock-window (display on)
+  "Calls *hemlock-window-mngt* on the argument ON when *current-window* is
+  bound.  This is called in the device init and exit methods for X bitmap
+  devices."
+  (when (and *hemlock-window-mngt* *current-window*)
+    (funcall *hemlock-window-mngt* display on)))
+
+
+
+;;;; Current terminal character translation.
+
+(defvar *terminal-translation-table* (make-array 128))
+
+;;; Converting ASCII control characters to Common Lisp control characters:
+;;; ASCII control character codes are separated from the codes of the
+;;; "non-controlified" characters by the code of atsign.  The ASCII control
+;;; character codes range from ^@ (0) through ^_ (one less than the code of
+;;; space).  We iterate over this range adding the ASCII code of atsign to
+;;; get the "non-controlified" character code.  With each of these, we turn
+;;; the code into a Common Lisp character and set its :control bit.  Certain
+;;; ASCII control characters have to be translated to special Common Lisp
+;;; characters outside of the loop.
+;;;    With the advent of Hemlock running under X, and all the key bindings
+;;; changing, we also downcase each Common Lisp character (where normally
+;;; control characters come in upcased) in an effort to obtain normal command
+;;; bindings.  Commands bound to uppercase modified characters will not be
+;;; accessible to terminal interaction.
+;;; 
+(let ((@-code (char-code #\@)))
+  (dotimes (i (char-code #\space))
+    (setf (svref *terminal-translation-table* i)
+	  (set-char-bit (char-downcase (code-char (+ i @-code))) :control t))))
+(setf (svref *terminal-translation-table* 9) #\tab)
+(setf (svref *terminal-translation-table* 10) #\linefeed)
+(setf (svref *terminal-translation-table* 13) #\return)
+(setf (svref *terminal-translation-table* 27) #\alt)
+(setf (svref *terminal-translation-table* 8) #\backspace)
+;;;
+;;; Other ASCII codes are exactly the same as the Common Lisp codes.
+;;; 
+(do ((i (char-code #\space) (1+ i)))
+    ((= i 128))
+  (setf (svref *terminal-translation-table* i) (code-char i)))
+
+;;; TRANSLATE-TTY-CHAR is our interface to be used in GET-EDITOR-INPUT.
+;;; 
+(proclaim '(inline translate-tty-char))
+(defun translate-tty-char (char)
+  (svref *terminal-translation-table* char))
+
+
+(defconstant termcap-file "/etc/termcap")
+
+(defun cl-termcap-char (char)
+  (if (char-bit char :control)
+      (code-char (the fixnum
+		      (- (the fixnum (char-code char))
+			 64))) ;(char-code #\@)
+      (case char
+	(#\alt (code-char 27))
+	(#\newline (code-char 10))
+	(#\return (code-char 13))
+	(#\tab (code-char 9))
+	(#\backspace (code-char 8))
+	(#\formfeed (code-char 12))
+	(t char))))
+
+
+
+;;;; Common editor input: stream def, event queue mngt, kbdmac waiting,
+;;;; more prompt, input method macro.
+
+;;; This is the basic editor stream definition.  More particular stream
+;;; definitions below include this.
+;;; 
+(defstruct (editor-input-stream
+	    (:include stream)
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore s d))
+	       (write-string "#<Editor-Input stream>" stream)))
+	    (:constructor make-editor-input-stream
+			  (head &optional (tail head))))
+  ;;
+  ;; FIFO queue of events on this stream.  The queue always contains
+  ;; at least one one element, which is the character most recently read.
+  ;; If no event has been read, the event is a dummy with a NIL char.
+  head		; First key event in queue.
+  tail)		; Last event in queue.
+
+
+;;; Key event queue.
+;;; 
+
+(defstruct (key-event
+	    (:constructor make-key-event ())) 
+  next		; Next queued event, or NIL if none.
+  hunk		; Screen hunk event was read from.
+  char		; Character read.
+  x		; X and Y character position of mouse cursor.
+  y
+  unread-p)
+
+(defvar *free-key-events* ())
+
+(defun new-event (char x y hunk next &optional unread-p)
+  (let ((res (if *free-key-events*
+		 (shiftf *free-key-events* (key-event-next *free-key-events*))
+		 (make-key-event))))
+    (setf (key-event-char res) char)
+    (setf (key-event-x res) x)
+    (setf (key-event-y res) y)
+    (setf (key-event-hunk res) hunk)
+    (setf (key-event-next res) next)
+    (setf (key-event-unread-p res) unread-p)
+    res))
+
+(defvar *last-character-typed* ()
+  "This variable contains the last character typed to the command
+  interpreter.") 
+
+;;; *character-history* is setup in SITE-INIT.
+;;;
+(defvar *character-history* nil
+  "This ring holds the last 60 characters read by the command interpreter.")
+
+(proclaim '(special *input-transcript*))
+
+;;; DQ-EVENT is used in editor stream methods for popping off input.
+;;; If there is an event not yet read in Stream, then pop the queue
+;;; and return the character.  If there is none, return NIL.
+;;;
+(defun dq-event (stream)
+  (without-interrupts
+   (let* ((head (editor-input-stream-head stream))
+	  (next (key-event-next head)))
+     (if next
+	 (let ((char (key-event-char next)))
+	   (setf (editor-input-stream-head stream) next)
+	   (shiftf (key-event-next head) *free-key-events* head)
+	   (ring-push char *character-history*)
+	   (setq *last-character-typed* char)
+	   (when *input-transcript* 
+	     (vector-push-extend char *input-transcript*))
+	   char)))))
+
+;;; Q-EVENT is used in low level input fetching routines to add input to the
+;;; editor stream.
+;;; 
+(defun q-event (stream char &optional x y hunk)
+  (without-interrupts
+   (let ((new (new-event char x y hunk nil))
+	 (tail (editor-input-stream-tail stream)))
+     (setf (key-event-next tail) new)
+     (setf (editor-input-stream-tail stream) new))))
+
+(defun un-event (char stream)
+  (without-interrupts
+   (let* ((head (editor-input-stream-head stream))
+	  (next (key-event-next head))
+	  (new (new-event char (key-event-x head) (key-event-y head)
+			  (key-event-hunk head) next t)))
+     (setf (key-event-next head) new)
+     (unless next (setf (editor-input-stream-tail stream) new)))))
+
+
+;;; Keyboard macro hacks.
+;;; 
+
+(defvar *input-transcript* ()
+  "If this variable is non-null then it should contain an adjustable vector
+  with a fill pointer into which all keyboard input will be pushed.")
+
+;;; INPUT-WAITING  --  Internal
+;;;
+;;;    An Evil hack that tells us whether there is an unread character on
+;;; *editor-input*.  Note that this is applied to the real *editor-input*
+;;; rather than to a kbdmac stream.
+;;;
+(defun input-waiting ()
+  "Returns true if there is a character which has been unread-char'ed
+   on *editor-input*.  Used by the keyboard macro stuff."
+  (let ((next (key-event-next (editor-input-stream-head *real-editor-input*))))
+    (and next (key-event-unread-p next))))
+
+
+;;; Random typeout hacks.
+;;; 
+
+(defun wait-for-more (stream)
+  (let ((ch (more-read-ch)))
+    (cond ((logical-char= ch :yes))
+	  ((or (logical-char= ch :do-all)
+	       (logical-char= ch :exit))
+	   (setf (random-typeout-stream-no-prompt stream) t)
+	   (random-typeout-cleanup stream))
+	  ((logical-char= ch :keep)
+	   (setf (random-typeout-stream-no-prompt stream) t)
+	   (maybe-keep-random-typeout-window stream)
+	   (random-typeout-cleanup stream))
+	  ((logical-char= ch :no)
+	   (random-typeout-cleanup stream)
+	   (throw 'more-punt nil))
+	  (t
+	   (unread-char ch *editor-input*)
+	   (random-typeout-cleanup stream)
+	   (throw 'more-punt nil)))))
+
+(proclaim '(special *more-prompt-action*))
+
+(defun maybe-keep-random-typeout-window (stream)
+  (let* ((window (random-typeout-stream-window stream))
+	 (buffer (window-buffer window))
+	 (start (buffer-start-mark buffer)))
+    (when (typep (hi::device-hunk-device (hi::window-hunk window))
+		 'hi::bitmap-device)
+      (let ((*more-prompt-action* :normal))
+	(update-modeline-field buffer window :more-prompt)
+	(random-typeout-redisplay window))
+      (buffer-start (buffer-point buffer))
+      (unless (make-window start :window (make-xwindow-like-hwindow window))
+	(editor-error "Could not create random typeout window.")))))
+
+(defun end-random-typeout (stream)
+  (let ((*more-prompt-action* :flush)
+	(window (random-typeout-stream-window stream)))
+    (update-modeline-field (window-buffer window) window :more-prompt)
+    (random-typeout-redisplay window))
+  (unless (random-typeout-stream-no-prompt stream)
+    (let* ((ch (more-read-ch))
+	   (keep-p (logical-char= ch :keep)))
+      (when keep-p (maybe-keep-random-typeout-window stream))
+      (random-typeout-cleanup stream)
+      (unless (or (logical-char= ch :do-all)
+		  (logical-char= ch :exit)
+		  (logical-char= ch :no)
+		  (logical-char= ch :yes)
+		  keep-p)
+	(unread-char ch *editor-input*)))))
+
+;;; MORE-READ-CH gets some input from the type of stream bound to
+;;; *editor-input*.  Need to loop over SERVE-EVENT since it returns on any kind
+;;; of event (not necessarily a key or button event).
+;;;
+;;; Currently this does not work for keyboard macro streams!
+;;; 
+(defun more-read-ch ()
+  (clear-input *editor-input*)
+  (let ((ch (do ((ch (dq-event *editor-input*) (dq-event *editor-input*)))
+		(ch ch)
+	      (system:serve-event))))
+    (when (or (char= ch #\control-g) (char= ch #\control-\g))
+      (beep)
+      (throw 'editor-top-level-catcher nil))
+    ch))
+
+
+;;; Input method macro.
+;;; 
+
+(defvar *in-hemlock-stream-input-method* nil
+  "This keeps us from undefined nasties like re-entering Hemlock stream
+   input methods from input hooks and scheduled events.")
+
+(proclaim '(special *screen-image-trashed*))
+
+;;; EDITOR-INPUT-METHOD-MACRO is used in EDITOR-TTY-IN and EDITOR-WINDOW-IN.
+;;; Somewhat odd stuff goes on here because this is the place where Hemlock
+;;; waits, so this is where we redisplay, check the time for scheduled
+;;; events, etc.  In the loop, we call the input hook when we get a character
+;;; and leave the loop.  If there isn't any input, invoke any scheduled
+;;; events whose time is up.  Unless SERVE-EVENT returns immediately and did
+;;; something, (serve-event 0), call redisplay, note that we are going into
+;;; a read wait, and call SERVE-EVENT with a wait or infinite timeout.  Upon
+;;; exiting the loop, turn off the read wait note and check for the abort
+;;; character.  Return the character we got.
+;;; We bind an error condition handler here because the default Hemlock
+;;; error handler goes into a little debugging prompt loop, but if we got
+;;; an error in getting input, we should prompt the user using the input
+;;; method (recursively even).
+;;; 
+(eval-when (compile eval)
+(defmacro editor-input-method-macro (&optional screen-image-trashed-concern)
+  `(handler-bind ((error #'(lambda (condition)
+			     (let ((device (device-hunk-device
+					    (window-hunk (current-window)))))
+			       (funcall (device-exit device) device))
+			     (invoke-debugger condition))))
+;     (when *in-hemlock-stream-input-method*
+;       (error "Entering Hemlock stream input method recursively!"))
+     (let ((*in-hemlock-stream-input-method* t)
+	   (nrw-fun (device-note-read-wait
+		     (device-hunk-device (window-hunk (current-window)))))
+	   char)
+       (loop
+	 (when (setf char (dq-event stream))
+	   (dolist (f (variable-value 'ed::input-hook)) (funcall f))
+	   (return))
+	 (invoke-scheduled-events)
+	 (unless (system:serve-event 0)
+	   (internal-redisplay)
+	   ,@(if screen-image-trashed-concern
+		 '((when *screen-image-trashed* (internal-redisplay))))
+	   (when nrw-fun (funcall nrw-fun t))
+	   (let ((wait (next-scheduled-event-wait)))
+	     (if wait (system:serve-event wait) (system:serve-event)))))
+       (when nrw-fun (funcall nrw-fun nil))
+       (when (and (or (char= char #\control-g) (char= char #\control-\g))
+		  eof-error-p)
+	 (beep)
+	 (throw 'editor-top-level-catcher nil))
+       char)))
+) ;eval-when
+
+
+
+;;;; Editor tty input streams.
+
+(defstruct (editor-tty-input-stream
+	    (:include editor-input-stream
+		      (:in #'editor-tty-in)
+		      (:misc #'editor-tty-misc))
+	    (:print-function
+	     (lambda (obj stream n)
+	       (declare (ignore obj n))
+	       (write-string "#<Editor-Tty-Input stream>" stream)))
+	    (:constructor make-editor-tty-input-stream
+			  (fd &optional (head (make-key-event)) (tail head))))
+  fd)
+
+
+(defun editor-tty-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg2))
+  (case operation
+    (:listen (cond ((key-event-next (editor-input-stream-head stream)) t)
+		   ((editor-tty-listen stream) t)
+		   (t nil)))
+    (:unread
+     (un-event arg1 stream))
+    (:clear-input
+     (without-interrupts
+      (let* ((head (editor-input-stream-head stream))
+	     (next (key-event-next head)))
+	(when next
+	  (setf (key-event-next head) nil)
+	  (shiftf (key-event-next (editor-input-stream-tail stream))
+		  *free-key-events* next)
+	  (setf (editor-input-stream-tail stream) head)))))
+    (:element-type 'character)))
+
+
+(defun editor-tty-in (stream eof-error-p eof-value)
+  (declare (ignore eof-value))
+  (editor-input-method-macro t))
+
+
+
+;;;; Editor window input streams.
+
+(defstruct (editor-window-input-stream
+	    (:include editor-input-stream
+		      (:in #'editor-window-in)
+		      (:misc #'editor-window-misc))
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore s d write))
+	       (write-string "#<Editor-Window-Input stream>" stream)))
+	    (:constructor make-editor-window-input-stream
+			  (&optional (head (make-key-event)) (tail head))))
+  hunks)    ; List of bitmap-hunks which input to this stream.
+
+
+(defun editor-window-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg2))
+  (case operation
+    (:listen
+     (loop (unless (system:serve-event 0)
+	     ;; If nothing is pending, check the queued input.
+	     (return (not (null (key-event-next
+				 (editor-input-stream-head stream))))))
+           (when (key-event-next (editor-input-stream-head stream))
+	     ;; Don't service anymore events if we just got some input.
+	     (return t))))
+    (:unread
+     (un-event arg1 stream))
+    (:clear-input
+     (loop (unless (system:serve-event 0) (return)))
+     (without-interrupts
+      (let* ((head (editor-input-stream-head stream))
+	     (next (key-event-next head)))
+	(when next
+	  (setf (key-event-next head) nil)
+	  (shiftf (key-event-next (editor-input-stream-tail stream))
+		  *free-key-events* next)
+	  (setf (editor-input-stream-tail stream) head)))))
+    (:element-type 'character)))
+
+
+(defun editor-window-in (stream eof-error-p eof-value)
+  (declare (ignore eof-value))
+  (editor-input-method-macro))
+
+
+
+;;; LAST-KEY-EVENT-CURSORPOS  --  Public
+;;;
+;;;    Just look up the saved info in the last read key event.
+;;;
+(defun last-key-event-cursorpos ()
+  "Return as values, the (X, Y) character position and window where the
+  last key event happened.  If this cannot be determined, Nil is returned.
+  If in the modeline, return a Y position of NIL and the correct X and window.
+  Returns nil for terminal input."
+  (let* ((ev (editor-input-stream-head *real-editor-input*))
+	 (hunk (key-event-hunk ev))
+	 (window (and hunk (device-hunk-window hunk))))
+    (when window
+      (values (key-event-x ev) (key-event-y ev) window))))
+
+
+;;; Window-Input-Handler  --  Internal
+;;;
+;;;    This is the input-handler function for hunks that implement windows.
+;;; It just queues the events on the *real-editor-input* stream.
+;;;
+(defun window-input-handler (hunk char x y)
+  (q-event *real-editor-input* char x y hunk))
+
+
+
+;;;; Event scheduling.
+
+;;; The time queue provides a ROUGH mechanism for scheduling events to
+;;; occur after a given amount of time has passed, optionally repeating
+;;; using the given time as an interval for rescheduling.  When the input
+;;; loop goes around, it will check the current time and process all events
+;;; that should have happened before or at this time.  The function gets
+;;; called on the number of seconds that have elapsed since it was last
+;;; called.
+;;;
+;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the
+;;; editor stream in methods.
+;;;
+;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
+
+(defstruct (tq-event (:print-function print-tq-event)
+		     (:constructor make-tq-event
+				   (time last-time interval function)))
+  time		; When the event should happen.
+  last-time	; When the event was scheduled.
+  interval	; When non-nil, how often the event should happen.
+  function)	; What to do.
+
+(defun print-tq-event (obj stream n)
+  (declare (ignore n))
+  (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
+
+(defvar *time-queue* nil
+  "This is the time priority queue used in Hemlock input streams for event
+   scheduling.")
+
+;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*.
+;;; Event is inserted before the first element that it is less than (which
+;;; means that it gets inserted after elements that are the same).
+;;; *time-queue* is returned.
+;;; 
+(defun queue-time-event (event)
+  (let ((time (tq-event-time event)))
+    (if *time-queue*
+	(if (< time (tq-event-time (car *time-queue*)))
+	    (push event *time-queue*)
+	    (do ((prev *time-queue* rest)
+		 (rest (cdr *time-queue*) (cdr rest)))
+		((or (null rest)
+		     (< time (tq-event-time (car rest))))
+		 (push event (cdr prev))
+		 *time-queue*)))
+	(push event *time-queue*))))
+
+;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
+;;; the next event to happen.
+;;; 
+(defun next-scheduled-event-wait ()
+  (if *time-queue*
+      (let ((wait (round (- (tq-event-time (car *time-queue*))
+			    (get-internal-real-time))
+			 internal-time-units-per-second)))
+	(if (plusp wait) wait 0))))
+
+;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose
+;;; time has come.  If we run out of events, or there are none, then we get
+;;; out.  If we popped an event whose time hasn't come, we push it back on the
+;;; queue.  Each function is called on how many seconds, roughly, went by since
+;;; the last time it was called (or scheduled).  If it has an interval, we
+;;; re-queue it.  While invoking the function, bind *time-queue* to nothing in
+;;; case the event function tries to read off *editor-input*.
+;;;
+(defun invoke-scheduled-events ()
+  (let ((time (get-internal-real-time)))
+    (loop
+      (unless *time-queue* (return))
+      (let* ((event (car *time-queue*))
+	     (event-time (tq-event-time event)))
+	(cond ((>= time event-time)
+	       (let ((*time-queue* nil))
+		 (funcall (tq-event-function event)
+			  (round (- time (tq-event-last-time event))
+				 internal-time-units-per-second)))
+	       (without-interrupts
+		(let ((interval (tq-event-interval event)))
+		  (when interval
+		    (setf (tq-event-time event) (+ time interval))
+		    (setf (tq-event-last-time event) time)
+		    (pop *time-queue*)
+		    (queue-time-event event)))))
+	      (t (return)))))))
+
+(defun schedule-event (time function &optional (repeat t))
+  "This causes function to be called after time seconds have passed,
+   optionally repeating every time seconds.  This is a rough mechanism
+   since commands can take an arbitrary amount of time to run; the function
+   will be called at the first possible moment after time has elapsed.
+   Function takes the time that has elapsed since the last time it was
+   called (or since it was scheduled for the first invocation)."
+  (let ((now (get-internal-real-time))
+	(itime (* internal-time-units-per-second time)))
+    (queue-time-event (make-tq-event (+ itime now) now (if repeat itime)
+				     function))))
+
+(defun remove-scheduled-event (function)
+  "Removes function queued with SCHEDULE-EVENT."
+  (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
+
+
+
+;;;; Editor sleeping.
+
+(defun editor-sleep (time)
+  "Sleep for approximately Time seconds."
+  (unless (or (zerop time) (listen *editor-input*))
+    (internal-redisplay)
+    (sleep-for-time time)
+    nil))
+
+(defun sleep-for-time (time)
+  (let ((nrw-fun (device-note-read-wait
+		  (device-hunk-device (window-hunk (current-window)))))
+	(end (+ (get-internal-real-time)
+		(truncate (* time internal-time-units-per-second)))))
+    (loop
+      (when (listen *editor-input*) (return))
+      (let ((left (- end (get-internal-real-time))))
+	(unless (plusp left) (return nil))
+	(when nrw-fun (funcall nrw-fun t))
+	(system:serve-event (/ (float left)
+			       (float internal-time-units-per-second)))))
+    (when nrw-fun (funcall nrw-fun nil))))
+
+
+
+;;;; Showing a mark.
+
+(defun show-mark (mark window time)
+  "Highlights the position of Mark within Window for Time seconds,
+   possibly by moving the cursor there.  If Mark is not displayed within
+   Window return NIL.  The wait may be aborted if there is pending input."
+  (let* ((result t))
+    (catch 'redisplay-catcher
+      (redisplay-window window)
+      (setf result
+	    (multiple-value-bind (x y) (mark-to-cursorpos mark window)
+	      (funcall (device-show-mark
+			(device-hunk-device (window-hunk window)))
+		       window x y time))))
+    result))
+
+(defun tty-show-mark (window x y time)
+  (cond ((listen *editor-input*))
+	(x (internal-redisplay)
+	   (let* ((hunk (window-hunk window))
+		  (device (device-hunk-device hunk)))
+	     (funcall (device-put-cursor device) hunk x y)
+	     (when (device-force-output device)
+	       (funcall (device-force-output device)))
+	     (sleep-for-time time))
+	   t)
+	(t nil)))
+
+(defun bitmap-show-mark (window x y time)
+  (cond ((listen *editor-input*))
+	(x (let* ((hunk (window-hunk window))
+		  (display (bitmap-device-display (device-hunk-device hunk))))
+	     (internal-redisplay)
+	     (hunk-show-cursor hunk x y)
+	     (drop-cursor)
+	     (xlib:display-finish-output display)
+	     (sleep-for-time time)
+	     (lift-cursor)
+	     t))
+	(t nil)))
+
+
+
+;;;; Funny character stuff.
+
+;;; TEXT-CHARACTER and PRINT-PRETTY-CHARACTER are documented Hemlock primitives.
+;;;
+
+(defun text-character (char)
+  "Translate a character as read from *editor-input* into one suitable for
+   inserting into text.  If this is not possible, nil is returned."
+  (cond ((or (char-bit char :meta)
+	     (char-bit char :super)
+	     (char-bit char :hyper))
+	 nil)
+	((char= char #\return) #\newline)
+	((char-bit char :control)
+	 (let* ((nchar (char-upcase (make-char char)))
+		(code (char-code nchar)))
+	   (if (<= 64 code 95)
+	       (code-char (- code 64))
+	       nil)))
+	(t char)))
+
+(defun print-pretty-character (char stream)
+  "Prints char to stream suitably for documentation, data displays, etc.
+   Control, Meta, Super, and Hyper bits are shown as C-, M-, S-, and H-,
+   respectively.  If the character is not a standard character other than
+   #\space or #\newline, and it has a name, then the name is printed."
+  (when (char-bit char :control) (write-string "C-" stream))
+  (when (char-bit char :meta) (write-string "M-" stream))
+  (when (char-bit char :super) (write-string "S-" stream))
+  (when (char-bit char :hyper) (write-string "H-" stream))
+  (let ((code (char-code char))
+	(safe-char (make-char char)))
+    (if (<= (char-code #\!) code (char-code #\~))
+	(write-char safe-char stream)
+	(let ((name (char-name (code-char code))))
+	  (cond (name (write-string (string-capitalize name) stream))
+		((< code (char-code #\space))
+		 (write-char #\^ stream)
+		 (write-char (code-char (+ code (char-code #\@))) stream))
+		(t
+		 (write-char safe-char stream)))))))
+
+(defvar *line-wrap-char* #\!
+  "The character to be displayed to indicate wrapped lines.")
+
+
+
+;;;; Function description and defined-from.
+
+;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
+;;; returns a pathname for the file the function was defined in.  If it was
+;;; not defined in some file, then nil is returned.
+;;; 
+(defun fun-defined-from-pathname (function)
+  "Takes a symbol or function and returns the pathname for the file the function
+   was defined in.  If it was not defined in some file, nil is returned."
+  (typecase function
+    (symbol (fun-defined-from-pathname (careful-symbol-function function)))
+    (compiled-function
+     (let* ((string (%primitive header-ref function
+				system:%function-defined-from-slot))
+	    (file (subseq string 0 (position #\space string :test #'char=))))
+       (declare (simple-string file))
+       (if (or (char= #\# (schar file 0))
+	       (string-equal file "lisp"))
+	   nil
+	   (if (string= file "/.." :end1 3)
+	       (pathname (subseq file
+				 (position #\/ file :test #'char= :start 4)))
+	       (pathname file)))))
+    (t nil)))
+
+
+(defvar *editor-describe-stream*
+  (system:make-indenting-stream *standard-output*))
+
+;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
+;;; work.  These apparently work fine for DESCRIBE, for which they were defined,
+;;; but not in general.  It seems they don't indent initial text, only that
+;;; following a newline, so inside our use of INDENTING-FURTHER, we need some
+;;; form before the WRITE-STRING.  To get this to work, I had to remove the ~%
+;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with
+;;; the ~% caused an extra blank line.  Possibly I should not have glommed onto
+;;; this hack whose interface comes from three different packages, but it did
+;;; the right thing ....
+;;;
+;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream
+;;; is based on whatever *standard-output* is when we are called.
+;;;
+(defun editor-describe-function (fun sym)
+  "Calls DESCRIBE on fun.  If fun is compiled, and its original name is not sym,
+   then this also outputs any 'function documentation for sym to
+   *standard-output*."
+  (describe fun)
+  (when (and (compiled-function-p fun)
+	     (not (eq (%primitive header-ref fun %function-name-slot) sym)))
+    (let ((doc (documentation sym 'function)))
+      (when doc
+	(format t "~&Function documentation for ~S:" sym)
+	(setf (lisp::indenting-stream-stream *editor-describe-stream*)
+	      *standard-output*)
+	(ext:indenting-further *editor-describe-stream* 2
+	  (fresh-line *editor-describe-stream*)
+	  (write-string doc *editor-describe-stream*))))))
+
+
+
+
+;;;; X Stuff.
+
+;;; Setting window cursors ...
+;;; 
+
+(proclaim '(special *default-foreground-pixel* *default-background-pixel*))
+
+(defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.")
+
+;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook".
+;;; 
+(defun define-window-cursor (window)
+  (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window)))
+	*hemlock-cursor*))
+
+;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN.
+;;;
+(defvar *cursor-foreground-color* nil)
+(defvar *cursor-background-color* nil)
+(defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
+(defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
+
+
+;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the
+;;; hemlock cursor for DEFINE-WINDOW-CURSOR.
+;;;
+(defun get-hemlock-cursor (display)
+  (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*))
+  (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file)))
+	 (mask-file (probe-file (make-pathname :type "mask"
+					       :defaults cursor-file)))
+	 (root (xlib:screen-root (xlib:display-default-screen display)))
+	 (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file))))
+    (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot)
+			 (get-cursor-pixmap root cursor-file)
+      (setf *hemlock-cursor*
+	    (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
+				:x cursor-x-hot :y cursor-y-hot
+				:foreground *cursor-foreground-color*
+				:background *cursor-background-color*))
+      (xlib:free-pixmap cursor-pixmap)
+      (when mask-pixmap (xlib:free-pixmap mask-pixmap)))))
+
+(defun get-cursor-pixmap (root pathname)
+  (let* ((image (xlib:read-bitmap-file pathname))
+	 (pixmap (xlib:create-pixmap :width 16 :height 16
+				     :depth 1 :drawable root))
+	 (gc (xlib:create-gcontext
+	      :drawable pixmap :function boole-1
+	      :foreground *default-foreground-pixel*
+	      :background *default-background-pixel*)))
+    (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
+    (xlib:free-gcontext gc)
+    (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image))))
+
+
+;;; Setting up grey borders ...
+;;; 
+
+(defparameter hemlock-grey-bitmap-data
+  '(#*10 #*01))
+
+(defun get-hemlock-grey-pixmap (display)
+  (let* ((screen (xlib:display-default-screen display))
+	 (depth (xlib:screen-root-depth screen))
+	 (root (xlib:screen-root screen))
+	 (height (length hemlock-grey-bitmap-data))
+	 (width (length (car hemlock-grey-bitmap-data)))
+	 (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data))
+	 (pixmap (xlib:create-pixmap :width width :height height
+				     :depth depth :drawable root))
+	 (gc (xlib:create-gcontext :drawable pixmap
+				   :function boole-1
+				   :foreground *default-foreground-pixel*
+				   :background *default-background-pixel*)))
+    (xlib:put-image pixmap gc image
+		    :x 0 :y 0 :width width :height height :bitmap-p t)
+    (xlib:free-gcontext gc)
+    pixmap))
+
+
+;;; Cut Buffer manipulation ...
+;;;
+
+(defun store-cut-string (display string)
+  (check-type string simple-string)
+  (setf (xlib:cut-buffer display) string))
+
+(defun fetch-cut-string (display)
+  (xlib:cut-buffer display))
+
+
+;;; Window naming ...
+;;;
+(defun set-window-name-for-buffer-name (buffer new-name)
+  (dolist (ele (buffer-windows buffer))
+    (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele))
+				  :icon-name new-name)))
+  
+(defun set-window-name-for-window-buffer (window new-buffer)
+  (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window))
+				:icon-name (buffer-name new-buffer)))
+
+
+
+;;;; Some hacks for supporting Hemlock under Mach.
+
+;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function
+;;; to determine if it needs to go around fixing all the windows.
+;;;
+(defun windowed-monitor-p ()
+  "This returns whether the monitor is being used with a window system.  It
+   returns the console's CLX display structure."
+  *editor-windowed-input*)
+
+(defun get-terminal-name ()
+  (cdr (assoc :term *environment-list* :test #'eq)))
+
+(defun get-termcap-env-var ()
+  (cdr (assoc :termcap *environment-list* :test #'eq)))
+
+
+
+(defvar *editor-buffer* (make-string 256))
+
+;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events
+;;; in the stream's queue.
+;;;
+(defun get-editor-tty-input (fd)
+  (let* ((buf *editor-buffer*)
+	 (len (mach:unix-read fd buf 256))
+	 (i 0))
+    (declare (simple-string buf) (fixnum len i))
+    (loop
+      (when (>= i len) (return t))
+      (q-event *real-editor-input*
+	       (translate-tty-char (char-code (schar buf i))))
+      (incf i))))
+
+;;; This is used to get listening during smart redisplay to pick up input
+;;; in between displaying each line by listening longer (or slowing down
+;;; line output depending on your model).  10-20 seems to be good for 9600
+;;; baud, and 250 seems to do it with 1200 baud.
+;;; 
+(defparameter listen-iterations-hack 1) ; 10-20 seems to really pick up input.
+
+(defun editor-tty-listen (stream)
+  (mach::with-trap-arg-block mach::int1 nc
+    (dotimes (i listen-iterations-hack nil)
+      (multiple-value-bind (val err) 
+			   (mach::Unix-ioctl (editor-tty-input-stream-fd stream)
+					     mach::FIONREAD
+					     (lisp::alien-value-sap
+					      mach::int1))
+	(declare (ignore err))
+	(when (and val
+		   (> (alien-access (mach::int1-int (alien-value nc))) 0))
+	  (return t))))))
+
+
+
+(defvar old-flags)
+
+(defvar old-tchars)
+
+(defvar old-ltchars)
+
+(defun setup-input ()
+  (let ((fd *editor-file-descriptor*))
+    (when (mach:unix-isatty 0)
+      (mach:with-trap-arg-block mach:sgtty sg
+	(multiple-value-bind
+	    (val err)
+	    (mach:unix-ioctl fd mach:TIOCGETP
+			     (lisp::alien-value-sap mach:sgtty))
+	  (if (null val)
+	      (error "Could not get tty information, unix error ~S."
+		     (mach:get-unix-error-msg err)))
+	  (let ((flags (alien-access (mach::sgtty-flags (alien-value sg)))))
+	    (setq old-flags flags)
+	    (setf (alien-access (mach::sgtty-flags (alien-value sg)))
+		  (logand (logior flags mach::tty-cbreak)
+			  (lognot mach::tty-echo)
+			  (lognot mach::tty-crmod)))
+	    (multiple-value-bind
+		(val err)
+		(mach:unix-ioctl fd mach:TIOCSETP
+				 (lisp::alien-value-sap mach:sgtty))
+	      (if (null val)
+		  (error "Could not set tty information, unix error ~S."
+			 (mach:get-unix-error-msg err)))))))
+      (mach:with-trap-arg-block mach:tchars tc
+	(multiple-value-bind
+	    (val err)
+	    (mach:unix-ioctl fd mach:TIOCGETC
+			     (lisp::alien-value-sap mach:tchars))
+	  (if (null val)
+	      (error "Could not get tty tchars information, unix error ~S."
+		     (mach:get-unix-error-msg err)))
+	  (setq old-tchars
+		(vector (alien-access (mach::tchars-intrc (alien-value tc)))
+			(alien-access (mach::tchars-quitc (alien-value tc)))
+			(alien-access (mach::tchars-startc (alien-value tc)))
+			(alien-access (mach::tchars-stopc (alien-value tc)))
+			(alien-access (mach::tchars-eofc (alien-value tc)))
+			(alien-access (mach::tchars-brkc (alien-value tc))))))
+	(setf (alien-access (mach::tchars-intrc (alien-value tc)))
+	      (if *editor-windowed-input* -1 28))
+	(setf (alien-access (mach::tchars-quitc (alien-value tc))) -1)
+	(setf (alien-access (mach::tchars-startc (alien-value tc))) -1)
+	(setf (alien-access (mach::tchars-stopc (alien-value tc))) -1)
+	(setf (alien-access (mach::tchars-eofc (alien-value tc))) -1)
+	(setf (alien-access (mach::tchars-brkc (alien-value tc))) -1)
+	(multiple-value-bind
+	    (val err)
+	    (mach:unix-ioctl fd mach:TIOCSETC
+			     (lisp::alien-value-sap mach:tchars))
+	  (if (null val) (error "Failed to set tchars, unix error ~S."
+				(mach:get-unix-error-msg err)))))
+      (mach:with-trap-arg-block mach:ltchars tc
+	(multiple-value-bind
+	    (val err)
+	    (mach:unix-ioctl fd mach:TIOCGLTC
+			     (lisp::alien-value-sap mach:ltchars))
+	  (if (null val)
+	      (error "Could not get tty ltchars information, unix error ~S."
+		     (mach:get-unix-error-msg err)))
+	  (setq old-ltchars
+		(vector (alien-access (mach::ltchars-suspc (alien-value tc)))
+			(alien-access (mach::ltchars-dsuspc (alien-value tc)))
+			(alien-access (mach::ltchars-rprntc (alien-value tc)))
+			(alien-access (mach::ltchars-flushc (alien-value tc)))
+			(alien-access (mach::ltchars-werasc (alien-value tc)))
+			(alien-access (mach::ltchars-lnextc (alien-value tc))))))
+	(setf (alien-access (mach::ltchars-suspc (alien-value tc))) -1)
+	(setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) -1)
+	(setf (alien-access (mach::ltchars-rprntc (alien-value tc))) -1)
+	(setf (alien-access (mach::ltchars-flushc (alien-value tc))) -1)
+	(setf (alien-access (mach::ltchars-werasc (alien-value tc))) -1)
+	(setf (alien-access (mach::ltchars-lnextc (alien-value tc))) -1)
+	(multiple-value-bind
+	    (val err)
+	    (mach:unix-ioctl fd mach:TIOCSLTC
+			     (lisp::alien-value-sap mach:ltchars))
+	  (if (null val) (error "Failed to set ltchars, unix error ~S."
+				(mach:get-unix-error-msg err))))))))
+
+	
+(defun reset-input ()
+  (when (mach:unix-isatty 0)
+    (if (boundp 'old-flags)
+	(let ((fd *editor-file-descriptor*))
+	  (mach:with-trap-arg-block mach:sgtty sg
+	    (multiple-value-bind
+		(val err)
+		(mach:unix-ioctl fd mach:TIOCGETP
+				 (lisp::alien-value-sap mach:sgtty))
+	      (if (null val)
+		  (error "Could not get tty information, unix error ~S."
+			 (mach:get-unix-error-msg err)))
+	      (setf (alien-access (mach::sgtty-flags (alien-value sg)))
+		    old-flags)
+	      (multiple-value-bind
+		  (val err)
+		  (mach:unix-ioctl fd mach:TIOCSETP
+				   (lisp::alien-value-sap mach:sgtty))
+		(if (null val)
+		    (error "Could not set tty information, unix error ~S."
+			   (mach:get-unix-error-msg err))))))
+	  (cond ((and (boundp 'old-tchars)
+		      (simple-vector-p old-tchars)
+		      (eq (length old-tchars) 6))
+		 (mach:with-trap-arg-block mach:tchars tc
+		   (setf (alien-access (mach::tchars-intrc (alien-value tc)))
+			 (svref old-tchars 0))
+		   (setf (alien-access (mach::tchars-quitc (alien-value tc)))
+			 (svref old-tchars 1))
+		   (setf (alien-access (mach::tchars-startc (alien-value tc)))
+			 (svref old-tchars 2))
+		   (setf (alien-access (mach::tchars-stopc (alien-value tc)))
+			 (svref old-tchars 3))
+		   (setf (alien-access (mach::tchars-eofc (alien-value tc)))
+			 (svref old-tchars 4))
+		   (setf (alien-access (mach::tchars-brkc (alien-value tc)))
+			 (svref old-tchars 5))
+		   (multiple-value-bind
+		       (val err)
+		       (mach:unix-ioctl fd mach:TIOCSETC
+					(lisp::alien-value-sap mach:tchars))
+		     (if (null val)
+			 (error "Failed to set tchars, unix error ~S."
+				(mach:get-unix-error-msg err)))))))
+	  (cond ((and (boundp 'old-ltchars)
+		      (simple-vector-p old-ltchars)
+		      (eq (length old-ltchars) 6))
+		 (mach:with-trap-arg-block mach:ltchars tc
+		   (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
+			 (svref old-ltchars 0))
+		   (setf (alien-access (mach::ltchars-dsuspc (alien-value tc)))
+			 (svref old-ltchars 1))
+		   (setf (alien-access (mach::ltchars-rprntc (alien-value tc)))
+			 (svref old-ltchars 2))
+		   (setf (alien-access (mach::ltchars-flushc (alien-value tc)))
+			 (svref old-ltchars 3))
+		   (setf (alien-access (mach::ltchars-werasc (alien-value tc)))
+			 (svref old-ltchars 4))
+		   (setf (alien-access (mach::ltchars-lnextc (alien-value tc)))
+			 (svref old-ltchars 5))
+		   (multiple-value-bind
+		       (val err)
+		       (mach:unix-ioctl fd mach:TIOCSLTC
+					(lisp::alien-value-sap mach:ltchars))
+		     (if (null val)
+			 (error "Failed to set ltchars, unix error ~S."
+				(mach:get-unix-error-msg err)))))))))))
+
+
+(defun pause-hemlock ()
+  "Pause hemlock and pop out to the Unix Shell."
+  (mach:unix-kill (mach:unix-getpid) mach:sigtstp)
+  T)
diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a82f122d0b4df965113e00976133a774e80d7ed4
--- /dev/null
+++ b/hemlock/screen.lisp
@@ -0,0 +1,188 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles.
+;;;
+;;; Device independent screen management functions.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(make-window delete-window next-window previous-window))
+
+
+
+;;;; Screen management initialization.
+
+(proclaim '(special *echo-area-buffer*))
+
+;;; %INIT-SCREEN-MANAGER creates the initial windows and sets up the data
+;;; structures used by the screen manager.  The "Main" and "Echo Area" buffer
+;;; modelines are set here in case the user modified these Hemlock variables in
+;;; his init file.  Since these buffers don't have windows yet, these sets
+;;; won't cause any updates to occur.  This is called from %INIT-REDISPLAY.
+;;;
+(defun %init-screen-manager (display)
+  (setf (buffer-modeline-fields *current-buffer*)
+	(value ed::default-modeline-fields))
+  (setf (buffer-modeline-fields *echo-area-buffer*)
+	(value ed::default-status-line-fields))
+  (if (windowed-monitor-p)
+      (init-bitmap-screen-manager display)
+      (init-tty-screen-manager (get-terminal-name))))
+
+
+
+;;;; Window operations.
+
+(defun make-window (start &key
+			  (modelinep t)
+			  (device nil)
+			  window
+			  (font-family *default-font-family*)
+			  (ask-user nil)
+			  x y
+			  (width (value ed::default-window-width))
+			  (height (value ed::default-window-height)))
+  "Make a window that displays text starting at the mark Start.
+
+   Modelinep specifies whether the window should display buffer modelines.
+
+   Device is the Hemlock device to make the window on.  If it is nil, then
+   the window is made on the same device as CURRENT-WINDOW.
+
+   Window is an X window to be used for the Hemlock window.  If not specified,
+   we make one by calling the function in *create-window-hook*.  This hook maps
+   the window to the screen.
+
+   Font-Family is the font-family used for displaying text in the window.
+
+   If Ask-User is non-nil, the user is prompted for missing X, Y, Width, and
+   Height arguments.  X and Y are supplied as pixels, but Width and Height are
+   supplied in characters.  Otherwise, the current window's height is halved,
+   and the new window fills the created space.  If halving the current window
+   results in too small of a window, then a new one is made the same size as
+   the current, offsetting its vertical placement on the screen some pixels."
+  
+  (let* ((device (or device (device-hunk-device (window-hunk (current-window)))))
+	 (window (funcall (device-make-window device)
+			  device start modelinep window font-family
+			  ask-user x y width height)))
+    (unless window (editor-error "Could not make a window."))
+    (invoke-hook ed::make-window-hook window)
+    window))
+
+(defun delete-window (window)
+  "Make Window go away, removing it from the screen.  Uses *delete-window-hook*
+   to get rid of bitmap window system windows."
+  (when (eq window *current-window*)
+    (error "Cannot kill the current window."))
+  (invoke-hook ed::delete-window-hook window)
+  (setq *window-list* (delq window *window-list*))
+  (funcall (device-delete-window (device-hunk-device (window-hunk window)))
+	   window))
+
+(defun next-window (window)
+  "Return the next window after Window, wrapping around if Window is the
+  bottom window."
+  (check-type window window)
+  (funcall (device-next-window (device-hunk-device (window-hunk window)))
+	   window))
+
+(defun previous-window (window)
+  "Return the previous window after Window, wrapping around if Window is the
+  top window."
+  (check-type window window)
+  (funcall (device-previous-window (device-hunk-device (window-hunk window)))
+	   window))
+
+
+
+;;;; Random typeout support.
+
+;;; PREPARE-FOR-RANDOM-TYPEOUT  --  Internal
+;;;
+;;; The WITH-POP-UP-DISPLAY macro calls this just before displaying output
+;;; for the user.  This goes to some effor to compute the height of the window
+;;; in text lines if it is not supplied.  Whether it is supplied or not, we
+;;; add one to the height for the modeline, and we subtract one line if the
+;;; last line is empty.  Just before using the height, make sure it is at
+;;; least two -- one for the modeline and one for text, so window making
+;;; primitives don't puke.
+;;;
+(defun prepare-for-random-typeout (stream height)
+  (let* ((buffer (line-buffer (mark-line (random-typeout-stream-mark stream))))
+	 (real-height (1+ (or height (rt-count-lines buffer))))
+	 (device (device-hunk-device (window-hunk (current-window)))))
+    (funcall (device-random-typeout-setup device) device stream
+	     (max (if (and (empty-line-p (buffer-end-mark buffer)) (not height))
+		      (1- real-height)
+		      real-height)
+		  2))))
+
+;;; RT-COUNT-LINES computes the correct height for a window.  This includes
+;;; taking wrapping line characters into account.  Take the MARK-COLUMN at
+;;; the end of each line.  This is how many characters long hemlock thinks
+;;; the line is.  When it is displayed, however, end of line characters are
+;;; added to the end of each line that wraps.  The second INCF form adds
+;;; these to the current line length.  Then INCF the current height by the
+;;; CEILING of the width of the random typeout window and the line length
+;;; (with added line-end chars).  Use CEILING because there is always at
+;;; least one line.  Finally, jump out of the loop if we're at the end of
+;;; the buffer.
+;;;
+(defun rt-count-lines (buffer)
+  (with-mark ((mark (buffer-start-mark buffer)))
+    (let ((width (window-width (current-window)))
+	  (count 0))
+	(loop
+	  (let* ((column (mark-column (line-end mark)))
+		 (temp (ceiling (incf column (floor (1- column) width))
+				width)))
+	    ;; Lines with no characters yield zero temp.
+	    (incf count (if (zerop temp) 1 temp))
+	    (unless (line-offset mark 1) (return count)))))))
+
+
+;;; RANDOM-TYPEOUT-CLEANUP  --  Internal
+;;;
+;;;    Clean up after random typeout.  This clears the area where the 
+;;; random typeout was and redisplays any affected windows.
+;;;
+(defun random-typeout-cleanup (stream &optional (degree t))
+  (let* ((window (random-typeout-stream-window stream))
+	 (buffer (window-buffer window))
+	 (device (device-hunk-device (window-hunk window)))
+	 (*more-prompt-action* :normal))
+    (update-modeline-field buffer window :more-prompt)
+    (random-typeout-redisplay window)
+    (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))
+    (funcall (device-random-typeout-cleanup device) stream degree)
+    (when (device-force-output device)
+      (funcall (device-force-output device)))))
+
+;;; *more-prompt-action* is bound in random typeout streams before
+;;; redisplaying.
+;;;
+(defvar *more-prompt-action* :normal)
+(defvar *random-typeout-ml-fields*
+  (list (make-modeline-field
+	 :name :more-prompt
+	 :function #'(lambda (buffer window)
+		       (declare (ignore buffer window))
+		       (ecase *more-prompt-action*
+			 (:more "--More--")
+			 (:flush "--Flush--")
+			 (:empty "")
+			 (:normal
+			  (concatenate 'simple-string
+				       "Random Typeout Buffer          ["
+				       (buffer-name buffer)
+				       "]")))))))
diff --git a/hemlock/search1.lisp b/hemlock/search1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0fe8d11aab0220eb8bd08c085aab4d8f91d71dc0
--- /dev/null
+++ b/hemlock/search1.lisp
@@ -0,0 +1,649 @@
+;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Searching and replacing functions for Hemlock.
+;;; Originally written by Skef Wholey, Rewritten by Rob MacLachlan.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(search-pattern search-pattern-p find-pattern replace-pattern
+			 new-search-pattern))
+
+
+
+;;; The search pattern structure is used only by simple searches, more
+;;; complex ones make structures which include it.
+
+(defstruct (search-pattern (:print-function %print-search-pattern)
+			   (:constructor internal-make-search-pattern))
+  kind			      ; The kind of pattern to search for.
+  direction		      ; The direction to search in.
+  pattern		      ; The search pattern to use.
+  search-function	      ; The function to call to search.
+  reclaim-function)	      ; The function to call to reclaim this pattern.
+
+(setf (documentation 'search-pattern-p 'function)
+  "Returns true if its argument is a Hemlock search-pattern object,
+  Nil otherwise.")
+
+(defun %print-search-pattern (object stream depth)
+  (let ((*print-level* (and *print-level* (- *print-level* depth)))
+	(*print-case* :downcase))
+    (declare (special *print-level* *print-case*))
+    (write-string "#<Hemlock " stream)
+    (princ (search-pattern-direction object) stream)
+    (write-char #\space stream)
+    (princ (search-pattern-kind object) stream)
+    (write-string " Search-Pattern for ")
+    (prin1 (search-pattern-pattern object) stream)
+    (write-char #\> stream)
+    (terpri stream)))
+
+(defvar *search-pattern-experts* (make-hash-table :test #'eq)
+  "Holds an eq hashtable which associates search kinds with the functions
+  that know how to make patterns of that kind.")
+(defvar *search-pattern-documentation* ()
+  "A list of all the kinds of search-pattern that are defined.")
+
+;;; define-search-kind  --  Internal
+;;;
+;;;    This macro is used to define a new kind of search pattern.  Kind
+;;; is the kind of search pattern to define.  Lambda-list is the argument 
+;;; list for the expert-function to be built and forms it's body.
+;;; The arguments passed are the direction, the pattern, and either
+;;; an old search-pattern of the same type or nil.  Documentation
+;;; is put on the search-pattern-documentation property of the kind
+;;; keyword.
+;;;
+(eval-when (compile eval)
+(defmacro define-search-kind (kind lambda-list documentation &body forms)
+  (let ((dummy (gensym)))
+    `(progn
+      (push ,documentation *search-pattern-documentation*)
+      (defun ,dummy ()
+	(setf (gethash ,kind *search-pattern-experts*)
+	      #'(lambda ,lambda-list ,@forms)))
+      (,dummy))))
+); eval-when (compile eval)
+
+;;; new-search-pattern  --  Public
+;;;
+;;;    This function deallocates any old search-pattern and then dispatches
+;;; to the correct expert.
+;;;
+(defun new-search-pattern (kind direction pattern &optional
+				result-search-pattern)
+  "Makes a new Hemlock search pattern of kind Kind to search direction
+  using Pattern.  Direction is either :backward or :forward.
+  If supplied, result-search-pattern is a pattern to destroy to make
+  the new one.  The variable *search-pattern-documentation* contains
+  documentation for each kind."
+  (unless (or (eq direction :forward) (eq direction :backward))
+    (error "~S is not a legal search direction." direction))
+  (when result-search-pattern
+    (funcall (search-pattern-reclaim-function result-search-pattern)
+	     result-search-pattern)
+    (unless (eq kind (search-pattern-kind result-search-pattern))
+      (setq result-search-pattern nil)))
+  (let ((expert (gethash kind *search-pattern-experts*)))
+    (unless expert
+      (error "~S is not a defined search pattern kind." kind))
+    (funcall expert direction pattern result-search-pattern)))
+
+;;;; stuff to allocate and de-allocate simple-vectors search-char-code-limit
+;;;; in length.
+
+(defvar *spare-search-vectors* ())
+(eval-when (compile eval)
+(defmacro new-search-vector ()
+  `(if *spare-search-vectors*
+       (pop *spare-search-vectors*)
+       (make-array search-char-code-limit)))
+
+(defmacro dispose-search-vector (vec)
+  `(push ,vec *spare-search-vectors*))
+); eval-when (compile eval)
+
+;;;; macros used by various search kinds:
+
+;;; search-once-forward-macro  --  Internal
+;;;
+;;;    Passes search-fun strings, starts and lengths to do a forward
+;;; search.  The other-args are passed through to the searching
+;;; function after after everything else  The search-fun is
+;;; expected to return NIL if nothing is found, or it index where the
+;;; match ocurred.  Something non-nil is returned if something is
+;;; found and line and start are set to where it was found.
+;;;
+(eval-when (compile eval)
+(defmacro search-once-forward-macro (line start search-fun &rest other-args)
+  `(do* ((l ,line)
+	 (chars (line-chars l) (line-chars l))
+	 (len (length chars) (length chars))
+	 (start-pos ,start 0) index)
+	(())
+     (declare (simple-string chars) (fixnum index start-pos len))
+     (setq index (,search-fun chars start-pos len ,@other-args))
+     (when index
+       (setq ,start index  ,line l)
+       (return t))
+     (setq l (line-next l))
+     (when (null l) (return nil))))
+
+
+;;; search-once-backward-macro  --  Internal
+;;;
+;;;    Like search-once-forward-macro, except it goes backwards.  Length
+;;; is not passed to the search function, since it won't need it.
+;;;
+(defmacro search-once-backward-macro (line start search-fun &rest other-args)
+  `(do* ((l ,line)
+	 (chars (line-chars l) (line-chars l))
+	 (start-pos (1- ,start) (1- (length chars))) index)
+	(())
+     (declare (simple-string chars) (fixnum index start-pos))
+     (setq index (,search-fun chars start-pos ,@other-args))
+     (when index
+       (setq ,start index  ,line l)
+       (return t))
+     (setq l (line-previous l))
+     (when (null l) (return nil))))
+); eval-when (compile eval)
+
+;;;; String Searches.
+;;;
+;;; We use the Boyer-Moore algorithm for string searches.
+;;;
+
+;;; sensitive-string-search-macro  --  Internal
+;;;
+;;;    This macro does a case-sensitive Boyer-Moore string search.
+;;;
+;;; Args:
+;;;    String - The string to search in.
+;;;    Start - The place to start searching at.
+;;;    Length - NIL if going backward, the length of String if going forward.
+;;;    Pattern - A simple-vector of characters.  A simple-vector is used 
+;;; rather than a string because it is believed that simple-vector access
+;;; will be faster in most implementations.
+;;;    Patlen - The length of Pattern.
+;;;    Last - (1- Patlen)
+;;;    Jumps - The jump vector as given by compute-boyer-moore-jumps
+;;;    +/- - The function to increment with, either + (forward) or -
+;;; (backward)
+;;;    -/+ - Like +/-, only the other way around.
+(eval-when (compile eval)
+(defmacro sensitive-string-search-macro (string start length pattern patlen
+						last jumps +/- -/+)
+  `(do ((scan (,+/- ,start ,last))
+	(patp ,last))
+       (,(if length `(>= scan ,length) '(minusp scan)))
+     (declare (fixnum scan patp))
+     (let ((char (schar ,string scan)))
+       (cond
+	((char= char (svref ,pattern patp))
+	 (if (zerop patp)
+	     (return scan)
+	     (setq scan (,-/+ scan 1)  patp (1- patp))))
+	(t
+	 ;; If mismatch consult jump table to find amount to skip.
+	 (let ((jump (svref ,jumps (search-char-code char))))
+	   (declare (fixnum jump))
+	   (if (> jump (- ,patlen patp))
+	       (setq scan (,+/- scan jump))
+	       (setq scan (,+/- scan (- ,patlen patp)))))
+	 (setq patp ,last))))))
+
+;;; insensitive-string-search-macro  --  Internal
+;;;
+;;;    This macro is very similar to the case sensitive one, except that
+;;; we do the search for a hashed string, and then when we find a match
+;;; we compare the uppercased search string with the found string uppercased
+;;; and only say we win when they match too.
+;;;
+(defmacro insensitive-string-search-macro (string start length pattern
+						  folded-string patlen last
+						  jumps  +/- -/+)
+  `(do ((scan (,+/- ,start ,last))
+	(patp ,last))
+       (,(if length `(>= scan ,length) '(minusp scan)))
+     (declare (fixnum scan patp))
+     (let ((hash (search-hash-code (schar ,string scan))))
+       (declare (fixnum hash))
+       (cond
+	((= hash (the fixnum (svref ,pattern patp)))
+	 (if (zerop patp)
+	     (if (do ((i ,last (1- i)))
+		     (())
+		   (when (char/=
+			  (search-char-upcase (schar ,string (,+/- scan i)))
+			  (schar ,folded-string i))
+		     (return nil))
+		   (when (zerop i) (return t)))
+		 (return scan)
+		 (setq scan (,+/- scan ,patlen)  patp ,last))
+	     (setq scan (,-/+ scan 1)  patp (1- patp))))
+	(t
+	 ;; If mismatch consult jump table to find amount to skip.
+	 (let ((jump (svref ,jumps hash)))
+	   (declare (fixnum jump))
+	   (if (> jump (- ,patlen patp))
+	       (setq scan (,+/- scan jump))
+	       (setq scan (,+/- scan (- ,patlen patp)))))
+	 (setq patp ,last))))))
+
+;;;; Searching for strings with newlines in them:
+;;;
+;;;    Due to the buffer representation, search-strings with embedded 
+;;; newlines need to be special-cased.  What we do is break
+;;; the search string up into lines and then searching for a line with
+;;; the correct prefix.  This is actually a faster search.
+;;; For this one we just have one big hairy macro conditionalized for
+;;; both case-sensitivity and direction.  Have fun!!
+
+;;; newline-search-macro  --  Internal
+;;;
+;;;    Do a search for a string containing newlines.  Line is the line
+;;; to start on, and Start is the position to start at.  Pattern and
+;;; optionally Pattern2, are simple-vectors of things that represent
+;;; each line in the pattern, and are passed to Test-Fun.  Pattern
+;;; must contain simple-strings so we can take the length.  Test-Fun is a
+;;; thing to compare two strings and see if they are equal.  Forward-p
+;;; tells whether to go forward or backward.
+;;;
+(defmacro newline-search-macro (line start test-fun pattern forward-p
+				     &optional pattern2)
+  `(let* ((patlen (length ,pattern))
+	  (first (svref ,pattern 0))
+	  (firstlen (length first))
+	  (l ,line)
+	  (chars (line-chars l))
+	  (len (length chars))
+	  ,@(if pattern2 `((other (svref ,pattern2 0)))))
+     (declare (simple-string first chars) (fixnum firstlen patlen len))
+     ,(if forward-p
+	  ;; If doing a forward search, go to the next line if we could not
+	  ;; match due to the start position.
+	  `(when (< (- len ,start) firstlen)
+	     (setq l (line-next l)))
+	  ;; If doing a backward search, go to the previous line if the current
+	  ;; line could not match the last line in the pattern, and then go
+	  ;; back the 1- number of lines in the pattern to avoid a possible
+	  ;; match across the starting point.
+	  `(let ((1-len (1- patlen)))
+	     (declare (fixnum 1-len))
+	     (when (< ,start (length (the simple-string
+					  (svref ,pattern 1-len))))
+	       (setq l (line-previous l)))
+	     (dotimes (i 1-len)
+	       (when (null l) (return nil))
+	       (setq l (line-previous l)))))
+     (do* ()
+	  ((null l))
+       (setq chars (line-chars l)  len (length chars))
+       ;; If the end of this line is the first line in the pattern then check
+       ;; to see if the other lines match.
+       (when (and (>= len firstlen)
+		  (,test-fun chars first other
+			     :start1 (- len firstlen) :end1 len
+			     :end2 firstlen))
+	 (when
+	  (do ((m (line-next l) (line-next m))
+	       (i 2 (1+ i))
+	       (next (svref ,pattern 1) (svref ,pattern i))
+	       ,@(if pattern2
+		     `((another (svref ,pattern2 1)
+				(svref ,pattern2 i))))
+	       len chars nextlen)
+	       ((null m))
+	    (declare (simple-string next chars) (fixnum len nextlen i))
+	    (setq chars (line-chars m)  nextlen (length next)
+		  len (length chars))
+	    ;; When on last line of pattern, check if prefix of line.
+	    (when (= i patlen)
+	      (return (and (>= len nextlen)
+			   (,test-fun chars next another :end1 nextlen
+				      :end2 nextlen))))
+	    (unless (,test-fun chars next another :end1 len
+			       :end2 nextlen)
+	      (return nil)))
+	  (setq ,line l  ,start (- len firstlen))
+	  (return t)))
+       ;; If not, try the next line
+       (setq l ,(if forward-p '(line-next l) '(line-previous l))))))
+
+;;;; String-comparison macros that are passed to newline-search-macro
+
+;;; case-sensitive-test-fun  --  Internal
+;;;
+;;;    Just thows away the extra arg and calls string=.
+;;;
+(defmacro case-sensitive-test-fun (string1 string2 ignore &rest keys)
+  `(string= ,string1 ,string2 ,@keys))
+
+;;; case-insensitive-test-fun  --  Internal
+;;;
+;;;    First compare the characters hashed with hashed-string2 and then
+;;; only if they agree do an actual compare with case-folding.
+;;;
+(defmacro case-insensitive-test-fun (string1 string2 hashed-string2
+					     &key end1 (start1 0) end2)
+  `(when (= (- ,end1 ,start1) ,end2)
+     (do ((i 0 (1+ i)))
+	 ((= i ,end2)
+	  (dotimes (i ,end2 t)
+	    (when (char/= (search-char-upcase (schar ,string1 (+ ,start1 i)))
+			  (schar ,string2 i))
+	      (return nil))))
+       (when (/= (search-hash-code (schar ,string1 (+ ,start1 i)))
+		 (svref ,hashed-string2 i))
+	 (return nil)))))
+); eval-when (compile eval)
+
+;;; compute-boyer-moore-jumps  --  Internal
+;;;
+;;;    Compute return a jump-vector to do a Boyer-Moore search for 
+;;; the "string" of things in Vector.  Access-fun is a function
+;;; that aref's vector and returns a number.
+;;;
+(defun compute-boyer-moore-jumps (vec access-fun)
+  (declare (simple-vector vec))
+  (let ((jumps (new-search-vector))
+	(len (length vec)))
+    (declare (simple-vector jumps))
+    (when (zerop len) (error "Zero length search string not allowed."))
+    ;; The default jump is the length of the search string.
+    (dotimes (i search-char-code-limit)
+      (setf (aref jumps i) len))
+    ;; For chars in the string the jump is the distance from the end.
+    (dotimes (i len)
+      (setf (aref jumps (funcall access-fun vec i)) (- len i 1)))
+    jumps))
+
+;;;; Case insensitive searches
+
+;;; In order to avoid case folding, we do a case-insensitive hash of
+;;; each character.  We then search for string in this translated
+;;; character set, and reject false successes by checking of the found
+;;; string is string-equal the the original search string.
+;;;
+
+(defstruct (string-insensitive-search-pattern
+	    (:include search-pattern)
+	    (:conc-name string-insensitive-)
+	    (:print-function %print-search-pattern))
+  jumps
+  hashed-string
+  folded-string)
+
+;;;  Search-Hash-String  --  Internal
+;;;
+;;;    Return a simple-vector containing the search-hash-codes of the
+;;; characters in String.
+;;;
+(defun search-hash-string (string)
+  (declare (simple-string string))
+  (let* ((len (length string))
+	 (result (make-array len)))
+    (declare (fixnum len) (simple-vector result))
+    (dotimes (i len result)
+      (setf (aref result i) (search-hash-code (schar string i))))))
+
+;;; make-insensitive-newline-pattern  -- Internal
+;;;
+;;;    Make bash in fields in a string-insensitive-search-pattern to
+;;; do a search for a string with newlines in it.
+;;;
+(defun make-insensitive-newline-pattern (pattern folded-string)
+  (declare (simple-string folded-string))
+  (let* ((len (length folded-string))
+	 (num (1+ (count #\newline folded-string :end len)))
+	 (hashed (make-array num))
+	 (folded (make-array num)))
+    (declare (simple-vector hashed folded) (fixnum len num))
+    (do ((prev 0 nl)
+	 (i 0 (1+ i))
+	 (nl (position #\newline folded-string :end len)
+	     (position #\newline folded-string :start nl  :end len)))
+	((null nl)
+	 (let ((piece (subseq folded-string prev len)))
+	   (setf (aref folded i) piece)
+	   (setf (aref hashed i) (search-hash-string piece))))
+      (let ((piece (subseq folded-string prev nl)))
+	(setf (aref folded i) piece)
+	(setf (aref hashed i) (search-hash-string piece)))
+      (incf nl))
+    (setf (string-insensitive-folded-string pattern) folded
+	  (string-insensitive-hashed-string pattern) hashed)))
+
+(define-search-kind :string-insensitive (direction pattern old)
+  ":string-insensitive - Pattern is a string to do a case-insensitive
+  search for."
+  (unless old (setq old (make-string-insensitive-search-pattern)))
+  (setf (search-pattern-kind old) :string-insensitive
+	(search-pattern-direction old) direction
+	(search-pattern-pattern old) pattern)
+  (let* ((folded-string (string-upcase pattern)))
+    (declare (simple-string folded-string))
+    (cond
+     ((find #\newline folded-string)
+      (make-insensitive-newline-pattern old folded-string)
+      (setf (search-pattern-search-function old)
+	    (if (eq direction :forward)
+		#'insensitive-find-newline-once-forward-method
+		#'insensitive-find-newline-once-backward-method))
+      (setf (search-pattern-reclaim-function old) #'identity))
+     (t
+      (case direction
+	(:forward
+	 (setf (search-pattern-search-function old)
+	       #'insensitive-find-string-once-forward-method))
+	(t
+	 (setf (search-pattern-search-function old)
+	       #'insensitive-find-string-once-backward-method)
+	 (nreverse folded-string)))
+      (let ((hashed-string (search-hash-string folded-string)))
+	(setf (string-insensitive-hashed-string old) hashed-string
+	      (string-insensitive-folded-string old) folded-string)
+	(setf (string-insensitive-jumps old)
+	      (compute-boyer-moore-jumps hashed-string #'svref))
+	(setf (search-pattern-reclaim-function old)
+	      #'(lambda (p)
+		  (dispose-search-vector (string-insensitive-jumps p))))))))
+  old)
+
+(defun insensitive-find-string-once-forward-method (pattern line start)
+  (let* ((hashed-string (string-insensitive-hashed-string pattern))
+	 (folded-string (string-insensitive-folded-string pattern))
+	 (jumps (string-insensitive-jumps pattern))
+	 (patlen (length hashed-string))
+	 (last (1- patlen)))
+    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
+	     (fixnum patlen last))
+    (when (search-once-forward-macro
+	   line start insensitive-string-search-macro
+	   hashed-string folded-string patlen last jumps + -)
+      (values line start patlen))))
+
+(defun insensitive-find-string-once-backward-method (pattern line start)
+  (let* ((hashed-string (string-insensitive-hashed-string pattern))
+	 (folded-string (string-insensitive-folded-string pattern))
+	 (jumps (string-insensitive-jumps pattern))
+	 (patlen (length hashed-string))
+	 (last (1- patlen)))
+    (declare (simple-vector jumps hashed-string) (simple-string folded-string)
+	     (fixnum patlen last))
+    (when (search-once-backward-macro
+	   line start insensitive-string-search-macro
+	   nil hashed-string folded-string patlen last jumps - +)
+      (values line (- start last) patlen))))
+
+(eval-when (compile eval)
+(defmacro def-insensitive-newline-search-method (name direction)
+  `(defun ,name (pattern line start)
+     (let* ((hashed (string-insensitive-hashed-string pattern))
+	    (folded-string (string-insensitive-folded-string pattern))
+	    (patlen (length (the string (search-pattern-pattern pattern)))))
+       (declare (simple-vector hashed folded-string))
+       (when (newline-search-macro line start case-insensitive-test-fun
+				   folded-string ,direction hashed)
+	 (values line start patlen)))))
+); eval-when (compile eval)
+
+(def-insensitive-newline-search-method
+  insensitive-find-newline-once-forward-method t)
+(def-insensitive-newline-search-method
+  insensitive-find-newline-once-backward-method nil)
+
+;;;; And Snore, case sensitive.
+;;;
+;;;    This is horribly repetitive, but if I introduce another level of
+;;; macroexpansion I will go Insaaaane....
+;;;
+(defstruct (string-sensitive-search-pattern
+	    (:include search-pattern)
+	    (:conc-name string-sensitive-)
+	    (:print-function %print-search-pattern))
+  string
+  jumps)
+
+;;; make-sensitive-newline-pattern  -- Internal
+;;;
+;;;    The same, only more sensitive (it hurts when you do that...)
+;;;
+(defun make-sensitive-newline-pattern (pattern string)
+  (declare (simple-vector string))
+  (let* ((string (coerce string 'simple-string))
+	 (len (length string))
+	 (num (1+ (count #\newline string :end len)))
+	 (sliced (make-array num)))
+    (declare (simple-string string) (simple-vector sliced) (fixnum len num))
+    (do ((prev 0 nl)
+	 (i 0 (1+ i))
+	 (nl (position #\newline string :end len)
+	     (position #\newline string :start nl  :end len)))
+	((null nl)
+	 (setf (aref sliced i) (subseq string prev len)))
+      (setf (aref sliced i) (subseq string prev nl))
+      (incf nl))
+    (setf (string-sensitive-string pattern) sliced)))
+
+(define-search-kind :string-sensitive (direction pattern old)
+  ":string-sensitive - Pattern is a string to do a case-sensitive
+  search for."
+  (unless old (setq old (make-string-sensitive-search-pattern)))
+  (setf (search-pattern-kind old) :string-sensitive
+	(search-pattern-direction old) direction
+	(search-pattern-pattern old) pattern)
+  (let* ((string (coerce pattern 'simple-vector)))
+    (declare (simple-vector string))
+    (cond
+     ((find #\newline string)
+      (make-sensitive-newline-pattern old string)
+      (setf (search-pattern-search-function old)
+	    (if (eq direction :forward)
+		#'sensitive-find-newline-once-forward-method
+		#'sensitive-find-newline-once-backward-method))
+      (setf (search-pattern-reclaim-function old) #'identity))
+     (t
+      (case direction
+	(:forward
+	 (setf (search-pattern-search-function old)
+	       #'sensitive-find-string-once-forward-method))
+	(t
+	 (setf (search-pattern-search-function old)
+	       #'sensitive-find-string-once-backward-method)
+	 (nreverse string)))
+      (setf (string-sensitive-string old) string)
+      (setf (string-sensitive-jumps old)
+	    (compute-boyer-moore-jumps
+	     string #'(lambda (v i) (char-code (svref v i)))))
+      (setf (search-pattern-reclaim-function old)
+	    #'(lambda (p)
+		(dispose-search-vector (string-sensitive-jumps p)))))))
+  old)
+
+(defun sensitive-find-string-once-forward-method (pattern line start)
+  (let* ((string (string-sensitive-string pattern))
+	 (jumps (string-sensitive-jumps pattern))
+	 (patlen (length string))
+	 (last (1- patlen)))
+    (declare (simple-vector jumps string) (fixnum patlen last))
+    (when (search-once-forward-macro
+	   line start sensitive-string-search-macro
+	   string patlen last jumps + -)
+      (values line start patlen))))
+
+(defun sensitive-find-string-once-backward-method (pattern line start)
+  (let* ((string (string-sensitive-string pattern))
+	 (jumps (string-sensitive-jumps pattern))
+	 (patlen (length string))
+	 (last (1- patlen)))
+    (declare (simple-vector jumps string) (fixnum patlen last))
+    (when (search-once-backward-macro
+	   line start sensitive-string-search-macro
+	   nil string patlen last jumps - +)
+      (values line (- start last) patlen))))
+
+(eval-when (compile eval)
+(defmacro def-sensitive-newline-search-method (name direction)
+  `(defun ,name (pattern line start)
+     (let* ((string (string-sensitive-string pattern))
+	    (patlen (length (the string (search-pattern-pattern pattern)))))
+       (declare (simple-vector string))
+       (when (newline-search-macro line start case-sensitive-test-fun
+				   string ,direction)
+	 (values line start patlen)))))
+); eval-when (compile eval)
+
+(def-sensitive-newline-search-method
+  sensitive-find-newline-once-forward-method t)
+(def-sensitive-newline-search-method
+  sensitive-find-newline-once-backward-method nil)
+
+(defun find-pattern (mark search-pattern)
+  "Find a match of Search-Pattern starting at Mark.  Mark is moved to
+  point before the match and the number of characters matched is returned.
+  If there is no match for the pattern then Mark is not modified and NIL
+  is returned."
+  (close-line)
+  (multiple-value-bind (line start matched)
+		       (funcall (search-pattern-search-function search-pattern)
+				search-pattern (mark-line mark)
+				(mark-charpos mark))
+    (when matched
+      (move-to-position mark start line)
+      matched)))
+
+;;; replace-pattern  --  Public
+;;;
+;;;
+(defun replace-pattern (mark search-pattern replacement &optional n)
+  "Replaces N occurrences of the Search-Pattern with the Replacement string
+  in the text starting at the given Mark.  If N is Nil, all occurrences 
+  following the Mark are replaced."
+  (close-line)
+  (do* ((replacement (coerce replacement 'simple-string))
+	(new (length (the simple-string replacement)))
+	(fun (search-pattern-search-function search-pattern))
+	(forward-p (eq (search-pattern-direction search-pattern) :forward))
+	(n (if n (1- n) -1) (1- n))
+	(m (copy-mark mark :temporary)) line start matched)
+       (())
+    (multiple-value-setq (line start matched)
+      (funcall fun search-pattern (mark-line m) (mark-charpos m)))
+    (unless matched (return m))
+    (setf (mark-line m) line  (mark-charpos m) start)
+    (delete-characters m matched)
+    (insert-string m replacement)
+    (when forward-p (character-offset m new))
+    (when (zerop n) (return m))
+    (close-line)))
diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3d79ff505f6c4f291d256eaf92653140f90e10a9
--- /dev/null
+++ b/hemlock/shell.lisp
@@ -0,0 +1,329 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Hemlock command level support for processes.
+;;;
+;;; Written by Blaine Burks.
+;;;
+
+(in-package "HEMLOCK")
+
+
+(defun setup-process-buffer (buffer)
+  (let ((mark (copy-mark (buffer-point buffer) :right-inserting)))
+    (defhvar "Buffer Input Mark"
+      "The buffer input mark for this buffer."
+      :buffer buffer
+      :value mark)
+    (defhvar "Process Output Stream"
+      "The process structure for this buffer."
+      :buffer buffer
+      :value (make-hemlock-output-stream mark))
+    (defhvar "Interactive History"
+      "A ring of the regions input to an interactive mode (Eval or Typescript)."
+      :buffer buffer
+      :value (make-ring (value interactive-history-length)))
+    (defhvar "Interactive Pointer"
+      "Pointer into \"Interactive History\"."
+      :buffer buffer
+      :value 0)
+    (defhvar "Searching Interactive Pointer"
+      "Pointer into \"Interactive History\"."
+      :buffer buffer
+      :value 0)
+    (unless (buffer-modeline-field-p buffer :process-status)
+      (setf (buffer-modeline-fields buffer)
+	    (nconc (buffer-modeline-fields buffer)
+		   (list (modeline-field :process-status)))))))
+
+(defmode "Process" :major-p nil :setup-function #'setup-process-buffer)
+
+
+;;;; Support for handling input before the prompt in process buffers.
+
+(defun unwedge-process-buffer ()
+  (buffer-end (current-point))
+  (deliver-signal-to-process :SIGINT (value process))
+  (editor-error "Aborted."))
+
+(defhvar "Unwedge Interactive Input Fun"
+  "Function to call when input is confirmed, but the point is not past the
+   input mark."
+  :value #'unwedge-process-buffer
+  :mode "Process")
+
+(defhvar "Unwedge Interactive Input String"
+  "String to add to \"Point not past input mark.  \" explaining what will
+   happen if the the user chooses to be unwedged."
+  :value "Interrupt and throw to end of buffer?"
+  :mode "Process")
+
+
+;;;; Some Global Variables.
+
+(defhvar "Current Shell"
+  "The shell that  \"Select Shell\" will zap you to.")
+
+(defhvar "Kill Process Confirm"
+  "When non-nil, ask the user whether he really wants to blow away the shell. ~
+   Otherwise, just blow it away."
+  :value T)
+
+(defhvar "Shell Utility"
+  "The shell command uses this as the default command line."
+  :value "/bin/csh")
+
+(defhvar "Shell Utility Switches"
+  "This is list of strings that are the default command line arguments to the
+   utility in \"Shell Utility\"."
+  :value nil)
+
+
+
+;;;; The Shell and New Shell Commands.
+
+(defcommand "Shell" (p)
+  "If a shell buffer exists, pop to it.  Otherwise creates a new one and pop to
+   it.  With an argument, prompt for a command and buffer to execute it in."
+  "If a shell buffer exists, pop to it.  Otherwise creates a new one and pop to
+   it.  With an argument, prompt for a command and buffer to execute it in."
+  (let ((shell (value current-shell)))
+    (if shell (change-to-buffer shell) (make-new-shell p))))
+
+(defcommand "New Shell" (p)
+  "Creates a new shell and puts you in it."
+  "Creates a new shell and puts you in it."
+  (make-new-shell p))
+
+(defun make-new-shell (prompt-for-command-p
+		       &optional (command-line (get-command-line) clp))
+  (let* ((command (or (and clp command-line)
+		      (if prompt-for-command-p
+			  (prompt-for-string
+			   :default command-line :trim t
+			   :prompt "Command to execute: "
+			   :help "Shell command line to execute.")
+			  command-line)))
+	 (buffer-name (if prompt-for-command-p
+			  (prompt-for-string
+			   :default
+			   (concatenate 'simple-string command " process")
+			   :trim t
+			   :prompt `("Buffer in which to execute ~A? "
+				     ,command)
+			   :help "Where output from this process will appear.")
+			  (new-shell-name)))
+	 (buffer (make-buffer
+		  buffer-name
+		  :modes '("Fundamental" "Process")
+		  :delete-hook
+		  (list #'(lambda (buffer)
+			    (when (eq (value current-shell) buffer)
+			      (setf (value current-shell) nil))
+			    (kill-process (variable-value 'process
+							  :buffer buffer)))))))
+    (unless buffer
+      (setf buffer (getstring buffer-name *buffer-names*))
+      (buffer-end (buffer-point buffer)))
+    (defhvar "Process"
+      "The process for Shell and Process buffers."
+      :buffer buffer
+      :value (ext::run-program "/bin/sh" (list "-c" command)
+			       :wait nil
+			       :pty (variable-value 'process-output-stream
+						    :buffer buffer)
+			       :env (frob-environment-list
+				     (car (buffer-windows buffer)))
+			       :status-hook #'(lambda (process)
+						(declare (ignore process))
+						(update-process-buffer buffer))
+			       :input t :output t))
+    (update-process-buffer buffer)
+    (unless (value current-shell)
+      (setf (value current-shell) buffer))
+    (change-to-buffer buffer)))
+
+;;; GET-COMMAND-LINE -- Internal.
+;;;
+;;; This just conses up a string to feed to the shell.
+;;;
+(defun get-command-line ()
+  (concatenate 'simple-string (value shell-utility) " "
+	       (value shell-utility-switches)))
+
+;;; FROB-ENVIRONMENT-LIST -- Internal.
+;;;
+;;; This sets some environment variables so the shell will be in the proper
+;;; state when it comes up.
+;;;
+(defun frob-environment-list (window)
+  (list* (cons :termcap  (concatenate 'simple-string
+				      "emacs:co#"
+				      (if window
+					  (lisp::quick-integer-to-string
+					   (window-width window))
+					  "")
+				      ":tc=unkown:"))
+	 (cons :emacs "t") (cons :term "emacs")
+	 (remove-if #'(lambda (keyword)
+			(member keyword '(:termcap :emacs :term)
+				:test #'(lambda (cons keyword)
+					  (eql (car cons) keyword))))
+		    ext:*environment-list*)))
+
+;;; NEW-SHELL-NAME -- Internal.
+;;;
+;;; This returns a unique buffer name for a shell by incrementing the value of
+;;; *process-number* until "Process <*process-number*> is not already the name
+;;; of a buffer.  Perhaps this is being overly cautious, but I've seen some
+;;; really stupid users.
+;;;
+(defvar *process-number* 0)
+;;;
+(defun new-shell-name ()
+  (loop
+    (let ((buffer-name (format nil "Shell ~D" (incf *process-number*))))
+      (unless (getstring buffer-name *buffer-names*) (return buffer-name)))))
+
+
+;;;; Modeline support.
+
+(defun modeline-process-status (buffer window)
+  (declare (ignore window))
+  (when (hemlock-bound-p 'process :buffer buffer)
+    (let ((process (variable-value 'process :buffer buffer)))
+      (ecase (ext:process-status process)
+	(:running "running")
+	(:stopped "stopped")
+	(:signaled "killed by signal ~D" (mach:unix-signal-name
+					  (ext:process-exit-code process)))
+	(:exited (format nil "exited with status ~D"
+			 (ext:process-exit-code process)))))))
+			 
+
+(make-modeline-field :name :process-status
+		     :function #'modeline-process-status)
+
+(defun update-process-buffer (buffer)
+  (when (buffer-modeline-field-p buffer :process-status)
+    (dolist (window (buffer-windows buffer))
+      (update-modeline-field buffer window :process-status)))
+  (let ((process (variable-value 'process :buffer buffer)))
+    (unless (ext:process-alive-p process)
+      (ext:process-close process)
+      (setf (value current-shell) nil))))
+
+
+;;;; Supporting Commands.
+
+(defcommand "Confirm Process Input" (p)
+  "Evaluate Process Mode input between the point and last prompt."
+  "Evaluate Process Mode input between the point and last prompt."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (let* ((process (value process))
+	 (stream (ext:process-pty process)))
+    (case (ext:process-status process)
+      (:running)
+      (:stopped (editor-error "The process has been stopped."))
+      (t (editor-error "The process is dead.")))
+    (let ((input-region (get-interactive-input)))
+      (write-line (region-to-string input-region) stream)
+      (force-output (ext:process-pty process))
+      (insert-character (current-point) #\newline)
+      ;; Move "Buffer Input Mark" to end of buffer.
+      (move-mark (region-start input-region) (region-end input-region)))))
+
+(defcommand "Kill Main Process" (p)
+  "Kills the process in the current buffer."
+  "Kills the process in the current buffer."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (when (or (not (value kill-process-confirm))
+	    (prompt-for-y-or-n :default nil
+			       :prompt "Really blow away shell? "
+			       :default nil
+			       :default-string "no"))
+    (kill-process (value process))))
+
+(defcommand "Stop Main Process" (p)
+  "Stops the process in the current buffer.  With an argument use :SIGSTOP
+   instead of :SIGTSTP."
+  "Stops the process in the current buffer.  With an argument use :SIGSTOP
+  instead of :SIGTSTP."
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (deliver-signal-to-process (if p :SIGSTOP :SIGTSTP) (value process)))
+
+(defcommand "Continue Main Process" (p)
+  "Continues the process in the current buffer."
+  "Continues the process in the current buffer."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (deliver-signal-to-process :SIGCONT (value process)))
+  
+(defun kill-process (process)
+  "Self-explanatory."
+  (deliver-signal-to-process :SIGKILL process))
+
+(defun deliver-signal-to-process (signal process)
+  "Delivers a signal to a process."
+  (ext:process-kill process signal :process-group))
+
+(defcommand "Send EOF to Process" (p)
+  "Sends a Ctrl-D to the process in the current buffer."
+  "Sends a Ctrl-D to the process in the current buffer."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (let ((stream (ext:process-pty (value process))))
+    (write-char (int-char 4) stream)
+    (force-output stream)))
+
+(defcommand "Interrupt Buffer Subprocess" (p)
+  "Stop the subprocess currently executing in this shell."
+  "Stop the subprocess currently executing in this shell."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (buffer-end (current-point))
+  (buffer-end (value buffer-input-mark))
+  (deliver-signal-to-subprocess :SIGINT (value process)))
+
+(defcommand "Kill Buffer Subprocess" (p)
+  "Kill the subprocess currently executing in this shell."
+  "Kill the subprocess currently executing in this shell."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))  
+  (deliver-signal-to-subprocess :SIGKILL (value process)))
+
+(defcommand "Quit Buffer Subprocess" (p)
+  "Quit the subprocess currently executing int his shell."
+  "Quit the subprocess currently executing int his shell."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))
+  (deliver-signal-to-subprocess :SIGQUIT (value process)))
+
+(defcommand "Stop Buffer Subprocess" (p)
+  "Stop the subprocess currently executing in this shell."
+  "Stop the subprocess currently executing in this shell."
+  (declare (ignore p))
+  (unless (hemlock-bound-p 'process :buffer (current-buffer))
+    (editor-error "Not in a process buffer."))  
+  (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process)))
+
+(defun deliver-signal-to-subprocess (signal process)
+  "Delivers a signal to a subprocess of a shell."
+  (ext:process-kill process signal :pty-process-group))
diff --git a/hemlock/spell-aug.lisp b/hemlock/spell-aug.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..32b5d19f14e785ff292ef345191fd0fe05fa5603
--- /dev/null
+++ b/hemlock/spell-aug.lisp
@@ -0,0 +1,235 @@
+;;; -*- Log: hemlock.log; Package: Spell -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;    Designed by Bill Chiles and Rob Maclachlan
+;;;
+;;; This file contains the code to grow the spelling dictionary in system
+;;; space by reading a text file of entries or adding one at a time.  This
+;;; code relies on implementation dependent code found in Spell-RT.Lisp.
+
+
+(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
+
+(export '(spell-add-entry spell-read-dictionary spell-remove-entry
+	  spell-root-flags))
+
+
+
+;;;; Converting Flags to Masks
+
+(defconstant flag-names-to-masks
+  `((#\V . ,V-mask) (#\N . ,N-mask) (#\X . ,X-mask)
+    (#\H . ,H-mask) (#\Y . ,Y-mask) (#\G . ,G-mask)
+    (#\J . ,J-mask) (#\D . ,D-mask) (#\T . ,T-mask)
+    (#\R . ,R-mask) (#\Z . ,Z-mask) (#\S . ,S-mask)
+    (#\P . ,P-mask) (#\M . ,M-mask)))
+
+(defvar *flag-masks*
+  (make-array 128 :element-type '(unsigned-byte 16) :initial-element 0)
+  "This holds the masks for character flags, which is used when reading
+   a text file of dictionary words.  Illegal character flags hold zero.")
+
+(eval-when (compile eval)
+(defmacro flag-mask (char)
+  `(aref *flag-masks* (char-code ,char)))
+) ;eval-when
+
+(dolist (e flag-names-to-masks)
+  (let ((char (car e))
+	(mask (cdr e)))
+    (setf (flag-mask char) mask)
+    (setf (flag-mask (char-downcase char)) mask)))
+
+
+
+;;;; String and Hashing Macros
+
+(eval-when (compile eval)
+
+(defmacro string-table-replace (src-string dst-start length)
+  `(sap-replace *string-table* ,src-string 0 ,dst-start (+ ,dst-start ,length)))
+
+;;; HASH-ENTRY is used in SPELL-ADD-ENTRY to find a dictionary location for
+;;; adding a new entry.  If a location contains a zero, then it has never
+;;; been used, and no entries have ever been "hashed past" it.  If a location
+;;; contains a -1, then it once contained an entry that has since been
+;;; deleted.
+;;; 
+(defmacro hash-entry (entry entry-len)
+  (let ((loop-loc (gensym)) (loc-contents (gensym))
+	(hash (gensym)) (loc (gensym)))
+    `(let* ((,hash (string-hash ,entry ,entry-len))
+	    (,loc (rem ,hash (the fixnum *dictionary-size*)))
+	    (,loc-contents (dictionary-ref ,loc)))
+       (declare (fixnum ,loc ,loc-contents))
+       (if (or (zerop ,loc-contents) (= ,loc-contents -1))
+	   ,loc
+	   (hash2-loop (,loop-loc ,loc-contents) ,loc ,hash
+	     ,loop-loc nil t)))))
+
+) ;eval-when
+
+
+
+;;;; Top Level Stuff
+
+(defun spell-read-dictionary (filename)
+  "Add entries to dictionary from lines in the file filename."
+  (with-open-file (s filename :direction :input)
+    (loop (multiple-value-bind (entry eofp) (read-line s nil nil)
+	    (declare (simple-string entry))
+	    (unless entry (return))
+	    (spell-add-entry entry)
+	    (if eofp (return))))))
+
+
+;;; This is used to break up an 18 bit string table index into two parts
+;;; for storage in a word descriptor unit.  See the documentation at the
+;;; top of Spell-Correct.Lisp.
+;;;
+(defconstant whole-index-low-byte (byte 16 0))
+
+(defun spell-add-entry (line &optional
+			     (word-end (or (position #\/ line :test #'char=)
+					   (length line))))
+  "Line is of the form \"entry/flag1/flag2\" or \"entry\".  It is parsed and
+   added to the spelling dictionary.  Line is desstructively modified."
+  (declare (simple-string line) (fixnum word-end))
+  (nstring-upcase line :end word-end)
+  (when (> word-end max-entry-length)
+    (return-from spell-add-entry nil))
+  (let ((entry (lookup-entry line word-end)))
+    (when entry
+      (add-flags (+ entry 2) line word-end)
+      (return-from spell-add-entry nil)))
+  (let* ((hash-loc (hash-entry line word-end))
+	 (string-ptr *string-table-size*)
+	 (desc-ptr *descriptors-size*)
+	 (desc-ptr+1 (1+ desc-ptr))
+	 (desc-ptr+2 (1+ desc-ptr+1)))
+    (declare (fixnum string-ptr))
+    (when (not hash-loc) (error "Dictionary Overflow!"))
+    (when (> 3 *free-descriptor-elements*) (grow-descriptors))
+    (when (> word-end *free-string-table-bytes*) (grow-string-table))
+    (decf *free-descriptor-elements* 3)
+    (incf *descriptors-size* 3)
+    (decf *free-string-table-bytes* word-end)
+    (incf *string-table-size* word-end)
+    (setf (dictionary-ref hash-loc) desc-ptr)
+    (setf (descriptor-ref desc-ptr)
+	  (dpb (the fixnum (ldb new-hash-byte (string-hash line word-end)))
+	       stored-hash-byte
+	       word-end))
+    (setf (descriptor-ref desc-ptr+1)
+	  (ldb whole-index-low-byte string-ptr))
+    (setf (descriptor-ref desc-ptr+2)
+	  (dpb (the fixnum (ldb whole-index-high-byte string-ptr))
+	       stored-index-high-byte
+	       0))
+    (add-flags desc-ptr+2 line word-end)
+    (string-table-replace line string-ptr word-end))
+  t)
+
+(defun add-flags (loc line word-end)
+  (declare (simple-string line) (fixnum word-end))
+  (do ((flag (1+ word-end) (+ 2 flag))
+       (line-end (length line)))
+      ((>= flag line-end))
+    (declare (fixnum flag line-end))
+    (let ((flag-mask (flag-mask (schar line flag))))
+      (declare (fixnum flag-mask))
+      (unless (zerop flag-mask)
+	(setf (descriptor-ref loc)
+	      (logior flag-mask (descriptor-ref loc)))))))
+
+;;; SPELL-REMOVE-ENTRY destructively uppercases entry in removing it from
+;;; the dictionary.  First entry is looked up, and if it is found due to a
+;;; flag, the flag is cleared in the descriptor table.  If entry is a root
+;;; word in the dictionary (that is, looked up without the use of a flag),
+;;; then the root and all its derivitives are deleted by setting its
+;;; dictionary location to -1.
+;;; 
+(defun spell-remove-entry (entry)
+  "Removes entry from the dictionary, so it will be an unknown word.  Entry
+   is a simple string and is destructively modified.  If entry is a root
+   word, then all words derived with entry and its flags will also be deleted."
+  (declare (simple-string entry))
+  (nstring-upcase entry)
+  (let ((entry-len (length entry)))
+    (declare (fixnum entry-len))
+    (when (<= 2 entry-len max-entry-length)
+      (multiple-value-bind (index flagp)
+			   (spell-try-word entry entry-len)
+	(when index
+	  (if flagp
+	      (setf (descriptor-ref (+ 2 index))
+		    (logandc2 (descriptor-ref (+ 2 index)) flagp))
+	      (let* ((hash (string-hash entry entry-len))
+		     (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash))
+					stored-hash-byte
+					(the fixnum entry-len)))
+		     (loc (rem hash (the fixnum *dictionary-size*)))
+		     (loc-contents (dictionary-ref loc)))
+		(declare (fixnum hash hash-and-len loc))
+		(cond ((zerop loc-contents) nil)
+		      ((found-entry-p loc-contents entry entry-len hash-and-len)
+		       (setf (dictionary-ref loc) -1))
+		      (t
+		       (hash2-loop (loop-loc loc-contents) loc hash
+				   nil
+				   (when (found-entry-p loc-contents entry
+							entry-len hash-and-len)
+				     (setf (dictionary-ref loop-loc) -1)
+				     (return -1))))))))))))
+
+(defun spell-root-flags (index)
+  "Return the flags associated with the root word corresponding to a
+   dictionary entry at index."
+  (let ((desc-word (descriptor-ref (+ 2 index)))
+	(result ()))
+    (declare (fixnum desc-word))
+    (dolist (ele flag-names-to-masks result)
+      (unless (zerop (logand (the fixnum (cdr ele)) desc-word))
+	(push (car ele) result)))))
+
+
+
+;;;; Growing Dictionary Structures
+
+;;; GROW-DESCRIPTORS grows the descriptors vector by 10%.
+;;;
+(defun grow-descriptors ()
+  (let* ((old-size (+ (the fixnum *descriptors-size*)
+		      (the fixnum *free-descriptor-elements*)))
+	 (new-size (truncate (* old-size 1.1)))
+	 (new-bytes (* new-size 2))
+	 (new-sap (allocate-bytes new-bytes)))
+    (declare (fixnum new-size old-size))
+    (sap-replace new-sap *descriptors* 0 0
+		 (* 2 (the fixnum *descriptors-size*)))
+    (deallocate-bytes (system-address *descriptors*) (* 2 old-size))
+    (setf *free-descriptor-elements*
+	  (- new-size (the fixnum *descriptors-size*)))
+    (setf *descriptors* new-sap)))
+
+;;; GROW-STRING-TABLE grows the string table by 10%.
+;;;
+(defun grow-string-table ()
+  (let* ((old-size (+ (the fixnum *string-table-size*)
+		      (the fixnum *free-string-table-bytes*)))
+	 (new-size (truncate (* old-size 1.1)))
+	 (new-sap (allocate-bytes new-size)))
+    (declare (fixnum new-size old-size))
+    (sap-replace new-sap *string-table* 0 0 *string-table-size*)
+    (setf *free-string-table-bytes*
+	  (- new-size (the fixnum *string-table-size*)))
+    (deallocate-bytes (system-address *string-table*) old-size)
+    (setf *string-table* new-sap)))
diff --git a/hemlock/spell-build.lisp b/hemlock/spell-build.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b8fb29a446fdcffecd25e82b2c8b959600328d3e
--- /dev/null
+++ b/hemlock/spell-build.lisp
@@ -0,0 +1,242 @@
+;;; -*- Log: hemlock.log; Package: Spell -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;    Designed by Bill Chiles and Rob Maclachlan
+;;;
+
+;;; This file contains code to build a new binary dictionary file from
+;;; text in system space.  This code relies on implementation dependent
+;;; code from spell-rt.lisp.  Also, it is expected that spell-corr.lisp
+;;; and spell-aug.lisp have been loaded.  In order to compile this file,
+;;; you must first compile spell-rt, spell-corr.lisp, and spell-aug.lisp.
+
+;;; The text file must be in the following format:
+;;;      entry1/flag1/flag2/flag3
+;;;      entry2
+;;;      entry3/flag1/flag2/flag3/flag4/flag5.
+;;; The flags are single letter indicators of legal suffixes for the entry;
+;;; the available flags and their correct use may be found at the beginning
+;;; of spell-corr.lisp in the Hemlock sources.  There must be exactly one 
+;;; entry per line, and each line must be flushleft.
+
+;;; The dictionary is built in system space as three distinct 
+;;; blocks of memory: the dictionary which is a hash table whose elements
+;;; are one machine word or of type '(unsigned-byte 16); a descriptors
+;;; vector which is described below; and a string table.  After all the
+;;; entries are read in from the text file, one large block of memory is
+;;; validated, and the three structures are moved into it.  Then the file
+;;; is written.  When the large block of memory is validated, enough
+;;; memory is allocated to write the three vector such that they are page
+;;; aligned.  This is important for the speed it allows in growing the
+;;; "dictionary" when augmenting it from a user's text file (see
+;;; spell-aug.lisp).
+
+
+(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
+
+
+
+;;;; Constants
+
+;;; This is an upper bound estimate of the number of stored entries in the
+;;; dictionary.  It should not be more than 21,845 because the dictionary
+;;; is a vector of type '(unsigned-byte 16), and the descriptors' vector
+;;; for the entries uses three '(unsigned-byte 16) elements per descriptor
+;;; unit.  See the beginning of Spell-Correct.Lisp.
+;;;
+(defconstant max-entry-count-estimate 15600)
+
+(defconstant new-dictionary-size 20011)
+
+(defconstant new-descriptors-size (1+ (* 3 max-entry-count-estimate)))
+
+(defconstant max-string-table-length (* 10 max-entry-count-estimate))
+
+
+
+;;;; Hashing
+
+;;; These hashing macros are different from the ones in Spell-Correct.Lisp
+;;; simply because we are using separate space and global specials/constants.
+;;; Of course, they should be identical, but it doesn't seem worth cluttering
+;;; up Spell-Correct with macro generating macros for this file.
+
+(eval-when (compile eval)
+
+(defmacro new-hash2-increment (hash)
+  `(- new-dictionary-size
+      2
+      (the fixnum (rem ,hash (- new-dictionary-size 2)))))
+
+(defmacro new-hash2-loop (loc hash dictionary)
+  (let ((incr (gensym))
+	(loop-loc (gensym)))
+    `(let* ((,incr (new-hash2-increment ,hash))
+	    (,loop-loc ,loc))
+       (declare (fixnum ,incr ,loop-loc))
+       (loop (setf ,loop-loc
+		   (rem (+ ,loop-loc ,incr) new-dictionary-size))
+	     (when (zerop (the fixnum (aref ,dictionary ,loop-loc)))
+	       (return ,loop-loc))
+	     (when (= ,loop-loc ,loc) (return nil))))))
+
+(defmacro new-hash-entry (entry entry-len dictionary)
+  (let ((hash (gensym))
+	(loc (gensym)))
+    `(let* ((,hash (string-hash ,entry ,entry-len))
+	    (,loc (rem ,hash new-dictionary-size)))
+       (declare (fixnum ,loc))
+       (cond ((not (zerop (the fixnum (aref ,dictionary ,loc))))
+	      (incf *collision-count*)
+	      (new-hash2-loop ,loc ,hash ,dictionary))
+	     (t ,loc)))))
+
+) ;eval-when
+
+
+
+;;;; Build-Dictionary
+
+;;; An interesting value when building an initial dictionary.
+(defvar *collision-count* 0)
+
+(defvar *new-dictionary*)
+(defvar *new-descriptors*)
+(defvar *new-string-table*)
+
+(defun build-dictionary (input output &optional save-structures-p)
+  (let ((dictionary (make-array new-dictionary-size
+				:element-type '(unsigned-byte 16)))
+	(descriptors (make-array new-descriptors-size
+				:element-type '(unsigned-byte 16)))
+	(string-table (make-string max-string-table-length)))
+    (write-line "Reading dictionary ...")
+    (force-output)
+    (setf *collision-count* 0)
+    (multiple-value-bind (entry-count string-table-length)
+			 (read-initial-dictionary input dictionary
+						  descriptors string-table)
+      (write-line "Writing dictionary ...")
+      (force-output)
+      (write-dictionary output dictionary descriptors entry-count
+			string-table string-table-length)
+      (when save-structures-p
+	(setf *new-dictionary* dictionary)
+	(setf *new-descriptors* descriptors)
+	(setf *new-string-table* string-table))
+      (format t "~D entries processed with ~D collisions."
+	      entry-count *collision-count*))))
+
+(defun read-initial-dictionary (f dictionary descriptors string-table)
+  (let* ((filename (pathname f))
+	 (s (open filename :direction :input :if-does-not-exist nil)))
+    (unless s (error "File ~S does not exist." f))
+    (multiple-value-prog1
+     (let ((descriptor-ptr 1)
+	   (string-ptr 0)
+	   (entry-count 0))
+       (declare (fixnum descriptor-ptr string-ptr entry-count))
+       (loop (multiple-value-bind (line eofp) (read-line s nil nil)
+	       (declare (simple-string line))
+	       (unless line (return (values entry-count string-ptr)))
+	       (incf entry-count)
+	       (when (> entry-count max-entry-count-estimate)
+		 (error "There are too many entries in text file!~%~
+			Please change constants in spell-build.lisp, ~
+			recompile the file, and reload it.~%~
+			Be sure to understand the constraints of permissible ~
+			values."))
+	       (let ((flags (or (position #\/ line :test #'char=) (length line))))
+		 (declare (fixnum flags))
+		 (cond ((> flags max-entry-length)
+			(format t "Entry ~s too long." (subseq line 0 flags))
+			(force-output))
+		       (t (let ((new-string-ptr (+ string-ptr flags)))
+			    (declare (fixnum new-string-ptr))
+			    (when (> new-string-ptr max-string-table-length)
+			      (error "Spell string table overflow!~%~
+				     Please change constants in ~
+				     spell-build.lisp, recompile the file, ~
+				     and reload it.~%~
+				     Be sure to understand the constraints ~
+				     of permissible values."))
+			    (spell-place-entry line flags
+					       dictionary descriptors string-table
+					       descriptor-ptr string-ptr)
+			    (incf descriptor-ptr 3)
+			    (setf string-ptr new-string-ptr)))))
+	       (when eofp (return (values entry-count string-ptr))))))
+     (close s))))
+
+(defun spell-place-entry (line word-end dictionary descriptors string-table
+			       descriptor-ptr string-ptr)
+  (declare (simple-string line string-table)
+	   (fixnum word-end descriptor-ptr string-ptr)
+	   (type (array (unsigned-byte 16) 1) dictionary descriptors))
+  (nstring-upcase line :end word-end)
+  (let* ((hash-loc (new-hash-entry line word-end dictionary))
+	 (descriptor-ptr+1 (1+ descriptor-ptr))
+	 (descriptor-ptr+2 (1+ descriptor-ptr+1)))
+    (unless hash-loc (error "Dictionary Overflow!"))
+    (setf (aref dictionary hash-loc) descriptor-ptr)
+    (setf (aref descriptors descriptor-ptr)
+	  (dpb (the fixnum
+		    (ldb new-hash-byte (string-hash line word-end)))
+	       stored-hash-byte
+	       word-end))
+    (setf (aref descriptors descriptor-ptr+1)
+	  (ldb whole-index-low-byte string-ptr))
+    (setf (aref descriptors descriptor-ptr+2)
+	  (dpb (the fixnum (ldb whole-index-high-byte string-ptr))
+	       stored-index-high-byte
+	       0))
+    (new-add-flags descriptors descriptor-ptr+2 line word-end)
+    (replace string-table line :start1 string-ptr :end2 word-end)))
+
+(defun new-add-flags (descriptors loc line word-end)
+  (declare (simple-string line)
+	   (fixnum word-end)
+	   (type (array (unsigned-byte 16) 1) descriptors))
+  (do ((flag (1+ word-end) (+ 2 flag))
+       (line-end (length line)))
+      ((>= flag line-end))
+    (declare (fixnum flag line-end))
+    (let ((flag-mask (flag-mask (schar line flag))))
+      (declare (fixnum flag-mask))
+      (if (zerop flag-mask)
+	  (format t "Illegal flag ~S on word ~S."
+		  (schar line flag) (subseq line 0 word-end))
+	  (setf (aref descriptors loc)
+		(logior flag-mask (aref descriptors loc)))))))
+
+(defun write-dictionary (f dictionary descriptors entry-count
+			   string-table string-table-length)
+  (declare (type (array (unsigned-byte 16) 1) dictionary descriptors)
+	   (simple-string string-table)
+	   (fixnum string-table-length))
+  (let ((filename (lisp::predict-name (namestring (pathname f)) nil)))
+    (with-open-file (s filename :direction :output
+		       :element-type '(unsigned-byte 16)
+		       :if-exists :overwrite
+		       :if-does-not-exist :create)
+      (let ((descriptors-size (1+ (* 3 entry-count))))
+	(write-byte magic-file-id s)
+	(write-byte new-dictionary-size s)
+	(write-byte descriptors-size s)
+	(write-byte (ldb whole-index-low-byte string-table-length) s)
+	(write-byte (ldb whole-index-high-byte string-table-length) s)
+	(dotimes (i new-dictionary-size)
+	  (write-byte (aref dictionary i) s))
+	(dotimes (i descriptors-size)
+	  (write-byte (aref descriptors i) s))))
+    (with-open-file (s f :direction :output :element-type 'string-char
+		         :if-exists :append)
+      (write-string string-table s :end string-table-length))))
diff --git a/hemlock/spell-corr.lisp b/hemlock/spell-corr.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..63f740588337af4a7f85f5e6a7f160c9381978b4
--- /dev/null
+++ b/hemlock/spell-corr.lisp
@@ -0,0 +1,804 @@
+;;; -*- Log: hemlock.log; Package: Spell -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;    Designed by Bill Chiles and Rob Maclachlan
+;;;
+
+;;;      This is the file that deals with checking and correcting words
+;;; using a dictionary read in from a binary file.  It has been written
+;;; from the basic ideas used in Ispell (on DEC-20's) which originated as
+;;; Spell on the ITS machines at MIT.  There are flags which have proper
+;;; uses defined for them that indicate permissible suffixes to entries.
+;;; This allows for about three times as many known words than are actually
+;;; stored.  When checking the spelling of a word, first it is looked up;
+;;; if this fails, then possible roots are looked up, and if any has the
+;;; appropriate suffix flag, then the word is considered to be correctly
+;;; spelled.  For an unknown word, the following rules define "close" words
+;;; which are possible corrections:
+;;;    1] two adjacent letters are transposed to form a correct spelling;
+;;;    2] one letter is changed to form a correct spelling;
+;;;    3] one letter is added to form a correct spelling; and/or
+;;;    4] one letter is removed to form a correct spelling. 
+;;; There are two restrictions on the length of a word in regards to its
+;;; worthiness of recognition: it must be at least more than two letters
+;;; long, and if it has a suffix, then it must be at least four letters
+;;; long.  More will be said about this when the flags are discussed.
+;;;      This is implemented in as tense a fashion as possible, and it uses
+;;; implementation dependent code from Spell-RT.Lisp to accomplish this.
+;;; In general the file I/O and structure accesses encompass the system
+;;; dependencies.
+
+;;;      This next section will discuss the storage of the dictionary
+;;; information.  There are three data structures that "are" the
+;;; dictionary: a hash table, descriptors table, and a string table.  The
+;;; hash table is a vector of type '(unsigned-byte 16), whose elements
+;;; point into the descriptors table.  This is a cyclic hash table to
+;;; facilitate dumping it to a file.  The descriptors table (also of type
+;;; '(unsigned-byte 16)) dedicates three elements to each entry in the
+;;; dictionary.  Each group of three elements has the following organization
+;;; imposed on them:
+;;;    ----------------------------------------------
+;;;    |  15..5  hash code  |      4..0 length      |
+;;;    ----------------------------------------------
+;;;    |           15..0 character index            |
+;;;    ----------------------------------------------
+;;;    |  15..14 character index  |  13..0 flags    |
+;;;    ----------------------------------------------
+;;; "Length" is the number of characters in the entry; "hash code" is some
+;;; eleven bits from the hash code to allow for quicker lookup, "flags"
+;;; indicate possible suffixes for the basic entry, and "character index"
+;;; is the index of the start of the entry in the string table.
+;;;      This was originally adopted due to the Perq's word size (can you guess?
+;;; 16 bits, that's right).  Note the constraint that is placed on the number
+;;; of the entries, 21845, because the hash table could not point to more
+;;; descriptor units (16 bits of pointer divided by three).  Since a value of
+;;; zero as a hash table element indicates an empty location, the zeroth element
+;;; of the descriptors table must be unused (it cannot be pointed to).
+
+
+;;;      The following is a short discussion with examples of the correct
+;;; use of the suffix flags.  Let # and @ be symbols that can stand for any
+;;; single letter.  Upper case letters are constants.  "..." stands for any
+;;; string of zero or more letters,  but note that no word may exist in the
+;;; dictionary which is not at least 2 letters long, so, for example, FLY
+;;; may not be produced by placing the "Y" flag on "F".  Also, no flag is
+;;; effective unless the word that it creates is at least 4 letters long,
+;;; so, for example, WED may not be produced by placing the "D" flag on
+;;; "WE".  These flags and examples are from the Ispell documentation with
+;;; only slight modifications.  Here are the correct uses of the flags:
+;;; 
+;;; "V" flag:
+;;;         ...E => ...IVE  as in  create => creative
+;;;         if # .ne. E, then  ...# => ...#IVE  as in  prevent => preventive
+;;; 
+;;; "N" flag:
+;;;         ...E => ...ION  as in create => creation
+;;;         ...Y => ...ICATION  as in  multiply => multiplication
+;;;         if # .ne. E or Y, then  ...# => ...#EN  as in  fall => fallen
+;;; 
+;;; "X" flag:
+;;;         ...E => ...IONS  as in  create => creations
+;;;         ...Y => ...ICATIONS  as in  multiply => multiplications
+;;;         if # .ne. E or Y, ...# => ...#ENS  as in  weak => weakens
+;;; 
+;;; "H" flag:
+;;;         ...Y => ...IETH  as in  twenty => twentieth
+;;;         if # .ne. Y, then  ...# => ...#TH  as in  hundred => hundredth
+;;; 
+;;; "Y" FLAG:
+;;;         ... => ...LY  as in  quick => quickly
+;;; 
+;;; "G" FLAG:
+;;;         ...E => ...ING  as in  file => filing
+;;;         if # .ne. E, then  ...# => ...#ING  as in  cross => crossing
+;;; 
+;;; "J" FLAG"
+;;;         ...E => ...INGS  as in  file => filings
+;;;         if # .ne. E, then  ...# => ...#INGS  as in  cross => crossings
+;;; 
+;;; "D" FLAG:
+;;;         ...E => ...ED  as in  create => created
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@IED  as in  imply => implied
+;;;         if # = Y, and @ = A, E, I, O, or U,
+;;;            then  ...@# => ...@#ED  as in  convey => conveyed
+;;;         if # .ne. E or Y, then  ...# => ...#ED  as in  cross => crossed
+;;; 
+;;; "T" FLAG:
+;;;         ...E => ...EST  as in  late => latest
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@IEST  as in  dirty => dirtiest
+;;;         if # = Y, and @ = A, E, I, O, or U,
+;;;            then  ...@# => ...@#EST  as in  gray => grayest
+;;;         if # .ne. E or Y, then  ...# => ...#EST  as in  small => smallest
+;;; 
+;;; "R" FLAG:
+;;;         ...E => ...ER  as in  skate => skater
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@IER  as in  multiply => multiplier
+;;;         if # = Y, and @ = A, E, I, O, or U,
+;;;            then ...@# => ...@#ER  as in  convey => conveyer
+;;;         if # .ne. E or Y, then  ...# => ...#ER  as in  build => builder
+;;; 
+
+;;; "Z FLAG:
+;;;         ...E => ...ERS  as in  skate => skaters
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@IERS  as in  multiply => multipliers
+;;;         if # = Y, and @ = A, E, I, O, or U,
+;;;            then  ...@# => ...@#ERS  as in  slay => slayers
+;;;         if # .ne. E or Y, then  ...@# => ...@#ERS  as in  build => builders
+;;; 
+;;; "S" FLAG:
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@IES  as in  imply => implies
+;;;         if # .eq. S, X, Z, or H,
+;;;            then  ...# => ...#ES  as in  fix => fixes
+;;;         if # .ne. S, X, Z, H, or Y,
+;;;            then  ...# => ...#S  as in  bat => bats
+;;;         if # = Y, and @ = A, E, I, O, or U,
+;;;            then  ...@# => ...@#S  as in  convey => conveys
+;;; 
+;;; "P" FLAG:
+;;;         if # .ne. Y, or @ = A, E, I, O, or U,
+;;;            then  ...@# => ...@#NESS  as in  late => lateness and
+;;;                                             gray => grayness
+;;;         if @ .ne. A, E, I, O, or U,
+;;;            then  ...@Y => ...@INESS  as in  cloudy => cloudiness
+;;; 
+;;; "M" FLAG:
+;;;         ... => ...'S  as in DOG => DOG'S
+
+
+
+(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
+
+(export '(spell-try-word spell-root-word spell-collect-close-words
+	  maybe-read-spell-dictionary correct-spelling max-entry-length))
+
+
+
+;;;; Some Constants
+
+;;; The next number (using 6 bits) is 63, and that's pretty silly because
+;;; "supercalafragalistic" is less than 31 characters long.
+;;;
+(defconstant max-entry-length 31
+  "This the maximum number of characters an entry may have.")
+
+;;; These are the flags (described above), and an entry is allowed a
+;;; certain suffix if the appropriate bit is on in the third element of
+;;; its descriptor unit (described above).
+;;;
+(defconstant V-mask (ash 1 13))
+(defconstant N-mask (ash 1 12))
+(defconstant X-mask (ash 1 11))
+(defconstant H-mask (ash 1 10))
+(defconstant Y-mask (ash 1 9))
+(defconstant G-mask (ash 1 8))
+(defconstant J-mask (ash 1 7))
+(defconstant D-mask (ash 1 6))
+(defconstant T-mask (ash 1 5))
+(defconstant R-mask (ash 1 4))
+(defconstant Z-mask (ash 1 3))
+(defconstant S-mask (ash 1 2))
+(defconstant P-mask (ash 1 1))
+(defconstant M-mask 1)
+
+
+;;; These are the eleven bits of a computed hash that are stored as part of
+;;; an entries descriptor unit.  The shifting constant is how much the
+;;; eleven bits need to be shifted to the right, so they take up the upper
+;;; eleven bits of one 16-bit element in a descriptor unit.
+;;;
+(defconstant new-hash-byte (byte 11 13))
+(defconstant stored-hash-byte (byte 11 5))
+
+
+;;; The next two constants are used to extract information from an entry's
+;;; descriptor unit.  The first is the two most significant bits of 18
+;;; bits that hold an index into the string table where the entry is
+;;; located.  If this is confusing, regard the diagram of the descriptor
+;;; units above.
+;;;
+(defconstant whole-index-high-byte (byte 2 16))
+(defconstant stored-index-high-byte (byte 2 14))
+(defconstant stored-length-byte (byte 5 0))
+
+
+
+;;;; Some Specials and Accesses
+
+;;; *spell-aeiou* will have bits on that represent the capital letters
+;;; A, E, I, O, and U to be used to determine if some word roots are legal
+;;; for looking up.
+;;;
+(defvar *aeiou*
+  (make-array 128 :element-type 'bit :initial-element 0))
+
+(setf (aref *aeiou* (char-code #\A)) 1)
+(setf (aref *aeiou* (char-code #\E)) 1)
+(setf (aref *aeiou* (char-code #\I)) 1)
+(setf (aref *aeiou* (char-code #\O)) 1)
+(setf (aref *aeiou* (char-code #\U)) 1)
+
+
+;;; *sxzh* will have bits on that represent the capital letters
+;;; S, X, Z, and H to be used to determine if some word roots are legal for
+;;; looking up.
+;;;
+(defvar *sxzh*
+  (make-array 128 :element-type 'bit :initial-element 0))
+
+(setf (aref *sxzh* (char-code #\S)) 1)
+(setf (aref *sxzh* (char-code #\X)) 1)
+(setf (aref *sxzh* (char-code #\Z)) 1)
+(setf (aref *sxzh* (char-code #\H)) 1)
+
+
+;;; SET-MEMBER-P will be used with *aeiou* and *sxzh* to determine if a
+;;; character is in the specified set.
+;;;
+(eval-when (compile eval)
+(defmacro set-member-p (char set)
+  `(not (zerop (the fixnum (aref (the simple-bit-vector ,set)
+				 (char-code ,char))))))
+) ;eval-when
+
+
+(defvar *dictionary*)
+(defvar *dictionary-size*)
+(defvar *descriptors*)
+(defvar *descriptors-size*)
+(defvar *string-table*)
+(defvar *string-table-size*)
+
+
+(eval-when (compile eval)
+
+;;; DICTIONARY-REF and DESCRIPTOR-REF are references to implementation
+;;; dependent structures.  *dictionary* and *descriptors* are "system
+;;; area pointers" as a result of the way the binary file is opened for
+;;; fast access.
+;;;
+(defmacro dictionary-ref (idx)
+  `(sapref *dictionary* ,idx))
+
+(defmacro descriptor-ref (idx)
+  `(sapref *descriptors* ,idx))
+
+
+;;; DESCRIPTOR-STRING-START access an entry's (indicated by idx)
+;;; descriptor unit (described at the beginning of the file) and returns
+;;; the start index of the entry in the string table.  The second of three
+;;; words in the descriptor holds the 16 least significant bits of 18, and
+;;; the top two bits of the third word are the 2 most significant bits.
+;;; These 18 bits are the index into the string table.
+;;;
+(defmacro descriptor-string-start (idx)
+  `(dpb (the fixnum (ldb stored-index-high-byte
+			 (the fixnum (descriptor-ref (+ 2 ,idx)))))
+	whole-index-high-byte
+	(the fixnum (descriptor-ref (1+ ,idx)))))
+
+) ;eval-when
+
+
+
+;;;; Top level Checking/Correcting
+
+;;; CORRECT-SPELLING can be called from top level to check/correct a words
+;;; spelling.  It is not used for any other purpose.
+;;; 
+(defun correct-spelling (word)
+  "Check/correct the spelling of word.  Output is done to *standard-output*."
+  (setf word (coerce word 'simple-string))
+  (let ((word (string-upcase (the simple-string word)))
+	(word-len (length (the simple-string word))))
+    (declare (simple-string word) (fixnum word-len))
+    (maybe-read-spell-dictionary)
+    (when (= word-len 1)
+      (error "Single character words are not in the dictionary."))
+    (when (> word-len max-entry-length)
+      (error "~A is too long for the dictionary." word))
+    (multiple-value-bind (idx used-flag-p)
+			 (spell-try-word word word-len)
+      (if idx
+	  (format t "Found it~:[~; because of ~A~]." used-flag-p
+		  (spell-root-word idx))
+	  (let ((close-words (spell-collect-close-words word)))
+	    (if close-words
+		(format *standard-output*
+			"The possible correct spelling~[~; is~:;s are~]:~
+			~:*~[~; ~{~A~}~;~{ ~A~^ and~}~:;~
+			~{~#[~; and~] ~A~^,~}~]."
+			(length close-words)
+			close-words)
+		(format *standard-output* "Word not found.")))))))
+
+
+(defvar *dictionary-read-p* nil)
+
+;;; MAYBE-READ-SPELL-DICTIONARY  --  Public
+;;;
+(defun maybe-read-spell-dictionary ()
+  "Read the spelling dictionary if it has not be read already."
+  (unless *dictionary-read-p* (read-dictionary)))
+
+
+(defun spell-root-word (index)
+  "Return the root word corresponding to a dictionary entry at index."
+  (let* ((start (descriptor-string-start index))
+	 (end (+ start (the fixnum (ldb stored-length-byte
+					(the fixnum (descriptor-ref index)))))))
+    (declare (fixnum start end))
+    (subseq (the simple-string *string-table*) start end)))
+
+
+(eval-when (compile eval)
+(defmacro check-closeness (word word-len closeness-list)
+  `(if (spell-try-word ,word ,word-len)
+       (pushnew (subseq ,word 0 ,word-len) ,closeness-list :test #'string=)))
+) ;eval-when
+
+(defconstant spell-alphabet
+  (list #\A #\B #\C #\D #\E #\F #\G #\H
+	#\I #\J #\K #\L #\M #\N #\O #\P
+	#\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
+
+;;; SPELL-COLLECT-CLOSE-WORDS Returns a list of all "close" correctly spelled
+;;; words.  The definition of "close" is at the beginning of the file, and
+;;; there are four sections to this function which collect each of the four
+;;; different kinds of close words.
+;;; 
+(defun spell-collect-close-words (word)
+  "Returns a list of all \"close\" correctly spelled words.  This has the
+   same contraints as SPELL-TRY-WORD, which you have probably already called
+   if you are calling this."
+  (declare (simple-string word))
+  (let* ((word-len (length word))
+	 (word-len--1 (1- word-len))
+	 (word-len-+1 (1+ word-len))
+	 (result ())
+	 (correcting-buffer (make-string max-entry-length)))
+    (declare (simple-string correcting-buffer)
+	     (fixnum word-len word-len--1 word-len-+1))
+    (replace correcting-buffer word :end1 word-len :end2 word-len)
+
+    ;; Misspelled because one letter is different.
+    (dotimes (i word-len)
+      (do ((save-char (schar correcting-buffer i))
+	   (alphabet spell-alphabet (cdr alphabet)))
+	  ((null alphabet)
+	   (setf (schar correcting-buffer i) save-char))
+	(setf (schar correcting-buffer i) (car alphabet))
+	(check-closeness correcting-buffer word-len result)))
+
+    ;; Misspelled because two adjacent letters are transposed.
+    (dotimes (i word-len--1)
+      (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i)))
+      (check-closeness correcting-buffer word-len result)
+      (rotatef (schar correcting-buffer i) (schar correcting-buffer (1+ i))))
+
+    ;; Misspelled because of extraneous letter.
+    (replace correcting-buffer word
+	     :start2 1 :end1 word-len--1 :end2 word-len)
+    (check-closeness correcting-buffer word-len--1 result)
+    (dotimes (i word-len--1)
+      (setf (schar correcting-buffer i) (schar word i))
+      (replace correcting-buffer word
+	       :start1 (1+ i) :start2 (+ i 2) :end1 word-len--1 :end2 word-len)
+      (check-closeness correcting-buffer word-len--1 result))
+
+    ;; Misspelled because a letter is missing.
+    (replace correcting-buffer word
+	     :start1 1 :end1 word-len-+1 :end2 word-len)
+    (dotimes (i word-len-+1)
+      (do ((alphabet spell-alphabet (cdr alphabet)))
+	  ((null alphabet)
+	   (rotatef (schar correcting-buffer i)
+		    (schar correcting-buffer (1+ i))))
+	(setf (schar correcting-buffer i) (car alphabet))
+	(check-closeness correcting-buffer word-len-+1 result)))
+    result))
+
+;;; SPELL-TRY-WORD The literal 4 is not a constant defined somewhere since it
+;;; is part of the definition of the function of looking up words.
+;;; TRY-WORD-ENDINGS relies on the guarantee that word-len is at least 4.
+;;; 
+(defun spell-try-word (word word-len)
+  "See if the word or an appropriate root is in the spelling dicitionary.
+   Word-len must be inclusively in the range 2..max-entry-length."
+  (or (lookup-entry word word-len)
+      (if (>= (the fixnum word-len) 4)
+	  (try-word-endings word word-len))))
+
+
+
+;;;; Divining Correct Spelling
+
+(eval-when (compile eval)
+
+(defmacro setup-root-buffer (word buffer root-len)
+  `(replace ,buffer ,word :end1 ,root-len :end2 ,root-len))
+
+(defmacro try-root (word root-len flag-mask)
+  (let ((result (gensym)))
+    `(let ((,result (lookup-entry ,word ,root-len)))
+       (if (and ,result (descriptor-flag ,result ,flag-mask))
+	   (return (values ,result ,flag-mask))))))
+
+;;; TRY-MODIFIED-ROOT is used for root words that become truncated
+;;; when suffixes are added (e.g., skate => skating).  Char-idx is the last
+;;; character in the root that has to typically be changed from a #\I to a
+;;; #\Y or #\E.
+;;;
+(defmacro try-modified-root (word buffer root-len flag-mask char-idx new-char)
+  (let ((root-word (gensym)))
+    `(let ((,root-word (setup-root-buffer ,word ,buffer ,root-len)))
+       (setf (schar ,root-word ,char-idx) ,new-char)
+       (try-root ,root-word ,root-len ,flag-mask))))
+
+) ;eval-when
+
+
+(defvar *rooting-buffer* (make-string max-entry-length))
+
+;;; TRY-WORD-ENDINGS takes a word that is at least of length 4 and
+;;; returns multiple values on success (the index where the word's root's
+;;; descriptor starts and :used-flag), otherwise nil.  It looks at
+;;; characters from the end to the beginning of the word to determine if it
+;;; has any known suffixes.  This is a VERY simple finite state machine
+;;; where all of the suffixes are narrowed down to one possible one in at
+;;; most two state changes.  This is a PROG form for speed, and in some sense,
+;;; readability.  The states of the machine are the flag names that denote
+;;; suffixes.  The two points of branching to labels are the very beginning
+;;; of the PROG and the S state.  This is a fairly straight forward
+;;; implementation of the flag rules presented at the beginning of this
+;;; file, with char-idx checks, so we do not index the string below zero.
+
+(defun try-word-endings (word word-len)
+  (declare (simple-string word)
+	   (fixnum word-len))
+  (prog* ((char-idx (1- word-len))
+	  (char (schar word char-idx))
+	  (rooting-buffer *rooting-buffer*)
+	  flag-mask)
+         (declare (simple-string rooting-buffer)
+		  (fixnum char-idx))
+         (case char
+	   (#\S (go S))        ;This covers over half of the possible endings
+	                       ;by branching off the second to last character
+	                       ;to other flag states that have plural endings.
+	   (#\R (setf flag-mask R-mask)		   ;"er" and "ier"
+		(go D-R-Z-FLAG))
+	   (#\T (go T-FLAG))			   ;"est" and "iest"
+	   (#\D (setf flag-mask D-mask)		   ;"ed" and "ied"
+	        (go D-R-Z-FLAG))
+	   (#\H (go H-FLAG))			   ;"th" and "ieth"
+	   (#\N (setf flag-mask N-mask)		   ;"ion", "ication", and "en"
+		(go N-X-FLAG))
+	   (#\G (setf flag-mask G-mask)		   ;"ing"
+		(go G-J-FLAG))
+	   (#\Y (go Y-FLAG))			   ;"ly"
+	   (#\E (go V-FLAG)))			   ;"ive"
+         (return nil)
+
+    S
+         (setf char-idx (1- char-idx))
+         (setf char (schar word char-idx))
+         (if (char= char #\Y)
+	     (if (set-member-p (schar word (1- char-idx)) *aeiou*)
+		 (try-root word (1+ char-idx) S-mask)
+		 (return nil))
+	     (if (not (set-member-p char *sxzh*))
+		 (try-root word (1+ char-idx) S-mask)))
+         (case char
+	   (#\E (go S-FLAG))                    ;"es" and "ies"
+	   (#\R (setf flag-mask Z-mask)		;"ers" and "iers"
+		(go D-R-Z-FLAG))
+	   (#\G (setf flag-mask J-mask)		;"ings"
+		(go G-J-FLAG))
+	   (#\S (go P-FLAG))			;"ness" and "iness"
+	   (#\N (setf flag-mask X-mask)		;"ions", "ications", and "ens"
+		(go N-X-FLAG))
+	   (#\' (try-root word char-idx M-mask)))
+         (return nil)
+
+    S-FLAG
+         (setf char-idx (1- char-idx))
+         (setf char (schar word char-idx))
+	 (if (set-member-p char *sxzh*)
+	     (try-root word (1+ char-idx) S-mask))
+         (if (and (char= char #\I)
+		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
+	     (try-modified-root word rooting-buffer (1+ char-idx)
+				S-mask char-idx #\Y))
+         (return nil)
+
+    D-R-Z-FLAG
+         (if (char/= (schar word (1- char-idx)) #\E) (return nil))
+         (try-root word char-idx flag-mask)
+         (if (<= (setf char-idx (- char-idx 2)) 0) (return nil))
+         (setf char (schar word char-idx))
+         (if (char= char #\Y)
+	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
+		 (try-root word (1+ char-idx) flag-mask)
+		 (return nil))
+	     (if (char/= (schar word char-idx) #\E)
+		 (try-root word (1+ char-idx) flag-mask)))
+         (if (and (char= char #\I)
+		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
+	     (try-modified-root word rooting-buffer (1+ char-idx)
+				flag-mask char-idx #\Y))
+         (return nil)
+
+    P-FLAG
+         (if (or (char/= (schar word (1- char-idx)) #\E)
+		 (char/= (schar word (- char-idx 2)) #\N))
+	     (return nil))
+         (if (<= (setf char-idx (- char-idx 3)) 0) (return nil))
+         (setf char (schar word char-idx))
+         (if (char= char #\Y)
+	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
+		 (try-root word (1+ char-idx) P-mask)
+		 (return nil)))
+         (try-root word (1+ char-idx) P-mask)
+         (if (and (char= char #\I)
+		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
+	     (try-modified-root word rooting-buffer (1+ char-idx)
+				P-mask char-idx #\Y))
+         (return nil)
+
+    G-J-FLAG
+         (if (< char-idx 3) (return nil))
+         (setf char-idx (- char-idx 2))
+         (setf char (schar word char-idx))
+         (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\N))
+	     (return nil))
+         (if (char/= (schar word (1- char-idx)) #\E)
+	     (try-root word char-idx flag-mask))
+         (try-modified-root word rooting-buffer (1+ char-idx)
+			    flag-mask char-idx #\E)
+         (return nil)
+
+    N-X-FLAG
+         (setf char-idx (1- char-idx))
+         (setf char (schar word char-idx))
+         (cond ((char= char #\E)
+		(setf char (schar word (1- char-idx)))
+		(if (and (char/= char #\Y) (char/= char #\E))
+		    (try-root word char-idx flag-mask))
+		(return nil))
+	       ((char= char #\O)
+		(if (char= (schar word (1- char-idx)) #\I)
+		    (try-modified-root word rooting-buffer char-idx
+				       flag-mask (1- char-idx) #\E)
+		    (return nil))
+		(if (< char-idx 5) (return nil))
+		(if (or (char/= (schar word (- char-idx 2)) #\T)
+			(char/= (schar word (- char-idx 3)) #\A)
+			(char/= (schar word (- char-idx 4)) #\C)
+			(char/= (schar word (- char-idx 5)) #\I))
+		    (return nil)
+		    (setf char-idx (- char-idx 4)))
+		(try-modified-root word rooting-buffer char-idx
+				   flag-mask (1- char-idx) #\Y))
+	       (t (return nil)))
+
+    T-FLAG
+         (if (or (char/= (schar word (1- char-idx)) #\S)
+		 (char/= (schar word (- char-idx 2)) #\E))
+	     (return nil)
+	     (setf char-idx (1- char-idx)))
+         (try-root word char-idx T-mask)
+         (if (<= (setf char-idx (- char-idx 2)) 0) (return nil))
+         (setf char (schar word char-idx))
+         (if (char= char #\Y)
+	     (if (set-member-p (schar word (1- char-idx)) *aeiou*) 
+		 (try-root word (1+ char-idx) T-mask)
+		 (return nil))
+	     (if (char/= (schar word char-idx) #\E)
+		 (try-root word (1+ char-idx) T-mask)))
+         (if (and (char= char #\I)
+		  (not (set-member-p (schar word (1- char-idx)) *aeiou*)))
+	     (try-modified-root word rooting-buffer (1+ char-idx)
+				T-mask char-idx #\Y))
+         (return nil)
+
+    H-FLAG
+         (setf char-idx (1- char-idx))
+         (setf char (schar word char-idx))
+         (if (char/= char #\T) (return nil))
+         (if (char/= (schar word (1- char-idx)) #\Y)
+	     (try-root word char-idx H-mask))
+         (if (and (char= (schar word (1- char-idx)) #\E)
+		  (char= (schar word (- char-idx 2)) #\I))
+	     (try-modified-root word rooting-buffer (1- char-idx)
+				H-mask (- char-idx 2) #\Y))
+         (return nil)
+
+    Y-FLAG
+         (setf char-idx (1- char-idx))
+         (setf char (schar word char-idx))
+         (if (char= char #\L)
+	     (try-root word char-idx Y-mask))
+         (return nil)
+
+    V-FLAG
+         (setf char-idx (- char-idx 2))
+         (setf char (schar word char-idx))
+         (if (or (char/= char #\I) (char/= (schar word (1+ char-idx)) #\V))
+	     (return nil))
+         (if (char/= (schar word (1- char-idx)) #\E)
+	     (try-root word char-idx V-mask))
+         (try-modified-root word rooting-buffer (1+ char-idx)
+			    V-mask char-idx #\E)
+         (return nil)))
+
+
+
+;;; DESCRIPTOR-FLAG returns t or nil based on whether the flag is on.
+;;; From the diagram at the beginning of the file, we see that the flags
+;;; are stored two words off of the first word in the descriptor unit for
+;;; an entry.
+;;;
+(defun descriptor-flag (descriptor-start flag-mask)
+  (not (zerop
+	(the fixnum
+	     (logand
+	      (the fixnum (descriptor-ref (+ 2 (the fixnum descriptor-start))))
+	      (the fixnum flag-mask))))))
+
+
+;;;; Looking up Trials
+
+(eval-when (compile eval)
+
+;;; SPELL-STRING= determines if string1 and string2 are the same.  Before
+;;; it is called it is known that they are both of (- end1 0) length, and
+;;; string2 is in system space.  This is used in FOUND-ENTRY-P.
+;;;
+(defmacro spell-string= (string1 string2 end1 start2)
+  (let ((idx1 (gensym))
+	(idx2 (gensym)))
+    `(do ((,idx1 0 (1+ ,idx1))
+	  (,idx2 ,start2 (1+ ,idx2)))
+	 ((= ,idx1 ,end1) t)
+       (declare (fixnum ,idx1 ,idx2))
+       (unless (= (the fixnum (char-code (schar ,string1 ,idx1)))
+		  (the fixnum (string-sapref ,string2 ,idx2)))
+	 (return nil)))))
+
+;;; FOUND-ENTRY-P determines if entry is what is described at idx.
+;;; Hash-and-length is 16 bits that look just like the first word of any
+;;; entry's descriptor unit (see diagram at the beginning of the file).  If
+;;; the word stored at idx and entry have the same hash bits and length,
+;;; then we compare characters to see if they are the same.
+;;;
+(defmacro found-entry-p (idx entry entry-len hash-and-length)
+  `(if (= (the fixnum (descriptor-ref ,idx))
+	  (the fixnum ,hash-and-length))
+      (spell-string= ,entry *string-table* ,entry-len
+		     (descriptor-string-start ,idx))))
+
+(defmacro hash2-increment (hash)
+  `(- (the fixnum *dictionary-size*)
+      2
+      (the fixnum (rem ,hash (- (the fixnum *dictionary-size*) 2)))))
+
+(defmacro hash2-loop ((location-var contents-var)
+		       loc hash zero-contents-form
+		       &optional body-form (for-insertion-p nil))
+  (let ((incr (gensym)))
+    `(let* ((,incr (hash2-increment ,hash))
+	    (,location-var ,loc)
+	    ,contents-var)
+	(declare (fixnum ,location-var ,contents-var ,incr))
+       (loop (setf ,location-var
+		   (rem (+ ,location-var ,incr) (the fixnum *dictionary-size*)))
+	     (setf ,contents-var (dictionary-ref ,location-var))
+	     (if (zerop ,contents-var) (return ,zero-contents-form))
+	     ,@(if for-insertion-p
+		   `((if (= ,contents-var -1) (return ,zero-contents-form))))
+	     (if (= ,location-var ,loc) (return nil))
+	     ,@(if body-form `(,body-form))))))
+
+) ;eval-when
+
+
+;;; LOOKUP-ENTRY returns the index of the first element of entry's
+;;; descriptor unit on success, otherwise nil.  
+;;;
+(defun lookup-entry (entry &optional len)
+  (declare (simple-string entry))
+  (let* ((entry-len (or len (length entry)))
+	 (hash (string-hash entry entry-len))
+	 (hash-and-len (dpb (the fixnum (ldb new-hash-byte hash))
+			    stored-hash-byte
+			    (the fixnum entry-len)))
+	 (loc (rem hash (the fixnum *dictionary-size*)))
+	 (loc-contents (dictionary-ref loc)))
+    (declare (fixnum entry-len hash hash-and-len loc))
+    (cond ((zerop loc-contents) nil)
+	  ((found-entry-p loc-contents entry entry-len hash-and-len)
+	   loc-contents)
+	  (t
+	   (hash2-loop (loop-loc loc-contents) loc hash
+	     nil
+	     (if (found-entry-p loc-contents entry entry-len hash-and-len)
+		 (return loc-contents)))))))
+
+;;;; Binary File Reading
+
+(defparameter default-binary-dictionary
+  "/usr/misc/.lisp/lib/spell-dictionary.bin")
+
+;;; This is the first thing in a spell binary dictionary file to serve as a
+;;; quick check of its proposed contents.  This particular number is
+;;; "BILLS" on a calculator held upside-down.
+;;;
+(defconstant magic-file-id 57718)
+
+;;; These constants are derived from the order things are written to the
+;;; binary dictionary in Spell-Build.Lisp.
+;;;
+(defconstant magic-file-id-loc 0)
+(defconstant dictionary-size-loc 1)
+(defconstant descriptors-size-loc 2)
+(defconstant string-table-size-low-byte-loc 3)
+(defconstant string-table-size-high-byte-loc 4)
+(defconstant file-header-bytes 10)
+
+;;; Initially, there are no free descriptor elements and string table bytes,
+;;; but when these structures are grown, they are grown by more than that
+;;; which is necessary.
+;;;
+(defvar *free-descriptor-elements* 0)
+(defvar *free-string-table-bytes* 0)
+
+;;; READ-DICTIONARY opens the dictionary and sets up the global structures
+;;; manifesting the spelling dictionary.  When computing the start addresses
+;;; of these structures, we multiply by two since their sizes are in 16bit
+;;; lengths while the RT is 8bit-byte addressable.
+;;;
+(defun read-dictionary (&optional (f default-binary-dictionary))
+  (when *dictionary-read-p*
+    (setf *dictionary-read-p* nil)
+    (deallocate-bytes (system-address *dictionary*)
+		      (* 2 (the fixnum *dictionary-size*)))
+    (deallocate-bytes (system-address *descriptors*)
+		      (* 2 (the fixnum
+				(+ (the fixnum *descriptors-size*)
+				   (the fixnum *free-descriptor-elements*)))))
+    (deallocate-bytes (system-address *string-table*)
+		      (+ (the fixnum *string-table-size*)
+			 (the fixnum *free-string-table-bytes*))))
+  (setf *free-descriptor-elements* 0)
+  (setf *free-string-table-bytes* 0)
+  (let* ((fd (open-dictionary f))
+	 (header-info (read-dictionary-structure fd file-header-bytes)))
+    (unless (= (sapref header-info magic-file-id-loc) magic-file-id)
+      (deallocate-bytes (system-address header-info) file-header-bytes)
+      (error "File is not a dictionary: ~S." f))
+    (setf *dictionary-size* (sapref header-info dictionary-size-loc))
+    (setf *descriptors-size* (sapref header-info descriptors-size-loc))
+    (setf *string-table-size* (sapref header-info string-table-size-low-byte-loc))
+    (setf (ldb (byte 12 16) (the fixnum *string-table-size*))
+	  (the fixnum (sapref header-info string-table-size-high-byte-loc)))
+    (deallocate-bytes (system-address header-info) file-header-bytes)
+    (setf *dictionary*
+	  (read-dictionary-structure fd (* 2 (the fixnum *dictionary-size*))))
+    (setf *descriptors*
+	  (read-dictionary-structure fd (* 2 (the fixnum *descriptors-size*))))
+    (setf *string-table* (read-dictionary-structure fd *string-table-size*))
+    (setf *dictionary-read-p* t)
+    (close-dictionary fd)))
diff --git a/hemlock/spell-rt.lisp b/hemlock/spell-rt.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6a066541bf1396c39e3d2990f1b34f698bfb23de
--- /dev/null
+++ b/hemlock/spell-rt.lisp
@@ -0,0 +1,93 @@
+;;; -*- Log: hemlock.log; Package: Spell -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;
+;;; This file contains system dependent primitives for the spelling checking/
+;;; correcting code in Spell-Correct.Lisp, Spell-Augment.Lisp, and
+;;; Spell-Build.Lisp.
+
+(in-package "SPELL" :use '("LISP" "EXTENSIONS" "SYSTEM"))
+
+
+;;;; System Area Referencing and Setting
+
+(eval-when (compile eval)
+
+;;; MAKE-SAP returns pointers that *dictionary*, *descriptors*, and
+;;; *string-table* are bound to.  Address is in the system area.
+;;;
+(defmacro make-sap (address)
+  `(lisp::fixnum-to-sap ,address))
+
+(defmacro system-address (sap)
+  `(lisp::sap-to-fixnum ,sap))
+
+
+(defmacro allocate-bytes (count)
+  `(make-sap (lisp::do-validate 0 ,count -1)))
+
+(defmacro deallocate-bytes (address byte-count)
+  `(mach::vm_deallocate lisp::*task-self* ,address ,byte-count))
+
+
+(defmacro sapref (sap offset)
+  `(%primitive 16bit-system-ref ,sap ,offset))
+
+(defsetf sapref (sap offset) (value)
+  `(%primitive 16bit-system-set ,sap ,offset ,value))
+
+
+(defmacro sap-replace (dst-string src-string src-start dst-start dst-end)
+  `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end))
+
+(defmacro string-sapref (sap index)
+  `(%primitive 8bit-system-ref ,sap ,index))
+
+
+
+;;;; Primitive String Hashing
+
+;;; STRING-HASH employs the instruction SXHASH-SIMPLE-SUBSTRING which takes
+;;; an end argument, so we do not have to use SXHASH.  SXHASH would mean
+;;; doing a SUBSEQ of entry.
+;;;
+(defmacro string-hash (string length)
+  `(%primitive sxhash-simple-substring ,string ,length))
+
+) ;eval-when
+
+
+
+;;;; Binary Dictionary File I/O
+
+(defun open-dictionary (f)
+  (multiple-value-bind (filename existsp)
+		       (lisp::predict-name f :for-input)
+    (unless existsp (error "Cannot find dictionary -- ~S." filename))
+    (multiple-value-bind (fd err)
+			 (mach:unix-open filename mach:o_rdonly 0)
+      (unless fd
+	(error "Opening ~S failed: ~A." filename err))
+      (multiple-value-bind (winp dev-or-err) (mach:unix-fstat fd)
+	(unless winp (error "Opening ~S failed: ~A." filename dev-or-err))
+	fd))))
+
+(defun close-dictionary (fd)
+  (mach:unix-close fd))
+
+(defun read-dictionary-structure (fd bytes)
+  (let* ((structure (allocate-bytes bytes)))
+    (multiple-value-bind (read-bytes err)
+			 (mach:unix-read fd structure bytes)
+      (when (or (null read-bytes) (not (= bytes read-bytes)))
+	(deallocate-bytes (system-address structure) bytes)
+	(error "Reading dictionary structure failed: ~A." err))
+      structure)))
diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..dfdae2b4fba3bdf85ac13ce853e651253bd0e812
--- /dev/null
+++ b/hemlock/streams.lisp
@@ -0,0 +1,316 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains definitions of various types of streams used
+;;; in Hemlock.  They are implementation dependant, but should be
+;;; portable to all implementations based on Spice Lisp with little
+;;; difficulty.
+;;;
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(make-hemlock-output-stream
+	  hemlock-region-stream hemlock-region-stream-p
+	  hemlock-output-stream make-hemlock-region-stream
+	  hemlock-output-stream-p make-kbdmac-stream
+	  modify-kbdmac-stream))
+
+(defstruct (hemlock-output-stream
+	    (:include stream
+		      (:misc #'hemlock-output-misc))
+	    (:print-function %print-hemlock-output-stream)
+	    (:constructor internal-make-hemlock-output-stream ()))
+  ;;
+  ;; The mark we insert at.
+  mark)
+
+(defun %print-hemlock-output-stream (s stream d)
+  (declare (ignore d s))
+  (write-string "#<Hemlock output stream>" stream))
+
+(defun make-hemlock-output-stream (mark &optional (buffered :line))
+  "Returns an output stream whose output will be inserted at the Mark.
+  Buffered, which indicates to what extent the stream may be buffered
+  is one of the following:
+   :None  -- The screen is brought up to date after each stream operation.
+   :Line  -- The screen is brought up to date when a newline is written.
+   :Full  -- The screen is not updated except explicitly via Force-Output."
+  (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark
+                                buffered))
+
+
+(defun modify-hemlock-output-stream (stream mark buffered)
+  (unless (and (markp mark)
+	       (memq (mark-kind mark) '(:right-inserting :left-inserting)))
+    (error "~S is not a permanent mark." mark))
+  (setf (hemlock-output-stream-mark stream) mark)
+  (case buffered
+    (:none
+     (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out
+	   (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout))
+    (:line
+     (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out
+	   (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout))
+    (:full
+     (setf (lisp::stream-out stream) #'hemlock-output-buffered-out
+	   (lisp::stream-sout stream) #'hemlock-output-buffered-sout))
+    (t
+     (error "~S is a losing value for Buffered." buffered)))
+  stream)
+
+(defmacro with-left-inserting-mark ((var form) &body forms)
+  (let ((change (gensym)))
+    `(let* ((,var ,form)
+	    (,change (eq (mark-kind ,var) :right-inserting)))
+       (unwind-protect
+	   (progn
+	     (when ,change
+	       (setf (mark-kind ,var) :left-inserting))
+	     ,@forms)
+	 (when ,change
+	   (setf (mark-kind ,var) :right-inserting))))))
+
+(defun hemlock-output-unbuffered-out (stream character)
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-character mark character)
+    (redisplay-windows-from-mark mark)))
+
+(defun hemlock-output-unbuffered-sout (stream string start end)
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-string mark string start end)
+    (redisplay-windows-from-mark mark)))
+
+(defun hemlock-output-buffered-out (stream character)
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-character mark character)))
+
+(defun hemlock-output-buffered-sout (stream string start end)
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-string mark string start end)))
+
+(defun hemlock-output-line-buffered-out (stream character)
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-character mark character)
+    (when (char= character #\newline)
+      (redisplay-windows-from-mark mark))))
+
+(defun hemlock-output-line-buffered-sout (stream string start end)
+  (declare (simple-string string))
+  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
+    (insert-string mark string start end)
+    (when (find #\newline string :start start :end end)
+      (redisplay-windows-from-mark mark))))
+
+(defun hemlock-output-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos (mark-charpos (hemlock-output-stream-mark stream)))
+    (:line-length
+     (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
+       (when buffer
+	 (do ((w (buffer-windows buffer) (cdr w))
+	      (min most-positive-fixnum (min (window-width (car w)) min)))
+	     ((null w)
+	      (if (/= min most-positive-fixnum) min))))))
+    ((:finish-output :force-output)
+     (redisplay-windows-from-mark (hemlock-output-stream-mark stream)))
+    (:close (setf (hemlock-output-stream-mark stream) nil))
+    (:element-type 'string-char)))
+
+(defstruct (hemlock-region-stream
+	    (:include stream
+		      (:in #'region-in)
+		      (:misc #'region-misc)
+		      (:in-buffer (make-string lisp::in-buffer-length)))
+	    (:print-function %print-region-stream)
+	    (:constructor internal-make-hemlock-region-stream (region mark)))
+  ;;
+  ;; The region we read from.
+  region
+  ;;
+  ;; The mark pointing to the next character to read.
+  mark)
+
+(defun %print-region-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Hemlock region stream>" stream))
+
+(defun make-hemlock-region-stream (region)
+  "Returns an input stream that will return successive characters from the
+  given Region when asked for input."
+  (internal-make-hemlock-region-stream
+   region (copy-mark (region-start region) :right-inserting)))
+
+(defun modify-hemlock-region-stream (stream region)
+  (setf (hemlock-region-stream-region stream) region
+	(lisp::stream-in-index stream) lisp::in-buffer-length)
+  (let* ((mark (hemlock-region-stream-mark stream))
+	 (start (region-start region))
+	 (start-line (mark-line start)))
+    ;; Make sure it's dead.
+    (delete-mark mark)
+    (setf (mark-line mark) start-line  (mark-charpos mark) (mark-charpos start))
+    (push mark (line-marks start-line)))
+  stream)
+
+(defun region-readline (stream eof-errorp eof-value)
+  (close-line)
+  (let ((mark (hemlock-region-stream-mark stream))
+	(end (region-end (hemlock-region-stream-region stream))))
+    (cond ((mark>= mark end)
+	   (if eof-errorp
+	       (error "~A hit end of file." stream)
+	       (values eof-value nil)))
+	  ((eq (mark-line mark) (mark-line end))
+	   (let* ((limit (mark-charpos end))
+		  (charpos (mark-charpos mark))
+		  (dst-end (- limit charpos))
+		  (result (make-string dst-end)))
+	     (declare (simple-string result))
+	     (%sp-byte-blt (line-chars (mark-line mark)) charpos
+			   result 0 dst-end)
+	     (setf (mark-charpos mark) limit)
+	     (values result t)))
+	  ((= (mark-charpos mark) 0)
+	   (let* ((line (mark-line mark))
+		  (next (line-next line)))
+	     (always-change-line mark next)
+	     (values (line-chars line) nil)))
+	  (t
+	   (let* ((line (mark-line mark))
+		  (chars (line-chars line))
+		  (next (line-next line))
+		  (charpos (mark-charpos mark))
+		  (dst-end (- (length chars) charpos))
+		  (result (make-string dst-end)))
+	     (declare (simple-string chars result))
+	     (%sp-byte-blt chars charpos result 0 dst-end)
+	     (setf (mark-charpos mark) 0)
+	     (always-change-line mark next)
+	     (values result nil))))))
+
+(defun region-in (stream eof-errorp eof-value)
+  (close-line)
+  (let* ((mark (hemlock-region-stream-mark stream))
+	 (charpos (mark-charpos mark))
+	 (line (mark-line mark))
+	 (chars (line-chars line))
+	 (length (length chars))
+	 (last (region-end (hemlock-region-stream-region stream)))
+	 (last-line (mark-line last))
+	 (buffer (lisp::stream-in-buffer stream)) start len)
+    (declare (fixnum length charpos last-charpos start len)
+	     (simple-string chars))
+    (cond 
+     ((eq line last-line)
+      (let ((last-charpos (mark-charpos last)))
+	(setq len (- last-charpos charpos))
+	(cond
+	 ((>= charpos last-charpos)
+	  (if eof-errorp
+	      (error "~A hit end of file." stream) 
+	      (return-from region-in eof-value)))
+	 ((> len lisp::in-buffer-length)       
+	  (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
+	  (setq start 0  len lisp::in-buffer-length))
+	 (t
+	  (setq start (- lisp::in-buffer-length len))
+	  (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length)))))
+     ((line> line last-line)
+      (if eof-errorp
+	  (error "~a hit end of file." stream) 
+	  (return-from region-in eof-value)))
+     (t
+      (setq len (- length charpos))
+      (cond
+       ((< len lisp::in-buffer-length)
+	(let ((end (1- lisp::in-buffer-length)))
+	  (setq start (- lisp::in-buffer-length len 1))
+	  (%sp-byte-blt chars charpos buffer start end)
+	  (setf (schar buffer end) #\newline))
+	(incf len))
+       (t
+	(%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
+	(setq start 0  len lisp::in-buffer-length)))))
+    (setf (lisp::stream-in-index stream) (1+ start))
+    (character-offset mark len)
+    (schar buffer start)))
+
+(defun region-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:listen (mark< (hemlock-region-stream-mark stream)
+		    (region-end (hemlock-region-stream-region stream))))
+    (:read-line (region-readline stream arg1 arg2))
+    (:clear-input (move-mark
+                   (hemlock-region-stream-mark stream)
+                   (region-end (hemlock-region-stream-region stream))))
+    (:close
+     (delete-mark (hemlock-region-stream-mark stream))
+     (setf (hemlock-region-stream-region stream) nil))
+    (:element-type 'string-char)))
+
+;;;; Stuff to support keyboard macros.
+
+;;; Note that the buffers in these streams must be general vectors, because
+;;; the characters may have bits.
+
+(defstruct (kbdmac-stream
+	    (:include stream
+		      (:in #'kbdmac-in)
+		      (:listen #'kbdmac-listen)
+		      (:misc #'kbdmac-misc))
+	    (:constructor make-kbdmac-stream ()))
+  ;;
+  ;; The simple-vector that holds the characters.
+  buffer
+  ;;
+  ;; Index of the next character.
+  index)
+
+;;; Kbdmac-In  --  Internal
+;;;
+;;;    This is the input method for a kbdmac stream.  It just grabs a character
+;;; and returns it, bumping the index.
+;;;
+(defun kbdmac-in (stream eof-errorp eof-value)
+  (declare (ignore eof-errorp eof-value))
+  (let ((index (kbdmac-stream-index stream)))
+    (prog1 (setq *last-character-typed*
+		 (svref (kbdmac-stream-buffer stream) index))
+	   (setf (kbdmac-stream-index stream) (1+ index)))))
+
+;;; Kbdmac-Misc --  Internal
+;;;
+;;;    This is the misc method for kbdmac streams.  Since any character
+;;; that might have been read is included in the simulated input, listen
+;;; will always return T.
+;;;
+(defun kbdmac-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:unread
+     (if (plusp (kbdmac-stream-index stream))
+	 (decf (kbdmac-stream-index stream))
+	 (error "Nothing to unread.")))
+    (:listen t)
+    (:element-type 'string-char))
+  t)
+
+;;; Modify-Kbdmac-Stream  --  Internal
+;;;
+;;;    Bash the kbdmac-stream Stream so that it will return the Input.
+;;;
+(defun modify-kbdmac-stream (stream input)
+  (setf (kbdmac-stream-index stream) 0)
+  (setf (kbdmac-stream-buffer stream) input)
+  stream)
diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c9e51959f13a9cdbdef99b3a755b874bc920a65b
--- /dev/null
+++ b/hemlock/struct.lisp
@@ -0,0 +1,611 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Structures and assorted macros for Hemlock.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(mark mark-line mark-charpos markp region region-start region-end
+	  regionp buffer bufferp buffer-modes buffer-point buffer-writable
+	  buffer-delete-hook buffer-windows buffer-variables buffer-write-date
+	  region regionp region-start region-end window windowp window-height
+	  window-width window-display-start window-display-end window-point
+	  commandp command command-function command-documentation
+	  modeline-field modeline-field-p))
+
+
+;;;; Marks.
+
+(defstruct (mark (:print-function %print-hmark)
+		 (:predicate markp)
+		 (:copier nil)
+		 (:constructor internal-make-mark (line charpos %kind)))
+  "A Hemlock mark object.  See Hemlock Command Implementor's Manual for details."
+  line					; pointer to line
+  charpos				; character position
+  %kind)				; type of mark
+
+(setf (documentation 'markp 'function)
+  "Returns true if its argument is a Hemlock mark object, false otherwise.")
+(setf (documentation 'mark-line 'function)
+  "Returns line that a Hemlock mark points to.")
+(setf (documentation 'mark-charpos 'function)
+  "Returns the character position of a Hemlock mark.
+  A mark's character position is the index within the line of the character
+  following the mark.")
+
+(defstruct (font-mark (:print-function
+		       (lambda (s stream d)
+			 (declare (ignore d))
+			 (write-string "#<Hemlock Font-Mark \"" stream)
+			 (%print-before-mark s stream)
+			 (write-string "/\\" stream)
+			 (%print-after-mark s stream)
+			 (write-string "\">" stream)))
+		      (:include mark)
+		      (:copier nil)
+		      (:constructor internal-make-font-mark
+				    (line charpos %kind font)))
+  font)
+
+(defmacro fast-font-mark-p (s)
+  `(eq (svref ,s 0) 'font-mark))
+
+
+
+;;;; Regions, buffers, modeline fields.
+
+;;; The region object:
+;;;
+(defstruct (region (:print-function %print-hregion)
+		   (:predicate regionp)
+		   (:copier nil)
+		   (:constructor internal-make-region (start end)))
+  "A Hemlock region object.  See Hemlock Command Implementor's Manual for details."
+  start					; starting mark
+  end)					; ending mark
+
+(setf (documentation 'regionp 'function)
+  "Returns true if its argument is a Hemlock region object, Nil otherwise.")
+(setf (documentation 'region-end 'function)
+  "Returns the mark that is the end of a Hemlock region.")
+(setf (documentation 'region-start 'function)
+  "Returns the mark that is the start of a Hemlock region.")
+
+
+;;; The buffer object:
+;;;
+(defstruct (buffer (:constructor internal-make-buffer)
+		   (:print-function %print-hbuffer)
+		   (:copier nil)
+		   (:predicate bufferp))
+  "A Hemlock buffer object.  See Hemlock Command Implementor's Manual for details."
+  %name			      ; name of the buffer (a string)
+  %region		      ; the buffer's region
+  %pathname		      ; associated pathname
+  modes			      ; list of buffer's mode names
+  mode-objects		      ; list of buffer's mode objects
+  bindings		      ; buffer's command table
+  point			      ; current position in buffer
+  (%writable t)		      ; t => can alter buffer's region
+  (modified-tick -2)	      ; The last time the buffer was modified.
+  (unmodified-tick -1)	      ; The last time the buffer was unmodified
+  windows		      ; List of all windows into this buffer.
+  var-values		      ; the buffer's local variables
+  variables		      ; string-table of local variables
+  write-date		      ; File-Write-Date for pathname.
+  display-start		      ; Window display start when switching to buf.
+  %modeline-fields	      ; List of modeline-field-info's.
+  (delete-hook nil))	      ; List of functions to call upon deletion.
+
+(setf (documentation 'buffer-modes 'function)
+  "Return the list of the names of the modes active in a given buffer.")
+(setf (documentation 'buffer-point 'function)
+  "Return the mark that is the current focus of attention in a buffer.")
+(setf (documentation 'buffer-windows 'function)
+  "Return the list of windows that are displaying a given buffer.")
+(setf (documentation 'buffer-variables 'function)
+  "Return the string-table of the variables local to the specifed buffer.")
+(setf (documentation 'buffer-write-date 'function)
+  "Return in universal time format the write date for the file associated
+   with the buffer.  If the pathname is set, then this should probably
+   be as well.  Should be NIL if the date is unknown or there is no file.")
+(setf (documentation 'buffer-delete-hook 'function)
+  "This is the list of buffer specific functions that Hemlock invokes when
+   deleting this buffer.")
+
+
+;;; Modeline fields.
+;;;
+(defstruct (modeline-field (:print-function print-modeline-field)
+			   (:constructor %make-modeline-field
+					 (%name %function %width)))
+  "This is one item displayed in a Hemlock window's modeline."
+  %name		; EQL name of this field.
+  %function	; Function that returns a string for this field.
+  %width)	; Width to display this field in.
+
+(setf (documentation 'modeline-field-p 'function)
+      "Returns true if its argument is a modeline field object, nil otherwise.")
+
+(defstruct (modeline-field-info (:print-function print-modeline-field-info)
+				(:conc-name ml-field-info-)
+				(:constructor make-ml-field-info (field)))
+  field
+  (start nil)
+  (end nil))
+
+
+
+;;;; The mode object.
+
+(defstruct (mode-object (:predicate modep)
+			(:copier nil)
+			(:print-function %print-hemlock-mode))
+  name                   ; name of this mode
+  setup-function         ; setup function for this mode
+  cleanup-function       ; Cleanup function for this mode
+  bindings               ; The mode's command table.
+  transparent-p		 ; Are key-bindings transparent?
+  hook-name              ; The name of the mode hook.
+  major-p                ; Is this a major mode?
+  precedence		 ; The precedence for a minor mode.
+  character-attributes   ; Mode local character attributes
+  variables              ; String-table of mode variables
+  var-values             ; Alist for saving mode variables
+  documentation)         ; Introductory comments for mode describing commands.
+
+(defun %print-hemlock-mode (object stream depth)
+  (declare (ignore depth))
+  (write-string "#<Hemlock Mode \"" stream)
+  (write-string (mode-object-name object) stream)
+  (write-string "\">" stream))
+
+
+
+;;;; Variables.
+
+;;; This holds information about Hemlock variables, and the system stores
+;;; these structures on the property list of the variable's symbolic
+;;; representation under the 'hemlock-variable-value property.
+;;;
+(defstruct (variable-object
+	    (:print-function
+	     (lambda (object stream depth)
+	       (declare (ignore depth))
+	       (format stream "#<Hemlock Variable-Object ~S>"
+		       (variable-object-name object))))
+	    (:copier nil)
+	    (:constructor make-variable-object (documentation name)))
+  value		; The value of this variable.
+  hooks		; The hook list for this variable.
+  down		; The variable-object for the previous value.
+  documentation ; The documentation.
+  name)		; The string name.
+
+
+
+;;;; Windows, dis-lines, and font-changes.
+
+;;; The window object:
+;;;
+(defstruct (window (:constructor internal-make-window)
+		   (:predicate windowp)
+		   (:copier nil)
+		   (:print-function %print-hwindow))
+  "This structure implements a Hemlock window."
+  tick				; The last time this window was updated.
+  %buffer			; buffer displayed in this window.
+  height			; Height of window in lines.
+  width				; Width of the window in characters.
+  old-start			; The charpos of the first char displayed.
+  first-line			; The head of the list of dis-lines.
+  last-line			; The last dis-line displayed.
+  first-changed			; The first changed dis-line on last update.
+  last-changed			; The last changed dis-line.
+  spare-lines			; The head of the list of unused dis-lines
+  (old-lines 0)			; Slot used by display to keep state info
+  hunk				; The device hunk that displays this window.
+  display-start			; first character position displayed
+  display-end			; last character displayed
+  point				; Where the cursor is in this window.  
+  modeline-dis-line		; Dis-line for modeline display.
+  modeline-buffer		; Complete string of all modeline data.
+  modeline-buffer-len)		; Valid chars in modeline-buffer.
+
+(setf (documentation 'windowp 'function)
+  "Returns true if its argument is a Hemlock window object, Nil otherwise.")
+(setf (documentation 'window-height 'function)
+  "Return the height of a Hemlock window in character positions.")
+(setf (documentation 'window-width 'function)
+  "Return the width of a Hemlock window in character positions.")
+(setf (documentation 'window-display-start 'function)
+  "Return the mark which points before the first character displayed in
+  the supplied window.")
+(setf (documentation 'window-display-end 'function)
+  "Return the mark which points after the last character displayed in
+  the supplied window.")
+(setf (documentation 'window-point 'function)
+  "Return the mark that points to where the cursor is displayed in this
+  window.  When the window is made current, the Buffer-Point of this
+  window's buffer is moved to this position.  While the window is
+  current, redisplay makes this mark point to the same position as the
+  Buffer-Point of its buffer.")
+
+(defstruct (dis-line (:copier nil)
+		     (:constructor nil))
+  chars			      ; The line-image to be displayed.
+  (length 0 :type fixnum)     ; Length of line-image.
+  font-changes)		      ; Font-Change structures for changes in this line.
+
+(defstruct (window-dis-line (:copier nil)
+			    (:include dis-line)
+			    (:constructor make-window-dis-line (chars))
+			    (:conc-name dis-line-))
+  old-chars		      ; Line-Chars of line displayed.
+  line			      ; Line displayed.
+  (flags 0 :type fixnum)      ; Bit flags indicate line status.
+  (delta 0 :type fixnum)      ; # lines moved from previous position.
+  (position 0 :type fixnum)   ; Line # to be displayed on.
+  (end 0 :type fixnum))	      ; Index after last logical character displayed.
+
+(defstruct (font-change (:copier nil)
+			(:constructor make-font-change (next)))
+  x			      ; X position that change takes effect.
+  font			      ; Index into font-map of font to use.
+  next			      ; The next Font-Change on this dis-line.
+  mark)			      ; Font-Mark responsible for this change.
+
+
+
+;;;; Font family.
+
+(defstruct font-family
+  map			; Font-map for hunk.
+  height		; Height of char box includung VSP.
+  width			; Width of font.
+  baseline		; Pixels from top of char box added to Y.
+  cursor-width		; Pixel width of cursor.
+  cursor-height		; Pixel height of cursor.
+  cursor-x-offset	; Added to pos of UL corner of char box to get
+  cursor-y-offset)	; UL corner of cursor blotch.
+
+
+
+;;;; Attribute descriptors.
+
+(defstruct (attribute-descriptor
+	    (:copier nil)
+	    (:print-function %print-attribute-descriptor))
+  "This structure is used internally in Hemlock to describe a character
+  attribute."
+  name
+  keyword
+  documentation
+  vector
+  hooks
+  end-value)
+
+
+
+;;;; Commands.
+
+(defstruct (command (:constructor internal-make-command
+				  (%name documentation function))
+		    (:copier nil)
+		    (:predicate commandp)
+		    (:print-function %print-hcommand))
+  %name				   ;The name of the command
+  documentation			   ;Command documentation string or function
+  function			   ;The function which implements the command
+  %bindings)			   ;Places where command is bound
+
+(setf (documentation 'commandp 'function)
+  "Returns true if its argument is a Hemlock command object, Nil otherwise.")
+(setf (documentation 'command-documentation 'function)
+  "Return the documentation for a Hemlock command, given the command-object.
+  Command documentation may be either a string or a function.  This may
+  be set with Setf.")
+
+
+
+;;;; Random typeout streams.
+
+;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY.
+;;;
+(defstruct (random-typeout-stream (:include stream)
+				  (:print-function print-random-typeout-stream)
+				  (:constructor
+				   make-random-typeout-stream (mark)))
+  mark		       ; The buffer point of the associated buffer.
+  window	       ; The hemlock window all this shit is in.
+  more-mark	       ; The mark that is not displayed when we need to more.
+  no-prompt	       ; T when we want to exit, still collecting output.
+  (first-more-p t))    ; T until the first time we more. Nil after.
+
+(defun print-random-typeout-stream (object stream ignore)
+  (declare (ignore ignore))
+  (format stream "#<Hemlock Random-Typeout-Stream ~S>"
+	  (buffer-name
+	   (line-buffer (mark-line (random-typeout-stream-mark object))))))
+
+
+
+;;;; Redisplay devices.
+
+;;; Devices contain monitor specific redisplay methods referenced by
+;;; redisplay independent code.
+;;;
+(defstruct (device (:print-function print-device)
+		   (:constructor %make-device))
+  name			; simple-string such as "concept" or "lnz".
+  init			; fun to call whenever going into the editor.
+			; args: device
+  exit			; fun to call whenever leaving the editor.
+			; args: device
+  smart-redisplay	; fun to redisplay a window on this device.
+			; args: window &optional recenterp
+  dumb-redisplay	; fun to redisplay a window on this device.
+			; args: window &optional recenterp
+  after-redisplay	; args: device
+			; fun to call at the end of redisplay entry points.
+  clear			; fun to clear the entire display.
+			; args: device
+  note-read-wait	; fun to somehow note on display that input is expected.
+			; args: on-or-off
+  put-cursor		; fun to put the cursor at (x,y) or (column,line).
+			; args: hunk &optional x y
+  show-mark		; fun to display the screens cursor at a certain mark.
+			; args: window x y time
+  next-window		; funs to return the next and previous window
+  previous-window	;    of some window.
+			; args: window
+  make-window		; fun to make a window on the screen.
+			; args: device start-mark
+			;       &optional modeline-string modeline-function
+  delete-window		; fun to remove a window from the screen.
+			; args: window
+  random-typeout-setup	; fun to prepare for random typeout.
+  			; args: device n
+  random-typeout-cleanup; fun to clean up after random typeout.
+  			; args: device degree
+  random-typeout-line-more ; fun to keep line-buffered streams up to date.
+  random-typeout-full-more ; fun to do full-buffered  more-prompting.
+			   ; args: # of newlines in the object just inserted
+			   ;    in the buffer.
+  force-output		; if non-nil, fun to force any output possibly buffered.
+  finish-output		; if non-nil, fun to force output and hand until done.
+  			; args: device window
+  beep			; fun to beep or flash the screen.
+  bottom-window-base    ; bottom text line of bottom window.
+  hunks)		; list of hunks on the screen.
+
+(defun print-device (obj str n)
+  (declare (ignore n))
+  (format str "#<Hemlock Device ~S>" (device-name obj)))
+
+
+(defstruct (bitmap-device #|(:print-function print-device)|#
+			  (:include device))
+  display)		      ; CLX display object.
+
+
+(defstruct (tty-device #|(:print-function print-device)|#
+		       (:constructor %make-tty-device)
+		       (:include device))
+  dumbp			; t if it does not have line insertion and deletion.
+  lines			; number of lines on device.
+  columns		; number of columns per line.
+  display-string	; fun to display a string of characters at (x,y).
+			; args: hunk x y string &optional start end 
+  standout-init         ; fun to put terminal in standout mode.
+			; args: hunk
+  standout-end          ; fun to take terminal out of standout mode.
+			; args: hunk
+  clear-lines		; fun to clear n lines starting at (x,y).
+			; args: hunk x y n
+  clear-to-eol		; fun to clear to the end of a line from (x,y).
+			; args: hunk x y
+  clear-to-eow		; fun to clear to the end of a window from (x,y).
+			; args: hunk x y
+  open-line		; fun to open a line moving lines below it down.
+			; args: hunk x y &optional n
+  delete-line		; fun to delete a line moving lines below it up.
+			; args: hunk x y &optional n
+  insert-string		; fun to insert a string in the middle of a line.
+			; args: hunk x y string &optional start end
+  delete-char		; fun to delete a character from the middle of a line.
+			; args: hunk x y &optional n
+  (cursor-x 0)		; column the cursor is in.
+  (cursor-y 0)		; line the cursor is on.
+  standout-init-string  ; string to put terminal in standout mode.
+  standout-end-string   ; string to take terminal out of standout mode.
+  clear-to-eol-string	; string to cause device to clear to eol at (x,y).
+  clear-string		; string to cause device to clear entire screen.
+  open-line-string	; string to cause device to open a blank line.
+  delete-line-string	; string to cause device to delete a line, moving
+			; lines below it up.
+  insert-init-string	; string to put terminal in insert mode.
+  insert-char-init-string ; string to prepare terminal for insert-mode character.
+  insert-char-end-string ; string to affect terminal after insert-mode character.
+  insert-end-string	; string to take terminal out of insert mode.
+  delete-init-string	; string to put terminal in delete mode.
+  delete-char-string	; string to delete a character.
+  delete-end-string	; string to take terminal out of delete mode.
+  init-string		; device init string.
+  cm-end-string		; takes device out of cursor motion mode.
+  (cm-x-add-char nil)	; char-code to unconditionally add to x coordinate.
+  (cm-y-add-char nil)	; char-code to unconditionally add to y coordinate.
+  (cm-x-condx-char nil)	; char-code threshold for adding to x coordinate.
+  (cm-y-condx-char nil)	; char-code threshold for adding to y coordinate.
+  (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate.
+  (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate.
+  cm-string1		; initial substring of cursor motion string.
+  cm-string2		; substring of cursor motion string between coordinates.
+  cm-string3		; substring of cursor motion string after coordinates.
+  cm-one-origin		; non-nil if need to add one to coordinates.
+  cm-reversep		; non-nil if need to reverse coordinates.
+  (cm-x-pad nil)	; nil, 0, 2, or 3 for places to pad.
+			; 0 sends digit-chars.
+  (cm-y-pad nil)	; nil, 0, 2, or 3 for places to pad.
+			; 0 sends digit-chars.
+  screen-image)		; vector device-lines long of strings
+			; device-columns long.
+
+
+
+;;;; Device screen hunks.
+
+;;; Device-hunks are used to claim a piece of the screen and for ordering
+;;; pieces of the screen.  Window motion primitives and splitting/merging
+;;; primitives use hunks.  Hunks are somewhat of an interface between the
+;;; portable and non-portable parts of screen management, between what the
+;;; user sees on the screen and how Hemlock internals deal with window
+;;; sequencing and creation.  Note: the echo area hunk is not hooked into
+;;; the ring of other hunks via the next and previous fields.
+;;;
+(defstruct (device-hunk (:print-function %print-device-hunk))
+  "This structure is used internally by Hemlock's screen management system."
+  window		; Window displayed in this hunk.
+  position		; Bottom Y position of hunk.
+  height		; Height of hunk in pixels or lines.
+  next			; Next and previous hunks.
+  previous
+  device)		; Display device hunk is on.
+
+(defun %print-device-hunk (object stream depth)
+  (declare (ignore depth))
+  (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>"
+	  (device-hunk-position object)
+	  (device-hunk-height object)
+	  (let* ((window (device-hunk-window object))
+		 (buffer (if window (window-buffer window))))
+	    (if buffer (buffer-name buffer)))))
+
+
+;;; Bitmap hunks.
+;;;
+;;; The lock field is no longer used.  If events could be handled while we
+;;; were in the middle of something with the hunk, then this could be set
+;;; for exclusion purposes.
+;;;
+(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|#
+			(:include device-hunk))
+  width			      ; Pixel width.
+  char-height	      	      ; Height of text body in characters.
+  char-width		      ; Width in characters.
+  xwindow		      ; X window for this hunk.
+  gcontext		      ; X gcontext for xwindow.
+  start			      ; Head of dis-line list (no dummy).
+  end			      ; Exclusive end, i.e. nil if nil-terminated.
+  modeline-dis-line	      ; Dis-line for modeline, or NIL if none.
+  modeline-pos		      ; Position of modeline in pixels.
+  (lock t)		      ; Something going on, set trashed if we're changed.
+  trashed 		      ; Something bad happened, recompute image.
+  font-family		      ; Font-family used in this window.
+  input-handler		      ; Gets hunk, char, x, y when char read.
+  changed-handler	      ; Gets hunk when size changed.
+  (thumb-bar-p nil))	      ; True if we draw a thumb bar in the top border.
+
+
+;;; Terminal hunks.
+;;; 
+(defstruct (tty-hunk #|(:print-function %print-device-hunk)|#
+		     (:include device-hunk))
+  text-position		; Bottom Y position of text in hunk.
+  text-height)		; Number of lines of text.
+
+
+
+;;;; Some defsetfs:
+
+(defsetf buffer-writable %set-buffer-writable
+  "Sets whether the buffer is writable and invokes the Buffer Writable Hook.")
+(defsetf buffer-name %set-buffer-name
+  "Sets the name of a specified buffer, invoking the Buffer Name Hook.")
+(defsetf buffer-modified %set-buffer-modified
+  "Make a buffer modified or unmodified.")
+(defsetf buffer-pathname %set-buffer-pathname
+  "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.")
+
+(defsetf getstring %set-string-table
+  "Sets the value for a string-table entry, making a new one if necessary.")
+
+(defsetf window-buffer %set-window-buffer
+  "Change the buffer a window is mapped to.")
+
+(lisp::define-setf-method value (var)
+  "Set the value of a Hemlock variable, calling any hooks."
+  (let ((svar (gensym)))
+    (values
+     ()
+     ()
+     (list svar)
+     `(%set-value ',var ,svar)
+     `(value ,var))))
+
+(defsetf variable-value (name &optional (kind :current) where) (new-value)
+  "Set the value of a Hemlock variable, calling any hooks."
+  `(%set-variable-value ,name ,kind ,where ,new-value))
+
+(defsetf variable-hooks (name &optional (kind :current) where) (new-value)
+  "Set the list of hook functions for a Hemlock variable."
+  `(%set-variable-hooks ,name ,kind ,where ,new-value))
+
+(defsetf variable-documentation (name &optional (kind :current) where) (new-value)
+  "Set a Hemlock variable's documentation."
+  `(%set-variable-documentation ,name ,kind ,where ,new-value))
+
+(defsetf buffer-minor-mode %set-buffer-minor-mode
+  "Turn a buffer minor mode on or off.")
+(defsetf buffer-major-mode %set-buffer-major-mode
+  "Set a buffer's major mode.")
+(defsetf previous-character %set-previous-character
+  "Sets the character to the left of the given Mark.")
+(defsetf next-character %set-next-character
+  "Sets the characters to the right of the given Mark.")
+(defsetf character-attribute %set-character-attribute
+  "Set the value for a character attribute.")
+(defsetf character-attribute-hooks %set-character-attribute-hooks
+  "Set the hook list for a Hemlock character attribute.")
+(defsetf ring-ref %set-ring-ref "Set an element in a ring.")
+(defsetf current-window %set-current-window "Set the current window.")
+(defsetf current-buffer %set-current-buffer
+  "Set the current buffer, doing necessary stuff.")
+(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
+(defsetf buffer-region %set-buffer-region "Set a buffer's region.")
+(defsetf command-name %set-command-name
+  "Change a Hemlock command's name.")
+(defsetf line-string %set-line-string
+  "Replace the contents of a line.")
+(defsetf last-command-type %set-last-command-type
+  "Set the Last-Command-Type for use by the next command.")
+(defsetf prefix-argument %set-prefix-argument
+  "Set the prefix argument for the next command.")
+(defsetf logical-char= %set-logical-char=
+  "Change what Logical-Char= returns for the specified arguments.")
+(defsetf window-font %set-window-font
+  "Change the font-object associated with a font-number in a window.")
+(defsetf default-font %set-default-font
+  "Change the font-object associated with a font-number in new windows.")
+
+(defsetf buffer-modeline-fields %set-buffer-modeline-fields
+  "Sets the buffer's list of modeline fields causing all windows into buffer
+   to be updated for the next redisplay.")
+(defsetf modeline-field-name %set-modeline-field-name
+  "Sets a modeline-field's name.  If one already exists with that name, an
+   error is signaled.")
+(defsetf modeline-field-width %set-modeline-field-width
+  "Sets a modeline-field's width and updates all the fields for all windows
+   in any buffer whose fields list contains the field.")
+(defsetf modeline-field-function %set-modeline-field-function
+  "Sets a modeline-field's function and updates this field for all windows in
+   any buffer whose fields list contains the field.")
diff --git a/hemlock/syntax.lisp b/hemlock/syntax.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..08a6b1f122e81280ab4b48fc3d056f41f44d1a1b
--- /dev/null
+++ b/hemlock/syntax.lisp
@@ -0,0 +1,565 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Hemlock syntax table routines.
+;;;
+;;; Written by Rob MacLachlan.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(character-attribute-name
+	  defattribute character-attribute-documentation character-attribute
+	  character-attribute-hooks character-attribute-p shadow-attribute
+	  unshadow-attribute find-attribute reverse-find-attribute))
+
+;;;; Character attribute caching.
+;;;
+;;;    In order to permit the %SP-Find-Character-With-Attribute sub-primitive
+;;; to be used for a fast implementation of find-attribute and
+;;; reverse-find-attribute, there must be some way of translating 
+;;; attribute/test-function pairs into a attribute vector and a mask.
+;;;    What we do is maintain a eq-hash-cache of attribute/test-function
+;;; pairs.  If the desired pair is not in the cache then we reclaim an old
+;;; attribute bit in the bucket we hashed to and stuff it by calling the
+;;; test function on the value of the attribute for all characters.
+
+(defvar *character-attribute-cache* ()
+  "This is the cache used to translate attribute/test-function pairs to
+  attribute-vector/mask pairs for find-attribute and reverse-find-attribute.")
+
+(eval-when (compile eval)
+(defconstant character-attribute-cache-size 13
+  "The number of buckets in the *character-attribute-cache*.")
+(defconstant character-attribute-bucket-size 3
+  "The number of bits to use in each bucket of the
+  *character-attribute-cache*.")
+); eval-when (compile eval)
+
+;;;    In addition, since a common pattern in code which uses find-attribute
+;;; is to repeatedly call it with the same function and attribute, we
+;;; remember the last attribute/test-function pair that was used, and check
+;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
+;;;
+(defvar *last-find-attribute-attribute* ()
+  "The attribute which we last did a find-attribute on.")
+(defvar *last-find-attribute-function* ()
+  "The last test-function used for find-attribute.")
+(defvar *last-find-attribute-vector* ()
+  "The %SP-Find-Character-With-Attribute vector corresponding to the last
+  attribute/function pair used for find-attribute.")
+(defvar *last-find-attribute-mask* ()
+  "The the mask to use with *last-find-attribute-vector* to do a search
+  for the last attribute/test-function pair.")
+(defvar *last-find-attribute-end-wins* ()
+  "The the value of End-Wins for the last attribute/test-function pair.")
+
+
+(defvar *character-attributes* (make-hash-table :test #'eq)
+  "A hash table which translates character attributes to their values.")
+(defvar *last-character-attribute-requested* nil
+  "The last character attribute which was asked for, Do Not Bind.")
+(defvar *value-of-last-character-attribute-requested* nil
+  "The value of the most recent character attribute, Do Not Bind.")
+
+(proclaim '(special *character-attribute-names*))
+
+
+;;; Each bucket contains a list of character-attribute-bucket-size
+;;; bit-descriptors.
+;;;
+(defstruct (bit-descriptor)
+  function		      ; The test on the attribute.
+  attribute		      ; The attribute this is a test of.
+  (mask 0 :type fixnum)	      ; The mask for the corresponding bit.
+  vector		      ; The vector the bit is in.
+  end-wins)		      ; Is this test true of buffer ends?
+
+;;;
+;;; In a descriptor for an unused bit, the function is nil, preventing a
+;;; hit.  Whenever we change the value of an attribute for some character,
+;;; we need to flush the cache of any entries for that attribute.  Currently
+;;; we do this by mapping down the list of all bit descriptors.  Note that
+;;; we don't have to worry about GC, since this is just a hint.
+;;;
+(defvar *all-bit-descriptors* () "The list of all the bit descriptors.")
+
+(eval-when (compile eval)
+(defmacro allocate-bit (vec bit-num)
+  `(progn
+    (when (= ,bit-num 8)
+      (setq ,bit-num 0  ,vec (make-array 256 :element-type '(mod 256))))
+    (car (push (make-bit-descriptor
+		:vector ,vec
+		:mask (ash 1 (prog1 ,bit-num (incf ,bit-num))))
+	       *all-bit-descriptors*)))))
+;;;    
+(defun %init-syntax-table ()
+  (let ((tab (make-array character-attribute-cache-size))
+	(bit-num 8) vec)
+    (setq *character-attribute-cache* tab)
+    (dotimes (c character-attribute-cache-size)
+      (setf (svref tab c)
+	    (do ((i 0 (1+ i))
+		 (res ()))
+		((= i character-attribute-bucket-size) res)
+	      (push (allocate-bit vec bit-num) res))))))
+
+(eval-when (compile eval)
+(defmacro hash-it (attribute function)
+  `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3)
+		     (lisp::%sp-make-fixnum ,function))
+	     character-attribute-cache-size)))
+
+;;; CACHED-ATTRIBUTE-LOOKUP  --  Internal
+;;;
+;;;    Sets Vector and Mask such that they can be used as arguments
+;;; to %sp-find-character-with-attribute to effect a search with attribute 
+;;; Attribute and test Function.  If the function and attribute
+;;; are the same as the last ones then we just set them to that, otherwise
+;;; we do the hash-cache lookup and update the *last-find-attribute-<mumble>*
+;;;
+(defmacro cached-attribute-lookup (attribute function vector mask end-wins)
+  `(if (and (eq ,function *last-find-attribute-function*)
+	    (eq ,attribute *last-find-attribute-attribute*))
+       (setq ,vector *last-find-attribute-vector*
+	     ,mask *last-find-attribute-mask*
+	     ,end-wins *last-find-attribute-end-wins*)
+       (let ((bit (svref *character-attribute-cache*
+			 (hash-it ,attribute ,function))))
+	 ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins)
+		       (new-cache-attribute ,attribute ,function))
+		    `(let ((b (car bit)))
+		       (cond
+			((and (eq (bit-descriptor-function b)
+				  ,function)
+			      (eq (bit-descriptor-attribute b)
+				  ,attribute))
+			 (setq ,vector (bit-descriptor-vector b)
+			       ,mask (bit-descriptor-mask b)
+			       ,end-wins (bit-descriptor-end-wins b)))
+			(t
+			 (setq bit (cdr bit)) ,res))))
+	       (count 0 (1+ count)))
+	      ((= count character-attribute-bucket-size) res))
+	 (setq *last-find-attribute-attribute* ,attribute
+	       *last-find-attribute-function* ,function
+	       *last-find-attribute-vector* ,vector
+	       *last-find-attribute-mask* ,mask
+	       *last-find-attribute-end-wins* ,end-wins))))
+); eval-when (compile eval)
+
+;;; NEW-CACHE-ATTRIBUTE  --  Internal
+;;;
+;;;    Pick out an old attribute to punt out of the cache and put in the
+;;; new one.  We pick a bit off of the end of the bucket and pull it around
+;;; to the beginning to get a degree of LRU'ness.
+;;;
+(defun new-cache-attribute (attribute function)
+  (let* ((hash (hash-it attribute function))
+	 (values (gethash attribute *character-attributes*))
+	 (bucket (svref *character-attribute-cache* hash))
+	 (bit (nthcdr (- character-attribute-bucket-size 2) bucket))
+	 (end-wins (funcall function (attribute-descriptor-end-value values))))
+    (unless values
+      (error "~S is not a defined character attribute." attribute))
+    (shiftf bit (cdr bit) nil)
+    (setf (svref *character-attribute-cache* hash) bit
+	  (cdr bit) bucket  bit (car bit))
+    (setf (bit-descriptor-attribute bit) attribute
+	  (bit-descriptor-function bit) function
+	  (bit-descriptor-end-wins bit) end-wins)
+    (setq values (attribute-descriptor-vector values))
+    (do ((mask (bit-descriptor-mask bit))
+	 (fun (bit-descriptor-function bit))
+	 (vec (bit-descriptor-vector bit))
+	 (i 0 (1+ i)))
+	((= i syntax-char-code-limit) (values vec mask end-wins))
+      (declare (type (simple-array (mod 256)) vec))
+      (if (funcall fun (aref (the simple-array values) i))
+	  (setf (aref vec i) (logior (aref vec i) mask))
+	  (setf (aref vec i) (logandc2 (aref vec i) mask))))))
+
+(defun %print-attribute-descriptor (object stream depth)
+  (declare (ignore depth))
+  (format stream "#<Hemlock Attribute-Descriptor ~S>"
+	  (attribute-descriptor-name object)))
+
+;;; DEFATTRIBUTE  --  Public
+;;;
+;;;    Make a new vector of some type and enter it in the table.
+;;;
+(defun defattribute (name documentation &optional (type '(mod 2))
+			  (initial-value 0))
+  "Define a new Hemlock character attribute with named Name with
+  the supplied Documentation, Type and Initial-Value.  Type
+  defaults to (mod 2) and Initial-Value defaults to 0."
+  (setq name (coerce name 'simple-string))
+  (let* ((attribute (string-to-keyword name))
+	 (new (make-attribute-descriptor
+	       :vector (make-array syntax-char-code-limit
+				   :element-type type
+				   :initial-element initial-value)
+	       :name name
+	       :keyword attribute
+	       :documentation documentation
+	       :end-value initial-value)))
+    (when (gethash attribute *character-attributes*)
+      (warn "Character Attribute ~S is being redefined." name))
+    (setf (getstring name *character-attribute-names*) attribute)
+    (setf (gethash attribute *character-attributes*) new))
+  name)
+
+;;; WITH-ATTRIBUTE  --  Internal
+;;;
+;;;    Bind obj to the attribute descriptor corresponding to symbol,
+;;; giving error if it is not a defined attribute.
+;;;
+(eval-when (compile eval)
+(defmacro with-attribute (symbol &body forms)
+  `(let ((obj (gethash ,symbol *character-attributes*)))
+     (unless obj
+       (error "~S is not a defined character attribute." ,symbol))
+     ,@forms))
+); eval-when (compile eval)
+
+(defun character-attribute-name (attribute)
+  "Return the string-name of the character-attribute Attribute."
+  (with-attribute attribute
+    (attribute-descriptor-name obj)))
+
+(defun character-attribute-documentation (attribute)
+  "Return the documentation for the character-attribute Attribute."
+  (with-attribute attribute
+    (attribute-descriptor-documentation obj)))
+
+(defun character-attribute-hooks (attribute)
+  "Return the hook-list for the character-attribute Attribute.  This can
+  be set with Setf."
+  (with-attribute attribute
+    (attribute-descriptor-hooks obj)))
+
+(defun %set-character-attribute-hooks (attribute new-value)
+  (with-attribute attribute
+    (setf (attribute-descriptor-hooks obj) new-value)))
+
+(proclaim '(special *last-character-attribute-requested*
+		    *value-of-last-character-attribute-requested*))
+
+;;; CHARACTER-ATTRIBUTE  --  Public
+;;;
+;;;    Return the value of a character attribute for some character.
+;;;
+(proclaim '(inline character-attribute))
+(defun character-attribute (attribute character)
+  "Return the value of the the character-attribute Attribute for Character.
+  If Character is Nil then return the end-value."
+  (if (and (eq attribute *last-character-attribute-requested*) character)
+      (aref (the simple-array *value-of-last-character-attribute-requested*)
+	    (syntax-char-code character))
+      (sub-character-attribute attribute character)))
+;;;
+(defun sub-character-attribute (attribute character)
+  (with-attribute attribute
+    (setq *last-character-attribute-requested* attribute)
+    (setq *value-of-last-character-attribute-requested*
+	  (attribute-descriptor-vector obj))
+    (if character
+	(aref (the simple-array *value-of-last-character-attribute-requested*)
+	      (syntax-char-code character))
+	(attribute-descriptor-end-value obj))))
+
+;;; CHARACTER-ATTRIBUTE-P
+;;;
+;;;    Look up attribute in table.
+;;;
+(defun character-attribute-p (symbol)
+  "Return true if Symbol is the symbol-name of a character-attribute, Nil
+  otherwise."
+  (not (null (gethash symbol *character-attributes*))))
+
+
+;;; %SET-CHARACTER-ATTRIBUTE  --  Internal
+;;;
+;;;    Set the value of a character attribute.
+;;;
+(defun %set-character-attribute (attribute character new-value)
+  (with-attribute attribute
+    (invoke-hook ed::character-attribute-hook attribute character new-value)
+    (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value)
+    (cond
+     ;;
+     ;; Setting the value for a real character.
+     (character
+      (let ((value (attribute-descriptor-vector obj))
+	    (code (syntax-char-code character)))
+	(declare (type (simple-array *) value))
+	(dolist (bit *all-bit-descriptors*)
+	  (when (eq (bit-descriptor-attribute bit) attribute)
+	    (let ((vec (bit-descriptor-vector bit)))
+	      (declare (type (simple-array (mod 256)) vec))
+	      (setf (aref vec code)
+		    (if (funcall (bit-descriptor-function bit) new-value)
+			(logior (bit-descriptor-mask bit) (aref vec code))
+			(logandc1 (bit-descriptor-mask bit) (aref vec code)))))))
+	(setf (aref value code) new-value)))
+     ;;
+     ;; Setting the magical end-value.
+     (t
+      (setf (attribute-descriptor-end-value obj) new-value)
+      (dolist (bit *all-bit-descriptors*)
+	(when (eq (bit-descriptor-attribute bit) attribute)
+	  (setf (bit-descriptor-end-wins bit)
+		(funcall (bit-descriptor-function bit) new-value))))
+      new-value))))
+
+(eval-when (compile eval)
+;;; swap-one-attribute  --  Internal
+;;;
+;;;    Install the mode-local values described by Vals for Attribute, whose
+;;; representation vector is Value.
+;;;
+ (defmacro swap-one-attribute (attribute value vals hooks)
+  `(progn
+    ;; Fix up any cached attribute vectors.
+    (dolist (bit *all-bit-descriptors*)
+      (when (eq ,attribute (bit-descriptor-attribute bit))
+	(let ((fun (bit-descriptor-function bit))
+	      (vec (bit-descriptor-vector bit))
+	      (mask (bit-descriptor-mask bit)))
+	  (declare (type (simple-array (mod 256)) vec)
+		   (fixnum mask))
+	  (dolist (char ,vals)
+	    (setf (aref vec (car char))
+		  (if (funcall fun (cdr char))
+		      (logior mask (aref vec (car char)))
+		      (logandc1 mask (aref vec (car char)))))))))
+    ;; Invoke the attribute-hook.
+    (dolist (hook ,hooks)
+      (dolist (char ,vals)
+	(funcall hook ,attribute (code-char (car char)) (cdr char))))
+    ;; Fix up the value vector.
+    (dolist (char ,vals)
+      (rotatef (aref ,value (car char)) (cdr char)))))
+); eval-when (compile eval)
+
+
+;;; SWAP-CHAR-ATTRIBUTES  --  Internal
+;;;
+;;;    Swap the current values of character attributes and the ones
+;;;specified by "mode".  This is used in Set-Major-Mode.
+;;;
+(defun swap-char-attributes (mode)
+  (dolist (attribute (mode-object-character-attributes mode))
+    (let* ((obj (car attribute))
+	   (sym (attribute-descriptor-keyword obj))
+	   (value (attribute-descriptor-vector obj))
+	   (hooks (attribute-descriptor-hooks obj)))
+      (declare (simple-array value))
+      (swap-one-attribute sym value (cdr attribute) hooks))))
+
+
+
+(proclaim '(special *mode-names* *current-buffer*))
+
+;;; SHADOW-ATTRIBUTE  --  Public
+;;;
+;;;    Stick mode character attribute information in the mode object.
+;;;
+(defun shadow-attribute (attribute character value mode)
+  "Make a mode specific character attribute value.  The value of
+  Attribute for Character when we are in Mode will be Value."
+  (let ((desc (gethash attribute *character-attributes*))
+	(obj (getstring mode *mode-names*)))
+    (unless desc
+      (error "~S is not a defined Character Attribute." attribute))
+    (unless obj (error "~S is not a defined Mode." mode))
+    (let* ((current (assq desc (mode-object-character-attributes obj)))
+	   (code (syntax-char-code character))
+	   (hooks (attribute-descriptor-hooks desc))
+	   (vec (attribute-descriptor-vector desc))
+	   (cons (cons code value)))
+      (declare (simple-array vec))
+      (if current
+	  (let ((old (assq code (cdr current))))
+	    (if old
+		(setf (cdr old) value  cons old)
+		(push cons (cdr current))))
+	  (push (list desc cons)
+		(mode-object-character-attributes obj)))
+      (when (memq obj (buffer-mode-objects *current-buffer*))
+	(let ((vals (list cons)))
+	  (swap-one-attribute attribute vec vals hooks)))
+      (invoke-hook ed::shadow-attribute-hook attribute character value mode)))
+  attribute)
+
+;;; UNSHADOW-ATTRIBUTE  --  Public
+;;;
+;;;    Nuke a mode character attribute.
+;;;
+(defun unshadow-attribute (attribute character mode)
+  "Make the value of Attribte for Character no longer shadowed in Mode."
+  (let ((desc (gethash attribute *character-attributes*))
+	(obj (getstring mode *mode-names*)))
+    (unless desc
+      (error "~S is not a defined Character Attribute." attribute))
+    (unless obj
+      (error "~S is not a defined Mode." mode))
+    (invoke-hook ed::shadow-attribute-hook mode attribute character)
+    (let* ((value (attribute-descriptor-vector desc))
+	   (hooks (attribute-descriptor-hooks desc))
+	   (current (assq desc (mode-object-character-attributes obj)))
+	   (char (assq (syntax-char-code character) (cdr current))))
+      (declare (simple-array value))
+      (unless char
+	(error "Character Attribute ~S is not defined for character ~S ~
+	       in Mode ~S." attribute character mode))
+      (when (memq obj (buffer-mode-objects *current-buffer*))
+	(let ((vals (list char)))
+	  (swap-one-attribute attribute value vals hooks)))
+      (setf (cdr current) (delete char (the list (cdr current))))))
+  attribute)
+
+
+;;; NOT-ZEROP, the default test function for find-attribute etc.
+;;;
+(defun not-zerop (n)
+  (not (zerop n)))
+
+;;; find-attribute  --  Public
+;;;
+;;;    Do hairy cache lookup to find a find-character-with-attribute style
+;;; vector that we can use to do the search.
+;;;
+(eval-when (compile eval)
+(defmacro normal-find-attribute (line start result vector mask)
+  `(let ((chars (line-chars ,line)))
+     (setq ,result (%sp-find-character-with-attribute
+		   chars ,start (strlen chars) ,vector ,mask))))
+;;;
+(defmacro cache-find-attribute (start result vector mask)
+  `(let ((gap (- right-open-pos left-open-pos)))
+     (declare (fixnum gap))
+     (cond
+      ((>= ,start left-open-pos)
+       (setq ,result
+	     (%sp-find-character-with-attribute
+	      open-chars (+ ,start gap) line-cache-length ,vector ,mask))
+       (when ,result (decf ,result gap)))
+      ((setq ,result (%sp-find-character-with-attribute
+		      open-chars ,start left-open-pos ,vector ,mask)))
+      (t
+       (setq ,result
+	     (%sp-find-character-with-attribute
+	      open-chars right-open-pos line-cache-length ,vector ,mask))
+       (when ,result (decf ,result gap))))))
+); eval-when (compile eval)
+;;;
+(defun find-attribute (mark attribute &optional (test #'not-zerop))
+  "Find the next character whose attribute value satisfies test."
+  (let ((charpos (mark-charpos mark))
+	(line (mark-line mark)) vector mask end-wins)
+    (declare (type (simple-array (mod 256)) vector) (fixnum mask))
+    (cached-attribute-lookup attribute test vector mask end-wins)
+    (cond
+     ((cond
+       ((eq line open-line)
+	(when (cache-find-attribute charpos charpos vector mask)
+	  (setf (mark-charpos mark) charpos) mark))
+       (t
+	(when (normal-find-attribute line charpos charpos vector mask)
+	  (setf (mark-charpos mark) charpos) mark))))
+     ;; Newlines win and there is one.
+     ((and (not (zerop (logand mask (aref vector (char-code #\newline)))))
+	   (line-next line))
+      (move-to-position mark (line-length line) line))
+     ;; We can ignore newlines.
+     (t
+      (do (prev)
+	  (())
+	(setq prev line  line (line-next line))
+	(cond
+	 ((null line)
+	  (if end-wins
+	      (return (line-end mark prev))
+	      (return nil)))
+	 ((eq line open-line)
+	  (when (cache-find-attribute 0 charpos vector mask)
+	    (return (move-to-position mark charpos line))))
+	 (t
+	  (when (normal-find-attribute line 0 charpos vector mask)
+	    (return (move-to-position mark charpos line))))))))))
+
+
+;;; REVERSE-FIND-ATTRIBUTE  --  Public
+;;;
+;;;    Line find-attribute, only goes backwards.
+;;;
+(eval-when (compile eval)
+(defmacro rev-normal-find-attribute (line start result vector mask)
+  `(let ((chars (line-chars ,line)))
+     (setq ,result (%sp-reverse-find-character-with-attribute
+		    chars 0 ,(or start '(strlen chars)) ,vector ,mask))))
+;;;
+(defmacro rev-cache-find-attribute (start result vector mask)
+  `(let ((gap (- right-open-pos left-open-pos)))
+     (declare (fixnum gap))
+     (cond
+      ,@(when start
+	  `(((<= ,start left-open-pos)
+	     (setq ,result
+		   (%sp-reverse-find-character-with-attribute
+		    open-chars 0 ,start ,vector ,mask)))))
+      ((setq ,result (%sp-reverse-find-character-with-attribute
+		      open-chars right-open-pos
+		      ,(if start `(+ ,start gap) 'line-cache-length)
+		      ,vector ,mask))
+       (decf ,result gap))
+      (t
+       (setq ,result
+	     (%sp-reverse-find-character-with-attribute
+	      open-chars 0 left-open-pos ,vector ,mask))))))
+
+); eval-when (compile eval)
+;;;
+(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop))
+  "Find the previous character whose attribute value satisfies test."
+  (let* ((charpos (mark-charpos mark))
+	 (line (mark-line mark)) vector mask end-wins)
+    (declare (type (simple-array (mod 256)) vector)
+	     (fixnum charpos))
+    (cached-attribute-lookup attribute test vector mask end-wins)
+    (cond 
+     ((cond
+       ((eq line open-line)
+	(when (rev-cache-find-attribute charpos charpos vector mask)
+	  (setf (mark-charpos mark) (1+ charpos)) mark))
+       (t
+	(when (rev-normal-find-attribute line charpos charpos vector mask)
+	  (setf (mark-charpos mark) (1+ charpos)) mark))))
+     ;; Newlines win and there is one.
+     ((and (line-previous line)
+	   (not (zerop (logand mask (aref vector (char-code #\newline))))))
+      (move-to-position mark 0 line))
+     (t
+      (do (next)
+	  (())
+	(setq next line  line (line-previous line))
+	(cond
+	 ((null line)
+	  (if end-wins
+	      (return (line-start mark next))
+	      (return nil)))
+	 ((eq line open-line)
+	  (when (rev-cache-find-attribute nil charpos vector mask)
+	    (return (move-to-position mark (1+ charpos) line))))
+	 (t
+	  (when (rev-normal-find-attribute line nil charpos vector mask)
+	    (return (move-to-position mark (1+ charpos) line))))))))))
diff --git a/hemlock/table.lisp b/hemlock/table.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..f046f15abad5c30f4b142ceaeebb94fd2b6d64b8
--- /dev/null
+++ b/hemlock/table.lisp
@@ -0,0 +1,744 @@
+;;; -*- Log: hemlock.log; Package: HEMLOCK-INTERNALS -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). 
+;;; **********************************************************************
+;;;
+;;; Reluctantly written by Christopher Hoover
+;;; Supporting cast includes Rob and Bill.
+;;;
+;;; This file defines a data structure, analogous to a Common Lisp
+;;; hashtable, which translates strings to values and facilitates
+;;; recognition and completion of these strings.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(string-table string-table-p make-string-table
+		       string-table-separator getstring
+		       find-ambiguous complete-string find-containing
+		       delete-string clrstring do-strings))
+
+
+;;;; Implementation Details
+
+;;; String tables are a data structure somewhat analogous to Common Lisp
+;;; hashtables.  String tables are case-insensitive.  Functions are
+;;; provided to quickly look up strings, insert strings, disambiguate or
+;;; complete strings, and to provide a variety of ``help'' when
+;;; disambiguating or completing strings.
+;;; 
+;;; String tables are represented as a series of word tables which form
+;;; a tree.  Four structures are used to implement this data structure.
+;;; The first is a STRING-TABLE.  This structure has severals slots one
+;;; of which, FIRST-WORD-TABLE, points to the first word table.  This
+;;; first word table is also the root of tree.  The STRING-TABLE
+;;; structure also contains slots to keep track of the number of nodes,
+;;; the string table separator (which is used to distinguish word or
+;;; field boundaries), and a pointer to an array of VALUE-NODE's.
+;;; 
+;;; A WORD-TABLE is simply an array of pointers to WORD-ENTRY's.  This
+;;; array is kept sorted by the FOLDED slot in each WORD-ENTRY so that a
+;;; binary search can be used.  Each WORD-ENTRY contains a case-folded
+;;; string and a pointer to the next WORD-TABLE in the tree.  By
+;;; traversing the tree made up by these structures, searching and
+;;; completion can easily be done.
+;;; 
+;;; Another structure, a VALUE-NODE, is used to hold each entry in the
+;;; string table and contains both a copy of the original string and a
+;;; case-folded version of the original string along with the value.
+;;; All of these value nodes are stored in a array (pointed at by the
+;;; VALUE-NODES slot of the STRING-TABLE structure) and sorted by the
+;;; FOLDED slot in the VALUE-NODE structure so that a binary search may
+;;; be used to quickly find existing strings.
+;;;
+
+
+;;;; Structure Definitions
+
+(defparameter initial-string-table-size 20
+  "Initial size of string table array for value nodes.")
+(defparameter initial-word-table-size 10
+  "Inital size of each word table array for each tree node.")
+
+(defstruct (string-table
+	    (:constructor %make-string-table (separator))
+	    (:print-function print-string-table))
+  "This structure is used to implement the Hemlock string-table type."
+  ;; Character used to 
+  (separator #\Space :type string-char)	   ; character used for word separator
+  (num-nodes 0 :type fixnum)		   ; number of nodes in string table
+  (value-nodes (make-array initial-string-table-size)) ; value node array
+  (first-word-table (make-word-table)))	   ; pointer to first WORD-TABLE
+
+(defun print-string-table (table stream depth)
+  (declare (ignore table depth))
+  (format stream "#<String Table>"))
+
+(defun make-string-table (&key (separator #\Space) initial-contents)
+  "Creates and returns a Hemlock string-table.  If Intitial-Contents is
+  supplied in the form of an A-list of string-value pairs, these pairs
+  will be used to initialize the table.  If Separator, which must be a
+  string-char, is specified then it will be used to distinguish word
+  boundaries."
+  (let ((table (%make-string-table separator)))
+    (dolist (x initial-contents)
+      (setf (getstring (car x) table) (cdr x)))
+    table))
+
+
+(defstruct (word-table
+	    (:print-function print-word-table))
+  "This structure is a word-table which is part of a Hemlock string-table."
+  (num-words 0 :type fixnum)		   ; Number of words
+  (words (make-array initial-word-table-size))) ; Array of WORD-ENTRY's
+
+(defun print-word-table (table stream depth)
+  (declare (ignore table depth))
+  (format stream "#<Word Table>"))
+
+
+(defstruct (word-entry
+	    (:constructor make-word-entry (folded))
+	    (:print-function print-word-entry))
+  "This structure is an entry in a word table which is part of a Hemlock
+  string-table."
+  next-table				   ; Pointer to next WORD-TABLE
+  folded				   ; Downcased word
+  value-node)				   ; Pointer to value node or NIL
+
+(defun print-word-entry (entry stream depth)
+  (declare (ignore depth))
+  (format stream "#<Word Table Entry: \"~A\">" (word-entry-folded entry)))
+
+
+(defstruct (value-node
+	    (:constructor make-value-node (proper folded value))
+	    (:print-function print-value-node))
+  "This structure is a node containing a value in a Hemlock string-table."
+  folded				   ; Downcased copy of string
+  proper				   ; Proper copy of string entry
+  value)				   ; Value of entry
+
+(defun print-value-node (node stream depth)
+  (declare (ignore depth))
+  (format stream "<Value Node \"~A\">" (value-node-proper node)))
+
+
+;;;; Bi-SvPosition, String-Compare, String-Compare*
+
+;;; Much like the CL function POSITION; however, this is a fast binary
+;;; search for simple vectors.  Vector must be a simple vector and Test
+;;; must be a function which returns either :equal, :less, or :greater.
+;;; (The vector must be sorted from lowest index to highest index by the
+;;; Test function.)  Two values are returned: the first is the position
+;;; Item was found or if it was not found, where it should be inserted;
+;;; the second is a boolean flag indicating whether or not Item was
+;;; found.
+;;; 
+(defun bi-svposition (item vector test &key (start 0) end key)
+  (declare (simple-vector vector) (fixnum start))
+  (let ((low start)
+	(high (if end end (length vector)))
+	(mid 0))
+    (declare (fixnum low high mid))
+    (loop
+      (when (< high low) (return (values low nil)))
+      (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
+      (let* ((array-item (svref vector mid))
+	     (test-item (if key (funcall key array-item) array-item)))
+	(ecase (funcall test item test-item)
+	  (:equal (return (values mid t)))
+	  (:less (setf high (1- mid)))
+	  (:greater (setf low (1+ mid))))))))
+
+;;; A simple-string comparison appropriate for use with BI-SVPOSITION.
+;;; 
+(defun string-compare (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (declare (simple-string s1 s2) (fixnum start1 start2))
+  (let* ((end1 (or end1 (length s1)))
+	 (end2 (or end2 (length s2)))
+	 (pos1 (string/= s1 s2
+			 :start1 start1 :end1 end1 :start2 start2 :end2 end2)))
+    (if (null pos1)
+	:equal
+	(let ((pos2 (+ (the fixnum pos1) (- start2 start1))))
+	  (declare (fixnum pos2))
+	  (cond ((= pos1 (the fixnum end1)) :less)
+		((= pos2 (the fixnum end2)) :greater)
+		((char< (schar s1 (the fixnum pos1)) (schar s2 pos2)) :less)
+		(t :greater))))))
+
+;;; Macro to return a closure to call STRING-COMPARE with the given
+;;; keys.
+;;; 
+(defmacro string-compare* (&rest keys)
+  `#'(lambda (x y) (string-compare x y ,@keys)))
+
+
+;;;; Insert-Element, Nconcf
+
+(eval-when (compile eval)
+
+;;; Insert-Element is a macro which encapsulates the hairiness of
+;;; inserting an element into a simple vector.  Vector should be a
+;;; simple vector with Num elements (which may be less than or equal to
+;;; the length of the vector) and Element is the element to insert at
+;;; Pos.  The optional argument Grow-Factor may be specified to control
+;;; the new size of the array if a new vector is necessary.  The result
+;;; of INSERT-ELEMENT must be used as a new vector may be created.
+;;; (Note that the arguments should probably be lexicals since some of
+;;; them are evaluated more than once.)
+;;; 
+(defmacro insert-element (vector pos element num &optional (grow-factor 2))
+  `(let ((new-num (1+ ,num))
+	 (max (length ,vector)))
+     (declare (fixnum new-num max))
+     (cond ((= ,num max)
+	    ;; grow the vector
+	    (let ((new (make-array (truncate (* max ,grow-factor)))))
+	      (declare (simple-vector new))
+	      ;; Blt the new buggers into place leaving a space for
+	      ;; the new element
+	      (replace new ,vector :end1 ,pos :end2 ,pos)
+	      (replace new ,vector :start1 (1+ ,pos) :end1 new-num
+		       :start2 ,pos :end2 ,num)
+	      (setf (svref new ,pos) ,element)
+	      new))
+	   (t
+	    ;; move the buggers down a slot
+	    (replace ,vector ,vector :start1 (1+ ,pos) :start2 ,pos)
+	    (setf (svref ,vector ,pos) ,element)
+	    ,vector)))))
+
+(define-modify-macro nconcf (&rest args) nconc)
+
+) ; eval-when
+
+
+;;;; With-Folded-String, Do-Words
+
+;;; With-Folded-String is a macro which deals with strings from the
+;;; user.  First, if the original string is not a simple string then it
+;;; is coerced to one.  Next, the string is trimmed using the separator
+;;; character and all separators between words are collapsed to a single
+;;; separator.  The word boundaries are pushed on to a list so that the
+;;; Do-Words macro can be called anywhere within the dynamic extent of a
+;;; With-Folded-String to ``do'' over the words.
+
+(defvar *string-buffer-size* 128)
+(defvar *string-buffer* (make-string *string-buffer-size*))
+(proclaim '(simple-string *string-buffer*))
+
+(defvar *separator-positions* nil)
+
+(eval-when (compile eval)
+
+(defmacro do-words ((start-var end-var) &body (body decls))
+  (let ((sep-pos (gensym)))
+    `(dolist (,sep-pos *separator-positions*)
+       (let ((,start-var (car ,sep-pos))
+	     (,end-var (cdr ,sep-pos)))
+	 ,@decls
+	 ,@body))))
+
+(defmacro with-folded-string ((str-var len-var orig-str separator)
+			      &body (body decls))
+  `(let ((,str-var *string-buffer*))
+     (declare (simple-string ,str-var))
+     ;; make the string simple if it isn't already
+     (unless (simple-string-p ,orig-str)
+       (setq ,orig-str (coerce ,orig-str 'simple-string)))
+     ;; munge it into *string-buffer* and do the body
+     (let ((,len-var (with-folded-munge-string ,orig-str ,separator)))
+       ,@decls
+       ,@body)))
+
+) ; eval-when
+
+(defun with-folded-munge-string (str separator)
+  (declare (simple-string str) (string-char separator))
+  (let ((str-len (length str))
+	(sep-pos nil)
+	(buf-pos 0))
+    ;; Make sure we have enough room to blt the string into place.
+    (when (> str-len *string-buffer-size*)
+      (setq *string-buffer-size* (* str-len 2))
+      (setq *string-buffer* (make-string *string-buffer-size*)))
+    ;; Bash the spaces out of the string remembering where the words are.
+    (let ((start-pos (position separator str :test-not #'char=)))
+      (when start-pos
+	(loop
+	  (let* ((end-pos (position separator str
+				    :start start-pos :test #'char=))
+		 (next-start-pos (and end-pos (position separator str
+							:start end-pos
+							:test-not #'char=)))
+		 (word-len (- (or end-pos str-len) start-pos))
+		 (new-buf-pos (+ buf-pos word-len)))
+	    (replace *string-buffer* str
+		     :start1 buf-pos :start2 start-pos :end2 end-pos)
+	    (push (cons buf-pos new-buf-pos) sep-pos)
+	    (setf buf-pos new-buf-pos)
+	    (when (or (null end-pos) (null next-start-pos))
+	      (return))
+	    (setf start-pos next-start-pos)
+	    (setf (schar *string-buffer* buf-pos) separator)
+	    (incf buf-pos)))))
+    (nstring-downcase *string-buffer* :end buf-pos)
+    (setf *separator-positions* (nreverse sep-pos))
+    buf-pos))
+
+
+;;;; Getstring, Setf Method for Getstring
+
+(defun getstring (string string-table)
+  "Looks up String in String-Table.  Returns two values: the first is
+  the value of String or NIL if it does not exist; the second is a
+  boolean flag indicating whether or not String was found in
+  String-Table."
+  (with-folded-string (folded len string (string-table-separator string-table))
+    (let ((nodes (string-table-value-nodes string-table))
+	  (num-nodes (string-table-num-nodes string-table)))
+      (declare (simple-vector nodes) (fixnum num-nodes))
+      (multiple-value-bind
+	  (pos found-p)
+	  (bi-svposition folded nodes (string-compare* :end1 len)
+			 :end (1- num-nodes) :key #'value-node-folded)
+	(if found-p
+	    (values (value-node-value (svref nodes pos)) t)
+	    (values nil nil))))))
+
+(defun %set-string-table (string table value)
+  "Sets the value of String in Table to Value.  If necessary, creates
+  a new entry in the string table."
+  (with-folded-string (folded len string (string-table-separator table))
+    (when (zerop len)
+      (error "An empty string cannot be inserted into a string-table."))
+    (let ((nodes (string-table-value-nodes table))
+	  (num-nodes (string-table-num-nodes table)))
+      (declare (simple-string folded) (simple-vector nodes) (fixnum num-nodes))
+      (multiple-value-bind
+	  (pos found-p)
+	  (bi-svposition folded nodes (string-compare* :end1 len)
+			 :end (1- num-nodes) :key #'value-node-folded)
+	(cond (found-p
+ 	       (setf (value-node-value (svref nodes pos)) value))
+	      (t
+	       ;; Note that a separator collapsed copy of string is NOT
+	       ;; used here ...
+	       ;; 
+	       (let ((node (make-value-node string (subseq folded 0 len) value))
+		     (word-table (string-table-first-word-table table)))
+		 ;; put in the value nodes array
+		 (setf (string-table-value-nodes table)
+		       (insert-element nodes pos node num-nodes))
+		 (incf (string-table-num-nodes table))
+		 ;; insert it into the word tree
+		 (%set-insert-words folded word-table node))))))
+    value))
+
+(defun %set-insert-words (folded first-word-table value-node)
+  (declare (simple-string folded))
+  (let ((word-table first-word-table)
+	(entry nil))
+    (do-words (word-start word-end)
+      (let ((word-array (word-table-words word-table))
+	    (num-words (word-table-num-words word-table)))
+	(declare (simple-vector word-array) (fixnum num-words))
+	;; find the entry or create a new one and insert it
+	(multiple-value-bind
+	    (pos found-p)
+	    (bi-svposition folded word-array
+			   (string-compare* :start1 word-start :end1 word-end)
+			   :end (1- num-words) :key #'word-entry-folded)
+	  (declare (fixnum pos))
+	  (cond (found-p
+		 (setf entry (svref word-array pos)))
+		(t
+		 (setf entry (make-word-entry
+			      (subseq folded word-start word-end)))
+		 (setf (word-table-words word-table)
+		       (insert-element word-array pos entry num-words))
+		 (incf (word-table-num-words word-table)))))
+	(let ((next-table (word-entry-next-table entry)))
+	  (unless next-table
+	    (setf next-table (make-word-table))
+	    (setf (word-entry-next-table entry) next-table))
+	  (setf word-table next-table))))
+    (setf (word-entry-value-node entry) value-node)))
+
+
+;;;; Find-Bound-Entries
+
+(defun find-bound-entries (word-entries)
+  (let ((res nil))
+    (dolist (entry word-entries)
+      (nconcf res (sub-find-bound-entries entry)))
+    res))
+
+(defun sub-find-bound-entries (entry)
+  (let ((bound-entries nil))
+    (when (word-entry-value-node entry) (push entry bound-entries))
+    (let ((next-table (word-entry-next-table entry)))
+      (when next-table
+	(let ((word-array (word-table-words next-table))
+	      (num-words (word-table-num-words next-table)))
+	  (declare (simple-vector word-array) (fixnum num-words))
+	  (dotimes (i num-words)
+	    (declare (fixnum i))
+	    (nconcf bound-entries
+		    (sub-find-bound-entries (svref word-array i)))))))
+    bound-entries))
+
+
+;;;; Find-Ambiguous
+
+(defun find-ambiguous (string string-table)
+  "Returns a list, in alphabetical order, of all the strings in String-Table
+  which String matches."
+  (with-folded-string (folded len string (string-table-separator string-table))
+    (find-ambiguous* folded len string-table)))
+
+(defun find-ambiguous* (folded len table)
+  (let ((word-table (string-table-first-word-table table))
+	(word-entries nil))
+    (cond ((zerop len)
+	   (setf word-entries (find-ambiguous-entries "" 0 0 word-table)))
+	  (t
+	   (let ((word-tables (list word-table)))
+	     (do-words (start end)
+	       (setf word-entries nil)
+	       (dolist (wt word-tables)
+		 (nconcf word-entries
+			 (find-ambiguous-entries folded start end wt)))
+	       (unless word-entries (return))
+	       (let ((next-word-tables nil))
+		 (dolist (entry word-entries)
+		   (let ((next-word-table (word-entry-next-table entry)))
+		     (when next-word-table
+		       (push next-word-table next-word-tables))))
+		 (unless next-word-tables (return))
+		 (setf word-tables (nreverse next-word-tables)))))))
+    (let ((bound-entries (find-bound-entries word-entries))
+	  (res nil))
+      (dolist (be bound-entries)
+	(push (value-node-proper (word-entry-value-node be)) res))
+      (nreverse res))))
+
+(defun find-ambiguous-entries (folded start end word-table)
+  (let ((word-array (word-table-words word-table))
+	(num-words (word-table-num-words word-table))
+	(res nil))
+    (declare (simple-vector word-array) (fixnum num-words))
+    (unless (zerop num-words)
+      (multiple-value-bind
+	  (pos found-p)
+	  (bi-svposition folded word-array
+			 (string-compare* :start1 start :end1 end)
+			 :end (1- num-words) :key #'word-entry-folded)
+	(declare (ignore found-p))
+	;;
+	;; Find last ambiguous string, checking for the end of the table.
+	(do ((i pos (1+ i)))
+	    ((= i num-words))
+	  (declare (fixnum i))
+	  (let* ((entry (svref word-array i))
+		 (str (word-entry-folded entry))
+		 (str-len (length str))
+		 (index (string/= folded str :start1 start :end1 end
+				  :end2 str-len)))
+	    (declare (simple-string str) (fixnum str-len))
+	    (when (and index (/= index end)) (return nil))
+	    (push entry res)))
+	(setf res (nreverse res))
+	;;
+	;; Scan back to the first string, checking for the beginning.
+	(do ((i (1- pos) (1- i)))
+	    ((minusp i))
+	  (declare (fixnum i))
+	  (let* ((entry (svref word-array i))
+		 (str (word-entry-folded entry))
+		 (str-len (length str))
+		 (index (string/= folded str :start1 start :end1 end
+				  :end2 str-len)))
+	    (declare (simple-string str) (fixnum str-len))
+	    (when (and index (/= index end)) (return nil))
+	    (push entry res)))))
+    res))
+
+
+;;;; Find-Containing
+
+(defun find-containing (string string-table)
+  "Return a list in alphabetical order of all the strings in Table which 
+  contain String as a substring."
+  (with-folded-string (folded len string (string-table-separator string-table))
+    (declare (ignore len))
+    (let ((word-table (string-table-first-word-table string-table))
+	  (words nil))
+      ;; cons up a list of the words
+      (do-words (start end)
+	(push (subseq folded start end) words))
+      (setf words (nreverse words))
+      (let ((entries (sub-find-containing words word-table))
+	    (res nil))
+	(dolist (e entries)
+	  (push (value-node-proper (word-entry-value-node e)) res))
+	(nreverse res)))))
+
+(defun sub-find-containing (words word-table)
+  (let ((res nil)
+	(word-array (word-table-words word-table))
+	(num-words (word-table-num-words word-table)))
+    (declare (simple-vector word-array) (fixnum num-words))
+    (dotimes (i num-words)
+      (declare (fixnum i))
+      (let* ((entry (svref word-array i))
+	     (word (word-entry-folded entry))
+	     (found (find word words
+			  :test #'(lambda (y x)
+				    (let ((lx (length x))
+					  (ly (length y)))
+				      (and (<= lx ly)
+					   (string= x y :end2 lx))))))
+	     (rest-words (if found
+			     (remove found words :test #'eq :count 1)
+			     words)))
+	(declare (simple-string word))
+	(cond (rest-words
+	       (let ((next-table (word-entry-next-table entry)))
+		 (when next-table
+		   (nconcf res (sub-find-containing rest-words next-table)))))
+	      (t
+	       (nconcf res (sub-find-bound-entries entry))))))
+    res))
+
+
+;;;; Complete-String
+
+(defvar *complete-string-buffer-size* 128)
+(defvar *complete-string-buffer* (make-string *complete-string-buffer-size*))
+(proclaim '(simple-string *complete-string-buffer*))
+
+(defun complete-string (string tables)
+  "Attempts to complete the string String against the string tables in the
+   list Tables.  Tables must all use the same separator character.  See the
+   manual for details on return values."
+  (let ((separator (string-table-separator (car tables))))
+    #|(when (member separator (cdr tables)
+		  :key #'string-table-separator :test-not #'char=)
+      (error "All tables must have the same separator."))|#
+    (with-folded-string (folded len string separator)
+      (let ((strings nil))
+	(dolist (table tables)
+	  (nconcf strings (find-ambiguous* folded len table)))
+	;; pick off easy case
+	(when (null strings)
+	  (return-from complete-string (values nil :none nil nil nil)))
+	;; grow complete-string buffer if necessary
+	(let ((size-needed (1+ len)))
+	  (when (> size-needed *complete-string-buffer-size*)
+	    (let* ((new-size (* size-needed 2))
+		   (new-buffer (make-string new-size)))
+	      (setf *complete-string-buffer* new-buffer)
+	      (setf *complete-string-buffer-size* new-size))))
+	(multiple-value-bind
+	    (str ambig-pos unique-p)
+	    (find-longest-completion strings separator)
+	  (multiple-value-bind (value found-p) (find-values str tables)
+	    (let ((field-pos (compute-field-pos string str separator)))
+	      (cond ((not found-p)
+		     (values str :ambiguous nil field-pos ambig-pos))
+		    (unique-p
+		     (values str :unique value field-pos nil))
+		    (t
+		     (values str :complete value field-pos ambig-pos))))))))))
+
+(defun find-values (string tables)
+  (dolist (table tables)
+    (multiple-value-bind (value found-p) (getstring string table)
+      (when found-p
+	(return-from find-values (values value t)))))
+  (values nil nil))
+
+(defun compute-field-pos (given best separator)
+  (declare (simple-string given best) (string-char separator))
+  (let ((give-pos 0)
+	(best-pos 0))
+    (loop
+      (setf give-pos (position separator given :start give-pos :test #'char=))
+      (setf best-pos (position separator best :start best-pos :test #'char=))
+      (unless (and give-pos best-pos) (return best-pos))
+      (incf (the fixnum give-pos))
+      (incf (the fixnum best-pos)))))
+
+
+;;;; Find-Longest-Completion
+
+(defun find-longest-completion (strings separator)
+  (declare (string-char separator))
+  (let ((first (car strings))
+	(rest-strings (cdr strings))
+	(punt-p nil)
+	(buf-pos 0)
+	(first-start 0)
+	(first-end -1)
+	(ambig-pos nil)
+	(maybe-unique-p nil))
+    (declare (simple-string first) (fixnum buf-pos first-start))
+    ;;
+    ;; Make room to store each string's next separator index.
+    (do ((l rest-strings (cdr l)))
+	((endp l))
+      (setf (car l) (cons (car l) -1)))
+    ;;
+    ;; Compare the rest of the strings to the first one.
+    ;; It's our de facto standard for how far we can go.
+    (loop
+      (setf first-start (1+ first-end))
+      (setf first-end
+	    (position separator first :start first-start :test #'char=))
+      (unless first-end
+	(setf first-end (length first))
+	(setf punt-p t)
+	(setf maybe-unique-p t))
+      (let ((first-max first-end)
+	    (word-ambiguous-p nil))
+	(declare (fixnum first-max))
+	;;
+	;; For each string, store the separator's next index.
+	;; If there's no separator, store nil and prepare to punt.
+	;; If the string's field is not equal to the first's, shorten the max
+	;;   expectation for this field, and declare ambiguity.
+	(dolist (s rest-strings)
+	  (let* ((str (car s))
+		 (str-last-pos (cdr s))
+		 (str-start (1+ str-last-pos))
+		 (str-end (position separator str
+				    :start str-start :test #'char=))
+		 (index (string-not-equal first str
+					  :start1 first-start :end1 first-max
+					  :start2 str-start :end2 str-end)))
+	    (declare (simple-string str) (fixnum str-last-pos str-start))
+	    (setf (cdr s) str-end)
+	    (unless str-end
+	      (setf punt-p t)
+	      (setf str-end (length str)))
+	    (when index
+	      (setf word-ambiguous-p t) ; not equal for some reason
+	      (when (< index first-max)
+		(setf first-max index)))))
+	;;
+	;; Store what we matched into the result buffer and save the
+	;; ambiguous position if its the first ambiguous field.
+	(let ((length (- first-max first-start)))
+	  (declare (fixnum length))
+	  (unless (zerop length)
+	    (unless (zerop buf-pos)
+	      (setf (schar *complete-string-buffer* buf-pos) separator)
+	      (incf buf-pos))
+	    (replace *complete-string-buffer* first
+		     :start1 buf-pos :start2 first-start :end2 first-max)
+	    (incf buf-pos length))
+	  (when (and (null ambig-pos) word-ambiguous-p)
+	    (setf ambig-pos buf-pos))
+	  (when (or punt-p (zerop length)) (return)))))
+    (values
+     (subseq *complete-string-buffer* 0 buf-pos)
+     ;; If every corresponding field in each possible completion was equal,
+     ;; our result string is an initial substring of some other completion,
+     ;; so we're ambiguous at the end.
+     (or ambig-pos buf-pos)
+     (and (null ambig-pos)
+	  maybe-unique-p
+	  (every #'(lambda (x) (null (cdr x))) rest-strings)))))
+		 
+
+;;;; Clrstring
+
+(defun clrstring (string-table)
+  "Delete all the entries in String-Table."
+  (fill (the simple-vector (string-table-value-nodes string-table)) nil)
+  (setf (string-table-num-nodes string-table) 0)
+  (let ((word-table (string-table-first-word-table string-table)))
+    (fill (the simple-vector (word-table-words word-table)) nil)
+    (setf (word-table-num-words word-table) 0))
+  t)
+
+
+;;;; Delete-String
+
+(defun delete-string (string string-table)
+  (with-folded-string (folded len string (string-table-separator string-table))
+    (when (plusp len)
+      (let* ((nodes (string-table-value-nodes string-table))
+	     (num-nodes (string-table-num-nodes string-table))
+	     (end (1- num-nodes)))
+	(declare (simple-string folded) (simple-vector nodes)
+		 (fixnum num-nodes end))
+	(multiple-value-bind
+	    (pos found-p)
+	    (bi-svposition folded nodes (string-compare* :end1 len)
+			   :end end :key #'value-node-folded)
+	  (cond (found-p
+		 (replace nodes nodes
+			  :start1 pos :end1 end :start2 (1+ pos) :end2 num-nodes)
+		 (setf (svref nodes end) nil)
+		 (setf (string-table-num-nodes string-table) end)
+		 (sub-delete-string folded string-table)
+		 t)
+		(t nil)))))))
+
+(defun sub-delete-string (folded string-table)
+  (let ((next-table (string-table-first-word-table string-table))
+	(word-table nil)
+	(node nil)
+	(entry nil)
+	(level -1)
+	last-table last-table-level last-table-pos
+	last-entry last-entry-level)
+    (declare (fixnum level))
+    (do-words (start end)
+      (when node
+	(setf last-entry entry)
+	(setf last-entry-level level))
+      (setf word-table next-table)
+      (incf level)
+      (let ((word-array (word-table-words word-table))
+	    (num-words (word-table-num-words word-table)))
+	(declare (simple-vector word-array) (fixnum num-words))
+	(multiple-value-bind
+	    (pos found-p)
+	    (bi-svposition folded word-array
+			   (string-compare* :start1 start :end1 end)
+			   :end (1- num-words) :key #'word-entry-folded)
+	  (declare (fixnum pos) (ignore found-p))
+	  (setf entry (svref word-array pos))
+	  (setf next-table (word-entry-next-table entry))
+	  (setf node (word-entry-value-node entry))
+	  (when (or (null last-table) (> num-words 1))
+	    (setf last-table word-table)
+	    (setf last-table-pos pos)
+	    (setf last-table-level level)))))
+    (cond (next-table
+	   (setf (word-entry-value-node entry) nil))
+	  ((and last-entry-level
+		(>= last-entry-level last-table-level))
+	   (setf (word-entry-next-table last-entry) nil))
+	  (t
+	   (let* ((del-word-array (word-table-words last-table))
+		  (del-num-words (word-table-num-words last-table))
+		  (del-end (1- del-num-words)))
+	     (declare (simple-vector del-word-array)
+		      (fixnum del-num-words del-end))
+	     (replace del-word-array del-word-array
+		      :start1 last-table-pos :end1 del-end
+		      :start2 (1+ last-table-pos)
+		      :end2 del-num-words)
+	     (setf (svref del-word-array del-end) nil)
+	     (setf (word-table-num-words last-table) del-end))))))
diff --git a/hemlock/text.lisp b/hemlock/text.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5614724172a44b30dbe15cc938b5ead616b6ff3b
--- /dev/null
+++ b/hemlock/text.lisp
@@ -0,0 +1,569 @@
+;;; -*- Log: hemlock.log; Package: Hemlock -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles
+;;;
+;;; This file contains stuff that operates on units of texts, such as
+;;;    paragraphs, sentences, lines, and words.
+;;;
+
+(in-package "HEMLOCK")
+
+;;;; -- New Variables --
+
+(defhvar "Paragraph Delimiter Function"
+  "The function that returns whether or not the current line should break the 
+  paragraph." 
+  :value 'default-para-delim-function)
+
+;;; The standard paragraph delimiting function is DEFAULT-PARA-DELIM-FUNCTION
+(defun default-para-delim-function (mark)
+  "Return whether or not to break on this line."
+  (paragraph-delimiter-attribute-p (next-character mark)))
+
+;;;; -- Paragraph Commands --
+
+(defcommand "Forward Paragraph" (p)
+  "moves point to the end of the current (next) paragraph."
+  "moves point to the end of the current (next) paragraph."
+  (let ((point (current-point)))
+    (unless (paragraph-offset point (or p 1))
+      (buffer-end point)
+      (editor-error))))
+
+(defcommand "Backward Paragraph" (p)
+  "moves point to the start of the current (previous) paragraph."
+  "moves point to the start of the current (previous) paragraph."
+  (let ((point (current-point)))
+    (unless (paragraph-offset point (- (or p 1)))
+      (buffer-start point)
+      (editor-error))))
+
+(defcommand "Mark Paragraph" (p)
+  "Put mark and point around current or next paragraph.
+   A paragraph is delimited by a blank line, a line beginning with a
+   special character (@,\,-,',and .), or it is begun with a line with at
+   least one whitespace character starting it.  Prefixes are ignored or
+   skipped over before determining if a line starts or delimits a
+   paragraph."
+  "Put mark and point around current or next paragraph."
+  (declare (ignore p))
+  (let* ((point (current-point))
+	 (mark (copy-mark point :temporary)))
+    (if (mark-paragraph point mark)
+	(push-buffer-mark mark t)
+	(editor-error))))
+
+(defun mark-paragraph (mark1 mark2)
+  "Mark the next or current paragraph, setting mark1 to the beginning and mark2
+   to the end.  This uses \"Fill Prefix\", and mark1 is always on the first
+   line of the paragraph.  If no paragraph is found, then the marks are not
+   moved, and nil is returned."
+  (with-mark ((tmark1 mark1)
+	      (tmark2 mark2))
+    (let* ((prefix (value fill-prefix))
+	   (prefix-len (length prefix))
+	   (paragraphp (paragraph-offset tmark2 1)))
+      (when (or paragraphp
+		(and (last-line-p tmark2)
+		     (end-line-p tmark2)
+		     (not (blank-line-p (mark-line tmark2)))))
+	(mark-before (move-mark tmark1 tmark2))
+	(%fill-paragraph-start tmark1 prefix prefix-len)
+	(move-mark mark1 tmark1)
+	(move-mark mark2 tmark2)))))
+
+
+
+(eval-when (compile eval)
+
+;;;      %MARK-TO-PARAGRAPH moves mark to next immediate (current)
+;;; paragraph in the specified direction.  Nil is returned when no
+;;; paragraph is found.  NOTE: the order of the arguments to OR within the
+;;; first branch of the COND must be as it is, and mark must be at the
+;;; beginning of the line it is on.
+(defmacro %mark-to-paragraph (mark prefix prefix-length
+				   &optional (direction :forward))
+  `(do ((skip-prefix-p)
+	(paragraph-delim-function (value paragraph-delimiter-function)))
+       (nil)
+     (setf skip-prefix-p
+	   (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
+     (if skip-prefix-p (character-offset ,mark ,prefix-length))
+     (let ((next-char (next-character ,mark)))
+       (cond ((and (not (blank-after-p ,mark))
+		   (or (whitespace-attribute-p next-char)
+		       (not (funcall paragraph-delim-function ,mark))))
+	      (return (if skip-prefix-p (line-start ,mark) ,mark)))
+	     (,(if (eq direction :forward)
+		   `(last-line-p ,mark)
+		   `(first-line-p ,mark))
+	      (if skip-prefix-p (line-start ,mark))
+	      (return nil)))
+       (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0))))
+
+
+;;;      %PARAGRAPH-OFFSET-AUX is the inner loop of PARAGRAPH-OFFSET.  It
+;;; moves over a paragraph to find the beginning or end depending on
+;;; direction.  Prefixes on a line are ignored or skipped over before it
+;;; is determined if the line is a paragraph boundary.
+(defmacro %paragraph-offset-aux (mark prefix prefix-length
+				       &optional (direction :forward))
+  `(do ((paragraph-delim-function (value paragraph-delimiter-function))
+	(skip-prefix-p))
+       (nil)
+     (setf skip-prefix-p
+	   (and ,prefix (%line-has-prefix-p ,mark ,prefix ,prefix-length)))
+     (if skip-prefix-p (character-offset ,mark ,prefix-length))
+     (cond ((or (blank-after-p ,mark)
+		(funcall paragraph-delim-function ,mark))
+	    (return (line-start ,mark)))
+	   (,(if (eq direction :forward)
+		 `(last-line-p ,mark)
+		 `(first-line-p ,mark))
+	    (return ,(if (eq direction :forward)
+			 `(line-end ,mark)
+			 `(line-start ,mark)))))
+     (line-offset ,mark ,(if (eq direction :forward) 1 -1) 0)))
+
+); (eval-when (compile eval)
+
+
+
+;;;      PARAGRAPH-OFFSET takes a mark and a number of paragraphs to
+;;; move over.  If the specified number of paragraphs does not exist in
+;;; the direction indicated by the sign of number, then nil is
+;;; returned, otherwise the mark is returned.
+
+(defun paragraph-offset (mark number &optional (prefix (value fill-prefix)))
+  "moves mark past the specified number of paragraph, forward if the number
+   is positive and vice versa.  If the specified number of paragraphs do
+   not exist in the direction indicated by the sign of the number, then nil
+   is returned, otherwise the mark is returned."
+  (if (plusp number)
+      (%paragraph-offset-forward mark number prefix)
+      (%paragraph-offset-backward mark number prefix)))
+
+
+
+;;;      %PARAGRAPH-OFFSET-FORWARD moves mark forward over number
+;;; paragraphs.  The first branch of the COND is necessary for the side
+;;; effect provided by LINE-OFFSET.  If %MARK-TO-PARAGRAPH left tmark at
+;;; the beginning of some paragraph %PARAGRAPH-OFFSET-AUX will think it has
+;;; moved mark past a paragraph, so we make sure tmark is inside the
+;;; paragraph or after it.
+
+(defun %paragraph-offset-forward (mark number prefix)
+  (do* ((n number (1- n))
+	(tmark (line-start (copy-mark mark :temporary)))
+	(prefix-length (length prefix))
+	(paragraphp (%mark-to-paragraph tmark prefix prefix-length)
+		    (if (plusp n)
+			(%mark-to-paragraph tmark prefix prefix-length))))
+       ((zerop n) (move-mark mark tmark))
+    (cond ((and paragraphp (not (line-offset tmark 1))) ; 
+	   (if (or (> n 1) (and (last-line-p mark) (end-line-p mark)))
+	       (return nil))
+	   (return (line-end (move-mark mark tmark))))
+	  (paragraphp (%paragraph-offset-aux tmark prefix prefix-length))
+	  (t (return nil)))))
+  
+
+
+(defun %paragraph-offset-backward (mark number prefix)
+  (with-mark ((tmark1 mark)
+	      (tmark2 mark))
+    (do* ((n (abs number) (1- n))
+	  (prefix-length (length prefix))
+	  (paragraphp (%para-offset-back-find-para tmark1 prefix
+						   prefix-length mark)
+		      (if (plusp n)
+			  (%para-offset-back-find-para tmark1 prefix
+						       prefix-length tmark2))))
+	 ((zerop n) (move-mark mark tmark1))
+      (cond ((and paragraphp (first-line-p tmark1))
+	     (if (and (first-line-p mark) (start-line-p mark))
+		 (return nil)
+		 (if (> n 1) (return nil))))
+	    (paragraphp
+	     (%paragraph-offset-aux tmark1 prefix prefix-length :backward)
+	     (%para-offset-back-place-mark tmark1 prefix prefix-length))
+	    (t (return nil))))))
+
+
+
+;;;      %PARA-OFFSET-BACK-PLACE-MARK makes sure that mark is in
+;;; the right place when it has been moved backward over a paragraph.  The
+;;; "right place" is defined to be where EMACS leaves it for a given
+;;; situation or where it is necessary to ensure the mark's skipping
+;;; backward over another paragraph if PARAGRAPH-OFFSET was given an
+;;; argument with a greater magnitude than one.  I believe these two
+;;; constraints are equivalent; that is, neither changes what the other
+;;; would dictate.
+
+(defun %para-offset-back-place-mark (mark prefix prefix-length)
+  (skip-prefix-if-here mark prefix prefix-length)
+  (cond ((text-blank-line-p mark) (line-start mark))
+	((not (first-line-p mark))
+	 (line-offset mark -1 0)
+	 (skip-prefix-if-here mark prefix prefix-length)
+	 (if (text-blank-line-p mark)
+	     (line-start mark)
+	     (line-offset mark 1 0)))))
+
+
+
+(defun %para-offset-back-find-para (mark1 prefix prefix-length mark2)
+  (move-mark mark2 mark1)
+  (line-start mark1)
+  (let ((para-p (%mark-to-paragraph mark1 prefix prefix-length :backward)))
+    (cond ((and para-p (same-line-p mark1 mark2))
+	   (skip-prefix-if-here mark1 prefix prefix-length)
+	   (find-attribute mark1 :whitespace #'zerop)
+	   (cond ((mark<= mark2 mark1)
+		  (line-offset mark1 -1 0)
+		  (%mark-to-paragraph mark1 prefix prefix-length :backward))
+		 (t (line-start mark1))))
+	  (t para-p))))
+
+
+
+;;;; -- Sentence Commands --
+
+(defcommand "Forward Sentence" (p)
+  "Moves forward one sentence or the specified number.
+   A sentence terminates with a .,?, or ! followed by any number of closing
+   delimiters (such as \",',),],>,|) which are followed by either two
+   spaces or a newline."
+  "Moves forward one sentence or the specified number."
+  (declare (ignore p))
+  (unless (sentence-offset (current-point) (or p 1))
+    (editor-error)))
+
+
+
+(defcommand "Backward Sentence" (p)
+  "Moves backward one sentence or the specified number.
+   A sentence terminates with a .,?, or ! followed by any number of closing
+   delimiters (such as \",',),],>,|) which are followed by either two
+   spaces or a newline."
+  "Moves backward one sentence or the specified number."
+  (declare (ignore p))
+   (unless (sentence-offset (current-point) (- (or p 1)))
+    (editor-error)))
+
+
+
+(defcommand "Mark Sentence" (p)
+  "Put mark and point around current or next sentence.
+   A sentence terminates with a .,?, or ! followed by any number of closing
+   delimiters (such as \",',),],>,|) which are followed by either two
+   spaces or a newline."
+  "Put mark and point around current or next sentence."
+  (declare (ignore p))
+  (let* ((point (current-point))
+	 (end (copy-mark point :temporary)))
+    (unless (sentence-offset end 1) (editor-error))
+    (move-mark point end)
+    (sentence-offset point -1)
+    (push-buffer-mark end t)))
+
+
+(defcommand "Forward Kill Sentence" (p)
+  "Kill forward to end of sentence."
+  "Kill forward to end of sentence."
+  (let ((point (current-point))
+	(offset (or p 1)))
+    (with-mark ((mark point))
+      (if (sentence-offset mark offset)
+	  (if (plusp offset)
+	      (kill-region (region point mark) :kill-forward)
+	      (kill-region (region mark point) :kill-backward))
+	  (editor-error)))))
+
+(defcommand "Backward Kill Sentence" (p)
+  "Kill backward to beginning of sentence."
+  "Kill backward to beginning of sentence."
+  (forward-kill-sentence-command (- (or p 1))))
+
+;;;      SENTENCE-OFFSET-END-P returns true if mark is at the end of a
+;;; sentence.  If that the end of a sentence, it leaves mark at an
+;;; appropriate position with respect to the sentence-terminator character,
+;;; the beginning of the next sentence, and direction.  See the commands
+;;; "Forward Sentence" and "Backward Sentence" for a definition of a sentence.
+
+(eval-when (compile eval)
+(defmacro sentence-offset-end-p (mark &optional (direction :forward))
+  `(let ((start (mark-charpos ,mark)))
+     (do ()
+	 ((not (sentence-closing-char-attribute-p (next-character ,mark))))
+       (mark-after ,mark))
+     (cond ((char= (next-character ,mark) #\newline)
+	    ,(if (eq direction :forward) mark `(mark-after ,mark)))
+	   ((and (char= (next-character ,mark) #\space)
+		 (or (char= (next-character (mark-after ,mark)) #\space)
+		     (char= (next-character ,mark) #\newline)))
+	    ,(if (eq direction :forward)
+		 `(mark-before ,mark)
+		 `(mark-after ,mark)))
+	   (t (move-to-position ,mark start)
+	      nil))))
+); (eval-when (compile eval)
+
+
+
+;;;      SENTENCE-OFFSET-FIND-END moves in the direction direction stopping
+;;; at sentence terminating characters until either there are not any more
+;;; such characters or one is found that defines the end of a sentence.
+;;; When looking backwards, we may be at the beginning of some sentence,
+;;; and if we are, then we must move mark before the sentence terminator;
+;;; otherwise, we would find the immediately preceding sentence terminator
+;;; and end up right where we started.
+
+(eval-when (compile eval)
+(defmacro sentence-offset-find-end (mark &optional (direction :forward))
+  `(progn
+    ,@(if (eq direction :backward)
+	  `((reverse-find-attribute ,mark :whitespace #'zerop)
+	    (when (fill-region-insert-two-spaces-p ,mark)
+	      (reverse-find-attribute ,mark :sentence-terminator)
+	      (mark-before ,mark))))
+    (do ((foundp) (endp)) (nil)
+      (setf foundp ,(if (eq direction :forward)
+			`(find-attribute ,mark :sentence-terminator)
+			`(reverse-find-attribute ,mark :sentence-terminator)))
+      (setf endp ,(if (eq direction :forward)
+		      `(if foundp (progn (mark-after ,mark)
+					 (sentence-offset-end-p ,mark)))
+		      `(if foundp (sentence-offset-end-p ,mark :backward))))
+      (if endp (return ,mark))
+      ,(if (eq direction :forward)
+	   `(unless foundp (return nil))
+	   `(if foundp (mark-before ,mark) (return nil))))))
+); (eval-when (compile eval)
+
+
+
+;;;      SENTENCE-OFFSET takes a mark and a number of paragraphs to move
+;;; over.  If the specified number of paragraphs does not exist in
+;;; the direction indicated by the sign of the number, then nil is returned,
+;;; otherwise the mark is returned.
+
+(defun sentence-offset (mark number)
+  (if (plusp number)
+      (sentence-offset-forward mark number)
+      (sentence-offset-backward mark (abs number))))
+
+
+
+;;;      SENTENCE-OFFSET-FORWARD tries to move mark forward over number
+;;; sentences.  If it can, then mark is moved and returned; otherwise, mark
+;;; remains unmoved, and nil is returned.  When tmark2 is moved to the end
+;;; of a new paragraph, we reverse find for a non-whitespace character to
+;;; bring tmark2 to the end of the previous line.  This is necessary to
+;;; detect if tmark1 is at the end of the paragraph, in which case tmark2
+;;; wants to be moved over another paragraph.
+
+(defun sentence-offset-forward (mark number)
+  (with-mark ((tmark1 mark)
+	      (tmark2 mark))
+    (do ((n number (1- n))
+	 (found-paragraph-p))
+	((zerop n) (move-mark mark tmark1))
+      (when (and (mark<= tmark2 tmark1)
+		 (setf found-paragraph-p (paragraph-offset tmark2 1)))
+	(reverse-find-attribute tmark2 :whitespace #'zerop)
+	(when (mark>= tmark1 tmark2)
+	  (line-offset tmark2 1 0)
+	  (setf found-paragraph-p (paragraph-offset tmark2 1))
+	  (reverse-find-attribute tmark2 :whitespace #'zerop)))
+      (cond ((sentence-offset-find-end tmark1)
+	     (if (mark> tmark1 tmark2) (move-mark tmark1 tmark2)))
+	    (found-paragraph-p (move-mark tmark1 tmark2))
+	    (t (return nil))))))
+
+
+
+(defun sentence-offset-backward (mark number)
+  (with-mark ((tmark1 mark)
+	      (tmark2 mark)
+	      (tmark3 mark))
+    (do* ((n number (1- n))
+	  (prefix (value fill-prefix))
+	  (prefix-length (length prefix))
+	  (found-paragraph-p
+	   (cond ((paragraph-offset tmark2 -1)
+		  (sent-back-place-para-start tmark2 prefix prefix-length)
+		  t))))
+	 ((zerop n) (move-mark mark tmark1))
+      (move-mark tmark3 tmark1)
+      (when (and (sent-back-para-start-p tmark1 tmark3 prefix prefix-length)
+		 (setf found-paragraph-p
+		       (paragraph-offset (move-mark tmark2 tmark3) -1)))
+	(paragraph-offset (move-mark tmark1 tmark2) 1)
+	(sent-back-place-para-start tmark2 prefix prefix-length))
+      (cond ((sentence-offset-find-end tmark1 :backward)
+	     (if (mark< tmark1 tmark2) (move-mark tmark1 tmark2)))
+	    (found-paragraph-p (move-mark tmark1 tmark2))
+	    (t (return nil))))))
+
+
+
+(defun sent-back-para-start-p (mark1 mark2 prefix prefix-length)
+  (skip-prefix-if-here (line-start mark2) prefix prefix-length)
+  (cond ((text-blank-line-p mark2)
+	 (line-start mark2))
+	((whitespace-attribute-p (next-character mark2))
+	 (find-attribute mark2 :whitespace #'zerop)
+	 (if (mark= mark1 mark2) (line-offset mark2 -1 0)))
+	((and (mark= mark2 mark1) (line-offset mark2 -1 0))
+	 (skip-prefix-if-here mark2 prefix prefix-length)
+	 (if (text-blank-line-p mark2)
+	     (line-start mark2)))))
+
+
+
+(defun sent-back-place-para-start (mark2 prefix prefix-length)
+  (skip-prefix-if-here mark2 prefix prefix-length)
+  (when (text-blank-line-p mark2)
+    (line-offset mark2 1 0)
+    (skip-prefix-if-here mark2 prefix prefix-length))
+  (find-attribute mark2 :whitespace #'zerop))
+
+
+
+;;;; -- Transposing Stuff --
+
+(defcommand "Transpose Words" (p)
+  "Transpose the words before and after the cursor.
+   With a positive argument it transposes the words before and after the
+   cursor, moves right, and repeats the specified number of times,
+   dragging the word to the left of the cursor right.  With a negative
+   argument, it transposes the two words to the left of the cursor, moves
+   between them, and repeats the specified number of times, exactly undoing
+   the positive argument form."
+  "Transpose the words before and after the cursor."
+  (let ((num (or p 1))
+	(point (current-point)))
+    (with-mark ((mark point :left-inserting)
+		(start point :left-inserting))
+      (let ((mark-prev (previous-character mark))
+	    (mark-next (next-character mark)))
+	(cond ((plusp num)
+	       (let ((forwardp (word-offset point num))
+		     (backwardp (if (or (word-delimiter-attribute-p mark-next)
+					(word-delimiter-attribute-p mark-prev))
+				    (word-offset mark -1)
+				    (word-offset mark -2))))
+		 (if (and forwardp backwardp)
+		     (transpose-words-forward mark point start)
+		     (editor-error))))
+	      ((minusp num)
+	       (let ((enoughp (word-offset point (1- num))))
+		 (if (word-delimiter-attribute-p mark-prev)
+		     (reverse-find-attribute mark :word-delimiter #'zerop)
+		     (find-attribute mark :word-delimiter))
+		 (if enoughp
+		     (transpose-words-backward point mark start)
+		     (editor-error))))
+	      (t (editor-error)))))))
+
+
+(defun transpose-words-forward (mark1 end mark2)
+  (with-mark ((tmark1 mark1 :left-inserting)
+	      (tmark2 mark2 :left-inserting))
+    (find-attribute tmark1 :word-delimiter)
+    (do ((region1 (delete-and-save-region (region mark1 tmark1))))
+	((mark= tmark2 end) (ninsert-region end region1))
+      (word-offset tmark2 1)
+      (reverse-find-attribute (move-mark tmark1 tmark2) :word-delimiter)
+      (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
+      (move-mark mark1 tmark1))))
+
+
+(defun transpose-words-backward (start mark1 mark2)
+  (with-mark ((tmark1 mark1 :left-inserting)
+	      (tmark2 mark2 :left-inserting))
+    (reverse-find-attribute tmark1 :word-delimiter)
+    (move-mark mark2 mark1)
+    (do ((region1 (delete-and-save-region (region tmark1 mark1))))
+	((mark= tmark1 start) (ninsert-region start region1))
+      (word-offset tmark1 -1)
+      (find-attribute (move-mark tmark2 tmark1) :word-delimiter)
+      (ninsert-region mark1 (delete-and-save-region (region tmark1 tmark2)))
+      (move-mark mark1 tmark1))))
+
+(defcommand "Transpose Lines" (p)
+  "Transpose the current line with the line before the cursor.
+   With a positive argument it transposes the current line with the one
+   before, moves down a line, and repeats the specified number of times,
+   dragging the originally current line down.  With a negative argument, it
+   transposes the two lines to the prior to the current, moves up a line,
+   and repeats the specified number of times, exactly undoing the positive
+   argument form.  With a zero argument, it transposes the lines at point
+   and mark."
+  "Transpose the current line with the line before the cursor."
+  (let ((num (or p 1))
+	 (point (current-point)))
+    (with-mark ((mark point :left-inserting))
+      (cond ((plusp num)
+	     (if (and (line-offset mark -1 0)
+		      (line-offset point num 0))
+		 (transpose-lines mark point)
+		 (editor-error)))
+	    ((minusp num)
+	     (cond ((and (line-offset mark (1- num) 0)
+			 (line-offset point -1 0))
+		    (transpose-lines point mark)
+		    (move-mark point mark))
+		   (t (editor-error))))
+	    (t
+	     (rotatef (line-string (mark-line point))
+		      (line-string (mark-line (current-mark))))
+	     (line-start point))))))
+
+
+(defun transpose-lines (mark1 mark2)
+  (with-mark ((tmark1 mark1))
+    (line-offset tmark1 1)
+    (ninsert-region mark2 (delete-and-save-region (region mark1 tmark1)))))
+
+
+
+;;;; -- Utilities --
+
+(defun skip-prefix-if-here (mark prefix prefix-length)
+  (if (and prefix (%line-has-prefix-p mark prefix prefix-length))
+      (character-offset mark prefix-length)))
+
+
+
+(defun text-blank-line-p (mark)
+  (let ((next-char (next-character mark)))
+    (or (blank-after-p mark)
+	(and (funcall (value paragraph-delimiter-function) mark)
+	     (not (whitespace-attribute-p next-char))))))
+
+
+
+(defun whitespace-attribute-p (char)
+  (= (character-attribute :whitespace char) 1))
+
+(defun sentence-terminator-attribute-p (char)
+  (= (character-attribute :sentence-terminator char) 1))
+
+(defun sentence-closing-char-attribute-p (char)
+  (= (character-attribute :sentence-closing-char char) 1))
+
+(defun paragraph-delimiter-attribute-p (char)
+  (= (character-attribute :paragraph-delimiter char) 1))
+
+(defun word-delimiter-attribute-p (char)
+  (= (character-attribute :word-delimiter char) 1))
diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e14aab70c73c63d36fbe0d9def922b03ca628e5b
--- /dev/null
+++ b/hemlock/ts-stream.lisp
@@ -0,0 +1,283 @@
+;;; -*- Package: Hemlock; Log: hemlock.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC).
+;;; **********************************************************************
+;;;
+;;; This file implements typescript streams.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "HEMLOCK")
+
+(defconstant ts-stream-output-buffer-size 512)
+
+(defstruct (ts-stream
+	    (:include stream
+		      (in #'%ts-stream-in)
+		      (out #'%ts-stream-out)
+		      (sout #'%ts-stream-sout)
+		      (misc #'%ts-stream-misc))
+	    (:print-function %ts-stream-print)
+	    (:constructor make-ts-stream (wire typescript)))
+  wire
+  typescript
+  (output-buffer (make-string ts-stream-output-buffer-size)
+		 :type simple-string)
+  (output-buffer-index 0 :type fixnum)
+  (char-pos 0)
+  current-input
+  (input-read-index 0 :type fixnum))
+
+(defun %ts-stream-print (ts stream depth)
+  (declare (ignore ts depth))
+  (write-string "#<TS Stream>" stream))
+
+;;; TS-STREAM-ACCEPT-INPUT --- internal interface.
+;;;
+;;; This routine is called by the editor to indicate that the user has typed
+;;; more input.
+;;;
+(defun ts-stream-accept-input (remote string)
+  (let ((stream (wire:remote-object-value remote)))
+    (system:without-interrupts
+      (setf (ts-stream-current-input stream)
+	    (nconc (ts-stream-current-input stream)
+		   (list string)))
+      (setf (ts-stream-char-pos stream) 0)))
+  nil)
+
+;;; %TS-STREAM-LISTEN --- internal.
+;;;
+;;; Determine if there is any input available.  If we don't think so, process
+;;; all pending events, and look again.
+;;; 
+(defun %ts-stream-listen (stream)
+  (flet ((check ()
+		(system:without-interrupts
+		 (loop
+		   (let ((current (ts-stream-current-input stream)))
+		     (cond ((null current)
+			    (return nil))
+			   ((>= (ts-stream-input-read-index stream)
+				(length (the simple-string (car current))))
+			    (pop (ts-stream-current-input stream))
+			    (setf (ts-stream-input-read-index stream) 0))
+			   (t
+			    (return t))))))))
+    (or (check)
+	(progn
+	  (system:serve-all-events 0)
+	  (check)))))
+
+;;; WAIT-FOR-TYPESCRIPT-INPUT --- internal.
+;;;
+;;; Keep calling server until some input shows up.
+;;; 
+(defun wait-for-typescript-input (stream)
+  (unless (%ts-stream-listen stream)
+    (let ((wire (ts-stream-wire stream))
+	  (ts (ts-stream-typescript stream)))
+      (wire:remote wire
+		   (ts-buffer-ask-for-input ts))
+      (wire:wire-force-output wire)
+      (loop
+	(system:serve-all-events)
+	(when (%ts-stream-listen stream)
+	  (return))))))
+
+;;; %TS-STREAM-IN --- internal.
+;;;
+;;; The READ-CHAR stream method.
+;;; 
+(defun %ts-stream-in (stream &optional eoferr eofval)
+  (declare (ignore eoferr eofval)) ; EOF's are impossible.
+  (wait-for-typescript-input stream)
+  (system:without-interrupts
+   (prog1
+       (schar (car (ts-stream-current-input stream))
+	      (ts-stream-input-read-index stream))
+     (incf (ts-stream-input-read-index stream)))))
+
+
+
+;;; %TS-STREAM-READ-LINE --- internal.
+;;;
+;;; The READ-LINE stream method.  Note: here we take advantage of the fact that
+;;; newlines will only appear at the end of strings.
+;;; 
+(defun %ts-stream-read-line (stream eoferr eofval)
+  (declare (ignore eoferr eofval))
+  (macrolet ((next-str ()
+	       '(progn
+		  (wait-for-typescript-input stream)
+		  (system:without-interrupts
+		    (prog1
+			(if (zerop (ts-stream-input-read-index stream))
+			    (pop (ts-stream-current-input stream))
+			    (subseq (pop (ts-stream-current-input stream))
+				    (ts-stream-input-read-index stream)))
+		      (setf (ts-stream-input-read-index stream) 0))))))
+    (do ((result (next-str) (concatenate 'simple-string result (next-str))))
+	((char= (schar result (1- (length result))) #\newline)
+	 (values (subseq result 0 (1- (length result)))
+		 nil))
+      (declare (simple-string result)))))
+
+;;; %TS-STREAM-FLSBUF --- internal.
+;;;
+;;; Flush the output buffer associated with stream.
+;;; 
+(defun %ts-stream-flsbuf (stream)
+  (when (and (ts-stream-wire stream)
+	     (ts-stream-output-buffer stream)
+	     (not (zerop (ts-stream-output-buffer-index stream))))
+    (wire:remote (ts-stream-wire stream)
+      (ts-buffer-output-string (ts-stream-typescript stream)
+			       (subseq (the simple-string
+					    (ts-stream-output-buffer stream))
+				       0
+				       (ts-stream-output-buffer-index stream))))
+    (setf (ts-stream-output-buffer-index stream)
+	  0)))
+
+;;; %TS-STREAM-OUT --- internal.
+;;;
+;;; Output a single character to stream.
+;;;
+(defun %ts-stream-out (stream char)
+  (declare (string-char char))
+  (when (= (ts-stream-output-buffer-index stream)
+	   ts-stream-output-buffer-size)
+    (%ts-stream-flsbuf stream))
+  (setf (schar (ts-stream-output-buffer stream)
+	       (ts-stream-output-buffer-index stream))
+	char)
+  (incf (ts-stream-output-buffer-index stream))
+  (incf (ts-stream-char-pos stream))
+  (when (= (char-code char)
+	   (char-code #\Newline))
+    (%ts-stream-flsbuf stream)
+    (setf (ts-stream-char-pos stream) 0)
+    (wire:wire-force-output (ts-stream-wire stream)))
+  char)
+
+;;; %TS-STREAM-SOUT --- internal.
+;;;
+;;; Output a string to stream.
+;;; 
+(defun %ts-stream-sout (stream string start end)
+  (declare (simple-string string))
+  (declare (fixnum start end))
+  (let ((wire (ts-stream-wire stream))
+	(newline (position #\Newline string :start start :end end :from-end t))
+	(length (- end start)))
+    (when wire
+      (let ((index (ts-stream-output-buffer-index stream)))
+	(cond ((> (+ index length)
+		  ts-stream-output-buffer-size)
+	       (%ts-stream-flsbuf stream)
+	       (wire:remote wire
+		 (ts-buffer-output-string (ts-stream-typescript stream)
+					  (subseq string start end)))
+	       (when newline
+		 (wire:wire-force-output wire)))
+	      (t
+	       (replace (the simple-string (ts-stream-output-buffer stream))
+			string
+			:start1 index
+			:end1 (+ index length)
+			:start2 start
+			:end2 end)
+	       (incf (ts-stream-output-buffer-index stream)
+		     length)
+	       (when newline
+		 (%ts-stream-flsbuf stream)
+		 (wire:wire-force-output wire))))))
+    (setf (ts-stream-char-pos stream)
+	  (if newline
+	    (- end newline 1)
+	    (+ (ts-stream-char-pos stream)
+	       length)))))
+
+;;; %TS-STREAM-UNREAD --- internal.
+;;;
+;;; Unread a single character.
+;;; 
+(defun %ts-stream-unread (stream char)
+  (system:without-interrupts
+    (cond ((and (ts-stream-current-input stream)
+		(> (ts-stream-input-read-index stream) 0))
+	   (setf (schar (car (ts-stream-current-input stream))
+			(decf (ts-stream-input-read-index stream)))
+		 char))
+	  (t
+	   (push (string char) (ts-stream-current-input stream))
+	   (setf (ts-stream-input-read-index stream) 0)))))
+
+;;; %TS-STREAM-CLOSE --- internal.
+;;;
+;;; Can't do much, 'cause the wire is shared.
+;;; 
+(defun %ts-stream-close (stream abort)
+  (unless abort
+    (force-output stream))
+  (lisp::set-closed-flame stream))
+
+;;; %TS-STREAM-CLEAR-INPUT --- internal.
+;;;
+;;; Pass the request to the editor and clear any buffered input.
+;;;
+(defun %ts-stream-clear-input (stream)
+  (when (ts-stream-wire stream)
+    (wire:remote-value (ts-stream-wire stream)
+      (ts-buffer-clear-input (ts-stream-typescript stream))))
+  (system:without-interrupts
+    (setf (ts-stream-current-input stream) nil
+	  (ts-stream-input-read-index stream) 0)))
+
+;;; %TS-STREAM-MISC --- internal.
+;;;
+;;; The misc stream method.
+;;; 
+(defun %ts-stream-misc (stream operation &optional arg1 arg2)
+  (case operation
+    (:read-line
+     (%ts-stream-read-line stream arg1 arg2))
+    (:listen
+     (%ts-stream-listen stream))
+    (:unread
+     (%ts-stream-unread stream arg1))
+    (:close
+     (%ts-stream-close stream arg1))
+    (:clear-input
+     (%ts-stream-clear-input stream)
+     t)
+    (:finish-output
+     (when (ts-stream-wire stream)
+       (%ts-stream-flsbuf stream)
+       ;; Note: for the return value to come back,
+       ;; all pending RPCs must have completed.
+       (wire:remote-value (ts-stream-wire stream)
+	 (ts-buffer-finish-output (ts-stream-typescript stream))))
+     t)
+    (:force-output
+     (when (ts-stream-wire stream)
+       (%ts-stream-flsbuf stream)
+       (wire:wire-force-output (ts-stream-wire stream)))
+     t)
+    (:clear-output
+     (setf (ts-stream-output-buffer-index stream) 0)
+     t)
+    (:element-type
+     'char-string)
+    (:charpos
+     (ts-stream-char-pos stream))
+    (:line-length
+     (wire:remote-value (ts-stream-wire stream)
+       (ts-buffer-line-length (ts-stream-typescript stream))))))
diff --git a/hemlock/tty-disp-rt.lisp b/hemlock/tty-disp-rt.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5bd888dc41f81b391cdfe0e704be19cc7e948889
--- /dev/null
+++ b/hemlock/tty-disp-rt.lisp
@@ -0,0 +1,139 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+
+;;;; Terminal init and exit methods.
+
+(defvar *hemlock-input-handler*)
+
+(defun init-tty-device (device)
+  (setf *hemlock-input-handler*
+	(system:add-fd-handler 0 :input #'get-editor-tty-input))
+  (standard-device-init)
+  (device-write-string (tty-device-init-string device))
+  (redisplay-all))
+
+(defun exit-tty-device (device)
+  (cursor-motion device 0 (1- (tty-device-lines device)))
+  ;; Can't call the clear-to-eol method since we don't have a hunk to
+  ;; call it on, and you can't count on the bottom hunk being the echo area.
+  ;; 
+  (if (tty-device-clear-to-eol-string device)
+      (device-write-string (tty-device-clear-to-eol-string device))
+      (dotimes (i (tty-device-columns device)
+		  (cursor-motion device 0 (1- (tty-device-lines device))))
+	(tty-write-char #\space)))
+  (device-write-string (tty-device-cm-end-string device))
+  (when (device-force-output device)
+    (funcall (device-force-output device)))
+  (when *hemlock-input-handler*
+    (system:remove-fd-handler *hemlock-input-handler*)
+    (setf *hemlock-input-handler* nil))
+  (standard-device-exit))
+
+
+
+;;;; Output routines and buffering.
+
+(defconstant redisplay-output-buffer-length 256)
+
+(defvar *redisplay-output-buffer*
+  (make-string redisplay-output-buffer-length))
+(proclaim '(simple-string *redisplay-output-buffer*))
+
+(defvar *redisplay-output-buffer-index* 0)
+(proclaim '(fixnum *redisplay-output-buffer-index*))
+
+
+;;; TTY-WRITE-STRING blasts the string into the redisplay output buffer.
+;;; If the string overflows the buffer, then segments of the string are
+;;; blasted into the buffer, dumping the buffer, until the last piece of
+;;; the string is stored in the buffer.  The buffer is always dumped if
+;;; it is full, even if the last piece of the string just fills the buffer.
+;;; 
+(defun tty-write-string (string start length)
+  (declare (fixnum start length))
+  (let ((buffer-space (- redisplay-output-buffer-length
+			 *redisplay-output-buffer-index*)))
+    (declare (fixnum buffer-space))
+    (cond ((<= length buffer-space)
+	   (let ((dst-index (+ *redisplay-output-buffer-index* length)))
+	     (%primitive byte-blt string start *redisplay-output-buffer*
+			 *redisplay-output-buffer-index* dst-index)
+	     (cond ((= length buffer-space)
+		    (mach:unix-write 1 *redisplay-output-buffer* 0 
+				      redisplay-output-buffer-length)
+		    (setf *redisplay-output-buffer-index* 0))
+		   (t
+		    (setf *redisplay-output-buffer-index* dst-index)))))
+	  (t
+	   (let ((remaining (- length buffer-space)))
+	     (declare (fixnum remaining))
+	     (loop
+	      (%primitive byte-blt string start *redisplay-output-buffer*
+			  *redisplay-output-buffer-index*
+			  redisplay-output-buffer-length)
+	      (mach:unix-write 1 *redisplay-output-buffer* 0 
+				redisplay-output-buffer-length)
+	      (when (< remaining redisplay-output-buffer-length)
+		(%primitive byte-blt string (+ start buffer-space)
+			    *redisplay-output-buffer* 0 remaining)
+		(setf *redisplay-output-buffer-index* remaining)
+		(return t))
+	      (incf start buffer-space)
+	      (setf *redisplay-output-buffer-index* 0)
+	      (setf buffer-space redisplay-output-buffer-length)
+	      (decf remaining redisplay-output-buffer-length)))))))
+
+
+;;; TTY-WRITE-CHAR stores a character in the redisplay output buffer,
+;;; dumping the buffer if it becomes full.
+;;; 
+(defun tty-write-char (char)
+  (setf (schar *redisplay-output-buffer* *redisplay-output-buffer-index*)
+	char)
+  (incf *redisplay-output-buffer-index*)
+  (when (= *redisplay-output-buffer-index* redisplay-output-buffer-length)
+    (mach:unix-write 1 *redisplay-output-buffer* 0
+		     redisplay-output-buffer-length)
+    (setf *redisplay-output-buffer-index* 0)))
+
+
+;;; TTY-FORCE-OUTPUT dumps the redisplay output buffer.  This is called
+;;; out of terminal device structures in multiple places -- the device
+;;; exit method, random typeout methods, out of tty-hunk-stream methods,
+;;; after calls to REDISPLAY or REDISPLAY-ALL.
+;;; 
+(defun tty-force-output ()
+  (unless (zerop *redisplay-output-buffer-index*)
+    (mach:unix-write 1 *redisplay-output-buffer* 0
+		     *redisplay-output-buffer-index*)
+    (setf *redisplay-output-buffer-index* 0)))
+
+
+;;; TTY-FINISH-OUTPUT simply dumps output.
+;;;
+(defun tty-finish-output (device window)
+  (declare (ignore window))
+  (let ((force-output (device-force-output device)))
+    (when force-output
+      (funcall force-output))))
+
+
+
+;;;; Screen image line hacks.
+
+(defmacro replace-si-line (dst-string src-string src-start dst-start dst-end)
+  `(%primitive byte-blt ,src-string ,src-start ,dst-string ,dst-start ,dst-end))
diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..29994d9b5d44ed58e5f528ee3adf33debbb50f11
--- /dev/null
+++ b/hemlock/tty-display.lisp
@@ -0,0 +1,1102 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Written by Bill Chiles.
+;;;
+
+(in-package "HEMLOCK-INTERNALS")
+
+(export '(redisplay redisplay-all))
+
+
+
+;;;; Macros.
+
+(eval-when (compile eval)
+(defmacro tty-hunk-modeline-pos (hunk)
+  `(tty-hunk-text-height ,hunk))
+) ;eval-when
+
+
+(defvar *currently-selected-hunk* nil)
+(defvar *hunk-top-line*)
+
+(proclaim '(fixnum *hunk-top-line*))
+
+(eval-when (compile eval)
+(defmacro select-hunk (hunk)
+  `(unless (eq ,hunk *currently-selected-hunk*)
+     (setf *currently-selected-hunk* ,hunk)
+     (setf *hunk-top-line*
+	   (the fixnum
+		(1+ (the fixnum
+			 (- (the fixnum
+				 (tty-hunk-text-position ,hunk))
+			    (the fixnum
+				 (tty-hunk-text-height ,hunk)))))))))
+) ;eval-when
+
+
+;;; Screen image lines.
+;;; 
+(defstruct (si-line (:print-function print-screen-image-line)
+		    (:constructor %make-si-line (chars)))
+  chars
+  (length 0))
+
+(defun make-si-line (n)
+  (%make-si-line (make-string n)))
+
+(defun print-screen-image-line (obj str n)
+  (declare (ignore n))
+  (write-string "#<Screen Image Line \"" str)
+  (write-string (si-line-chars obj) str :end (si-line-length obj))
+  (write-string "\">" str))
+
+
+(defmacro si-line (screen-image n)
+  `(svref ,screen-image ,n))
+
+
+
+;;;; Dumb window redisplay.
+
+(defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y)
+  (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym))
+	(dl-pos (gensym)) (screen-image-line (gensym)))
+    `(let* ((,dl ,dis-line)
+	    (,dl-chars (dis-line-chars ,dl))
+	    (,dl-len (dis-line-length ,dl))
+	    (,dl-pos ,(or y `(dis-line-position ,dl))))
+       (funcall (tty-device-display-string ,device)
+		,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len)
+       (setf (dis-line-flags ,dl) unaltered-bits)
+       (setf (dis-line-delta ,dl) 0)
+       (select-hunk ,hunk)
+       (let ((,screen-image-line (si-line (tty-device-screen-image ,device)
+					  (+ *hunk-top-line* ,dl-pos))))
+	 (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars
+			  0 0 ,dl-len)
+	 (setf (si-line-length ,screen-image-line) ,dl-len)))))
+
+(defun tty-dumb-window-redisplay (window)
+  (let* ((first (window-first-line window))
+	 (hunk (window-hunk window))
+	 (device (device-hunk-device hunk))
+	 (screen-image (tty-device-screen-image device)))
+    (funcall (tty-device-clear-to-eow device) hunk 0 0)
+    (do ((i 0 (1+ i))
+	 (dl (cdr first) (cdr dl)))
+	((eq dl the-sentinel)
+	 (setf (window-old-lines window) (1- i))
+	 (select-hunk hunk)
+	 (do ((last (tty-hunk-text-position hunk))
+	      (i (+ *hunk-top-line* i) (1+ i)))
+	     ((> i last))
+	   (declare (fixnum i last))
+	   (setf (si-line-length (si-line screen-image i)) 0)))
+      (tty-dumb-line-redisplay device hunk (car dl) i))
+    (setf (window-first-changed window) the-sentinel
+	  (window-last-changed window) first)
+    (when (window-modeline-buffer window)
+      (let ((dl (window-modeline-dis-line window))
+	    (y (tty-hunk-modeline-pos hunk)))
+	(funcall (tty-device-standout-init device) hunk)
+	(funcall (tty-device-clear-to-eol device) hunk 0 y)
+	(tty-dumb-line-redisplay device hunk dl y)
+	(funcall (tty-device-standout-end device) hunk)
+	(setf (dis-line-flags dl) unaltered-bits)))))
+
+
+
+;;;; Dumb redisplay top n lines of a window.
+
+(defun tty-redisplay-n-lines (window n)
+  (let* ((hunk (window-hunk window))
+	 (device (device-hunk-device hunk)))
+    (funcall (tty-device-clear-lines device) hunk 0 0 n)
+    (do ((n n (1- n))
+	 (dl (cdr (window-first-line window)) (cdr dl)))
+	((or (zerop n) (eq dl the-sentinel)))
+      (tty-dumb-line-redisplay device hunk (car dl)))))
+
+
+
+;;;; Semi dumb window redisplay
+
+;;; This is for terminals without opening and deleting lines.
+
+;;; TTY-SEMI-DUMB-WINDOW-REDISPLAY is a lot like TTY-SMART-WINDOW-REDISPLAY,
+;;; but it calls different line redisplay functions.
+;;; 
+(defun tty-semi-dumb-window-redisplay (window)
+  (let* ((hunk (window-hunk window))
+	 (device (device-hunk-device hunk)))
+    (let ((first-changed (window-first-changed window))
+	  (last-changed (window-last-changed window)))
+      ;; Is there anything to do?
+      (unless (eq first-changed the-sentinel)
+	(if ;; One line-changed.
+	    (and (eq first-changed last-changed)
+		 (zerop (dis-line-delta (car first-changed))))
+	    (tty-semi-dumb-line-redisplay device hunk (car first-changed))
+	    ;; More lines changed.
+	    (do-semi-dumb-line-writes first-changed last-changed hunk))
+	;; Set the bounds so we know we displayed...
+	(setf (window-first-changed window) the-sentinel
+	      (window-last-changed window) (window-first-line window))))
+    ;;
+    ;; Clear any extra lines at the end of the window.
+    (let ((pos (dis-line-position (car (window-last-line window)))))
+      (when (< pos (window-old-lines window))
+	(tty-smart-clear-to-eow hunk (1+ pos)))
+      (setf (window-old-lines window) pos))
+    ;;
+    ;; Update the modeline if needed.
+    (when (window-modeline-buffer window)
+      (let ((dl (window-modeline-dis-line window)))
+	(when (/= (dis-line-flags dl) unaltered-bits)
+	  (funcall (tty-device-standout-init device) hunk)
+	  (unwind-protect
+	      (tty-smart-line-redisplay device hunk dl
+					(tty-hunk-modeline-pos hunk))
+	    (funcall (tty-device-standout-end device) hunk)))))))
+
+;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and
+;;; COMPUTE-TTY-CHANGES.
+;;; 
+(eval-when (compile eval)
+(defmacro next-dis-line ()
+  `(progn 
+    (setf prev dl)
+    (setf dl (cdr dl))
+    (setf flags (dis-line-flags (car dl)))))
+) ;eval-when
+
+;;; DO-SEMI-DUMB-LINE-WRITES does what it says until it hits the last
+;;; changed line.  The commented out code was a gratuitous optimization,
+;;; especially if the first-changed line really is the first changes line.
+;;; Anyway, this had to be removed because of this function's use in
+;;; TTY-SMART-WINDOW-REDISPLAY, which was punting line moves due to
+;;; "Scroll Redraw Ratio".  However, these supposedly moved lines had their
+;;; bits set to unaltered bits in COMPUTE-TTY-CHANGES because it was
+;;; assuming TTY-SMART-WINDOW-REDISPLAY guaranteed to do line moves.
+;;; 
+(defun do-semi-dumb-line-writes (first-changed last-changed hunk)
+  (let* ((dl first-changed)
+	 flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE.
+	 prev)
+    (declare (ignore flags))
+    ;;
+    ;; Skip old, unchanged, unmoved lines.
+    ;; (loop
+    ;;  (unless (zerop flags) (return))
+    ;;  (next-dis-line))
+    ;;
+    ;; Write every remaining line.
+    (let* ((device (device-hunk-device hunk))
+	   (force-output (device-force-output device)))
+      (loop
+       (tty-semi-dumb-line-redisplay device hunk (car dl))
+       (when force-output (funcall force-output))
+       (next-dis-line)
+       (when (eq prev last-changed) (return))))))
+
+;;; TTY-SEMI-DUMB-LINE-REDISPLAY finds the first different character
+;;; comparing the display line and the screen image line, writes out the
+;;; rest of the display line, and clears to end-of-line as necessary.
+;;; 
+(defun tty-semi-dumb-line-redisplay (device hunk dl
+				     &optional (dl-pos (dis-line-position dl)))
+  (declare (fixnum dl-pos))
+  (let* ((dl-chars (dis-line-chars dl))
+	 (dl-len (dis-line-length dl)))
+    (declare (fixnum dl-len) (simple-string dl-chars))
+    (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input))
+    (select-hunk hunk)
+    (let* ((screen-image-line (si-line (tty-device-screen-image device)
+				       (+ *hunk-top-line* dl-pos)))
+	   (si-line-chars (si-line-chars screen-image-line))
+	   (si-line-length (si-line-length screen-image-line))
+	   (findex (string/= dl-chars si-line-chars
+			     :end1 dl-len :end2 si-line-length)))
+      (declare (fixnum findex) (simple-string si-line-chars))
+      ;;
+      ;; When the dis-line and screen chars are not string=.
+      (when findex
+	(cond
+	 ;; See if the screen shows an initial substring of the dis-line.
+	 ((= findex si-line-length)
+	  (funcall (tty-device-display-string device)
+		   hunk findex dl-pos dl-chars findex dl-len)
+	  (replace-si-line si-line-chars dl-chars findex findex dl-len))
+	 ;; When the dis-line is an initial substring of what's on the screen.
+	 ((= findex dl-len)
+	  (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
+	 ;; Otherwise, blast dl-chars and clear to eol as necessary.
+	 (t (funcall (tty-device-display-string device)
+		     hunk findex dl-pos dl-chars findex dl-len)
+	    (when (< dl-len si-line-length)
+	      (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))
+	    (replace-si-line si-line-chars dl-chars findex findex dl-len)))
+	(setf (si-line-length screen-image-line) dl-len)))
+    (setf (dis-line-flags dl) unaltered-bits)
+    (setf (dis-line-delta dl) 0)))
+
+
+
+;;;; Smart window redisplay -- operation queues and internal screen image.
+
+;;; This is used for creating temporary smart redisplay structures.
+;;; 
+(defconstant tty-hunk-height-limit 100)
+
+
+;;; Queues for redisplay operations and access macros.
+;;; 
+(defvar *tty-line-insertions* (make-array (* 2 tty-hunk-height-limit)))
+
+(defvar *tty-line-deletions* (make-array (* 2 tty-hunk-height-limit)))
+
+(defvar *tty-line-writes* (make-array tty-hunk-height-limit))
+
+(eval-when (compile eval)
+
+(defmacro queue (value queue ptr)
+  `(progn
+    (setf (svref ,queue ,ptr) ,value)
+    (the fixnum (incf (the fixnum ,ptr)))))
+
+(defmacro dequeue (queue ptr)
+  `(prog1
+    (svref ,queue ,ptr)
+    (the fixnum (incf (the fixnum ,ptr)))))
+
+) ;eval-when
+
+;;; INSERT-LINE-COUNT is used in TTY-SMART-WINDOW-REDISPLAY.  The counting is
+;;; based on calls to QUEUE in COMPUTE-TTY-CHANGES.
+;;; 
+(defun insert-line-count (ins)
+  (do ((i 1 (+ i 2))
+       (count 0 (+ count (svref *tty-line-insertions* i))))
+      ((> i ins) count)))
+
+
+;;; Temporary storage for screen-image lines and accessing macros.
+;;; 
+(defvar *screen-image-temp* (make-array tty-hunk-height-limit))
+
+(eval-when (compile eval)
+
+;;; DELETE-SI-LINES is used in DO-LINE-DELETIONS to simulate what's
+;;; happening to the screen in a device's screen-image.  At y, num
+;;; lines are deleted and saved in *screen-image-temp*; fsil is the
+;;; end of the free screen image lines saved here.  Also, we must
+;;; move lines up in the screen-image structure.  In the outer loop
+;;; we save lines in the temp storage and move lines up at the same
+;;; time.  In the termination/inner loop we move any lines that still
+;;; need to be moved up.  The screen-length is adjusted by the fsil
+;;; because any time a deletion is in progress, there are fsil bogus
+;;; lines at the bottom of the screen image from lines being moved
+;;; up previously.
+;;; 
+(defmacro delete-si-lines (screen-image y num fsil screen-length)
+  (let ((do-screen-image (gensym)) (delete-index (gensym))
+	(free-lines (gensym)) (source-index (gensym)) (target-index (gensym))
+	(n (gensym)) (do-screen-length (gensym)) (do-y (gensym)))
+    `(let ((,do-screen-image ,screen-image)
+	   (,do-screen-length (- ,screen-length fsil))
+	   (,do-y ,y))
+       (declare (fixnum ,do-screen-length ,do-y))
+       (do ((,delete-index ,do-y (1+ ,delete-index))
+	    (,free-lines ,fsil (1+ ,free-lines))
+	    (,source-index (+ ,do-y ,num) (1+ ,source-index))
+	    (,n ,num (1- ,n)))
+	   ((zerop ,n)
+	    (do ((,target-index ,delete-index (1+ ,target-index))
+		 (,source-index ,source-index (1+ ,source-index)))
+		((>= ,source-index ,do-screen-length))
+	      (declare (fixnum ,target-index ,source-index))
+	      (setf (si-line ,do-screen-image ,target-index)
+		    (si-line ,do-screen-image ,source-index))))
+	 (declare (fixnum ,delete-index ,free-lines ,source-index ,n))
+	 (setf (si-line *screen-image-temp* ,free-lines)
+	       (si-line ,do-screen-image ,delete-index))
+	 (when (< ,source-index ,do-screen-length)
+	   (setf (si-line ,do-screen-image ,delete-index)
+		 (si-line ,do-screen-image ,source-index)))))))
+
+
+;;; INSERT-SI-LINES is used in DO-LINE-INSERTIONS to simulate what's
+;;; happening to the screen in a device's screen-image.  At y, num free
+;;; lines are inserted from *screen-image-temp*; fsil is the end of the
+;;; free lines.  When copying lines down in screen-image, we must start
+;;; with the lower lines and end with the higher ones, so we don't trash
+;;; any lines.  The outer loop does all the copying, and the termination/
+;;; inner loop inserts the free screen image lines, setting their length
+;;; to zero.
+;;; 
+(defmacro insert-si-lines (screen-image y num fsil screen-length)
+  (let ((do-screen-image (gensym)) (source-index (gensym))
+	(target-index (gensym)) (target-terminus (gensym))
+	(do-screen-length (gensym)) (temp (gensym)) (do-y (gensym))
+	(insert-index (gensym)) (free-lines-index (gensym))
+	(n (gensym)))
+    `(let ((,do-screen-length ,screen-length)
+	   (,do-screen-image ,screen-image)
+	   (,do-y ,y))
+       (do ((,target-terminus (1- (+ ,do-y ,num)))	 ; (1- target-start)
+	    (,source-index (- ,do-screen-length ,fsil 1) ; (1- source-end)
+			   (1- ,source-index))
+	    (,target-index (- (+ ,do-screen-length ,num)
+			      ,fsil 1)			 ; (1- target-end)
+		(1- ,target-index)))
+	   ((= ,target-index ,target-terminus)
+	    (do ((,insert-index ,do-y (1+ ,insert-index))
+		 (,free-lines-index (1- ,fsil) (1- ,free-lines-index))
+		 (,n ,num (1- ,n)))
+		((zerop ,n))
+	      (declare (fixnum ,insert-index ,free-lines-index ,n))
+	      (let ((,temp (si-line *screen-image-temp* ,free-lines-index)))
+		(setf (si-line-length ,temp) 0)
+		(setf (si-line ,do-screen-image ,insert-index) ,temp)))
+	    (decf ,fsil ,num))
+	 (declare (fixnum ,target-terminus ,source-index ,target-index))
+	 (setf (si-line ,do-screen-image ,target-index)
+	       (si-line ,do-screen-image ,source-index))))))
+
+) ;eval-when
+
+
+
+;;;; Smart window redisplay -- the function.
+
+;;; TTY-SMART-WINDOW-REDISPLAY sees if only one line changed after
+;;; some preliminary processing.  If more than one line changed,
+;;; then we compute changes to make to the screen in the form of
+;;; line insertions, deletions, and writes.  Deletions must be done
+;;; first, so lines are not lost off the bottom of the screen by
+;;; inserting lines.
+;;; 
+(defun tty-smart-window-redisplay (window)
+  (let* ((hunk (window-hunk window))
+	 (device (device-hunk-device hunk)))
+    (let ((first-changed (window-first-changed window))
+	  (last-changed (window-last-changed window)))
+      ;; Is there anything to do?
+      (unless (eq first-changed the-sentinel)
+	(if (and (eq first-changed last-changed)
+		 (zerop (dis-line-delta (car first-changed))))
+	    ;; One line-changed.
+	    (tty-smart-line-redisplay device hunk (car first-changed))
+	    ;; More lines changed.
+	    (multiple-value-bind (ins outs writes)
+				 (compute-tty-changes
+				  first-changed last-changed
+				  (tty-hunk-modeline-pos hunk))
+	      (let ((ratio (variable-value 'ed::scroll-redraw-ratio)))
+		(cond ((and ratio
+			    (> (/ (insert-line-count ins)
+				  (tty-hunk-text-height hunk))
+			       ratio))
+		       (do-semi-dumb-line-writes first-changed last-changed
+						 hunk))
+		      (t
+		       (do-line-insertions hunk ins
+					   (do-line-deletions hunk outs))
+		       (do-line-writes hunk writes))))))
+	;; Set the bounds so we know we displayed...
+	(setf (window-first-changed window) the-sentinel
+	      (window-last-changed window) (window-first-line window))))
+    ;;
+    ;; Clear any extra lines at the end of the window.
+    (let ((pos (dis-line-position (car (window-last-line window)))))
+      (when (< pos (window-old-lines window))
+	(tty-smart-clear-to-eow hunk (1+ pos)))
+      (setf (window-old-lines window) pos))
+    ;;
+    ;; Update the modeline if needed.
+    (when (window-modeline-buffer window)
+      (let ((dl (window-modeline-dis-line window)))
+	(when (/= (dis-line-flags dl) unaltered-bits)
+	  (funcall (tty-device-standout-init device) hunk)
+	  (unwind-protect
+	      (tty-smart-line-redisplay device hunk dl
+					(tty-hunk-modeline-pos hunk))
+	    (funcall (tty-device-standout-end device) hunk)))))))
+
+
+
+;;;; Smart window redisplay -- computing changes to the display.
+
+;;; There is a lot of documentation here to help since this code is not
+;;; obviously correct.  The code is not that cryptic, but the correctness
+;;; of the algorithm is somewhat.  Most of the complexity is in handling
+;;; lines that moved on the screen which the introduction deals with.
+;;; Also, the block of documentation immediately before the function
+;;; COMPUTE-TTY-CHANGES has its largest portion dedicated to this part of
+;;; the function which is the largest block of code in the function.
+
+;;; The window image dis-lines are annotated with the difference between
+;;; their current intended locations and their previous locations in the
+;;; window.  This delta (distance moved) is negative for an upward move and
+;;; positive for a downward move.  To determine what to do with moved
+;;; groups of lines, we consider the transition (or difference in deltas)
+;;; between two adjacent groups as we look at the window's dis-lines moving
+;;; down the window image, disregarding whether they are contiguous (having
+;;; moved only by a different delta) or separated by some lines (such as
+;;; lines that are new and unmoved).
+;;;
+;;; Considering the transition between moved groups makes sense because a
+;;; given group's delta affects all the lines below it since the dis-lines
+;;; reflect the window's buffer's actual lines which are all connected in
+;;; series.  Therefore, if the previous group moved up some delta number of
+;;; lines because of line deletions, then the lines below this group (down
+;;; to the last line of the window image) moved up by the same delta too,
+;;; unless one of the following is true:
+;;;    1] The lines below the group moved up by a greater delta, possibly
+;;;       due to multiple disjoint buffer line deletions.
+;;;    2] The lines below the group moved up by a lesser delta, possibly
+;;;       due to a number (less than the previous delta) of new line
+;;;       insertions below the group that moved up.
+;;;    3] The lines below the group moved down, possibly due to a number
+;;;       (greater than the previous delta) of new line insertions below
+;;;       the group that moved up.
+;;; Similarly, if the previous group moved down some delta number of lines
+;;; because of new line insertions, then the lines below this group (down
+;;; to the last line of the window image not to fall off the window's lower
+;;; edge) moved down by the same delta too, unless one of the following is
+;;; true:
+;;;    1] The lines below the group moved down by a greater delta, possibly
+;;;       due to multiple disjoint buffer line insertions.
+;;;    2] The lines below the group moved down by a lesser delta, possibly
+;;;       due to a number (less than the previous delta) of line deletions
+;;;       below the group that moved down.
+;;;    3] The lines below the group moved up, possibly due to a number
+;;;       (greater than the previous delta) of line deletions below the
+;;;       group that moved down.
+;;;
+;;; Now we can see how the first moved group affects the window image below
+;;; it except where there is a lower group of lines that have moved a
+;;; different delta due to separate operations on the buffer's lines viewed
+;;; through a window.  We can see that this different delta is the expected
+;;; effect throughout the window image below the second group, unless
+;;; something lower down again has affected the window image.  Also, in the
+;;; case of a last group of lines that moved up, the group will never
+;;; reflect all of the lines in the window image from the first line to
+;;; move down to the bottom of the window image because somewhere down below
+;;; the group that moved up are some new lines that have just been drawn up
+;;; into the window's image.
+;;;
+
+;;; COMPUTE-TTY-CHANGES is used once in TTY-SMART-WINDOW-REDISPLAY.
+;;; It goes through all the display lines for a window recording where
+;;; lines need to be inserted, deleted, or written to make the screen
+;;; consistent with the internal image of the screen.  Pointers to
+;;; the insertions, deletions, and writes that have to be done are
+;;; returned.
+;;; 
+;;; If a line is new, then simply queue it to be written.
+;;; 
+;;; If a line is moved and/or changed, then we compute the difference
+;;; between the last block of lines that moved with the same delta and the
+;;; current block of lines that moved with the current delta.  If this
+;;; difference is positive, then some lines need to be deleted.  Since we
+;;; do all the line deletions first to prevent line insertions from
+;;; dropping lines off the bottom of the screen, we have to compute the
+;;; position of line deletions using the cumulative insertions
+;;; (cum-inserts).  Without any insertions, deletions may be done right at
+;;; the dis-line's new position.  With insertions needed above a given
+;;; deletion point combined with the fact that deletions are all done
+;;; first, the location for the deletion is higher than it would be without
+;;; the insertions being done above the deletions.  The location of the
+;;; deletion is higher by the number of insertions we have currently put
+;;; off.  When computing the position of line insertions (a negative delta
+;;; transition), we do not need to consider the cumulative insertions or
+;;; cumulative deletions since everything above the point of insertion
+;;; (both deletions and insertions) has been done.  Because of the screen
+;;; state being correct above the point of an insertion, the screen is only
+;;; off by the delta transition number of lines.  After determining the
+;;; line insertions or deletions, loop over contiguous lines with the same
+;;; delta queuing any changed ones to be written.  The delta and flag
+;;; fields are initialized according to the need to be written; since
+;;; redisplay may be interrupted by more user input after moves have been
+;;; done to the screen, we save the changed bit on, so the line will be
+;;; queued to be written after redisplay is re-entered.
+;;; 
+;;; If the line is changed or new, then queue it to be written.  Note
+;;; before that we checked the flags for equality with the new bits, and
+;;; it is possible that updating the window image will yield lines that
+;;; are both new and changed.
+;;; 
+;;; Otherwise, get the next display line, loop, and see if it's
+;;; interesting.
+;;; 
+(defun compute-tty-changes (first-changed last-changed modeline-pos)
+  (declare (fixnum modeline-pos))
+  (let* ((dl first-changed)
+	 (flags (dis-line-flags (car dl)))
+	 (ins 0) (outs 0) (writes 0)
+	 (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0)
+	 prev)
+    (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta
+		     cum-inserts))
+    (loop
+     (cond
+      ((= flags new-bit)
+       (queue (car dl) *tty-line-writes* writes)
+       (next-dis-line))
+      ((not (zerop (the fixnum (logand flags moved-bit))))
+       (let* ((start-dl (car dl))
+	      (start-pos (dis-line-position start-dl))
+	      (curr-delta (dis-line-delta start-dl))
+	      (delta-delta (- prev-delta curr-delta))
+	      (car-dl start-dl))
+	 (declare (fixnum start-pos curr-delta delta-delta))
+	 (cond ((plusp delta-delta)
+		(queue (the fixnum (- start-pos cum-inserts))
+		       *tty-line-deletions* outs)
+		(queue delta-delta *tty-line-deletions* outs)
+		(incf cum-deletes delta-delta)
+		(decf net-delta delta-delta))
+	       ((minusp delta-delta)
+		(let ((eff-pos (the fixnum (+ start-pos delta-delta)))
+		      (num (the fixnum (- delta-delta))))
+		  (queue eff-pos *tty-line-insertions* ins)
+		  (queue num *tty-line-insertions* ins)
+		  (incf net-delta num)
+		  (incf cum-inserts num)))
+	       (t (error "Internal error -- unexpected zero transition delta ~
+			 in redisplay.")))
+	 (loop
+	  (cond ((and (zerop (the fixnum (logand flags changed-bit)))
+		      (zerop (the fixnum (logand flags new-bit))))
+		 (setf (dis-line-flags car-dl) unaltered-bits))
+		(t (queue car-dl *tty-line-writes* writes)
+		   ;; keep just the changed-bit on.
+		   (setf (dis-line-flags car-dl) changed-bit)))
+	  (setf (dis-line-delta car-dl) 0)
+	  (next-dis-line)
+	  (setf car-dl (car dl))
+	  (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta)
+	    (setf prev-delta curr-delta)
+	    (return)))))
+      ((not (and (zerop (logand (the fixnum flags) changed-bit))
+		 (zerop (logand (the fixnum flags) new-bit))))
+       (queue (car dl) *tty-line-writes* writes)
+       (next-dis-line))
+      (t (next-dis-line)))
+     (when (eq prev last-changed)
+       (unless (zerop net-delta)
+	 (cond ((plusp net-delta)
+		(queue (the fixnum (- modeline-pos cum-deletes net-delta))
+		       *tty-line-deletions* outs)
+		(queue net-delta *tty-line-deletions* outs))
+	       (t (queue (the fixnum (+ modeline-pos net-delta))
+			 *tty-line-insertions* ins)
+		  (queue (the fixnum (- net-delta))
+			 *tty-line-insertions* ins))))
+       (return (values ins outs writes))))))
+
+
+
+;;;; Smart window redisplay -- operation methods.
+
+;;; TTY-SMART-CLEAR-TO-EOW clears lines y through the last text line of hunk.
+;;; It takes care not to clear a line unless it really has some characters
+;;; displayed on it.  It also maintains the device's screen image lines.
+;;; 
+(defun tty-smart-clear-to-eow (hunk y)
+  (let* ((device (device-hunk-device hunk))
+	 (screen-image (tty-device-screen-image device))
+	 (clear-to-eol (tty-device-clear-to-eol device)))
+    (select-hunk hunk)
+    (do ((y y (1+ y))
+	 (si-idx (+ *hunk-top-line* y) (1+ si-idx))
+	 (last (tty-hunk-text-position hunk)))
+	((> si-idx last))
+      (declare (fixnum y si-idx last))
+      (let ((si-line (si-line screen-image si-idx)))
+	(unless (zerop (si-line-length si-line))
+	  (funcall clear-to-eol hunk 0 y)
+	  (setf (si-line-length si-line) 0))))))
+
+;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue,
+;;; deleting lines from hunk's area of the screen.  The internal screen
+;;; image is updated, and the total number of lines deleted is returned.
+;;; 
+(defun do-line-deletions (hunk outs)
+  (declare (fixnum outs))
+  (let* ((i 0)
+	 (device (device-hunk-device hunk))
+	 (fun (tty-device-delete-line device))
+	 (fsil 0)) ;free-screen-image-lines
+    (declare (fixnum i fsil))
+    (loop
+     (when (= i outs) (return fsil))
+     (let ((y (dequeue *tty-line-deletions* i))
+	   (num (dequeue *tty-line-deletions* i)))
+       (declare (fixnum y num))
+       (funcall fun hunk 0 y num)
+       (select-hunk hunk)
+       (delete-si-lines (tty-device-screen-image device)
+			(+ *hunk-top-line* y) num fsil
+			(tty-device-lines device))
+       (incf fsil num)))))
+
+;;; DO-LINE-INSERTIONS pops elements off the *tty-line-insertions* queue,
+;;; inserting lines into hunk's area of the screen.  The internal screen
+;;; image is updated using free screen image lines pointed to by fsil.
+;;; 
+(defun do-line-insertions (hunk ins fsil)
+  (declare (fixnum ins fsil))
+  (let* ((i 0)
+	 (device (device-hunk-device hunk))
+	 (fun (tty-device-open-line device)))
+    (declare (fixnum i))
+    (loop
+     (when (= i ins) (return))
+     (let ((y (dequeue *tty-line-insertions* i))
+	   (num (dequeue *tty-line-insertions* i)))
+       (declare (fixnum y num))
+       (funcall fun hunk 0 y num)
+       (select-hunk hunk)
+       (insert-si-lines (tty-device-screen-image device)
+			(+ *hunk-top-line* y) num fsil
+			(tty-device-lines device))))))
+
+;;; DO-LINE-WRITES pops elements off the *tty-line-writes* queue, displaying
+;;; these dis-lines with TTY-SMART-LINE-REDISPLAY.  We force output after
+;;; each line, so the user can see how far we've gotten in case he chooses
+;;; to give more editor commands which will abort redisplay until there's no
+;;; more input.
+;;; 
+(defun do-line-writes (hunk writes)
+  (declare (fixnum writes))
+  (let* ((i 0)
+	 (device (device-hunk-device hunk))
+	 (force-output (device-force-output device)))
+    (declare (fixnum i))
+    (loop
+     (when (= i writes) (return))
+     (tty-smart-line-redisplay device hunk (dequeue *tty-line-writes* i))
+     (when force-output (funcall force-output)))))
+
+;;; TTY-SMART-LINE-REDISPLAY uses an auxiliary screen image structure to
+;;; try to do minimal character shipping to the terminal.  Roughly, we find
+;;; the first different character when comparing what's on the screen and
+;;; what should be there; we will start altering the line after this same
+;;; initial substring.  Then we find, from the end, the first character
+;;; that is different, blasting out characters to the lesser of the two
+;;; indexes.  If the dis-line index is lesser, we have some characters to
+;;; delete from the screen, and if the screen index is lesser, we have some
+;;; additional dis-line characters to insert.  There are a few special
+;;; cases that allow us to punt out of the above algorithm sketch.  If the
+;;; terminal doesn't have insert mode or delete mode, we have blast out to
+;;; the end of the dis-line and possibly clear to the end of the screen's
+;;; line, as appropriate.  Sometimes we don't use insert or delete mode
+;;; because of the overhead cost in characters; it simply is cheaper to
+;;; blast out characters and clear to eol.
+;;; 
+(defun tty-smart-line-redisplay (device hunk dl
+				 &optional (dl-pos (dis-line-position dl)))
+  (declare (fixnum dl-pos))
+  (let* ((dl-chars (dis-line-chars dl))
+	 (dl-len (dis-line-length dl)))
+    (declare (fixnum dl-len) (simple-string dl-chars))
+    (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input))
+    (select-hunk hunk)
+    (let* ((screen-image-line (si-line (tty-device-screen-image device)
+				       (+ *hunk-top-line* dl-pos)))
+	   (si-line-chars (si-line-chars screen-image-line))
+	   (si-line-length (si-line-length screen-image-line))
+	   (findex (string/= dl-chars si-line-chars
+			      :end1 dl-len :end2 si-line-length)))
+      (declare (fixnum findex) (simple-string si-line-chars))
+      ;;
+      ;; When the dis-line and screen chars are not string=.
+      (when findex
+	(block tslr-main-body
+	  ;;
+	  ;; See if the screen shows an initial substring of the dis-line.
+	  (when (= findex si-line-length)
+	    (funcall (tty-device-display-string device)
+		     hunk findex dl-pos dl-chars findex dl-len)
+	    (replace-si-line si-line-chars dl-chars findex findex dl-len)
+	    (return-from tslr-main-body t))
+	  ;;
+	  ;; When the dis-line is an initial substring of what's on the screen.
+	  (when (= findex dl-len)
+	    (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)
+	    (return-from tslr-main-body t))
+	  ;;
+	  ;; Find trailing substrings that are the same.
+	  (multiple-value-bind (sindex dindex)
+			       (do ((sindex (1- si-line-length) (1- sindex))
+				    (dindex (1- dl-len) (1- dindex)))
+				   ((or (= sindex -1)
+					(= dindex -1)
+					(char/= (schar dl-chars dindex)
+						(schar si-line-chars sindex)))
+				    (values (1+ sindex) (1+ dindex))))
+	    (declare (fixnum sindex dindex))
+	    ;;
+	    ;; No trailing substrings -- blast and clear to eol.
+	    (when (= dindex dl-len)
+	      (funcall (tty-device-display-string device)
+		       hunk findex dl-pos dl-chars findex dl-len)
+	      (when (< dindex sindex)
+		(funcall (tty-device-clear-to-eol device)
+			 hunk dl-len dl-pos))
+	      (replace-si-line si-line-chars dl-chars findex findex dl-len)
+	      (return-from tslr-main-body t))
+	    (let ((lindex (min sindex dindex)))
+	      (cond ((< lindex findex)
+		     ;; This can happen in funny situations -- believe me!
+		     (setf lindex findex))
+		    (t
+		     (funcall (tty-device-display-string device)
+			      hunk findex dl-pos dl-chars findex lindex)
+		     (replace-si-line si-line-chars dl-chars
+				      findex findex lindex)))
+	      (cond
+	       ((= dindex sindex))
+	       ((< dindex sindex)
+		(let ((delete-char-num (- sindex dindex)))
+		  (cond ((and (tty-device-delete-char device)
+			      (worth-using-delete-mode
+			       device delete-char-num (- si-line-length dl-len)))
+			 (funcall (tty-device-delete-char device)
+				  hunk dindex dl-pos delete-char-num))
+			(t 
+			 (funcall (tty-device-display-string device)
+				  hunk dindex dl-pos dl-chars dindex dl-len)
+			 (funcall (tty-device-clear-to-eol device)
+				  hunk dl-len dl-pos)))))
+	       (t
+		(if (and (tty-device-insert-string device)
+			 (worth-using-insert-mode device (- dindex sindex)))
+		    (funcall (tty-device-insert-string device)
+			     hunk sindex dl-pos dl-chars sindex dindex)
+		    (funcall (tty-device-display-string device)
+			     hunk sindex dl-pos dl-chars sindex dl-len))))
+	      (replace-si-line si-line-chars dl-chars
+			       lindex lindex dl-len))))
+	(setf (si-line-length screen-image-line) dl-len)))
+    (setf (dis-line-flags dl) unaltered-bits)
+    (setf (dis-line-delta dl) 0)))
+
+
+
+;;;; Device methods
+
+;;; Initializing and exiting the device (DEVICE-INIT and DEVICE-EXIT functions).
+;;; These can be found in Tty-Display-Rt.Lisp.
+
+
+;;; Clearing the device (DEVICE-CLEAR functions).
+
+(defun clear-device (device)
+  (device-write-string (tty-device-clear-string device))
+  (cursor-motion device 0 0)
+  (setf (tty-device-cursor-x device) 0)
+  (setf (tty-device-cursor-y device) 0))
+
+
+;;; Moving the cursor around (DEVICE-PUT-CURSOR)
+
+;;; TTY-PUT-CURSOR makes sure the coordinates are mapped from the hunk's
+;;; axis to the screen's and determines the minimal cost cursor motion
+;;; sequence.  Currently, it does no cost analysis of relative motion
+;;; compared to absolute motion but simply makes sure the cursor isn't
+;;; already where we want it.
+;;;
+(defun tty-put-cursor (hunk x y)
+  (declare (fixnum x y))
+  (select-hunk hunk)
+  (let ((y (the fixnum (+ *hunk-top-line* y)))
+	(device (device-hunk-device hunk)))
+    (declare (fixnum y))
+    (unless (and (= (the fixnum (tty-device-cursor-x device)) x)
+		 (= (the fixnum (tty-device-cursor-y device)) y))
+      (cursor-motion device x y)
+      (setf (tty-device-cursor-x device) x)
+      (setf (tty-device-cursor-y device) y))))
+
+;;; UPDATE-CURSOR is used in device redisplay methods to make sure the
+;;; cursor is where it should be.
+;;; 
+(eval-when (compile eval)
+  (defmacro update-cursor (hunk x y)
+    `(funcall (device-put-cursor (device-hunk-device ,hunk)) ,hunk ,x ,y))
+) ;eval-when
+
+;;; CURSOR-MOTION takes two coordinates on the screen's axis,
+;;; moving the cursor to that location.  X is the column index,
+;;; and y is the line index, but Unix and Termcap believe that
+;;; the default order of indexes is first the line and then the
+;;; column or (y,x).  Because of this, when reversep is non-nil,
+;;; we send first x and then y.
+;;; 
+(defun cursor-motion (device x y)
+  (let ((x-add-char (tty-device-cm-x-add-char device))
+	(y-add-char (tty-device-cm-y-add-char device))
+	(x-condx-add (tty-device-cm-x-condx-char device))
+	(y-condx-add (tty-device-cm-y-condx-char device))
+	(one-origin (tty-device-cm-one-origin device)))
+    (when x-add-char (incf x x-add-char))
+    (when (and x-condx-add (> x x-condx-add))
+      (incf x (tty-device-cm-x-condx-add-char device)))
+    (when y-add-char (incf y y-add-char))
+    (when (and y-condx-add (> y y-condx-add))
+      (incf y (tty-device-cm-y-condx-add-char device)))
+    (when one-origin (incf x) (incf y)))
+  (device-write-string (tty-device-cm-string1 device))
+  (let ((reversep (tty-device-cm-reversep device))
+	(x-pad (tty-device-cm-x-pad device))
+	(y-pad (tty-device-cm-y-pad device)))
+    (if reversep
+	(cm-output-coordinate x x-pad)
+	(cm-output-coordinate y y-pad))
+    (device-write-string (tty-device-cm-string2 device))
+    (if reversep
+	(cm-output-coordinate y y-pad)
+	(cm-output-coordinate x x-pad))
+    (device-write-string (tty-device-cm-string3 device))))
+
+;;; CM-OUTPUT-COORDINATE outputs the coordinate with respect to the pad.  If
+;;; there is a pad, then the coordinate needs to be sent as digit-char's (for
+;;; each digit in the coordinate), and if there is no pad, the coordinate needs
+;;; to be converted into a character.  Using CODE-CHAR here is not really
+;;; portable.  With a pad, the coordinate buffer is filled from the end as we
+;;; truncate the coordinate by 10, generating ones digits.
+;;;
+(defconstant cm-coordinate-buffer-len 5)
+(defvar *cm-coordinate-buffer* (make-string cm-coordinate-buffer-len))
+;;;
+(defun cm-output-coordinate (coordinate pad)
+  (cond (pad
+	 (let ((i (1- cm-coordinate-buffer-len)))
+	   (loop
+	     (when (= i -1) (error "Terminal has too many lines!"))
+	     (multiple-value-bind (tens ones)
+				  (truncate coordinate 10)
+	       (setf (schar *cm-coordinate-buffer* i) (digit-char ones))
+	       (when (zerop tens)
+		 (dotimes (n (- pad (- cm-coordinate-buffer-len i)))
+		   (decf i)
+		   (setf (schar *cm-coordinate-buffer* i) #\0))
+		 (device-write-string *cm-coordinate-buffer* i
+				      cm-coordinate-buffer-len)
+		 (return))
+	       (decf i)
+	       (setf coordinate tens)))))
+	(t (tty-write-char (code-char coordinate)))))
+
+
+;;; Writing strings (TTY-DEVICE-DISPLAY-STRING functions)
+
+;;; DISPLAY-STRING is used to put a string at (x,y) on the device.
+;;; 
+(defun display-string (hunk x y string
+			    &optional (start 0) (end (strlen string)))
+  (declare (fixnum x y start end))
+  (update-cursor hunk x y)
+  (device-write-string string start end)
+  (setf (tty-device-cursor-x (device-hunk-device hunk))
+	(the fixnum (+ x (the fixnum (- end start))))))
+
+;;; DISPLAY-STRING-CHECKING-UNDERLINES is used for terminals that special
+;;; case underlines doing an overstrike when they don't otherwise overstrike.
+;;; Note: we do not know in this code whether the terminal can backspace (or
+;;; what the sequence is), whether the terminal has insert-mode, or whether
+;;; the terminal has delete-mode.
+;;; 
+(defun display-string-checking-underlines (hunk x y string
+						&optional (start 0)
+						          (end (strlen string)))
+  (declare (fixnum x y start end) (simple-string string))
+  (update-cursor hunk x y)
+  (let ((upos (position #\_ string :test #'char= :start start :end end))
+	(device (device-hunk-device hunk)))
+    (if upos
+	(let ((previous start)
+	      after-pos)
+	  (declare (fixnum previous after-pos))
+	  (loop (device-write-string string previous upos)
+		(setf after-pos (do ((i (1+ upos) (1+ i)))
+				    ((or (= i end)
+					 (char/= (schar string i) #\_)) i)
+				  (declare (fixnum i))))
+		(let ((ulen (the fixnum (- after-pos upos)))
+		      (cursor-x (the fixnum (+ x (the fixnum
+						      (- after-pos start))))))
+		  (declare (fixnum ulen))
+		  (dotimes (i ulen) (tty-write-char #\space))
+		  (setf (tty-device-cursor-x device) cursor-x)
+		  (update-cursor hunk upos y)
+		  (dotimes (i ulen) (tty-write-char #\_))
+		  (setf (tty-device-cursor-x device) cursor-x))
+		(setf previous after-pos)
+		(setf upos (position #\_ string :test #'char=
+				     :start previous :end end))
+		(unless upos
+		  (device-write-string string previous end)
+		  (return))))
+	(device-write-string string start end))
+    (setf (tty-device-cursor-x device)
+	  (the fixnum (+ x (the fixnum (- end start)))))))
+	   
+
+;;; DEVICE-WRITE-STRING is used to shove a string at the terminal regardless
+;;; of cursor position.
+;;; 
+(defun device-write-string (string &optional (start 0) (end (strlen string)))
+  (declare (fixnum start end))
+  (unless (= start end)
+    (tty-write-string string start (the fixnum (- end start)))))
+
+
+;;; Clearing lines (TTY-DEVICE-CLEAR-TO-EOL, DEVICE-CLEAR-LINES, and
+;;; TTY-DEVICE-CLEAR-TO-EOW functions.)
+
+(defun clear-to-eol (hunk x y)
+  (update-cursor hunk x y)
+  (device-write-string
+   (tty-device-clear-to-eol-string (device-hunk-device hunk))))
+
+(defun space-to-eol (hunk x y)
+  (declare (fixnum x))
+  (update-cursor hunk x y)
+  (let* ((device (device-hunk-device hunk))
+	 (num (- (the fixnum (tty-device-columns device))
+		 x)))
+    (declare (fixnum num))
+    (dotimes (i num) (tty-write-char #\space))
+    (setf (tty-device-cursor-x device) (+ x num))))
+
+(defun clear-lines (hunk x y n)
+  (let* ((device (device-hunk-device hunk))
+	 (clear-to-eol (tty-device-clear-to-eol device)))
+    (funcall clear-to-eol hunk x y)
+    (do ((y (1+ y) (1+ y))
+	 (count (1- n) (1- count)))
+	((zerop count)
+	 (setf (tty-device-cursor-x device) 0)
+	 (setf (tty-device-cursor-y device) (1- y)))
+      (declare (fixnum count y))
+      (funcall clear-to-eol hunk 0 y))))
+
+(defun clear-to-eow (hunk x y)
+  (declare (fixnum x y))
+  (funcall (tty-device-clear-lines (device-hunk-device hunk))
+	   hunk x y
+	   (the fixnum (- (the fixnum (tty-hunk-text-height hunk)) y))))
+
+
+;;; Opening and Deleting lines (TTY-DEVICE-OPEN-LINE and TTY-DEVICE-DELETE-LINE)
+
+(defun open-tty-line (hunk x y &optional (n 1))
+  (update-cursor hunk x y)
+  (dotimes (i n)
+    (device-write-string (tty-device-open-line-string (device-hunk-device hunk)))))
+
+(defun delete-tty-line (hunk x y &optional (n 1))
+  (update-cursor hunk x y)
+  (dotimes (i n)
+    (device-write-string (tty-device-delete-line-string (device-hunk-device hunk)))))
+
+
+;;; Insert and Delete modes (TTY-DEVICE-INSERT-STRING and TTY-DEVICE-DELETE-CHAR)
+
+(defun tty-insert-string (hunk x y string
+			   &optional (start 0) (end (strlen string)))
+  (declare (fixnum x y start end))
+  (update-cursor hunk x y)
+  (let* ((device (device-hunk-device hunk))
+	 (init-string (tty-device-insert-init-string device))
+	 (char-init-string (tty-device-insert-char-init-string device))
+	 (cis-len (if char-init-string (length char-init-string)))
+	 (char-end-string (tty-device-insert-char-end-string device))
+	 (ces-len (if char-end-string (length char-end-string)))
+	 (end-string (tty-device-insert-end-string device)))
+    (declare (simple-string char-init-string char-end-string))
+    (when init-string (device-write-string init-string))
+    (if char-init-string
+	(do ((i start (1+ i)))
+	    ((= i end))
+	  (device-write-string char-init-string 0 cis-len)
+	  (tty-write-char (schar string i))
+	  (when char-end-string
+	    (device-write-string char-end-string 0 ces-len)))
+	(device-write-string string start end))
+    (when end-string (device-write-string end-string))
+    (setf (tty-device-cursor-x device)
+	  (the fixnum (+ x (the fixnum (- end start)))))))
+
+(defun worth-using-insert-mode (device insert-char-num)
+  (let* ((init-string (tty-device-insert-init-string device))
+	 (char-init-string (tty-device-insert-char-init-string device))
+	 (char-end-string (tty-device-insert-char-end-string device))
+	 (end-string (tty-device-insert-end-string device))
+	 (cost 0))
+    (when init-string (incf cost (length (the simple-string init-string))))
+    (when char-init-string
+      (incf cost (* insert-char-num (+ (length (the simple-string
+						    char-init-string))
+				       (if char-end-string
+					   (length (the simple-string
+							char-end-string))
+					   0)))))
+    (when end-string (incf cost (length (the simple-string end-string))))
+    (< cost insert-char-num)))
+
+(defun delete-char (hunk x y &optional n)
+  (declare (fixnum x y n))
+  (update-cursor hunk x y)
+  (let* ((device (device-hunk-device hunk))
+	 (init-string (tty-device-delete-init-string device))
+	 (end-string (tty-device-delete-end-string device))
+	 (delete-char-string (tty-device-delete-char-string device)))
+    (when init-string (device-write-string init-string))
+    (dotimes (i n)
+      (device-write-string delete-char-string))
+    (when end-string (device-write-string end-string))))
+
+(defun worth-using-delete-mode (device delete-char-num clear-char-num)
+  (declare (fixnum num))
+  (let ((init-string (tty-device-delete-init-string device))
+	(end-string (tty-device-delete-end-string device))
+	(delete-char-string (tty-device-delete-char-string device))
+	(clear-to-eol-string (tty-device-clear-to-eol-string device))
+	(cost 0))
+    (declare (simple-string init-string end-string delete-char-string)
+	     (fixnum cost))
+    (when init-string (incf cost (the fixnum (length init-string))))
+    (when end-string (incf cost (the fixnum (length end-string))))
+    (incf cost (the fixnum
+		    (* (the fixnum (length delete-char-string))
+		       delete-char-num)))
+    (< cost (+ delete-char-num
+	       (if clear-to-eol-string
+		   (length clear-to-eol-string)
+		   clear-char-num)))))
+
+
+;;; Standout mode (TTY-DEVICE-STANDOUT-INIT and TTY-DEVICE-STANDOUT-END)
+
+(defun standout-init (hunk)
+  (device-write-string
+   (tty-device-standout-init-string (device-hunk-device hunk))))
+
+(defun standout-end (hunk)
+  (device-write-string
+   (tty-device-standout-end-string (device-hunk-device hunk))))
diff --git a/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..84b1781bf4cd0c52313a996b77d21d50540f008f
--- /dev/null
+++ b/hemlock/tty-stream.lisp
@@ -0,0 +1,157 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Some stuff to make streams that write out to terminal hunks.
+;;;
+;;; Written by Bill Chiles.
+;;;
+;;; This code is VERY similar to that in Pane-Stream.Lisp.  The biggest
+;;; (if only) difference is in TTY-HUNK-STREAM-NEWLINE.
+;;;
+
+(in-package 'hemlock-internals)
+
+
+
+;;;; Constants
+
+(defconstant tty-hunk-width-limit 200)
+
+
+
+;;;; Structures
+
+;;; Tty-Hunk streams are inherently buffered by line.
+
+(defstruct (stream-hunk (:print-function %print-device-hunk)
+			(:include tty-hunk))
+  (width 0 :type fixnum)
+  (point-x 0 :type fixnum)
+  (point-y 0 :type fixnum)
+  (buffer "" :type simple-string))
+
+(defstruct (tty-hunk-output-stream (:include stream
+					     (out #'hunk-out)
+					     (sout #'hunk-sout)
+					     (misc #'hunk-misc))
+				   (:constructor
+				    make-tty-hunk-output-stream ()))
+  (hunk (make-stream-hunk :buffer (make-string tty-hunk-width-limit))))
+
+
+
+;;;; Tty-hunk-output-stream methods
+
+;;; HUNK-OUT puts a character into a hunk-stream buffer.  If the character
+;;; makes the current line wrap, or if the character is a newline, then
+;;; call TTY-HUNK-NEWLINE.
+;;;
+(defun hunk-out (stream character)
+  (let* ((hunk (tty-hunk-output-stream-hunk stream))
+	 (x (stream-hunk-point-x hunk)))
+    (declare (fixnum x))
+    (cond ((char= character #\newline)
+	   (tty-hunk-stream-newline hunk)
+	   (return-from hunk-out nil))
+	  ((= x (the fixnum (stream-hunk-width hunk)))
+	   (setf x 0)
+	   (tty-hunk-stream-newline hunk)))
+    (setf (schar (stream-hunk-buffer hunk) x) character)
+    (incf (stream-hunk-point-x hunk))))
+
+;;; HUNK-MISC, when finishing or forcing output, only needs to blast
+;;; out the buffer at y from 0 to x since these streams are inherently
+;;; line buffered.  Currently, these characters will be blasted out again
+;;; since there isn't a separate buffer index from point-x, and we can't
+;;; set point-x to zero since we haven't a newline.
+;;; 
+(defun hunk-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos
+     (let ((hunk (tty-hunk-output-stream-hunk stream)))
+       (values (stream-hunk-point-x hunk) (stream-hunk-point-y hunk))))
+    ((:finish-output :force-output)
+     (let* ((hunk (tty-hunk-output-stream-hunk stream))
+	    (device (device-hunk-device hunk)))
+       (funcall (tty-device-display-string device)
+		hunk 0 (stream-hunk-point-y hunk) (stream-hunk-buffer hunk)
+		0 (stream-hunk-point-x hunk))
+       (when (device-force-output device)
+	 (funcall (device-force-output device)))))
+    (:line-length
+     (stream-hunk-width (tty-hunk-output-stream-hunk stream)))
+    (:element-type 'string-char)))
+
+;;; HUNK-SOUT writes a byte-blt's a string to a hunk-stream's buffer.
+;;; When newlines are found, recurse on the substrings delimited by start,
+;;; end, and newlines.  If the string causes line wrapping, then we break
+;;; the string up into line-at-a-time segments calling TTY-HUNK-STREAM-NEWLINE.
+;;; 
+(defun hunk-sout (stream string start end)
+  (declare (fixnum start end))
+  (let* ((hunk (tty-hunk-output-stream-hunk stream))
+	 (buffer (stream-hunk-buffer hunk))
+	 (x (stream-hunk-point-x hunk))
+	 (dst-end (+ x (- end start)))
+	 (width (stream-hunk-width hunk))
+	 (newlinep (%sp-find-character string start end #\newline)))
+    (declare (fixnum x dst-end width))
+    (cond (newlinep
+	   (let ((previous start) (current newlinep))
+	     (declare (fixnum previous))
+	     (loop (when (null current)
+		     (hunk-sout stream string previous end)
+		     (return))
+		   (hunk-sout stream string previous current)
+		   (tty-hunk-stream-newline hunk)
+		   (setf previous (the fixnum (1+ (the fixnum current))))
+		   (setf current
+			 (%sp-find-character string previous end #\newline)))))
+	  ((> dst-end width)
+	   (let ((new-start (+ start (- width x))))
+	     (declare (fixnum new-start))
+	     (%primitive byte-blt string start buffer x width)
+	     (setf (stream-hunk-point-x hunk) width)
+	     (tty-hunk-stream-newline hunk)
+	     (do ((idx (+ new-start width) (+ idx width))
+		  (prev new-start idx))
+		 ((>= idx end)
+		  (let ((dst-end (- end prev)))
+		    (%primitive byte-blt string prev buffer 0 dst-end)
+		    (setf (stream-hunk-point-x hunk) dst-end)))
+	       (declare (fixnum prev idx))
+	       (%primitive byte-blt string prev buffer 0 width)
+	       (setf (stream-hunk-point-x hunk) width)
+	       (tty-hunk-stream-newline hunk))))
+	  (t
+	   (%primitive byte-blt string start buffer x dst-end)
+	   (setf (stream-hunk-point-x hunk) dst-end)))))
+
+;;; TTY-HUNK-STREAM-NEWLINE is the only place we display lines and affect
+;;; point-y.  We also blast out the buffer in HUNK-MISC.
+;;; 
+(defun tty-hunk-stream-newline (hunk)
+  (let* ((device (device-hunk-device hunk))
+	 (force-output-fun (device-force-output device))
+	 (y (stream-hunk-point-y hunk)))
+    (declare (fixnum y))
+    (when (= y (the fixnum (device-hunk-position hunk)))
+      (funcall (tty-device-display-string device) hunk 0 y "--More--" 0 8)
+      (when force-output-fun (funcall force-output-fun))
+      (wait-for-more)
+      (funcall (tty-device-clear-to-eow device) hunk 0 0)
+      (setf (stream-hunk-point-y hunk) 0)
+      (setf y 0))
+    (funcall (tty-device-display-string device)
+	     hunk 0 y (stream-hunk-buffer hunk) 0 (stream-hunk-point-x hunk))
+    (when force-output-fun (funcall force-output-fun))
+    (setf (stream-hunk-point-x hunk) 0)
+    (incf (stream-hunk-point-y hunk))))
diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e8ccd4b874fae984767396c89460106337c5f4fa
--- /dev/null
+++ b/tools/hemcom.lisp
@@ -0,0 +1,149 @@
+;;;
+;;; This file compiles all of Hemlock.
+;;;
+
+(when (ext:get-command-line-switch "slave")
+  (error "Cannot compile Hemlock in a slave due to its clobbering needed
+	  typescript routines by renaming the package."))
+
+
+;;; Blast the old packages in case they are around.  We do this solely to
+;;; prove Hemlock can compile cleanly without its having to exist already.
+;;;
+(when (find-package "ED")
+  (rename-package (find-package "ED") "OLD-ED"))
+;;;
+(when (find-package "HI")
+  (rename-package (find-package "HI") "OLD-HI"))
+
+
+;;; Stuff to set up the packages Hemlock uses.
+;;;
+(in-package "HEMLOCK-INTERNALS"
+	    :nicknames '("HI")
+	    :use '("LISP" "EXTENSIONS" "SYSTEM"))
+;;;
+(in-package "HEMLOCK"
+	    :nicknames '("ED")
+	    :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM"))
+;;;
+(in-package "SYSTEM")
+(export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute
+		       %sp-reverse-find-character-with-attribute))
+
+(in-package "HEMLOCK-INTERNALS")
+
+
+(pushnew :command-bits *features*)
+(pushnew :buffered-lines *features*)
+
+(defparameter the-log-file "hem:lossage.log")
+
+(when (probe-file the-log-file)
+  (delete-file the-log-file))
+
+(defun cf (file)
+  (write-line file)
+  (finish-output nil)
+  (let ((*error-output* (open the-log-file
+			      :direction :output 
+			      :if-exists :append
+			      :if-does-not-exist :create)))
+    (unwind-protect
+	(progn
+	  (compile-file file :error-file nil)
+	  (terpri *error-output*) (terpri *error-output*))
+      (close *error-output*))))
+
+(cf "hem:struct.lisp")
+(cf "hem:struct-ed.lisp")
+(cf "hem:rompsite.lisp")
+(cf "hem:charmacs.lisp")
+;; keytran and keytrandefs used to be in rompsite, but they are too big now.
+;; They also need to go after charmacs due to the funny characters named.
+(cf "hem:keytran.lisp")
+(cf "hem:keytrandefs.lisp")
+(cf "hem:macros.lisp")
+(cf "hem:line.lisp")
+(cf "hem:ring.lisp")
+(cf "hem:table.lisp")
+(cf "hem:htext1.lisp")
+(cf "hem:htext2.lisp")
+(cf "hem:htext3.lisp")
+(cf "hem:htext4.lisp")
+(cf "hem:search1.lisp")
+(cf "hem:search2.lisp")
+(cf "hem:linimage.lisp")
+(cf "hem:cursor.lisp")
+(cf "hem:syntax.lisp")
+(cf "hem:winimage.lisp")
+(cf "hem:hunk-draw.lisp")
+;(cf "hem:bit-stream.lisp")
+(cf "hem:termcap.lisp")
+(cf "hem:display.lisp")
+(cf "hem:bit-display.lisp")
+(cf "hem:tty-disp-rt.lisp")
+(cf "hem:tty-display.lisp")
+;(cf "hem:tty-stream.lisp")
+(cf "hem:pop-up-stream.lisp")
+(cf "hem:screen.lisp")
+(cf "hem:bit-screen.lisp")
+(cf "hem:tty-screen.lisp")
+(cf "hem:window.lisp")
+(cf "hem:font.lisp")
+(cf "hem:interp.lisp")
+(cf "hem:vars.lisp")
+(cf "hem:buffer.lisp")
+(cf "hem:files.lisp")
+(cf "hem:streams.lisp")
+(cf "hem:echo.lisp")
+(cf "hem:main.lisp")
+(cf "hem:echocoms.lisp")
+(cf "hem:defsyn.lisp")
+(cf "hem:command.lisp")
+(cf "hem:morecoms.lisp")
+(cf "hem:undo.lisp")
+(cf "hem:killcoms.lisp")
+(cf "hem:searchcoms.lisp")
+(cf "hem:filecoms.lisp")
+(cf "hem:indent.lisp")
+(cf "hem:lispmode.lisp")
+(cf "hem:comments.lisp")
+(cf "hem:fill.lisp")
+(cf "hem:text.lisp")
+(cf "hem:doccoms.lisp")
+(cf "hem:srccom.lisp")
+(cf "hem:group.lisp")
+(cf "hem:spell-rt.lisp")
+(cf "hem:spell-corr.lisp")
+(cf "hem:spell-aug.lisp")
+(cf "hem:spell-build.lisp")
+(cf "hem:spellcoms.lisp")
+(cf "hem:abbrev.lisp")
+(cf "hem:overwrite.lisp")
+(cf "hem:gosmacs.lisp")
+(cf "hem:ts-buf.lisp")
+(cf "hem:ts-stream.lisp")
+(cf "hem:eval-server.lisp")
+(cf "hem:lispbuf.lisp")
+(cf "hem:lispeval.lisp")
+(cf "hem:kbdmac.lisp")
+(cf "hem:icom.lisp")
+(cf "hem:hi-integrity.lisp")
+(cf "hem:ed-integrity.lisp")
+(cf "hem:scribe.lisp")
+(cf "hem:pascal.lisp")
+(cf "hem:edit-defs.lisp")
+(cf "hem:auto-save.lisp")
+(cf "hem:register.lisp")
+(cf "hem:xcoms.lisp")
+(cf "hem:unixcoms.lisp")
+(cf "hem:mh.lisp")
+(cf "hem:highlight.lisp")
+(cf "hem:dired.lisp")
+(cf "hem:diredcoms.lisp")
+(cf "hem:bufed.lisp")
+(cf "hem:lisp-lib.lisp")
+(cf "hem:completion.lisp")
+(cf "hem:shell.lisp")
+(cf "hem:bindings.lisp")