From c7695f15d9076a04fc482f908d82b951f0fc67c8 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Fri, 31 Jan 1992 14:28:15 +0000
Subject: [PATCH] Initial revision

---
 clim/coordinate-sorted-set.lisp           |  240 +++
 clim/genera-activities.lisp               |   94 +
 clim/item-list-manager.lisp               |   96 +
 clim/prefill.lisp                         | 1543 +++++++++++++++
 clim/text-style.lisp                      |  659 +++++++
 demo/browser.lisp                         | 1383 +++++++++++++
 misc/pixmaps.lisp                         |  425 ++++
 pre-silica/cloe-applications.lisp         |   24 +
 pre-silica/cloe-events.lisp               |  291 +++
 pre-silica/cloe-implementation.lisp       | 1035 ++++++++++
 pre-silica/clx-implementation.lisp        | 1586 +++++++++++++++
 pre-silica/default-application.lisp       |  204 ++
 pre-silica/define-application.lisp        | 1287 +++++++++++++
 pre-silica/defs-graphics-generics.lisp    |  504 +++++
 pre-silica/drawing-state-mixin.lisp       |  165 ++
 pre-silica/genera-implementation.lisp     | 1873 ++++++++++++++++++
 pre-silica/graphics-generics.lisp         |  387 ++++
 pre-silica/graphics-internals.lisp        |  427 ++++
 pre-silica/laserwriter-metrics.lisp       | 2145 +++++++++++++++++++++
 pre-silica/postscript-implementation.lisp | 1211 ++++++++++++
 pre-silica/protocol-intermediaries.lisp   |   98 +
 pre-silica/vertical-string.lisp           |   45 +
 pre-silica/wheader.lisp                   | 1634 ++++++++++++++++
 pre-silica/window-protocol.lisp           |  500 +++++
 pre-silica/windows.lisp                   | 1334 +++++++++++++
 utils/ccl-streams.lisp                    |   16 +
 utils/cl-stream-classes.lisp              |   77 +
 utils/cl-stream-functions.lisp            |  197 ++
 utils/clim-macros.lisp                    |  123 ++
 utils/clim-streams.lisp                   |   24 +
 utils/coral-char-bits.lisp                |   44 +
 utils/genera-streams.lisp                 |  116 ++
 utils/lisp-package-fixups.lisp            |   69 +
 utils/minima-stream-classes.lisp          |   39 +
 utils/processes.lisp                      |  259 +++
 35 files changed, 20154 insertions(+)
 create mode 100644 clim/coordinate-sorted-set.lisp
 create mode 100644 clim/genera-activities.lisp
 create mode 100644 clim/item-list-manager.lisp
 create mode 100644 clim/prefill.lisp
 create mode 100644 clim/text-style.lisp
 create mode 100644 demo/browser.lisp
 create mode 100644 misc/pixmaps.lisp
 create mode 100644 pre-silica/cloe-applications.lisp
 create mode 100644 pre-silica/cloe-events.lisp
 create mode 100644 pre-silica/cloe-implementation.lisp
 create mode 100644 pre-silica/clx-implementation.lisp
 create mode 100644 pre-silica/default-application.lisp
 create mode 100644 pre-silica/define-application.lisp
 create mode 100644 pre-silica/defs-graphics-generics.lisp
 create mode 100644 pre-silica/drawing-state-mixin.lisp
 create mode 100644 pre-silica/genera-implementation.lisp
 create mode 100644 pre-silica/graphics-generics.lisp
 create mode 100644 pre-silica/graphics-internals.lisp
 create mode 100644 pre-silica/laserwriter-metrics.lisp
 create mode 100644 pre-silica/postscript-implementation.lisp
 create mode 100644 pre-silica/protocol-intermediaries.lisp
 create mode 100644 pre-silica/vertical-string.lisp
 create mode 100644 pre-silica/wheader.lisp
 create mode 100644 pre-silica/window-protocol.lisp
 create mode 100644 pre-silica/windows.lisp
 create mode 100644 utils/ccl-streams.lisp
 create mode 100644 utils/cl-stream-classes.lisp
 create mode 100644 utils/cl-stream-functions.lisp
 create mode 100644 utils/clim-macros.lisp
 create mode 100644 utils/clim-streams.lisp
 create mode 100644 utils/coral-char-bits.lisp
 create mode 100644 utils/genera-streams.lisp
 create mode 100644 utils/lisp-package-fixups.lisp
 create mode 100644 utils/minima-stream-classes.lisp
 create mode 100644 utils/processes.lisp

diff --git a/clim/coordinate-sorted-set.lisp b/clim/coordinate-sorted-set.lisp
new file mode 100644
index 00000000..1396cf43
--- /dev/null
+++ b/clim/coordinate-sorted-set.lisp
@@ -0,0 +1,240 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: coordinate-sorted-set.lisp,v 1.4 91/03/26 12:47:48 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+;;; The output record generics:
+;;;  output-record-children: (record)
+;;;  add-output-record: (child record)
+;;;  delete-output-record: (child record)
+;;;  clear-output-record: (record)
+;;;  replay-output-record: (record stream)
+;;;  recompute-extent: (record)
+;;;  recompute-extent-for-new-child: (there's a default): (record child)
+;;;  recompute-extent-for-changed-child: (record child)
+;;;  map-over-output-records-overlapping-region:
+;;;   (function record region
+;;;    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+;;;  map-over-output-records-containing-point*:
+;;;   (function record x y
+;;;    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+
+(defclass standard-tree-output-record
+	  (output-record-mixin output-record-element-mixin output-record)
+    ((coordinate-sorted-set)			;a simple vector, by gawd
+     (fill-pointer :initform 0)
+     (tallest-box-height :initform 0)))
+
+(defmethod initialize-instance :after ((record standard-tree-output-record)
+				       &key (size 200))
+  (with-slots (coordinate-sorted-set) record
+    (setf coordinate-sorted-set (make-array size))))
+
+
+;; A top-level coordinate sorted set, used for CLIM windows by default
+(defclass standard-tree-output-history
+	  (stream-output-history-mixin standard-tree-output-record)
+    ())
+
+
+;;; For debugging.
+(defmethod output-record-children ((record standard-tree-output-record))
+  (with-slots (coordinate-sorted-set fill-pointer) record
+    (let ((result (make-list fill-pointer)))
+      (replace result coordinate-sorted-set :end1 fill-pointer :end2 fill-pointer)
+      result)))
+
+(defmethod output-record-element ((record standard-tree-output-record) index)
+  (with-slots (coordinate-sorted-set) record
+    (svref coordinate-sorted-set index)))
+
+(defmethod output-record-count ((record standard-tree-output-record))
+  (slot-value record 'fill-pointer))
+
+(defmethod clear-output-record ((record standard-tree-output-record))
+  (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record
+    (setf tallest-box-height 0)
+    ;; Release pointers to objects
+    (fill coordinate-sorted-set nil :start 0 :end fill-pointer)
+    (setf fill-pointer 0)))
+
+(defmethod add-output-record (child (record standard-tree-output-record))
+  (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record
+    (let ((vector coordinate-sorted-set)
+	  (fp fill-pointer))
+      (declare (type simple-vector vector) #+Genera (sys:array-register vector))
+      (declare (fixnum fp))
+      (maxf tallest-box-height (bounding-rectangle-height child))
+      (with-bounding-rectangle* (left top right bottom) child
+        (declare (ignore left top))
+	;; Quick check for doing output at the bottom of the window
+	(if (or (zerop fp)
+		(let ((other-child (svref vector (1- fp))))
+		  (when (eq other-child child)
+		    (return-from add-output-record nil))
+		  (with-bounding-rectangle* (other-left other-top other-right other-bottom)
+					    other-child
+		    (declare (ignore other-left other-top))
+		    (or (> bottom other-bottom)
+			(and (= bottom other-bottom) 
+			     (>= right other-right))))))
+	    (multiple-value-setq (coordinate-sorted-set fill-pointer)
+	      (simple-vector-push-extend child vector fp 200))
+	  (let ((index (coordinate-sorted-set-index-for-position
+			 vector right bottom 0 fp)))
+	    (declare (fixnum index))
+	    ;; Make sure that the new child comes after any child it overlaps
+	    ;; so that replaying happens in the right order.
+	    (loop
+	      (if (and (< index fp)
+		       (region-intersects-region-p child (svref vector index)))
+		  (incf index)
+		  (return)))
+	    (multiple-value-setq (coordinate-sorted-set fill-pointer)
+	      (simple-vector-insert-element child index vector fp 200))))))))
+
+(defmethod delete-output-record
+	   (child (record standard-tree-output-record) &optional (errorp t))
+  (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record
+    (let ((index (coordinate-sorted-set-position child coordinate-sorted-set fill-pointer)))
+      (cond (index
+	     (let ((new-fp (the fixnum (1- fill-pointer)))
+		   (vector coordinate-sorted-set))
+	       (declare (type simple-vector vector) (fixnum new-fp)
+			#+Genera (sys:array-register vector))
+	       (unless (= (the fixnum index) new-fp)
+		 ;; Shift the whole vector downward
+		 (do ((i (the fixnum index) (1+ i)))
+		     ((= i new-fp))
+		   (declare (fixnum i) (optimize (speed 3) (safety 0)))
+		   (setf (svref vector i) (svref vector (1+ i)))))
+	       (setf fill-pointer new-fp)
+	       t))
+	    (errorp
+	     (error "The output record ~S was not found in ~S" child record))))))
+
+(defmethod map-over-output-records-overlapping-region
+	   (function (record standard-tree-output-record) region
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (dynamic-extent function continuation-args))
+  (declare (type coordinate x-offset y-offset))
+  (declare (optimize (safety 0)))
+  (let ((vector (slot-value record 'coordinate-sorted-set))
+	(length (slot-value record 'fill-pointer)))
+    (declare (type simple-vector vector) (fixnum length)
+	     #+Genera (sys:array-register vector))
+    (if (or (null region) (eql region +everywhere+))
+	(dovector ((child index) vector :start 0 :end length :simple-p t)
+	  (apply function child continuation-args))
+      (with-bounding-rectangle* (left1 top1 right1 bottom1) region
+	(translate-fixnum-positions x-offset y-offset left1 top1 right1 bottom1)
+	(let ((start (coordinate-sorted-set-index-for-position vector 0 top1 0 length))
+	      (limit (+ bottom1 (slot-value record 'tallest-box-height))))
+	  (declare (fixnum start limit))
+	  ;; Subtract out the record offset from the region, to make comparison fair
+	  (multiple-value-bind (xoff yoff)
+	      (output-record-position* record)
+	    (translate-fixnum-positions (- xoff) (- yoff) left1 top1 right1 bottom1))
+	  (do ((index start (the fixnum (1+ (the fixnum index)))))
+	      ((= (the fixnum index) length))
+	    (declare (fixnum index))
+	    (let ((child (svref vector index)))
+	      (with-bounding-rectangle* (left2 top2 right2 bottom2) child
+		(when (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1
+					    left2 top2 right2 bottom2)
+		  (apply function child continuation-args))
+		(when (> bottom2 limit)
+		  (return nil))))))))))
+
+(defmethod map-over-output-records-containing-point*
+	   (function (record standard-tree-output-record) x y
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (dynamic-extent function continuation-args))
+  (declare (type coordinate x-offset y-offset))
+  (declare (optimize (safety 0)))
+  (translate-fixnum-positions x-offset y-offset x y)
+  (let ((vector (slot-value record 'coordinate-sorted-set))
+	(length (slot-value record 'fill-pointer))
+	(bound (slot-value record 'tallest-box-height)))
+    (declare (type simple-vector vector) (fixnum length bound)
+	     #+Genera (sys:array-register vector))
+    (let ((end (coordinate-sorted-set-index-for-position vector 0 (+ y bound 1) 0 length))
+	  (limit (- y bound)))
+      (declare (fixnum end limit))
+      (multiple-value-bind (xoff yoff)
+	  (output-record-position* record)
+	(translate-fixnum-positions (- xoff) (- yoff) x y))
+      (do ((index (min (1- length) end) (the fixnum (1- (the fixnum index)))))
+	  ((< (the fixnum index) 0))
+	(declare (fixnum index))
+	(let ((child (svref vector index)))
+	  (with-bounding-rectangle* (left top right bottom) child
+	    (when (ltrb-contains-point*-p left top right bottom x y)
+	      (apply function child continuation-args))
+	    (when (< bottom limit)
+	      (return nil))))))))
+
+;; Like POSITION, but searches coordinate sorted sets
+(defun coordinate-sorted-set-position (object vector fill-pointer)
+  (declare (type simple-vector vector) (fixnum fill-pointer))
+  (declare (optimize (speed 3) (safety 0)))
+  (with-bounding-rectangle* (left top right bottom) object
+    (declare (ignore left top))
+    ;; Binary search to find where this one goes.
+    (let ((search-index (coordinate-sorted-set-index-for-position
+			  vector right bottom 0 fill-pointer)))
+      (declare (fixnum search-index))
+      ;; Search back over things in the same place.
+      (when (< search-index fill-pointer)
+	(dovector ((record index) vector :start 0 :end (1+ search-index)
+					 :from-end t :simple-p t)
+	  (when (eq record object)
+	    (return-from coordinate-sorted-set-position index))
+	  (with-bounding-rectangle* (other-left other-top other-right other-bottom) record
+	    (declare (ignore other-left other-top))
+	    (unless (and (= right other-right) (= bottom other-bottom))
+	      (return)))))
+      ;; Search forward too.
+      (dovector ((record index) vector
+		 :start (if (< search-index fill-pointer) (1+ search-index) 0)
+		 :end fill-pointer :simple-p t)
+	(when (eq record object)
+	  (return index)
+	  (when (> (bounding-rectangle-bottom record) bottom)
+	    (return nil)))))))
+
+;; Binary search; dictionary order Y, X.
+(defun coordinate-sorted-set-index-for-position (vector right bottom start end)
+  (declare (type simple-vector vector) 
+	   (type fixnum start end)
+	   (type coordinate right bottom))
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((below start)
+	(above end))
+    (declare (fixnum below above))
+    (assert (<= below above))			;Binary search will loop otherwise.
+    (let (#+(or Genera Minima) (vector vector))
+      #+Genera (declare (sys:array-register vector))
+      #+Minima (declare (type vector vector))
+      (loop
+	(when (= above below)
+	  (return above))
+	(let* ((index (the fixnum (ash (the fixnum (+ above below)) -1)))
+	       (other-box (svref vector index)))
+	  (with-bounding-rectangle* (other-left other-top other-right other-bottom)
+				    other-box
+	    (declare (ignore other-left other-top))
+	    (cond ((or (< bottom other-bottom)
+		       (and (= bottom other-bottom) (< right other-right)))
+		   (setq above index))
+		  ((or (> bottom other-bottom)
+		       (and (= bottom other-bottom) (> right other-right)))
+		   (if (= below index)
+		       (return above)
+		       (setq below index)))
+		  (t
+		   (return index)))))))))
diff --git a/clim/genera-activities.lisp b/clim/genera-activities.lisp
new file mode 100644
index 00000000..373524f0
--- /dev/null
+++ b/clim/genera-activities.lisp
@@ -0,0 +1,94 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: genera-activities.lisp,v 1.4 91/03/26 12:47:58 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+(defvar *sheet-roots* nil)
+(defvar *deactivated-clim-activities* nil)
+
+(scl:defflavor clim-activity
+	(frame-name
+	 (frame-args nil))
+	(cli::basic-activity)
+  (:initable-instance-variables frame-name frame-args)
+  (:required-init-keywords :frame-name))
+
+(scl:defmethod (sys:select-activity clim-activity)
+	       (&key console superior force-create beep-if-only-one-selected)
+  (cli::find-frame-for-activity console superior
+    #'(lambda (clim-sheet)
+	(when (typep clim-sheet 'clim-sheet)
+	  (let* ((window (clim-window-for-host-window clim-sheet :error-if-no-match nil))
+		 (frame (and window (window-stream-to-frame window))))
+	    (and frame (eq (frame-name frame) frame-name)))))
+    #'(lambda (&rest init-keywords &key superior &allow-other-keys)
+	(let ((root (find superior *sheet-roots* :key #'(lambda (root)
+							  (slot-value root 'window)))))
+	  (unless root
+	    (setq root (open-root-window :sheet :screen superior))
+	    (push root *sheet-roots*))
+	  (let* ((frame (dolist (frame *deactivated-clim-activities*
+				       ;; Didn't find one, so make a new one
+				       (with-keywords-removed (init-keywords init-keywords
+							       '(:superior))
+					 (apply #'make-application-frame frame-name
+						:parent root
+						:pretty-name cli::description
+						(append init-keywords frame-args))))
+			  (when (eq (frame-name frame) frame-name)
+			    (let ((window (frame-top-level-sheet frame)))
+			      (when (eq (window-parent window) root)
+				(setq *deactivated-clim-activities*
+				      (delete frame *deactivated-clim-activities*))
+				(when (zerop (tv:sheet-dead (slot-value window 'window)))
+				  (return frame)))))))
+		 (window (frame-top-level-sheet frame))
+		 (clim-sheet (slot-value window 'window)))
+	    (stream-clear-input window)		;might have an Abort left in it
+	    (scl:process-run-function (frame-pretty-name frame)
+	      #'(lambda (frame clim-sheet)
+		  (setf (tv:io-buffer-last-output-process (scl:send clim-sheet :io-buffer))
+			scl:*current-process*)
+		  (unwind-protect (run-frame-top-level frame)
+		    (when (zerop (tv:sheet-dead clim-sheet))
+		      (push frame *deactivated-clim-activities*))))
+	      frame clim-sheet)
+	    clim-sheet)))
+    :select t
+    :force-create force-create
+    :beep-if-only-one-selected beep-if-only-one-selected))
+
+(scl:defmethod (cli::activity-frame-acceptable-p clim-activity) (clim-sheet)
+  (and (typep clim-sheet 'clim-sheet)
+       (let* ((window (clim-window-for-host-window clim-sheet :error-if-no-match nil))
+	      (frame (and window (window-stream-to-frame window))))
+	 (and frame
+	      (eql (frame-name frame) frame-name)))))
+
+(flavor:defmethod (x-screen::activity-acceptable-for-x-screen-p clim-activity) () t)
+
+(scl:compile-flavor-methods clim-activity)
+
+
+(defmacro define-genera-application (frame-name &rest keys
+				     &key pretty-name select-key
+					  ;; Default edges and size for the frame
+					  left top right bottom width height)
+  (declare (ignore left top right bottom width height))
+  (with-keywords-removed (keys keys '(:pretty-name :select-key))
+    `(define-genera-application-1
+       ',frame-name ',pretty-name ',select-key ',(copy-list keys))))
+
+(defun define-genera-application-1 (frame-name pretty-name select-key &optional frame-args)
+  (when (null pretty-name)
+    (setq pretty-name (command-name-from-symbol frame-name)))
+  (when (cli::define-activity 'clim-activity
+			      :name pretty-name
+			      :description pretty-name
+			      :frame-name frame-name
+			      :frame-args frame-args)
+    (when select-key
+      (sys:set-select-key-activity select-key pretty-name))))
diff --git a/clim/item-list-manager.lisp b/clim/item-list-manager.lisp
new file mode 100644
index 00000000..5f36ed61
--- /dev/null
+++ b/clim/item-list-manager.lisp
@@ -0,0 +1,96 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: item-list-manager.lisp,v 1.4 91/03/26 12:48:10 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1989, 1990 International Lisp Associates.  All rights reserved."
+
+(defclass item-list-manager ()
+     ((item-list :initarg :item-list :accessor ilm-item-list)
+      (display-record :initform nil))
+  (:default-initargs :item-list nil))
+
+(defmethod clear-items ((ilm item-list-manager))
+  (setf (slot-value ilm 'item-list) nil))
+
+(defmethod add-item ((ilm item-list-manager) new-item
+		     &key before-item after-item before-index after-index)
+  ;; Default is before 1st item
+  (unless (or before-item after-item before-index after-index)
+    (setq before-index 0))
+  ;;--- make sure that only one argument is supplied
+  (with-slots (item-list) ilm
+    (when before-item
+      (setq before-index (position before-item item-list))
+      (when (null before-index)
+	(error "Could not find :before-item ~S in item-list" before-item)))
+    (when after-item
+      (setq after-index (position after-item item-list))
+      (when (null after-index)
+	(error "Could not find :after-item ~S in item-list" after-item)))
+    (cond (before-index
+	   ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0
+	   #+Ignore
+	   (assert (< -1 before-index (max 1 (length item-list))) ()
+		   "The :before-index was ~D which is outside the bounds of the item-list"
+		   before-index)
+	   (if (= before-index 0)
+	       (push new-item item-list)
+	       (push new-item (cdr (nthcdr (1- before-index) item-list)))))
+	  (after-index
+	   ;; Check bounds, but allow for empty list (add first item either :before- or :after-index 0
+	   #+Ignore
+	   (assert (< -1 after-index (max 1 (length item-list))) ()
+		   "The :after-index was ~D which is outside the bounds of the item-list"
+		   after-index)
+	   (push new-item (cdr (nthcdr after-index item-list))))
+	  (t (error "Could not add item ~S to the item list." new-item)))))
+
+(defmethod delete-item ((ilm item-list-manager) item)
+  (with-slots (item-list) ilm
+    (let ((pos (position item item-list)))
+      (if pos
+	  (setf item-list (delete item item-list))
+	  (error "Could not find item ~S in item list" item)))))
+
+(defmethod append-item ((ilm item-list-manager) new-item)
+  (with-slots (item-list) ilm
+    (add-item ilm new-item :before-index (length item-list))))
+
+(defmethod delete-item-at-index ((ilm item-list-manager) index)
+  (with-slots (item-list) ilm
+    (assert (< -1 index (length item-list)) () 
+		   "The index was ~D which is outside the bounds of the item-list"
+		   index)
+    (setf item-list (append (subseq item-list 0 index)
+			    (nthcdr (1+ index) item-list)))))
+
+(defmethod map-over-items ((ilm item-list-manager) function)
+  (dolist (item (slot-value ilm 'item-list))
+    (funcall function item)))
+
+;;; This is sort of kludgy.  We really need to keep a per-stream cache of display-records.
+(defmethod display-items ((ilm item-list-manager) stream
+			  &key incrementally (printer #'write-string))
+  (if incrementally
+      (display-items-incrementally ilm stream :printer printer)
+      (with-slots (display-record item-list) ilm
+	(dolist (item item-list)
+	  (funcall printer item stream)
+	  (terpri stream)))))
+
+(defmethod display-items-incrementally ((ilm item-list-manager) stream
+					&key (printer #'write-string))
+  (with-slots (display-record item-list) ilm
+    (setq display-record (updating-output (stream)
+			   (dolist (item item-list)
+			     (updating-output (stream :unique-id item :cache-value t)
+			       (funcall printer item stream)
+			       (terpri stream)))))))
+
+(defmethod redisplay-items ((ilm item-list-manager) stream)
+  (with-slots (display-record) ilm
+    (unless display-record
+      (error "You must use display-items with the :incrementally option to use redisplay"))
+    (redisplay display-record stream)))
diff --git a/clim/prefill.lisp b/clim/prefill.lisp
new file mode 100644
index 00000000..6bbf0b7a
--- /dev/null
+++ b/clim/prefill.lisp
@@ -0,0 +1,1543 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: prefill.lisp,v 1.4 91/03/26 12:48:29 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; This file prefills generic function dispatch caches at load time so that
+;;; there won't be so much delay starting things up the first time the application
+;;; is run.
+
+;;; The first page of this file contains commented-out functions for gathering the
+;;; necessary information.  The second page contains the prefill mechanism.  The
+;;; third page contains calls to the prefill mechanism, generated by running the
+;;; commented-out functions after running the usual CLIM demos on both Genera and
+;;; Cloe, in CLIM 13.x, and then manually massaging the results.  The file
+;;; CLIM:DEMO;DEMO-PREFILL contains additional prefills specific to the demos.
+
+
+#||
+
+;; Exercise the system with a synthetic load (i.e. run demos) and then
+;; call this function to produce calls to PREFILL-DISPATCH-CACHES
+;; corresponding to what has actually been called.  You can also call
+;; the function GENERATE-PREFILL-DISPATCH-CACHES on whatever classes you
+;; deem interesting.  This only works in Symbolics Genera and Cloe.
+
+(defun generate-all-prefill-dispatch-caches (&optional file)
+  (if file
+      (with-open-file (*standard-output* file :direction :output)
+	(generate-all-prefill-dispatch-caches))
+      (let ((*print-pretty* t)
+	    (*print-length* nil)
+	    (*print-level* nil))
+	(dolist (base-class '(transformation
+			      ;; This gets us all kinds of windows and output records, too
+			      design
+			      line-style
+			      text-style
+			      device-font
+			      ;; WINDOW-STREAM stuff gets listed twice, but we
+			      ;; need ACCEPT-VALUES-STREAM, STANDARD-INPUT-EDITING-STREAM, etc.
+			      fundamental-stream
+			      pointer
+			      console
+			      device-event
+			      view
+			      basic-history
+			      application-frame
+			      command-table
+			      noise-string
+			      display-device
+			      io-buffer
+			      queue
+			      cursor
+			      accept-values-query
+			      presentation-translator))
+	  (format t "~2%;;; ~(~S~)~2%~S"
+		  `(generate-prefill-dispatch-caches ',base-class)
+		  (generate-prefill-dispatch-caches base-class)))
+	;; This is only the presentation types that I think all applications use
+	(dolist (base-class '(command command-name command-arguments keyword-argument-name
+			      command-or-form expression 
+			      command-menu-element menu-item
+			      completion subset-completion sequence null blank-area))
+	  (format t "~2%;;; ~(~S~)~2%~S"
+		  `(generate-prefill-dispatch-caches
+		     (find-presentation-type-class ',base-class))
+		  (generate-prefill-dispatch-caches
+		    (find-presentation-type-class base-class)))))))
+
+(defun generate-prefill-dispatch-caches (class-name)
+  (let ((generic-functions nil)
+	(classes nil))
+    (clos-internals::map-over-class-and-its-subclasses class-name
+      #'(lambda (class)
+	  (pushnew (class-name class) classes)
+	  (clos-internals::map-over-dispatch-table
+	    #'(lambda (selector handler extra-argument)
+		(typecase selector
+		  (cons
+		    (pushnew (first selector) generic-functions))
+		  (clos-internals::generic-function-selector
+		    (when (clos-internals::generic-function-clos selector)
+		      (pushnew (clos-internals::funcallable-instance-from-generic-selector
+				 selector)
+			       generic-functions)))
+		  (otherwise))
+		(values selector handler extra-argument))
+	    (clos-internals::%instance-information-dispatch-table
+	      (clos-internals::class-instance-information class)))))
+    (setq generic-functions (sort generic-functions
+				  #'(lambda (x y)
+				      (setq x (clos:generic-function-name x)
+					    y (clos:generic-function-name y))
+				      (let ((xx (if (atom x) x (second x)))
+					    (yy (if (atom y) y (second y))))
+					(if (eq xx yy)
+					    (or (atom x)
+						(and (consp y)
+						     (string<= (first x) (first y))))
+					    (string<= xx yy))))))
+    `(prefill-dispatch-caches
+      ,@(mapcar
+	 #'(lambda (generic-function)
+	     (let ((nargs
+		    (length (clos-internals::dispatching-funcallable-instance-precedence-order
+			      generic-function)))
+		   (calls nil))
+	       (labels ((mapper (dispatch handler extra-argument state &rest arguments)
+			  (declare (dynamic-extent arguments))
+			  (ecase (clos-internals::dispatch-type dispatch)
+			    (clos-internals::class-dispatch
+			      (apply #'clos-internals::generic-function-map-over-dispatch
+				     generic-function handler extra-argument state
+				     #'mapper
+				     (clos-internals::class-dispatch-position dispatch)
+				     (class-name
+				       (clos-internals::class-dispatch-class dispatch))
+				     arguments))
+			    (clos-internals::eql-dispatch
+			      (let ((key-or-nil
+				      (clos-internals::eql-dispatch-key-or-nil dispatch)))
+				(when key-or-nil
+				  (apply #'clos-internals::generic-function-map-over-dispatch
+					 generic-function handler extra-argument state
+					 #'mapper
+					 (clos-internals::eql-dispatch-position dispatch)
+					 `(eql ,(cond ((eq key-or-nil +foreground-ink+)
+						       `+foreground-ink+)
+						      ((eq key-or-nil +background-ink+)
+						       `+background-ink+)
+						      ((eq key-or-nil +everywhere+)
+						       `+everywhere+)
+						      ((eq key-or-nil +nowhere+)
+						       `+nowhere+)
+						      ((eq key-or-nil +flipping-ink+)
+						       `+flipping-ink+)
+						      ((typep key-or-nil '(or number
+									      character
+									      (member t nil)
+									      keyword))
+						       key-or-nil)
+						      (t `',key-or-nil)))
+					 arguments))))
+			      (clos-internals::finish-dispatch
+				(when (do ((l arguments (cddr l)))
+					  ((null l) nil)
+					(when (member (second l) classes)
+					  (return t)))
+				  (pushnew (do ((i (1- nargs) (1- i))
+						(l nil))
+					       ((< i 0) l)
+					     (push (getf arguments i 't) l))
+					   calls :test #'equal))))
+			    (values handler extra-argument)))
+		   (clos-internals::map-over-generic-function-computed-dispatches
+		     generic-function #'mapper)
+		   `(,(clos:generic-function-name generic-function)
+		     ,@calls))))
+	   generic-functions))))
+||#
+
+;;; Prefill dispatch caches for a bunch of generic function calls
+(defmacro prefill-dispatch-caches (&body clauses &environment env)
+  (let (function)
+    (labels ((expand-clause (clause)
+	       (setq function (car clause))
+	       (unless (clos-internals::fboundp-in-environment function env)
+		 #+++ignore	;until we fix CLOS
+		 (warn "prefill-dispatch-caches: ~S is not a defined generic function."
+		       function))
+	       (mapcan #'expand-call (cdr clause)))
+	     (expand-call (args)
+	       (dolist (arg args)
+		 (unless (cond ((atom arg) (find-class arg nil env))
+			       ((eq (first arg) 'eql) t)
+			       ((eq (first arg) 'presentation-type)
+				(find-presentation-type-class (second arg) nil env)))
+		   #+++ignore	;until we fix CLOS
+		   (warn "prefill-dispatch-caches: ~S is not a valid specializer in the ~
+			  arguments to ~S."
+			 arg function)))
+	       `(',function
+		 ,(if (some #'needs-evaluation args)
+		      `(list ,@(mapcar #'(lambda (arg)
+					   (if (and (consp arg) (eq (first arg) 'eql))
+					       ``(eql ,,(second arg))
+					       ``,',arg))
+				       args))
+		      `',(mapcar #'(lambda (arg)
+				     (if (and (consp arg) (eq (first arg) 'eql))
+					 `(eql ,(eval (second arg)))
+					 arg))
+				 args))))
+	     (needs-evaluation (arg)
+	       (and (consp arg)
+		    (eq (first arg) 'eql)
+		    (not (if (consp (second arg))
+			     (eq (first (second arg)) 'quote)
+			     (typep (second arg)
+				    '(or number character keyword (member t nil))))))))
+      `(prefill-dispatch-caches-1
+	 ,@(mapcan #'expand-clause clauses)))))
+
+(defun prefill-dispatch-caches-1 (&rest calls)
+  (declare (dynamic-extent calls))
+  (dorest (calls calls cddr)
+    (let ((generic-function
+	    (and (clos-internals::fboundp-in-environment (first calls) nil)
+		 (clos-internals::fdefinition-in-environment (first calls) nil)))
+	  (arguments (mapcar #'(lambda (arg)
+				 (setq arg (cond ((atom arg) (find-class arg))
+						 ((eq (first arg) 'eql) arg)
+						 ((eq (first arg) 'presentation-type)
+						  (find-presentation-type-class (second arg)))
+						 (t
+						  (error "Invalid argument specification: ~S"
+							 arg))))
+				 (when (typep arg 'class)
+				   (unless (clos-internals::class-finalized-p arg)
+				     (clos-internals::finalize-inheritance arg)))
+				 arg)
+			     (second calls))))
+      (unless (typep generic-function 'generic-function)
+	(error "~S is not a defined generic function." (first calls)))
+      #+Symbolics				;Symbolics CLOS, that is
+      (clos-internals::generic-function-ensure-specializers-mapped
+	generic-function arguments #'clos-internals::standard-method-combiner)
+      #-Symbolics
+      (error "I don't know how to prefill generic function dispatch caches except in Symbolics CLOS"))))
+
+
+;;; This page contains the non-demo-specific results after running the demos in
+;;; both Genera and Cloe.  Some things have been commented out since they didn't
+;;; seem important, machine-dependent things have been conditionalized, and
+;;; demo-specific things have been moved to the demo specific file.  Otherwise
+;;; the only hand-massaging was to standardize the pretty printing and remove
+;;; some duplicate entries and things only used when printing internal objects.
+
+;;; (generate-prefill-dispatch-caches 'transformation)
+
+(PREFILL-DISPATCH-CACHES
+  (COMPOSE-TRANSFORMATIONS
+    (IDENTITY-TRANSFORMATION STANDARD-TRANSFORMATION)
+    (IDENTITY-TRANSFORMATION TRANSLATION-TRANSFORMATION)
+    (TRANSLATION-TRANSFORMATION STANDARD-TRANSFORMATION)
+    (STANDARD-TRANSFORMATION TRANSLATION-TRANSFORMATION)
+    (STANDARD-TRANSFORMATION STANDARD-TRANSFORMATION)
+    (STANDARD-TRANSFORMATION IDENTITY-TRANSFORMATION)) 
+  #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (TRANSLATION-TRANSFORMATION T)
+					       (IDENTITY-TRANSFORMATION T)
+					       (STANDARD-TRANSFORMATION T))
+  (RECTILINEAR-TRANSFORMATION-P (IDENTITY-TRANSFORMATION) 
+				(STANDARD-TRANSFORMATION)) 
+  (TRANSFORM-DISTANCE (STANDARD-TRANSFORMATION T T) 
+		      (IDENTITY-TRANSFORMATION T T)) 
+  (TRANSFORM-POINT* (IDENTITY-TRANSFORMATION T T) 
+		    (STANDARD-TRANSFORMATION T T)))
+
+
+;;; (generate-prefill-dispatch-caches 'design)
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-1
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-ADD-CHARACTER-OUTPUT
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (ADD-CHARACTER-OUTPUT-TO-TEXT-RECORD
+    (STANDARD-TEXT-OUTPUT-RECORD T T T T T)
+    (STYLED-TEXT-OUTPUT-RECORD T T T T T))
+  (STREAM-ADD-OUTPUT-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (ADD-OUTPUT-RECORD (T STANDARD-CELL-OUTPUT-RECORD)
+		     (T STANDARD-PRESENTATION)
+		     (T STANDARD-ITEM-LIST-OUTPUT-RECORD)
+		     (T STANDARD-SEQUENCE-OUTPUT-RECORD)
+		     (T STANDARD-TREE-OUTPUT-HISTORY)
+		     (T STANDARD-UPDATING-OUTPUT-RECORD)
+		     (T ACCEPT-VALUES-OUTPUT-RECORD)
+		     (T STANDARD-ROW-OUTPUT-RECORD)
+		     (T BORDER-OUTPUT-RECORD)
+		     (T STANDARD-TABLE-OUTPUT-RECORD))
+  (STREAM-ADD-STRING-OUTPUT
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T))
+  (ADD-STRING-OUTPUT-TO-TEXT-RECORD
+    (STANDARD-TEXT-OUTPUT-RECORD T T T T T T T)
+    (STYLED-TEXT-OUTPUT-RECORD T T T T T T T))
+  (ADJUST-TABLE-CELLS (STANDARD-ITEM-LIST-OUTPUT-RECORD) (STANDARD-TABLE-OUTPUT-RECORD) (STANDARD-ROW-OUTPUT-RECORD))
+  (BOUNDING-RECTANGLE*
+    #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+    #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+    #+Genera (SHEET-WINDOW-STREAM)
+    #+Minima (CLX-WINDOW)
+    (STANDARD-BOUNDING-RECTANGLE)
+    (STANDARD-SEQUENCE-OUTPUT-RECORD)
+    (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+    (STANDARD-PRESENTATION)
+    (STANDARD-CELL-OUTPUT-RECORD)
+    (STANDARD-TEXT-OUTPUT-RECORD)
+    (STYLED-TEXT-OUTPUT-RECORD)
+    (STANDARD-TREE-OUTPUT-HISTORY)
+    (POLYGON-DISPLAYED-OUTPUT-RECORD)
+    (ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+    (LINE-DISPLAYED-OUTPUT-RECORD)
+    (RECTANGLE-DISPLAYED-OUTPUT-RECORD)
+    (STRING-DISPLAYED-OUTPUT-RECORD)
+    (STANDARD-UPDATING-OUTPUT-RECORD)
+    (ACCEPT-VALUES-OUTPUT-RECORD)
+    (STANDARD-POINT)
+    (STANDARD-TABLE-OUTPUT-RECORD)
+    (BORDER-OUTPUT-RECORD)
+    (STANDARD-ROW-OUTPUT-RECORD))
+  (BOUNDING-RECTANGLE-SET-EDGES
+    (STANDARD-SEQUENCE-OUTPUT-RECORD T T T T)
+    (STANDARD-ITEM-LIST-OUTPUT-RECORD T T T T)
+    (STANDARD-PRESENTATION T T T T)
+    (STANDARD-CELL-OUTPUT-RECORD T T T T)
+    (STANDARD-TEXT-OUTPUT-RECORD T T T T)
+    (STYLED-TEXT-OUTPUT-RECORD T T T T)
+    (STANDARD-TREE-OUTPUT-HISTORY T T T T)
+    #+Cloe-Runtime (CLOE-ROOT-WINDOW T T T T) 
+    #+Cloe-Runtime (CLOE-WINDOW-STREAM T T T T)
+    #+Genera (SHEET-WINDOW-STREAM T T T T)
+    #+Minima (CLX-WINDOW T T T T)
+    (POLYGON-DISPLAYED-OUTPUT-RECORD T T T T)
+    (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T T T)
+    (LINE-DISPLAYED-OUTPUT-RECORD T T T T)
+    (RECTANGLE-DISPLAYED-OUTPUT-RECORD T T T T)
+    (STRING-DISPLAYED-OUTPUT-RECORD T T T T)
+    (STANDARD-UPDATING-OUTPUT-RECORD T T T T)
+    (ACCEPT-VALUES-OUTPUT-RECORD T T T T)
+    (STANDARD-TABLE-OUTPUT-RECORD T T T T)
+    (BORDER-OUTPUT-RECORD T T T T)
+    (STANDARD-ROW-OUTPUT-RECORD T T T T))
+  (BOUNDING-RECTANGLE-SET-POSITION*
+    (STANDARD-TREE-OUTPUT-HISTORY T T)
+    (STANDARD-CELL-OUTPUT-RECORD T T)
+    (STANDARD-BOUNDING-RECTANGLE T T)
+    #+Cloe-Runtime (CLOE-ROOT-WINDOW T T) 
+    #+Cloe-Runtime (CLOE-WINDOW-STREAM T T)
+    #+Genera (SHEET-WINDOW-STREAM T T)
+    #+Minima (CLX-WINDOW T T)
+    (STANDARD-TEXT-OUTPUT-RECORD T T)
+    (STYLED-TEXT-OUTPUT-RECORD T T)
+    (STANDARD-PRESENTATION T T)
+    (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T)
+    (LINE-DISPLAYED-OUTPUT-RECORD T T))
+  (BOUNDING-RECTANGLE-SET-SIZE
+    (STANDARD-TEXT-OUTPUT-RECORD T T)
+    (STYLED-TEXT-OUTPUT-RECORD T T)
+    #+Cloe-Runtime (CLOE-ROOT-WINDOW T T)
+    #+Cloe-Runtime (CLOE-WINDOW-STREAM T T)
+    #+Genera (SHEET-WINDOW-STREAM T T)
+    #+Minima (CLX-WINDOW T T)
+    (STANDARD-BOUNDING-RECTANGLE T T))
+  (CACHE-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T))
+  (CLEAR-OUTPUT-HISTORY 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (CLEAR-OUTPUT-RECORD (STANDARD-TREE-OUTPUT-HISTORY)
+                       (STANDARD-UPDATING-OUTPUT-RECORD)
+                       (ACCEPT-VALUES-OUTPUT-RECORD)
+                       (STANDARD-PRESENTATION)
+                       (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                       (STANDARD-CELL-OUTPUT-RECORD))
+  #+Cloe-Runtime (CLOE-PROCESS-DEFERRED-EVENTS (CLOE-WINDOW-STREAM)) 
+  #+Cloe-Runtime (CLOE-RECOMPUTE-SCROLL-BARS (CLOE-WINDOW-STREAM)) 
+  (STREAM-CLOSE-TEXT-OUTPUT-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (COLOR-RGB (GRAY-COLOR) (RGB-COLOR))
+  (COMPUTE-DIFFERENCES (STANDARD-UPDATING-OUTPUT-RECORD)
+                       (ACCEPT-VALUES-OUTPUT-RECORD)
+                       (STANDARD-PRESENTATION)
+                       (STANDARD-TEXT-OUTPUT-RECORD)
+                       (STYLED-TEXT-OUTPUT-RECORD)
+                       (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                       (STANDARD-CELL-OUTPUT-RECORD)
+                       (ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+                       (LINE-DISPLAYED-OUTPUT-RECORD))
+  (COPY-AREA
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T))
+  (COPY-DISPLAY-STATE (STANDARD-UPDATING-OUTPUT-RECORD T)
+                      (ACCEPT-VALUES-OUTPUT-RECORD T)
+                      (STANDARD-PRESENTATION T)
+                      (STANDARD-ITEM-LIST-OUTPUT-RECORD T)
+                      (STANDARD-CELL-OUTPUT-RECORD T))
+  #+Cloe-Runtime (DC-IMAGE-FOR-INK (T GRAY-COLOR) 
+				   (T FLIPPING-INK) 
+				   (T RGB-COLOR) 
+				   (T (EQL +BLACK+)) 
+				   (T (EQL +WHITE+)) 
+				   (T (EQL +FOREGROUND-INK+)) 
+				   (T (EQL +BACKGROUND-INK+)))
+  (DECACHE-INFERIOR-OUTPUT-RECORD (ACCEPT-VALUES-OUTPUT-RECORD T T)
+                                  (STANDARD-ITEM-LIST-OUTPUT-RECORD T T)
+                                  (STANDARD-UPDATING-OUTPUT-RECORD T T))
+  (DECODE-FLIPPING-INK (FLIPPING-INK))
+  (DECODE-PATTERN (PATTERN))
+  (DECODE-RECTANGULAR-TILE (RECTANGULAR-TILE))
+  (DECODE-STREAM-FOR-WRITING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (DELETE-OUTPUT-RECORD (T ACCEPT-VALUES-OUTPUT-RECORD)
+			(T STANDARD-TREE-OUTPUT-HISTORY)
+			(T STANDARD-SEQUENCE-OUTPUT-RECORD))
+  (DO-TEXT-SCREEN-REAL-ESTATE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T))
+  (DRAW-ELLIPSE-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T T T))
+  (DRAW-ELLIPSE-METHOD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T))
+  (DRAW-LINE-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T))
+  (DRAW-LINE-METHOD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T))
+  (DRAW-POLYGON-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T))
+  (DRAW-POLYGON-METHOD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T))
+  (DRAW-RECTANGLE-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T))
+  (DRAW-RECTANGLE-METHOD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (DRAW-STRING-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T T T T))
+  (DRAW-STRING-METHOD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T)))
+
+(PREFILL-DISPATCH-CACHES
+  (DRAWING-SURFACE-TO-VIEWPORT-COORDINATES
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (INFERIORS-NEVER-OVERLAP-P (STANDARD-UPDATING-OUTPUT-RECORD)
+			     (STANDARD-PRESENTATION)
+			     (STANDARD-SEQUENCE-OUTPUT-RECORD)
+			     (STANDARD-CELL-OUTPUT-RECORD))
+  (ENCODE-STREAM-AFTER-WRITING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T))
+  (EXTENDED-OUTPUT-STREAM-P #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+			    #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+			    #+Genera (SHEET-WINDOW-STREAM)
+			    #+Minima (CLX-WINDOW))
+  (FIND-CACHED-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T))
+  (FIND-INFERIOR-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T)
+                               (STANDARD-PRESENTATION T T)
+                               (STANDARD-CELL-OUTPUT-RECORD T T))
+  (FIND-QUERY (ACCEPT-VALUES-OUTPUT-RECORD T))
+  (INVOKE-FORMATTING-CELL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+
+  (GET-TEXT-OUTPUT-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STYLIZE-TEXT-OUTPUT-RECORD
+    (STANDARD-TEXT-OUTPUT-RECORD T T))
+  (GRAPHICS-STREAM-P
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (HIGHLIGHT-OUTPUT-RECORD-1 (STANDARD-PRESENTATION T T)
+			     (STANDARD-TEXT-OUTPUT-RECORD T T)
+			     (STYLED-TEXT-OUTPUT-RECORD T T))
+  (HOST-WINDOW-MARGINS #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		       #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		       #+Genera (SHEET-WINDOW-STREAM)
+		       #+Minima (CLX-WINDOW))
+  (INCREMENTAL-REDISPLAY
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T))
+  (INFERIOR-OUTPUT-RECORD-CHANGED (STANDARD-TREE-OUTPUT-HISTORY T T T T T))
+  (INITIALIZE-MENU 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (INPUT-EDITING-STREAM-P 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MAKE-GRAY-COLOR-FOR-CONTRASTING-INK (CONTRASTING-INK))
+  (MAP-OVER-MENU-CELLS (STANDARD-ITEM-LIST-OUTPUT-RECORD T))
+  (MAP-OVER-OUTPUT-RECORDS-CONTAINING-POINT*
+    (T STANDARD-TREE-OUTPUT-HISTORY T T)
+    (T STANDARD-SEQUENCE-OUTPUT-RECORD T T)
+    (T STANDARD-ITEM-LIST-OUTPUT-RECORD T T)
+    (T STANDARD-PRESENTATION T T)
+    (T STANDARD-CELL-OUTPUT-RECORD T T)
+    (T STANDARD-TEXT-OUTPUT-RECORD T T)
+    (T STYLED-TEXT-OUTPUT-RECORD T T)
+    (T STANDARD-UPDATING-OUTPUT-RECORD T T)
+    (T STRING-DISPLAYED-OUTPUT-RECORD T T)
+    (T POLYGON-DISPLAYED-OUTPUT-RECORD T T)
+    (T ELLIPSE-DISPLAYED-OUTPUT-RECORD T T)
+    (T ACCEPT-VALUES-OUTPUT-RECORD T T)
+    (T LINE-DISPLAYED-OUTPUT-RECORD T T)
+    (T STANDARD-TABLE-OUTPUT-RECORD T T)
+    (T STANDARD-ROW-OUTPUT-RECORD T T)
+    (T RECTANGLE-DISPLAYED-OUTPUT-RECORD T T)
+    (T BORDER-OUTPUT-RECORD T T))
+  (MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION
+    (T STANDARD-TREE-OUTPUT-HISTORY T)
+    (T STANDARD-SEQUENCE-OUTPUT-RECORD T)
+    (T STANDARD-ITEM-LIST-OUTPUT-RECORD T)
+    (T STANDARD-PRESENTATION T)
+    (T STANDARD-CELL-OUTPUT-RECORD T)
+    (T STANDARD-TEXT-OUTPUT-RECORD T)
+    (T STYLED-TEXT-OUTPUT-RECORD T)
+    (T STANDARD-UPDATING-OUTPUT-RECORD T)
+    (T STRING-DISPLAYED-OUTPUT-RECORD T)
+    (T POLYGON-DISPLAYED-OUTPUT-RECORD T)
+    (T ELLIPSE-DISPLAYED-OUTPUT-RECORD T)
+    (T LINE-DISPLAYED-OUTPUT-RECORD T)
+    (T ACCEPT-VALUES-OUTPUT-RECORD T)
+    (T STANDARD-ROW-OUTPUT-RECORD T)
+    (T STANDARD-TABLE-OUTPUT-RECORD T)
+    (T BORDER-OUTPUT-RECORD T))
+  (MAP-OVER-ROW-CELLS (T STANDARD-ROW-OUTPUT-RECORD))
+  (MAP-OVER-TABLE-ELEMENTS (T STANDARD-ITEM-LIST-OUTPUT-RECORD T)
+                           (T STANDARD-PRESENTATION T)
+                           (T STANDARD-UPDATING-OUTPUT-RECORD T)
+                           (T STANDARD-TABLE-OUTPUT-RECORD T)
+                           (T STANDARD-SEQUENCE-OUTPUT-RECORD T)
+                           (T STANDARD-ROW-OUTPUT-RECORD T))
+  (MAP-OVER-TABLE-ELEMENTS-HELPER (T STANDARD-PRESENTATION T)
+                                  (T STANDARD-CELL-OUTPUT-RECORD T)
+                                  (T STANDARD-UPDATING-OUTPUT-RECORD T)
+                                  (T BORDER-OUTPUT-RECORD T)
+                                  (T STANDARD-ROW-OUTPUT-RECORD T))
+  (MAP-OVER-TABLE-ROWS (T STANDARD-TABLE-OUTPUT-RECORD))
+  (MAP-OVER-TABLE-ROWS-OR-COLUMNS (T STANDARD-TABLE-OUTPUT-RECORD))
+  (MATCH-OUTPUT-RECORDS (ACCEPT-VALUES-OUTPUT-RECORD)
+			(STANDARD-PRESENTATION)
+			(STANDARD-ITEM-LIST-OUTPUT-RECORD)
+			(STANDARD-CELL-OUTPUT-RECORD)
+			(STANDARD-TABLE-OUTPUT-RECORD)
+			(STANDARD-ROW-OUTPUT-RECORD)
+			(STANDARD-SEQUENCE-OUTPUT-RECORD))
+  (MAYBE-SET-COLOR (POSTSCRIPT-STREAM GRAY-COLOR)
+		   (POSTSCRIPT-STREAM (EQL +BACKGROUND-INK+))
+		   (POSTSCRIPT-STREAM (EQL +FOREGROUND-INK+)))
+  (MEDIUM-BACKGROUND 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-FOREGROUND 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-DEFAULT-TEXT-STYLE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF MEDIUM-DEFAULT-TEXT-STYLE)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-INK 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-LINE-STYLE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-TEXT-STYLE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF MEDIUM-TEXT-STYLE)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (MEDIUM-TRANSFORMATION 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  #+Genera (MOUSE-DOCUMENTATION-WINDOW (SHEET-WINDOW-STREAM))
+  (NEW-OUTPUT-RECORDS (STANDARD-UPDATING-OUTPUT-RECORD T))
+  (NOTIFY-USER-1 #+Genera (SHEET-WINDOW-STREAM T T)
+		 #+Minima (CLX-WINDOW T T)
+		 #+Cloe-Runtime (CLOE-WINDOW-STREAM T T))
+  (OPACITY-VALUE (CLIM-UTILS::EVERYWHERE))
+  #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (SHEET-WINDOW-STREAM T)
+					       (DESIGN T)
+					       (FLIPPING-INK T)))
+
+(PREFILL-DISPATCH-CACHES
+  (OUTPUT-RECORD-CACHE-VALUE (STANDARD-UPDATING-OUTPUT-RECORD))
+  ((SETF OUTPUT-RECORD-CACHE-VALUE) (T STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-CONTENTS-OK (STANDARD-UPDATING-OUTPUT-RECORD)
+                             (ACCEPT-VALUES-OUTPUT-RECORD)
+                             (STANDARD-PRESENTATION)
+                             (STANDARD-TEXT-OUTPUT-RECORD)
+			     (STYLED-TEXT-OUTPUT-RECORD)
+                             (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                             (STANDARD-CELL-OUTPUT-RECORD))
+  (OUTPUT-RECORD-COUNT (STANDARD-CELL-OUTPUT-RECORD)
+		       (STANDARD-PRESENTATION)
+		       (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+		       (STANDARD-SEQUENCE-OUTPUT-RECORD)
+		       (STANDARD-TREE-OUTPUT-HISTORY)
+		       (STANDARD-UPDATING-OUTPUT-RECORD)
+		       (ACCEPT-VALUES-OUTPUT-RECORD)
+		       (STANDARD-ROW-OUTPUT-RECORD)
+		       (BORDER-OUTPUT-RECORD)
+		       (STANDARD-TABLE-OUTPUT-RECORD))
+  (OUTPUT-RECORD-CHILDREN (STANDARD-UPDATING-OUTPUT-RECORD)
+                          (ACCEPT-VALUES-OUTPUT-RECORD)
+                          (STANDARD-PRESENTATION)
+                          (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                          (STANDARD-CELL-OUTPUT-RECORD))
+  (OUTPUT-RECORD-END-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-FIXED-POSITION (STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-GENERATION-TICK (STANDARD-UPDATING-OUTPUT-RECORD)
+                                 (ACCEPT-VALUES-OUTPUT-RECORD)
+                                 (STANDARD-PRESENTATION)
+                                 (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                                 (STANDARD-CELL-OUTPUT-RECORD))
+  ((SETF OUTPUT-RECORD-GENERATION-TICK)
+   (T STANDARD-UPDATING-OUTPUT-RECORD)
+   (T ACCEPT-VALUES-OUTPUT-RECORD)
+   (T STANDARD-PRESENTATION)
+   (T STANDARD-ITEM-LIST-OUTPUT-RECORD)
+   (T STANDARD-CELL-OUTPUT-RECORD))
+  (OUTPUT-RECORD-OLD-CHILDREN (STANDARD-UPDATING-OUTPUT-RECORD)
+                              (STANDARD-PRESENTATION)
+                              (ACCEPT-VALUES-OUTPUT-RECORD)
+                              (STANDARD-CELL-OUTPUT-RECORD)
+                              (STANDARD-ITEM-LIST-OUTPUT-RECORD))
+  ((SETF OUTPUT-RECORD-OLD-CHILDREN) (T STANDARD-UPDATING-OUTPUT-RECORD)
+				     (T STANDARD-CELL-OUTPUT-RECORD))
+  (OUTPUT-RECORD-OLD-BOUNDING-RECTANGLE (STANDARD-UPDATING-OUTPUT-RECORD))
+  ((SETF OUTPUT-RECORD-OLD-PARENT) (T STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-OLD-CURSOR-POSITION (STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-OLD-START-CURSOR-POSITION (STANDARD-UPDATING-OUTPUT-RECORD))
+  (OUTPUT-RECORD-OLD-START-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD)
+					    (ACCEPT-VALUES-OUTPUT-RECORD)
+					    (STANDARD-PRESENTATION)
+					    (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+					    (STANDARD-CELL-OUTPUT-RECORD))
+  (OUTPUT-RECORD-PARENT (STANDARD-TEXT-OUTPUT-RECORD)
+			(STYLED-TEXT-OUTPUT-RECORD)
+                        (STANDARD-CELL-OUTPUT-RECORD)
+                        (STANDARD-PRESENTATION)
+                        (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                        (STANDARD-SEQUENCE-OUTPUT-RECORD)
+                        (STANDARD-TREE-OUTPUT-HISTORY)
+                        (STANDARD-UPDATING-OUTPUT-RECORD)
+                        (ACCEPT-VALUES-OUTPUT-RECORD)
+                        (STANDARD-ROW-OUTPUT-RECORD)
+                        (BORDER-OUTPUT-RECORD)
+                        (STANDARD-TABLE-OUTPUT-RECORD))
+  ((SETF OUTPUT-RECORD-PARENT)
+   (T STANDARD-TEXT-OUTPUT-RECORD)
+   (T STYLED-TEXT-OUTPUT-RECORD)
+   (T STANDARD-CELL-OUTPUT-RECORD)
+   (T STANDARD-PRESENTATION)
+   (T STANDARD-ITEM-LIST-OUTPUT-RECORD) (T STANDARD-SEQUENCE-OUTPUT-RECORD)
+   (T POLYGON-DISPLAYED-OUTPUT-RECORD) (T ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+   (T LINE-DISPLAYED-OUTPUT-RECORD) (T RECTANGLE-DISPLAYED-OUTPUT-RECORD)
+   (T STRING-DISPLAYED-OUTPUT-RECORD) (T STANDARD-UPDATING-OUTPUT-RECORD) (T ACCEPT-VALUES-OUTPUT-RECORD)
+   (T STANDARD-ROW-OUTPUT-RECORD) (T BORDER-OUTPUT-RECORD) (T STANDARD-TABLE-OUTPUT-RECORD))
+  (OUTPUT-RECORD-REFINED-SENSITIVITY-TEST (STANDARD-PRESENTATION T T)
+					  (STANDARD-TEXT-OUTPUT-RECORD T T)
+					  (STYLED-TEXT-OUTPUT-RECORD T T)
+					  (LINE-DISPLAYED-OUTPUT-RECORD T T)
+					  (STRING-DISPLAYED-OUTPUT-RECORD T T)
+					  (RECTANGLE-DISPLAYED-OUTPUT-RECORD T T)
+					  (ELLIPSE-DISPLAYED-OUTPUT-RECORD T T)
+					  (POLYGON-DISPLAYED-OUTPUT-RECORD T T))
+  (OUTPUT-RECORD-SET-END-CURSOR-POSITION* (STANDARD-CELL-OUTPUT-RECORD T T)
+					  (STANDARD-PRESENTATION T T)
+					  (STANDARD-ITEM-LIST-OUTPUT-RECORD T T)
+					  (STANDARD-SEQUENCE-OUTPUT-RECORD T T)
+					  (STANDARD-UPDATING-OUTPUT-RECORD T T)
+					  (ACCEPT-VALUES-OUTPUT-RECORD T T)
+					  (STANDARD-TREE-OUTPUT-HISTORY T T)
+					  (STANDARD-ROW-OUTPUT-RECORD T T)
+					  (BORDER-OUTPUT-RECORD T T)
+					  (STANDARD-TABLE-OUTPUT-RECORD T T))
+  (OUTPUT-RECORD-SET-OLD-START-CURSOR-POSITION* (STANDARD-UPDATING-OUTPUT-RECORD T T)
+						(ACCEPT-VALUES-OUTPUT-RECORD T T)
+						(STANDARD-PRESENTATION T T)
+						(STANDARD-ITEM-LIST-OUTPUT-RECORD T T)
+						(STANDARD-CELL-OUTPUT-RECORD T T))
+  (OUTPUT-RECORD-SET-START-CURSOR-POSITION* (STANDARD-SEQUENCE-OUTPUT-RECORD T T)
+					    (STANDARD-ITEM-LIST-OUTPUT-RECORD T T)
+					    (STANDARD-PRESENTATION T T)
+					    (STANDARD-CELL-OUTPUT-RECORD T T)
+					    (STANDARD-TEXT-OUTPUT-RECORD T T)
+					    (STYLED-TEXT-OUTPUT-RECORD T T)
+					    (STANDARD-UPDATING-OUTPUT-RECORD T T)
+					    (ACCEPT-VALUES-OUTPUT-RECORD T T)
+					    (STANDARD-TABLE-OUTPUT-RECORD T T)
+					    (BORDER-OUTPUT-RECORD T T)
+					    (STANDARD-ROW-OUTPUT-RECORD T T))
+  (OUTPUT-RECORD-START-CURSOR-POSITION (STANDARD-TREE-OUTPUT-HISTORY))
+  (OUTPUT-RECORD-START-CURSOR-POSITION* (STANDARD-CELL-OUTPUT-RECORD)
+					(STANDARD-PRESENTATION)
+					(STANDARD-ITEM-LIST-OUTPUT-RECORD)
+					(STANDARD-SEQUENCE-OUTPUT-RECORD)
+					(STANDARD-TREE-OUTPUT-HISTORY)
+					(STANDARD-TEXT-OUTPUT-RECORD)
+					(STYLED-TEXT-OUTPUT-RECORD)
+					(STRING-DISPLAYED-OUTPUT-RECORD)
+					(POLYGON-DISPLAYED-OUTPUT-RECORD)
+					(ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+					(LINE-DISPLAYED-OUTPUT-RECORD)
+					(STANDARD-UPDATING-OUTPUT-RECORD)
+					(ACCEPT-VALUES-OUTPUT-RECORD)
+					(STANDARD-ROW-OUTPUT-RECORD)
+					(BORDER-OUTPUT-RECORD)
+					(STANDARD-TABLE-OUTPUT-RECORD))
+  (OUTPUT-RECORD-UNIQUE-ID (STANDARD-UPDATING-OUTPUT-RECORD)
+			   (STANDARD-TEXT-OUTPUT-RECORD)
+			   (STYLED-TEXT-OUTPUT-RECORD))
+  (STREAM-CURRENT-OUTPUT-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-CURRENT-OUTPUT-RECORD)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-HIGHLIGHTED-PRESENTATION)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-OUTPUT-HISTORY
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-OUTPUT-HISTORY)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-OUTPUT-HISTORY-POSITION
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (OUTPUT-RECORDING-STREAM-P
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-CURRENT-REDISPLAY-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-CURRENT-REDISPLAY-RECORD)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-REPLAY
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-TEXT-OUTPUT-RECORD
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-TEXT-OUTPUT-RECORD)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (OUTPUT-STREAM-P 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (POINT-POSITION* (STANDARD-POINT))
+  (POINT-X (STANDARD-POINT))
+  ((SETF POINT-X) (T STANDARD-POINT))
+  (POINT-Y (STANDARD-POINT))
+  ((SETF POINT-Y) (T STANDARD-POINT)))
+
+(PREFILL-DISPATCH-CACHES
+  (POINTER-MOTION-PENDING 
+    (#+Genera SHEET-WINDOW-STREAM #+Cloe-Runtime CLOE-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF POINTER-MOTION-PENDING)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (PREPARE-TEXT-RECORD-FOR-APPENDING (STANDARD-TEXT-OUTPUT-RECORD T T)
+				     (STYLED-TEXT-OUTPUT-RECORD T T))
+  (PRESENTATION-OBJECT (STANDARD-PRESENTATION))
+  ((SETF PRESENTATION-OBJECT) (T STANDARD-PRESENTATION))
+  (PRESENTATION-SINGLE-BOX (STANDARD-PRESENTATION))
+  (PRESENTATION-TYPE (STANDARD-PRESENTATION))
+  #+Genera (PRINT-OBJECT (FLIPPING-INK T)
+			 ((EQL +FOREGROUND-INK+) T)
+			 ((EQL +BACKGROUND-INK+) T))
+  #+Genera (CLOS-INTERNALS::PRINT-SELF (DESIGN T T T) (FLIPPING-INK T T T))
+  (PROMPT-FOR-ACCEPT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (PROPAGATE-INFERIOR-OUTPUT-RECORD-CHANGES-P (STANDARD-TREE-OUTPUT-HISTORY T T))
+  (RECOMPUTE-CONTENTS-OK (STANDARD-TEXT-OUTPUT-RECORD)
+			 (STYLED-TEXT-OUTPUT-RECORD)
+			 (STANDARD-PRESENTATION)
+			 (ACCEPT-VALUES-OUTPUT-RECORD)
+			 (STANDARD-CELL-OUTPUT-RECORD)
+			 (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+			 (STANDARD-UPDATING-OUTPUT-RECORD)
+			 (STANDARD-ROW-OUTPUT-RECORD)
+			 (STANDARD-TABLE-OUTPUT-RECORD)
+			 (STANDARD-SEQUENCE-OUTPUT-RECORD))
+  (RECOMPUTE-EXTENT (STANDARD-SEQUENCE-OUTPUT-RECORD)
+		    (STANDARD-TREE-OUTPUT-HISTORY)
+		    (STANDARD-UPDATING-OUTPUT-RECORD)
+		    (STANDARD-TABLE-OUTPUT-RECORD)
+		    (ACCEPT-VALUES-OUTPUT-RECORD)
+		    (STANDARD-CELL-OUTPUT-RECORD)
+		    (STANDARD-ROW-OUTPUT-RECORD)
+		    (STANDARD-PRESENTATION))
+  (RECOMPUTE-EXTENT-FOR-CHANGED-CHILD (STANDARD-SEQUENCE-OUTPUT-RECORD T T T T T)
+				      (STANDARD-TREE-OUTPUT-HISTORY T T T T T)
+				      (STANDARD-UPDATING-OUTPUT-RECORD T T T T T)
+				      (ACCEPT-VALUES-OUTPUT-RECORD T T T T T)
+				      (STANDARD-TABLE-OUTPUT-RECORD T T T T T)
+				      (STANDARD-CELL-OUTPUT-RECORD T T T T T)
+				      (STANDARD-ROW-OUTPUT-RECORD T T T T T)
+				      (STANDARD-PRESENTATION T T T T T))
+  (RECOMPUTE-EXTENT-FOR-NEW-CHILD (STANDARD-CELL-OUTPUT-RECORD T)
+				  (STANDARD-PRESENTATION T)
+				  (STANDARD-ITEM-LIST-OUTPUT-RECORD T)
+				  (STANDARD-SEQUENCE-OUTPUT-RECORD T)
+				  (STANDARD-TREE-OUTPUT-HISTORY T)
+				  (STANDARD-UPDATING-OUTPUT-RECORD T)
+				  (ACCEPT-VALUES-OUTPUT-RECORD T)
+				  (STANDARD-ROW-OUTPUT-RECORD T)
+				  (STANDARD-TABLE-OUTPUT-RECORD T))
+  (RECOMPUTE-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T T T T T T T))
+  (REDISPLAY-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T))
+  (REDISPLAY-DECORATIONS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (REGION-CONTAINS-POINT*-P (STANDARD-PRESENTATION T T)
+                            (STANDARD-TEXT-OUTPUT-RECORD T T)
+			    (STYLED-TEXT-OUTPUT-RECORD T T)
+                            (LINE-DISPLAYED-OUTPUT-RECORD T T))
+  (REGION-INTERSECTS-REGION-P (POLYGON-DISPLAYED-OUTPUT-RECORD RECTANGLE-DISPLAYED-OUTPUT-RECORD)
+                              (POLYGON-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD)
+                              (ELLIPSE-DISPLAYED-OUTPUT-RECORD ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+                              (ELLIPSE-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD)
+                              (STANDARD-PRESENTATION STANDARD-PRESENTATION)
+                              (STANDARD-PRESENTATION POLYGON-DISPLAYED-OUTPUT-RECORD)
+                              (LINE-DISPLAYED-OUTPUT-RECORD LINE-DISPLAYED-OUTPUT-RECORD)
+                              (LINE-DISPLAYED-OUTPUT-RECORD ELLIPSE-DISPLAYED-OUTPUT-RECORD)
+                              (RECTANGLE-DISPLAYED-OUTPUT-RECORD POLYGON-DISPLAYED-OUTPUT-RECORD)
+                              (RECTANGLE-DISPLAYED-OUTPUT-RECORD RECTANGLE-DISPLAYED-OUTPUT-RECORD)
+                              (STANDARD-SEQUENCE-OUTPUT-RECORD STANDARD-UPDATING-OUTPUT-RECORD))
+  (REPLAY-OUTPUT-RECORD (STANDARD-TREE-OUTPUT-HISTORY T)
+			(STANDARD-SEQUENCE-OUTPUT-RECORD T)
+			(STANDARD-ITEM-LIST-OUTPUT-RECORD T)
+			(STANDARD-PRESENTATION T)
+			(STANDARD-CELL-OUTPUT-RECORD T)
+			(STANDARD-TEXT-OUTPUT-RECORD T)
+			(STYLED-TEXT-OUTPUT-RECORD T)
+			(ELLIPSE-DISPLAYED-OUTPUT-RECORD T)
+			(LINE-DISPLAYED-OUTPUT-RECORD T)
+			(POLYGON-DISPLAYED-OUTPUT-RECORD T)
+			(RECTANGLE-DISPLAYED-OUTPUT-RECORD T)
+			(STRING-DISPLAYED-OUTPUT-RECORD T)
+			(STANDARD-UPDATING-OUTPUT-RECORD T)
+			(ACCEPT-VALUES-OUTPUT-RECORD T)
+			(STANDARD-TABLE-OUTPUT-RECORD T)
+			(BORDER-OUTPUT-RECORD T)
+			(STANDARD-ROW-OUTPUT-RECORD T))
+  (REPOSITION-OUTPUT-RECORD (STANDARD-UPDATING-OUTPUT-RECORD T T T T T))
+  (ROW-TABLE-P (STANDARD-TABLE-OUTPUT-RECORD))
+  #+Genera (CLOS-INTERNALS::SEND-IF-HANDLES (SHEET-WINDOW-STREAM T))
+  (OUTPUT-RECORD-SET-POSITION* (STANDARD-TREE-OUTPUT-HISTORY T T)
+                               (STANDARD-CELL-OUTPUT-RECORD T T))
+  (SET-POINTER-WINDOW-AND-LOCATION
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  #+Genera (SET-STREAM-POINTER-IN-SCREEN-COORDINATES (SHEET-WINDOW-STREAM T T T))
+  (SHARED-INITIALIZE #+Cloe-Runtime (CLOE-ROOT-WINDOW T) 
+		     #+Cloe-Runtime (CLOE-WINDOW-STREAM T)
+		     #+Genera (SHEET-WINDOW-STREAM T)
+		     #+Minima (CLX-WINDOW T)
+		     (ACCEPT-VALUES-OUTPUT-RECORD T))
+  #+Genera (SHEET-DECODE-COLOR (GRAY-COLOR T)
+			       (RGB-COLOR T))
+  #+Genera (SHEET-DECODE-INK (FLIPPING-INK T)
+			     (GRAY-COLOR T)
+			     (RGB-COLOR T)
+			     (CONTRASTING-INK T)
+			     (RECTANGULAR-TILE T)
+			     (PATTERN T))
+  #+Genera (SHEET-DECODE-PATTERN (PATTERN T))
+  (STREAM-ADVANCE-CURSOR-LINE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-BASELINE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-BASELINE)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-CHARACTER-SIZE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-CHARACTER-WIDTH
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-CLEAR-INPUT
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  #+Genera (STREAM-COMPATIBLE-CURSOR-POSITION* (SHEET-WINDOW-STREAM))
+  #+Genera (STREAM-COMPATIBLE-OUTPUT-AS-PRESENTATION-1 (SHEET-WINDOW-STREAM T T))
+  #+Genera (STREAM-COMPATIBLE-READ-CHAR (SHEET-WINDOW-STREAM))
+  #+Genera (STREAM-COMPATIBLE-SIZE-IN-CHARACTERS (SHEET-WINDOW-STREAM))
+  (STREAM-CURRENT-LINE-HEIGHT
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-CURRENT-LINE-HEIGHT)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-CURSOR-POSITION* #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+			   #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+			   #+Genera (SHEET-WINDOW-STREAM)
+			   #+Minima (CLX-WINDOW)) 
+  (STREAM-DEFAULT-TEXT-MARGIN
+    #+Cloe-Runtime (CLOE-ROOT-WINDOW)
+    #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+    #+Genera (SHEET-WINDOW-STREAM)
+    #+Minima (CLX-WINDOW))
+  ((SETF STREAM-DEFAULT-TEXT-MARGIN)
+   #+Cloe-Runtime (T CLOE-ROOT-WINDOW) 
+   #+Cloe-Runtime (T CLOE-WINDOW-STREAM)
+   #+Genera (T SHEET-WINDOW-STREAM)
+   #+Minima (T CLX-WINDOW))
+  (STREAM-DEFAULT-VIEW
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-DEFAULT-VIEW)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-DRAWING-P
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-DRAWING-P)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-END-OF-LINE-ACTION
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-END-OF-LINE-ACTION)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-END-OF-PAGE-ACTION
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-END-OF-PAGE-ACTION)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW)))
+
+(PREFILL-DISPATCH-CACHES
+  (STREAM-ENSURE-CURSOR-VISIBLE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-EVENT-HANDLER #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+			#+Cloe-Runtime (CLOE-WINDOW-STREAM)
+			#+Genera (SHEET-WINDOW-STREAM)
+			#+Minima (CLX-WINDOW))
+  (STREAM-FINISH-OUTPUT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-FORCE-OUTPUT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-FRESH-LINE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-GLYPH-FOR-CHARACTER
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (STREAM-HANDLE-LINE-WRAP
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (STREAM-INPUT-BUFFER 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-INPUT-WAIT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-LINE-HEIGHT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-MERGED-TEXT-STYLE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-MERGED-TEXT-STYLE-VALID
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-MERGED-TEXT-STYLE-VALID)
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-MOVE-FOR-LINE-HEIGHT-CHANGE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T))
+  (STREAM-NOTE-LINE-HEIGHT-CHANGE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (STREAM-NOTE-POINTER-BUTTON-PRESS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (STREAM-OUTPUT-GLYPH-BUFFER 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-POINTER-POSITION* 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-POINTERS #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		   #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		   #+Genera (SHEET-WINDOW-STREAM)
+		   #+Minima (CLX-WINDOW)) 
+  ((SETF STREAM-POINTERS) #+Cloe-Runtime (T CLOE-ROOT-WINDOW)
+			  #+Genera (T SHEET-WINDOW-STREAM)
+			  #+Minima (T CLX-WINDOW)) 
+  (STREAM-PRIMARY-POINTER #+Cloe-Runtime (CLOE-ROOT-WINDOW)
+			  #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+			  #+Genera (SHEET-WINDOW-STREAM)
+			  #+Minima (CLX-WINDOW)) 
+  (STREAM-READ-CHAR 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-READ-GESTURE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-RECORDING-P 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-RECORDING-P) 
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (REDISPLAYABLE-STREAM-P 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-REDISPLAYING-P 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF STREAM-REDISPLAYING-P) 
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-RESTORE-INPUT-FOCUS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-SCAN-CHARACTER-FOR-WRITING 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T))
+  (STREAM-SCAN-STRING-FOR-WRITING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T))
+  (STREAM-SET-CURSOR-POSITION*
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (STREAM-SET-CURSOR-POSITION*-INTERNAL
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (STREAM-SET-INPUT-FOCUS
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-SET-POINTER-POSITION*
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (STREAM-STRING-OUTPUT-SIZE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-STRING-WIDTH
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-SUPPORTS-INPUT-EDITING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-TEXT-CURSOR
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-TEXT-MARGIN
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-UNREAD-GESTURE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-VERTICAL-SPACING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (STREAM-WRITE-CHAR
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-WRITE-CHAR-1
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T))
+  (STREAM-WRITE-STRING
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (STREAM-WRITE-STRING-1
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T))
+  (TREE-RECOMPUTE-EXTENT-1 (STANDARD-ITEM-LIST-OUTPUT-RECORD)
+                           (STANDARD-PRESENTATION)
+                           (STANDARD-CELL-OUTPUT-RECORD)
+                           (STANDARD-UPDATING-OUTPUT-RECORD)
+                           (STANDARD-TABLE-OUTPUT-RECORD)
+                           (BORDER-OUTPUT-RECORD)
+                           (STANDARD-SEQUENCE-OUTPUT-RECORD)
+                           (STANDARD-ROW-OUTPUT-RECORD)
+                           (LINE-DISPLAYED-OUTPUT-RECORD))
+  (VIEWPORT-TO-DRAWING-SURFACE-COORDINATES 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  #+Genera (CLOS-INTERNALS::WHICH-OPERATIONS (DESIGN) (FLIPPING-INK)))
+
+(PREFILL-DISPATCH-CACHES
+  (WINDOW-BEEP 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-CHILDREN #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		   #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		   #+Genera (SHEET-WINDOW-STREAM)
+		   #+Minima (CLX-WINDOW)) 
+  ((SETF WINDOW-CHILDREN) #+Cloe-Runtime (T CLOE-ROOT-WINDOW) 
+			  #+Cloe-Runtime (T CLOE-WINDOW-STREAM)
+			  #+Genera (T SHEET-WINDOW-STREAM)
+			  #+Minima (T CLX-WINDOW))
+  (WINDOW-CLEAR 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-CLEAR-AREA 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T))
+  (WINDOW-ERASE-VIEWPORT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-EXPOSE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-FLUSH-UPDATE-REGION 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-INSIDE-EDGES #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		       #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		       #+Genera (SHEET-WINDOW-STREAM)
+		       #+Minima (CLX-WINDOW)) 
+  (WINDOW-INSIDE-SIZE #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		      #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		      #+Genera (SHEET-WINDOW-STREAM)
+		      #+Minima (CLX-WINDOW))
+  (WINDOW-INSIDE-WIDTH 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-LABEL 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF WINDOW-LABEL) 
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-LABEL-SIZE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-MARGINS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-PARENT #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+		 #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+		 #+Genera (SHEET-WINDOW-STREAM)
+		 #+Minima (CLX-WINDOW))
+  (WINDOW-PROCESS-UPDATE-REGION 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-SET-VIEWPORT-POSITION* 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T))
+  (WINDOW-MODIFIER-STATE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-SHIFT-VISIBLE-REGION 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T T T T T T))
+  (WINDOW-STACK-ON-TOP 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-STREAM-CLASS-NAME #+Cloe-Runtime (CLOE-ROOT-WINDOW) 
+			    #+Cloe-Runtime (CLOE-WINDOW-STREAM)
+			    #+Genera (SHEET-WINDOW-STREAM)
+			    #+Minima (CLX-WINDOW))
+  (WINDOW-VIEWPORT 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-VIEWPORT-POSITION* 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (WINDOW-VISIBILITY 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  ((SETF WINDOW-VISIBILITY) 
+   (T #+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW))
+  (INVOKE-WITH-CLIPPING-REGION 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW
+     T STANDARD-BOUNDING-RECTANGLE))
+  (INVOKE-WITH-DRAWING-OPTIONS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T))
+  (INVOKE-WITH-OUTPUT-RECORDING-OPTIONS 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T))
+  (INVOKE-WITH-TEXT-STYLE 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM #+Minima CLX-WINDOW T T T)))
+
+
+;;; (generate-prefill-dispatch-caches 'line-style)
+
+(PREFILL-DISPATCH-CACHES (LINE-STYLE-CAP-SHAPE (STANDARD-LINE-STYLE)) 
+                         (LINE-STYLE-DASHES (STANDARD-LINE-STYLE)) 
+                         (LINE-STYLE-JOINT-SHAPE (STANDARD-LINE-STYLE)) 
+                         (LINE-STYLE-THICKNESS (STANDARD-LINE-STYLE)) 
+                         (LINE-STYLE-UNIT (STANDARD-LINE-STYLE)))
+
+
+;;; (generate-prefill-dispatch-caches 'text-style)
+
+(PREFILL-DISPATCH-CACHES
+  (MERGE-TEXT-STYLES (TEXT-STYLE TEXT-STYLE) 
+		     (TEXT-STYLE CONS) 
+		     (CONS TEXT-STYLE)) 
+  (PARSE-TEXT-STYLE (TEXT-STYLE)) 
+  (TEXT-STYLE-COMPONENTS (TEXT-STYLE)) 
+  (TEXT-STYLE-INDEX (TEXT-STYLE)) 
+  (TEXT-STYLE-MAPPING
+    (#+Cloe-Runtime CLOE-DEVICE #+Genera SHEET-DEVICE #+Minima CLX-DISPLAY-DEVICE T TEXT-STYLE T)))
+
+
+;;; (generate-prefill-dispatch-caches 'device-font)
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches 'fundamental-stream)
+;;; Window stuff has been removed by hand since it duplicates earlier entries
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-1 (STANDARD-INPUT-EDITING-STREAM T)
+	    (ACCEPT-VALUES-STREAM T)) 
+  (STREAM-CLOSE-TEXT-OUTPUT-RECORD (STANDARD-INPUT-EDITING-STREAM)
+				   (ACCEPT-VALUES-STREAM)) 
+  (DECODE-STREAM-FOR-WRITING (STANDARD-INPUT-EDITING-STREAM)) 
+  (DO-INPUT-BUFFER-SCREEN-REAL-ESTATE (STANDARD-INPUT-EDITING-STREAM T)) 
+  (ERASE-INPUT-BUFFER (STANDARD-INPUT-EDITING-STREAM)) 
+  (EXTENDED-OUTPUT-STREAM-P (ACCEPT-VALUES-STREAM)) 
+  (FIND-OR-ADD-QUERY (ACCEPT-VALUES-STREAM T T T T T))
+  (INVOKE-FORMATTING-CELL (ACCEPT-VALUES-STREAM T)
+			  (STANDARD-INPUT-EDITING-STREAM T)) 
+  (INITIALIZE-INPUT-EDITING-STREAM (STANDARD-INPUT-EDITING-STREAM)) 
+  (INITIALIZE-POSITION (STANDARD-INPUT-EDITING-STREAM)) 
+  (INPUT-BUFFER-INPUT-POSITION->CURSOR-POSITION* (STANDARD-INPUT-EDITING-STREAM)) 
+  (INPUT-EDITOR-BUFFER (STANDARD-INPUT-EDITING-STREAM)) 
+  (INPUT-POSITION (STANDARD-INPUT-EDITING-STREAM)) 
+  ((SETF INPUT-POSITION) (T STANDARD-INPUT-EDITING-STREAM)) 
+  (INSERTION-POINTER (STANDARD-INPUT-EDITING-STREAM)) 
+  ((SETF INSERTION-POINTER) (T STANDARD-INPUT-EDITING-STREAM)) 
+  (INPUT-EDITING-STREAM-P (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-PROCESS-GESTURE (STANDARD-INPUT-EDITING-STREAM T T)) 
+  #+Genera (CLOS-INTERNALS:OPERATION-HANDLED-P (STANDARD-INPUT-EDITING-STREAM T)
+					       (ACCEPT-VALUES-STREAM T))
+  ((SETF ORIGINAL-STREAM-RECORDING-P) (T STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-CURRENT-OUTPUT-RECORD (STANDARD-INPUT-EDITING-STREAM)
+				(ACCEPT-VALUES-STREAM)) 
+  ((SETF STREAM-CURRENT-OUTPUT-RECORD) (T STANDARD-INPUT-EDITING-STREAM)
+   (T ACCEPT-VALUES-STREAM)) 
+  (STREAM-OUTPUT-HISTORY (STANDARD-INPUT-EDITING-STREAM)
+			 (ACCEPT-VALUES-STREAM)) 
+  (STREAM-OUTPUT-HISTORY-POSITION (STANDARD-INPUT-EDITING-STREAM)
+				  (ACCEPT-VALUES-STREAM)) 
+  (STREAM-CURRENT-REDISPLAY-RECORD (ACCEPT-VALUES-STREAM))
+  ((SETF STREAM-CURRENT-REDISPLAY-RECORD) (T ACCEPT-VALUES-STREAM))
+  (STREAM-REPLAY (ACCEPT-VALUES-STREAM)
+		 (STANDARD-INPUT-EDITING-STREAM)) 
+  (PRESENTATION-REPLACE-INPUT (STANDARD-INPUT-EDITING-STREAM T T)) 
+  (PROMPT-FOR-ACCEPT (STANDARD-INPUT-EDITING-STREAM T T)
+		     (ACCEPT-VALUES-STREAM T T)) 
+  (REDRAW-INPUT-BUFFER (STANDARD-INPUT-EDITING-STREAM)) 
+  (REMOVE-ACTIVATION-GESTURE (STANDARD-INPUT-EDITING-STREAM)) 
+  (REPLACE-INPUT (STANDARD-INPUT-EDITING-STREAM T)) 
+  (RESCAN-IF-NECESSARY (STANDARD-INPUT-EDITING-STREAM)) 
+  (RESCANNING-P (STANDARD-INPUT-EDITING-STREAM)) 
+  (RESET-CURSOR-POSITION (STANDARD-INPUT-EDITING-STREAM)) 
+  (RESET-SCAN-POINTER (STANDARD-INPUT-EDITING-STREAM)) 
+  #+Genera (CLOS-INTERNALS::SEND-IF-HANDLES (STANDARD-INPUT-EDITING-STREAM T)
+					    (ACCEPT-VALUES-STREAM T))
+  #+Genera (STREAM-COMPATIBLE-OUTPUT-AS-PRESENTATION-1 (STANDARD-INPUT-EDITING-STREAM T T))
+  #+Genera (STREAM-COMPATIBLE-READ-CHAR (STANDARD-INPUT-EDITING-STREAM))
+  (START-CURSOR-POSITION* (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-DEFAULT-VIEW (STANDARD-INPUT-EDITING-STREAM)
+		       (ACCEPT-VALUES-STREAM)) 
+  ((SETF STREAM-DEFAULT-VIEW) (T ACCEPT-VALUES-STREAM)) 
+  (STREAM-DRAWING-P (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-END-OF-LINE-ACTION (ACCEPT-VALUES-STREAM)
+			     (STANDARD-INPUT-EDITING-STREAM)) 
+  ((SETF STREAM-END-OF-LINE-ACTION) (T ACCEPT-VALUES-STREAM)
+				    (T STANDARD-INPUT-EDITING-STREAM))
+  (STREAM-END-OF-PAGE-ACTION (ACCEPT-VALUES-STREAM)
+			     (STANDARD-INPUT-EDITING-STREAM))
+  ((SETF STREAM-END-OF-PAGE-ACTION) (T ACCEPT-VALUES-STREAM)
+				    (T STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-FRESH-LINE (STANDARD-INPUT-EDITING-STREAM)
+		     (ACCEPT-VALUES-STREAM)) 
+  (STREAM-READ-CHAR (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-READ-GESTURE (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-RECORDING-P (STANDARD-INPUT-EDITING-STREAM)
+		      (ACCEPT-VALUES-STREAM)) 
+  (STREAM-REDISPLAYING-P (STANDARD-INPUT-EDITING-STREAM)
+			 (ACCEPT-VALUES-STREAM)) 
+  ((SETF STREAM-REDISPLAYING-P) (T ACCEPT-VALUES-STREAM))
+  (STREAM-SET-CURSOR-POSITION* (ACCEPT-VALUES-STREAM T T)
+			       (STANDARD-INPUT-EDITING-STREAM T T)) 
+  (STREAM-STRING-WIDTH (ACCEPT-VALUES-STREAM T)
+		       (STANDARD-INPUT-EDITING-STREAM T)) 
+  (STREAM-TERPRI (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-UNREAD-GESTURE (STANDARD-INPUT-EDITING-STREAM T)) 
+  (STREAM-VERTICAL-SPACING (ACCEPT-VALUES-STREAM)
+			   (STANDARD-INPUT-EDITING-STREAM)) 
+  (STREAM-WRITE-CHAR (STANDARD-INPUT-EDITING-STREAM T)
+		     (ACCEPT-VALUES-STREAM T)) 
+  (STREAM-WRITE-STRING (STANDARD-INPUT-EDITING-STREAM T)
+		       (ACCEPT-VALUES-STREAM T)) 
+  #+Genera (CLOS-INTERNALS::WHICH-OPERATIONS (STANDARD-INPUT-EDITING-STREAM) (ACCEPT-VALUES-STREAM))
+  (WINDOW-BEEP (STANDARD-INPUT-EDITING-STREAM)) 
+  (WINDOW-INSIDE-SIZE (STANDARD-INPUT-EDITING-STREAM)) 
+  (INVOKE-WITH-INPUT-EDITOR-TYPEOUT (STANDARD-INPUT-EDITING-STREAM T)) 
+  (INVOKE-WITH-OUTPUT-RECORDING-OPTIONS (STANDARD-INPUT-EDITING-STREAM T T T)
+					(ACCEPT-VALUES-STREAM T T T)) 
+  (INVOKE-WITH-TEXT-STYLE (STANDARD-INPUT-EDITING-STREAM T T T)
+			  (ACCEPT-VALUES-STREAM T T T)))
+
+
+;;; (generate-prefill-dispatch-caches 'pointer)
+
+(PREFILL-DISPATCH-CACHES
+  #+Genera ((SETF POINTER-BUTTON-STATE) (T POINTER))
+  (POINTER-POSITION* (POINTER))
+  #+Genera ((SETF POINTER-POSITION-CHANGED) (T POINTER))
+  (POINTER-SET-POSITION* (POINTER T T))
+  (POINTER-WINDOW (POINTER))
+  ((SETF POINTER-WINDOW) (T POINTER))
+  #+Genera (POINTER-X-POSITION (POINTER))
+  #+Genera (POINTER-Y-POSITION (POINTER))
+  (QUERY-POINTER (POINTER)))
+
+
+;;; (generate-prefill-dispatch-caches 'console)
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches 'device-event)
+
+(PREFILL-DISPATCH-CACHES
+  (EVENT-WINDOW (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT))
+  (EVENT-MODIFIER-STATE (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT))
+  (POINTER-EVENT-BUTTON (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT))
+  (POINTER-EVENT-X (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT))
+  (POINTER-EVENT-Y (POINTER-BUTTON-PRESS-EVENT POINTER-BUTTON-RELEASE-EVENT)))
+
+
+;;; (generate-prefill-dispatch-caches 'basic-view)
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-METHOD
+    ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE FORM) T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE OR) T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-DIALOG-VIEW)
+    ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMMAND-NAME) T T T T TEXTUAL-VIEW)) 
+  (ACCEPT-PRESENT-DEFAULT-METHOD
+    ((PRESENTATION-TYPE COMPLETION) T T T T TEXTUAL-DIALOG-VIEW T T T T))
+  (PRESENT-METHOD
+    ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-MENU-VIEW)
+    ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-MENU-VIEW)
+    ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMMAND-NAME) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE OR) T T T T T TEXTUAL-DIALOG-VIEW)
+    ((PRESENTATION-TYPE OR) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-DIALOG-VIEW)
+    ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-VIEW)
+    ((PRESENTATION-TYPE NULL) T T T T T TEXTUAL-VIEW)))
+
+
+;;; (generate-prefill-dispatch-caches 'standard-application-frame)
+
+(PREFILL-DISPATCH-CACHES 
+  (DISPLAY-EXIT-BOXES (ACCEPT-VALUES T))
+  (EXECUTE-FRAME-COMMAND (ACCEPT-VALUES T))
+  (FRAME-COMMAND-TABLE (DEFAULT-APPLICATION)
+		       (ACCEPT-VALUES)) 
+  (FRAME-DOCUMENT-HIGHLIGHTED-PRESENTATION (ACCEPT-VALUES T T T T T T))
+  (FRAME-FIND-INNERMOST-APPLICABLE-PRESENTATION (DEFAULT-APPLICATION T T T T)
+						(ACCEPT-VALUES T T T T)) 
+  (FRAME-INPUT-CONTEXT-BUTTON-PRESS-HANDLER (DEFAULT-APPLICATION T T)
+					    (ACCEPT-VALUES T T)) 
+  (FRAME-NAME (ACCEPT-VALUES)) 
+  (FRAME-POINTER-DOCUMENTATION-OUTPUT (ACCEPT-VALUES)) 
+  (FRAME-REPLAY (DEFAULT-APPLICATION T)
+		(ACCEPT-VALUES T)) 
+  (FRAME-TOP-LEVEL-SHEET (ACCEPT-VALUES)) 
+  (INITIALIZE-INSTANCE (DEFAULT-APPLICATION)
+		       (ACCEPT-VALUES)) 
+  (LAYOUT-FRAME-PANES (ACCEPT-VALUES T)) 
+  (RUN-FRAME-TOP-LEVEL (ACCEPT-VALUES)) 
+  (SHARED-INITIALIZE (DEFAULT-APPLICATION T)
+		     (ACCEPT-VALUES T)))
+
+
+;;; (generate-prefill-dispatch-caches 'command-table)
+
+(PREFILL-DISPATCH-CACHES 
+  (COMMAND-PRESENT-IN-COMMAND-TABLE-P (T STANDARD-COMMAND-TABLE)) 
+  (COMMAND-TABLE-INHERIT-FROM (STANDARD-COMMAND-TABLE)) 
+  (COMMAND-TABLE-NAME (STANDARD-COMMAND-TABLE)))
+
+
+;;; (generate-prefill-dispatch-caches 'noise-string)
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches 'display-device)
+
+(PREFILL-DISPATCH-CACHES
+  ((SETF TEXT-STYLE-MAPPING) #+Cloe-Runtime (T CLOE-DEVICE T T) 
+			     #+Genera (T SHEET-DEVICE T T)
+			     #+Minima (T CLX-DISPLAY-DEVICE T T)
+			     (T POSTSCRIPT-DEVICE T T))
+  (DISPLAY-DEVICE-NAME #+Cloe-Runtime (CLOE-DEVICE)
+		       #+Genera (SHEET-DEVICE)
+		       #+Minima (CLX-DISPLAY-DEVICE)
+		       (POSTSCRIPT-DEVICE)) 
+  (STANDARDIZE-TEXT-STYLE #+Cloe-Runtime (CLOE-DEVICE T T) 
+			  #+Genera (SHEET-DEVICE T T)
+			  #+Minima (CLX-DISPLAY-DEVICE T T)
+			  (POSTSCRIPT-DEVICE T T)) 
+  (TEXT-STYLE-MAPPING #+Cloe-Runtime (CLOE-DEVICE T TEXT-STYLE)
+		      #+Genera (SHEET-DEVICE T TEXT-STYLE)
+		      #+Minima (CLX-DISPLAY-DEVICE T TEXT-STYLE)
+		      #+Genera (SHEET-DEVICE T CONS)) 
+  (TEXT-STYLE-MAPPING* #+Cloe-Runtime (CLOE-DEVICE T T)
+		       #+Genera (SHEET-DEVICE T T)
+		       #+Minima (CLX-DISPLAY-DEVICE T T)))
+
+
+;;; (generate-prefill-dispatch-caches 'io-buffer)
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches 'queue)
+
+(PREFILL-DISPATCH-CACHES (QUEUE-EMPTY-P (QUEUE)) 
+                         (QUEUE-FLUSH (QUEUE)) 
+                         (QUEUE-GET (QUEUE)) 
+                         (QUEUE-NEXT (QUEUE)) 
+                         (QUEUE-PUT (QUEUE T)) 
+                         (QUEUE-UNGET (QUEUE T)))
+
+
+;;; (generate-prefill-dispatch-caches 'fundamental-cursor)
+
+(PREFILL-DISPATCH-CACHES ((SETF CURSOR-STREAM) (T TEXT-CURSOR)) 
+                         (CURSOR-VISIBILITY (TEXT-CURSOR)) 
+                         ((SETF CURSOR-VISIBILITY) (T TEXT-CURSOR)) 
+                         (DRAW-CURSOR (TEXT-CURSOR T)) 
+			 (CURSOR-POSITION* (TEXT-CURSOR))
+                         (CURSOR-SET-POSITION* (TEXT-CURSOR T T)))
+
+
+;;; (generate-prefill-dispatch-caches 'accept-values-query)
+
+(PREFILL-DISPATCH-CACHES (ACCEPT-VALUES-QUERY-CHANGED-P (ACCEPT-VALUES-QUERY))
+			 (ACCEPT-VALUES-QUERY-EDIT-VALUE (ACCEPT-VALUES-QUERY T))
+			 ((SETF ACCEPT-VALUES-QUERY-PRESENTATION) (T ACCEPT-VALUES-QUERY))
+			 (ACCEPT-VALUES-QUERY-TYPE (ACCEPT-VALUES-QUERY))
+			 (ACCEPT-VALUES-QUERY-VALUE (ACCEPT-VALUES-QUERY)))
+
+
+;;; (generate-prefill-dispatch-caches 'kill-ring-history)
+
+(PREFILL-DISPATCH-CACHES
+  (DISPLAY-HISTORY-CONTENTS (KILL-RING-HISTORY T))
+  (DISPLAY-HISTORY-MENU-ELEMENT (KILL-RING-HISTORY T T T))
+  (DO-HISTORY-ELEMENTS-1 (KILL-RING-HISTORY T))
+  (HISTORY-AND-ELEMENT (KILL-RING-HISTORY T))
+  (HISTORY-ELEMENT (KILL-RING-HISTORY T))
+  (HISTORY-ELEMENT-VISIBLE-P (KILL-RING-HISTORY T))
+  (HISTORY-ELEMENTS-EQUAL (KILL-RING-HISTORY T T))
+  (HISTORY-LENGTH (KILL-RING-HISTORY))
+  (HISTORY-TOP-ELEMENT (KILL-RING-HISTORY))
+  (PRINT-HISTORY-ELEMENT (KILL-RING-HISTORY T T))
+  (PUSH-HISTORY-ELEMENT (KILL-RING-HISTORY T)))
+
+
+;;; (generate-prefill-dispatch-caches 'presentation-history)
+
+(PREFILL-DISPATCH-CACHES
+  (DISPLAY-HISTORY-CONTENTS (PRESENTATION-HISTORY T))
+  (DISPLAY-HISTORY-MENU-ELEMENT (PRESENTATION-HISTORY T T T))
+  (DO-HISTORY-ELEMENTS-1 (PRESENTATION-HISTORY T))
+  (HISTORY-AND-ELEMENT (PRESENTATION-HISTORY T))
+  (HISTORY-ELEMENT (PRESENTATION-HISTORY T))
+  (HISTORY-ELEMENT-VISIBLE-P (PRESENTATION-HISTORY T))
+  (HISTORY-ELEMENTS-EQUAL (PRESENTATION-HISTORY T T))
+  (HISTORY-LENGTH (PRESENTATION-HISTORY))
+  (HISTORY-TOP-ELEMENT (PRESENTATION-HISTORY))
+  (PRESENTATION-HISTORY-TYPE (PRESENTATION-HISTORY))
+  (PRESENTATION-TYPE-FOR-YANKING (PRESENTATION-HISTORY))
+  (PRINT-HISTORY-ELEMENT (PRESENTATION-HISTORY T T))
+  (PUSH-HISTORY-ELEMENT (PRESENTATION-HISTORY T))
+  (UNPARSE-PRESENTATION-HISTORY-ELEMENT (PRESENTATION-HISTORY T)))
+
+
+;;; (generate-prefill-dispatch-caches 'presentation-translator)
+
+(PREFILL-DISPATCH-CACHES
+  (PRESENTATION-TRANSLATOR-COMMAND-NAME (PRESENTATION-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-DOCUMENTATION (PRESENTATION-TRANSLATOR)
+                                         (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-FROM-TYPE (PRESENTATION-TRANSLATOR)
+                                     (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-FUNCTION (PRESENTATION-TRANSLATOR)
+                                    (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-GESTURE-NAME (PRESENTATION-TRANSLATOR)
+					(PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-MENU (PRESENTATION-TRANSLATOR) (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-NAME (PRESENTATION-TRANSLATOR) (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-POINTER-DOCUMENTATION (PRESENTATION-TRANSLATOR)
+                                                 (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-PRIORITY (PRESENTATION-TRANSLATOR)
+                                    (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TESTER (PRESENTATION-TRANSLATOR)
+                                  (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TESTER-DEFINITIVE (PRESENTATION-TRANSLATOR)
+                                             (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TO-TYPE (PRESENTATION-TRANSLATOR)
+                                   (PRESENTATION-TO-COMMAND-TRANSLATOR)))
+
+
+;;; (generate-prefill-dispatch-caches 'presentation-to-command-translator)
+
+(PREFILL-DISPATCH-CACHES
+  (PRESENTATION-TRANSLATOR-DOCUMENTATION (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-FROM-TYPE (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-FUNCTION (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-GESTURE-NAME (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-MENU (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-NAME (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-POINTER-DOCUMENTATION (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-PRIORITY (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TESTER (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TESTER-DEFINITIVE (PRESENTATION-TO-COMMAND-TRANSLATOR))
+  (PRESENTATION-TRANSLATOR-TO-TYPE (PRESENTATION-TO-COMMAND-TRANSLATOR)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command))
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-VIEW)
+                 ((PRESENTATION-TYPE COMMAND) T T T T TEXTUAL-DIALOG-VIEW))
+  (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T))
+  (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T T))
+  (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-MENU-VIEW)
+                  ((PRESENTATION-TYPE COMMAND) T T T T T TEXTUAL-VIEW))
+  (PRESENTATION-SUBTYPEP-METHOD ((PRESENTATION-TYPE COMMAND) T T))
+  (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMMAND) T T))
+  (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND) T T T))
+  (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMMAND) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-name))
+
+(PREFILL-DISPATCH-CACHES
+ (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T T TEXTUAL-VIEW))
+ (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T T T TEXTUAL-VIEW))
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-NAME) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-arguments))
+
+(PREFILL-DISPATCH-CACHES
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-ARGUMENTS) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'keyword-argument-name))
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-or-form))
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T TEXTUAL-VIEW))
+  (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T T T))
+  (PRESENTATION-SUBTYPEP-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T))
+  (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T))
+  (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T))
+  (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMMAND-OR-FORM) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'expression))
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-METHOD ((PRESENTATION-TYPE FORM) T T T T TEXTUAL-VIEW))
+  (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE FORM) T T T T T))
+  (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE FORM) T T T T T T)
+				 ((PRESENTATION-TYPE EXPRESSION) T T T T T T))
+  (PRESENT-METHOD ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-MENU-VIEW)
+		  ((PRESENTATION-TYPE EXPRESSION) T T T T T TEXTUAL-VIEW)
+		  ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-MENU-VIEW)
+		  ((PRESENTATION-TYPE FORM) T T T T T TEXTUAL-VIEW))
+  (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE FORM) T T T)
+					((PRESENTATION-TYPE EXPRESSION) T T T)))
+
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'command-menu-element))
+
+(PREFILL-DISPATCH-CACHES
+ (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T T))
+ (PRESENT-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T T T TEXTUAL-VIEW))
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMMAND-MENU-ELEMENT) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'menu-item))
+
+(PREFILL-DISPATCH-CACHES
+ (HIGHLIGHT-PRESENTATION-METHOD ((PRESENTATION-TYPE MENU-ITEM) T T T T T T))
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE MENU-ITEM) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'completion))
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-PRESENT-DEFAULT-METHOD ((PRESENTATION-TYPE COMPLETION) T T T T TEXTUAL-DIALOG-VIEW T T T T))
+  (PRESENT-METHOD ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-VIEW)
+                  ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-MENU-VIEW)
+                  ((PRESENTATION-TYPE COMPLETION) T T T T T TEXTUAL-DIALOG-VIEW))
+  (PRESENTATION-DEFAULT-PREPROCESSOR-METHOD ((PRESENTATION-TYPE COMPLETION) T T))
+  (PRESENTATION-TYPE-HISTORY-METHOD ((PRESENTATION-TYPE COMPLETION) T T))
+  (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE COMPLETION) T T T))
+  (PRESENTATION-TYPEP-METHOD ((PRESENTATION-TYPE COMPLETION) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'subset-completion))
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'sequence))
+
+(PREFILL-DISPATCH-CACHES)
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'sequence-enumerated))
+
+(PREFILL-DISPATCH-CACHES
+  (DESCRIBE-PRESENTATION-TYPE-METHOD ((PRESENTATION-TYPE SEQUENCE-ENUMERATED) T T T T T))
+  (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE SEQUENCE-ENUMERATED) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'null))
+
+(PREFILL-DISPATCH-CACHES
+ (ACCEPT-METHOD ((PRESENTATION-TYPE NULL) T T T T TEXTUAL-VIEW))
+ (PRESENT-METHOD ((PRESENTATION-TYPE NULL) T T T T T TEXTUAL-VIEW))
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE NULL) T T T)))
+
+
+;;; (generate-prefill-dispatch-caches (find-presentation-type-class 'blank-area))
+
+(PREFILL-DISPATCH-CACHES
+ (PRESENTATION-TYPE-SPECIFIER-P-METHOD ((PRESENTATION-TYPE BLANK-AREA) T T T)))
diff --git a/clim/text-style.lisp b/clim/text-style.lisp
new file mode 100644
index 00000000..1ec27efc
--- /dev/null
+++ b/clim/text-style.lisp
@@ -0,0 +1,659 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: text-style.lisp,v 1.4 91/03/26 12:49:00 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; To consider: how to merge Genera styles with styles.
+
+(define-protocol-class text-style ())
+
+(defclass standard-text-style (text-style)
+     ((family :initarg :family :initform nil :reader text-style-family)
+      (face   :initarg :face   :initform nil :reader text-style-face)
+      (size   :initarg :size   :initform nil :reader text-style-size)
+      (index  :initarg :index  :initform nil)))
+
+(define-constructor make-text-style-1 standard-text-style (family face size index)
+  :family family :face face :size size :index index)
+
+(defmethod text-style-components ((style standard-text-style))
+  (with-slots (family face size) style
+    (values family face size)))
+
+(defmethod fully-merged-text-style-p ((style standard-text-style))
+  (with-slots (family face size) style
+    (and family face size)))
+
+(defmethod make-load-form ((object standard-text-style))
+  (with-slots (family face size) object
+    `(make-text-style ,family ,face ,size)))
+
+(defmethod print-object ((style standard-text-style) stream)
+  (with-slots (family face size) style
+    (let ((true-face (face-code->face face)))
+      #+Genera
+      (when *print-readably*
+	(format stream "#.(~S ~S)" 'parse-text-style
+		`'(,family ,true-face ,size))
+	(return-from print-object style))
+      (macrolet ((do-it ()
+		   `(format stream "~S.~S.~S" family true-face size)))
+	(if *print-escape*
+	    (print-unreadable-object (style stream :type t :identity t)
+	      (do-it))
+	    (do-it))))))
+
+(defclass device-font ()
+     ((display-device :initarg :display-device :reader device-font-display-device)
+      (font-name :initarg :font-name :reader device-font-name)))
+
+(defun make-device-font (display-device font-name)
+  (make-instance 'device-font :display-device display-device :font-name font-name))
+
+(defmethod print-object ((df device-font) stream)
+  (print-unreadable-object (df stream :type t :identity t)
+    (format stream "~A" (slot-value df 'font-name))))
+
+(defconstant maximum-text-style-index 256)	;Why not?  That's the Genera maximum
+
+(defvar *standard-character-set* nil)		;Not really used yet.
+
+(defvar *null-text-style*)
+(defvar *undefined-text-style*)
+(defvar *text-style-index-table*)
+(defvar *next-text-style-index*)
+(defvar *text-style-intern-table*)
+(defvar *text-style-merging-cache*)
+(defvar *default-text-style*)
+
+(defun initialize-text-style-tables ()
+  (setf *null-text-style* (make-text-style-1 nil nil nil 0)
+	*undefined-text-style* (make-text-style-1 (make-symbol "UNDEFINED") nil nil 1)
+	*next-text-style-index* 2
+	*text-style-index-table*
+	  (make-array maximum-text-style-index 
+		      :initial-element *undefined-text-style*)
+	*text-style-intern-table*
+	  (copy-tree `((nil . ((nil . ((nil . ,*null-text-style*)))))))
+	(aref *text-style-index-table* 0) *null-text-style*
+	*text-style-merging-cache*
+	  (make-array (* maximum-text-style-index 10)
+		      :element-type `(integer 0 (,maximum-text-style-index))
+		      :initial-element 0)
+	*default-text-style*
+	  (make-text-style :fix :roman :normal)
+	*undefined-text-style*
+	  (make-text-style :stand-in-for-undefined-style :roman :normal))
+  *null-text-style*)
+
+(defmethod parse-text-style ((text-style standard-text-style))
+  text-style)
+
+(defmethod parse-text-style ((text-style device-font))
+  text-style)
+
+(defmethod parse-text-style ((null null))
+  *null-text-style*)
+
+(defmethod parse-text-style ((style list))
+  (assert (= (length style) 3) (style)
+	  "A text style is a three element list (face family size), not ~S"
+	  style)
+  (apply #'make-text-style style))
+
+
+(defvar *text-style-lock* (make-lock "text style lock"))
+
+;;; The text-style table is an alist-structured database; the
+;;; first key is family, then face, then size.  This might or might not
+;;; be better than an EQUAL hash table.  We can decide later to do this
+;;; if we want.
+(defun make-text-style (family face size &aux changed-p original-face)
+  (unless (numberp face)
+    (setf original-face face
+	  face (face->face-code face)))		;"Intern" the face code.
+  (loop 
+    (let* ((family-stuff (assoc family *text-style-intern-table*))
+	   (face-stuff (and family-stuff (assoc face (cdr family-stuff))))
+	   (size-stuff (and face-stuff (assoc size (cdr face-stuff)))))
+      (when size-stuff (return-from make-text-style (cdr size-stuff)))
+      (multiple-value-setq (family face size changed-p original-face)
+	(validate-text-style-components family face size original-face))
+      (unless changed-p
+	(macrolet ((ensure-stuff (stuff thing from-stuff)
+		     `(unless ,stuff
+			(setf ,stuff (cons ,thing nil))
+			(with-lock-held (*text-style-lock* "Text style lock")
+			  (setf ,from-stuff (nconc ,from-stuff (cons ,stuff nil)))))))
+	  (ensure-stuff family-stuff family *text-style-intern-table*)
+	  (ensure-stuff face-stuff face family-stuff)
+	  (ensure-stuff size-stuff size face-stuff))
+	(let* ((new-style (make-text-style-1 family face size nil)))
+	  (setf (cdr size-stuff) new-style)
+	  (return-from make-text-style new-style))))))
+
+(defmethod text-style-index ((text-style standard-text-style))
+  (with-slots (index) text-style
+    (when index (return-from text-style-index index))
+    (let* ((new-index (with-lock-held (*text-style-lock* "Text style lock")
+			(prog1 *next-text-style-index*
+			       (incf *next-text-style-index*)))))
+      (when (> new-index maximum-text-style-index)
+	(error "Too many text style indices; can't assign an index to ~A"
+	       text-style))
+      (setf (aref *text-style-index-table* new-index) text-style)
+      (setf index new-index))))
+
+(defvar *valid-text-style-sizes*
+	'(:tiny :very-small :small :normal :large :very-large :huge))
+
+(defun validate-text-style-components (family face size &optional original-face)
+  (when (consp face)				;This is an error in face->face-code.
+    (apply #'error face))
+  ;;--- Handle point sizes
+  (unless (or (null size)
+	      (numberp size)
+	      (member size *valid-text-style-sizes*)
+	      (eql size :smaller)
+	      (eql size :larger))
+    (error "The size ~S is not valid." size))
+  ;; This needs to be fleshed out with error handlers, etc.
+  (values family face size nil original-face))
+
+(defun-inline index->text-style (index)
+  (aref *text-style-index-table* index))
+
+;;; General case
+(defmethod merge-text-styles (style1 style2)
+  (setf style1 (parse-text-style style1)
+	style2 (parse-text-style style2))
+  (index->text-style
+    (merge-text-style-indices (text-style-index style1)
+			      (text-style-index style2))))
+
+;;; Device fonts can't be merged against anything.
+(defmethod merge-text-styles ((style1 device-font) style2)
+  (declare (ignore style2))
+  style1)
+
+(defmethod merge-text-styles (style1 (style2 device-font))
+  (declare (ignore style1))
+  style2)
+
+(defun merge-text-style-indices (index1 index2)
+  (when (zerop index1) (return-from merge-text-style-indices index2))
+  (let ((subscript (+ index1 (* index2 maximum-text-style-index))))
+    (when (>= subscript (array-total-size *text-style-merging-cache*))
+      (let ((new (make-array (* (min (+ index2 5) maximum-text-style-index)
+				maximum-text-style-index)
+			     :element-type `(integer 0 (,maximum-text-style-index))
+			     :initial-element 0)))
+	(replace new *text-style-merging-cache*)
+	(setq *text-style-merging-cache* new)))
+    (let ((merged-style-index (aref *text-style-merging-cache* subscript)))
+      (when (plusp merged-style-index)
+	(return-from merge-text-style-indices merged-style-index)))
+    (let ((merged-style-index
+	    (text-style-index
+	      (multiple-value-bind (result-family result-face result-size)
+		  (multiple-value-bind (family1 face1 size1)
+		      (text-style-components (index->text-style index1))
+		    (multiple-value-bind (family2 face2 size2)
+			(text-style-components (index->text-style index2))
+		      (merge-text-style-components family1 face1 size1
+						   family2 face2 size2)))
+		(make-text-style result-family result-face result-size)))))
+      (setf (aref *text-style-merging-cache* subscript) merged-style-index)
+      merged-style-index)))
+
+(defun merge-text-style-components (family1 face1 size1 family2 face2 size2)
+  (values (merge-text-style-families family1 family2)
+	  (merge-text-style-faces face1 face2)
+	  (merge-text-style-sizes size1 size2)))
+
+(defun merge-text-style-families (family1 family2)
+  (or family1 family2))
+
+(defun merge-text-style-sizes (size1 size2)
+  (let ((max-larger-size 24)			;limits for :LARGER and :SMALLER
+	(min-smaller-size 4))
+    (case size1
+      (:larger
+	(cond ((numberp size2) (min (+ size2 2) max-larger-size))
+	      ((eql size2 :smaller) nil)	;let a higher level decide...
+	      (t (let ((index (position size2 *valid-text-style-sizes*)))
+		   (if (null index)
+		       size1
+		       (or (nth (1+ index) *valid-text-style-sizes*) :huge))))))
+      (:smaller
+	(cond ((numberp size2) (max (- size2 2) min-smaller-size))
+	      ((eql size2 :larger) nil)		;let a higher level decide...
+	      (t (let ((index (position size2 *valid-text-style-sizes*)))
+		   (if (null index)
+		       size1
+		       (if (zerop index) :tiny (nth (1- index) *valid-text-style-sizes*)))))))
+      (otherwise
+	(or size1 size2)))))
+
+(defmacro define-text-face-class (class name-list lambda-list &body merging-function
+				  &environment env)
+  (multiple-value-bind (documentation declarations body)
+      (extract-declarations merging-function env)
+    (let ((text-face-class-definitions
+	    (mapcar #'(lambda (name) `(add-text-face-class ',name ',class)) name-list))
+	  (face-code-mask-macro-name (fintern "~A-~A" class 'face-code-mask))
+	  (set-bits-macro-name (fintern "~A-~A-~A" 'set class 'face-code-bits))
+	  (reset-bits-macro-name (fintern "~A-~A-~A" 'reset class 'face-code-bits))
+	  (test-bits-macro-name (fintern "~A-~A-~A" 'test class 'face-code-bits)))
+      `(define-group ,class define-text-face-class
+	 (define-text-face-class-load-time ',class)
+
+	 ;; Cloe doesn't appear able to find the MACROLETted versions below.
+	 #+Cloe-Runtime				;Cloe bug?
+	 (progn
+	   (defmacro ,face-code-mask-macro-name (&rest face-codes)
+	     (let ((result 0))
+	       (dolist (face-code face-codes result)
+		 (assert (member face-code ',name-list))
+		 (setf result (logior result
+				      (ash 1 (position face-code ',name-list)))))))
+	   (defmacro ,test-bits-macro-name (datum &rest face-codes)
+	     `(logtest ,datum (,',face-code-mask-macro-name ,@face-codes)))
+	   (defmacro ,set-bits-macro-name (datum &rest face-codes)
+	     `(setf ,datum
+		    (logior ,datum (,',face-code-mask-macro-name ,@face-codes))))
+	   (defmacro ,reset-bits-macro-name (datum &rest face-codes)
+	     `(setf ,datum
+		    (logand ,datum
+			    (lognot (,',face-code-mask-macro-name ,@face-codes))))))
+	 (defun-property (:property ,class face-class-merging-function) ,lambda-list
+	   ,@declarations
+	   ,@(when documentation (list documentation))
+	   (macrolet ((,face-code-mask-macro-name (&rest face-codes)
+		       (let ((result 0))
+			 (dolist (face-code face-codes result)
+			   (assert (member face-code ',name-list))
+			   (setf result (logior result
+						(ash 1 (position face-code ',name-list)))))))
+		      (,test-bits-macro-name (datum &rest face-codes)
+		       `(logtest ,datum (,',face-code-mask-macro-name ,@face-codes)))
+		      (,set-bits-macro-name (datum &rest face-codes)
+		       `(setf ,datum
+			      (logior ,datum (,',face-code-mask-macro-name ,@face-codes))))
+		      (,reset-bits-macro-name (datum &rest face-codes)
+		       `(setf ,datum
+			      (logand ,datum
+				      (lognot (,',face-code-mask-macro-name ,@face-codes))))))
+	     ,@body))
+	 ,@text-face-class-definitions))))
+
+(defmacro define-text-face-added-mappings (class &body mappings)
+  `(add-face-added-text-mappings ',class ',mappings))
+
+(defvar *face->face-code-cache* nil)
+(defvar *face-added-text-mapping-cache* nil)
+
+(defun define-text-face-class-load-time (class)
+  (let ((alist (assoc class *face->face-code-cache*)))
+    (when (null alist)
+      (setf alist (cons class nil))
+      (setf *face->face-code-cache* (nconc *face->face-code-cache* (list alist))))))
+
+(defmacro define-text-face (name class)
+  `(add-text-face-class ',name ',class))
+
+(defun add-text-face-class (name class)
+  (let ((alist (assoc class *face->face-code-cache*)))
+    (when (null alist)
+      (error "Can't define face ~S in unknown face class ~S." name class))
+    (unless (member name (cdr alist))
+      (nconc alist (list name)))))
+
+(defun add-face-added-text-mappings (class mappings)
+  (let ((pair (assoc class *face-added-text-mapping-cache*)))
+    (unless pair
+      (setf pair (list class))
+      (push pair *face-added-text-mapping-cache*))
+    (dorest (mapping-pair mappings cddr)
+      (let* ((logical (first mapping-pair))
+	     (underlying (face->face-code (second mapping-pair)))
+	     (mapping-pair (assoc logical (cdr pair))))
+	(if mapping-pair
+	    (setf (cdr mapping-pair) underlying)
+	    (push (cons logical underlying) (cdr pair)))))))
+
+(defconstant %%face-code-no-merge (byte 1 28))
+(defconstant %%face-code-class (byte 4 24))
+(defconstant %%face-code-faces (byte 24 0))
+
+(defun face->face-code (face)
+  (when (null face) (return-from face->face-code nil))
+  (let ((class-alist nil)
+	(added-mapping-alist nil)
+	(class-number nil)
+	(value 0)
+	(no-merge 0))
+    (flet ((parse-face (face)
+	     (when (eql face :no-merge)
+	       (setf no-merge 1)
+	       (return-from parse-face 0))
+	     (if class-number
+		 (or
+		   (cdr (assoc face (cdr added-mapping-alist)))
+		   (ash 1
+			(or (position face (cdr class-alist))
+			    (return-from face->face-code	;Return an error indication.
+			      (list "Can't parse face ~S in class ~S"
+				    face (car class-alist))))))
+		 (do ((face-cache *face->face-code-cache* (cdr face-cache))
+		      (class-no 0 (1+ class-no)))
+		     ((null face-cache)
+		      (return-from face->face-code (list "Can't parse face ~S" face)))
+		   (let ((value (position face (cdar face-cache))))
+		     (when value
+		       (setf class-number class-no
+			     class-alist (car face-cache)
+			     added-mapping-alist (assoc (car class-alist)
+							*face-added-text-mapping-cache*))
+		       (return (ash 1 value))))
+		   (let* ((added-value-mapping-alist 
+			    (assoc (caar face-cache) *face-added-text-mapping-cache*))
+			  (value (cdr (assoc face (cdr added-value-mapping-alist)))))
+		     (when value
+		       (setf class-number class-no
+			     class-alist (car face-cache)
+			     added-mapping-alist added-value-mapping-alist)
+		       (return value)))))))
+      (if (listp face)
+	  (dolist (face face)
+	    (setf value (logior value (parse-face face))))
+	  (setf value (parse-face face))))
+    (dpb class-number %%face-code-class
+	 (dpb value %%face-code-faces
+	      (dpb no-merge %%face-code-no-merge 0)))))
+
+(defvar *face-code->face-cache* (make-hash-table))
+
+(defun face-code->face (face-code)
+  (when (or (null face-code) (zerop face-code))	;?? zerop?
+    (return-from face-code->face nil))
+  (or (gethash face-code *face-code->face-cache*)
+      (let* ((class-number (ldb %%face-code-class face-code))
+	     (face-bits (ldb %%face-code-faces face-code))
+	     (class-alist (cdr (nth class-number *face->face-code-cache*)))
+	     (result (if (ldb-test %%face-code-no-merge face-code)
+			 (list :no-merge)
+			 (= (logcount face-bits) 1))))
+	(loop
+	  (when (zerop face-bits)
+	    (return (setf (gethash face-code *face-code->face-cache*) (nreverse result))))
+	  (when (logtest face-bits 1)
+	    (when (eql result t) (return (car class-alist)))
+	    (push (car class-alist) result))
+	  (pop class-alist)
+	  (setf face-bits (ash face-bits -1))))))
+
+(defun merge-text-style-faces (face1 face2)
+  (when (null face1) (return-from merge-text-style-faces face2))
+  (when (null face2) (return-from merge-text-style-faces face1))
+  (let ((class1 (ldb %%face-code-class face1)))
+    (unless (= class1 (ldb %%face-code-class face2))
+      (return-from merge-text-style-faces face1))
+    (funcall (get (car (nth class1 *face->face-code-cache*)) 'face-class-merging-function)
+	     face1 face2)))
+
+(define-text-face-class :roman (:roman :extra :bold :italic :condensed :extended
+				:caps :underline :outline :shadow)
+			(face1 face2)
+  (let ((result (logior face1 face2)))
+    (when (ldb-test %%face-code-no-merge face1)
+      (setf result (dpb 0 %%face-code-no-merge face1)))
+    ;; Some heuristics: when condensed, we're not extended and vice-versa
+    (when (test-roman-face-code-bits face1 :condensed)
+      (reset-roman-face-code-bits result :extended))
+    (when (test-roman-face-code-bits face1 :extended)
+      (reset-roman-face-code-bits result :condensed))
+    ;; And a couple more: when roman, we're not bold or italic, and vice-versa
+    (when (test-roman-face-code-bits face1 :roman)
+      (reset-roman-face-code-bits result :bold :italic :extra))
+    (when (test-roman-face-code-bits face1 :bold :italic)
+      (reset-roman-face-code-bits result :roman))
+    result))
+
+(define-text-face-added-mappings :roman
+  :bold-italic (:bold :italic)
+  :bold-condensed-caps (:bold :condensed :caps)
+  :bold-extended (:bold :extended)
+  :extra-condensed (:extra :condensed))
+
+(define-text-face-class :special (:uppercase)
+			(face1 face2)
+  (or face1 face2))
+
+(define-text-face-class :logical ()
+			(face1 face2)
+  (declare (ignore face2))
+  face1)
+
+(when (not (boundp '*null-text-style*))
+  (initialize-text-style-tables))
+
+
+(defgeneric text-style-height (text-style medium))
+(defgeneric text-style-width (text-style medium))
+(defgeneric text-style-ascent (text-style medium))
+(defgeneric text-style-descent (text-style medium))
+(defgeneric text-style-fixed-width-p (text-style medium))
+
+(defgeneric text-size (medium string &key text-style start end)
+  (declare (values width height final-x final-y baseline)))
+
+
+(defmethod text-style-height ((text-style standard-text-style)
+			      (stream standard-encapsulating-stream))
+  (text-style-height text-style (slot-value stream 'stream)))
+
+(defmethod text-style-width ((text-style standard-text-style)
+			     (stream standard-encapsulating-stream))
+  (text-style-width text-style (slot-value stream 'stream)))
+
+(defmethod text-style-ascent ((text-style standard-text-style)
+			      (stream standard-encapsulating-stream))
+  (text-style-ascent text-style (slot-value stream 'stream)))
+
+(defmethod text-style-descent ((text-style standard-text-style) 
+			       (stream standard-encapsulating-stream))
+  (text-style-descent text-style (slot-value stream 'stream)))
+
+(defmethod text-style-fixed-width-p ((text-style standard-text-style) 
+				     (stream standard-encapsulating-stream))
+  (text-style-fixed-width-p text-style (slot-value stream 'stream)))
+
+(defmethod text-size ((stream standard-encapsulating-stream) string
+		      &key (text-style (stream-merged-text-style stream)) (start 0) end)
+  (text-size stream string :text-style text-style :start start :end end))
+
+
+#-Genera
+(defun merged-text-style (character style)
+  (values character style))
+
+#+Genera
+(progn
+
+(defvar *genera-style-to-style-table* (make-array 256 :initial-element nil))
+
+(defun genera-style->style (character-style)
+  (let ((index (si:style-index character-style)))
+    (or (aref *genera-style-to-style-table* index)
+	(setf (aref *genera-style-to-style-table* index)
+	      (parse-text-style (si:unparse-character-style character-style))))))
+
+(defun merged-text-style (character style)
+  (let* ((char-style (si:char-style character))
+	 (char-style (genera-style->style char-style))
+	 (merged-style (merge-text-styles style char-style)))
+    (values (sys:make-character character :style nil) merged-style)))
+) ;;; End of #+Genera
+
+
+;; See SHEET-GRAPHICS-IMPLEMENTATION for an example of its use...
+(defmacro define-display-device (name class &key font-for-undefined-style)
+  `(defvar ,name (make-instance ',class 
+				:name ',name
+				:font-for-undefined-style ',font-for-undefined-style)))
+
+;;; [ 1/4/90 naha -- determined by reading DEFINE-TEXT-STYLE-MAPPINGS-LOAD-TIME ]
+;;; each element of SPECS can be one of
+;;;     `(:style ,family ,face ,size)   [what will this do?]
+;;;     `(:family ,family ,specs)       ==> recurse on specs for specified family
+;;;     `(:face ,face ,specs)           ==> recurse on specs for specified face
+;;;     `(:size ,size ,specs)           ==> recurse on specs for specified size
+;;;     the name of a font to map the specified text style to.
+
+(defmacro define-text-style-mappings (device character-set &body specs)
+  `(define-text-style-mappings-load-time ,device ,character-set ',specs))
+
+(defun define-text-style-mappings-load-time (device character-set specs)
+  (labels ((load-specs (family face size specs)
+	     (when (and (consp specs) (eql (first specs) :style))
+	       (setf specs (apply #'make-text-style (rest specs))))
+	     (if (and (consp specs) (not (eql (car specs) :style)))
+		 (do* ((type (first specs))
+		       (my-specs (cdr specs) (cddr my-specs))
+		       (value (first my-specs) (first my-specs))
+		       (rest (second my-specs) (second my-specs)))
+		      ((null my-specs))
+		   (case type
+		     (:family (setf family value))
+		     (:face (setf face value))
+		     (:size (setf size value))
+		     (otherwise (warn "Ill-formed mapping contains ~S" specs)))
+		   (load-specs family face size rest))
+		 (if (and family face size)
+		     (setf (text-style-mapping 
+			     device character-set (make-text-style family face size))
+			   specs)
+		     (error "Can't do [~A.~A.~A]" family face size)))))
+    (dolist (spec specs)
+      (load-specs nil nil nil spec))))
+
+(defclass display-device ()
+     ((name :initarg :name :reader display-device-name)
+      (mapping-table :initform (make-hash-table))))
+
+(defvar *display-devices* nil)
+
+(defmethod initialize-instance :after
+    ((device display-device) &key font-for-undefined-style)
+  ;; Keep track of all of the display devices
+  (push-unique device *display-devices* :key #'display-device-name)
+  (when font-for-undefined-style
+    (setf (text-style-mapping
+	    device *standard-character-set* *undefined-text-style*)
+	  font-for-undefined-style)))
+
+(defmethod print-object ((device display-device) stream)
+  (print-unreadable-object (device stream :type t :identity t)
+    (format stream "~A" (slot-value device 'name))))
+
+(defmethod (setf text-style-mapping)
+	   (mapping (device display-device) character-set style &optional window)
+  (declare (ignore window))
+  (setq style (standardize-text-style device character-set style))
+  (when (listp mapping)
+    (assert (eql (first mapping) :style) ()
+	    "Text style mappings must be atomic font names ~
+	     or (:STYLE . (family face size))")
+    (setf mapping (parse-text-style (cdr mapping))))
+  (setf (gethash style (slot-value device 'mapping-table)) mapping))
+
+#+CLIM-1-compatibility
+(define-compatibility-function (add-text-style-mapping (setf text-style-mapping))
+			       (device character-set style mapping)
+  (setf (text-style-mapping device character-set style) mapping))
+
+;;; This is broken up into two methods so any :AROUND method will only
+;;; be called on the outermost recursion.
+(defmethod text-style-mapping
+	   ((device display-device) character-set style &optional window)
+  (text-style-mapping* device character-set style window))
+
+(defmethod text-style-mapping
+	   ((device display-device) character-set (style device-font) &optional window)
+  (declare (ignore character-set window))
+  ;;--- What about character-set when using device fonts?
+  ;;--- EQL? TYPE-EQUAL?  This is too restrictive as it stands
+  (unless (eql device (device-font-display-device style))
+    (error "An attempt was made to map device font ~S on device ~S, ~@
+	    but it is defined for device ~S"
+	   style device (device-font-display-device style)))
+  (device-font-name style))
+
+(defmethod text-style-mapping* ((device display-device) character-set style &optional window)
+  (setq style (standardize-text-style device character-set (parse-text-style style)))
+  (let* ((mapping-table (slot-value device 'mapping-table))
+	 (result (or (gethash style mapping-table)
+		     (gethash *undefined-text-style* mapping-table))))
+    (when (text-style-p result)			;logical translations
+      (setf result (text-style-mapping* device character-set result window)))
+    result))
+
+(defmethod text-style-mapping-exists-p ((device display-device) character-set style)
+  (setq style (standardize-text-style device character-set (parse-text-style style)))
+  (let* ((mapping-table (slot-value device 'mapping-table))
+	 (result (gethash style mapping-table)))
+    (cond ((null result) nil)
+	  ((text-style-p result)		;logical translations
+	   (text-style-mapping-exists-p device character-set style))
+	  (t t))))
+
+;; This method allows the device to convert logical sizes into point
+;; sizes, etc.  The default method doesn't do much of anything.
+(defmethod standardize-text-style ((device display-device) character-set style)
+  (declare (ignore character-set))
+  (unless (numberp (text-style-size style))
+    (standardize-text-style-error style))
+  style)
+
+(defun standardize-text-style-error (style)
+  (if (fully-merged-text-style-p style)
+      (cerror "Use the undefined text style stand-in instead"
+	      "The size component of ~S is not numeric.  This display-device does not know ~
+	       how to map logical text style sizes"
+	      style)
+      (cerror "Use the undefined text style stand-in instead"
+	      "The text style ~S must be a fully merged text style"
+	      style))
+  *undefined-text-style*)
+
+;; For use by more specific STANDARDIZE-TEXT-STYLE methods
+(defun-inline standardize-text-style-1 (display-device style character-set size-alist)
+  (declare (ignore display-device character-set))
+  (let ((size (text-style-size style)))
+    (if (numberp size)
+	style
+	(let ((new-size (assoc size size-alist)))
+	  (cond (new-size
+		 (make-text-style (text-style-family style)
+				  (text-style-face style)
+				  (second new-size)))
+		(t
+		 (standardize-text-style-error style)))))))
+
+
+;;; Extensions to Common Lisp character operations.
+
+(defun-inline diacritic-char-p (character)
+  #-Genera (declare (ignore character))
+  #+Genera (si:diacritic-char-p character)
+  #-Genera nil)
+
+;;; For now, only standard character set characters are understood...
+(defun-inline char-character-set-and-index (character)
+  (declare (values character-set index))
+  (values *standard-character-set* (char-code character)))
diff --git a/demo/browser.lisp b/demo/browser.lisp
new file mode 100644
index 00000000..f23307cf
--- /dev/null
+++ b/demo/browser.lisp
@@ -0,0 +1,1383 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Package: (CLIM-BROWSER :use (CLIM-LISP CLIM)); Base: 10; Lowercase: Yes -*-
+
+;;; Simple extensible browser
+;;; Scott McKay
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; To use the Browser, first choose a browser type and browser subtype from
+;;; the ACCEPTING-VALUES pane in the lower right corner. 
+;;; 
+;;; After you have selected a browser type, use the "Show Graph" command to
+;;; specify the root node for the graph.  You can supply more than one root.
+;;; The type of the object you supply to "Show Graph" varies with what the
+;;; browser type is (for example, when browsing classes you should type in
+;;; a class name.)
+;;; 
+;;; Once there is a graph drawn, there are a number of useful mouse gestures
+;;; defined for the nodes in the graph:
+;;; 
+;;; 
+;;; 
+;;; 
+;;;   inferiors, and replaces them with an ellipsis node (indicated by "...").
+;;; 
+;;; 
+;;; 
+;;;   create some sort of "subnode" which contains additional information (for
+;;;   example, the slots for a class).
+;;; 
+;;;   of operations specific to the browser type (for example, when browsing
+;;;   classes you might get other class-related commands).
+;;;
+;;; There are some other options in the ACCEPTING-VALUES pane:
+;;; 
+;;; 
+;;;   should be shared or not.  
+;;;
+;;; There are also a few command buttons:
+;;; 
+;;; 
+;;; 
+;;; 
+;;; 
+;;; 
+;;;   The items it displays are mouse-sensitive.
+;;; 
+;;;
+;;; There are a few additional commands:
+;;; 
+;;;   are currently two modes, graphical and textual.
+;;;
+;;; It is pretty obvious how to write your own browser extensions.  Enjoy.
+
+;;--- This presumes that both SAP:>swm>clim>code>draw-arrow.lisp is loaded
+
+
+;;; Utilities
+
+(defparameter *browser-print-length* 2)
+(defparameter *browser-print-level* 2)
+
+(defun false (&rest args)
+  (declare (ignore args))
+  nil)
+
+(defun true (&rest args)
+  (declare (ignore args))
+  t)
+
+(defmacro with-browser-io-environment (&body body)
+  `(invoke-with-browser-io-environment #'(lambda () ,@body)))
+
+(defun invoke-with-browser-io-environment (continuation)
+  (declare (dynamic-extent continuation))
+  ;; Heavily truncate the printed result
+  (let ((*print-base* 10)
+	(*print-radix* nil)	  
+	(*print-readably* nil)
+	(*print-pretty* nil)
+	(*print-length* *browser-print-length*)
+	(*print-level* *browser-print-level*)
+	(*print-circle* nil)
+	(*print-array* nil)
+	(*print-escape* t)
+	#+Genera (scl:*print-string-length* nil)
+	#+Genera (scl:*print-structure-contents* nil))
+    (funcall continuation)))
+
+(defmacro centering-line ((&optional stream) &body body)
+  `(invoke-centering-line #'(lambda (,stream) ,@body) ,stream))
+
+(defun invoke-centering-line (continuation stream)
+  (multiple-value-bind (sx sy) (stream-cursor-position* stream)
+    (let ((inside-width (window-inside-width stream))
+	  (line-width (bounding-rectangle-width 
+			(with-output-to-output-record (stream)
+			  (funcall continuation stream)))))
+      (stream-set-cursor-position* stream (+ sx (floor (- inside-width line-width) 2)) sy)
+      (funcall continuation stream))))
+
+
+;;; Basic call nodes
+
+;; These are the generic functions that are intended to be specialized
+(defgeneric node-object-name (call-node))
+(defgeneric display-node (call-node stream))
+(defgeneric node-generate-inferior-objects (call-node subtype))
+(defgeneric node-any-inferior-objects-p (call-node subtype))
+(defgeneric node-arc-drawer (call-node)
+  #+Genera (declare (values arc-drawer arc-drawing-options)))
+
+
+(defclass basic-call-node ()
+    ((object :reader node-object :initarg :object)
+     (inferiors :accessor node-inferiors :initform nil)
+     (superiors :accessor node-superiors :initform nil)
+     ;; RECURSES is T iff this node eventually calls itself
+     (recurses  :accessor node-recurses  :initform nil)
+     (tick :accessor node-tick :initform 0)))
+  
+(defmethod node-object-name ((node basic-call-node))
+  (node-object node))
+
+(defmethod print-object ((node basic-call-node) stream)
+  (with-browser-io-environment
+    (if *print-escape*
+	(print-unreadable-object (node stream :type t :identity t)
+	  (write (node-object-name node) :stream stream :escape nil))
+        (write (node-object-name node) :stream stream :escape nil))))
+
+;; Propagate ticks up the graph to get proper redisplay.
+(defmethod tick-node ((node basic-call-node))
+  (labels ((tick (node)
+	     (incf (node-tick node))
+	     ;; No need to check for recursion since it is the responsibility
+	     ;; of the graph generator to do that.
+	     (dolist (superior (node-superiors node))
+	       (tick superior))))
+    (declare (dynamic-extent #'tick))
+    (tick node)))
+
+(defparameter *display-node-character-style* '(:sans-serif nil :very-small))
+(defmethod display-node :around ((node basic-call-node) stream)
+  (updating-output (stream :unique-id node
+			   :cache-value (node-tick node))
+    (with-text-style (stream *display-node-character-style*)
+      (call-next-method node stream))))
+
+(defmethod display-node ((node basic-call-node) stream)
+  (with-output-as-presentation (stream node (presentation-type-of node))
+    (write (node-object node) :stream stream :escape nil)))
+
+;; Let the "to" node contribute to the drawing of the arc to it.
+(defmethod node-arc-drawer ((node basic-call-node))
+  (values #'draw-arrow* nil))
+
+(defmethod node-generate-inferior-objects ((node basic-call-node) subtype)
+  (declare (ignore subtype))
+  nil)
+
+;; Answers the question "will NODE-GENERATE-INFERIOR-OBJECTS return anything?",
+;; except that it's allowed to be much faster.  If this returns T, that means
+;; NODE-GENERATE-INFERIOR-OBJECTS might return something; if this returns NIL,
+;; then NODE-GENERATE-INFERIOR-OBJECTS will definitely not return anything.
+(defmethod node-any-inferior-objects-p ((node basic-call-node) subtype)
+  (declare (ignore subtype))
+  t)
+
+(defun node-eql (n1 n2)
+  (eql (node-object n1) (node-object n2)))
+
+
+;; This is the most basic instantiable sort of call node.
+;; Commands and translators are written on this, not on BASIC-CALL-NODE.
+(defclass call-node (basic-call-node) ())
+
+;; CALL-SUBNODEs are a stripped-down version of CALL-NODEs, which mostly
+;; means that most commands and translators don't operate on subnodes.
+(defclass call-subnode (basic-call-node) ())
+
+(defmethod node-any-inferior-objects-p ((node call-subnode) type)
+  (declare (ignore type))
+  nil)
+
+(defmethod node-arc-drawer ((node call-subnode))
+  (values #'draw-arrow* '(:line-dashes #(2 2))))
+
+
+;; Ellipsis nodes
+(defclass ellipsis-call-node
+	  (basic-call-node)
+    ((replaced-node :reader ellipsis-node-replaced-node :initarg :replaced-node)))
+
+(proclaim '(inline make-ellipsis-call-node))
+(defun make-ellipsis-call-node (object replaced-node)
+  (make-instance 'ellipsis-call-node :object object :replaced-node replaced-node))
+
+(defmethod initialize-instance :after ((node ellipsis-call-node) &rest init-options)
+  (declare (ignore init-options))
+  ;; The inferiors of the ellipsis node are all of the combined inferiors
+  ;; of the node we are replacing
+  (let ((inferiors nil))
+    (dolist (inferior (node-inferiors (ellipsis-node-replaced-node node)))
+      (setq inferiors (nconc inferiors (copy-list (node-inferiors inferior)))))
+    (setf (node-inferiors node) inferiors))
+  node)
+
+(defmethod display-node ((node ellipsis-call-node) stream)
+  (with-output-as-presentation (stream node 'ellipsis-call-node)
+    (write-string "..." stream)))
+
+
+;;; Hooks to define a type of browser
+
+(defvar *browser-types* nil)
+
+(defgeneric browser-type-subtypes (type))
+(defgeneric browser-type-information (type subtype)
+  #+Genera (declare (values node-maker root-node-maker
+			    graph-type grapher-args presentation-type options)))
+
+(defmacro define-browser-type (type presentation-type graph-type options &body subtypes)
+  #+Genera (declare (zwei:indentation 3 3 4 1))
+  (let ((subtype-names (mapcar #'first subtypes)))
+    `(progn
+       (let ((old (member ',type *browser-types*)))
+	 (if old
+	     (setf (car old) ',type)
+	     (setq *browser-types* (nconc *browser-types* (list ',type)))))
+       (defmethod browser-type-subtypes ((type (eql ',type)))
+	 ',subtype-names)
+       ,@(mapcar 
+	   #'(lambda (entry)
+	       (destructuring-bind (subtype node-maker root-node-maker grapher-args) entry
+		 `(defmethod browser-type-information ((type (eql ',type))
+						       (subtype (eql ',subtype)))
+		    (values ',node-maker ',root-node-maker
+			    ',graph-type ',grapher-args 
+			    ',presentation-type ',options))))
+	   subtypes))))
+
+
+;;; Function call browsing
+
+(defclass function-call-node (call-node) ())
+  
+(proclaim '(inline make-function-call-node))
+(defun make-function-call-node (object)
+  (make-instance 'function-call-node :object object))
+
+(defmethod node-object-name ((node function-call-node))
+  (let ((function (node-object node)))
+    #+Genera (if (functionp function) (sys:function-name function) function)
+    #-Genera function))
+
+(defmethod display-node ((node function-call-node) stream)
+  (labels ((draw (stream)
+	     (with-output-as-presentation (stream node 'function-call-node)
+	       (present (node-object-name node) 'expression :stream stream))))
+    (declare (dynamic-extent #'draw))
+    (if (node-recurses node)
+	(surrounding-output-with-border (stream :shape :rectangle)
+	  (draw stream))
+	(draw stream))))
+
+(define-browser-type :function expression :graphical
+    ()
+  (:callees make-function-call-node function-browser-make-root
+	    (:arc-drawer draw-arrow*))
+  (:callers make-function-call-node function-browser-make-root
+	    (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil))))
+
+(defun function-browser-make-root (object)
+  (typecase object
+    (function 
+      (make-function-call-node object))
+    (symbol
+      (when (fboundp object)
+	(make-function-call-node (fdefinition object))))))
+
+#+Genera
+(defmethod node-generate-inferior-objects ((node function-call-node) (type (eql ':callees)))
+  (let ((function (node-object node)))
+    (typecase function
+      (compiled-function
+	(let ((callees nil))
+	  (si:map-over-compiled-function-callees
+	    function
+	    #'(lambda (caller callee how)
+		(declare (ignore caller))
+		(case how
+		  ((:function :generic-function)
+		   (pushnew (sys:fdefinition callee) callees))
+		  (:variable
+		    (pushnew callee callees))))
+	    :external-references t)
+	  (nreverse callees)))
+      (flavor:generic-function
+	;; Return all the real methods for this generic function
+	(loop for method in (sort (flavor:generic-function-methods
+				    (sys:generic-function-name function))
+				  #'string-lessp
+				  :key #'flavor:method-flavor)
+	      as function = (unless (and (listp method)
+					 (eql (first method) 'flavor:read-instance-variable))
+			      (si:valid-function-definition method))
+	      when function
+		collect function))
+      (clos:generic-function
+	;; Return all the real methods for this generic function
+	(loop for method in (clos-internals::sort-generic-function-methods
+			      function
+			      (copy-list (clos:generic-function-methods function))
+			      :sort :heuristic)
+	      as function = (clos:method-function method)
+	      when function
+		collect function)))))
+
+#+Genera
+(defmethod node-generate-inferior-objects ((node function-call-node) (type (eql ':callers)))
+  (let ((function (node-object node)))
+    (let ((callee-function-name (sys:function-name function)))
+      (typecase callee-function-name
+	(clos:method
+	  (list (clos:method-generic-function callee-function-name)))
+	(t
+	  (if (and (listp callee-function-name)
+		   (eql (car callee-function-name) 'flavor:method))
+	      (list (flavor:method-generic callee-function-name))
+	      (let ((callers nil))
+		(si:map-over-callers
+		  (sys:function-name function)
+		  #'(lambda (caller how)
+		      (case how
+			((:function :generic-function :macro)
+			 (pushnew (sys:fdefinition caller) callers))
+			(:variable
+			  (pushnew caller callers))))
+		  :called-how '(:function :generic-function :macro :variable))
+		(nreverse callers))))))))
+
+
+;;; CLOS class browsing
+
+(define-presentation-type class ()
+  :history t)
+
+#+Genera
+(define-presentation-method accept ((type class) stream (view textual-view) &key)
+  (find-class
+    (completing-from-suggestions (stream :partial-completers '(#\-))
+      (map nil #'(lambda (x) 
+		   (if (listp x)
+		       (suggest (first x) (second x))
+		       (suggest (symbol-name x) x)))
+	   clos-internals:*all-class-names-aarray*))))
+
+#-Genera
+(define-presentation-method accept ((type class) stream (view textual-view) &key default)
+  (let* ((class-name (accept 'symbol :stream stream :view view
+				     :default (and default (class-name default))
+				     :prompt nil))
+	 (class (find-class class-name nil)))
+    (unless class
+      (input-not-of-required-type class-name type))
+    class))
+
+(define-presentation-method present (class (type class) stream (view textual-view) &key)
+  (prin1 (class-name class) stream))
+
+
+(defclass class-call-node (call-node) ())
+
+(proclaim '(inline make-class-call-node))
+(defun make-class-call-node (object)
+  (make-instance 'class-call-node :object object))
+
+(defmethod node-object-name ((node class-call-node))
+  (class-name (node-object node)))
+
+(defmethod display-node ((node class-call-node) stream)
+  (let ((class (node-object node)))
+    (with-output-as-presentation (stream node 'class-call-node)
+      (with-output-as-presentation (stream class 'class)
+	(write (node-object-name node) :stream stream)))))
+
+(define-browser-type :class class :graphical
+    ()
+  (:superclasses make-class-call-node clos-browser-make-root
+		 (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil)))
+  (:subclasses make-class-call-node clos-browser-make-root
+	       (:arc-drawer draw-arrow*)))
+
+(defun clos-browser-make-root (object)
+  (typecase object
+    (class
+      (make-class-call-node object))
+    (symbol
+      (let ((class (find-class object nil)))
+	(when class
+	  (make-class-call-node class))))))
+
+(defmethod node-generate-inferior-objects ((node class-call-node) (type (eql ':superclasses)))
+  (class-direct-superclasses (node-object node)))
+
+(defmethod node-any-inferior-objects-p ((node class-call-node) (type (eql ':superclasses)))
+  (not (null (class-direct-superclasses (node-object node)))))
+
+(defmethod node-generate-inferior-objects ((node class-call-node) (type (eql ':subclasses)))
+  (class-direct-subclasses (node-object node)))
+
+(defmethod node-any-inferior-objects-p ((node class-call-node) (type (eql ':subclasses)))
+  (not (null (class-direct-subclasses (node-object node)))))
+
+
+(defclass clos-slot-call-subnode (call-subnode) ())
+
+(proclaim '(inline make-clos-slot-call-subnode))
+(defun make-clos-slot-call-subnode (class-node slots)
+  (let ((subnode (make-instance 'clos-slot-call-subnode :object slots)))
+    (setf (node-superiors subnode) (list class-node))
+    subnode))
+
+(defmethod node-object-name ((node clos-slot-call-subnode))
+  (format nil "Slots of ~S" (node-object-name (first (node-superiors node)))))
+
+(defmethod display-node ((node clos-slot-call-subnode) stream)
+  (let ((slots (node-object node)))
+    (with-output-as-presentation (stream node 'clos-slot-call-subnode
+				  :single-box t)
+      (surrounding-output-with-border (stream :shape :rectangle)
+	(formatting-table (stream)
+	  (dolist (slot slots)
+	    (formatting-row (stream)
+	      (formatting-cell (stream)
+		(present slot 'symbol :stream stream)))))))))
+
+
+(defclass clos-method-call-subnode (call-subnode) ())
+
+(proclaim '(inline make-clos-method-call-subnode))
+(defun make-clos-method-call-subnode (class-node method-list)
+  (let ((subnode (make-instance 'clos-slot-call-subnode :object method-list)))
+    (setf (node-superiors subnode) (list class-node))
+    subnode))
+
+(defmethod node-object-name ((node clos-method-call-subnode))
+  (format nil "Methods of ~S" (node-object-name (first (node-superiors node)))))
+
+(defmethod display-node ((node clos-method-call-subnode) stream)
+  (let ((methods (node-object node)))
+    (with-output-as-presentation (stream node 'clos-method-call-subnode
+				  :single-box t)
+      (surrounding-output-with-border (stream :shape :rectangle)
+	(formatting-table (stream)
+	  (dolist (item methods)
+	    (formatting-row (stream)
+	      (formatting-cell (stream)
+		(destructuring-bind (gf method) item
+		  (with-output-as-presentation (stream method 'expression
+						:allow-sensitive-inferiors nil)
+		    (prin1 (clos:generic-function-name gf) stream)))))))))))
+
+
+;;; Package browsing
+
+(define-presentation-type package ()
+  :inherit-from t
+  :history t)
+
+#+Genera
+(define-presentation-method accept ((type package) stream (view textual-view) &key)
+  (completing-from-suggestions (stream :partial-completers '(#\-))
+    (map nil #'(lambda (package) 
+		 (suggest (package-name package) package))
+	 (list-all-packages))))
+
+(define-presentation-method present (package (type package) stream (view textual-view) &key)
+  (princ (package-name package) stream))
+
+
+(defclass package-call-node (call-node) ())
+  
+(proclaim '(inline make-package-call-node))
+(defun make-package-call-node (object)
+  (make-instance 'package-call-node :object object))
+
+(defmethod node-object-name ((node package-call-node))
+  (package-name (node-object node)))
+
+(defmethod display-node ((node package-call-node) stream)
+  (with-output-as-presentation (stream node 'package-call-node)
+    (present (node-object node) 'package :stream stream)))
+
+(define-browser-type :package package :graphical
+    ()
+  (:uses make-package-call-node package-browser-make-root
+	 (:arc-drawer draw-arrow* :arc-drawing-options (:from-head t :to-head nil)))
+  (:used-by make-package-call-node package-browser-make-root
+	    (:arc-drawer draw-arrow*)))
+
+(defun package-browser-make-root (object)
+  (typecase object
+    (package
+      (make-package-call-node object))
+    ((or string symbol)
+     (let ((package (find-package object)))
+       (and package
+	    (make-package-call-node package))))))
+
+(defmethod node-generate-inferior-objects ((node package-call-node) (type (eql ':uses)))
+  (package-use-list (node-object node)))
+
+(defmethod node-any-inferior-objects-p ((node package-call-node) (type (eql ':uses)))
+  (not (null (package-use-list (node-object node)))))
+
+(defmethod node-generate-inferior-objects ((node package-call-node) (type (eql ':used-by)))
+  (package-used-by-list (node-object node)))
+
+(defmethod node-any-inferior-objects-p ((node package-call-node) (type (eql ':used-by)))
+  (not (null (package-used-by-list (node-object node)))))
+
+
+(defclass package-symbols-subnode (call-subnode) ())
+
+(proclaim '(inline make-package-symbols-subnode))
+(defun make-package-symbols-subnode (package-node symbols)
+  (let ((subnode (make-instance 'package-symbols-subnode :object symbols)))
+    (setf (node-superiors subnode) (list package-node))
+    subnode))
+
+(defmethod node-object-name ((node package-symbols-subnode))
+  (format nil "Instance variables of ~S" (node-object-name (first (node-superiors node)))))
+
+(defmethod display-node ((node package-symbols-subnode) stream)
+  (let ((symbols (node-object node)))
+    (with-output-as-presentation (stream node 'package-symbols-subnode
+				  :single-box t)
+      (surrounding-output-with-border (stream :shape :rectangle)
+	(formatting-table (stream :multiple-columns t)
+	  (dolist (symbol symbols)
+	    (formatting-row (stream)
+	      (formatting-cell (stream)
+		(present symbol 'symbol :stream stream)))))))))
+
+
+;;; File system browsing (how can I resist?)
+
+;; As the object, we have a list of the form (PATHNAME . PROPERTIES)
+(defclass filesystem-call-node
+	  (call-node)
+    ((directory-p :reader filesystem-node-directory-p :initarg :directory-p)))
+
+(proclaim '(inline make-filesystem-call-node))
+(defun make-filesystem-call-node (object)
+  (destructuring-bind (pathname &rest properties) object
+    (let* ((directory-p (getf properties :directory))
+	   (pathname (if directory-p
+			 (make-pathname :name :wild
+					:type :wild
+					:version :newest
+					:directory (append (pathname-directory pathname) 
+							   (list (pathname-name pathname)))
+					:defaults pathname)
+			 pathname)))
+      (make-instance 'filesystem-call-node :object `(,pathname ,@properties)
+					   :directory-p directory-p))))
+
+(defmethod node-object-name ((node filesystem-call-node))
+  (let ((pathname (first (node-object node))))
+    (namestring pathname)))
+
+(defmethod display-node ((node filesystem-call-node) stream)
+  (let ((pathname (first (node-object node))))
+    (with-output-as-presentation (stream node 'filesystem-call-node)
+      (with-output-as-presentation (stream pathname 'pathname)
+	(format stream "~A" pathname)))))
+
+(define-browser-type :filesystem pathname :textual
+    ()
+  (:filesystem make-filesystem-call-node filesystem-browser-make-root
+	       nil))
+
+(defun filesystem-browser-make-root (object)
+  (when (pathnamep object)
+    (let ((pathname (make-pathname :name :wild
+				   :type :wild
+				   :version :newest
+				   :defaults object)))
+      (make-instance 'filesystem-call-node :object `(,pathname :directory t)
+					   :directory-p t))))
+
+(defmethod node-generate-inferior-objects ((node filesystem-call-node) (type (eql ':filesystem)))
+  (when (filesystem-node-directory-p node)
+    (let* ((pathname (first (node-object node)))
+	   (dirlist (directory-and-properties
+		      (make-pathname :name :wild
+				     :type :wild
+				     :version :newest
+				     :defaults pathname))))
+      (sort dirlist #'(lambda (x y)
+			(if (string-equal (pathname-name x) (pathname-name y))
+			    (string-lessp (pathname-type x) (pathname-type y))
+			    (string-lessp (pathname-name x) (pathname-name y))))
+	    :key #'first))))
+
+(defmethod node-any-inferior-objects-p ((node filesystem-call-node) (type (eql ':filesystem)))
+  (filesystem-node-directory-p node))
+
+(defun directory-and-properties (pathname)
+  #+Genera (cdr (fs:directory-list pathname))
+  #-Genera (mapc #'list (directory pathname)))
+
+
+;;; Lisp object browsing
+
+(defclass lisp-object-call-node (call-node) ())
+
+(proclaim '(inline make-lisp-object-call-node))
+(defun make-lisp-object-call-node (object)
+  (make-instance 'lisp-object-call-node :object object))
+
+;; Kludge to prevent explosions when we click on a node which doesn't
+;; have a reasonable printed representation
+(defmethod print-object :around ((node lisp-object-call-node) stream)
+  (handler-case
+      (call-next-method node stream)
+    (print-not-readable)))
+
+(defvar *unbound-marker* (list nil))
+(defmethod display-node ((node lisp-object-call-node) stream)
+  (let ((object (node-object node)))
+    (labels ((draw (stream)
+	       ;;--- This should produce a more graphical presentation
+	       (with-output-as-presentation (stream node 'lisp-object-call-node)
+		 (with-browser-io-environment
+		   (if (eql object *unbound-marker*)
+		       (princ "Unbound" stream)
+		       (prin1 object stream))))))
+      (declare (dynamic-extent #'draw))
+      (if (node-recurses node)
+	  (surrounding-output-with-border (stream :shape :rectangle)
+	    (draw stream))
+	  (draw stream)))))
+
+(define-browser-type :lisp-object expression :graphical
+    ()
+  (:objects make-lisp-object-call-node lisp-object-browser-make-root
+	    (:arc-drawer draw-arrow*)))
+
+(defun lisp-object-browser-make-root (object)
+  (make-lisp-object-call-node
+    (if (and (listp object)
+	     (fboundp (first object)))
+	;; Handles both quoted forms and calls to functions
+	(eval object)
+	(if (symbolp object)
+	    (symbol-value object)
+	    object))))
+
+(defmethod node-generate-inferior-objects ((node lisp-object-call-node) (type (eql ':objects)))
+  (let ((object (node-object node)))
+    (cond #+Genera
+	  ((si:named-structure-p object)
+	   ;; Generate a list of all of the structures slots
+	   ;;--- How to arrange for the slot names to be printed?
+	   (let* ((description (get (or (and (arrayp object)
+					     (si:named-structure-symbol object))
+					(and (listp object)
+					     (symbolp (car object))
+					     (car object)))
+				    'si:defstruct-description)))
+	     (loop for (slot-name . slot-description)
+		       in (si:defstruct-description-slot-alist description)
+		   as form = `(,(si:defstruct-slot-description-ref-macro-name slot-description)
+			       ',object)
+		   collect (eval form))))
+	  ;;--- What do we do for INSTANCEP?
+	  ((si:instancep object)
+	   #+Genera (setq object (si:follow-structure-forwarding object))
+	   ;;--- How to arrange for the slot names to be printed?
+	   ;; This works for Genera Flavors because they are embedded in CLOS
+	   (let* ((class (class-of object))
+		  (slots (clos:class-slots class)))
+	     (loop for slot in slots
+		   as slot-name = (clos:slot-definition-name slot)
+		   collect (if (slot-boundp object slot-name)
+			       (slot-value object slot-name)
+			       *unbound-marker*))))
+	  ((stringp object) nil)
+	  ((arrayp object) (coerce object 'list))
+	  ((consp object) object)
+	  (t nil))))
+
+(defmethod node-any-inferior-objects-p ((node lisp-object-call-node) (type (eql ':objects)))
+  (let ((object (node-object node)))
+    (or (consp object)
+        ;;--- What do we do for INSTANCEP?
+	(si:instancep object)
+	(and (arrayp object)
+	     (not (stringp object))))))
+
+
+;;; The browser itself
+
+(define-application-frame browser ()
+    ((graph-type :initform :graphical)
+     (browser-type :initform nil)
+     (browser-subtype :initform nil)
+     (browser-ptype :initform nil)
+     (browser-options :initform nil)
+     (node-maker :initform #'false)
+     (root-node-maker :initform #'false)
+     (grapher-args :initform nil)
+     (tree-depth :initform 1)
+     (merge-duplicate-nodes :initform t)
+     (root-nodes :initform nil)
+     (all-nodes :initform nil)
+     (auto-snapshot :initform t)
+     (snapshots :initform nil))
+  (:command-definer t)
+  (:command-table (browser :inherit-from (accept-values-pane)))
+  (:panes
+    ((title :title
+       :display-after-commands t
+       :display-function 'display-title-pane
+       :default-text-style '(:sans-serif :bold :large))
+     (graph :application
+       :display-function 'display-graph-pane
+       :display-after-commands t
+       :incremental-redisplay t
+       :scroll-bars :both)
+     (commands :command-menu
+       :display-function '(display-command-menu :n-rows 2))
+     (interactor :interactor)
+     (control-panel :accept-values
+       :display-function '(accept-values-pane-displayer
+			    :displayer accept-call-graph-options))))
+  (:layout
+    ((default 
+       (:column 1
+	(title :compute)
+	(graph :rest)
+	(:row 1/4
+	 (:column :rest
+	  (commands 1/4)
+	  (interactor :rest))
+	 (control-panel 2/5)))))))
+
+#+Genera (define-genera-application browser :select-key #\Triangle)
+#+Genera (zwei:defindentation (define-browser-command 0 3 1 3 2 1))
+
+(defmethod configure-for-browser-type ((browser browser) type subtype)
+  (with-slots (auto-snapshot browser-type browser-subtype
+	       node-maker root-node-maker graph-type grapher-args
+	       browser-ptype browser-options) browser
+    (when auto-snapshot
+      (snapshot-current-graph browser))
+    (setq browser-type type
+	  browser-subtype subtype)
+    (multiple-value-bind (maker root-maker gr-type gr-args ptype options)
+	(browser-type-information browser-type browser-subtype)
+      (setq node-maker maker
+	    root-node-maker root-maker
+	    graph-type gr-type
+	    grapher-args gr-args
+	    browser-ptype ptype
+	    browser-options options))))
+
+(defmethod initialize-instance :after ((browser browser) &key)
+  (with-slots (root-nodes all-nodes) browser
+    (setq root-nodes nil
+	  all-nodes nil)
+    (configure-for-browser-type
+      browser
+      (first *browser-types*)
+      (first (browser-type-subtypes (first *browser-types*))))))
+
+(defmethod display-title-pane ((browser browser) stream)
+  (with-slots (root-nodes browser-type browser-subtype) browser
+    (if (or (null browser-type) (null root-nodes))
+	(centering-line (stream)
+	  (format stream "Browser"))
+        (updating-output (stream :unique-id 'title
+				 :cache-value (list root-nodes browser-type browser-subtype)
+				 :cache-test #'equal)
+	  (centering-line (stream)
+	    (with-browser-io-environment
+	      (format stream "~@(~A~) browser: ~(~A~) of ~S~:[~;, etc.~]"
+		browser-type browser-subtype
+		(node-object-name (first root-nodes))
+		(cdr root-nodes))))))))
+
+(defgeneric display-graph-pane-1 (browser type stream))
+
+(defvar *graph-displayer-types* nil)
+(defmacro define-graph-displayer (type (browser stream) &body body)
+  `(progn
+     (pushnew ',type *graph-displayer-types*)
+     (defmethod display-graph-pane-1 ((,browser browser) (type (eql ',type)) ,stream)
+       ,@body)))
+
+(defun draw-browser-graph (root-nodes node-printer inferior-producer
+			   &key (stream *standard-output*)
+				(orientation :horizontal)
+				(center-nodes nil)
+				(merge-duplicates nil)
+				(arc-drawer #'draw-line*)
+				(arc-drawing-options nil)
+				(generation-separation 
+				  *default-generation-separation*)
+				(within-generation-separation
+				  *default-within-generation-separation*)
+				node-filter)
+  (flet ((inferior-producer (node)
+	   (let ((inferiors (funcall inferior-producer node)))
+	     (if (null node-filter)
+		 inferiors
+	         (delete-if-not node-filter inferiors)))))
+    (declare (dynamic-extent #'inferior-producer))
+    (format-graph-from-roots root-nodes node-printer #'inferior-producer
+			     :stream stream
+			     :orientation orientation
+			     :center-nodes center-nodes
+			     :merge-duplicates merge-duplicates
+			     :arc-drawer arc-drawer
+			     :arc-drawing-options arc-drawing-options
+			     :generation-separation generation-separation
+			     :within-generation-separation within-generation-separation)))
+
+(define-graph-displayer :graphical (browser stream)
+  (with-slots (root-nodes merge-duplicate-nodes browser-options grapher-args) browser
+    (updating-output (stream :unique-id root-nodes)
+      (apply #'draw-browser-graph root-nodes #'display-node #'node-inferiors
+				  :stream stream
+				  :orientation :horizontal
+				  :merge-duplicates merge-duplicate-nodes
+				  :node-filter (getf browser-options :display-filter)
+				  grapher-args))))
+
+(define-graph-displayer :textual (browser stream)
+  (with-slots (root-nodes browser-options) browser
+    (let ((filter (getf browser-options :display-filter)))
+      (labels ((display (node stream indentation)
+		 (when (or (null filter)
+			   (funcall filter node))
+		   (fresh-line stream)
+		   (dotimes (i indentation)
+		     (declare (ignore i))
+		     (write-char #\Space stream))
+		   (display-node node stream)
+		   (dolist (inferior (node-inferiors node))
+		     (display inferior stream (+ indentation 2))))))
+	(declare (dynamic-extent #'display))
+	(updating-output (stream :unique-id root-nodes)
+	  (with-end-of-page-action (stream :allow)
+	    (with-end-of-line-action (stream :allow)
+	      (dolist (node root-nodes)
+		(display node stream 0)))))))))
+
+(defmethod display-graph-pane ((browser browser) stream)
+  (with-slots (root-nodes graph-type) browser
+    (when root-nodes
+      (display-graph-pane-1 browser graph-type stream))))
+
+(defmethod generate-call-graph ((browser browser) nodes
+				&optional (depth (slot-value browser 'tree-depth)))
+  (with-slots (browser-subtype) browser
+    (when nodes
+      (let ((generated nil))
+	(labels 
+	  ((collect-inferiors (node parent-node depth)
+	     ;; Disallow direct recursion in a simple-minded way
+	     (when (and (plusp depth)
+			(not (eql node parent-node)))
+	       (let ((places nil)
+		     (inferior-objects
+		       (filter-generated-objects
+			 browser
+			 (node-generate-inferior-objects node browser-subtype))))
+		 (when inferior-objects
+		   (setq generated t)		;we generated something
+		   ;; Use this hairy DO stuff to detect dotted lists
+		   (do ((place inferior-objects (cdr place)))
+		       (())
+		     (when (null place) (return nil))
+		     (let* ((object (if (consp place) (car place) place))
+			    (inferior-node
+			      (find-node-for-object browser object)))
+		       (cond ((member place places)
+			      ;; Beware of circular lists
+			      (setf (node-recurses node) t)
+			      (return nil))
+			     (t
+			      (push place places)))
+		       (cond ((node-recurses-p browser node inferior-node)
+			      (setf (node-recurses node) t))
+			     (t
+			      (unless (member node (node-superiors inferior-node))
+				(setf (node-superiors inferior-node)
+				      (nconc (node-superiors inferior-node) (list node))))
+			      (unless (member inferior-node (node-inferiors node)
+					      :test #'node-eql)
+				(setf (node-inferiors node)
+				      (nconc (node-inferiors node) (list inferior-node))))))
+		       ;; Recursively collect inferiors for these nodes
+		       (collect-inferiors inferior-node node (1- depth))
+		       (unless (consp place) (return nil)))))))))
+	  (declare (dynamic-extent #'collect-inferiors))
+	  (dolist (node nodes)
+	    (collect-inferiors node nil depth)))
+	generated))))
+
+;; Find or intern a new node.
+(defmethod find-node-for-object ((browser browser) object &key (test #'eql))
+  (with-slots (all-nodes node-maker) browser
+    (dolist (node all-nodes)
+      (when (funcall test object (node-object node))
+	(return-from find-node-for-object node)))
+    (let ((node (funcall node-maker object)))
+      (setq all-nodes (nconc all-nodes (list node)))
+      node)))
+
+(defmethod node-recurses-p ((browser browser) node inferior)
+  (with-slots (all-nodes) browser
+    (or (eql node inferior)			;quick test often succeeds
+	(let ((mark-table 
+		#+Genera (scl:make-hash-table :size (length all-nodes) :number-of-values 0)
+		#-Genera (make-hash-table :size (length all-nodes))))
+	  (labels ((recurses (inferiors)
+		     (when (member node inferiors)
+		       (return-from node-recurses-p t))
+		     (dolist (inferior inferiors)
+		       (unless (gethash inferior mark-table)
+			 (setf (gethash inferior mark-table) t)
+			 (recurses (node-inferiors inferior))))))
+	    (declare (dynamic-extent #'recurses))
+	    (setf (gethash node mark-table) t)
+	    (setf (gethash inferior mark-table) t)
+	    (recurses (node-inferiors inferior))
+	    nil)))))
+
+;; Given a generator, create the call graph for a node.
+(defmethod filter-generated-objects ((browser browser) objects)
+  (with-slots (browser-options) browser
+    (let ((predicate (getf browser-options :object-filter)))
+      (if (null predicate)
+	  objects
+	  (delete-if-not predicate objects)))))
+
+(defmethod generate-upward-call-graph ((browser browser) inferior-node subtype)
+  (let ((superior-objects
+	  (filter-generated-objects
+	    browser
+	    (node-generate-inferior-objects inferior-node subtype))))
+    (when superior-objects
+      (dolist (object superior-objects)
+	(let ((node (find-node-for-object browser object)))
+	  (cond ((node-recurses-p browser node inferior-node)
+		 (setf (node-recurses node) t))
+		(t
+		 (unless (member node (node-superiors inferior-node))
+		   (setf (node-superiors inferior-node)
+			 (nconc (node-superiors inferior-node) (list node))))
+		 (unless (member inferior-node (node-inferiors node)
+				 :test #'node-eql)
+		   (setf (node-inferiors node)
+			 (nconc (node-inferiors node) (list inferior-node))))))))
+      (recompute-root-nodes browser)
+      t)))
+
+(defmethod recompute-root-nodes ((browser browser))
+  (with-slots (all-nodes root-nodes) browser
+    (loop for node in all-nodes
+	  when (null (node-superiors node))
+	    collect node into new-roots
+	  finally (unless (node-set-equal new-roots root-nodes)
+		    (setq root-nodes new-roots)))))
+
+(defun node-set-equal (nodes1 nodes2)
+  (let ((l1 (length nodes1))
+	(l2 (length nodes2)))
+    (and (= l1 l2)
+	 (let ((mark-table
+		 #+Genera (scl:make-hash-table :size l1 :number-of-values 0)
+		 #-Genera (make-hash-table :size l1)))
+	   (dolist (node nodes1)
+	     (setf (gethash (node-object node) mark-table) t))
+	   (every #'(lambda (node) (gethash (node-object node) mark-table))
+		  nodes2)))))
+
+(defmethod accept-call-graph-options ((browser browser) stream)
+  (with-slots (browser-type browser-subtype tree-depth
+	       merge-duplicate-nodes auto-snapshot browser-options 
+	       root-nodes root-node-maker all-nodes) browser
+    (flet ((accept (type default prompt query-id)
+	     (fresh-line stream)
+	     (accept type
+		     :stream stream :default default
+		     :query-identifier query-id :prompt prompt)))
+      (declare (dynamic-extent #'accept))
+      (multiple-value-bind (new-type nil type-changed)
+	  (accept `(member ,@*browser-types*) (or browser-type (first *browser-types*))
+		  "Browser type" 'type)
+	(let* ((sub-ptype
+		 (browser-type-subtypes new-type))
+	       (new-subtype
+		 (accept `(member ,@sub-ptype)
+			 (if type-changed (first sub-ptype) browser-subtype)
+			 "Browser subtype" 'subtype))
+	       (new-depth
+		 (accept '(integer 1 10) tree-depth
+			 "Starting depth" 'depth))
+	       (new-merge
+		 (accept 'boolean merge-duplicate-nodes
+			 "Merge duplicate nodes" 'merge))
+	       (new-auto-snapshot
+		 (accept 'boolean auto-snapshot
+			 "Automatic snapshots" 'auto-snapshot)))
+	  (let ((additional-dialog (getf browser-options :additional-browser-options)))
+	    (when additional-dialog
+	      (funcall additional-dialog browser stream)))
+	  (setq tree-depth new-depth
+		merge-duplicate-nodes new-merge
+		auto-snapshot new-auto-snapshot)
+	  (when (or (not (eql new-type browser-type))
+		    (not (eql new-subtype browser-subtype)))
+	    (configure-for-browser-type browser new-type new-subtype)
+	    (when root-nodes
+	      (loop for node in root-nodes
+		    as new-node = (funcall root-node-maker (node-object node))
+		    when new-node
+		      collect new-node into new-root-nodes
+		    finally
+		      (setq root-nodes new-root-nodes)
+		      ;; ALL-NODES and ROOT-NODES must not be EQ lists...
+		      (setq all-nodes (copy-list root-nodes))))
+	    ;; Regenerate and redisplay the call graph
+	    (generate-call-graph browser root-nodes)
+	    (redisplay-frame-pane *application-frame* 'graph :force-p t)))))))
+
+
+;;; Browser commands
+
+(define-browser-command (com-show-graph :name t :menu t)
+    ((objects (with-slots (browser-ptype) *application-frame*
+		`(or (sequence ,browser-ptype) call-node))
+	      :prompt "the name of an object"
+	      :default nil))
+  (with-slots (auto-snapshot root-node-maker root-nodes all-nodes) *application-frame*
+    (when auto-snapshot
+      (snapshot-current-graph *application-frame*))
+    (if (typep objects 'call-node)
+	(setq root-nodes (list (funcall root-node-maker (node-object objects))))
+        (loop for object in objects
+	      as new-node = (funcall root-node-maker object)
+	      when new-node
+		collect new-node into new-root-nodes
+	      finally (setq root-nodes new-root-nodes)))
+    ;; ALL-NODES and ROOT-NODES must not be EQ lists...
+    (setq all-nodes (copy-list root-nodes))
+    (window-clear (get-frame-pane *application-frame* 'graph))
+    (generate-call-graph *application-frame* root-nodes)
+    (redisplay-frame-pane *application-frame* 'graph :force-p t)))
+
+(define-gesture-name :show-graph :button :left :shifts (:shift))
+
+(define-presentation-to-command-translator show-graph
+    (call-node com-show-graph browser
+     :gesture :show-graph
+     :tester ((object)
+	      (presentation-typep
+		(node-object object) (slot-value *application-frame* 'browser-ptype))))
+    (object)
+  (list (node-object object)))
+
+(define-browser-command (com-decache :menu t) ()
+  (with-slots (root-nodes all-nodes) *application-frame*
+    (setq root-nodes nil
+	  all-nodes nil)
+    (window-clear (get-frame-pane *application-frame* 'graph))))
+
+(define-browser-command (com-redisplay :menu t) ()
+  (window-clear (get-frame-pane *application-frame* 'graph))
+  (redisplay-frame-pane *application-frame* 'graph :force-p t))
+
+(define-browser-command (com-hardcopy-graph :name t :menu "Hardcopy")
+    (&key (file 'pathname
+	   :default (make-pathname :name "GRAPH-HARDCOPY"
+				   :type "PS"
+				   :defaults (user-homedir-pathname)
+				   :case :common)
+	   :documentation "File in which to put the PostScript result")
+	  (orientation '(member :landscape :portrait)
+	   :default :portrait
+	   :documentation "Orientation to use on the paper"))
+  (with-slots (browser-subtype root-nodes) *application-frame*
+    (with-open-file (file-stream file :direction :output)
+      (with-output-to-postscript-stream (stream file-stream 
+					 :orientation orientation
+					 :multi-page t)
+	(with-text-style (stream '(:sans-serif :bold :large))
+	  (display-title-pane *application-frame* stream))
+	(terpri stream)
+	(terpri stream)
+	(display-graph-pane *application-frame* stream)))))
+
+(define-browser-command (com-set-graph-type :name t)
+    ((type `(member ,@*graph-displayer-types*)))
+  (with-slots (graph-type) *application-frame*
+    (unless (eql type graph-type)
+      (setq graph-type type)
+      (redisplay-frame-pane *application-frame* 'graph :force-p t))))
+
+(define-browser-command com-show-node-inferiors
+    ((node 'call-node :prompt "node to show inferiors for"))
+  (when (generate-call-graph *application-frame* (list node) 1)
+    (tick-node node)))
+
+(define-presentation-to-command-translator show-node-inferiors
+   (call-node com-show-node-inferiors browser
+    :gesture :select
+    :tester ((object)
+	     (node-any-inferior-objects-p 
+	       object (slot-value *application-frame* 'browser-subtype))))
+   (object)
+  (list object))
+
+(define-browser-command com-hide-node-inferiors
+    ((node 'call-node :prompt "node to hide inferiors of"))
+  (when (node-inferiors node)
+    (setf (node-inferiors node) nil)
+    (tick-node node)))
+
+(define-presentation-to-command-translator hide-node-inferiors
+    (call-node com-hide-node-inferiors browser
+     :gesture :describe
+     :tester ((object)
+	      (not (null (node-inferiors object)))))
+    (object)
+  (list object))
+
+(define-browser-command com-delete-node
+    ((node 'call-node :prompt "node to delete"))
+  (when (node-superiors node)
+    (dolist (superior (node-superiors node))
+      (setf (node-inferiors superior) (delete node (node-inferiors superior))))
+    (tick-node node)))
+
+(define-presentation-to-command-translator delete-node
+    (call-node com-delete-node browser
+     :gesture :describe
+     :tester ((object) (and (null (node-inferiors object))
+			    (not (null (node-superiors object))))))
+    (object)
+  (list object))
+
+(define-browser-command com-show-node-superiors
+    ((node 'call-node
+	   :prompt "node to show superiors for"))
+  (with-slots (browser-type browser-subtype) *application-frame*
+    (let* ((subtypes (browser-type-subtypes browser-type))
+	   (subtype (block find-subtype
+		      (dolist (subtype subtypes)
+			(unless (eql browser-subtype subtype)
+			  (return-from find-subtype subtype))))))
+      (when (and subtype
+		 (generate-upward-call-graph *application-frame* node subtype))
+	(tick-node node)))))
+
+(define-presentation-to-command-translator show-node-superiors
+    (call-node com-show-node-superiors browser
+     :gesture nil
+     :menu t)
+    (object)
+  (list object))
+
+;; Given a node, replace it by another one which contains the inferiors of
+;; all of its inferiors (i.e., splice out the intermediates so that the
+;; graph takes up less space).
+(define-browser-command com-ellipsize-node
+    ((node 'call-node :prompt "node to ellipsize"))
+  (with-slots (all-nodes) *application-frame*
+    (let ((ellipsis (make-ellipsis-call-node (node-object-name node) node)))
+      ;; Dike out all references to the ellipsized node
+      (dolist (n all-nodes)
+	(nsubstitute ellipsis node (node-inferiors n)))
+      (nsubstitute ellipsis node all-nodes)
+      (incf (node-tick node))
+      (tick-node ellipsis))))
+
+(define-presentation-to-command-translator ellipsize-node
+    ((or call-node ellipsis-call-node) com-ellipsize-node browser
+     :gesture :delete)
+    (object)
+  (list object))
+
+(define-browser-command com-unellipsize-node
+    ((ellipsis 'ellipsis-call-node :prompt "node to unellipsize" :gesture :select))
+  (with-slots (all-nodes) *application-frame*
+    (let ((node (ellipsis-node-replaced-node ellipsis)))
+      ;; Replace all references to the ellipsized node
+      (dolist (n all-nodes)
+	(nsubstitute node ellipsis (node-inferiors n)))
+      (nsubstitute node ellipsis all-nodes)
+      (tick-node node))))
+
+
+;;; Snapshotting
+
+(defstruct snapshot
+  graph-type
+  browser-type
+  browser-subtype
+  browser-ptype
+  browser-options
+  node-maker
+  root-node-maker
+  grapher-args
+  tree-depth
+  merge-duplicate-nodes
+  root-nodes
+  all-nodes)
+
+(define-presentation-type snapshot (&optional snapshots))
+
+(define-presentation-method accept ((type snapshot) stream (view textual-view) &key)
+  (values
+    (with-browser-io-environment
+      (completing-from-suggestions (stream)
+	(dolist (snapshot snapshots)
+	  (suggest (format nil "~:(~A~) ~:(~A~) ~S"
+		     (snapshot-browser-type snapshot)
+		     (snapshot-browser-subtype snapshot)
+		     (mapcar #'node-object-name (snapshot-root-nodes snapshot)))
+		   snapshot))))))
+
+(define-presentation-method present (snapshot (type snapshot) stream (view textual-view) &key)
+  (with-browser-io-environment
+    (format stream "~:(~A~) ~:(~A~) ~S"
+      (snapshot-browser-type snapshot)
+      (snapshot-browser-subtype snapshot)
+      (mapcar #'node-object-name (snapshot-root-nodes snapshot)))))
+
+(defmethod snapshot-current-graph ((browser browser))
+  (with-slots (graph-type browser-type browser-subtype
+	       browser-ptype browser-options node-maker
+	       root-node-maker grapher-args tree-depth
+	       merge-duplicate-nodes root-nodes all-nodes snapshots) browser
+    (let ((snapshot (make-snapshot :graph-type graph-type
+				   :browser-type browser-type
+				   :browser-subtype browser-subtype
+				   :browser-ptype browser-ptype
+				   :browser-options (copy-list browser-options)
+				   :node-maker node-maker
+				   :root-node-maker root-node-maker
+				   :grapher-args grapher-args
+				   :tree-depth tree-depth
+				   :merge-duplicate-nodes merge-duplicate-nodes
+				   :root-nodes (copy-list root-nodes)
+				   :all-nodes (copy-list all-nodes))))
+      (flet ((snapshot-equal (s1 s2)
+	       (and (eql (snapshot-browser-type s1) (snapshot-browser-type s2))
+		    (eql (snapshot-browser-subtype s1) (snapshot-browser-subtype s2))
+		    (equal (snapshot-root-nodes s1) (snapshot-root-nodes s2)))))
+	(declare (dynamic-extent #'snapshot-equal))
+	(let ((old-snapshot (member snapshot snapshots :test #'snapshot-equal)))
+	  (if old-snapshot
+	      (setf (car old-snapshot) snapshot)
+	      (setq snapshots (nconc snapshots (list snapshot)))))))))
+
+(define-browser-command (com-snapshot-graph :menu "Snapshot") ()
+  (snapshot-current-graph *application-frame*))
+
+(define-browser-command (com-show-snapshots :menu t) ()
+  (with-slots (snapshots) *application-frame*
+    (dolist (snapshot snapshots)
+      (fresh-line)
+      (present snapshot 'snapshot))))
+
+(define-browser-command (com-recover-snapshot :menu t)
+    ((snapshot (with-slots (snapshots) *application-frame*
+		 `(snapshot ,snapshots))
+	       :prompt "snapshot to recover"))
+  (with-slots (browser-type browser-subtype root-nodes graph-type
+	       browser-ptype browser-options node-maker
+	       root-node-maker grapher-args tree-depth
+	       merge-duplicate-nodes all-nodes) *application-frame*
+    (unless (and (eql browser-type (snapshot-browser-type snapshot))
+		 (eql browser-subtype (snapshot-browser-subtype snapshot))
+		 (equal root-nodes (snapshot-root-nodes snapshot)))
+      (setq graph-type (snapshot-graph-type snapshot)
+	    browser-type (snapshot-browser-type snapshot)
+	    browser-subtype (snapshot-browser-subtype snapshot)
+	    browser-ptype (snapshot-browser-ptype snapshot)
+	    browser-options (copy-list (snapshot-browser-options snapshot))
+	    node-maker (snapshot-node-maker snapshot)
+	    root-node-maker (snapshot-root-node-maker snapshot)
+	    grapher-args (snapshot-grapher-args snapshot)
+	    tree-depth (snapshot-tree-depth snapshot)
+	    merge-duplicate-nodes (snapshot-merge-duplicate-nodes snapshot)
+	    root-nodes (copy-list (snapshot-root-nodes snapshot))
+	    all-nodes (copy-list (snapshot-all-nodes snapshot)))
+      (redisplay-frame-pane *application-frame* 'graph :force-p t))))
+
+(define-presentation-to-command-translator recover-snapshot
+    (snapshot com-recover-snapshot browser
+     :gesture :select)
+    (object)
+  (list object))
+
+(define-browser-command com-remove-snapshot
+    ((snapshot 'snapshot :prompt "snapshot to remove" :gesture :delete))
+  (with-slots (snapshots) *application-frame*
+    (setq snapshots (delete snapshot snapshots))))
+
+
+;;; Less general browser commands, mostly pertaining to subnodes
+
+(define-browser-command com-remove-subnode
+    ((subnode 'call-subnode :prompt "subnode to remove" :gesture :delete))
+  (with-slots (all-nodes) *application-frame*
+    (let ((node (first (node-superiors subnode))))
+      (setf (node-inferiors node) (delete subnode (node-inferiors node)))
+      (setq all-nodes (delete subnode all-nodes))
+      (tick-node subnode))))
+
+(defun subnode-object-present-in-node (node object &key (test #'eql))
+  (dolist (subnode (node-inferiors node))
+    (when (and (typep subnode 'call-subnode)
+	       (funcall test object (node-object subnode)))
+      (return-from subnode-object-present-in-node t)))
+  nil)
+
+(define-gesture-name :subnode-1 :button :left   :shifts (:control :meta))
+(define-gesture-name :subnode-2 :button :middle :shifts (:control :meta))
+
+(define-browser-command com-show-clos-slots
+    ((class-node 'class-call-node
+      :prompt "class node to show slots for" :gesture :subnode-1))
+  (let* ((class (node-object class-node))
+	 (slots (sort (mapcar #'clos:slot-definition-name (clos:class-direct-slots class))
+		      #'string-lessp)))
+    (when (and slots
+	       (not (subnode-object-present-in-node class-node slots :test #'equal)))
+      (let ((subnode (make-clos-slot-call-subnode class-node slots)))
+	(push subnode (node-inferiors class-node))
+	(tick-node subnode)))))
+
+(define-browser-command com-show-clos-methods
+    ((class-node 'class-call-node
+      :prompt "class node to show methods for" :gesture :subnode-2))
+  (let* ((class (node-object class-node))
+	 (methods (clos:specializer-direct-methods class))
+	 (method-list
+	   (loop for method in methods
+		 collect (list (clos:method-generic-function method) method))))
+    (setq method-list (sort method-list #'string-lessp
+			    :key #'(lambda (item)
+				     (let ((name (clos:generic-function-name (first item))))
+				       (if (listp name) (second name) name)))))
+    (when (and method-list
+	       (not (subnode-object-present-in-node class-node method-list
+						    :test #'equal)))
+      (let ((subnode (make-clos-method-call-subnode class-node method-list)))
+	(push subnode (node-inferiors class-node))
+	(tick-node subnode)))))
+
+
+(define-browser-command com-show-exported-symbols
+    ((package-node 'package-call-node
+      :prompt "package node to show exported symbols of" :gesture :subnode-1))
+  (let ((package (node-object package-node))
+	symbols)
+    (do-external-symbols (symbol package)
+      (when (eql (symbol-package symbol) package)
+	(push symbol symbols)))
+    (setq symbols (sort symbols #'string-lessp :key #'symbol-name))
+    (when (and symbols
+	       (not (subnode-object-present-in-node package-node symbols :test #'equal)))
+      (let ((subnode (make-package-symbols-subnode package-node symbols)))
+	(push subnode (node-inferiors package-node))
+	(tick-node subnode)))))
diff --git a/misc/pixmaps.lisp b/misc/pixmaps.lisp
new file mode 100644
index 00000000..a9bad955
--- /dev/null
+++ b/misc/pixmaps.lisp
@@ -0,0 +1,425 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10; Patch-File: T; Lowercase: Yes -*-
+;;; Patch file for Private version 0.0
+;;; Reason: Add support for pixmaps and pixmap streams to CLIM.
+;;; 
+;;; Function CLIM:WITH-OUTPUT-TO-PIXMAP-STREAM:  New, creates a pixmap stream.
+;;; 
+;;; DEFOPERATION CLIM:COPY-AREA:  Replacement for COPY-AREA-INTERNAL.
+;;; Function (CLOS:METHOD CLIM::WINDOW-SHIFT-VISIBLE-REGION (CLIM::WINDOW-MIXIN T T T T T T T T)):
+;;;   Use it.
+;;; CLOS class CLIM::BASIC-PIXMAP:  The basic pixmap class, with PIXMAP-WIDTH and PIXMAP-HEIGHT
+;;;   readers for the allocated width and height.
+;;; 
+;;; The methods for Genera sheets.
+;;; Function (CLOS:METHOD CLIM:COPY-AREA (CLIM::SHEET-IMPLEMENTATION-MIXIN T T T T T T)):  ..
+;;; CLOS class CLIM::GENERA-PIXMAP:  ..
+;;; Function (CLOS:METHOD CLIM:ALLOCATE-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T T)):  ..
+;;; Function (CLOS:METHOD CLIM:DEALLOCATE-PIXMAP (CLIM::GENERA-PIXMAP)):  ..
+;;; Function (CLOS:METHOD CLIM:COPY-TO-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T T T T)):  ..
+;;; Function (CLOS:METHOD CLIM:COPY-FROM-PIXMAP (CLIM::GENERA-PIXMAP T T T T CLIM::SHEET-IMPLEMENTATION-MIXIN T T)):  ..
+;;; CLOS class CLIM::GENERA-PIXMAP-STREAM:  ..
+;;; function (CLOS:METHOD CLOS:INITIALIZE-INSTANCE (CLIM::GENERA-PIXMAP-STREAM) :AFTER):  ..
+;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-FOREGROUND) (T CLIM::GENERA-PIXMAP-STREAM) :AFTER):  ..
+;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-BACKGROUND) (T CLIM::GENERA-PIXMAP-STREAM) :AFTER):  ..
+;;; Function (CLOS:METHOD CLIM::INVOKE-WITH-OUTPUT-TO-PIXMAP (CLIM::SHEET-IMPLEMENTATION-MIXIN T)):  ..
+;;; 
+;;; The methods for CLX windows.
+;;; Function (CLOS:METHOD CLIM:COPY-AREA (CLIM::CLX-WINDOW T T T T T T)):  ..
+;;; CLOS class CLIM::CLX-PIXMAP:  ..
+;;; Function (CLOS:METHOD CLIM:ALLOCATE-PIXMAP (CLIM::CLX-WINDOW T T)):  ..
+;;; Function (CLOS:METHOD CLIM:DEALLOCATE-PIXMAP (CLIM::CLX-PIXMAP)):  ..
+;;; Function (CLOS:METHOD CLIM:COPY-TO-PIXMAP (CLIM::CLX-WINDOW T T T T)):  ..
+;;; Function (CLOS:METHOD CLIM:COPY-FROM-PIXMAP (CLIM::CLX-PIXMAP T T T T CLIM::CLX-WINDOW T T)):  ..
+;;; CLOS class CLIM::CLX-PIXMAP-STREAM:  ..
+;;; Function (CLOS:METHOD CLOS:INITIALIZE-INSTANCE (CLIM::CLX-PIXMAP-STREAM) :AFTER):  ..
+;;; function (CLOS:METHOD (SETF CLIM:MEDIUM-FOREGROUND) (T CLIM::CLX-PIXMAP-STREAM) :AFTER):  ..
+;;; Function (CLOS:METHOD (SETF CLIM:MEDIUM-BACKGROUND) (T CLIM::CLX-PIXMAP-STREAM) :AFTER):  ..
+;;; function (CLOS:METHOD CLIM::INVOKE-WITH-OUTPUT-TO-PIXMAP (CLIM::CLX-WINDOW T)):  ..
+;;; Written by SWM, 18-Oct-91 18:09:01
+;;; while running on Evening Grosbeak from FEP0:>dSCRC-439-25-from-IH-Sys439-25.load.1
+;;; with Experimental System 439.45, Experimental CLOS 424.5, Experimental RPC 428.1,
+;;; Experimental Embedding Support 420.0, Experimental MacIvory Support 434.0,
+;;; Experimental UX Support 429.0, Experimental Development Utilities 424.4,
+;;; Experimental Old TV 422.0, Experimental Zwei 422.5, Experimental Utilities 432.0,
+;;; Experimental RPC Development 423.0, Experimental MacIvory Development 422.0,
+;;; Experimental UX Development 428.0, Experimental Server Utilities 430.1,
+;;; Experimental Serial 423.1, Experimental Hardcopy 433.0, Experimental Zmail 430.0,
+;;; Experimental LMFS Defstorage 406.0, Experimental SCSI 419.0,
+;;; Experimental Tape 432.1, Experimental LMFS 431.2, Experimental NSage 428.0,
+;;; Experimental Extended Help 429.0, Experimental CL Developer 416.0,
+;;; Experimental Documentation Database 429.13, Experimental IP-TCP 438.2,
+;;; Experimental IP-TCP Documentation 411.0, Experimental CLX 434.0,
+;;; Experimental X Remote Screen 432.0, Experimental X Documentation 410.0,
+;;; Experimental NFS Client 428.0, Experimental NFS Documentation 412.0,
+;;; Experimental DNA 427.0, Experimental Metering 432.0,
+;;; Experimental Metering Substrate 432.0, Experimental Conversion Tools 423.0,
+;;; Experimental Hacks 428.0, Experimental Mac Dex 421.0,
+;;; Experimental HyperCard/MacIvory 421.0, Experimental Statice Runtime 412.10,
+;;; Experimental Statice 433.0, Experimental Statice Browser 409.0,
+;;; Experimental Statice Documentation 415.0, Experimental CLIM 33.21,
+;;; Experimental CLIM Documentation 33.1, Experimental CLIM Demo 33.2,
+;;; Experimental Lock Simple 425.0, Version Control 404.4, Compare Merge 403.0,
+;;; VC Documentation 401.0, Symbolics In-House 431.0,
+;;; Symbolics In-House Documentation 413.6, SCRC 429.0, Weather User 413.0,
+;;; Logical Pathnames Translation Files NEWEST, cold load 2, microcode 3645-MIC 430,
+;;; FEP 127, FEP0:>V127-lisp.flod(64), FEP0:>V127-loaders.flod(64),
+;;; FEP0:>V127-info.flod(64), FEP0:>V127-debug.flod(38), 1067x752 B&W Screen,
+;;; Machine serial number 10129,
+
+
+#+Genera
+(SYSTEM-INTERNALS:FILES-PATCHED-IN-THIS-PATCH-FILE 
+  "SYS:CLIM;CLIM;CLX-IMPLEMENTATION.LISP.236"
+  "SYS:CLIM;CLIM;GENERA-IMPLEMENTATION.LISP.285"
+  "SYS:CLIM;CLIM;WINDOW-PROTOCOL.LISP.76"
+  "SYS:CLIM;CLIM;STREAM-DEFPROTOCOLS.LISP.71"
+  "SYS:CLIM;CLIM;CLIM-DEFS.LISP.149"
+  "SYS:WINDOW;BITMAP-SCREEN.LISP.37")
+
+
+;;--- Make DRAGGING-OUTPUT-RECORD use pixmaps when possible
+
+
+;=====================================
+#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;CLIM-DEFS.LISP.149")
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-")
+
+(eval-when (compile load eval)
+  (scl:export 'clim::(with-output-to-pixmap-stream) 'clim))
+
+(defmacro with-output-to-pixmap-stream ((stream) &body body)
+  (default-output-stream stream with-output-to-pixmap-stream)
+  `(flet ((with-output-to-pixmap-body (,stream) ,@body))
+     (declare (dynamic-extent #'with-output-to-pixmap-body))
+     (invoke-with-output-to-pixmap ,stream #'with-output-to-pixmap-body)))
+
+
+;=====================================
+#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;STREAM-DEFPROTOCOLS.LISP.71")
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-")
+
+(eval-when (compile load eval)
+  (scl:export 'clim::(copy-area
+		      allocate-pixmap deallocate-pixmap
+		      copy-to-pixmap copy-from-pixmap
+		      pixmap-width pixmap-height)))
+
+;; Replaces COPY-AREA-INTERNAL
+(scl:fundefine 'copy-area-internal)
+(defoperation copy-area window-mixin
+  ((window window-mixin) from-x from-y width height to-x to-y))
+
+
+;=====================================
+#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;WINDOW-PROTOCOL.LISP.76")
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-")
+
+;; This is called by output-recording-mixin's whopper on set-viewport-position*.
+;; It shifts a region of the "host screen" that's visible to some other visible
+;; location.  It does NOT do any cleaning up after itself.  It does not side-effect
+;; the output history of the window.  It calls COPY-AREA-INTERNAL whose contract is to 
+;; do the above, the whole above, and nothing but the above.
+(defmethod window-shift-visible-region ((window window-mixin)
+					old-left old-top old-right old-bottom
+					new-left new-top new-right new-bottom)
+  (declare (fixnum new-left new-top new-right new-bottom))
+  (declare (ignore old-right old-bottom new-right new-bottom))
+  (let ((delta-x (the fixnum (- old-left new-left)))
+	(delta-y (the fixnum (- old-top new-top))))
+    (multiple-value-bind (stream-width stream-height)
+	(window-inside-size window)
+      (declare (fixnum stream-width stream-height))
+      (let (from-x from-y)
+	(cond ((and (>= delta-x 0)
+		    (>= delta-y 0))
+	       ;; shifting down and to the right
+	       (setq from-x 0
+		     from-y 0))
+	      ((and (>= delta-x 0)
+		    (<= delta-y 0))
+	       ;; shifting up and to the right
+	       (setq from-x 0
+		     from-y (abs delta-y)))
+	      ((>= delta-y 0)
+	       ;; shifting down and to the left
+	       (setq from-x (abs delta-x)
+		     from-y 0))
+	      (t
+	       ;; shifting up and to the left
+	       (setq from-x (abs delta-x)
+		     from-y (abs delta-y))))
+	(let ((width (the fixnum (- stream-width (abs (the fixnum delta-x)))))
+	      (height (the fixnum (- stream-height (abs (the fixnum delta-y))))))
+	  (multiple-value-bind (ml mt) (window-margins window)
+	    (declare (fixnum ml mt))
+	    (translate-fixnum-positions ml mt from-x from-y))
+	  (let ((to-x (the fixnum (+ from-x delta-x)))
+		(to-y (the fixnum (+ from-y delta-y))))
+	    (copy-area window from-x from-y width height to-x to-y)))))))
+
+
+;;; Basic pixmaps
+
+(defclass basic-pixmap ()
+  ((pixmap :initarg :pixmap)
+   (screen :initarg :screen)
+   (width :initarg :width :reader pixmap-width)
+   (height :initarg :height :reader pixmap-height)))
+
+(defmethod copy-to-pixmap ((stream encapsulating-stream-mixin)
+			   window-x window-y width height
+			   &optional pixmap (pixmap-x 0) (pixmap-y 0))
+  (copy-to-pixmap (slot-value stream 'stream)
+		  window-x window-y width height
+		  pixmap pixmap-x pixmap-y))
+
+(defmethod copy-from-pixmap (pixmap pixmap-x pixmap-y width height
+			     (stream encapsulating-stream-mixin) window-x window-y)
+  (copy-from-pixmap pixmap pixmap-x pixmap-y width height
+		    (slot-value stream 'stream) window-x window-y))
+
+
+;=====================================
+#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;GENERA-IMPLEMENTATION.LISP.285")
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-")
+
+;;; Pixmaps
+
+;; Replaces COPY-AREA-INTERNAL
+(defmethod copy-area ((stream sheet-implementation-mixin)
+		      from-x from-y width height to-x to-y)
+  ;; Coords in "host" coordinate system
+  (when (window-drawing-possible stream)
+    (fix-points from-x from-y width height to-x to-y)
+    (with-slots (window) stream
+      (when (>= to-x from-x)
+	;; Shifting to the right
+	(setq width (- (abs width))))
+      (when (>= to-y from-y)
+	(setq height (- (abs height))))
+      (scl:send window :bitblt-within-sheet 
+		       tv:alu-seta width height from-x from-y to-x to-y))))
+
+
+(defclass genera-pixmap (basic-pixmap))
+
+(defmethod allocate-pixmap ((stream sheet-implementation-mixin) width height)
+  (with-slots (window) stream
+    (let* ((root (window-root stream))
+	   (screen (slot-value root 'window))
+	   (pixmap (tv:allocate-bitmap-stream :for-stream window
+					      :width width :height height
+					      :host-allowed t)))
+      (make-instance 'genera-pixmap 
+		     :pixmap pixmap :screen screen
+		     :width width :height height))))
+
+(defmethod deallocate-pixmap ((pixmap genera-pixmap))
+  (with-slots (pixmap) pixmap
+    (tv:deallocate-bitmap-stream pixmap)
+    (setq pixmap nil)))
+
+(defmethod copy-to-pixmap ((stream sheet-implementation-mixin)
+			   window-x window-y width height
+			   &optional pixmap (pixmap-x 0) (pixmap-y 0))
+  (fix-points window-x window-y width height pixmap-x pixmap-y)
+  (with-slots (window) stream
+    (cond ((null pixmap)
+	   (setq pixmap (allocate-pixmap stream width height)))
+	  (t
+	   (check-type pixmap genera-pixmap)
+	   (let* ((root (window-root stream))
+		  (screen (slot-value root 'window)))
+	     (assert (eql screen (slot-value pixmap 'screen)) ()
+		     "You can only use a pixmap on the screen for which it was allocated"))))
+    (scl:send (slot-value pixmap 'pixmap) :bitblt-from-sheet
+	      tv:alu-seta width height pixmap-x pixmap-y
+	      window window-x window-y))
+  pixmap)
+
+(defmethod copy-from-pixmap ((pixmap genera-pixmap) pixmap-x pixmap-y width height
+			     (stream sheet-implementation-mixin) window-x window-y)
+  (fix-points window-x window-y width height pixmap-x pixmap-y)
+  (let* ((root (window-root stream))
+	 (screen (slot-value root 'window)))
+    (assert (eql screen (slot-value pixmap 'screen)) ()
+	    "You can only use a pixmap on the screen for which it was allocated"))
+  (with-slots (window) stream
+    (scl:send (slot-value pixmap 'pixmap) :bitblt-to-sheet
+	      tv:alu-seta width height pixmap-x pixmap-y
+	      window window-x window-y))
+  pixmap)
+
+
+(defclass genera-pixmap-stream
+	  (sheet-implementation-mixin window-stream)
+    ()
+  (:default-initargs :display-device-type nil
+		     :text-cursor nil))
+
+(defmethod initialize-instance :after ((stream genera-pixmap-stream) &key parent pixmap)
+  (assert (not (null parent)) ()
+	  "You must provide a root window for Genera pixmap streams")
+  (with-slots (display-device-type) stream
+    (unless display-device-type
+      (setf display-device-type (slot-value parent 'display-device-type))))
+  (let ((root-sheet (slot-value (window-root parent) 'window))
+	(parent-sheet (slot-value parent 'window))
+	(sheet (slot-value pixmap 'pixmap)))
+    (with-slots (left top right bottom) stream
+      (multiple-value-bind (width height) (scl:send parent-sheet :size)
+	(setf left 0
+	      top  0
+	      right  width
+	      bottom height)))
+    (setf (slot-value stream 'window) sheet)
+    (setf (slot-value stream 'color-p) (color:color-stream-p root-sheet))
+    (setf (slot-value stream 'embedded-p)
+	  (typep (tv:sheet-screen sheet) 'tv:basic-remote-screen))
+    (setf (medium-foreground stream) (medium-foreground parent))
+    (setf (medium-background stream) (medium-background parent))
+    (associate-clim-window-with-host-window sheet stream)))
+
+(defmethod (setf medium-foreground) :after (ink (stream genera-pixmap-stream))
+  (with-slots (window) stream	   
+    (scl:send window :set-char-aluf (sheet-decode-color ink stream nil))))
+
+(defmethod (setf medium-background) :after (ink (stream genera-pixmap-stream))
+  (with-slots (window) stream	   
+    (scl:send window :set-erase-aluf (sheet-decode-color ink stream nil))))
+
+(defmethod invoke-with-output-to-pixmap ((stream sheet-implementation-mixin) continuation)
+  (let* ((pixmap (allocate-pixmap stream nil nil))
+	 (stream (make-instance 'genera-pixmap-stream 
+				:parent stream :pixmap pixmap)))
+    (funcall continuation stream)
+    pixmap))
+
+
+;=====================================
+#+Genera (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:CLIM;CLIM;CLX-IMPLEMENTATION.LISP.236")
+#+Genera (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-")
+
+;;; Pixmaps
+
+;; Replaces COPY-AREA-INTERNAL
+(defmethod copy-area ((stream clx-window) from-x from-y width height to-x to-y)
+  ;; Coords in "host" coordinate system
+  (fix-points from-x from-y width height to-x to-y)
+  (with-slots (window copy-gc) stream
+    (xlib:copy-area window copy-gc from-x from-y width height window to-x to-y))
+  (clx-force-output-if-necessary stream))
+
+
+(defclass clx-pixmap (basic-pixmap))
+
+(defmethod allocate-pixmap ((stream clx-window) width height)
+  (with-slots (window) stream
+    (let* ((root (window-root stream))
+	   (screen (slot-value root 'window))
+	   (pixmap (xlib:create-pixmap :drawable window
+				       :width width :height height
+				       :depth (xlib:drawable-depth window))))
+      (make-instance 'clx-pixmap 
+		     :pixmap pixmap :screen screen
+		     :width width :height height))))
+
+(defmethod deallocate-pixmap ((pixmap clx-pixmap))
+  (with-slots (pixmap) pixmap
+    (xlib:free-pixmap pixmap)
+    (setq pixmap nil)))
+
+(defmethod copy-to-pixmap ((stream clx-window) window-x window-y width height
+			   &optional pixmap (pixmap-x 0) (pixmap-y 0))
+  (fix-points window-x window-y width height pixmap-x pixmap-y)
+  (with-slots (window copy-gc) stream
+    (cond ((null pixmap)
+	   (setq pixmap (allocate-pixmap stream width height)))
+	  (t
+	   (check-type pixmap clx-pixmap)
+	   (let* ((root (window-root stream))
+		  (screen (slot-value root 'window)))
+	     (assert (eql screen (slot-value pixmap 'screen)) ()
+		     "You can only use a pixmap on the screen for which it was allocated"))))
+    (xlib:copy-area window copy-gc window-x window-y width height
+		    (slot-value pixmap 'pixmap) pixmap-x pixmap-y))
+  pixmap)
+
+(defmethod copy-from-pixmap ((pixmap clx-pixmap) pixmap-x pixmap-y width height
+			     (stream clx-window) window-x window-y)
+  (fix-points window-x window-y width height pixmap-x pixmap-y)
+  (let* ((root (window-root stream))
+	 (screen (slot-value root 'window)))
+    (assert (eql screen (slot-value pixmap 'screen)) ()
+	    "You can only use a pixmap on the screen for which it was allocated"))
+  (with-slots (window copy-gc) stream
+    (xlib:copy-area (slot-value pixmap 'pixmap) copy-gc pixmap-x pixmap-y width height
+		    window window-x window-y))
+  (clx-force-output-if-necessary stream)
+  pixmap)
+
+
+(defclass clx-pixmap-stream
+	  (clx-window)
+    ()
+  (:default-initargs :display-device-type nil
+		     :text-cursor nil))
+
+(defmethod initialize-instance :after ((stream clx-pixmap-stream) &key parent pixmap)
+  (assert (not (null parent)) ()
+	  "You must provide a root window for CLX pixmap streams")
+  (with-slots (display-device-type) stream
+    (unless display-device-type
+      (setf display-device-type (slot-value parent 'display-device-type))))
+  (let ((sheet (slot-value pixmap 'pixmap)))
+    (with-slots (root screen window left top right bottom
+		 color-p white-pixel black-pixel copy-gc points-to-pixels) stream
+      (setf root (clx-stream-root parent))
+      (setf screen (clx-stream-screen parent))
+      (setf window sheet)
+      (setf left 0)
+      (setf top 0)
+      (setf right (xlib:screen-width screen))
+      (setf bottom (xlib:screen-height screen))
+      (setf color-p (color-stream-p stream))
+      (setf color-p (color-stream-p stream)) 
+      (setf black-pixel (xlib:screen-black-pixel screen))
+      (setf copy-gc (xlib:create-gcontext :drawable window :exposures nil))
+      (setf points-to-pixels (* (sqrt (* (/ (xlib:screen-width screen)
+					    (xlib:screen-width-in-millimeters screen))
+					 (/ (xlib:screen-height screen)
+					    (xlib:screen-height-in-millimeters screen))))
+				(/ 25.4s0 72))) 
+      (let ((rounded (round points-to-pixels)))
+	(when (< (abs (- points-to-pixels rounded)) .1s0)
+	  (setf points-to-pixels rounded)))
+      (clx-recompute-gcs stream)
+      (setf (getf (xlib:window-plist window) 'stream) stream)))
+  (setf (medium-foreground stream) (medium-foreground parent))
+  (setf (medium-background stream) (medium-background parent)))
+
+(defmethod (setf medium-foreground) :after (ink (stream clx-pixmap-stream))
+  (declare (ignore ink))
+  (clx-recompute-gcs stream))
+
+(defmethod (setf medium-background) :after (ink (stream clx-pixmap-stream))
+  (declare (ignore ink))
+  (clx-recompute-gcs stream))
+
+(defmethod invoke-with-output-to-pixmap ((stream clx-window) continuation)
+  (let* ((pixmap (allocate-pixmap stream nil nil))
+	 (stream (make-instance 'clx-pixmap-stream 
+				:parent stream :pixmap pixmap)))
+    (funcall continuation stream)
+    pixmap))
+
diff --git a/pre-silica/cloe-applications.lisp b/pre-silica/cloe-applications.lisp
new file mode 100644
index 00000000..33c3aa37
--- /dev/null
+++ b/pre-silica/cloe-applications.lisp
@@ -0,0 +1,24 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: cloe-applications.lisp,v 1.4 91/03/26 12:47:13 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+(defun run-cloe-application (name)
+  (win::start-windows)
+  (unwind-protect
+      (progn
+	(win::show-window (win::get-term-window) :type :minimize)
+	(run-frame-top-level (make-application-frame name :parent (open-root-window :cloe))))
+    (win::stop-windows)))
+
+(defun cloe-debugger-hook (condition hook)
+  (declare (ignore hook))
+  (let ((term (win::get-term-window)))
+    (win::show-window term :type :show-normal)
+    (unwind-protect
+        (invoke-debugger condition)
+      (when (frame-top-level-sheet *application-frame*)
+        (win::show-window term :type :minimize)))))
diff --git a/pre-silica/cloe-events.lisp b/pre-silica/cloe-events.lisp
new file mode 100644
index 00000000..36a58bd5
--- /dev/null
+++ b/pre-silica/cloe-events.lisp
@@ -0,0 +1,291 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: cloe-events.lisp,v 1.4 91/03/26 12:47:14 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+(defvar *cloe-windows-with-deferred-events* nil)
+(defvar *input-queued* nil)
+(defvar *pointer-moved* nil)
+(defvar *pointer-window*)
+(defvar *pointer-x*)
+(defvar *pointer-y*)
+
+(defun cloe-note-pointer-motion (stream x y)
+  (setf *pointer-window* stream)
+  (setf *pointer-x* x)
+  (setf *pointer-y* y)
+  (setf *pointer-moved* t))
+
+(defun-inline sign-extend-16 (n)
+  (dpb n (byte 15 0) (- (ldb (byte 1 15) n))))
+
+(defmethod cloe-vanilla-event ((stream cloe-window-stream) message args)
+  (declare (fixnum message))
+  (with-slots (update-region pending-scrolls move-pending input-buffer
+	       event-left event-top event-width event-height) stream
+    (cond ((= message win::wm_paint)
+	   (let ((ileft (win::get-16bit args 4))
+		 (itop (win::get-16bit args 6))
+		 (iright (win::get-16bit args 8))
+		 (ibottom (win::get-16bit args 10)))
+	     (unless (or (= ileft iright) (= itop ibottom))	;seems to happen alot
+	       (multiple-value-bind (dsx dsy)
+		   (viewport-to-drawing-surface-coordinates stream ileft itop)
+		 (push (make-bounding-rectangle
+			 dsx dsy
+			 (+ dsx (- iright ileft)) (+ dsy (- ibottom itop)))
+		       update-region)
+		 (pushnew stream *cloe-windows-with-deferred-events*)))))
+	  ;; scrolling
+	  ((or (= message win::wm_hscroll) (= message win::wm_vscroll))
+	   (let ((type (win::get-16bit args 4))
+		 (position (win::get-16bit args 6))
+		 (message (cond ((= message win::wm_hscroll) :x)
+				((= message win::wm_vscroll) :y))))
+	     (declare (fixnum type position))
+	     (multiple-value-bind (type position)
+		 (cond ((= type win::sb_lineup)
+			(values :relative-jump -1))
+		       ((= type win::sb_linedown)
+			(values :relative-jump +1))
+		       ((= type win::sb_pageup)
+			(values :screenful -1))
+		       ((= type win::sb_pagedown)
+			(values :screenful +1))
+		       ((= type win::sb_thumbposition)
+			(values :percentage position))
+		       ((= type win::sb_top)
+			(values :percentage 0))
+		       ((= type win::sb_bottom)
+			(values :percentage 100)))
+	       (when type
+		 (queue-put pending-scrolls (list message type position))
+		 (pushnew stream *cloe-windows-with-deferred-events*)))))
+	  ;; resizing
+	  ((= message win::wm_move)
+	   (setf event-left (sign-extend-16 (win::get-16bit args 6)))
+	   (setf event-top (sign-extend-16 (win::get-16bit args 8)))
+	   (pushnew stream *cloe-windows-with-deferred-events*)
+	   (setf move-pending t))
+	  ((= message win::wm_size)
+	   (unless (= (the fixnum (win::get-16bit args 4)) win::sizeiconic)
+	     (setf event-width (win::get-16bit args 6))
+	     (setf event-height (win::get-16bit args 8))
+	     (pushnew stream *cloe-windows-with-deferred-events*)
+	     (setf move-pending t)))
+	  ;; character typed
+	  ((= message win::wm_char)
+	   (let ((char (aref args 4)))
+             (when (char= char #\return)
+	       (setq char #\newline))
+	     (queue-put input-buffer char))
+	   (setf *input-queued* t))
+	  ;; meta character typed
+	  ((= message win::wm_syschar) ;meta key
+	   (let ((char (set-char-bit 
+			 (char-upcase (aref args 4)) :meta t))) 
+	   (queue-put input-buffer char))
+	   (setf *input-queued* t))
+	  ;; button press or release
+	  ((or (= message win::wm_lbuttondown)
+	       (= message win::wm_rbuttondown)
+	       (= message win::wm_mbuttondown)
+	       (= message win::wm_lbuttonup)
+	       (= message win::wm_rbuttonup)
+	       (= message win::wm_mbuttonup))
+	   (let ((mask (win::get-16bit args 4)) 
+		 (x (win::get-16bit args 6))
+		 (y (win::get-16bit args 8))
+		 (pointer (stream-primary-pointer stream)))
+	     (cloe-note-pointer-motion stream x y)
+	     (when pointer
+	       (cond ((or (= message win::wm_lbuttondown)
+			  (= message win::wm_rbuttondown)
+			  (= message win::wm_mbuttondown))
+		      (stream-note-pointer-button-press 
+			stream pointer (case message
+					 (#.win::wm_lbuttondown 1)
+					 (#.win::wm_mbuttondown 2)
+					 (#.win::wm_rbuttondown 4))
+			(windows-mask->modifier-state mask) x y)
+		      (setf *input-queued* t))
+		     (*generate-button-release-events*
+		      (stream-note-pointer-button-release 
+			stream pointer (case message
+					 (#.win::wm_lbuttonup 1)
+					 (#.win::wm_mbuttonup 2)
+					 (#.win::wm_rbuttonup 4))
+			(windows-mask->modifier-state mask) x y)
+		      (setf *input-queued* t)))))))))
+
+(defun win::vanilla-event (code length args)
+  (declare (ignore length))			;because I don't know what they are!
+  (let ((stream (clim-window-for-host-window
+			 (win::get-16bit args 0) :error-if-no-match nil))
+	(message (win::get-16bit args 2)))
+    (declare (fixnum message))
+    (when stream
+      (cond ((= message win::wm_mousemove)
+	     (let ((x (win::get-16bit args 6))
+		   (y (win::get-16bit args 8)))
+	       (cloe-note-pointer-motion stream x y)))
+	    (t
+	     (cloe-vanilla-event stream message args))))))
+
+;;; Convert a MS Windows shift mask into a CLIM modifier-state
+(defun windows-mask->modifier-state (mask)
+  (let ((modifier-state 0))
+    (macrolet ((do-shift (shift)
+		 `(when (logtest ,(intern (format nil "MK_~A" (symbol-name shift))
+					  (find-package 'win))
+				 mask)
+		    (let ((bit (modifier-key-index ,shift)))
+		      (setf modifier-state (dpb 1 (byte 1 bit) modifier-state))))))
+      (do-shift :shift)
+      (do-shift :control)
+      ;; no meta super or hyper bits here!
+      modifier-state
+      )))
+
+(defmethod set-pointer-window-and-location ((stream cloe-window-stream) pointer)
+  ;;--- What should this do?
+  )
+
+(defmethod stream-event-handler ((stream cloe-window-stream)
+			         &key (timeout nil) (input-wait-test nil))
+  (cloe-event-handler timeout input-wait-test stream))
+
+(defmethod stream-event-handler ((stream cloe-root-window)
+			         &key (timeout nil) (input-wait-test nil))
+  (cloe-event-handler timeout input-wait-test stream))
+
+(defun cloe-event-handler (timeout input-wait-test original-stream)
+  (cloe-process-all-deferred-events)
+  (let ((end-time (and timeout (+ (get-internal-real-time)
+				  (* internal-time-units-per-second timeout))))
+	;; If we're inside an encapsulating stream, such as the input editor, and a window
+	;; resizing event is received, don't get confused while handling the event
+	(*original-stream* nil))
+    (loop
+      ;; The assumption is that the input-wait-test function can only change
+      ;; its value when an event is received and processed.  The only
+      ;; commonly-desired exception is a timeout, which we provide directly.
+      (when (and input-wait-test (funcall input-wait-test original-stream))
+	(return-from cloe-event-handler :input-wait-test))
+      (win::await-response -1 nil t)
+      ;; we do this here, rather than in vanilla event
+      ;; to provide for better synchronization.
+      (cloe-process-all-deferred-events)
+      (when *pointer-moved*
+	(setf *pointer-moved* nil)
+	(let ((window *pointer-window*))
+	  (setf (pointer-window *cloe-pointer*) window)
+	  (when window
+	    (multiple-value-bind (wx wy)
+		(window-offset window)
+	      (pointer-set-position* *cloe-pointer* (+ *pointer-x* wx) (+ *pointer-y* wy)))
+	    (setf (pointer-motion-pending window *cloe-pointer*) t)))
+	(return :mouse-motion))
+      (when *input-queued*
+	(setf *input-queued* nil)
+	(return :input-buffer))
+      (when (and end-time (> (get-internal-real-time) end-time))
+	(return :timeout)))))
+
+;;; Called after paint events have likely been generated.  First, make sure
+;;; they get read from the WINFE side.  Then, process all queued paint events
+;;; now.
+(defun handle-generated-paints () 
+  (win::await-response -1 nil nil)
+  (cloe-process-all-deferred-events))
+
+(defmethod set-stream-pointer-in-screen-coordinates ((stream cloe-window-stream)
+						     pointer x y)
+  (declare (ignore pointer))
+  (win::set-pointer-position x y))
+
+(defmethod stream-pointer-input-rectangle*
+    ((stream cloe-window-stream)
+     pointer &key left top right bottom)
+ (declare (ignore left top right bottom))
+ (portable-pointer-input-rectangle* stream pointer))
+
+(defun cloe-process-all-deferred-events ()
+  (loop
+    (when (null *cloe-windows-with-deferred-events*) (return))
+    (cloe-process-deferred-events (pop *cloe-windows-with-deferred-events*))))
+
+(defmethod cloe-process-deferred-events ((stream cloe-window-stream))
+  (with-slots (window left top right bottom margin-width margin-height
+  		      event-left event-top event-width event-height
+		      move-pending update-region pending-scrolls) stream
+    (declare (fixnum left top right bottom event-left event-top event-width event-height))
+    (when move-pending
+      (setf move-pending nil)
+      (unless (win::is-iconic window)
+	(multiple-value-bind (new-left new-top new-right new-bottom)
+	    (multiple-value-bind (width height)
+		(multiple-value-bind (wleft wtop wright wbottom)
+		    (win::get-window-rectangle window)
+		  (declare (fixnum wleft wtop wright wbottom))
+		  (values (- wright wleft) (- wbottom wtop)))
+	      (declare (fixnum width height))
+	      (setf margin-width (- width event-width))
+	      (setf margin-height (- height event-height))
+	      (values event-left event-top (+ event-left width) (+ event-top height)))
+	  (declare (fixnum new-left new-top new-right new-bottom))
+	  (unless (and (= left new-left) (= top new-top)
+		       (= right new-right) (= bottom new-bottom))
+	    (window-note-size-or-position-change
+	      stream new-left new-top new-right new-bottom)))))
+    (loop
+      (let ((entry (queue-get pending-scrolls)))
+	(when (null entry) (return))
+	(apply #'cloe-process-deferred-scroll stream entry)))
+    (when update-region
+      (window-process-update-region stream))
+    nil))
+
+(defmethod cloe-process-deferred-scroll ((stream cloe-window-stream) message type position)
+  (multiple-value-bind (new-left new-top)
+      (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream)
+	(multiple-value-bind (hleft htop hright hbottom)
+	    (let ((history (and (output-recording-stream-p stream)
+				(stream-output-history stream))))
+	      (if history
+		  (bounding-rectangle* history)
+		  (values 0 0 1000 100)))
+	  (ecase message
+	    (:y
+	      (values vleft
+		      (min (max htop
+				(ecase type
+				  (:relative-jump
+				    (+ vtop (* position (stream-line-height stream))))
+				  (:screenful
+				    (+ vtop (* position (- vbottom vtop))))
+				  (:percentage
+				    (+ htop
+				       (round (* position (- (- hbottom htop) (- vbottom vtop)))
+					      100)))))
+			   hbottom)))
+	    (:x
+	      (values (min (max hleft
+				(ecase type
+				  (:relative-jump
+				    (+ vleft
+				       (* position (stream-character-width stream #\space))))
+				  (:screenful
+				    (+ vleft (* position (- vright vleft))))
+				  (:percentage
+				    (+ hleft
+				       (round (* position (- (- hright hleft) (- vright vleft)))
+					      100)))))
+			   hright)
+		      vtop))
+	    )))
+    (window-set-viewport-position* stream new-left new-top)))
diff --git a/pre-silica/cloe-implementation.lisp b/pre-silica/cloe-implementation.lisp
new file mode 100644
index 00000000..9839b4c3
--- /dev/null
+++ b/pre-silica/cloe-implementation.lisp
@@ -0,0 +1,1035 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: cloe-implementation.lisp,v 1.4 91/03/26 12:47:15 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; Support for the shared class DC.
+
+(defvar *dc*)
+
+(defvar *current-pen*)
+(defvar *current-brush*)
+(defvar *current-rop2*)
+(defvar *current-background-color*)
+(defvar *current-text-color*)
+(defvar *current-font*)
+
+;;; Stock objects
+
+(defvar *null-pen*)
+(defvar *black-pen*)
+(defvar *white-pen*)
+
+(defvar *null-brush*)
+(defvar *black-brush*)
+(defvar *white-brush*)
+
+;;; Original objects
+
+(defvar *color-to-image* (make-hash-table))
+(defvar *black-image*)
+(defvar *white-image*)
+
+(defvar *ink-to-image* (make-hash-table))
+
+(defstruct (dc-image (:predicate nil))
+  (bitmap nil)
+  solid-1-pen
+  (pen-table (make-hash-table))
+  brush
+  (rop2 win::r2_copypen)
+  text-color
+  background-color)
+
+;;;
+
+(defun initialize-dc ()
+  ;; Dummy window to represent class.
+  (setf *dc* (win::create-window "Vanilla" "CLIM" win::ws_popup 0 0 0 0 0 0 0 "arg"))
+
+  ;; Stock objects
+  (setf *null-pen* (win::get-stock-object win::null_pen))
+  (setf *black-pen* (win::get-stock-object win::black_pen))
+  (setf *white-pen* (win::get-stock-object win::white_pen))
+  (setf *current-pen* *black-pen*)
+
+  (setf *null-brush* (win::get-stock-object win::null_brush))
+  (setf *black-brush* (win::get-stock-object win::black_brush))
+  (setf *white-brush* (win::get-stock-object win::white_brush))
+  (setf *current-brush* *white-brush*)
+
+  (setf *current-rop2* win::r2_copypen)
+  (setf *current-background-color* #xffffff)
+  (setf *current-text-color* #x000000)
+  (setf *current-font* nil)
+
+  (setf *black-image*
+	(make-dc-image :solid-1-pen *black-pen* :brush *black-brush*
+		       :text-color #x000000 :background-color nil))
+  (setf (gethash #x000000 *color-to-image*) *black-image*)
+  (setf *white-image*
+	(make-dc-image :solid-1-pen *white-pen* :brush *white-brush*
+		       :text-color #xffffff :background-color nil))
+  (setf (gethash #xffffff *color-to-image*) *white-image*)
+  )
+
+(defun select-pen (pen)
+  (unless (eql *current-pen* pen)
+    (win::select-pen *dc* pen)
+    (setf *current-pen* pen))
+  pen)
+
+(defun select-brush (brush)
+  (unless (eql *current-brush* brush)
+    (win::select-brush *dc* brush)
+    (setf *current-brush* brush))
+  brush)
+
+(defun select-rop2 (rop2)
+  (unless (eql *current-rop2* rop2)
+    (win::set-rop2 *dc* rop2)
+    (setf *current-rop2* rop2))
+  rop2)
+
+(defun select-background-color (color)
+  (unless (eql *current-background-color* color)
+    (cond ((null color)
+	   #||(win::set-background-mode *dc* win::transparent)||#)
+	  (t
+	   #||(when (null *current-background-color*)
+		(win::set-background-mode *dc* win::opaque))||#
+	   (win::set-background-color *dc* color)
+    (setf *current-background-color* color))))
+  color)
+
+(defun select-text-color (color)
+  (unless (eql *current-text-color* color)
+    (win::set-text-color *dc* color)
+    (setf *current-text-color* color))
+  color)
+
+(defun select-font (font)
+  (unless (eql *current-font* font)
+    (win::select-font *dc* font)
+    (setf *current-font* font))
+  font)
+
+;;;
+
+(defun set-dc-for-drawing (image line-style)
+  (let ((dashes (line-style-dashes line-style)))
+    (select-pen
+      (let* ((thickness (max 1 (round (line-style-thickness line-style))))
+	     (code (if dashes (- thickness) thickness)))
+	(declare (fixnum thickness code))
+	(if (= code 1)
+	    (dc-image-solid-1-pen image)
+	    (or (gethash code (dc-image-pen-table image))
+		(setf (gethash code (dc-image-pen-table image))
+		      (win::create-pen (if dashes win::ps_dash win::ps_solid)
+				       thickness
+				       (dc-image-text-color image)))))))
+    (when dashes
+      (select-background-color nil)))
+  (select-brush *null-brush*)
+  (select-rop2 (dc-image-rop2 image))
+  image)
+
+(defun set-dc-for-filling (image)
+  (select-pen *null-pen*)
+  (select-brush (dc-image-brush image))
+  (let ((background-color (dc-image-background-color image)))
+    (when background-color
+      (select-background-color background-color)))
+  (select-rop2 (dc-image-rop2 image)))
+
+(defun set-dc-for-ink (stream ink line-style)
+  (let ((image (dc-image-for-ink stream ink)))
+    (if line-style
+	(set-dc-for-drawing image line-style)
+	(set-dc-for-filling image))))
+
+(defun set-dc-for-text (stream ink font)
+  (select-text-color (dc-image-text-color (dc-image-for-ink stream ink)))
+  (select-background-color nil)
+  (select-font font))
+
+
+
+(defclass cloe-root-window
+	  (window-stream)
+    ()
+  (:default-initargs :input-buffer nil :display-device-type *cloe-device* :left 0 :top 0))
+
+(defmethod initialize-instance :after ((stream cloe-root-window) &key)
+  (unless win::*windows-enabled*
+    (win::start-windows))
+  (with-slots (right bottom) stream
+    (multiple-value-setq (right bottom)
+      (win::get-screen-size)))
+  (initialize-dc)
+  (setf (stream-pointers stream) (list (make-instance 'standard-pointer :root stream))))
+
+(defmethod window-margins ((stream cloe-root-window))
+  (values 0 0 0 0))
+
+(defmethod host-window-margins ((stream cloe-root-window))
+  (values 0 0 0 0))
+
+(defmethod window-stream-class-name ((stream cloe-root-window))
+  'cloe-window-stream)
+
+(defmethod close ((stream cloe-root-window) &key abort)
+  (declare (ignore abort))
+  nil)
+
+(defvar *cloe-root-window*)
+(defvar *cloe-pointer*)
+
+(defun create-cloe-root-window ()
+  (unless (boundp '*cloe-root-window*)
+    (setf *cloe-root-window* (make-instance 'cloe-root-window))
+    (setf *cloe-pointer* (stream-primary-pointer *cloe-root-window*)))
+  *cloe-root-window*)
+
+(define-implementation :cloe 'create-cloe-root-window)
+
+
+
+(defclass cloe-window-stream
+	  (window-stream)
+    ((window :initarg :window)
+     (move-pending :initform nil)
+     (event-width) (event-height)
+     (event-left) (event-top)
+     (margin-width) (margin-height)
+     (h-scroll-pos :initform nil)
+     (v-scroll-pos :initform nil)
+     (pending-scrolls :initform (make-queue))
+     (background-dc-image)
+     (foreground-dc-image)
+     (modifier-state :initform 0 :reader window-modifier-state))
+  (:default-initargs :display-device-type *cloe-device*))
+
+(defmethod initialize-instance :after ((stream cloe-window-stream) &key parent
+				       label (scroll-bars :both) (borders t) save-under)
+  (with-slots (window left top right bottom margin-width margin-height
+		      event-left event-top event-width event-height
+		      foreground-dc-image background-dc-image)
+	      stream
+    (let ((top-level (not (slot-exists-p parent 'window))))
+      (setf window (win::create-window
+		     "Vanilla" (or label "CLIM")
+		     (logior  win::ws_clipchildren	;new, helps refresh
+			      (if top-level
+				  (if save-under
+				      (logior win::ws_popup
+					      win::ws_border)
+				      (logior win::ws_overlapped
+					      win::ws_caption
+					      win::ws_thickframe
+					      win::ws_sysmenu
+					      win::ws_minimizebox
+					      win::ws_maximizebox))
+				  (logior win::ws_child
+					  win::ws_clipsiblings
+					  (if borders win::ws_border 0)))
+			      (if (member scroll-bars '(:horizontal :both))
+			          (progn (setf h-scroll-pos 0)
+				  	 win::ws_hscroll)
+				  0)
+			      (if (member scroll-bars '(:vertical :both))
+			          (progn (setf v-scroll-pos 0)
+				  	 win::ws_vscroll)
+				  0)
+			      )
+		     left top (- right left) (- bottom top)
+		     (if top-level 0 (slot-value parent 'window)) 0 0 "arg")))
+    (associate-clim-window-with-host-window window stream)
+    (setf foreground-dc-image (dc-image-for-ink stream (medium-foreground stream)))
+    (setf background-dc-image (dc-image-for-ink stream (medium-background stream)))
+    (multiple-value-bind (cleft ctop cright cbottom)
+	(win::get-client-rectangle window)
+      (multiple-value-bind (wleft wtop wright wbottom)
+	  (win::get-window-rectangle window)
+	(setf margin-width (- (- wright wleft) (- cright cleft)))
+	(setf margin-height (- (- wbottom wtop) (- cbottom ctop))))
+      (setf event-left (+ left cleft))
+      (setf event-top (+ top ctop))
+      (setf event-width (- cright cleft))
+      (setf event-height (- cbottom ctop))
+      (setf right (+ left event-width margin-width))
+      (setf bottom (+ top event-height margin-height)))
+    nil))
+
+(defmethod (setf window-label) :after (new-label (stream cloe-window-stream))
+  (when (consp new-label)
+    (setf new-label (first new-label)))
+  (with-slots (window) stream
+    (win::set-window-text window (or new-label "CLIM"))))
+
+(defmethod implementation-pixels-per-point ((stream cloe-window-stream))
+  1)
+
+(defmethod window-beep ((stream cloe-window-stream))
+  (win::message-beep))
+
+(defmethod close ((stream cloe-window-stream) &key abort)
+  (declare (ignore abort))
+  (with-slots (window) stream
+    (win::destroy-window window)))
+
+;;; After changing the background color, refresh the window.
+(defmethod (setf medium-background) :after (new-background (stream cloe-window-stream))
+  (with-slots (background-dc-image) stream
+    (setf background-dc-image (dc-image-for-ink stream new-background)))
+  (window-refresh stream))
+
+(defmethod (setf medium-foreground) :after (new-foreground (stream cloe-window-stream))
+  (with-slots (foreground-dc-image) stream
+    (setf foreground-dc-image (dc-image-for-ink stream new-foreground)))
+  (window-refresh stream))
+
+(defmethod window-erase-viewport ((stream cloe-window-stream))
+  (when (window-drawing-possible stream)
+    (multiple-value-bind (width height)
+	(window-inside-size stream)
+      (window-clear-area stream 0 0 width height))))
+
+(defmethod (setf window-visibility) :after (visibility (stream cloe-window-stream))
+  (labels ((window-set-visibility-1 (stream visibility)
+	     (win::show-window (slot-value stream 'window)
+			       :type (if visibility :show-no-activate :hide))
+	     (dolist (child (window-children stream))
+	       (when (window-visibility child)
+		 (window-set-visibility-1 child visibility)))))
+    (window-set-visibility-1 stream visibility))
+  (handle-generated-paints)
+  visibility)
+
+ (defmethod wait-for-window-exposed ((window cloe-window-stream))
+  (loop
+    (when (window-visibility window)
+      (return))
+    (process-yield)))
+
+(defmethod window-drawing-possible ((stream cloe-window-stream))
+  (window-visibility stream))
+
+(defmethod window-stack-on-top ((stream cloe-window-stream))
+  (with-slots (window) stream
+    (win::set-window-position window 0 0 0 0 0
+			      (logior win::swp_noactivate
+				      win::swp_nomove
+				      win::swp_nosize)))
+  (handle-generated-paints))
+
+(defmethod window-stack-on-bottom ((stream cloe-window-stream))
+  (with-slots (window) stream
+    (win::set-window-position window 1 0 0 0 0
+			      (logior win::swp_noactivate
+				      win::swp_nomove
+				      win::swp_nosize)))
+  (handle-generated-paints))
+
+(defmethod bounding-rectangle-set-edges :after
+	   ((stream cloe-window-stream) left top right bottom)
+  (with-slots (window) stream
+    (win::move-window window left top (- right left) (- bottom top) t))
+  (handle-generated-paints))
+  
+(defmethod bounding-rectangle-set-position* :after
+	   ((stream cloe-window-stream) new-left new-top)
+  (multiple-value-bind (width height) (bounding-rectangle-size stream)
+    (with-slots (window) stream
+      (win::move-window window new-left new-top width height t)))
+  (handle-generated-paints))
+
+(defmethod bounding-rectangle-set-size :after
+	   ((stream cloe-window-stream) width height)
+  (multiple-value-bind (left top) (bounding-rectangle-position* stream)
+    (with-slots (window) stream
+      (win::move-window window left top width height t)))
+  (handle-generated-paints))
+
+(defmethod stream-force-output ((stream cloe-window-stream))
+  (declare (ignore stream))
+  )
+
+(defmethod stream-clear-output ((stream cloe-window-stream))
+  (declare (ignore stream))
+  )
+
+(defmethod stream-finish-output ((stream cloe-window-stream))
+  (declare (ignore stream))
+  )
+
+(defmethod window-margins ((stream cloe-window-stream))
+  (declare (ignore stream))
+  (values 0 0 0 0))
+
+(defmethod host-window-margins ((stream cloe-window-stream))
+  (with-slots (margin-width margin-height) stream
+    (values 0 0 margin-width margin-height)))
+
+(defmethod window-flush-update-region ((stream cloe-window-stream))
+  (with-slots (update-region) stream
+    (setf update-region nil)))
+
+;;;changed to fix the scrolling problem
+(defmethod window-process-update-region ((stream cloe-window-stream))
+  (with-slots (window update-region background-dc-image) stream
+    (when update-region
+      (set-dc-for-filling background-dc-image)
+      (multiple-value-bind (dx dy)
+	  (window-viewport-position* stream)
+	(declare (type coordinate dx dy))
+	(dolist (region update-region)
+	  (with-bounding-rectangle* (left top right bottom) region
+	    (win::rectangle window (- left dx) (- top dy)
+				   (- right dx) (- bottom dy))))))))
+
+;;; Postpone better update region stuff.
+(defmethod window-shift-visible-region :after ((stream cloe-window-stream)
+					       old-left old-top old-right old-bottom
+					       new-left new-top new-right new-bottom)
+
+  (setf (slot-value stream 'update-region)
+	(ltrb-difference new-left new-top new-right new-bottom
+			 old-left old-top old-right old-bottom)))
+
+;; Does this want to be an :after method?  Will the primary method on
+;; window-stream ever want to do anything else?
+(defmethod stream-set-input-focus ((stream cloe-window-stream))
+  (with-slots (window) stream
+    (win::set-focus window)))
+
+(defmethod stream-restore-input-focus ((stream cloe-window-stream) old-focus)
+  (declare (ignore stream))
+  (win::set-focus old-focus))
+
+(defmethod stream-has-input-focus ((stream cloe-window-stream))
+  (with-slots (window) stream
+    (= window  (win::get-focus))))
+
+(defmethod notify-user-1 ((stream cloe-window-stream) frame format-string &rest format-args)
+  (declare (ignore frame) (dynamic-extent format-args))
+  (let ((formatted-string (apply #'format nil format-string format-args)))
+    (clos:with-slots (window) stream
+      (win::notify-user window formatted-string))))
+
+;;; Draw a rectangle in the background color.
+(defmethod window-clear-area ((stream cloe-window-stream) left top right bottom)
+  (with-slots (window background-dc-image) stream
+    (set-dc-for-filling background-dc-image)
+    (win::rectangle window left top right bottom)))
+
+(defmethod copy-area ((stream cloe-window-stream)
+		      from-left from-top from-right from-bottom
+		      to-left to-top)
+  (fix-points from-left from-top from-right from-bottom to-left to-top)
+  (let ((x-delta (- to-left from-left))		; can be negative
+	(y-delta (- to-top from-top)))		; can be negative
+    (multiple-value-bind (width height)
+	(window-inside-size stream)
+      (with-slots (window) stream
+	(win::scroll-dc window
+			x-delta y-delta
+			from-left from-top 
+			;; --- from-bottom or 1+?
+			from-right from-bottom	;rectangles are different...
+			0 0 width height)))))
+
+;;; Scrolling support.
+(defmethod cloe-recompute-scroll-bars ((stream cloe-window-stream))
+  ;; don't update the scroll bars if they didn't change.
+  (multiple-value-bind (new-h-pos new-v-pos)
+      (let ((history (and (output-recording-stream-p stream)
+			  (stream-output-history stream))))
+	(when history
+	  (multiple-value-bind (width height) (bounding-rectangle-size history)
+	    (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream)
+	      (values (and (< (- vright vleft) width)
+			   (round (* vleft 100)
+				  (- width (- vright vleft))))
+		      (and (< (- vbottom vtop) height)
+			   (round (* vtop 100)
+				  (- height (- vbottom vtop)))))))))
+    (with-slots (window h-scroll-pos v-scroll-pos) stream
+      (unless (eql new-h-pos h-scroll-pos)
+	(cond ((null new-h-pos)
+	       ;;(win::show-scroll-bar window win::sb_horz nil)
+	       (win::set-scroll-position window win::sb_horz new-h-pos))
+	      (t
+	       (win::set-scroll-position window win::sb_horz new-h-pos)
+	       #||(when (null h-scroll-pos)
+		 (win::show-scroll-bar window win::sb_horz t))||#))
+	(setf h-scroll-pos new-h-pos))
+      (unless (eql new-v-pos v-scroll-pos)
+	(cond ((null new-v-pos)
+	       ;;(win::show-scroll-bar window win::sb_vert nil)
+	       (win::set-scroll-position window win::sb_vert new-v-pos))
+	      (t
+	       (win::set-scroll-position window win::sb_vert new-v-pos)
+	       #||(when (null v-scroll-pos)
+		 (win::show-scroll-bar window win::sb_vert t))||#))
+	(setf v-scroll-pos new-v-pos)))))
+
+(defmethod window-set-viewport-position* :after ((stream cloe-window-stream) new-x new-y)
+  (cloe-recompute-scroll-bars stream))
+
+
+
+(defmethod invoke-with-clipping-region ((stream cloe-window-stream) continuation region)
+  (funcall continuation stream))
+
+(defmethod draw-point-internal ((stream cloe-window-stream)
+				x-offset y-offset x y ink line-style)
+  (with-slots (window) stream
+    (fix-points x y)
+    (translate-positions x-offset y-offset x y)
+    (set-dc-for-ink stream ink line-style)
+    (win::rectangle window x y x y)))
+
+(defmethod draw-line-internal ((stream cloe-window-stream) x-offset y-offset
+			       start-x start-y end-x end-y ink line-style)
+  (with-slots (window) stream
+    (fix-points start-x start-y end-x end-y)
+    (translate-positions x-offset y-offset start-x start-y end-x end-y)
+    (set-dc-for-ink stream ink line-style)
+    (win::move-to window start-x start-y)
+    (win::line-to window end-x end-y)))
+
+(defmethod draw-rectangle-internal ((stream cloe-window-stream) x-offset y-offset
+				    left top right bottom ink line-style)
+  (with-slots (window) stream
+    (fix-points left top right bottom)
+    (translate-positions x-offset y-offset left top right bottom)
+    (set-dc-for-ink stream ink line-style)
+    (win::rectangle window left top right bottom)))
+
+(defmethod draw-polygon-internal ((stream cloe-window-stream) x-offset y-offset
+				  list-of-x-and-ys closed ink line-style)
+  (with-slots (window) stream
+    (set-dc-for-ink stream ink line-style)
+    (if (null line-style)
+	(win::polygon window list-of-x-and-ys x-offset y-offset)
+	(win::polyline window list-of-x-and-ys closed x-offset y-offset))))
+
+(defvar *ft* .0001)
+(defun fl-= (x y)
+  (< (abs (- x y)) *ft*))
+
+(defmethod draw-ellipse-internal ((stream cloe-window-stream) x-offset y-offset
+				  center-x center-y
+				  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+				  start-angle end-angle ink line-style)
+  (fix-points center-x center-y)
+  (translate-positions x-offset y-offset center-x center-y)
+  (when (null start-angle)
+    (setq start-angle 0.0
+	  end-angle 2pi))
+  (with-slots (window) stream
+    (set-dc-for-ink stream ink line-style)
+    (setf radius-1-dx (round radius-1-dx))
+    (setf radius-1-dy (round radius-1-dy))
+    (setf radius-2-dx (round radius-2-dx))
+    (setf radius-2-dy (round radius-2-dy))
+    (multiple-value-bind (x-radius y-radius)
+	(cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+	       (values (abs radius-2-dx) (abs radius-1-dy)))
+	      ((and (= radius-2-dx 0) (= radius-1-dy 0))
+	       (values (abs radius-1-dx) (abs radius-2-dy)))
+	      (t (nyi)))
+      (let (left top right bottom)
+	(setq left (- center-x x-radius)
+	      right (+ center-x x-radius)
+	      top (- center-y y-radius)
+	      bottom (+ center-y y-radius))
+	(cond ((or (fl-= (- end-angle start-angle) 2pi)
+		   (fl-= (- end-angle start-angle) 0))
+	       #+Ignore
+	       (and (= start-angle 0)
+		    (= end-angle 2pi))
+	       ;; drawing a full ellipse
+	       (win::ellipse window left top right bottom))
+	      ((null line-style)
+	       ;; drawing a pie slice
+	       (win::pie window left top right bottom
+			 (round (+ (* (cos end-angle) x-radius) center-x))
+			 (round (+ (* (sin end-angle) y-radius) center-y))
+			 (round (+ (* (cos start-angle) x-radius) center-x))
+			 (round (+ (* (sin start-angle) y-radius) center-y))
+	
+			 ))
+	      (t
+	       ;; drawing an arc
+	       (win::arc window left top right bottom
+			 (+ (* (cos start-angle) x-radius) center-x)
+			 (+ (* (sin start-angle) y-radius) center-y)
+			 (+ (* (cos end-angle) x-radius) center-x)
+			 (+ (* (sin end-angle) y-radius) center-y))))))))
+
+
+
+(defgeneric dc-image-for-ink (stream ink))
+
+(defmethod dc-image-for-ink (stream (ink (eql +foreground-ink+)))
+  (slot-value stream 'foreground-dc-image))
+
+(defmethod dc-image-for-ink (stream (ink (eql +background-ink+)))
+  (slot-value stream 'background-dc-image))
+
+(defmethod dc-image-for-ink (stream (ink (eql +black+)))
+  (declare (ignore stream))
+  *black-image*)
+
+(defmethod dc-image-for-ink (stream (ink (eql +white+)))
+  (declare (ignore stream))
+  *white-image*)
+
+(defmethod dc-image-for-ink (stream (ink color))
+  (declare (ignore stream))
+  (multiple-value-bind (red green blue)
+      (color-rgb ink)
+    (let ((color (dpb (round (* 255 blue)) (byte 8 16)
+		      (dpb (round (* 255 green)) (byte 8 8)
+			   (round (* 255 red))))))
+      (declare (fixnum color))
+      (case color
+	((#x000000) *black-image*)
+	((#xffffff) *white-image*)
+	(otherwise
+	  (or (gethash color *color-to-image*)
+	      (setf (gethash color *color-to-image*)
+		    (make-dc-image :solid-1-pen (win::create-pen win::ps_solid 1 color)
+				   :brush (win::create-solid-brush color)
+				   :text-color color :background-color nil))))))))
+
+(defmethod dc-image-for-ink (stream (ink rectangular-tile))
+  ;; The only case we handle right now is stipples
+  (or (gethash ink *ink-to-image*)
+      (setf (gethash ink *ink-to-image*)
+	    (multiple-value-bind (array width height)
+		(decode-tile-as-stipple ink)
+	      (unless array
+		(error "Rectangular tiles other than stipples are not supported yet."))
+	      (let ((into (make-array 8 :element-type '(unsigned-byte 16)))
+		    (dc-image (copy-dc-image (slot-value stream 'foreground-dc-image))))
+		(macrolet ((collect-byte (row-no)
+			     `(let ((result 0))
+				(dotimes (j 8)
+				  (setq result
+					(dpb (aref array (mod ,row-no width) (mod j height))
+					     (byte 1 (- 7 j)) result)))
+				(logxor result #2r11111111))))
+		  (dotimes (i 8)
+		    (setf (aref into i) (collect-byte i))))
+		(let ((bitmap (win::create-bitmap into)))
+		  (setf (dc-image-bitmap dc-image) bitmap)
+		  (setf (dc-image-brush dc-image) (win::create-pattern-brush bitmap))
+		  (setf (dc-image-background-color dc-image)
+			(dc-image-text-color (slot-value stream 'background-dc-image))))
+		dc-image)))))
+
+(defmethod dc-image-for-ink (stream (ink flipping-ink))
+  (declare (ignore stream))
+  (or (gethash ink *ink-to-image*)
+      (setf (gethash ink *ink-to-image*)
+	    (multiple-value-bind (ink1 ink2)
+		(decode-flipping-ink ink)
+	      (let* ((image1 (dc-image-for-ink stream ink1))
+		     (image2 (dc-image-for-ink stream ink2))
+		     (color (logxor (dc-image-text-color image1)
+				    (dc-image-text-color image2))))
+		(unless (and (eql (dc-image-rop2 image1) win::r2_copypen)
+			     (eql (dc-image-rop2 image2) win::r2_copypen)
+			     (null (dc-image-bitmap image1))
+			     (null (dc-image-bitmap image2)))
+		  (nyi))
+		(make-dc-image :solid-1-pen (win::create-pen win::ps_solid 1 color)
+			       :brush (win::create-solid-brush color)
+			       :rop2 win::r2_xorpen
+			       :text-color color :background-color nil))))))
+
+(defmethod dc-image-for-ink (stream (ink contrasting-ink))
+  (dc-image-for-ink stream (make-color-for-contrasting-ink ink)))
+
+
+
+(defstruct (cloe-font)
+  index
+  height
+  ascent
+  descent
+  internal-leading
+  external-leading
+  average-character-width
+  maximum-character-width
+  weight
+  italic
+  underlined
+  struckout
+  first-character
+  last-character
+  default-character
+  break-character
+  character-set
+  overhang
+  pitch
+  family
+  font-width-table)
+
+;;; Fill up the font width table for a variable width font
+;;; by asking windows the width of each character.
+;;; This doesn't quite work in the face of kerning.
+(defun initialize-font-width-table (font window)
+  ;; only need to run this on variable-width fonts.
+  (select-font (cloe-font-index font))
+  (let ((array (make-array (1+ (- 126 32)))))
+    (with-temporary-string (string :length 1)
+      (setf (fill-pointer string) 1)
+      (loop for i from 32 to 126 do
+	(setf (aref string 0) (code-char i))
+	(multiple-value-bind (width height)
+	    (win::get-text-extent window string)
+	  (declare (ignore height ))
+	  (setf (aref array (- i 32)) width))))
+    (setf (cloe-font-font-width-table font) array)))
+
+(defmethod stream-glyph-for-character ((stream cloe-window-stream) character style
+				       &optional our-font)
+  (let ((display-device-type (slot-value stream 'display-device-type))
+	(window (slot-value stream 'window)))
+    (multiple-value-bind (character-set index)
+	(char-character-set-and-index character)
+      (let* ((cloe-font (or our-font
+			    (text-style-mapping
+			      display-device-type character-set style window)))
+	     (origin-x 0)
+	     (origin-y (cloe-font-ascent cloe-font))
+	     (average-w (cloe-font-average-character-width cloe-font))
+	     (max-w (cloe-font-maximum-character-width cloe-font))
+	     (fixed-width-p (= max-w average-w))
+	     (escapement-x (if fixed-width-p
+			       average-w
+			       (aref (cloe-font-font-width-table cloe-font) (- index 32))))
+	     (escapement-y 0)
+	     (bb-y (+ (cloe-font-height cloe-font)
+		      (cloe-font-external-leading cloe-font)))
+	     (bb-x escapement-x))
+	(values index cloe-font escapement-x escapement-y
+		origin-x origin-y bb-x bb-y
+		fixed-width-p)))))
+
+;;; Really want to set the text color to color.  Talk to Bob.
+(defmethod stream-write-string-1 ((stream cloe-window-stream)
+				  glyph-buffer start end font ink x y)
+  (with-slots (window) stream
+    (set-dc-for-text stream ink (cloe-font-index font))
+    (with-temporary-string (string :length (- end start))
+      (dovector (index glyph-buffer :start start :end end)
+	(vector-push (int-char index) string))
+      (win::text-out window x y string))))
+
+(defmethod stream-write-char-1 ((stream cloe-window-stream) index font ink x y)
+  (with-slots (window) stream
+    (set-dc-for-text stream ink (cloe-font-index font))
+    (with-temporary-string (string :length 1)
+      (vector-push (int-char index) string)
+      (win::text-out window x y string))))
+
+(defmethod draw-string-internal ((stream cloe-window-stream)
+				 x-offset y-offset string x y
+				 start end align-x align-y text-style ink)
+  (unless end (setq end (length string)))
+  (fix-points x y)
+  (translate-positions x-offset y-offset x y)
+  (with-temporary-substring (substring string start end)
+    (with-slots (window display-device-type) stream
+      (let* ((font (text-style-mapping
+		     display-device-type *standard-character-set* text-style window))
+	     (height (cloe-font-height font))
+             (descent (cloe-font-descent font))
+             (ascent (cloe-font-ascent font)))
+	(incf x (compute-text-x-adjustment
+		  align-x stream string text-style start end))
+	(incf y (compute-text-y-adjustment
+		  align-y descent ascent height))
+	(decf y ascent)		;text is positioned by its top left on CLOE
+	(set-dc-for-text stream ink (cloe-font-index font))
+	(win::text-out window x y substring)))))
+
+(defmethod draw-character-internal ((stream cloe-window-stream) x-offset y-offset 
+				    character x y align-x align-y text-style ink)
+  (fix-points x y)
+  (translate-positions x-offset y-offset x y)
+  (with-slots (window display-device-type) stream
+    (let* ((font (text-style-mapping
+		   display-device-type *standard-character-set* text-style window))
+	   (height (cloe-font-height font))
+	   (descent (cloe-font-descent font))
+	   (ascent (cloe-font-ascent font)))
+      (incf x (compute-text-x-adjustment
+		align-x stream character text-style))
+      (incf y (compute-text-y-adjustment
+		align-y descent ascent height))
+      (decf y ascent)		;text is positioned by its top left on CLOE
+      (set-dc-for-text stream ink (cloe-font-index font))
+      (with-temporary-string (string :length 1)
+	(vector-push character string)
+	(win::text-out window x y string)))))
+
+
+(defmethod text-style-height ((text-style standard-text-style) (stream cloe-window-stream))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (cloe-font-height font))))
+
+(defmethod text-style-width ((text-style standard-text-style) (stream cloe-window-stream))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (cloe-font-average-character-width font))))
+
+(defmethod text-style-ascent ((text-style standard-text-style) (stream cloe-window-stream))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (cloe-font-ascent font))))
+
+(defmethod text-style-descent ((text-style standard-text-style) (stream cloe-window-stream))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (cloe-font-descent font))))
+
+(defmethod text-style-fixed-width-p ((text-style standard-text-style) (stream cloe-window-stream))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      ;; Really disgusting, but probably OK
+      (= (cloe-font-average-character-width font)
+	 (cloe-font-maximum-character-width font)))))
+
+(defmethod text-size ((stream cloe-window-stream) string
+		      &key (text-style (stream-merged-text-style stream)) (start 0) end)
+  (when (characterp string)
+    (setq string (string string)
+	  start 0
+	  end nil))
+  (multiple-value-bind (last-x largest-x last-y total-height baseline)
+      (stream-string-output-size stream string :text-style text-style :start start :end end)
+    (values largest-x total-height last-x last-y baseline)))
+
+
+(defclass cloe-device (display-device)
+     ((font->cloe-font-mapping :initform (make-hash-table))))
+
+(defmethod text-style-mapping :around
+	   ((device cloe-device) character-set style &optional window)
+  (let ((font-name (call-next-method))
+	(hash-table (slot-value device 'font->cloe-font-mapping)))
+    (or (gethash font-name hash-table)
+	(setf (gethash font-name hash-table)
+	      (let ((name (string font-name))
+		    (here 0))
+		(labels ((token ()
+			   (unless here (error "Ran off end of name in font parser: ~A" name))
+			   (let ((new-here (position #\- name :test #'char-equal :start here)))
+			     (prog1 (subseq name here new-here)
+				    (setf here (and new-here (1+ new-here))))))
+			 (integer ()
+			   (parse-integer (token))))
+		  (let* ((face-name (token))
+			 (height (integer))
+			 (width (integer))
+			 (weight (integer))
+			 (italic (integer))
+			 (win-font (win::create-font height width 0 0 weight italic
+						     0 0 0 0 0 0 0 face-name)))
+		    (select-font win-font)
+		    (multiple-value-bind (height ascent descent
+					  internal-leading external-leading
+					  average-character-width maximum-character-width
+					  weight italic underlined struckout
+					  first-character last-character default-character
+					  break-character p&f character-set overhang
+					  aspect-x aspect-y)
+			(win::get-text-metrics *dc*)
+		      (declare (ignore p&f aspect-x aspect-y))
+		      (let ((cf
+			      (make-cloe-font
+				:index win-font :height height :ascent ascent
+				:descent descent
+				:internal-leading internal-leading
+				:external-leading external-leading
+				:average-character-width average-character-width
+				:maximum-character-width maximum-character-width
+				:weight weight :italic italic
+				:underlined underlined :struckout struckout
+				:first-character first-character
+				:last-character last-character
+				:default-character default-character
+				:break-character break-character
+				:overhang overhang)))
+			(unless (= average-character-width
+				   maximum-character-width)
+			  (initialize-font-width-table cf window))
+			cf)))))))))
+
+
+;;; Font names are "Family-height-width-weight-italic"; must be strings because case matters.
+(define-display-device *cloe-device* cloe-device
+  :font-for-undefined-style "Helv-10-10-400-0")
+
+;;; More to come, obviously.
+(define-text-style-mappings *cloe-device* *standard-character-set*
+  (:family :fix (:face :roman (:size 22 "Courier-22-30-400-0"
+				     16 "Courier-16-10-400-0"
+				     12 "Courier-12-8-400-0"
+				     12 "Courier-10-8-400-0"
+				      7 "Courier-8-6-400-0"
+				      6 "Courier-6-5-400-0")
+		       :bold (:size 22 "Courier-22-30-700-0"
+				    16 "Courier-16-10-700-0"
+				    12 "Courier-12-8-700-0"
+				    10 "Courier-10-8-700-0"
+				     8 "Courier-8-6-700-0"
+				     6 "Courier-6-5-700-0")
+		       :italic (:size 22 "Courier-22-30-400-1"
+				      16 "Courier-16-10-400-1"
+				      12 "Courier-12-8-400-1"
+				      10  "Courier-10-8-400-1"
+				       8 "Courier-8-6-400-1"
+				       6 "Courier-6-5-400-1")
+		       (:bold :italic) (:size 22 "Courier-22-30-700-1"
+					      16 "Courier-16-10-700-1"
+					      12 "Courier-12-8-700-1"
+					      10  "Courier-10-8-700-1"
+					       8 "Courier-8-6-700-1"
+					       6 "Courier-6-5-700-1"))))
+
+(define-text-style-mappings *cloe-device* *standard-character-set*
+  (:family :sans-serif (:face :roman (:size 22 "Helv-22-30-400-0"
+					    16 "Helv-16-10-400-0"
+					    12 "Helv-12-8-400-0"
+					    10 "Helv-10-8-400-0"
+					     8 "Helv-8-6-400-0"
+					     6 "Helv-6-5-400-0")
+			      :bold (:size 22 "Helv-22-30-700-0"
+					   16 "Helv-16-10-700-0"
+					   12 "Helv-12-8-700-0"
+					   10 "Helv-10-8-700-0"
+					    8 "Helv-8-6-700-0"
+					    6 "Helv-6-5-700-0")
+			      :italic (:size 22 "Helv-22-30-400-1"
+					     16 "Helv-16-10-400-1"
+					     12 "Helv-12-8-400-1"
+					     10 "Helv-10-8-400-1"
+					      8 "Helv-8-6-400-1"
+					      6 "Helv-6-5-400-1")
+			      (:bold :italic) (:size 22 "Helv-22-30-700-1"
+						     16 "Helv-16-10-700-1"
+						     12 "Helv-12-8-700-1"
+						     10 "Helv-10-8-700-1"
+						      8 "Helv-8-6-700-1"
+						      6 "Helv-6-5-700-1"))))
+
+(define-text-style-mappings *cloe-device* *standard-character-set*
+  (:family :serif (:face :roman (:size 22 "TMS RMN-22-30-400-0"
+				       16 "TMS RMN-16-10-400-0"
+				       12 "TMS RMN-12-8-400-0"
+				       10 "TMS RMN-10-8-400-0"
+				        8 "TMS RMN-8-6-400-0"
+				        6 "TMS RMN-6-5-400-0")
+			 :bold (:size 22 "TMS RMN-22-10-700-0"
+				      16 "TMS RMN-16-10-700-0"
+				      12 "TMS RMN-12-8-700-0"
+				      10 "TMS RMN-10-8-700-0"
+				       8 "TMS RMN-8-6-700-0"
+				       6 "TMS RMN-6-5-700-0")
+			 :italic (:size 22 "TMS RMN-22-30-400-1"
+					16 "TMS RMN-16-10-400-1"
+					12 "TMS RMN-12-8-400-1"
+					10 "TMS RMN-10-8-400-1"
+					 8 "TMS RMN-8-6-400-1"
+					 6 "TMS RMN-6-5-400-1")
+			 (:bold :italic) (:size 22 "TMS RMN-22-30-700-1"
+						16 "TMS RMN-16-10-700-1"
+						12 "TMS RMN-12-8-700-1"
+						10 "TMS RMN-10-8-700-1"
+						 8 "TMS RMN-8-6-700-1"
+						 6 "TMS RMN-6-5-700-1"))))
+
+(defparameter *cloe-logical-size-alist*
+	      '((:tiny       6)
+		(:very-small 8)
+		(:small	     10)
+		(:normal     12)
+		(:large	     16)
+		(:very-large 22)))
+
+(defmethod standardize-text-style ((display-device cloe-device) character-set style)
+  (standardize-text-style-1
+    display-device style character-set *cloe-logical-size-alist*))
+
+
+;;; These should really be defined in CL-STREAM, but doing it causes CLOE to
+;;; go south during the build, my guess is the regular streams get trashed.
+;;; So anyway we now do it here.
+
+(clos:defmethod stream-read-byte ((stream t)) 
+  (read-byte stream nil :eof))
+
+(clos:defmethod stream-read-char ((stream t)) 
+  (read-char stream nil :eof))
+
+(clos:defmethod stream-unread-char ((stream t) character) 
+  (unread-char character stream))
+
+(clos:defmethod stream-read-char-no-hang ((stream t)) 
+  (read-char-no-hang stream nil :eof))
+
+(clos:defmethod stream-peek-char ((stream t)) 
+  (peek-char nil stream nil :eof))
+
+(clos:defmethod stream-listen ((stream t)) 
+  (listen stream))
+
+(clos:defmethod stream-read-line ((stream t)) 
+  (read-line stream nil :eof))
+
+(clos:defmethod stream-clear-input ((stream t)) 
+  (clear-input stream))
+
+(clos:defmethod stream-write-byte ((stream t) integer) 
+  (write-byte integer stream))
+
+(clos:defmethod stream-write-char ((stream t) character) 
+  (write-char character stream))
+
+(clos:defmethod stream-write-string ((stream t) string &optional (start 0) end) 
+  (write-string string stream 
+		:start start 
+		:end end))
+
+(clos:defmethod stream-terpri ((stream t)) (terpri stream))
+
+
+(clos:defmethod stream-fresh-line ((stream t)) 
+  (fresh-line stream))
+
+(clos:defmethod stream-force-output ((stream t)) 
+  (force-output stream))
+
+(clos:defmethod stream-finish-output ((stream t)) 
+  (finish-output stream))
+
+(clos:defmethod stream-clear-output ((stream t)) 
+  (clear-output stream))
diff --git a/pre-silica/clx-implementation.lisp b/pre-silica/clx-implementation.lisp
new file mode 100644
index 00000000..5d38d240
--- /dev/null
+++ b/pre-silica/clx-implementation.lisp
@@ -0,0 +1,1586 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: clx-implementation.lisp,v 1.15 91/04/17 15:57:02 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+(defclass clx-display-device (display-device) ())
+
+(defvar *clx-font-families* '((:fix "*-courier-*")
+			      (:sans-serif "*-helvetica-*")
+			      (:serif "*-charter-*" "*-new century schoolbook-*" "*-times-*")))
+
+(defun disassemble-x-font-name (name)
+  (let ((cpos 0)
+	(tokens nil))
+    (loop
+      (let ((dpos (position #\- name :start cpos)))
+	(when (null dpos)
+	  (push (subseq name cpos) tokens)
+	  (return))
+	(push (if (= cpos dpos)
+		  nil
+		  (subseq name cpos dpos))
+	      tokens)
+	(setf cpos (1+ dpos))))
+    (reverse tokens)))
+
+(defmethod initialize-instance :after ((display-device clx-display-device) &key display)
+  ;; Sort of cheating, but ...
+  (setf (text-style-mapping
+	  display-device *standard-character-set* *undefined-text-style*)
+	'(:style :fix :roman 10))
+  ;;--- Bad idea to override the undefined mapping as above without guaranteeing
+  ;;--- that (:FIX :ROMAN 12) maps to something!  Hopefully this mapping will be
+  ;;--- replaced by the initialization code below, but if not at least we have a
+  ;;--- fallback.  For example, on the Genera X Server XLIB:LIST-FONTS is broken
+  ;;--- so no text styles get defined.
+  (setf (text-style-mapping
+	  display-device *standard-character-set* (parse-text-style '(:fix :roman 12)))
+	(xlib:open-font display "8x13"))
+  (flet ((font->text-style (font family)
+	   (let* ((tokens (disassemble-x-font-name (xlib:font-name font)))
+		  (italic (member (fifth tokens) '("i" "o") :test #'equalp))
+		  (bold (equalp (fourth tokens) "Bold"))
+		  (face (if italic
+			    (if bold '(:bold :italic) :italic)
+			    (if bold :bold :roman)))
+		  (point-size (or (xlib:font-property font :point_size)
+				  (parse-integer (ninth tokens))))
+		  (size (round point-size 10)))
+	     (when size
+	       (make-text-style family face size)))))
+    (dolist (family-stuff *clx-font-families*)
+      (let ((family (car family-stuff)))
+	(dolist (font-pattern (cdr family-stuff))
+	  (dolist (xfont (xlib:list-fonts display font-pattern))
+	    (let ((text-style (font->text-style xfont family)))
+	      (when text-style
+		;; prefer first font satisfying this text style, so
+		;; don't override if we've already defined one.
+		(unless (text-style-mapping-exists-p
+			  display-device *standard-character-set* text-style)
+		  (setf (text-style-mapping
+			  display-device *standard-character-set* text-style)
+			xfont))))))))))
+
+(defparameter *clx-logical-size-alist*
+	      '((:tiny       6)
+		(:very-small 8)
+		(:small	     10)
+		(:normal     12)
+		(:large	     14)
+		(:very-large 18)
+		(:huge	     24)))
+
+(defmethod standardize-text-style ((display-device clx-display-device) character-set style)
+  (standardize-text-style-1
+    display-device style character-set *clx-logical-size-alist*))
+
+
+(defclass clx-root-window
+	  (window-stream)
+    ((display)
+     (screen :reader clx-stream-screen)
+     (window :reader clx-stream-window)
+     (modifier-state :initform (make-modifier-state)
+		     :reader window-modifier-state)
+     ;; Used to create "color" stipples on monochrome screens
+     (stipple-gc))
+  (:default-initargs :input-buffer nil))
+
+(defun disassemble-display-spec (display &optional (default-display 0) (default-screen 0))
+  (declare (values host display-number nscreen))
+  (let ((host-n (position #\: display)))
+    (unless host-n
+      (return-from disassemble-display-spec 
+	(values display default-display default-screen)))
+    (let* ((host (subseq display 0 host-n))
+	   (screen-n (position #\. display :start (1+ host-n)))
+	   (display-number (if screen-n
+			       (parse-integer display :start (1+ host-n) :end screen-n
+					      :junk-allowed t)
+			       (parse-integer display :start (1+ host-n)
+					      :junk-allowed t)))
+	   (nscreen (if screen-n
+			(parse-integer display :start (1+ screen-n)
+				       :junk-allowed t)
+		        default-screen)))
+      (values host display-number nscreen))))
+
+(defmethod initialize-instance :before
+	   ((stream clx-root-window)
+	    &key (host #+Genera  (scl:send neti:*local-host* :name)
+		       #+Minima  (machine-instance)
+		       #+Allegro (or (system:getenv "DISPLAY") (short-site-name))
+		       #+Lucid   (or (lcl:environment-variable "DISPLAY")
+				     (machine-instance)))
+		 ((:display display-number) 0)
+		 ((:screen nscreen) 0))
+  (multiple-value-bind (host display-number nscreen)
+      (disassemble-display-spec host display-number nscreen)
+    (with-slots (display screen window display-device-type
+		 left top right bottom stipple-gc) stream
+      (setf display (xlib:open-display host :display display-number))
+      (fill-keycode->modifier-state display)
+      (fill-clim-modifier-key-index->x-state display)
+      (setf screen (nth nscreen (xlib:display-roots display)))
+      (setf window (xlib:screen-root screen))
+      (setf left 0)
+      (setf top 0)
+      (setf right (xlib:screen-width screen))
+      (setf bottom (xlib:screen-height screen))
+      (setf display-device-type
+	    (make-instance 'clx-display-device
+			   :display display :name (format nil "~A" display)))
+      (setf stipple-gc (xlib:create-gcontext
+			 :drawable window
+			 :foreground (xlib:screen-black-pixel screen)
+			 :background (xlib:screen-white-pixel screen))))
+    (setf (stream-pointers stream)
+	  (list (setf (stream-primary-pointer stream)
+		      (make-instance 'standard-pointer :root stream))))))
+
+;;; --- What should this really be returning?
+(defmethod host-window-margins ((stream clx-root-window))
+  (values 0 0 0 0))
+
+(defmethod window-stream-class-name ((stream clx-root-window))
+  'clx-window)
+
+(defmethod clx-stream-root ((stream clx-root-window))
+  stream)
+
+(defmethod close ((stream clx-root-window) &key abort)
+  (with-slots (window) stream
+    (when window
+      (xlib:close-display (xlib:window-display (shiftf window nil)) :abort abort))))
+
+;;; Convert an X keycode into a CLIM modifier state that can be IORed with
+;;; another modifier state.
+;;; We'll just use an array that's DISPLAY-MAX-KEYCODEs long and index each keycode
+;;; to a modifier state.
+(defun keycode->modifier-state (keycode display)
+  (let ((array (getf (xlib:display-plist display) 'keycode->modifier-state)))
+    (aref array keycode)))
+
+(defun fill-keycode->modifier-state (display)
+  (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
+      (xlib:modifier-mapping display)
+    (declare (ignore lock))
+    (declare (ignore mod4 mod5))
+    (let ((array (getf (xlib:display-plist display) 'keycode->modifier-state))
+	  (n-keycodes (1+ (xlib:display-max-keycode display))))
+      (cond ((or (null array)
+		 (< (length array)
+		    n-keycodes))
+	     (setq array (make-array n-keycodes :element-type '(unsigned-byte 8)
+						:initial-element 0))
+	     (setf (getf (xlib:display-plist display) 'keycode->modifier-state)
+		   array))
+	    (t (fill array 0)))
+      (flet ((x-name->clim-name (name)
+	       ;;; for now, 1 = meta, 2 = super and 3 = hyper.
+	       (ecase name
+		 ((:shift :control) name)
+		 (:mod1 :meta)
+		 (:mod2 :super)
+		 (:mod3 :hyper))))
+	(macrolet ((do-shift (x-name)
+		     `(let* ((clim-name (x-name->clim-name
+					  ,(intern (symbol-name x-name) *keyword-package*)))
+			     (modifier-state (if clim-name
+						 (make-modifier-state clim-name)
+						 0)))
+			(dolist (code ,x-name)
+			  (setf (aref array code) modifier-state)))))
+	  (do-shift shift)
+	  (do-shift control)
+	  (do-shift mod1)
+	  (do-shift mod2)
+	  (do-shift mod3))))))
+
+(defun fill-clim-modifier-key-index->x-state (display)
+  (multiple-value-bind (shift lock control mod-1 mod-2 mod-3 mod-4 mod-5)
+      (xlib:modifier-mapping display)
+    (declare (ignore shift lock control))
+    (let ((array (getf (xlib:display-plist display) 'clim-modifier-key-index->x-state))
+	  (length (length *modifier-keys*)))
+      (cond ((or (null array)
+		 (< (length array) length))
+	     (setq array (make-array length :element-type '(unsigned-byte 8)
+					    :initial-element 0))
+	     (setf (getf (xlib:display-plist display) 'clim-modifier-key-index->x-state)
+		   array))
+	    (t (fill array 0)))
+      ;; Maybe we can speed this up by special casing :SHIFT and :CONTROL
+      ;; somewhere else.
+      (setf (aref array (modifier-key-index :shift)) (xlib:make-state-mask :shift))
+      (setf (aref array (modifier-key-index :control)) (xlib:make-state-mask :control))
+
+      (flet ((test-keysym (keysym state-mask)
+	       (cond ((or (= keysym xlib::left-meta-keysym)
+			  (= keysym xlib::right-meta-keysym))
+		      (setf (aref array (modifier-key-index :meta)) state-mask))
+		     ((or (= keysym xlib::left-super-keysym)
+			  (= keysym xlib::right-super-keysym))
+		      (setf (aref array (modifier-key-index :super)) state-mask))
+		     ((or (= keysym xlib::left-hyper-keysym)
+			  (= keysym xlib::right-hyper-keysym))
+		      (setf (aref array (modifier-key-index :hyper)) state-mask)))))
+	(macrolet ((do-mod (mod)
+		     `(let ((codes ,mod))
+			(dolist (keycode codes)
+			  (let ((keysym (xlib:keycode->keysym display keycode 0)))
+			    (test-keysym
+			      keysym (xlib:make-state-mask
+				       ,(intern (symbol-name mod) *keyword-package*))))))))
+	  (do-mod mod-1)
+	  (do-mod mod-2)
+	  (do-mod mod-3)
+	  (do-mod mod-4)
+	  (do-mod mod-5))))))
+
+;;; Don't want to have to always go through the plist.
+;;; We can store this info in slots in the root window
+;;; and pass the arrays in as args.
+(defun clim-modifier-key-index->x-state (modifier-key-index display)
+  (let ((array (getf (xlib:display-plist display)
+		     'clim-modifier-key-index->x-state)))
+    (aref array modifier-key-index)))
+
+(defun state-mask->modifier-state (state-mask display)
+  (let ((mask 0))
+    (macrolet ((do-shift (clim-shift)
+		 `(let* ((bit (modifier-key-index ,clim-shift))
+			 (x-state (clim-modifier-key-index->x-state bit display)))
+		    (unless (zerop (boole boole-and x-state state-mask))
+		      (setf mask (dpb 1 (byte 1 bit) mask))))))
+      (do-shift :shift)
+      (do-shift :control)
+      (do-shift :meta)
+      (do-shift :super)
+      (do-shift :hyper))
+    mask))
+
+(defmethod stream-event-handler ((stream clx-root-window)
+				 &key (timeout nil)
+				      (input-wait-test nil)
+				      (original-stream stream))
+  ;; No hang-p argument, use :timeout 0.
+  (with-slots (display (root-window window) modifier-state) stream
+    (let ((pointer (stream-primary-pointer stream))
+	  ;; If we're inside an encapsulating stream, such as the input editor, and a window
+	  ;; resizing event is received, don't get confused while handling the event
+	  (*original-stream* nil)
+	  event)
+      ;; Return after processing each event or after the timeout.
+      (loop
+	;; The assumption is that the input-wait-test function can only change
+	;; its value when an event is received and processed.  The only
+	;; commonly-desired exception is a timeout, which we provide directly.
+	(when (and input-wait-test (funcall input-wait-test original-stream))
+	  (return :input-wait-test))
+	(when (not (or (xlib:event-listen display)
+		       (not (xlib::buffer-input-wait display timeout))))
+	  (return :timeout))
+	(setq event
+	      (xlib:event-case (display :discard-p t :timeout timeout)
+		((:motion-notify) (window)
+		 ;; We use the pointer-motion-hint strategy to avoid event overload.
+		 (let ((ws (getf (xlib:window-plist window) 'stream)))
+		   (when ws
+		     (multiple-value-bind (x y same-screen-p child mask root-x root-y root)
+			 (xlib:query-pointer root-window)
+		       (declare (ignore x y same-screen-p child mask root))
+		       (pointer-set-position* pointer root-x root-y)
+		       (setf (pointer-window pointer) ws)
+		       (setf (pointer-motion-pending ws pointer) T))))
+		 :mouse-motion)
+		((:button-press :button-release) (window event-key code x y state)
+		 (let ((ws (getf (xlib:window-plist window) 'stream))
+		       (old-state (pointer-button-state pointer))
+		       ;; X enumerates buttons, we need a mask...
+		       ;;--- Why isn't this just (ASH 1 CODE)?
+		       (new-state (dpb 1 (byte 1 (1- code)) 0)))
+		   (setf (pointer-button-state pointer)
+			 (ecase event-key
+			   (:button-press (logior new-state old-state))
+			   (:button-release (logandc1 new-state old-state))))
+		   (setf (pointer-window pointer) ws)
+		   ;; Resolve the selected-window issue.  We currently just put the
+		   ;; button-press "blip" in the clicked-on window's input buffer.
+		   (when ws
+		     ;; X and Y are presumed to be fixnums here
+		     (case event-key
+		       (:button-press
+			 (stream-note-pointer-button-press
+			   ws pointer new-state modifier-state x y))
+		       (:button-release
+			 (when *generate-button-release-events*
+			   (stream-note-pointer-button-release
+			     ws pointer new-state modifier-state x y))))))
+		 :input-buffer)
+		((:key-press :key-release) (window child code state event-key)
+		 (let ((ws (getf (xlib:window-plist (or child window)) 'stream)))
+		   (let ((ch (xlib:keycode->character display code state)))
+		     (cond ((characterp ch)
+			    (when (and ws (eql event-key :key-press))
+			      (queue-put (stream-input-buffer ws) ch))
+			    ;; Store the modifier state in a canonical place.
+			    (setf modifier-state (state-mask->modifier-state state display)))
+			   (t
+			    ;; Save away the current set of shifts.
+			    (let ((state-modifier-state 
+				    (state-mask->modifier-state state display))
+				  (shift-modifier-state
+				    (keycode->modifier-state code display)))
+			      (case event-key
+				(:key-press 
+				  (setf modifier-state
+					(boole boole-ior 
+					       state-modifier-state shift-modifier-state)))
+				(:key-release
+				  (setf modifier-state
+					(boole boole-andc2
+					       state-modifier-state shift-modifier-state)))))))))
+		 :input-buffer)
+		((:mapping-notify) (request start count)
+		 (xlib:mapping-notify display request start count)
+		 (when (eql request :modifier)
+		   (fill-keycode->modifier-state display)
+		   (fill-clim-modifier-key-index->x-state display))
+		 nil)
+		((:reparent-notify) (window parent x y)
+		 ;; We're interested in the relationship between our window and our
+		 ;; parent, so if that's what this event is about, take notice.  If
+		 ;; the event is about any other windows (e.g. intermediaries inserted
+		 ;; by the window manger), then it's talking about something beyond
+		 ;; our sphere of influence and we ignore it.
+		 (let ((ws (getf (xlib:window-plist window) 'stream))
+		       (ps (getf (xlib:window-plist parent) 'stream)))
+		   (when (and ws ps (eq (window-parent ws) ps))
+		     (with-slots (left top right bottom) ws
+		       (unless (and (= x left) (= y top))
+			 (window-note-size-or-position-change
+			   ws x y (+ x (- right left)) (+ y (- bottom top)))))))
+		 nil)
+		((:configure-notify) (window width height x y)
+		 (let ((ws (getf (xlib:window-plist window) 'stream)))
+		   ;; we have to discard the current event now because we'll likely
+		   ;; THROW out and we don't want to process it again.
+		   ;;--- This may be a problem in R4.4 CLX.  -- jdi
+		   (xlib:discard-current-event display)
+		   (when ws
+		     (window-note-size-or-position-change
+		       ws x y (+ x width) (+ y height))))
+		 nil)
+		((:graphics-exposure :exposure) (event-window width height x y count)
+		 ;; --- We're actually losing here because we have to forcibly
+		 ;; read out and process the graphicsExpose (or noExpose) event at
+		 ;; COPY-AREA time to ensure the consistency of the display.
+		 (let ((ws (getf (xlib:window-plist event-window) 'stream)))
+		   (when ws
+		     (with-slots (update-region) ws
+		       (multiple-value-bind (dsx dsy)
+			   ;; transform these coords into history coords, adding viewport, substracting margin
+			   (viewport-to-drawing-surface-coordinates ws x y)
+			 (push (make-bounding-rectangle dsx dsy (+ dsx width) (+ dsy height))
+			       update-region)))
+		     (when (zerop count)
+		       ;; if no expose events are to come, repaint the stream.
+		       (window-process-update-region ws))))
+		 nil)))
+	(if event
+	    (return event)
+	    (return :timeout))))))
+
+
+
+(defclass clx-window
+	  (window-stream)
+    ((screen :reader clx-stream-screen)
+     (window :reader clx-stream-window)
+     (root :reader clx-stream-root)
+     (color-p :initform nil)
+     ;; These two are used on monochrome screens
+     (white-pixel)
+     (black-pixel)
+     (copy-gc)
+     (foreground-gc)
+     (foreground-pixel)
+     (background-gc)
+     (background-pixel)
+     (flipping-gc)
+     (ink-table :initform (make-hash-table :test #'equal))
+     (clip-mask :initform :none)
+     (points-to-pixels)
+     (vertical-scroll-bar :initform nil :reader window-vertical-scroll-bar)
+     (horizontal-scroll-bar :initform nil :reader window-horizontal-scroll-bar)))
+
+(defparameter *clx-use-color* t)	;for debugging monochrome...
+(defmethod color-stream-p ((stream clx-window))
+  (and *clx-use-color*
+       (> (xlib:screen-root-depth (clx-stream-screen stream)) 2)))
+
+(defparameter *clx-scrollbar-border-width* 0)
+(defparameter *clx-scrollbar-width* 14)
+
+;;--- Scrollbars have an inner margin
+;;--- Perhaps we should use window-margin!
+(defvar *clx-scrollbar-inner-margin* 2)
+
+(defclass clx-scrollbar (clx-window) 
+    ((scroll-bar-values-1 :initform nil
+			  :accessor scroll-bar-values-1)
+     (scroll-bar-values-2 :initform nil
+			  :accessor scroll-bar-values-2)))
+
+(defclass clx-h-scrollbar (clx-scrollbar) ())
+(defclass clx-v-scrollbar (clx-scrollbar) ())
+
+(defmethod initialize-instance :before ((stream clx-window) &key parent)
+  (setf (slot-value stream 'display-device-type)
+	(slot-value parent 'display-device-type)))  
+
+(defmethod initialize-instance :after
+	   ((stream clx-window) &key left top right bottom
+				     (scroll-bars :both) save-under label (borders t))
+  (with-slots (window root screen copy-gc points-to-pixels
+	       color-p black-pixel white-pixel) stream
+    (let* ((parent (window-parent stream))
+	   (top-level (null (window-parent parent)))
+	   (border-width (if borders 2 0)))
+      (setf root (clx-stream-root parent))
+      (setf screen (clx-stream-screen parent))
+      (setf color-p (color-stream-p stream))
+      (setf white-pixel (xlib:screen-white-pixel screen))
+      (setf black-pixel (xlib:screen-black-pixel screen))
+      (setf points-to-pixels (* (sqrt (* (/ (xlib:screen-width screen)
+					    (xlib:screen-width-in-millimeters screen))
+					 (/ (xlib:screen-height screen)
+					    (xlib:screen-height-in-millimeters screen))))
+				(/ 25.4s0 72)))
+      (let ((rounded (round points-to-pixels)))
+	(when (< (abs (- points-to-pixels rounded)) .1s0)
+	  (setf points-to-pixels rounded)))
+      (cond (top-level
+	     (setf window (xlib:create-window
+			    :parent (clx-stream-window parent)
+			    :x left :y top :width (- right left) :height (- bottom top)
+			    ;; putting in bit-gravity reduces the number
+			    ;; of repaint events we have to process when we resize the window.
+			    :bit-gravity :north-west
+			    :save-under (if save-under :on nil)
+			    :event-mask '(:key-press :button-press 
+					  :key-release :button-release
+					  :pointer-motion :pointer-motion-hint
+					  :structure-notify
+					  :exposure)
+			    :border-width border-width))
+	     (setf (window-label stream) label)
+	     (xlib:set-wm-properties window :input :on :initial-state :normal))
+	    (t
+	     (setf window (xlib:create-window
+			    :parent (clx-stream-window parent)
+			    :x left :y top :width (- right left) :height (- bottom top)
+			    :event-mask '(:button-press :button-release
+					  :pointer-motion :pointer-motion-hint
+					  :exposure)
+			    ;; putting in bit-gravity reduces the number of repaint
+			    ;; events we have to process when we resize the window.
+			    :bit-gravity :north-west
+			    :border-width border-width))
+	     (setf (stream-input-buffer stream) (stream-input-buffer parent)))))
+    (setf copy-gc (xlib:create-gcontext :drawable window :exposures nil))
+    (clx-recompute-gcs stream)
+    (setf (getf (xlib:window-plist window) 'stream) stream))
+  (when scroll-bars
+    (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream
+      (let ((hp (member scroll-bars '(:both :horizontal)))
+	    (vp (member scroll-bars '(:both :vertical))))
+	(when hp
+	  (setf horizontal-scroll-bar 
+		(open-window-stream :parent stream 
+				    :window-class 'clx-h-scrollbar
+				    :borders nil
+				    :left (if vp *clx-scrollbar-width* 0) 
+				    :right (- right left)
+				    :top (- bottom top *clx-scrollbar-width*) 
+				    :bottom (- bottom  top)
+				    :scroll-bars nil))
+	  (setf (stream-recording-p horizontal-scroll-bar) nil)
+	  (window-expose horizontal-scroll-bar))
+	(when vp
+	  (setf vertical-scroll-bar
+		(open-window-stream :parent stream 
+				    :borders nil
+				    :window-class 'clx-v-scrollbar
+				    :left 0 :right *clx-scrollbar-width*
+				    :top 0 :bottom (- bottom top
+						      (if hp *clx-scrollbar-width* 0))
+				    :scroll-bars nil))
+	  (setf (stream-recording-p vertical-scroll-bar) nil)
+	  (window-expose vertical-scroll-bar))))))
+
+
+;;; Scroll bars
+
+(defmethod stream-replay ((stream clx-scrollbar) &optional region)
+  (declare (ignore region))
+  (draw-scrollbar stream t))
+
+(defmethod stream-note-pointer-button-press ((bar clx-v-scrollbar)
+					     pointer button modifier-state x y)
+  (declare (ignore pointer modifier-state x))
+  (let* ((stream (window-parent bar))
+	 (history (stream-output-history stream)))
+    (when history
+      (with-bounding-rectangle* (hleft htop hright hbottom) history
+	(declare (ignore hleft hright))
+	(with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream)
+	  (declare (ignore v-right))
+	  (window-set-viewport-position* stream 
+	    v-left
+	    (compute-scroll-to-value
+	      y (bounding-rectangle-width bar) (bounding-rectangle-height bar)
+	      htop hbottom v-top v-bottom button))
+	  (draw-scrollbar bar))))))
+
+(defmethod stream-note-pointer-button-press ((bar clx-h-scrollbar)
+					     pointer button modifier-state x y)
+  (declare (ignore pointer modifier-state y))
+  (let* ((stream (window-parent bar))
+	 (history (stream-output-history stream)))
+    (when history
+      (with-bounding-rectangle* (hleft htop hright hbottom) history
+	(declare (ignore htop hbottom))
+	(with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream)
+	  (declare (ignore v-bottom))
+	  (window-set-viewport-position* stream 
+	    (compute-scroll-to-value
+	      x (bounding-rectangle-height bar) (bounding-rectangle-width bar)
+	      hleft hright v-left v-right button)
+	    v-top)
+	  (draw-scrollbar bar))))))
+
+(defun compute-scroll-to-value (y bar-width bar-height
+				history-top history-bottom viewport-top viewport-bottom
+				button)
+  (cond 
+   ;; top
+   ((if (= button 1) (< y bar-width) (> y (- bar-height bar-width)))
+    (max history-top 
+	 (- viewport-top (truncate (* 0.9 (- viewport-bottom viewport-top))))))
+   ;; bottom
+   ((if (= button 1) (> y (- bar-height bar-width)) (< y bar-width))
+    (min (- history-bottom (- viewport-bottom viewport-top))
+	 (+ viewport-top (truncate (* 0.9 (- viewport-bottom viewport-top))))))
+   ;; elsewhere
+   (t
+    (let* ((ratio (float (/ (max 0 (- y bar-width)) bar-height))))
+      (min (- history-bottom (- viewport-bottom viewport-top))
+	   (truncate (+ history-top (* ratio (- history-bottom history-top)))))))))
+
+(defmacro with-scroll-bar-update (&body body)
+  `(unless (and (not force-p)
+		(eq slug-start (scroll-bar-values-1 stream))
+		(eq slug-length (scroll-bar-values-2 stream)))
+     (let ((old-slug-start (scroll-bar-values-1 stream))
+	   (old-slug-length (scroll-bar-values-2 stream)))
+       (setf  (scroll-bar-values-1 stream) slug-start
+	      (scroll-bar-values-2 stream) slug-length)
+       ,@body)))
+
+(defmethod draw-scrollbar ((stream clx-v-scrollbar) &optional force-p)
+  (with-bounding-rectangle* (left top right bottom) stream
+    (let ((width (- right left))
+	  (height (- bottom top))
+	  (win (window-parent stream)))
+      (with-bounding-rectangle* (extent-left extent-top extent-right extent-bottom)
+				(stream-output-history win)
+	(declare (ignore extent-left extent-right))
+	(with-bounding-rectangle* (viewport-left viewport-top viewport-right viewport-bottom)
+				  (window-viewport win)
+	  (declare (ignore viewport-left viewport-right))
+	  (multiple-value-bind (y1 y2 y3 y4 x1 x2 slug-start slug-length)
+	      (compute-scrollbar-values
+		height width *clx-scrollbar-inner-margin*
+		extent-top extent-bottom viewport-top viewport-bottom)
+	    (with-scroll-bar-update 
+	      (if (or force-p (null old-slug-start))
+		  (progn
+		    (draw-rectangle* stream
+		      0 0
+		      (bounding-rectangle-width stream) (bounding-rectangle-height stream)
+		      :ink +background-ink+)
+		    (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +black+)
+		    (draw-rectangle* stream x1 y3 x2 y4 :filled nil :ink +black+)
+		    (draw-rectangle* stream x1 y2 x2 y3 :filled nil :ink +black+))
+		  ;; Clear the slug
+		  (draw-rectangle* stream 
+		    (1+ x1) (min slug-start old-slug-start)
+		    (1- x2) (max (+ slug-start slug-length) (+ old-slug-start old-slug-length))
+		    :ink +background-ink+))
+	      ;; Redraw the slug
+	      (draw-rectangle* stream 
+		(1+ x1) slug-start (1- x2) (+ slug-start slug-length)
+		:ink +light-gray+))))))))
+
+(defmethod draw-scrollbar ((stream clx-h-scrollbar) &optional force-p)
+  (with-bounding-rectangle* (left top right bottom) stream
+    (let ((width (- right left))
+	  (height (- bottom top))
+	  (win (window-parent stream)))
+      (with-bounding-rectangle* (extent-left extent-top extent-right extent-bottom)
+				(stream-output-history win)
+	(declare (ignore extent-top extent-bottom))
+	(with-bounding-rectangle* (viewport-left viewport-top viewport-right viewport-bottom)
+				  (window-viewport win)
+	  (declare (ignore viewport-top viewport-bottom))
+	  (multiple-value-bind (x1 x2 x3 x4 y1 y2 slug-start slug-length)
+	      (compute-scrollbar-values
+		width height *clx-scrollbar-inner-margin*
+		extent-left extent-right viewport-left viewport-right)
+	    (with-scroll-bar-update 
+	      (if (or force-p (null old-slug-start))
+		  (progn
+		    (draw-rectangle* stream
+		      0 0
+		      (bounding-rectangle-width stream) (bounding-rectangle-height stream)
+		      :ink +background-ink+)
+		    (draw-rectangle* stream x1 y1 x2 y2 :filled nil :ink +black+)
+		    (draw-rectangle* stream x3 y1 x4 y2 :filled nil :ink +black+)
+		    (draw-rectangle* stream x2 y1 x3 y2 :filled nil :ink +black+))
+		;; Clear the slug
+		(draw-rectangle* stream 
+		  (min slug-start old-slug-start) (1+ y1)
+		  (max (+ slug-start slug-length) (+ old-slug-start old-slug-length)) (1- y2)
+		  :ink +background-ink+))
+	      ;; Redraw the slug
+	      (draw-rectangle* stream 
+		slug-start (1+ y1) (+ slug-start slug-length) (1- y2)
+		:ink +light-gray+))))))))
+ 
+(defun compute-scrollbar-values (long short margin
+				 extent-min extent-max viewport-min viewport-max)
+  (let* ((square (- short (* 2 margin)))
+	 (x1 margin)
+	 (x2 (+ x1 square))
+	 (x4 (- long margin))
+	 (x3 (- x4 square))
+	 (y1 margin)
+	 (y2 (- short margin))
+	 (esize (- (max viewport-max extent-max) (min viewport-min extent-min)))
+	 (vsize (- viewport-max viewport-min))
+	 (ratio (float (/ (max 1 vsize) (max vsize 1 esize))))
+	 (available-size (- x3 x2 2))
+	 (slug-length (* available-size ratio))
+	 (left (- available-size slug-length))
+	 (slug-start (+ x2 (* left (/ (- viewport-min extent-min)
+				      (max 1 (- esize vsize)))) 1)))
+      (values x1 x2 x3 x4 y1 y2 (floor slug-start) (floor slug-length))))
+
+;; Update the scroll-bars when their parent window changes
+(defun update-scrollbars (stream width height)
+  (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream
+    (when vertical-scroll-bar
+      (bounding-rectangle-set-size 
+	vertical-scroll-bar
+	(bounding-rectangle-width vertical-scroll-bar)
+	(if horizontal-scroll-bar (- height *clx-scrollbar-width*) height))
+      (draw-scrollbar vertical-scroll-bar t))
+    (when horizontal-scroll-bar
+      (bounding-rectangle-set-edges
+	horizontal-scroll-bar
+	(if vertical-scroll-bar *clx-scrollbar-width* 0)
+	(- height *clx-scrollbar-width*)
+	width
+	height)
+      (draw-scrollbar horizontal-scroll-bar))))
+
+(defmethod host-window-margins ((stream clx-window))
+  (values 0 0 0 0))
+
+(defmethod window-margins ((stream clx-window))
+  (let ((h (window-horizontal-scroll-bar stream))
+	(v (window-vertical-scroll-bar stream)))
+    (values (if v 
+		(+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-width v))
+	        0)
+	    0 
+	    0
+	    (if h
+		(+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-height h))
+	        0))))
+
+(defmethod window-note-size-or-position-change :after
+	   ((stream clx-window) new-left new-top new-right new-bottom)
+  (update-scrollbars stream (- new-right new-left) (- new-bottom new-top)))
+
+
+;;; This is called by the menu facility.  Under X, we simply set the transient-for
+;;; slot to tell the window manager not to interfere with this window.
+(defmethod initialize-menu :after ((stream clx-window) associated-window)
+  ;;--- May actually want to go :OVERRIDE-REDIRECT here. -- jdi
+  (when associated-window
+    (setf (xlib:transient-for (slot-value stream 'window))
+	  (slot-value associated-window 'window))))
+
+(defmethod (setf medium-foreground) :after (ink (stream clx-window))
+  (declare (ignore ink))
+  (clx-recompute-gcs stream))
+
+(defmethod (setf medium-background) :after (ink (stream clx-window))
+  (declare (ignore ink))
+  (clx-recompute-gcs stream))
+
+(defmethod window-modifier-state ((window clx-window))
+  (window-modifier-state (clx-stream-root window)))
+
+(defmethod clx-recompute-gcs ((stream clx-window))
+  (with-slots (foreground-gc foreground-pixel background-gc background-pixel
+	       window flipping-gc) stream
+    (unless (slot-boundp stream 'foreground-gc)
+      (setf foreground-gc (xlib:create-gcontext :drawable window)))
+    (unless (slot-boundp stream 'background-gc)
+      (setf background-gc (xlib:create-gcontext :drawable window)))
+    (unless (slot-boundp stream 'flipping-gc)
+      (setf flipping-gc (xlib:create-gcontext :drawable window :function boole-xor)))
+    (flet ((do-ground (ink gc)
+	     (setf (xlib:gcontext-fill-style gc) :solid)
+	     (setf (xlib:gcontext-foreground gc) (clx-decode-color stream ink))))
+      (setf foreground-pixel (do-ground (medium-foreground stream) foreground-gc))
+      (setf background-pixel (do-ground (medium-background stream) background-gc)))
+    (cond ((and (integerp foreground-pixel) (integerp background-pixel))
+	   (setf (xlib:gcontext-background foreground-gc) background-pixel)
+	   (setf (xlib:gcontext-fill-style flipping-gc) :solid)
+	   (setf (xlib:gcontext-foreground flipping-gc)
+		 (logxor foreground-pixel background-pixel)))
+	  (t (nyi)))
+    (setf (xlib:window-background window) background-pixel)))
+
+(defmethod window-beep ((stream clx-window))
+  (with-slots (window) stream
+    (let ((display (xlib:window-display window)))
+      (xlib:bell display)
+      (xlib:display-force-output display))))
+
+(defmethod notify-user-1 ((stream clx-window) frame format-string &rest format-args)
+  (declare (ignore frame) (dynamic-extent format-args))
+  (with-menu (window stream)
+    (with-end-of-line-action (window :allow)
+      (apply #'format window format-string format-args)
+      (fresh-line window)
+      (terpri window)
+      (with-text-size (window :smaller)
+	(write-string "Hit any key to remove this window" window))
+      (force-output window)
+      (size-menu-appropriately window)
+      (position-window-near-carefully window 10 10)	;whatever...
+      (window-expose window)
+      (read-gesture :stream window))))
+
+(defmethod implementation-pixels-per-point ((stream clx-window))
+  (with-slots (screen) stream
+    (/ (xlib:screen-width screen) (* (/ 72 25.4) (xlib:screen-width-in-millimeters screen)))))
+
+(defmethod (setf window-label) :after (label (stream clx-window))
+  (with-slots (window) stream
+    (multiple-value-bind (name icon-name)
+	(etypecase label
+	  (null (values "CLIM Window" "CLIM"))
+	  (string (values label label))
+	  (cons (values (first label) (first label))))
+      (setf (xlib:wm-name window) name)
+      (setf (xlib:wm-icon-name window) icon-name))
+    label))
+
+;;; Debugging aid
+(defparameter *clx-force-output* nil)
+
+(defun clx-force-output-if-necessary (stream &optional force-p)
+  (when (or force-p *clx-force-output*)
+    (xlib:display-force-output (xlib:window-display (slot-value stream 'window)))))
+
+(defmethod window-flush-update-region ((stream clx-window))
+  (with-slots (update-region) stream
+    (setf update-region nil)))
+
+(defmethod window-process-update-region ((stream clx-window))
+  (with-slots (update-region) stream
+    (when update-region
+      (dolist (rectangle update-region)
+	(with-bounding-rectangle* (left top right bottom) rectangle
+	  (adjust-for-viewport-and-margins stream left top right bottom)
+	  (window-clear-area stream left top right bottom))))))
+
+(defmethod window-shift-visible-region :after ((stream clx-window)
+					       old-left old-top old-right old-bottom
+					       new-left new-top new-right new-bottom)
+  (let ((rectangles (ltrb-difference new-left new-top new-right new-bottom
+				     old-left old-top old-right old-bottom)))
+    ;; Use the rectangle-list as the internal representation for a CLX-implementation region
+    (setf (slot-value stream 'update-region) rectangles)))
+
+(defmethod window-clear-area ((stream clx-window) left top right bottom)
+  (with-slots (window background-gc background-pixel) stream
+    (if (integerp background-pixel)
+	(xlib:clear-area window :x left :y top :width (- right left) :height (- bottom top))
+	(xlib:draw-rectangle window background-gc left top (- right left) (- bottom top) t)))
+  (clx-force-output-if-necessary stream))
+
+(defmethod copy-area ((stream clx-window)
+		      from-left from-top from-right from-bottom
+		      to-left to-top)
+  ;; coords in "host" coordinate system
+  (fix-points from-left from-top from-right from-bottom to-left to-top)
+  (with-slots (window copy-gc) stream
+    (let ((width (- from-right from-left))
+	  (height (- from-bottom from-top)))
+      (xlib:copy-area window copy-gc from-left from-top width height window to-left to-top)))
+  (clx-force-output-if-necessary stream))
+
+;;--- This should clip to real regions, not just to bounding-rectangles
+(defmethod invoke-with-clipping-region
+	   ((stream clx-window) continuation (region standard-bounding-rectangle))
+  (with-slots (window clip-mask) stream
+    (multiple-value-bind (x y) (window-viewport-position* stream)
+      (declare (type coordinate x y))
+      (multiple-value-bind (ml mt) (window-margins stream)
+	(declare (type coordinate ml mt))
+      	(with-bounding-rectangle* (left top right bottom) region
+	  (translate-fixnum-positions (- ml x) (- mt y)
+	    left top right bottom)
+	  ;;--- DEVICIZE-POINTS or something...
+	  (fix-points left top right bottom)
+	  ;;--- How not to cons? (this list and the rectangles)
+	  (let ((old-clip-mask clip-mask))
+	    (unwind-protect
+		(progn
+		  (setf clip-mask (list left top (- right left) (- bottom top)))
+		  (funcall continuation stream))
+	      (setf clip-mask old-clip-mask))))))))
+
+
+
+(defmethod stream-force-output ((stream clx-window))
+  (xlib:display-force-output (xlib:window-display (slot-value stream 'window))))
+
+(defmethod stream-finish-output ((stream clx-window))
+  (xlib:display-finish-output (xlib:window-display (slot-value stream 'window))))
+
+(defmethod stream-clear-output ((stream clx-window))
+  ;;;--- Not yet implemented.
+  )
+
+;;; Required
+(defmethod stream-set-input-focus ((stream clx-window))
+  ;;--- should there be a "default" method on input-protocol-mixin that
+  ;;--- does this??
+  )
+
+(defmethod stream-restore-input-focus ((stream clx-window) old-focus)
+  (declare (ignore old-focus))
+  ;;--- should there be a "default" method on input-protocol-mixin that
+  ;;--- does this??
+  )
+
+(defmethod window-erase-viewport ((stream clx-window))
+  (when (window-drawing-possible stream)
+    (with-slots (window) stream
+      (xlib:clear-area window))
+    (clx-force-output-if-necessary stream)))
+
+(defmethod window-visibility ((stream clx-window))
+  (with-slots (window) stream
+    (not (eq (xlib:window-map-state window) :unmapped))))
+
+(defmethod (setf window-visibility) (visibility (stream clx-window))
+  (with-slots (window screen) stream
+    ;; Have to wait for map to happen or subsequent output is lost
+    ;;--- How do we deal with state :UNVIEWABLE?  It means that window is
+    ;;--- mapped but some superior isn't.  Do we propagate visibility up?
+    ;;--- I think not.
+    (if visibility				; visibility is a boolean
+	;; This isn't quite right, because activating it means it's now buried??
+	;; Fine: that's what WINDOW-EXPOSE is for.  -- jdi
+	(xlib:map-window window)
+        ;;--- WITHDRAW-WINDOW isn't in R3 CLX.
+        (if (fboundp 'xlib::withdraw-window)
+	    (xlib::withdraw-window window screen)
+	    (xlib:unmap-window window))))
+  (clx-force-output-if-necessary stream))
+
+(defmethod wait-for-window-exposed ((window clx-window))
+  ;;--- This is expensive if the window manager doesn't map the window "soon"
+  (loop
+    (when (window-visibility window)
+      (return))
+    (process-yield)))
+
+(defmethod window-drawing-possible ((stream clx-window))
+  ;;--- This isn't really right for a window that has backing store.
+  (with-slots (window) stream
+    (not (eq (xlib:window-map-state window) :unmapped))))
+
+(defmethod window-stack-on-top ((stream clx-window))
+  (with-slots (window) stream
+    (setf (xlib:window-priority window) :above))
+  (clx-force-output-if-necessary stream))
+
+(defmethod window-stack-on-bottom ((stream clx-window))
+  (with-slots (window) stream
+    (setf (xlib:window-priority window) :below))
+  (clx-force-output-if-necessary stream))
+
+(defmethod close ((stream clx-window) &key abort)
+  (declare (ignore abort))
+  (with-slots (window) stream
+    (when window
+      (remf (xlib:window-plist window) 'stream)
+      (xlib:destroy-window (shiftf window nil))))
+  (clx-force-output-if-necessary stream))
+
+(defmethod bounding-rectangle-set-edges :after ((stream clx-window) left top right bottom)
+  (let ((width (- right left))
+	(height (- bottom top)))
+    (with-slots (window) stream
+      (xlib:with-state (window)
+	(setf (xlib:drawable-x window) left
+	      (xlib:drawable-y window) top
+	      (xlib:drawable-width window) width
+	      (xlib:drawable-height window) height)))
+    (update-scrollbars stream width height))
+  (clx-force-output-if-necessary stream t))
+
+(defmethod bounding-rectangle-set-position* :after ((stream clx-window) new-left new-top)
+  (with-slots (window) stream
+    (xlib:with-state (window)
+      (setf (xlib:drawable-x window) new-left)
+      (setf (xlib:drawable-y window) new-top)))
+  (clx-force-output-if-necessary stream t))
+
+(defmethod bounding-rectangle-set-size :after ((stream clx-window) width height)
+  (with-slots (window) stream
+    (xlib:with-state (window)
+      (setf (xlib:drawable-width window) width
+	    (xlib:drawable-height window) height)))
+  (update-scrollbars stream width height)
+  (clx-force-output-if-necessary stream t))
+
+(defmethod redisplay-decorations ((stream clx-window))
+  (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream
+    (when vertical-scroll-bar
+      (draw-scrollbar vertical-scroll-bar))
+    (when horizontal-scroll-bar
+      (draw-scrollbar horizontal-scroll-bar))))
+
+
+
+;;; Input side
+
+(defmethod set-pointer-window-and-location ((stream clx-window) pointer)
+  ;;--- What should this do?
+  )
+
+;;; The root stream-event-handler will do the appropriate keyword validation
+(defmethod stream-event-handler ((stream clx-window) &rest args &key &allow-other-keys)
+  (declare (dynamic-extent args))
+  (with-slots (root) stream
+    (apply #'stream-event-handler root :original-stream stream args)))
+
+(defmethod set-stream-pointer-in-screen-coordinates
+	   ((stream clx-window) pointer x y)
+  (declare (ignore pointer))			;Sigh.
+  (xlib:warp-pointer (xlib:drawable-root (clx-stream-window stream)) x y))
+
+(defmethod stream-pointer-input-rectangle*
+	   ((stream clx-window) pointer &key left top right bottom)
+  (declare (ignore left top right bottom))
+  (portable-pointer-input-rectangle* stream pointer))
+
+
+;;; Colors and their monochrome imposters
+
+(defun make-stipple-image (height width patterns)
+  (xlib:create-image :width width :height height
+		     :data (make-stipple-array height width patterns)
+		     :bits-per-pixel 1))
+
+(defvar *clx-luminance-stipples*
+	(mapcar #'(lambda (entry)
+		    (cons (first entry) (apply #'make-stipple-image (second entry))))
+		'((0.1 (8 16 (#b0111111111111111
+			      #b1111110111111111
+			      #b1111111111110111
+			      #b1101111111111111
+			      #b1111111101111111
+			      #b1111111111111101
+			      #b1111011111111111
+			      #b1111111111011111)))
+		  (0.2 (8 8 (#b01111111
+			     #b11101111
+			     #b11111101
+			     #b10111111
+			     #b11110111
+			     #b11111110
+			     #b11011111
+			     #b11111011)))
+		  (0.3 (4 4 (#b0111
+			     #b1101
+			     #b1011
+			     #b1110)))
+		  (0.4 (3 3 (#b011
+			     #b101
+			     #b110)))
+		  (0.6 (2 2 (#b01
+			     #b10)))
+		  (0.7 (3 3 (#b100
+			     #b010
+			     #b001)))
+		  (0.8 (4 4 (#b1000
+			     #b0010
+			     #b0100
+			     #b0001)))
+		  (0.9 (8 8 (#b10000000
+			     #b00010000
+			     #b00000010
+			     #b01000000
+			     #b00001000
+			     #b00000001
+			     #b00100000
+			     #b00000100)))
+		  (0.95 (8 16 (#b1000000000000000
+			       #b0000001000000000
+			       #b0000000000001000
+			       #b0010000000000000
+			       #b0000000010000000
+			       #b0000000000000010
+			       #b0000100000000000
+			       #b0000000000100000))))))
+		
+;; The xlib:image objects are created at load time to save run time & space.
+;; Here a '0' means white, '1' black.
+(defun clx-decode-luminance (luminance stipple-p)
+  (if (not stipple-p)
+      (if (< luminance 0.5) 1 0)
+      (if (< luminance 0.05)
+	  1
+	  (dolist (entry *clx-luminance-stipples* 0)
+	    (let ((l (car entry))
+		  (stipple (cdr entry)))
+	      (when (< luminance l)
+		(return-from clx-decode-luminance stipple)))))))
+
+;; This should only be called on a color screen.
+(defmethod clx-decode-color ((stream clx-window) (ink color))
+  (with-slots (screen color-p black-pixel) stream
+    (multiple-value-bind (red green blue) (color-rgb ink)
+      ;;--- Should probably use COLOR-P here.  Otherwise if *CLX-USE-COLOR* is NIL,
+      ;;--- colors can still be used for foreground, background, patterns.
+      (handler-case
+	  (xlib:alloc-color (xlib:screen-default-colormap screen)
+			    ;; Either someone has to ensure the the color values in a color
+			    ;; object are floats, or we have to here.
+			    (xlib:make-color :red (float red)
+					     :green (float green)
+					     :blue (float blue)))
+	;;--- Have to handle resource exhaustion better here.  -- jdi
+	(xlib:alloc-error (condition)
+	  (declare (ignore condition))
+	  (warn "No more colors available for ~S, using black instead." ink)
+	  black-pixel)))))
+
+(defmethod clx-decode-color ((stream clx-window) (ink (eql +foreground-ink+)))
+  (slot-value stream 'foreground-pixel))
+
+(defmethod clx-decode-color ((stream clx-window) (ink (eql +background-ink+)))
+  (slot-value stream 'background-pixel))
+
+;;--- We can surely do better than this
+(defmethod clx-decode-color ((stream clx-window) (ink standard-opacity))
+  (if (> (slot-value ink 'clim-utils::value) 0.5)
+      (slot-value stream 'foreground-pixel)
+      (slot-value stream 'background-pixel)))
+
+(defgeneric clx-decode-ink (ink stream))
+
+(defmethod clx-decode-ink ((ink (eql +foreground-ink+)) stream)
+  (slot-value stream 'foreground-gc))
+
+(defmethod clx-decode-ink ((ink (eql +background-ink+)) stream)
+  (slot-value stream 'background-gc))
+
+(defmethod clx-decode-ink ((ink (eql +flipping-ink+)) stream)
+  (slot-value stream 'flipping-gc))
+
+(defmethod clx-decode-ink ((ink flipping-ink) stream)
+  (multiple-value-bind (design1 design2)
+      (decode-flipping-ink ink)
+    (cond ((or (and (eq design1 +foreground-ink+) (eq design2 +background-ink+))
+	       (and (eq design1 +background-ink+) (eq design2 +foreground-ink+)))
+	   (slot-value stream 'flipping-gc))
+	  (t (nyi)))))
+
+(defmethod clx-decode-ink ((ink color) stream)
+  (with-slots (window ink-table foreground-gc color-p black-pixel white-pixel root) stream
+    (or (gethash ink ink-table)
+	(let ((gc (xlib:create-gcontext :drawable window)))
+	  (xlib:copy-gcontext foreground-gc gc)
+	  (cond (color-p
+		 (setf (xlib:gcontext-fill-style gc) :solid
+		       (xlib:gcontext-foreground gc) (clx-decode-color stream ink)))
+		(t
+		 (multiple-value-bind (r g b) (color-rgb ink)
+		   (let* ((luminance (color-luminosity r g b))
+			  (color (clx-decode-luminance luminance t)))
+		     (cond ((eql color 1)
+			    (setf (xlib:gcontext-fill-style gc) :solid
+				  (xlib:gcontext-foreground gc) black-pixel))
+			   ((eql color 0)
+			    (setf (xlib:gcontext-fill-style gc) :solid
+				  (xlib:gcontext-foreground gc) white-pixel))
+			   (t			; color is an image
+			    (setf (xlib:gcontext-fill-style gc) :tiled)
+			    (let ((pixmap (xlib:create-pixmap
+					    :drawable window
+					    :width (xlib:image-width color)
+					    :height (xlib:image-height color)
+					    ;;--- is this right?
+					    :depth (xlib:drawable-depth window))))
+			      (xlib:put-image pixmap
+					      (slot-value root 'stipple-gc)
+					      color :x 0 :y 0 :bitmap-p t)
+			      (setf (xlib:gcontext-tile gc) pixmap))))))))
+	  (setf (gethash ink ink-table) gc)))))
+
+(defmethod clx-decode-ink ((ink contrasting-ink) stream)
+  (clx-decode-ink (make-color-for-contrasting-ink ink) stream))
+
+(defmethod clx-decode-ink ((ink rectangular-tile) stream)
+  (with-slots (ink-table) stream
+    (or (gethash ink ink-table)
+	(multiple-value-bind (pattern width height)
+	    (decode-rectangular-tile ink)
+	  (clx-decode-pattern pattern stream width height t)))))
+
+(defmethod clx-decode-ink ((ink pattern) stream)
+  (clx-decode-pattern ink stream))
+
+(defmethod clx-decode-ink ((ink stencil) stream)
+  (declare (ignore stream))
+  (error "Stencils and opacities are not supported in this CLIM implementation"))
+
+(defmethod clx-decode-ink ((ink composite-in) stream)
+  (declare (ignore stream))
+  (error "Compositing is not supported in this CLIM implementation"))
+
+(defmethod clx-decode-ink ((ink composite-out) stream)
+  (declare (ignore stream))
+  (error "Compositing is not supported in this CLIM implementation"))
+
+(defmethod clx-decode-pattern ((ink design) stream &optional width height tiled-p)
+  (declare (ignore stream width height tiled-p))
+  (error "Arbitrary patterned designs are not supported in this CLIM implementation"))
+
+(defmethod clx-decode-pattern ((ink color) stream &optional width height tiled-p)
+  (declare (ignore stream width height tiled-p))
+  (error "A pattern must be a bounded design, ~S isn't" ink))
+
+(defmethod clx-decode-pattern ((ink pattern) stream &optional width height tiled-p)
+  (with-slots (foreground-gc foreground-pixel background-gc background-pixel
+	       window ink-table screen) stream
+    (or (gethash ink ink-table)
+	(multiple-value-bind (array designs)
+	    (decode-pattern ink)
+	  (let ((pattern-height (array-dimension array 0))
+		(pattern-width  (array-dimension array 1)))
+	    (declare (type xlib::array-index pattern-width pattern-height))
+	    (unless width
+	      (setq width pattern-width))
+	    (unless height
+	      (setq height pattern-height))
+	    #+++ignore
+	    (do ((i 0 (1+ i))
+		 (design))
+		((eq i (length designs)))
+	      (setq design (elt designs i))
+	      (when (and (not (colorp design))
+			 (not (eq design +foreground-ink+))
+			 (not (eq design +background-ink+)))
+		(error "Pattern designs other than colors are not supported yet.")))
+	     (let* ((depth (xlib:screen-root-depth screen))
+		    (image-data (make-array (list height width)
+					    :element-type `(unsigned-byte ,depth))))
+	       (do ((y 0 (1+ y)))
+		   ((eq y height))
+		 (declare (type xlib::array-index y))
+		 (do ((x 0 (1+ x)))
+		     ((eq x width))
+		   (declare (type xlib::array-index x))
+		   (setf (aref image-data y x)
+			 (if (or (>= y pattern-height) (>= x pattern-width))
+			     background-pixel
+			     (clx-decode-color stream (elt designs (aref array y x)))))))
+	       (let ((gc (xlib:create-gcontext :drawable window)))
+		(xlib:copy-gcontext foreground-gc gc)
+		(setf (xlib:gcontext-fill-style gc) :tiled)
+		(setf (xlib:gcontext-tile gc)
+		  (let ((image
+			 (xlib:create-image :depth depth
+					    :data image-data
+					    :width width :height height))
+			(pixmap
+			  (xlib:create-pixmap :width width :height height
+					      :drawable window
+					      :depth depth)))
+		    (xlib:put-image pixmap gc image :x 0 :y 0)
+		    pixmap))
+		(when (not tiled-p)
+		  ;;--- This doesn't work because the clip mask is set below.
+		  ;;--- Anyway, the clip-mask applies to the destination, so
+		  ;;--- the x and y must be set correctly.  -- jdi
+		  (setf (xlib:gcontext-clip-mask gc)
+			(list 0 0 pattern-width pattern-height)))
+		(setf (gethash ink ink-table) gc))))))))
+
+;;--- It would be nice if we did not have to cons up a new list each
+;;--- time.  Perhaps we could test if it had changed.  Perhaps the global
+;;--- value of the clipping rectangle could be determined in advance.
+(defun compute-gcontext-clip-mask (stream clip-mask)
+  (multiple-value-bind 
+      (left top right bottom)
+      (window-margins stream)
+    (let ((s-width (bounding-rectangle-width stream))
+	  (s-height (bounding-rectangle-height stream)))
+      (if (eq clip-mask :none)
+	  (list left top (- s-width right) (- s-height bottom))
+	(let* ((x (pop clip-mask))
+	       (y (pop clip-mask))
+	       (width  (pop clip-mask))
+	       (height (pop clip-mask)))
+	  (let ((new-clip-left (max left x))
+		(new-clip-top (max top y)))
+	    (list new-clip-left new-clip-top
+		  (- (min (+ left (- s-width right))	;clip-right
+			  (+ x width))			;another clip-right
+		     new-clip-left)
+		   (- (min (+ top (- s-height bottom))	;clip-bottom
+			   (+ y height))		;another clip-bottom
+		      new-clip-top))))))))
+
+;; This is necessary because the GC used for drawing doesn't depend only
+;; on the ink used, unfortunately.  We have to adjust the clip-mask for
+;; the stream it's used on.
+(defmethod clx-decode-ink :around (ink stream)
+  (setq ink (call-next-method))
+  (with-slots (clip-mask) stream
+    (setf (xlib:gcontext-clip-mask ink)
+      #---ignore clip-mask
+      #+++ignore (compute-gcontext-clip-mask stream clip-mask)))
+  ink)
+    
+;; This only needs to be called for shapes, not points or characters.
+;; Basically, we want to do things in here that operate on cached inks
+;; (graphics contexts).
+(defmethod clx-adjust-ink (ink stream line-style)
+  (with-slots (points-to-pixels) stream
+    (when (eq (xlib:gcontext-fill-style ink) :tiled)
+      (with-bounding-rectangle* (left top right bottom) (window-viewport stream)
+	(declare (ignore right bottom))
+	(let ((size (xlib:drawable-width (xlib:gcontext-tile ink))))
+	  (setf (xlib:gcontext-ts-x ink) (mod left size)	;--- 16 is a magic
+		(xlib:gcontext-ts-y ink) (mod top size)))))
+    (when line-style
+      (let ((thickness (line-style-thickness line-style)))
+	(ecase (line-style-unit line-style)
+	  ((:normal :point)
+	   (setf thickness (* thickness points-to-pixels))))
+	(setf (xlib:gcontext-line-width ink) 
+	  (if (< thickness 2) 0 (round thickness)))
+	(let ((dashes (line-style-dashes line-style)))
+	  (cond (dashes
+		 (setf (xlib:gcontext-line-style ink) :dash)
+		 (setf (xlib:gcontext-dashes ink) 
+		       #-Allegro (cond ((eq dashes t) #(4 4))
+				       ((listp dashes) (coerce dashes 'vector))
+				       (t dashes))
+		       #+Allegro (cond ((eq dashes t) '(4 4))
+				       ((vectorp dashes) (coerce dashes 'list))
+				       (t dashes))))
+		(t
+		 (setf (xlib:gcontext-line-style ink) :solid))))
+	(setf (xlib:gcontext-cap-style ink)
+	      (ecase (line-style-cap-shape line-style)
+		(:butt :butt)
+		(:square :projecting)
+		(:round :round)
+		(:no-end-point :not-last)))
+	(setf (xlib:gcontext-join-style ink)
+	      (ecase (line-style-joint-shape line-style)
+		((:miter :none) :miter)
+		(:bevel :bevel)
+		(:round :round)))))
+    ink))
+
+
+;;; Drawing functions
+
+(defmethod draw-point-internal ((stream clx-window) x-offset y-offset x y ink line-style)
+  (fix-points x y)
+  (translate-positions x-offset y-offset x y)
+  (with-slots (window points-to-pixels) stream
+    (let ((thickness (line-style-thickness line-style))
+	  (gc (clx-decode-ink ink stream)))
+      (ecase (line-style-unit line-style)
+	((:normal :point)
+	 (setf thickness (* thickness points-to-pixels))))
+      (if (< thickness 2)
+	  (xlib:draw-point window gc x y)
+	  (let ((thickness (round thickness)))
+	    (xlib:draw-arc window gc x y thickness thickness 0 2pi t)))))
+  (clx-force-output-if-necessary stream))
+
+(defmethod draw-line-internal ((stream clx-window) x-offset y-offset
+			       start-x start-y end-x end-y ink line-style)
+  (fix-points start-x end-x start-y end-y)
+  (translate-positions x-offset y-offset start-x start-y end-x end-y)
+  (with-slots (window) stream
+    (xlib:draw-line window
+		    (clx-adjust-ink (clx-decode-ink ink stream) stream line-style)
+		    start-x start-y end-x end-y))
+  (clx-force-output-if-necessary stream))
+
+(defmethod draw-rectangle-internal ((stream clx-window) x-offset y-offset
+				    left top right bottom ink line-style)
+  (fix-points left top right bottom)
+  (translate-positions x-offset y-offset left top right bottom)
+  (with-slots (window) stream
+    (xlib:draw-rectangle window 
+			 (clx-adjust-ink (clx-decode-ink ink stream) stream line-style)
+			 left top (- right left) (- bottom top) (null line-style)))
+  (clx-force-output-if-necessary stream))
+
+(defmethod draw-polygon-internal ((stream clx-window) x-offset y-offset
+				  list-of-x-and-ys closed ink line-style)
+  (setq list-of-x-and-ys
+	(mapcar #'round (translate-point-sequence x-offset y-offset list-of-x-and-ys)))
+  (let ((points list-of-x-and-ys))
+    (when (and closed line-style)		;kludge
+      (setq points (append points `(,(first points) ,(second points)))))
+    (with-slots (window) stream
+      (xlib:draw-lines window 
+		       (clx-adjust-ink (clx-decode-ink ink stream) stream line-style)
+		       points :fill-p (null line-style))))
+  (clx-force-output-if-necessary stream))
+
+(defmethod draw-ellipse-internal ((stream clx-window) x-offset y-offset
+				  center-x center-y
+				  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+				  start-angle end-angle ink line-style)
+  (fix-points center-x center-y)
+  (translate-positions x-offset y-offset center-x center-y)
+  (when (null start-angle)
+    (setq start-angle 0.0
+	  end-angle 2pi))
+  ;; Awaiting implementation of real graphics model
+  ;; CLX takes a start angle and a delta-angle relative to it, but measures angles
+  ;; such that pi/2 points straight up even though Y increases downwards.  Flip that.
+  (setq start-angle (- 2pi start-angle)
+	end-angle (- 2pi end-angle))
+  ;; We also have to flip the sense of clockwise.
+  (rotatef start-angle end-angle)
+  ;; The caller has already coerced start- and end-angle to be in the range 0 <= angle < 2pi
+  (when (< end-angle start-angle)
+    (setq end-angle (+ end-angle 2pi)))
+  (setf radius-1-dx (round radius-1-dx))
+  (setf radius-1-dy (round radius-1-dy))
+  (setf radius-2-dx (round radius-2-dx))
+  (setf radius-2-dy (round radius-2-dy))
+  (multiple-value-bind (x-radius y-radius)
+      (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+	     (values (abs radius-2-dx) (abs radius-1-dy)))
+	    ((and (= radius-2-dx 0) (= radius-1-dy 0))
+	     (values (abs radius-1-dx) (abs radius-2-dy)))
+	    (t
+	     (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy)))
+		   (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy))))
+	       (if (= s-1 s-2)
+		   (let ((r (truncate (sqrt s-1))))
+		     (values r r))
+		   ;; Degrade to drawing a rectilinear ellipse
+		   (values (truncate (sqrt s-1)) 
+			   (truncate (sqrt s-2)))))))
+    (with-slots (window) stream
+      (let ((angle-size (- end-angle start-angle)))
+	(xlib:draw-arc window 
+		       (clx-adjust-ink (clx-decode-ink ink stream) stream line-style)
+		       (- center-x x-radius) (- center-y y-radius)
+		       (* x-radius 2) (* y-radius 2)
+		       ;; CLX measures the second angle relative to the first
+		       start-angle angle-size (null line-style)))))
+  (clx-force-output-if-necessary stream))
+
+
+;;; Character-drawing methods for CLX implementation
+
+;; TEXT-STYLE  must be a fully merged text style
+(defmethod stream-glyph-for-character
+	   ((stream clx-window) character text-style &optional our-font)
+  (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y))
+  (with-slots (window display-device-type) stream
+    (multiple-value-bind (character-set index)
+	(char-character-set-and-index character)
+      (when (eql character-set *standard-character-set*)
+	(setf index (xlib:char->card8 character)))	;A little gross, but right, I think.
+      (let* ((x-font (or our-font
+			 (text-style-mapping
+			   display-device-type character-set text-style window)))
+	     (escapement-x (or (xlib:char-width x-font index)
+			       ;;--- Sometimes the above can return NIL
+			       (xlib:char-width x-font (xlib:char->card8 #\A))))
+	     (escapement-y 0)
+	     (origin-x 0)
+	     (origin-y (xlib:font-ascent x-font))
+	     (bb-x escapement-x)
+	     (bb-y (+ origin-y (xlib:font-descent x-font))))
+	(values index x-font escapement-x escapement-y origin-x origin-y bb-x bb-y)))))
+
+(defmethod stream-write-char-1 ((stream clx-window) index x-font ink x y)
+  (with-slots (window) stream
+    (let ((gc (clx-decode-ink ink stream)))
+      (setf (xlib:gcontext-font gc) x-font)
+      ;; Move line down so that the top of the character (not the baseline) is at Y.
+      (xlib:draw-glyph window gc (round x) (+ (round y) (xlib:font-ascent x-font)) index)))
+  (clx-force-output-if-necessary stream))
+
+(defmethod stream-write-string-1 ((stream clx-window)
+				  glyph-buffer start end x-font ink x y)
+  ;;--- For some reason we can get into a state when start = end meaning
+  ;;--- there is nothing to draw and font is NIL so lets skip doing
+  ;;--- anything - cer
+  (when (> end start)
+    (with-slots (window) stream
+      (let ((size (if (find-if #'(lambda (x) (> x 255.)) glyph-buffer :start start :end end)
+		      16 :default))
+	    (gc (clx-decode-ink ink stream)))
+	(setf (xlib:gcontext-font gc) x-font)
+	;; Move line down so that the top of the characters (not the baseline) is at Y.
+	(xlib:draw-glyphs window gc (round x) (+ (round y) (xlib:font-ascent x-font))
+			  glyph-buffer
+			  :start start :end end :translate #'noop-translate-function
+			  :size size)))
+    (clx-force-output-if-necessary stream)))
+
+;;; Too bad we have to copy the glyphs again, but that's life...
+(defun noop-translate-function (src src-start src-end font dst dst-start)
+  (declare (values ending-index horizontal-motion width))
+  (declare (ignore font))
+  (replace dst src :start1 dst-start :start2 src-start :end2 src-end)
+  (values src-end nil nil))
+
+(defmethod clx-get-default-font ((stream clx-window))
+  (with-slots (window display-device-type) stream
+    (text-style-mapping
+      display-device-type *standard-character-set* (stream-merged-text-style stream) window)))
+
+(defmethod draw-string-internal ((stream clx-window) x-offset y-offset
+				 string x y start end align-x align-y text-style ink)
+  (fix-points x y)
+  (translate-positions x-offset y-offset x y)
+  (with-slots (window display-device-type) stream
+    (let* ((font (if text-style
+		     (text-style-mapping
+		       display-device-type *standard-character-set* text-style window)
+		     (clx-get-default-font stream)))
+	   (ascent (xlib:font-ascent font))
+	   (descent (xlib:font-descent font))
+	   (height (+ ascent descent))
+	   (gc (clx-decode-ink ink stream)))
+      (incf x (compute-text-x-adjustment 
+		align-x stream string text-style start end))
+      (incf y (compute-text-y-adjustment
+		align-y descent ascent height))
+      (setf (xlib:gcontext-font gc) font)
+      (xlib:draw-glyphs window gc x y string :start start :end end)))
+  (clx-force-output-if-necessary stream))
+
+(defmethod draw-character-internal ((stream clx-window) x-offset y-offset
+				    character x y align-x align-y text-style ink)
+  (fix-points x y)
+  (translate-positions x-offset y-offset x y)
+  (with-slots (window display-device-type) stream
+    (let* ((font (if text-style
+		     (text-style-mapping
+		       display-device-type *standard-character-set* text-style window)
+		     (clx-get-default-font stream)))
+	   (ascent (xlib:font-ascent font))
+	   (descent (xlib:font-descent font))
+	   (height (+ ascent descent))
+	   (gc (clx-decode-ink ink stream)))
+      (incf x (compute-text-x-adjustment 
+		align-x stream character text-style))
+      (incf y (compute-text-y-adjustment
+		align-y descent ascent height))
+      (setf (xlib:gcontext-font gc) font)
+      (xlib:draw-glyph window gc x y character)))
+  (clx-force-output-if-necessary stream))
+
+
+(defmethod text-style-height ((text-style standard-text-style) (stream clx-window))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (let* ((ascent (xlib:font-ascent font))
+	     (descent (xlib:font-descent font))
+	     (height (+ ascent descent)))
+	height))))
+
+(defmethod text-style-width ((text-style standard-text-style) (stream clx-window))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      ;; Disgusting, but probably OK
+      (xlib:char-width font (xlib:char->card8 #\A)))))
+
+(defmethod text-style-ascent ((text-style standard-text-style) (stream clx-window))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (xlib:font-ascent font))))
+
+(defmethod text-style-descent ((text-style standard-text-style) (stream clx-window))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (xlib:font-descent font))))
+
+(defmethod text-style-fixed-width-p ((text-style standard-text-style) (stream clx-window))
+  (with-slots (window display-device-type) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      ;; Really disgusting, but probably OK
+      (= (xlib:char-width font (xlib:char->card8 #\.))
+	 (xlib:char-width font (xlib:char->card8 #\M))))))
+
+(defmethod text-size ((stream clx-window) string
+		      &key (text-style (stream-merged-text-style stream)) (start 0) end)
+  (when (characterp string)
+    (setq string (string string)
+	  start 0
+	  end nil))
+  (multiple-value-bind (last-x largest-x last-y total-height baseline)
+      (stream-string-output-size stream string :text-style text-style :start start :end end)
+    (values largest-x total-height last-x last-y baseline)))
+
+
+
+(defun create-clx-root-window (&rest args)
+  (declare (dynamic-extent args))
+  (apply #'make-instance 'clx-root-window args))
+
+(define-implementation :clx 'create-clx-root-window)
+
diff --git a/pre-silica/default-application.lisp b/pre-silica/default-application.lisp
new file mode 100644
index 00000000..b4dede10
--- /dev/null
+++ b/pre-silica/default-application.lisp
@@ -0,0 +1,204 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: default-application.lisp,v 1.4 91/03/26 12:47:50 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+(define-application-frame default-application () ()
+  (:command-definer nil))
+
+;;; These are DEFVARs in clim-defs.lisp
+(setq *default-application* (make-application-frame 'default-application))
+
+;;--- Is it really necessary for this to have a global value?
+(setq *application-frame* *default-application*)
+
+(defmethod frame-input-context-button-press-handler
+	   ((frame standard-application-frame) stream button-press-event)
+  (declare (ignore stream))
+  (let* ((window (event-window button-press-event))
+	 (x (pointer-event-x button-press-event))
+	 (y (pointer-event-y button-press-event))
+	 (highlighted-presentation (highlighted-presentation window nil))
+	 (input-context *input-context*))
+    (when highlighted-presentation
+      ;; Unhighlight on the way out.
+      ;; But only unhighlight the window that the click is from. 
+      (unhighlight-highlighted-presentation window nil))
+    (throw-highlighted-presentation 
+      (or (and (output-recording-stream-p window)
+	       (frame-find-innermost-applicable-presentation
+		 frame input-context window x y))
+	  *null-presentation*)
+      input-context
+      button-press-event)))
+
+;;; The contract of this is to find an "appropriate" presentation; i.e., one
+;;; satisfying the input context specified by TYPE.  Everything that looks for a
+;;; presentation goes through this so that applications can specialize it.
+(defmethod frame-find-innermost-applicable-presentation
+	   ((frame standard-application-frame) input-context stream x y)
+  (find-innermost-applicable-presentation input-context stream x y))
+
+;;; The contract of this is to replay the contents of STREAM within the region.
+(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
+  (stream-replay stream region)
+  (force-output stream))
+
+
+(defvar *pointer-documentation-interval*
+	(max (floor (* 1/10 internal-time-units-per-second)) 1))
+(defvar *last-pointer-documentation-time* 0)
+
+#+Genera
+(defvar *pointer-documentation-buffer*
+	(make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t))
+
+;;; Produce pointer documentation
+(defmethod frame-document-highlighted-presentation
+	   ((frame standard-application-frame) presentation input-context window x y stream)
+  (let (#+Genera (documentation-window (mouse-documentation-window window)))
+    ;; The documentation should never say anything if we're not over a presentation
+    (when (null presentation) 
+      #+Genera (if documentation-window
+		   (scl:send documentation-window :clear-window)
+		   (window-clear stream))
+      #-Genera (window-clear stream))
+    ;; Cheap test to not do this work too often
+    (let ((old-modifier-state *last-pointer-documentation-modifier-state*)
+	  (modifier-state (window-modifier-state window))
+	  (last-time *last-pointer-documentation-time*)
+	  (time (get-internal-real-time)))
+      (setq *last-pointer-documentation-modifier-state* modifier-state)
+      (when (and (< time (+ last-time *pointer-documentation-interval*))
+		 (= modifier-state old-modifier-state))
+	(return-from frame-document-highlighted-presentation nil))
+      (setq *last-pointer-documentation-time* time))
+    (when presentation
+      #+Genera
+      (when documentation-window
+	(setf (fill-pointer *pointer-documentation-buffer*) 0)
+	(with-output-to-string (stream *pointer-documentation-buffer*)
+	  (scl:send documentation-window :clear-window)
+	  (when (null (frame-document-highlighted-presentation-1
+			frame presentation input-context window x y stream))
+	    (setq *last-pointer-documentation-time* 0))
+	  (scl:send documentation-window :string-out *pointer-documentation-buffer*))
+	(return-from frame-document-highlighted-presentation nil))
+      (with-output-recording-options (stream :record nil)
+	(with-end-of-line-action (stream :allow)
+	  (with-end-of-page-action (stream :allow)
+	    (window-clear stream)
+	    (when (null (frame-document-highlighted-presentation-1
+			  frame presentation input-context window x y stream))
+	      (setq *last-pointer-documentation-time* 0))
+	    (force-output stream)))))))
+
+(defun frame-document-highlighted-presentation-1
+       (frame presentation input-context window x y stream)
+  (let ((modifier-state (window-modifier-state window)))
+    (declare (fixnum modifier-state))
+    (multiple-value-bind (left left-context middle middle-context right right-context)
+	(find-applicable-translators-for-documentation presentation input-context
+						       frame window x y modifier-state)
+      (let* ((*print-length* 3)
+	     (*print-level* 2)
+	     (*print-circle* nil)
+	     (*print-array* nil)
+	     (*print-readably* nil)
+	     (*print-pretty* nil))
+	(flet ((document-translator (translator context-type button-name separator)
+		 ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
+		 (let ((bit #o20)
+		       (shift-name '("h-" "s-" "m-" "c-" "sh-")))
+		   (declare (fixnum bit))
+		   (dotimes (i 5)
+		     #-(or Allegro Minima) (declare (ignore i))
+		     (unless (zerop (logand bit modifier-state))
+		       (write-string (car shift-name) stream))
+		     (pop shift-name)
+		     (setq bit (the fixnum (ash bit -1)))))
+		 (write-string button-name stream)
+		 (document-presentation-translator translator presentation context-type
+						   frame nil window x y
+						   :stream stream
+						   :documentation-type :pointer)
+		 (write-string separator stream)))
+	  (declare (dynamic-extent #'document-translator))
+	  (when left
+	    (let ((button-name (cond ((and (eql left middle)
+					   (eql left right))
+				      (setq middle nil
+					    right nil)
+				      "L,M,R: ")
+				     ((eql left middle) 
+				      (setq middle nil)
+				      "L,M: ")
+				     (t "L: "))))
+	      (document-translator left left-context button-name
+				   (if (or middle right) "; " "."))))
+	  (when middle
+	    (let ((button-name (cond ((eql middle right)
+				      (setq right nil)
+				      "M,R: ")
+				     (t "M: "))))
+	      (document-translator middle middle-context button-name
+				   (if right "; " "."))))
+	  (when right
+	    (document-translator right right-context "R: " "."))
+	  ;; Return non-NIL if any pointer documentation was produced
+	  (or left middle right))))))
+
+;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
+(defun find-applicable-translators-for-documentation
+       (presentation input-context frame window x y modifier-state)
+  ;; Assume a maximum of three pointer buttons
+  (let ((left nil)   (left-context nil)
+	(middle nil) (middle-context nil)
+	(right nil)  (right-context nil))
+    (macrolet ((match (translator context-type button)
+		 (let ((button-translator (intern (symbol-name button)))
+		       (button-context (fintern "~A-~A" (symbol-name button) 'context)))
+		   `(when (and (or (null ,button-translator)
+				   (> (presentation-translator-priority ,translator)
+				      (presentation-translator-priority ,button-translator)))
+			       (button-and-modifier-state-matches-gesture-name
+				 (button-index ,button) modifier-state
+				 (presentation-translator-gesture-name ,translator)))
+		      (setq ,button-translator ,translator
+			    ,button-context ,context-type)))))
+      (do ((presentation presentation
+			 (parent-presentation-with-shared-box presentation window)))
+	  ((null presentation))
+	(let ((from-type (presentation-type presentation)))
+	  (dolist (context input-context)
+	    (let ((context-type (pop context)))	;input-context-type = first
+	      (let ((translators (find-presentation-translators 
+				   from-type context-type (frame-command-table frame))))
+		(when translators
+		  (dolist (translator translators)
+		    (when (test-presentation-translator translator
+							presentation context-type
+							frame window x y
+							:modifier-state modifier-state)
+		      (match translator context-type :left)
+		      (match translator context-type :middle)
+		      (match translator context-type :right)))))
+	      (when (and (or left middle right)
+			 *presentation-menu-translator*
+			 (test-presentation-translator *presentation-menu-translator*
+						       presentation context-type
+						       frame window x y
+						       :modifier-state modifier-state))
+		(match *presentation-menu-translator* context-type :left)
+		(match *presentation-menu-translator* context-type :middle)
+		(match *presentation-menu-translator* context-type :right)))))))
+    (values left   left-context
+	    middle middle-context
+	    right  right-context)))
+
+#+Genera
+(defmethod mouse-documentation-window ((window window-stream)) nil)
diff --git a/pre-silica/define-application.lisp b/pre-silica/define-application.lisp
new file mode 100644
index 00000000..9780aeb8
--- /dev/null
+++ b/pre-silica/define-application.lisp
@@ -0,0 +1,1287 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: define-application.lisp,v 1.4 91/03/26 12:47:50 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+(defvar *window-stream-to-frame-table* (make-hash-table))
+
+(defun-inline window-stream-to-frame (window-stream)
+  (gethash window-stream *window-stream-to-frame-table*))
+
+(defun create-application-frame (frame &rest args)
+  (declare (dynamic-extent args))
+  (let* ((window-stream
+	   (apply #'open-window-stream args)))
+    (setf (gethash window-stream *window-stream-to-frame-table*) frame)
+    window-stream))
+
+(define-protocol-class application-frame ())
+
+(defclass standard-application-frame
+	  (application-frame)
+     ((name :initarg :name :accessor frame-name)
+      (pretty-name :initarg :pretty-name :accessor frame-pretty-name)
+      (current-layout :initarg :current-layout
+		      :reader frame-current-layout)
+      (top-level-sheet :initarg :top-level-sheet :initform nil
+		       :accessor frame-top-level-sheet)
+      (panes :initarg panes :initform nil :accessor frame-panes)
+      ;; This is a copy of what's in the frame-descriptor, so that local
+      ;; state can be cached here.  It's length and order matches PANES.
+      (pane-descriptions :initarg :pane-descriptions :initform nil)
+      ;; The real panes in the current layout
+      (current-panes :initform nil :accessor frame-current-panes)
+      (initialized-panes :initform nil)
+      (command-table :initarg :command-table :initform nil
+		     :accessor frame-command-table)
+      (disabled-commands :initarg :disabled-commands :initform nil)
+      ;; A slot for per-application histories
+      (histories :initform nil)))
+
+#+CLIM-1-compatibility
+(define-compatibility-function (frame-top-level-window frame-top-level-sheet)
+			       (frame)
+  (frame-top-level-sheet frame))
+
+(defmethod (setf frame-pretty-name) :after (name (frame standard-application-frame))
+  (with-slots (top-level-sheet) frame
+    (when #+Genera (not (typep top-level-sheet 'sheet-implementation-mixin))
+	  #-Genera t
+      (setf (window-label top-level-sheet) name))))
+
+(eval-when (eval compile load)
+
+(defstruct (frame-descriptor (:print-function print-frame-descriptor))
+  name
+  state-variables
+  state-variable-names
+  pane-descriptions
+  layout
+  top-level
+  command-table
+  disabled-commands)
+
+(defun print-frame-descriptor (descriptor stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (descriptor stream :type t :identity t)
+    (write (frame-descriptor-name descriptor) :stream stream :escape nil)))
+
+;; Where is the LIST* DEFSTRUCT type when we need it?
+(defun-inline pane-descriptor-name    (pane-descriptor) (first pane-descriptor))
+(defun-inline pane-descriptor-type    (pane-descriptor) (second pane-descriptor))
+(defun-inline pane-descriptor-options (pane-descriptor) (cddr pane-descriptor))
+(defsetf pane-descriptor-options      (pane-descriptor) (new-value)
+  `(setf (cddr ,pane-descriptor) ,new-value))
+
+(defvar *frame-descriptors* nil)
+
+(defun collect-state-variable-names (state-variables)
+  (let ((names nil))
+    (dolist (var state-variables)
+      (cond ((atom var) (push var names))
+	    (t (push (first var) names))))
+    (nreverse names)))
+
+(defun construct-default-layout (pane-descriptions)
+  (let ((the-layout nil))
+    (dolist (entry pane-descriptions)
+      (let ((window-name (pane-descriptor-name entry))
+	    (default-size (getf (pane-descriptor-options entry) :default-size ':rest)))
+	(push `(,window-name ,default-size) the-layout)))
+    `((main (:column :rest ,@(nreverse the-layout))))))
+
+(defun define-application-frame-1 (name state-variables pane-descriptions
+				   &key top-level layout
+					command-table disabled-commands)
+  (unless layout
+    (setq layout (construct-default-layout pane-descriptions)))
+  (let* ((state-variable-names (collect-state-variable-names state-variables))
+	 (command-table-name (first command-table))
+	 (frame-descriptor
+	   (make-frame-descriptor :name name
+				  :state-variables state-variables
+				  :state-variable-names state-variable-names
+				  :pane-descriptions pane-descriptions
+				  :layout layout
+				  :top-level top-level
+				  :command-table command-table-name
+				  :disabled-commands disabled-commands)))
+    (push-unique frame-descriptor *frame-descriptors*
+		 :key #'frame-descriptor-name)
+    ;; If we're going to be defining commands for this application frame,
+    ;; make sure there's an command table lying around so that all other
+    ;; code doesn't have to be defensive against its absence.
+    (when command-table
+      (apply #'define-command-table-1 command-table))
+    frame-descriptor))
+
+(defun find-frame-descriptor (frame)
+  (when (application-frame-p frame)
+    (setq frame (frame-name frame)))
+  (find frame *frame-descriptors* :key #'frame-descriptor-name))
+
+)
+
+(defmacro define-application-frame (name superclasses slots &rest options)
+  #+Genera (declare (zwei:indentation 1 25 2 3 3 1))
+  (with-warnings-for-definition name define-application-frame
+    (let (panes layout top-level command-definer command-table disabled-commands)
+      (macrolet ((extract (name keyword default)
+		   `(let ((entry (assoc ',keyword options)))
+		      (cond ((null entry)
+			     (setq ,name ,default))
+			    (t
+			     (assert (= (length entry) 2) (entry)
+				     "The length of the option ~S must be 2" entry)
+			     (setq ,name (second entry)
+				   options (delete entry options)))))))
+	(extract panes :panes nil)
+	(extract layout :layout nil)
+	(extract top-level :top-level '(default-frame-top-level))
+	(extract command-definer :command-definer t)
+	(extract command-table :command-table t)
+	(extract disabled-commands :disabled-commands nil))
+      (check-type name symbol)
+      (check-type superclasses list)
+      (check-type slots list)
+      (check-type panes list)
+      (check-type layout list)
+      (check-type top-level list)
+      (check-type disabled-commands list)
+      (let* ((pane-descriptions (produce-pane-descriptions panes)))
+	(when (null superclasses)
+	  (setq superclasses '(standard-application-frame)))
+	(when (eq command-definer 't)
+	  (setq command-definer (fintern "~A-~A-~A" 'define name 'command)))
+	(check-type command-definer symbol)
+	(cond ((null command-table))
+	      ((symbolp command-table)
+	       (setq command-table (list command-table)))
+	      (t (warn-if-command-table-invalid name command-table)))
+	(when (eq (first command-table) 't)
+	  (setq command-table (list* name (rest command-table))))
+	(warn-if-pane-descriptions-invalid name pane-descriptions)
+	(warn-if-layout-invalid name layout pane-descriptions)
+	;; The pane descriptions is really a form that evaluates to be the
+	;; pane decriptions, but it's easier to deal with in the "raw" form.
+	;; A little extra consing at compile-time won't kill us.
+	(setq pane-descriptions
+	      `(list ,@(mapcar #'(lambda (desc)
+				   (let ((name (first desc))
+					 (type (second desc))
+					 (options (cddr desc)))
+				     `(list ',name ',type ,@options)))
+			       pane-descriptions)))
+	`(progn
+	   (eval-when (compile)
+	     (when ',command-table
+	       (setf (compile-time-property ',(first command-table) 'command-table-name) t))
+	     (define-application-frame-1 ',name ',slots ,pane-descriptions
+					 :layout ',layout
+					 :top-level ',top-level
+					 :command-table ',command-table))
+	   (define-group ,name define-application-frame
+	     (defclass ,name ,superclasses ,slots ,@options)
+	     ,@(when command-definer
+		 `((defmacro ,command-definer (command-name arguments &body body)
+		     #+Genera (declare (zwei:indentation 1 3 2 1))
+		     `(define-frame-command ,',(first command-table)
+					    ,command-name ,arguments ,@body))
+		   #+Genera (scl:defprop ,command-definer
+					 define-command
+					 zwei:definition-function-spec-type)
+		   #+Genera (scl:defprop ,command-definer
+					 remove-command
+					 zwei:kill-definition)
+		   #+Genera (scl:defprop ,command-definer
+					 zwei:defselect-function-spec-finder
+					 zwei:definition-function-spec-finder)))
+	     (define-application-frame-1 ',name ',slots ,pane-descriptions
+					 :layout ',layout
+					 :top-level ',top-level
+					 :command-table ',command-table
+					 :disabled-commands ',disabled-commands)
+	     #+Cloe-Runtime
+	     (cloe:define-program ,name ()
+	       :main ,name
+	       :debugger-hook cloe-debugger-hook)))))))
+
+#+Genera
+(scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name)
+
+;; For now each application frame has its own command table named after the application
+(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
+  #+Genera (declare (zwei:indentation 2 3 3 1))
+  (multiple-value-bind (command-name command-options)
+      (decode-name-and-options name-and-options command-table-name)
+    `(define-command (,command-name :command-table ,command-table-name ,@command-options)
+	 ,arguments
+       ,@body)))
+
+#+Genera
+(scl::defprop define-frame-command define-command zwei:definition-function-spec-type)
+#+Genera
+(scl:defun (:property define-frame-command zwei:definition-function-spec-finder) (bp)
+  (zwei:defselect-function-spec-finder (zwei:forward-sexp bp 1 t)))
+
+#+CLIM-1-compatibility
+(defmacro with-frame-state-variables
+	  ((frame-name &optional (frame '*application-frame*)) &body body)
+  ;; frame descriptor must be findable at compile-time
+  (let* ((descriptor (find-frame-descriptor frame-name))
+	 (state-variables (frame-descriptor-state-variable-names descriptor)))
+    `(with-slots ,state-variables ,frame ,@body)))
+
+(defun warn-if-command-table-invalid (frame-name command-table)
+  (cond ((not (and (listp command-table)
+		   (symbolp (first command-table))
+		   (oddp (length command-table))))
+	 (warn "The :COMMAND-TABLE option for frame ~S, ~S, is invalid.~@
+		It is supposed to be a list of a command table name followed by ~
+		keyword/value pairs."
+	       frame-name command-table))
+	(t
+	 (do* ((options (cdr command-table) (cddr options))
+	       (keyword (first options) (first options))
+	       (value (second options) (second options)))
+	      ((null options))
+	   (case keyword
+	     (:inherit-from
+	       (if (listp value)
+		   (dolist (item value)
+		     (unless (typep item '(or symbol command-table))
+		       (warn "The :INHERIT-FROM keyword in the :COMMAND-TABLE option for ~
+			      frame ~S~@
+			      is followed by a list containing ~S, which is not a ~
+			      command table nor a command table name."
+			     frame-name item)))
+		   (warn "The :INHERIT-FROM keyword in the :COMMAND-TABLE option for ~
+			  frame ~S~@
+			  is followed by ~S, which is not a list of command tables ~
+			  or command table names."
+			 frame-name value)))
+	     (:menu
+	       (if (listp value)
+		   (dolist (clause value)
+		     (unless (and (listp clause)
+				  (>= (length clause) 3)
+				  (oddp (length clause))
+				  (stringp (first clause))
+				  (member (second clause)
+					  '(:command :function :menu :divider)))
+		       (warn "The :MENU keyword in the :COMMAND-TABLE option for frame ~S~@
+			      is followed by a list of menu clauses containing~@
+			      an invalid clause ~S."
+			     frame-name clause)))
+		   (warn "The :MENU keyword in the :COMMAND-TABLE option for frame ~S~@
+			  is followed by ~S, which is not a list of menu clauses."
+			 frame-name value)))
+	     (otherwise
+	       (warn "The keyword ~S in the :COMMAND-TABLE option for frame ~S is invalid.~@
+		      The valid keywords are :INHERIT-FROM and :MENU."
+		     keyword frame-name)))))))
+
+;;; The args just get passed through to the specific application.
+(defun make-application-frame (frame-name &rest args
+			       &key frame-class pretty-name &allow-other-keys)
+  (declare (arglist frame-name
+		    &key frame-class pretty-name
+		    ;; initargs to application-frame that are
+		    ;; not supplied in the make-instance below
+		    parent left top right bottom height width
+		    ;panes		;i don't think we want to mention this
+		    ;top-level-sheet 	;..
+		    ;; this is here because application frame classes
+		    ;; can define additional initialization arguments,
+		    ;; so we can't predict the full set of keyword
+		    ;; arguments allowed in a particular call.
+		    &allow-other-keys))
+  (declare (dynamic-extent args))
+  (check-type pretty-name (or null string))
+  (let* ((descriptor (find-frame-descriptor frame-name))
+	 pane-descriptions current-layout)
+    (assert descriptor nil "unknown application frame: ~s" frame-name)
+    (setq pane-descriptions (frame-descriptor-pane-descriptions descriptor)
+	  current-layout (caar (frame-descriptor-layout descriptor)))
+    (when (null frame-class) (setq frame-class frame-name))
+    (with-keywords-removed (new-args args '(:frame-class :pretty-name))
+      (apply #'make-instance frame-class
+	     :name frame-name
+	     :pretty-name (or pretty-name
+			      (getf (pane-descriptor-options
+				      (find :title pane-descriptions
+					    :key #'pane-descriptor-type))
+				    :display-string)
+			      (title-capitalize (string frame-name)))
+	     :pane-descriptions (copy-tree pane-descriptions)
+	     :current-layout current-layout
+	     :command-table (frame-descriptor-command-table descriptor)
+	     :disabled-commands (copy-list (frame-descriptor-disabled-commands descriptor))
+	     new-args))))
+
+;;; PANE-TYPE-OPTIONS is how you define a new pane type.
+(defmethod pane-type-options ((type (eql :command-menu)))
+  `(:default-text-style *command-table-menu-text-style*
+    :incremental-redisplay t
+    :display-function 'display-command-menu
+    :display-after-commands t
+    :default-size :compute
+    :scroll-bars nil))
+
+;;--- Should this use incremental redisplay?
+(defmethod pane-type-options ((type (eql :title)))
+  `(:default-text-style (parse-text-style '(:sans-serif :bold :very-large))
+    :display-function 'display-title
+    :display-after-commands nil
+    :default-size :compute
+    :scroll-bars nil))
+
+(defmethod pane-type-options ((type (eql :interactor)))
+  `(:scroll-bars :vertical
+    :initial-cursor-visibility :off))
+
+(defmethod pane-type-options ((type (eql :application)))
+  `(:default-size :rest))
+
+(defmethod pane-type-options ((type (eql :pointer-documentation)))
+  `(:default-text-style (parse-text-style '(:sans-serif :bold :normal))
+    :display-after-commands nil
+    :default-size :compute
+    :scroll-bars nil))
+
+(defun produce-pane-descriptions (panes)
+  (let ((descriptions nil))
+    (dolist (window-info panes (nreverse descriptions))
+      ;; We really need destructuring-bind, but until there are options we can wait
+      (let ((name (first window-info))
+	    (type (second window-info))
+	    (options (cddr window-info)))
+	(push `(,name ,type ,@options ,@(pane-type-options type)) descriptions)))))
+
+(defun-inline dummy-pane-p (pane)
+  (symbolp pane))
+
+(defvar *non-window-pane-keywords* 
+	'(:width :height :default-size :height-in-lines
+	  :display-after-commands :incremental-redisplay
+	  :display-function :display-string :save-under))
+
+;;; This function simply creates a bunch of windows with dummy size.
+;;; LAYOUT-FRAME-PANES actually does the laying out of the windows.
+(defun create-windows-from-description (frame descriptions root
+					&key left top right bottom width height
+					     save-under)
+  (when descriptions		;suppose no windows...
+    (let ((p-left 0) (p-top 0) (p-right nil) (p-bottom nil))
+      (multiple-value-setq (p-right p-bottom)
+	(window-inside-size root))
+      ;; This is the same definition as is macroleted in open-window-stream.  You
+      ;; could argue that it should be pulled out and published.
+      (macrolet ((rationalize-dimensions (low high delta direction)
+		   (flet ((parent-name (name) (fintern "~A-~A" 'p name)))
+		     (let ((p-low (parent-name low))
+			   (p-high (parent-name high)))
+		       `(progn 
+			  (assert (not (and ,low ,high ,delta
+					    (/= ,delta (- ,high ,low))))
+				  (,low ,high ,delta)
+				  ,(format
+				     nil
+				       "The ~A dimensions of this window are overconstrained."
+				     direction))
+			  (when ,low (setf ,p-low ,low))
+			  (when ,high (setf ,p-high ,high))
+			  (when ,delta (if ,high
+					   (setf ,p-low (- ,p-high ,delta))
+					   (setf ,p-high (+ ,p-low ,delta))))
+			  (setf ,low ,p-low ,high ,p-high ,delta (- ,p-high ,p-low)))))))
+      (rationalize-dimensions left right width "horizontal")
+      (rationalize-dimensions top bottom height "vertical")))
+    (let* ((genera-p #+Genera (typep root 'sheet-window-stream)
+		     #-Genera nil)
+	   ;; On non-Genera window systems, use the title bar that those window
+	   ;; systems provide instead of a title pane.
+	   (title-pane-p (and genera-p
+			      (find :title descriptions :key #'pane-descriptor-type)))
+	   ;; On Genera, only label the frame if there is no title pane.  On other
+	   ;; window systems, the label will appear in the title bar.
+	   (label (if genera-p
+		      (if title-pane-p nil (frame-pretty-name frame))
+		      (frame-pretty-name frame)))
+	   ;; Only give the frame borders when there is no title pane.
+	   (borders (not title-pane-p))
+	   (main (create-application-frame frame
+					   :parent root :left left :top top
+					   :width (- right left) :height (- bottom top)
+					   :label label :borders borders
+					   :scroll-bars nil :save-under save-under))
+	   (input-buffer (stream-input-buffer main))
+	   (panes nil))
+      (dolist (desc descriptions)
+	(let ((type (pane-descriptor-type desc))
+	      (options (pane-descriptor-options desc)))
+	  (with-keywords-removed (new-options options *non-window-pane-keywords*)
+	    (cond ((and genera-p (eql type ':pointer-documentation))
+		   ;; On Genera, use the normal mouse-doc line
+		   (push 'dummy-pointer-documentation-pane panes))
+		  ((and (not genera-p) (eql type ':title))
+		   ;; Most window systems put the title in the window decorations
+		   (push 'dummy-title-pane panes))
+		  (t
+		   (push (apply #'open-window-stream :parent main :left 0 :top 0
+				:width 100 :height 100
+				:input-buffer input-buffer
+				new-options)
+			 panes))))))
+      (values main (nreverse panes)))))
+
+(defun warn-if-pane-descriptions-invalid (frame-name descriptions)
+  (let ((valid-keywords
+	  ;; We will instantiate a port-dependent subclass of this class, but we only care
+	  ;; about initialization arguments that are accepted by all subclasses.
+	  (let ((class (find-class 'window-stream)))
+	    ;; It's probably a bug that class-make-instance-keywords doesn't do this itself
+	    #+(or Genera Cloe-Runtime) (unless (clos-internals::class-finalized-p class)
+					 (clos-internals::finalize-inheritance class))
+	    ;; In Symbolics CLOS this function returns the initialization arguments accepted
+	    #+(or Genera Cloe-Runtime) (clos-internals::class-make-instance-keywords class)
+	    ;; There is no standard for this, so in systems where we don't know how to do it,
+	    ;; just punt.
+	    #-(or Genera Cloe-Runtime) (return-from warn-if-pane-descriptions-invalid nil)))
+	(non-window-keywords *non-window-pane-keywords*))
+    (dolist (desc descriptions)
+      (let (;; Surprisingly, the valid options don't depend on the pane type
+	    ;(type (pane-descriptor-type desc))
+	    (options (pane-descriptor-options desc))
+	    (invalid-keywords nil))
+	(do* ((options options (cddr options))
+	      (keyword (car options) (car options)))
+	     ((null options))
+	  (unless (or (eql keyword ':window-class)
+		      (member keyword non-window-keywords)
+		      (member keyword valid-keywords))
+	    (push keyword invalid-keywords)))
+	(when invalid-keywords
+	  (setq invalid-keywords (nreverse invalid-keywords))
+	  (warn "The option~P ~{~S~^, ~}~@
+		 specified for pane ~S of frame ~S ~:[is~;are~] not valid.~@
+		 Known options are ~S."
+		(length invalid-keywords) invalid-keywords
+		(pane-descriptor-name desc) frame-name (cdr invalid-keywords)
+		(sort (append valid-keywords non-window-keywords '(:window-class) nil)
+		      #'string<)))))))
+
+(defvar *frame-layout-changing-p* nil)
+
+;;; This used to be an after method, unconditionally setting the layout.
+;;; Now, make it an around method that only recomputes the layout if the size changes,
+;;; not if only the position changes.  (Eliminates some unnecessary redisplays.)
+#-Silica
+(defmethod window-note-size-or-position-change :around ((window window-mixin)
+							new-left new-top new-right new-bottom)
+  (declare (type coordinate new-left new-top new-right new-bottom))
+  (multiple-value-bind (width height) (bounding-rectangle-size window)
+    (declare (type coordinate width height))
+    (call-next-method window new-left new-top new-right new-bottom)
+    (unless (and (= width (- new-right new-left))
+		 (= height (- new-bottom new-top)))
+      (let ((frame (window-stream-to-frame window)))
+	(when frame
+	  (let ((*application-frame* frame))
+	    (catch 'resynchronize
+	      (let ((*frame-layout-changing-p* t))
+		;; Forcibly layout the frame again
+		(layout-frame-panes frame (frame-top-level-sheet frame))))))))))
+
+(defmethod (setf frame-current-layout) (new-layout (frame standard-application-frame))
+  (setq *frame-layout-changing-p* t)
+  (with-slots (current-panes initialized-panes current-layout) frame
+    (setf current-layout new-layout)
+    (layout-frame-panes frame (frame-top-level-sheet frame))
+    ;; Forcibly display any panes that have not been displayed yet
+    (dolist (pane current-panes)
+      (unless (member pane initialized-panes)
+	;; Display the pane and mark it initialized
+	(redisplay-frame-pane frame pane :force-p t))))
+  (unless (eq *application-frame* *default-application*)
+    ;; must resynchronize even if the layout phase "didn't do anything"
+    ;; because we might need to get streams rebound, etc.
+    (throw 'resynchronize T)))
+
+#+CLIM-1-compatibility
+(define-compatibility-function (set-frame-layout (setf frame-current-layout))
+			       (frame new-layout)
+  (setf (frame-current-layout frame) new-layout))
+
+;; This works in 2 phases.
+;; The first phase figures out which windows need to be visible and where
+;; the second phase does the work, doing as little as possible.  Quite often,
+;; the size and position of some windows will not change, and there's no reason
+;; to set their visibility to NIL and back to T in that case.
+(defmethod layout-frame-panes ((frame standard-application-frame) window-frame)
+  ;; Some applications have no top-level window.
+  #-silica
+  (when window-frame
+    (let* ((*sizing-application-frame* t)
+	   (descriptor (find-frame-descriptor frame))
+	   (layout (frame-descriptor-layout descriptor))
+	   (current-layout (frame-current-layout frame))
+	   (this-layout (second (assoc current-layout layout))))
+      (multiple-value-bind (available-x available-y)
+	  (window-inside-size window-frame)
+	(let ((windows-and-sizes nil))
+	  (flet ((size-setter (name left top right bottom)
+		   (setq left (floor left)
+			 top (floor top)
+			 right (floor right)
+			 bottom (floor bottom))
+		   (let ((pane (get-frame-pane frame name)))
+		     (push (list pane left top right bottom) windows-and-sizes)))
+		 (size-helper (name cluster-type available-width available-height)
+		   (multiple-value-bind (pane description)
+		       (get-frame-pane frame name)
+		     (let ((amount
+			     (if (dummy-pane-p pane)
+				 0
+			         (size-frame-pane pane frame 
+						  (pane-descriptor-type description)
+						  description
+						  cluster-type
+						  available-width available-height))))
+		       (cond ((or (keywordp amount)
+				  (dummy-pane-p pane)
+				  (< 0 amount 1))	;for upward compatibility
+			      amount)
+			     (t
+			      ;; the amount returned by SIZE-FRAME-PANE is inside size
+			      ;; to save SIZE-FRAME-PANE method writers from having to
+			      ;; understand margins.
+			      (multiple-value-bind (lm tm rm bm)
+				  (host-window-margins pane)
+				(case cluster-type
+				  (:row (+ amount lm rm))
+				  (:column (+ amount tm bm))))))))))
+	    (layout-frame-panes-1 this-layout 0 0 available-x available-y
+					 #'size-setter #'size-helper))
+	  ;; Now windows-and-sizes contains the size and position of each pane
+	  (setq windows-and-sizes (nreverse windows-and-sizes))
+	  ;; First set the sizes properly
+	  (dolist (element windows-and-sizes)
+	    (let ((pane (pop element)))
+	      (unless (dummy-pane-p pane)
+		(multiple-value-bind (left top right bottom)
+		    (values-list element)
+		  (with-bounding-rectangle* (pl pt pr pb) pane
+		    (unless (ltrb-equals-ltrb-p pl pt pr pb left top right bottom)
+		      (bounding-rectangle-set-edges pane left top right bottom)
+		    ;; If the size changed, the pane isn't initialized anymore
+		    (setf (slot-value frame 'initialized-panes)
+			  (delete pane (slot-value frame 'initialized-panes)))))))))
+	  ;; Then get the visibilities right
+	  (dolist (inf (window-children window-frame))
+	    (if (assoc inf windows-and-sizes)
+		(unless (window-visibility inf) (setf (window-visibility inf) T))
+		(when (window-visibility inf) (setf (window-visibility inf) nil))))
+	  ;; Remember the panes in this layout for later
+	  (setf (frame-current-panes frame)
+		(delete nil (mapcar #'first windows-and-sizes))))))))
+
+(defun layout-frame-panes-1 (layout-spec start-x start-y available-x available-y
+			     size-setter size-helper)
+  (declare (dynamic-extent size-setter size-helper))
+  (setq layout-spec (copy-list layout-spec))	; so we can modify it
+  (let ((parent-type (first layout-spec))
+	(inferiors (cddr layout-spec))
+	(calculated-inferiors nil))
+    (dolist (inf inferiors)
+      (let ((type-or-name (first inf))
+	    (size-spec (second inf))
+	    size)
+	(cond ((eql size-spec :rest)
+	       (setq size ':rest))
+	      ((eql size-spec :compute)
+	       (setq size (funcall size-helper type-or-name parent-type 
+				   available-x available-y)))
+	      ((and (numberp size-spec)
+		    (<= 0 size-spec 1))
+	       ;; A pane with a relative sizing parameter
+	       (case parent-type
+		 (:row
+		   (setq size (* available-x size-spec)))
+		 (:column
+		   (setq size (* available-y size-spec)))))
+	      (t
+	       (cerror "Compute the size of the pane"
+		       "The size specification ~S is unrecognized" size-spec)
+	       (setq size (funcall size-helper type-or-name parent-type 
+				   available-x available-y))))
+	;; Save a copy of this inferior's spec, with the abstract size
+	;; spec (e.g. :COMPUTE) replaced by a number.
+	(let ((entry (copy-list inf)))
+	  (setf (second entry) size)
+	  (push entry calculated-inferiors))))
+    (setq calculated-inferiors (nreverse calculated-inferiors))
+    (let ((available (case parent-type
+		       (:row available-x)
+		       (:column available-y)))
+	  (n-rests 0))
+      ;; Compute left-over space after explicitly-sized panes are allocated
+      (dolist (inf calculated-inferiors)
+	(let ((size (second inf)))
+	  (if (eql size ':rest)
+	      (incf n-rests)
+	      (decf available size))))
+      (let ((rest-allocation (and (plusp n-rests) (floor available n-rests)))
+	    constant-start adjusted-start constant-size adjusted-size)
+	;; Attempt to write code that deals with allocating space along one
+	;; dimension (either X or Y) while holding the other dimension constant.
+	(case parent-type
+	  (:row (setq constant-start start-y
+		      adjusted-start start-x
+		      constant-size  available-y))
+	  (:column (setq constant-start start-x
+			 adjusted-start start-y
+			 constant-size  available-x)))
+	;; Decode the "adjusted" and "constant" dimensions into actual X and Y
+	;; depending on whether we are laying out a row or column
+	(macrolet ((with-real-coords ((xvar yvar widthvar heightvar) &body body)
+		     `(let (,xvar ,yvar ,widthvar ,heightvar)
+			(case parent-type
+			  (:row
+			    (setq ,xvar adjusted-start
+				  ,yvar constant-start
+				  ,widthvar  adjusted-size
+				  ,heightvar constant-size))
+			  (:column
+			    (setq ,yvar adjusted-start
+				  ,xvar constant-start
+				  ,heightvar adjusted-size
+				  ,widthvar  constant-size)))
+			,@body)))
+	  (dolist (inf calculated-inferiors)
+	    (let* ((name-or-type (first inf))
+		   (size-info (second inf)))
+	      ;; Bite off a chunk for this pane
+	      (setq adjusted-size (if (eql size-info ':rest)
+				      rest-allocation
+				      size-info))
+	      (with-real-coords (x y width height)
+	        ;; If a sub-row or -column, lay it out
+	        (cond ((keywordp name-or-type)
+		       (layout-frame-panes-1
+			 inf x y width height size-setter size-helper))
+		      ;; must be a pane name
+		      (t (funcall size-setter name-or-type x y
+				  (+ x width) (+ y height))))
+		;; Set where the new pane will start.
+		(incf adjusted-start adjusted-size)))))))))
+
+(defun warn-if-layout-invalid (frame-name layouts pane-descriptions)
+  (dolist (layout layouts)
+    (if (and (listp layout)
+	     (= (length layout) 2)
+	     (symbolp (first layout))
+	     (listp (second layout))
+	     (>= (length (second layout)) 3))
+	(let ((layout-name (first layout)))
+	  (labels ((check-layout-spec (layout-spec max-remaining)
+		     (unless (and (listp layout-spec)
+				  (>= (length layout-spec) 2))
+		       (warn "~S appears where either a list of a pane name and size~@
+			      or a list of :ROW or :COLUMN, size, and inferiors is expected~@
+			      in layout ~S of frame ~S."
+			     layout-spec layout-name frame-name)
+		       (return-from check-layout-spec max-remaining))
+		     (let* ((name-or-type (first layout-spec))
+			    (aggregate (keywordp name-or-type))
+			    (size-spec (second layout-spec))
+			    (inferiors (cddr layout-spec)))
+		       ;; Check name-or-type
+		       (if aggregate
+			   (unless (member name-or-type '(:row :column))
+			     (warn "The keyword ~S appears where :ROW, :COLUMN, or a~@
+				    pane name is expected, in layout ~S of frame ~S."
+				   name-or-type layout-name frame-name))
+			   (unless (assoc name-or-type pane-descriptions)
+			     (warn "The undefined pane name ~S appears ~
+				    in layout ~S of frame ~S."
+				   name-or-type layout-name frame-name)))
+		       ;; Check size-spec
+		       (cond ((eq size-spec :rest))
+			     ((and (not aggregate) (eq size-spec :compute)))
+			     ((typep size-spec #-Cloe-Runtime '(real 0 1)
+				               #+Cloe-Runtime '(or (rational 0 1)
+								   (float 0 1)))
+			      (decf max-remaining size-spec))
+			     (aggregate
+			      (warn "The invalid size specification ~S appears in~@
+				     a ~S entry in layout ~S of frame ~S.~@
+				     A valid size specification for a row or column is :REST~@
+				     or a real number between 0 and 1 inclusive."
+				    size-spec name-or-type layout-name frame-name))
+			     (t
+			      (warn "The invalid size specification ~S appears in~@
+				     the entry for pane ~S in layout ~S of frame ~S.~@
+				     A valid size specification for a pane is :REST,~@
+				     :COMPUTE, or a real number between 0 and 1 inclusive."
+				    size-spec name-or-type layout-name frame-name)))
+		       ;; Check inferiors and check overall plausibility of size-specs
+		       (cond ((not aggregate)
+			      (unless (null inferiors)
+				(warn "Extra garbage ~S appears after the size specification~@
+				       in the entry for pane ~S in layout ~S of frame ~S."
+				      inferiors name-or-type layout-name frame-name)))
+			     ((not (consp inferiors))
+			      (warn "~S appears where a list of inferiors is expected,~@
+				     after the size specification~@
+				     in a ~S entry in layout ~S of frame ~S."
+				    inferiors name-or-type layout-name frame-name))
+			     (t (check-layout-specs name-or-type inferiors)))
+		       max-remaining))
+		   (check-layout-specs (name-or-type inferiors)
+		     (let ((max-remaining 1) (rest nil))
+		       (dolist (layout-spec inferiors)
+			 (when (and (listp layout-spec)
+				    (symbolp (second layout-spec)))
+			   (setq rest t))
+			 (setq max-remaining (check-layout-spec layout-spec max-remaining)))
+		       (cond ((< max-remaining 0)
+			      (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@
+				     overcommitted the available space by ~S."
+				    name-or-type layout-name frame-name
+				    (- max-remaining)))
+			     ((and rest (= max-remaining 0))
+			      (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@
+				     overcommitted the available space.  ~
+				     It didn't leave anything for :REST/:COMPUTE."
+				    name-or-type layout-name frame-name))
+			     ((and (not rest) (> max-remaining 0))
+			      (warn "~:[The top~;~:*A ~S~] entry in layout ~S of frame ~S~@
+				     failed to consume all available space.  ~
+				     The fraction ~S was left over."
+				    name-or-type layout-name frame-name
+				    max-remaining))))))
+	    (check-layout-specs nil (cdr layout))))
+        (warn "~S appears where a list (layout-name (direction 1.0 spec...))~@
+	       is expected, in the :LAYOUT option of frame ~S."
+	      layout frame-name))))
+
+;;; Returns one (1) value, the space taken up along the "available space" dimension.
+#-silica
+(defmethod size-frame-pane ((window window-mixin)
+			    (frame standard-application-frame)
+			    (type T)		;pane type
+			    pane-description	;description of this window
+			    cluster-type	;horizontal or vertical
+			    available-width available-height)
+  ;; default method (on T)
+  pane-description cluster-type available-width available-height
+  ':rest)
+
+(defmethod size-frame-pane :around ((window window-mixin)
+				    (frame standard-application-frame)
+				    (type T)
+				    pane-description 
+				    cluster-type
+				    available-width available-height)
+  available-width available-height
+  (let* ((options (pane-descriptor-options pane-description)) 
+	 (nlines (getf options :height-in-lines))
+	 (vsp (getf options :vertical-spacing (stream-vertical-spacing window)))
+	 (size (call-next-method)))
+    (case cluster-type
+      (:row size)
+      (:column
+	(if nlines
+	    (if (eql size ':rest)
+		(+ 5 (* nlines (+ (stream-line-height window) vsp)))
+		(max size (+ 5 (* nlines (+ (stream-line-height window) vsp)))))
+	    size)))))
+
+#-silica
+(defmethod size-frame-pane ((window window-mixin)
+			    (frame standard-application-frame)
+			    (type (eql :title))
+			    pane-description
+			    cluster-type
+			    available-width available-height)
+  available-width available-height
+  (let* ((options (pane-descriptor-options pane-description))
+	 (vsp (getf options :vertical-spacing (stream-vertical-spacing window))))
+    (case cluster-type
+      (:row
+	;; as wide as the title
+	':rest)
+      (:column 
+	;; one line in current text style
+	(+ 5 (+ vsp (stream-line-height window)))))))
+
+#-silica
+(defmethod size-frame-pane ((window window-mixin)
+			    (frame standard-application-frame)
+			    (type (eql :command-menu))
+			    pane-description
+			    cluster-type
+			    available-width available-height)
+  ;; Unconstrain the direction along which we are computing the size, so that
+  ;; the menu will use the constraint in the orthogonal direction to compute
+  ;; how much space it needs to occupy in this direction
+  (case cluster-type
+    (:row (setq available-width nil))
+    (:column (setq available-height nil)))
+  (let* ((options (pane-descriptor-options pane-description))
+	 (vsp (getf options :vertical-spacing (stream-vertical-spacing window)))
+	 (display-function (getf options :display-function #'display-command-menu))
+	 (incremental-redisplay (getf options :incremental-redisplay))
+	 ;; The menu cell for a disabled command is (sometimes) smaller than the
+	 ;; menu cell for an enabled command, so make sure we allocate enough space
+	 (*assume-all-commands-enabled* t)
+	 (command-table (getf options :command-table))
+	 (displayer (if incremental-redisplay
+			#'call-redisplay-function
+			#'call-display-function))
+	 (menu-contents
+	   (with-output-to-output-record (window)
+	     (if command-table
+		 (funcall displayer display-function frame window
+			  :command-table command-table
+			  :max-width available-width
+			  :max-height available-height)
+		 (funcall displayer display-function frame window
+			  :max-width available-width
+			  :max-height available-height)))))
+    (multiple-value-bind (width height) (bounding-rectangle-size menu-contents)
+      (case cluster-type
+	(:row width)
+	(:column (+ height vsp))))))
+
+#-silica
+(defmethod size-frame-pane ((window window-mixin)
+			    (frame standard-application-frame)
+			    (type (eql :application))
+			    pane-description
+			    cluster-type
+			    available-width available-height)
+  available-width available-height
+  ;;--- This might want to see if the window already has stuff in it, no?
+  ;;--- The display-function needs to produce a meaningful result when
+  ;;--- the application frame is created.
+  (let* ((options (pane-descriptor-options pane-description))
+	 (display-function (getf options :display-function))
+	 (incremental-redisplay (getf options :incremental-redisplay)))
+    (if display-function
+	(let ((window-contents
+		(with-output-to-output-record (window)
+		  (funcall (if incremental-redisplay
+			       #'call-redisplay-function
+			       #'call-display-function)
+			   display-function frame window))))
+	  (multiple-value-bind (width height)
+	      (bounding-rectangle-size window-contents)
+	    (case cluster-type
+	      (:row width)
+	      (:column height))))
+        ':rest)))
+
+#-silica
+(defmethod size-frame-pane ((window window-mixin)
+			    (frame standard-application-frame)
+			    (type (eql :pointer-documentation))
+			    pane-description
+			    cluster-type
+			    available-width available-height)
+  available-width available-height
+  (let* ((options (pane-descriptor-options pane-description))
+	 (vsp (getf options :vertical-spacing (stream-vertical-spacing window))))
+    (case cluster-type
+      (:row
+	;; as wide as the title
+	':rest)
+      (:column 
+	;; one line in current text style
+	(+ 2 (+ vsp (stream-line-height window)))))))
+
+(defmethod initialize-instance :after ((frame standard-application-frame)
+				       &key pane-descriptions parent
+					    left top right bottom width height)
+  ;; If parent is NIL, assume that the caller of MAKE-APPLICATION-FRAME is going
+  ;; to take care of window initialization.
+  (when parent
+    (multiple-value-bind (main-window panes)
+	(create-windows-from-description frame pane-descriptions parent
+					 :left left :top top
+					 :right right :bottom bottom
+					 :width width :height height)
+      (setf (slot-value frame 'top-level-sheet) main-window)
+      (setf (slot-value frame 'panes) panes)
+      (let ((*application-frame* frame))
+	(layout-frame-panes frame main-window)))))
+
+(defun get-frame-pane (frame pane-name &key (errorp t))
+  (let* ((descriptor (find-frame-descriptor frame))
+	 (position (if (typep pane-name 'window-mixin)
+		       (position pane-name (frame-panes frame))
+		       (position pane-name (frame-descriptor-pane-descriptions descriptor)
+				 :key #'pane-descriptor-name))))
+    (when (and (null position)
+	       (dummy-pane-p pane-name))
+      (setq position (position pane-name (frame-panes frame))))
+    (if (null position)
+	(when errorp
+	  (error "There is no pane named ~S in frame ~S" pane-name frame))
+        (let ((pane (elt (frame-panes frame) position))
+	      (descr (elt (frame-descriptor-pane-descriptions descriptor) position)))
+	  ;; Note that this can return dummy panes!
+	  (values pane descr)))))
+
+(defun title-capitalize (string)
+  (let ((new-string (substitute #\Space #\- string)))
+    (when (eq new-string string)
+      (setq new-string (copy-seq new-string)))
+    (nstring-capitalize new-string)))
+
+(defun display-title (frame stream)
+  (multiple-value-bind (pane desc) (get-frame-pane frame stream)
+    (when (and pane (eq pane stream))
+      (let ((title (getf (pane-descriptor-options desc) :display-string)))
+	(when (and (stringp title)
+		   (not (string-equal title (frame-pretty-name frame))))
+	  ;; On some hosts this will update the title bar 
+	  (setf (frame-pretty-name frame) title))
+	(when (and (eq stream pane) (not (dummy-pane-p pane)))
+	  (multiple-value-bind (width height)
+	      (window-inside-size stream)
+	    (draw-string* stream (or title (frame-pretty-name frame))
+			  (/ width 2) (/ height 2)
+			  :align-x :center :align-y :center))
+	  (force-output stream))
+	(values)))))
+
+(defun display-command-menu (frame stream &rest keys
+			     &key command-table &allow-other-keys)
+  (declare (dynamic-extent keys))
+  (declare (arglist frame stream &rest keys
+		    &key command-table
+			 ;; Defaults for these provided by DISPLAY-COMMAND-TABLE-MENU
+			 max-width max-height n-rows n-columns
+			 (cell-align-x ':left) (cell-align-y ':top) 
+			 (initial-spacing t)))
+  ;;--- This really wants to get the information from some other place
+  ;;--- than having to find the descriptor each time, which is kludgy at best.
+  (multiple-value-bind (descriptor pane)
+      (do ((panes (frame-panes frame) (cdr panes))
+	   (descriptions (frame-descriptor-pane-descriptions
+			   (find-frame-descriptor frame))
+			 (cdr descriptions)))
+	  ((null panes) nil)
+	(when (eq (first panes) stream)
+	  (return (values (first descriptions) (first panes)))))
+    (when pane
+      (let ((command-table
+	      (find-command-table (or command-table (frame-command-table frame))))
+	    (incremental-redisplay
+	      (getf (pane-descriptor-options descriptor) :incremental-redisplay))
+	    (*application-frame* frame))
+	(with-keywords-removed (keys keys '(:command-table))
+	  (if incremental-redisplay
+	      (apply #'display-command-menu-1 stream command-table keys)
+	      (apply #'display-command-table-menu command-table stream keys)))))))
+
+;; Split out to avoid consing unnecessary closure environments.
+(defun display-command-menu-1 (stream command-table &rest keys)
+  (declare (dynamic-extent keys))
+  (updating-output (stream :unique-id stream
+			   :cache-value (slot-value command-table 'menu-tick))
+    (apply #'display-command-table-menu command-table stream keys)))
+
+(defmethod run-frame-top-level :around ((frame standard-application-frame))
+  (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame))
+    (with-slots (top-level-sheet) frame
+      (unwind-protect
+	  (let ((*frame-layout-changing-p* *frame-layout-changing-p*)
+		;; Reset the state of the input editor and the presentation
+		;; type system, etc., in case there is an entry into another
+		;; application from inside the input editor, such as a Debugger
+		;; written using CLIM.
+		;;--- This should be done in a more modular way
+		;;--- If you change this, change MENU-CHOOSE-FROM-DRAWER
+		(*original-stream* nil)
+		(*input-wait-test* nil)
+		(*input-wait-handler* nil)
+		(*pointer-button-press-handler* nil)
+		(*generate-button-release-events* nil)
+		(*numeric-argument* nil)
+		(*blip-gestures* nil)
+		(*activation-gestures* nil)
+		(*accelerator-gestures* nil)
+		(*input-context* nil)
+		(*accept-help* nil)
+		(*assume-all-commands-enabled* nil)
+		(*sizing-application-frame* nil)
+		(*command-parser* 'command-line-command-parser)
+		(*command-unparser* 'command-line-command-unparser)
+		(*partial-command-parser*
+		  'command-line-read-remaining-arguments-for-partial-command))
+	    (loop
+	      (with-simple-restart (nil "~A top level" (frame-pretty-name frame))
+		(when top-level-sheet
+		  (window-expose top-level-sheet))
+		(loop
+		  (catch 'resynchronize
+		    (let ((*application-frame* frame)
+			  (*pointer-documentation-output*
+			    (frame-pointer-documentation-output frame)))
+		      ;; We must return the values from CALL-NEXT-METHOD,
+		      ;; or else ACCEPTING-VALUES will return NIL
+                      #-CCL-2
+		      (return-from run-frame-top-level (call-next-method))
+                      ;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above
+                      ;; doesn't work in Coral.  If the "top level" restart
+                      ;; above is taken, the CALL-NEXT-METHOD form blows out
+                      ;; the second time through this code, claiming that it
+		      ;; can't find the next method.  Hoisting the
+                      ;; CALL-NEXT-METHOD out of the RETURN-FROM form seems
+                      ;; to fix it...  So it conses, big deal.
+                      #+CCL-2
+                      (let ((results (multiple-value-list (call-next-method))))
+                        (return-from run-frame-top-level (values-list results)))))))))
+	(when top-level-sheet
+	  (setf (window-visibility top-level-sheet) nil))))))
+
+(defmethod run-frame-top-level ((frame standard-application-frame))
+  (let* ((descriptor (find-frame-descriptor frame))
+	 (top-level (frame-descriptor-top-level descriptor)))
+    (apply (first top-level) frame (rest top-level))))
+
+(defun find-pane-of-type (frame type &key (if-current t))
+  (let ((current-panes (frame-current-panes frame)))
+    (do ((panes (frame-panes frame) (cdr panes))
+	 (descriptions (frame-descriptor-pane-descriptions (find-frame-descriptor frame))
+		       (cdr descriptions)))
+	((null panes) nil)
+      (let* ((pane (first panes))
+	     (descriptor (first descriptions)))
+	(when (and (eq (pane-descriptor-type descriptor) type)
+		   (or (null if-current)
+		       (member pane current-panes)))
+	  (return (values pane descriptor)))))))
+
+(defmethod frame-standard-output ((frame standard-application-frame))
+  (or (find-pane-of-type frame ':application)
+      (find-pane-of-type frame ':interactor)))
+
+(defmethod frame-standard-input ((frame standard-application-frame))
+  (or (find-pane-of-type frame ':interactor)
+      (frame-standard-output frame)))
+
+(defmethod frame-query-io ((frame standard-application-frame))
+  (or (frame-standard-input frame)
+      (frame-standard-output frame)))
+
+(defmethod frame-error-output ((frame standard-application-frame))
+  (frame-standard-output frame))
+
+(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
+  ;; If it's a Genera frame, use the mouse-doc line, otherwise find
+  ;; the pointer documentation pane.
+  (or #+Genera (let ((stream (frame-top-level-sheet frame)))
+		 (and (typep stream 'sheet-window-stream)
+		      (not (null (tv:screen-who-line-screen
+				   (tv:sheet-screen (slot-value stream 'window)))))))
+      (find-pane-of-type frame ':pointer-documentation)))
+
+(defmethod read-frame-command ((frame standard-application-frame) 
+			       &key (stream *query-io*)		;frame-query-io?
+			       ;; should the rest of the *command-parser*
+			       ;; etc. variables be passed as keywords or bound?
+			       )
+  (read-command (frame-command-table frame) :stream stream))
+
+(defmethod execute-frame-command ((frame standard-application-frame) command)
+  (apply (command-name command) (command-arguments command)))
+
+;;--- This causes direct-manipulation and menu-driven applications not to
+;;--- maintain histories.  Is there a better heuristic?
+(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
+  (not (null (find-pane-of-type frame ':interactor :if-current nil))))
+
+;; Generic because someone might want :BEFORE or :AFTER
+(defmethod frame-exit ((frame standard-application-frame))
+  (invoke-restart 'frame-exit))
+
+(defmethod notify-user ((frame standard-application-frame) format-string &rest format-args)
+  (declare (dynamic-extent format-args))
+  (apply #'notify-user-1 (frame-top-level-sheet frame) frame format-string format-args))
+
+(defun default-frame-top-level (frame
+				&key command-parser command-unparser partial-command-parser
+				     (prompt "Command: "))
+  (let* ((*standard-output*
+	   (or (frame-standard-output frame) *standard-output*))
+	 (*standard-input* 
+	   (or (frame-standard-input frame) *standard-output*))
+	 (*query-io* 
+	   (or (frame-query-io frame) *standard-input*))
+	 (*error-output* 
+	   (or (frame-error-output frame) *standard-output*))
+	 (interactor (not (null (find-pane-of-type frame ':interactor))))
+	 (*command-parser*
+	   (or command-parser
+	       (if interactor
+		   #'command-line-command-parser
+		   #'menu-command-parser)))
+	 (*command-unparser*
+	   (or command-unparser 
+	       #'command-line-command-unparser))
+	 (*partial-command-parser* 
+	   (or partial-command-parser
+	       (if interactor
+		   #'command-line-read-remaining-arguments-for-partial-command
+		   #'menu-read-remaining-arguments-for-partial-command))))
+
+    ;; The read-eval-print loop for applications...
+    (loop
+      ;; Redisplay all the panes
+      (redisplay-frame-panes frame)
+      (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
+	(when interactor
+	  (fresh-line *standard-input*)
+	  (if (stringp prompt)
+	      (write-string prompt *standard-input*)
+	      (funcall prompt *standard-input* frame)))
+	(let ((command (read-frame-command frame :stream *standard-input*)))
+	  (when interactor
+	    (terpri *standard-input*))
+	  ;; Need this check in case the user aborted out of a command menu
+	  (when command
+	    (execute-frame-command frame command)))))))
+
+(defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p)
+  (with-slots (panes pane-descriptions current-panes) frame
+    (do ((windows panes (cdr windows))
+	 (descriptions pane-descriptions (cdr descriptions)))
+	((null windows) nil)
+      (let* ((window (first windows))
+	     (description (first descriptions)))
+	(when (member window current-panes)
+	  (redisplay-frame-pane-1 frame window description force-p))))
+    (setq *frame-layout-changing-p* nil)))
+
+(defmethod redisplay-frame-pane ((frame standard-application-frame) pane-name &key force-p)
+  (multiple-value-bind (pane description)
+      (get-frame-pane frame pane-name)
+    (redisplay-frame-pane-1 frame pane description force-p)))
+
+;; FORCE-P can be NIL (meaning just do the redisplay normally) or T (meaning
+;; forcibly redisplay the pane).
+(defun redisplay-frame-pane-1 (frame pane description &optional force-p)
+  (let* ((options (pane-descriptor-options description))
+	 (display-function (getf options :display-function))
+	 (incremental-redisplay (getf options :incremental-redisplay))
+	 (redisplay-record
+	   (and incremental-redisplay
+		(let ((history (stream-output-history pane)))
+		  (when history
+		    #+compulsive-redisplay
+		    (when (> (output-record-count history) 1)
+		      (cerror "Clear the output history and proceed"
+			      "There more than one output record in this redisplay pane")
+		      (window-clear pane))
+		    (unless (zerop (output-record-count history))
+		      (output-record-element history 0)))))))
+    ;; We're trying to get bits on the screen.
+    (cond ((dummy-pane-p pane)
+	   ;; Give everyone a chance to update the title bar
+	   (when (eql (pane-descriptor-type description) :title)
+	     (display-title frame pane)))
+	  (t
+	   (when *frame-layout-changing-p*
+	     (setq force-p t))
+	   (unless *sizing-application-frame*
+	     (unless (member pane (slot-value frame 'initialized-panes))
+	       (setq force-p t)
+	       (push pane (slot-value frame 'initialized-panes))))
+	   (with-simple-restart (nil "Skip redisplaying pane ~S" pane)
+	     (loop
+	       (with-simple-restart (nil "Retry displaying pane ~S" pane)
+		 (return
+		   (cond (display-function
+			  ;; If there's a display function, call it to generate new contents.
+			  (cond (incremental-redisplay
+				 (cond ((or (null redisplay-record) force-p)
+					(when force-p
+					  (window-clear pane))
+					(call-redisplay-function
+					  display-function frame pane))
+				       (t (redisplay redisplay-record pane))))
+				((or force-p
+				     (getf options :display-after-commands t))
+				 (unless (and (not force-p)
+					      (eq (getf options :display-after-commands)
+						  ':no-clear))
+				   (window-clear pane))
+				 (call-display-function display-function frame pane)))
+			  (force-output pane))
+			 (force-p
+			  ;; If refilling from scratch, give the application a chance
+			  ;; to draw stuff
+			  (frame-replay frame pane))
+			 ;; Otherwise do nothing, the bits will still be on display
+			 ;; and will be refreshed properly if there's a damage event.
+			 )))))))))
+
+;; Factored out of the above to avoid consing closures
+(defun call-redisplay-function (display-function frame pane &rest args)
+  (declare (dynamic-extent args))
+  (updating-output (pane)
+    (apply #'call-display-function display-function frame pane args)))
+
+(defun call-display-function (display-function frame pane &rest args)
+  (declare (dynamic-extent args))
+  (let* ((display-args
+	   (if (listp display-function) (rest display-function) nil))
+	 (display-function
+	   (if (listp display-function) (first display-function) display-function)))
+    ;; Cons as little as possible...
+    (cond ((and (null args) (null display-args))
+	   (funcall display-function frame pane))
+	  ((null display-args)
+	   (apply display-function frame pane args))
+	  ((null args)
+	   (apply display-function frame pane display-args))
+	  (t
+	   (apply display-function frame pane (nconc (copy-list args) display-args))))))
+
+
+;;; Enabling and disabling of commands
+
+(defmethod command-enabled (command-name (frame standard-application-frame))
+  (with-slots (disabled-commands) frame
+    (or *assume-all-commands-enabled*
+	(and (not (member command-name disabled-commands))
+	     (command-accessible-in-command-table-p
+	       command-name (frame-command-table frame))))))
+
+(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
+  (with-slots (disabled-commands) frame
+    (if enabled
+	(setf disabled-commands (delete command-name disabled-commands))
+        (push command-name disabled-commands))))
+
+#+CLIM-1-compatibility
+(progn
+(define-compatibility-function (command-enabled-p command-enabled)
+			       (command-name frame)
+  (command-enabled command-name frame))
+
+(define-compatibility-function (enable-command (setf command-enabled))
+			       (command-name frame)
+  (setf (command-enabled command-name frame) t))
+
+(define-compatibility-function (disable-command (setf command-enabled))
+  (setf (command-enabled command-name frame) nil))
+)	;#+CLIM-1-compatibility
diff --git a/pre-silica/defs-graphics-generics.lisp b/pre-silica/defs-graphics-generics.lisp
new file mode 100644
index 00000000..546c756b
--- /dev/null
+++ b/pre-silica/defs-graphics-generics.lisp
@@ -0,0 +1,504 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: defs-graphics-generics.lisp,v 1.4 91/03/26 12:47:54 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+(eval-when (compile load eval)
+
+;; NOTE: if you change this list of keywords, you also have to change the keyword arguments
+;; accepted by (CLOS:METHOD INVOKE-WITH-DRAWING-OPTIONS (DRAWING-STATE-MIXIN T))
+(defparameter *all-drawing-options*
+	      '(:ink :clipping-region :transformation
+		:line-style :line-unit :line-thickness :line-dashes
+		:line-joint-shape :line-cap-shape
+		:text-style :text-family :text-face :text-size))
+
+(defparameter *always-meaningful-drawing-options* '(:ink :clipping-region :transformation))
+
+(defparameter *drawing-option-subsets*
+	      '((:point          :line-style :line-thickness :line-unit)
+		(:line-cap       :line-style :line-thickness :line-unit
+				 :line-dashes :line-cap-shape)
+		(:line-joint     :line-style :line-thickness :line-unit
+				 :line-dashes :line-joint-shape)
+		(:line-joint-cap :line-style :line-thickness :line-unit
+				 :line-dashes :line-joint-shape :line-cap-shape)
+		(:text           :text-style :text-family :text-face :text-size)))
+
+(defun non-drawing-option-keywords (arglist)
+  (do ((l (cdr (member '&key arglist)) (cdr l))
+       (non-drawing-option-keywords nil)
+       k)
+      ((null l) non-drawing-option-keywords)
+    (setq k (cond ((atom (car l)) (intern (string (car l)) "KEYWORD"))
+		  ((atom (caar l)) (intern (string (caar l)) "KEYWORD"))
+		  (t (caaar l))))
+    (unless (member k *all-drawing-options*)
+      (push k non-drawing-option-keywords))))
+
+;;; Caller must stick &key in front
+;;; If drawing-options isn't nil, it's a list of the option keywords accepted.
+(defun all-drawing-options-lambda-list (drawing-options)
+  (mapcar #'(lambda (keyword) (intern (string keyword)))
+	  (cond ((null drawing-options) *all-drawing-options*)
+		((atom drawing-options)
+		 (append (or (cdr (assoc drawing-options *drawing-option-subsets*))
+			     (warn "~S was specified in :drawing-options but is not ~
+				    a known drawing-option subset."
+				   drawing-options))
+			 *always-meaningful-drawing-options*))
+		(t
+		 (dolist (option drawing-options)
+		   (unless (member option *all-drawing-options*)
+		     (warn "~S was specified in :drawing-options but ~
+			    is not a known drawing option."
+			   option)))
+		 (append drawing-options *always-meaningful-drawing-options*)))))
+
+)	;eval-when
+
+(defclass graphics-mixin (drawing-state-mixin) ())
+
+;;; Register this class.
+(define-stream-protocol graphics-mixin)
+
+(define-protocol-p-method graphics-stream-p graphics-mixin)
+
+(defmacro define-graphics-operation (name arglist &key arguments method-body drawing-options)
+  (let ((method-name (fintern "~A-~A" name 'method)))
+    (with-warnings-for-definition name define-graphics-operation
+      `(define-group ,name define-graphics-operation
+	 (defoperation ,method-name graphics-mixin 
+	   ((graphics-mixin graphics-mixin)
+	    ,@(remove '&key (flatten-arglist arglist))))
+	 ,(define-graphics-method name method-name arglist arguments method-body)
+	 ,(define-standard-graphics-operation-1 name method-name arglist
+						arguments drawing-options)
+	 ,(define-point-graphics-operation-1 name method-name arglist
+					     arguments drawing-options)
+	 ,(define-point-sequence-operation-1 name method-name arglist
+					     arguments drawing-options)))))
+
+(defmacro fix-points (&rest numbers)
+  `(progn ,@(do* ((numbers numbers (cdr numbers))
+		  (number (first numbers) (first numbers))
+		  (forms nil))
+		 ((null numbers) (nreverse forms))
+	      (push `(unless (integerp ,number)
+		       (setf ,number (floor ,number)))
+		    forms))
+	  (values)))
+
+(defmacro transform-points ((transform) &rest points)
+  (assert (evenp (length points)) ()
+	  "Points must be x/y pairs.  There are an odd number of elements in ~S"
+	  points)
+  (let ((xform '#:transform))
+    `(let ((,xform ,transform))
+       ,@(do* ((points points (cddr points))
+	       (x (first points) (first points))
+	       (y (second points) (second points))
+	       (forms nil))
+	      ((null points) (nreverse forms))
+	   (push `(multiple-value-setq (,x ,y)
+		    (transform-point* ,xform ,x ,y))
+		 forms))
+       (values))))
+
+;;; Update the points list in the reference.
+(defmacro transform-point-sequence (transform points-reference)
+  (let ((pts-sequence '#:points-sequence)
+	(pts-temp '#:points)
+	(original-pts-temp '#:original-points)
+	(xform '#:transform))
+    ;;--- is a run-time error check worth it?
+    `(let ((,pts-sequence ,points-reference)
+	   (,xform ,transform))
+       (assert (evenp (length ,pts-sequence)) ()
+	       "Points must be x/y pairs.  There are an odd number of elements in ~S"
+	       ,pts-sequence)
+       (setf ,points-reference
+	     (let* ((,pts-temp (copy-list ,pts-sequence))
+		    (,original-pts-temp ,pts-temp))
+	       (dorest (pt ,pts-sequence cddr)
+		 (let ((x (first pt))
+		       (y (second pt)))
+		   (multiple-value-bind (nx ny)
+		       (transform-point* ,xform x y)
+		     (setf (car ,pts-temp) nx
+			   ,pts-temp (cdr ,pts-temp)
+			   (car ,pts-temp) ny
+			   ,pts-temp (cdr ,pts-temp)))))
+	       ,original-pts-temp))
+	    (values))))
+
+(defmacro transform-distances ((transform) &rest distances)
+  (assert (evenp (length distances)) ()
+	  "Distances must be dx/dy pairs.  There are an odd number of elements in ~S"
+	  distances)
+  (let ((xform '#:transform))
+    `(let ((,xform ,transform))
+       ,@(do* ((distances distances (cddr distances))
+	       (dx (first distances) (first distances))
+	       (dy (second distances) (second distances))
+	       (forms nil))
+	      ((null distances) (nreverse forms))
+	   (push `(multiple-value-setq (,dx ,dy)
+		    (transform-distance ,xform ,dx ,dy))
+		 forms))
+       (values))))
+
+
+;;; Macro to write all the version of a drawing function
+;;; It also will write the drawing method in the simplest case.
+
+(defun define-graphics-method (drawing-function-name method-name arglist argument-specs method-body)
+  (declare (ignore drawing-function-name))
+  (let ((method-arglist `((stream graphics-mixin) ,@(remove '&key (flatten-arglist arglist)))))
+    ;; This writes the draw-foo-method.  By default, it will write a
+    ;; simple method body that transforms the args and calls the
+    ;; DRAW-FOO-INTERNAL method.  The caller can supply a method body,
+    ;; and that body had better wrap WITH-TRANSFORMED-ARGUMENTS around
+    ;; its call to DRAW-FOO-INTERNAL methods, if any.
+    `(defmethod ,method-name ,method-arglist
+       ;; Write a "customized" macro that knows how to transform the
+       ;; args for this drawing function.  The :method-body writer has
+       ;; to wrap this around any call to a DRAW-FOO-INTERNAL method.
+       (macrolet ((with-transformed-arguments (&body body)
+		    ;; Postpone drawing-state update until last minute
+		    `(progn
+		       ;; Transform the positions, ltrbs, position
+		       ;; sequences, and distances.
+		       ,@(write-transform-clauses ',argument-specs
+						  '(medium-transformation stream))
+		       ,@body)))
+	 (progn
+	   ,(or method-body
+		(error ":METHOD-BODY must be supplied.")))))))
+
+;;; Interprets the argument specs provided via the :arguments keyword to
+;;; define-graphics-operation and writes the appropriate coordinate
+;;; transform form.
+(defun write-transform-clauses (argument-specs transform)
+  (let ((clauses nil))
+    (dolist (spec argument-specs)
+      (case (first spec)
+	(point
+	  ;; The rest of the spec is a list of x/y pairs
+	  (assert (evenp (length (rest spec))) ()
+		  "Points must be listed in x/y pairs. ~S has an odd number of elements."
+		  (rest spec))
+	  (push `(transform-points (,transform) ,@(rest spec))
+		clauses))
+	(rectangle
+	  ;; The rest of the spec if a list of left/top/right/bottom 4-tuples.
+	  (assert (zerop (mod (length (rest spec)) 4)) ()
+		  "Rectangles must have four values, left top right bottom.  ~S"
+		  (rest spec))
+	  (push `(transform-points (,transform) ,@(rest spec))
+		clauses))
+	(point-sequence
+	  ;; Elements of REST are references containing lists of points.
+	  (dolist (ps (rest spec))
+	    ;; No compile-time ASSERTion.
+	    (push `(transform-point-sequence ,transform ,ps)
+		  clauses)))
+	(distance
+	  ;; The rest of the spec is a list of dx/dy pairs indicating a distance
+	  (assert (evenp (length (rest spec))) ()
+		  "Distances must be listed in dx/dy pairs. ~S has an odd number of elements."
+		  (rest spec))
+	  (push `(transform-distances (,transform) ,@(rest spec))
+		clauses))))
+    (nreverse clauses)))
+
+;;; Macro to write the DRAW-FOO-INTERNAL methods
+
+(defmacro adjust-for-viewport-and-margins (stream &rest points)
+  (assert (evenp (length points)) ()
+	  "Points must be x/y pairs.  There are an odd number of elements in ~S"
+	  points)
+  (let ((dx '#:dx)
+	(dy '#:dy))
+    `(multiple-value-bind (,dx ,dy)
+	 (drawing-surface-to-viewport-coordinates ,stream 0 0)
+       (translate-positions ,dx ,dy ,@points))))
+
+(defmacro with-stipple-offsets ((sx sy array stream) &body body)
+  (let ((vx '#:viewport-x)
+	(vy '#:viewport-y)
+	(sw '#:stipple-width)
+	(sh '#:stipple-height))
+    `(let ((,sx 0) 
+	   (,sy 0))
+       (when ,array
+	 (multiple-value-bind (,vx ,vy)
+	     (window-viewport-position* ,stream)
+	   (multiple-value-bind (,sw ,sh)
+	       (values-list (array-dimensions ,array))
+	     (translate-positions (mod ,vx ,sw) (mod ,vy ,sh) ,sx ,sy))))
+       ,@body)))
+
+(defmacro define-graphics-internal (name arglist
+				    &key points-to-convert point-sequence-to-convert
+					 bounding-rectangle
+					 highlighting-test highlighting-function
+					 output-recording-hook)
+  (when (and point-sequence-to-convert
+	     (null output-recording-hook))
+    ;; Since we're using NTRANSLATE below, we must avoid bashing user lists
+    (setq output-recording-hook
+	  `(setq ,point-sequence-to-convert (copy-list ,point-sequence-to-convert))))
+  (let* ((pass-on-arglist (make-pass-on-arglist arglist))
+	 (flat-arglist (flatten-arglist arglist))
+	 (class-name (fintern "~A-~A"
+			      (remove-word-from-string
+				"-internal" (remove-word-from-string "draw-" name))
+			      'displayed-output-record))
+	 (constructor-name (fintern "~A-~A" 'make class-name)))
+    `(;; define-group ,name define-graphics-internal ;; POS Genera
+      progn
+      (defgeneric ,name (stream x-offset y-offset ,@flat-arglist))
+      (defclass ,class-name
+		(output-record-element-mixin graphics-displayed-output-record)
+	  ,(mapcar #'(lambda (arg) `(,arg :initarg ,arg)) flat-arglist))       
+      (define-constructor-using-prototype-instance
+	,constructor-name ,class-name ,flat-arglist
+	,@(mapcar #'(lambda (arg) `(,arg ',arg ,arg)) flat-arglist))
+      ;; I'm too damned lazy to invent another protocol to hang this off of...
+      (defmethod ,name ((stream standard-encapsulating-stream) xoff yoff ,@arglist)
+	(,name (slot-value stream 'stream) xoff yoff ,@pass-on-arglist))
+      (defmethod ,name :around ((stream output-and-window-protocol-intermediary) 
+				x-offset y-offset ,@arglist)
+	(declare (type coordinate x-offset y-offset))
+	(adjust-for-viewport-and-margins stream x-offset y-offset)
+	(call-next-method stream x-offset y-offset ,@pass-on-arglist))
+      (defmethod replay-output-record ((record ,class-name) stream
+				       &optional region (x-offset 0) (y-offset 0))
+	;; Ignore the region and let MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION
+	;; take care of not calling REPLAY-OUTPUT-RECORD unnecessarily.  Too expensive here.
+	(declare (ignore region))
+	(declare (type coordinate x-offset y-offset))
+	(with-slots (,@flat-arglist) record
+	  (,name stream x-offset y-offset ,@flat-arglist)))
+      (defmethod ,name :around ((stream graphics-output-recording) x-offset y-offset
+				,@arglist)
+	(declare (ignore x-offset y-offset))
+	(when (stream-recording-p stream)
+	  ,output-recording-hook
+	  (multiple-value-bind (abs-x abs-y)
+	      (point-position*
+		(stream-output-history-position stream))
+	    (declare (type coordinate abs-x abs-y))
+	    ;; Adjust the coordinates by the position of the current record
+	    (let ((rec (,constructor-name ,@flat-arglist)))
+	      (multiple-value-bind (lf tp rt bt)
+		  (progn ,bounding-rectangle)
+		(declare (type coordinate lf tp rt bt))
+		(bounding-rectangle-set-edges
+		  rec
+		  (- lf abs-x) (- tp abs-y)
+		  (- rt abs-x) (- bt abs-y)))
+	      (multiple-value-bind (cx cy) (stream-cursor-position* stream)
+		(declare (type coordinate cx cy))
+		;; Doing this directly beats calling OUTPUT-RECORD-SET-START-CURSOR-POSITION*
+		(with-slots (start-x start-y) rec
+		  (setq start-x (- cx abs-x)
+			start-y (- cy abs-y)))
+		;; Adjust the stored coordinates by the current cursor position
+		,@(when points-to-convert
+		    `((with-slots (,@points-to-convert) rec
+			(translate-positions (- abs-x) (- abs-y) ,@points-to-convert))))
+		,@(when point-sequence-to-convert
+		    `((with-slots (,point-sequence-to-convert) rec
+			(setq ,point-sequence-to-convert
+			      (ntranslate-point-sequence (- abs-x) (- abs-y)
+							 ,point-sequence-to-convert))))))
+	      (stream-add-output-record stream rec))))
+	(when (stream-drawing-p stream)
+	  (call-next-method)))
+
+      ,@(when highlighting-test
+	  (let ((args (first highlighting-test))
+		(body (rest highlighting-test)))
+	    `((defmethod output-record-refined-sensitivity-test ((record ,class-name) ,@args)
+		,@body))))
+      ,@(when highlighting-function
+	  (let ((args (first highlighting-function))
+		(body (rest highlighting-function)))
+	    `((defmethod highlight-output-record-1 ((record ,class-name) ,@args)
+		,@body)))))))
+
+
+;;; Macro helpers to write the user-called drawing functions.
+
+;;; First some helper functions.
+
+;;; Extract the positional and &rest arguments from an arglist.
+(defun compute-pass-on (arglist)
+  (let ((pass-on nil))
+    (dolist (arg arglist)
+      (cond ((eql arg '&key)
+	     (return))
+	    (t (push arg pass-on))))
+    (nreverse pass-on)))
+
+;;; Splice in an "&rest .args." before the &key in an arglist.
+(defun add-&rest (arglist &optional (rest-arg-var '.args.))
+  (let ((pos-&key (position '&key arglist)))
+    (append (subseq arglist 0 pos-&key)
+	    `(&rest ,rest-arg-var)
+	    (when pos-&key
+	      (subseq arglist pos-&key)))))
+
+(defun apply-method-code (method-name stream pass-on args non-drawing-option-keywords)
+  `(if ,args
+       (flet ((trampoline ()
+		(,method-name ,stream ,@pass-on)))
+	 (declare (dynamic-extent #'trampoline))
+	 ,(if non-drawing-option-keywords
+	      `(with-keywords-removed (drawing-options ,args ',non-drawing-option-keywords)
+		 (apply #'invoke-with-drawing-options ,stream #'trampoline drawing-options))
+	      `(apply #'invoke-with-drawing-options ,stream #'trampoline ,args)))
+       (,method-name ,stream ,@pass-on)))
+
+;;; Writes the "standard" draw-foo* function, which takes separate X and Y arguments.
+(defun define-standard-graphics-operation-1 (name method-name arglist
+					     arguments drawing-options)
+  (declare (ignore arguments))
+  (let ((pass-on (remove '&key (flatten-arglist arglist)))
+	(fcn-args (add-&rest (append arglist
+				     (if (member '&key arglist)
+					 `(&allow-other-keys)
+					 `(&key &allow-other-keys)))
+			     '.args.))
+	;; Spread form is called DRAW-FOO*
+	(function-name (fintern "~A*" name)))
+    `(progn
+       (defun ,function-name (stream ,@fcn-args)
+	 (declare (dynamic-extent .args.))
+	 (declare (arglist stream
+			   ,@arglist
+			   ,@(unless (member '&key arglist) `(&key))
+			   ,@(all-drawing-options-lambda-list drawing-options)))
+	 ,(apply-method-code method-name 'stream pass-on '.args.
+			     (non-drawing-option-keywords arglist)))
+       ,(when (null (intersection arglist lambda-list-keywords))
+	  `(define-compiler-macro ,function-name (&whole form &rest args)
+	     (when (= (length args) (1+ ,(length arglist)))
+	       (return-from ,function-name
+		 `(,',method-name ,@args)))
+	     form)))))
+
+;;; Writes the draw-foo version, which spreads out the points into positions.
+(defun define-point-graphics-operation-1 (name method-name arglist arguments drawing-options)
+  ;; Turn adjacent args of type point into "point" arguments
+  (let ((point-arglist nil)
+	(point-associations nil)
+	(count 1)
+	(point-args (cdr (assoc 'point arguments))))
+    (when point-args
+      (do* ((args arglist (cdr args))
+	    (arg (first args) (first args)))
+	   ((null args) nil)
+	(let ((stuff (member arg point-args)))
+	  (cond ((and stuff
+		      (eql (second args) (second stuff)))
+		 (let ((point-varname
+			 (fintern "~A-~D" 'point count)))
+		   (incf count)
+		   (push `(,(first args) ,(second args) ,point-varname) point-associations)
+		   (push point-varname point-arglist))
+		 (setq args (cdr args)))
+		(t (push arg point-arglist)))))
+      (setq point-arglist
+	    (append (reverse point-arglist)
+		    (if (member '&key point-arglist)
+			`(&allow-other-keys)
+			`(&key &allow-other-keys))))
+      (setq point-arglist (add-&rest point-arglist '.args.))
+      ;; Structure-oriented version is called DRAW-FOO
+      (let ((function-name name))
+	(flet ((let-args ()
+		 (let ((args nil))
+		   (dolist (spec point-associations)
+		     (push (first spec) args)
+		     (push (second spec) args))
+		   (nreverse args)))
+	       (set-clauses ()
+		 (let ((clauses nil))
+		   (dolist (spec point-associations)
+		     (push `(setf ,(first spec) (point-x ,(third spec))) clauses)
+		     (push `(setf ,(second spec) (point-y ,(third spec))) clauses))
+		   (nreverse clauses))))
+	  `(defun ,function-name (stream ,@point-arglist)
+	     (declare (dynamic-extent .args.))
+	     (declare (arglist stream
+			       ,@(ldiff point-arglist (member '&rest point-arglist))
+			       &key ,@(cdr (member '&key arglist))
+				    ,@(all-drawing-options-lambda-list drawing-options)))
+	     (let (,@(let-args))
+	       ,@(set-clauses)
+	       ,(apply-method-code method-name 'stream (remove '&key (flatten-arglist arglist))
+				   '.args. (non-drawing-option-keywords arglist)))))))))
+
+;;; Writes the DRAW-FOO version for things that take an arg that is a
+;;; sequence of points/positions.
+(defun define-point-sequence-operation-1 (name method-name arglist arguments drawing-options)
+  ;; turn point-sequence (list of x&ys) args into sequences of points
+  ;; (inefficiently).
+  (let ((point-sequence-arglist nil)
+	(point-sequence-associations nil)
+	(count 1)
+	(point-sequence-args (cdr (assoc 'point-sequence arguments))))
+    (when point-sequence-args
+      (do* ((args arglist (cdr args))
+	    (arg (first args) (first args)))
+	   ((null args) nil)
+	(let ((stuff (member arg point-sequence-args)))
+	  (cond (stuff
+		 (let ((point-sequence-varname
+			 (fintern "~A-~D" 'point-sequence count)))
+		   (incf count)
+		   (push `(,(first args) ,point-sequence-varname) point-sequence-associations)
+		   (push point-sequence-varname point-sequence-arglist)))
+		(t (push arg point-sequence-arglist)))))
+      (setq point-sequence-arglist
+	    (append (reverse point-sequence-arglist)
+		    (if (member '&key point-sequence-arglist)
+			`(&allow-other-keys)
+			`(&key &allow-other-keys))))
+      (setq point-sequence-arglist (add-&rest point-sequence-arglist '.args.))
+      ;; Structure-oriented version is called DRAW-FOO
+      (let ((function-name name))
+	(flet ((let-args ()
+		 (let ((args nil))
+		   (dolist (spec point-sequence-associations)
+		     (push (first spec) args))
+		   (nreverse args)))
+	       (set-clauses ()
+		 (let ((clauses nil))
+		   (dolist (spec point-sequence-associations)
+		     (push `(do* ((points ,(second spec) (cdr points))
+				  (point (first points) (first points)))
+				 ((null points) (setq ,(first spec) (nreverse ,(first spec))))
+			      (push (point-x point) ,(first spec))
+			      (push (point-y point) ,(first spec)))
+			   clauses))
+		   (nreverse clauses))))
+	  `(defun ,function-name (stream ,@point-sequence-arglist)
+	     (declare (dynamic-extent .args.))
+	     (declare (arglist stream
+			       ,@(ldiff point-sequence-arglist
+					(member '&rest point-sequence-arglist))
+			       &key ,@(cdr (member '&key arglist))
+				    ,@(all-drawing-options-lambda-list drawing-options)))
+	     ,(ignore-arglist point-sequence-arglist)
+	     (let (,@(let-args))
+	       ,@(set-clauses)
+	       ,(apply-method-code method-name 'stream (remove '&key (flatten-arglist arglist))
+				   '.args. (non-drawing-option-keywords arglist)))))))))
diff --git a/pre-silica/drawing-state-mixin.lisp b/pre-silica/drawing-state-mixin.lisp
new file mode 100644
index 00000000..3a1fbc0c
--- /dev/null
+++ b/pre-silica/drawing-state-mixin.lisp
@@ -0,0 +1,165 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: drawing-state-mixin.lisp,v 1.4 91/03/26 12:47:56 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; Line Style
+
+(define-protocol-class line-style ())
+
+(defclass standard-line-style (line-style)
+    ((unit :type (member :normal :point)
+	   :initform :normal :initarg :unit
+	   :reader line-style-unit)
+     (thickness :type real
+		:initform 1 :initarg :thickness
+		:reader line-style-thickness)
+     (joint-shape :type (member :miter :bevel :round :none)
+		  :initform :miter :initarg :joint-shape
+		  :reader line-style-joint-shape)
+     (cap-shape :type (member :butt :square :round :no-end-point)
+		:initform :butt :initarg :cap-shape
+		:reader line-style-cap-shape)
+     (dashes :initform nil :initarg :dashes
+	     :reader line-style-dashes)
+     #+++ignore (initial-dash-phase :initform 0 :initarg :initial-dash-phase
+				    :reader line-style-initial-dash-phase)))
+
+(defmethod print-object ((line-style standard-line-style) stream)
+  (print-unreadable-object (line-style stream :type t :identity t)
+    (with-slots (unit thickness joint-shape cap-shape dashes) line-style
+      (format stream "Units ~(~A~), thickness ~D, joint ~(~A~), cap ~(~A~), dashes ~S"
+	      unit thickness joint-shape cap-shape dashes))))
+
+(defvar +default-line-style+ (make-instance 'standard-line-style))
+(defvar +dashed-line-styles+
+	(make-array 5 :initial-contents
+		        (list (make-instance 'standard-line-style :thickness 0 :dashes t)
+			      (make-instance 'standard-line-style :thickness 1 :dashes t)
+			      (make-instance 'standard-line-style :thickness 2 :dashes t)
+			      (make-instance 'standard-line-style :thickness 3 :dashes t)
+			      (make-instance 'standard-line-style :thickness 4 :dashes t))))
+(defvar +undashed-line-styles+
+	(make-array 5 :initial-contents
+		        (list (make-instance 'standard-line-style :thickness 0 :dashes nil)
+			      (make-instance 'standard-line-style :thickness 1 :dashes nil)
+			      (make-instance 'standard-line-style :thickness 2 :dashes nil)
+			      (make-instance 'standard-line-style :thickness 3 :dashes nil)
+			      (make-instance 'standard-line-style :thickness 4 :dashes nil))))
+
+(defun-inline make-line-style-1 (unit thickness dashes joint-shape cap-shape)
+  #+Genera (declare lt:(side-effects simple reducible))
+  (if (and (eql unit :normal)
+	   (eql joint-shape :miter)
+	   (eql cap-shape :butt)
+	   (integerp thickness) (<= 0 thickness 4)
+	   (or (eq dashes t) (eq dashes nil)))
+      ;; Cache the common case when only :DASHES and :THICKNESS are provided
+      (svref (if dashes +dashed-line-styles+ +undashed-line-styles+) thickness)
+      (make-instance 'standard-line-style
+		     :unit unit :thickness thickness :dashes dashes
+		     :joint-shape joint-shape :cap-shape cap-shape)))
+
+(defun make-line-style (&key (unit :normal) (thickness 1) (dashes nil)
+			     (joint-shape :miter) (cap-shape :butt))
+  #+Genera (declare lt:(side-effects simple reducible))
+  (make-line-style-1 unit thickness dashes joint-shape cap-shape))
+
+(setq +highlighting-line-style+ (make-line-style :thickness 1))
+
+(defmethod make-load-form ((line-style standard-line-style))
+  (with-slots (unit thickness joint-shape cap-shape dashes) line-style
+    `(make-line-style ,@(unless (eq unit :points) `(:unit ,unit))
+		      ,@(unless (= thickness 1) `(:thickness ,thickness))
+		      ,@(unless (eq joint-shape :miter) `(:joint-shape ,joint-shape))
+		      ,@(unless (eq cap-shape :butt) `(:cap-shape ,cap-shape))
+		      ,@(unless (eq dashes nil) `(:dashes ,dashes)))))
+
+
+(defclass drawing-state-mixin
+	  ()
+    ((ink :initform +foreground-ink+ :accessor medium-ink)
+     (transformation :initform +identity-transformation+ :accessor medium-transformation)
+     (transformed-clipping-region :initform +everywhere+)
+     (line-style :initform +default-line-style+ :accessor medium-line-style)
+     (+Y-upward-p :initform nil :accessor medium-+Y-upward-p)))
+
+(defmethod medium-clipping-region ((medium drawing-state-mixin))
+  (with-slots (transformation transformed-clipping-region) medium
+    (untransform-region transformation transformed-clipping-region)))
+
+(defmethod (setf medium-clipping-region) (clipping-region (medium drawing-state-mixin))
+  (with-slots (transformation transformed-clipping-region) medium
+    (setf transformed-clipping-region (transform-region transformation clipping-region)))
+  clipping-region)
+
+;; NOTE: if you change the keyword arguments accepted by this method, you
+;; also have to change the list of keywords in *ALL-DRAWING-OPTIONS*
+(defmethod invoke-with-drawing-options
+	   ((medium drawing-state-mixin) continuation
+	    &key ink clipping-region transformation
+		 line-style line-unit line-thickness (line-dashes nil dashes-p)
+		 line-joint-shape line-cap-shape
+		 (text-style nil text-style-p) (text-family nil text-family-p)
+		 (text-face nil text-face-p) (text-size nil text-size-p))
+  (with-slots ((medium-ink ink)
+	       (medium-transformation transformation)
+	       transformed-clipping-region
+	       (medium-line-style line-style)) medium
+    ;; Close the current output record if the drawing ink is changing
+    (unless (eq medium-ink ink)
+      (stream-close-text-output-record medium))
+    (let* ((saved-ink medium-ink)
+	   (saved-transformation medium-transformation)
+	   (saved-clipping-region transformed-clipping-region)
+	   (saved-line-style medium-line-style))
+      (unwind-protect
+	  (progn
+	    (when ink
+	      (setf medium-ink ink))
+	    (when transformation
+	      (setf medium-transformation
+		    (compose-transformations saved-transformation transformation)))
+	    (when clipping-region
+	      (setf transformed-clipping-region
+		    (region-intersection saved-clipping-region
+					 (transform-region medium-transformation
+							   clipping-region))))
+	    (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p)
+		   (when (null line-style)
+		     (setf line-style saved-line-style))
+		   (setf medium-line-style
+			 (make-line-style-1
+			   (or line-unit (line-style-unit line-style))
+			   (or line-thickness (line-style-thickness line-style))
+			   (if dashes-p line-dashes (line-style-dashes line-style))
+			   (or line-joint-shape (line-style-joint-shape line-style))
+			   (or line-cap-shape (line-style-cap-shape line-style)))))
+		  (line-style
+		   (setf medium-line-style line-style)))
+	    (when (or text-family-p text-face-p text-size-p)
+	      (if text-style-p
+		  (setq text-style (with-stack-list (style text-family text-face text-size)
+				     (merge-text-styles style text-style)))
+		  (setq text-style (make-text-style text-family text-face text-size)
+			text-style-p t)))
+	    (if text-style-p
+		(flet ((call-continuation (stream)
+			 (declare (ignore stream))
+			 (funcall continuation)))
+		  (declare (dynamic-extent #'call-continuation))
+		  (invoke-with-text-style medium #'call-continuation text-style medium))
+	        (funcall continuation)))
+	(setf medium-line-style saved-line-style)
+	(setf transformed-clipping-region saved-clipping-region)
+	(setf medium-transformation saved-transformation)
+	(setf medium-ink saved-ink)))))
+
+(defmethod invoke-with-drawing-options
+	   ((stream standard-encapsulating-stream) continuation
+	    &rest args &key &allow-other-keys)
+  (declare (dynamic-extent args))
+  (apply #'invoke-with-drawing-options (slot-value stream 'stream) continuation args))
diff --git a/pre-silica/genera-implementation.lisp b/pre-silica/genera-implementation.lisp
new file mode 100644
index 00000000..e65fe328
--- /dev/null
+++ b/pre-silica/genera-implementation.lisp
@@ -0,0 +1,1873 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: genera-implementation.lisp,v 1.4 91/03/26 12:48:48 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; Defined below
+(eval-when (compile load eval)
+  (proclaim '(special *sheet-device*))
+  #+IMach (proclaim '(special *small-sheet-device*)))
+
+(defconstant *alu-noop* boole-2)
+
+(defclass sheet-implementation-mixin
+	  ()
+     ((window :initarg :window)
+      (color-p :initform nil)
+      (embedded-p :initform nil)
+      (ink-cache :initform (make-ink-cache 16))))
+
+;;; Will these SAGE variables be present in all Genera worlds?
+;;; I don't want to have to figure out how many microns/pixel there are
+;;; for each screen type.
+(defmethod implementation-pixels-per-point ((stream sheet-implementation-mixin))
+  (/ sage::*microns-per-point* sage:*microns-per-screen-pixel*))
+
+(defmethod window-erase-viewport ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (when (window-drawing-possible stream)
+      (scl:send window :clear-window))))
+
+(defmethod window-clear-area ((stream sheet-implementation-mixin) left top right bottom)
+  ;; In sheet window coordinates, basically
+  (with-slots (window) stream
+    (when (window-drawing-possible stream)
+      (scl:send window :draw-rectangle (- right left) (- bottom top) left top
+		(scl:send window :erase-aluf)))))
+
+(defmethod window-visibility ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (scl:send window :exposed-p)))
+
+(defmethod (setf window-visibility) (visibility (stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    ;; visibility is a boolean
+    (if visibility
+	;; this isn't quite right, because activating it means it's now buried??
+	(scl:send window :expose)
+	(scl:send window :deactivate))
+    visibility))
+
+(defmethod wait-for-window-exposed ((window sheet-implementation-mixin))
+  (unless (window-visibility window)
+    (scl:process-wait "Await exposure" #'window-visibility window)))
+
+(defmethod window-drawing-possible ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    ;; tv:sheet-output-held-p, except that temp-locking only delays drawing,
+    ;; it doesn't make it impossible, so only look at the output-hold flag
+    (or (zerop (tv:sheet-output-hold-flag window))
+	(tv:sheet-screen-array window))))
+
+(defmethod window-stack-on-top ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (unless (scl:send window :exposed-p)
+      (scl:send window :expose))
+    (let ((screen (tv:sheet-screen window))
+	  (console (tv:sheet-console window))
+	  (mouse (tv:sheet-mouse window)))
+      ;; SCREEN-MANAGE-AUTOEXPOSE-INFERIORS doesn't reliably select a window
+      ;; that fills the entire screen
+      (let ((sw (tv:console-selected-window console)))
+	(unless (and sw (atom (tv:sheet-lock sw)))
+	  (scl:send window :select)))
+      (scl:send screen :screen-select)
+      (unless (eq screen (tv:sheet-screen (tv:mouse-sheet mouse)))
+	(tv:mouse-set-sheet screen)))))
+
+(defmethod window-stack-on-bottom ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (scl:send window :bury)))
+
+(defmethod close ((stream sheet-implementation-mixin) &key abort)
+  (declare (ignore abort))
+  (with-slots (window) stream
+    (if (eq window (scl:send window :screen)) ; if this is a screen.
+	(mapc #'close (window-children stream))
+	(scl:send window :kill))))
+
+(defmethod bounding-rectangle-set-edges :after
+	   ((stream sheet-implementation-mixin) left top right bottom)
+  (with-slots (window) stream
+    (let ((superior (tv:sheet-superior window)))
+      (when t ; (null (tv:sheet-superior superior))	;root-p
+	(multiple-value-bind (wl wt wr wb)
+	    (scl:send superior :inside-edges)
+	  (declare (ignore wr wb))
+	  (translate-positions wl wt left top right bottom))))
+    (scl:send window :set-edges left top right bottom)))
+
+(defmethod bounding-rectangle-set-position* :after
+	   ((stream sheet-implementation-mixin) new-left new-top)
+  (with-slots (window) stream
+    (let ((superior (tv:sheet-superior window)))
+      (when t ; (null (tv:sheet-superior superior))	;root-p
+	(multiple-value-bind (wl wt)
+	    (scl:send superior :inside-edges)
+	  (translate-positions wl wt new-left new-top))))
+    (scl:send window :set-position new-left new-top)))
+
+(defmethod bounding-rectangle-set-size :after
+	   ((stream sheet-implementation-mixin) width height)
+  (with-slots (window) stream
+    (multiple-value-bind (wl wt wr wb)
+	(scl:send window :inside-edges)
+      (setq wr (+ wl width)
+	    wb (+ wt height))
+      (scl:send window :set-edges wl wt wr wb))))
+
+(defmethod stream-force-output ((stream sheet-implementation-mixin))
+  ;; yikes!!  Don't charge the screen-manager overhead to the caller!
+  #+Ignore
+  (with-slots (window) stream
+    (tv:screen-manage-window-area window)))
+
+(defmethod stream-clear-output ((stream sheet-implementation-mixin))
+  )
+
+(defmethod stream-finish-output ((stream sheet-implementation-mixin))
+  ;; kludge after kludge
+  (stream-force-output stream))
+
+(defmethod redisplay-decorations ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (when (window-drawing-possible stream)
+      (scl:send window :refresh-margins))))
+
+(defmethod window-refresh ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (scl:send window :refresh)))
+
+(defun clim-label->genera-label (label-spec stream)
+  (when label-spec
+    (let (label label-text-style character-style)
+      (setq label (cond ((stringp label-spec) label-spec)
+			(t (first label-spec))))
+
+      (setq label-text-style
+	    (cond ((stringp label-spec)
+		   (stream-merged-text-style stream))
+		  ((getf (rest label-spec) :text-style))
+		  (t (stream-merged-text-style stream))))
+
+      (setq character-style
+	    (si:intern-character-style :device-font
+				       (tv:font-name 
+					 (text-style-mapping
+					   (slot-value stream 'display-device-type)
+					   *standard-character-set*
+					   label-text-style
+					   (slot-value stream 'window)))
+				       :normal))
+      `(:string ,label :character-style ,character-style))))
+
+;;; A label is either a string or a list of the form (string :text-style style).
+(defmethod (setf window-label) :after (new-label (stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (multiple-value-bind (old-width old-height)
+	(scl:send window :inside-size)
+      (let ((genera-label (clim-label->genera-label new-label stream)))
+	(scl:send window :set-label genera-label))
+      (ignore-errors
+	(scl:send window :set-inside-size old-width old-height)))))
+
+(defmethod window-label-size ((stream sheet-implementation-mixin)
+			      &optional (label (window-label stream)))
+  (cond ((null label)
+	 (values 0 0))
+	(t (dw::margin-label-size (clim-label->genera-label label stream)
+				  (slot-value stream 'window)))))
+
+(defmethod window-margins ((stream sheet-implementation-mixin))
+  stream
+  (values 0 0 0 0))
+
+(defmethod host-window-margins ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (scl:send window :margins)))
+
+(defmethod window-beep ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (scl:send window :beep)))
+
+(defmethod window-flush-update-region ((stream sheet-implementation-mixin))
+  (with-slots (update-region) stream
+    (setf update-region nil)))
+
+(defmethod window-process-update-region ((stream sheet-implementation-mixin))
+  (with-slots (update-region) stream
+    (when update-region
+      (multiple-value-bind (vx vy)
+	  (window-viewport-position* stream)
+	(dolist (rectangle update-region)
+	  (with-bounding-rectangle* (left top right bottom) rectangle
+	    (translate-positions (- vx) (- vy) left top right bottom)
+	    (window-clear-area stream left top right bottom)))))))
+
+(defmethod window-shift-visible-region :after ((stream sheet-implementation-mixin)
+					       old-left old-top old-right old-bottom
+					       new-left new-top new-right new-bottom)
+  (let ((rectangles (ltrb-difference new-left new-top new-right new-bottom
+				     old-left old-top old-right old-bottom)))
+    (setf (slot-value stream 'update-region) rectangles)))
+
+;; Does this want to be an :after method?  Will the primary method on
+;; window-stream ever want to do anything else?
+(defmethod stream-set-input-focus ((stream sheet-implementation-mixin))
+  (with-slots (window) stream
+    (prog1 (sys:console-selected-window (tv:sheet-console window))
+	   ;; :select-relative ?
+	   (scl:send window :select))))
+
+(defmethod stream-restore-input-focus ((stream sheet-implementation-mixin)
+				       old-focus)
+  (with-slots (window) stream
+    (unless (eq old-focus window)
+      (if (eq (scl:send old-focus :alias-for-selected-windows)
+	      (scl:send window :alias-for-selected-windows))
+	  (scl:send old-focus :select-relative)
+	  (scl:send window :deselect t)))))
+
+(defmethod copy-area ((stream sheet-implementation-mixin)
+		      from-left from-top from-right from-bottom
+		      to-left to-top)
+  (with-slots (window) stream
+    (when (window-drawing-possible stream)
+      (fix-points from-left from-top from-right from-bottom to-left to-top)
+      ;; coords in "host" coordinate system
+      (let ((width (- from-right from-left))
+	    (height (- from-bottom from-top)))
+	(when (>= to-left from-left)
+	  ;; shifting to the right
+	  (setq width (- (abs width))))
+	(when (>= to-top from-top)
+	  (setq height (- (abs height))))
+	(scl:send window :bitblt-within-sheet
+			 tv:alu-seta width height
+			 from-left from-top
+			 to-left to-top)))))
+
+(defmethod notify-user-1 ((stream sheet-implementation-mixin)
+			  frame format-string &rest format-args)
+  (declare (ignore frame) (dynamic-extent format-args))
+  (apply #'tv:notify (slot-value stream 'window) format-string format-args))
+
+
+;;;; Translation between CLIM and Genera graphics model
+
+;;; We cache the translation of the most recently used inks in a small array,
+;;; using a property-list masquerade for quick lookup.  When a cache element
+;;; is replaced, any temporary resources used by the translation are returned
+;;; (temporary rasters are currently the only examples).
+(defun make-ink-cache (size)
+  (let ((array (make-array size :fill-pointer t)))
+    (setf (sys:%p-cdr-code (scl:locf (aref array (1- size)))) sys:cdr-nil)
+    (values array)))
+
+(defun-inline ink-cache-lookup (cache ink)
+  (getf (sys:%make-pointer sys:dtp-list (scl:locf (aref cache 0))) ink))
+
+(defun ink-cache-replace (cache ink value)
+  (let ((index (fill-pointer cache)))
+    (when (<= (array-total-size cache) index)
+      (setq index 0))
+    ;; Deallocate the previous temporary rasters
+    (let ((value (aref cache (1+ index))))
+      (when (listp value)
+	(dolist (element value)
+	  (when (sixth element)
+	    (tv:deallocate-temporary-sheet-bit-raster (first element))))))
+    (setf (aref cache index) ink)
+    (setf (aref cache (1+ index)) value)
+    (setf (fill-pointer cache) (+ index 2))
+    value))
+
+(defun-inline follow-indirect-ink (ink stream)
+  (cond ((eq ink +foreground-ink+) (medium-foreground stream))
+	((eq ink +background-ink+) (medium-background stream))
+	(t ink)))
+
+(defmethod sheet-decode-color (ink stream &optional (stipple-p t))
+  (declare (ignore stipple-p stream))
+  (error "Expected ~S to be a color.  This may be due to an implementation limitation." ink))
+
+(defun sheet-decode-luminance (luminance stipple-p)
+  (macrolet ((stipple (height width patterns)
+	       `(quote ((,(graphics::make-stipple height width patterns)
+			 ,boole-set ,boole-clr)))))
+    (if (not stipple-p)
+	(if (< luminance 0.5) boole-set boole-clr)
+      (sys:selector luminance <
+	(0.05 boole-set)
+	(0.1 (stipple 8 16 #b(0111111111111111
+			      1111110111111111
+			      1111111111110111
+			      1101111111111111
+			      1111111101111111
+			      1111111111111101
+			      1111011111111111
+			      1111111111011111)))
+	(0.2 (stipple 8 8 #b(01111111
+			     11101111
+			     11111101
+			     10111111
+			     11110111
+			     11111110
+			     11011111
+			     11111011)))
+	(0.3 (stipple 4 4 #b(0111 1101 1011 1110)))
+	(0.4 (stipple 3 3 #b(011 101 110)))
+	(0.6 (stipple 2 2 #b(01 10)))
+	(0.7 (stipple 3 3 #b(100 010 001)))
+	(0.8 (stipple 4 4 #b(1000 0010 0100 0001)))
+	(0.9 (stipple 8 8 #b(10000000
+			     00010000
+			     00000010
+			     01000000
+			     00001000
+			     00000001
+			     00100000
+			     00000100)))
+	(0.95 (stipple 8 16 #b(1000000000000000
+			       0000001000000000
+			       0000000000001000
+			       0010000000000000
+			       0000000010000000
+			       0000000000000010
+			       0000100000000000
+			       0000000000100000)))
+	(otherwise boole-clr)))))
+
+(defmethod sheet-decode-color ((ink gray-color) stream &optional (stipple-p t))
+  (with-slots (color-p window) stream
+    (let ((luminance (slot-value ink 'clim-utils::luminance))
+	  (invert-p (not (funcall (tv:sheet-screen window) :bow-mode))))
+      (cond ((= luminance 0.0) (if invert-p boole-clr boole-set))
+	    ((= luminance 1.0) (if invert-p boole-set boole-clr))
+	    ((not color-p)
+	     (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) stipple-p))
+	    (t
+	     (funcall (tv:sheet-screen window) :compute-rgb-alu boole-1
+		      luminance luminance luminance (not invert-p)))))))
+
+(defmethod sheet-decode-color ((ink color) stream &optional (stipple-p t))
+  (with-slots (color-p window) stream
+    (multiple-value-bind (r g b)
+	(color-rgb ink)
+      (let ((invert-p (not (funcall (tv:sheet-screen window) :bow-mode))))
+	(if (not color-p)
+	    (let ((luminance (color-luminosity r g b)))
+	      (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) stipple-p))
+	  (funcall (tv:sheet-screen window) :compute-rgb-alu boole-1
+		   r g b (not invert-p)))))))
+
+(defmethod sheet-decode-color ((ink flipping-ink) stream &optional (stipple-p t))
+  (declare (ignore stipple-p))
+  (with-slots (color-p window) stream
+    (if (not color-p)
+	(values boole-xor)
+      (multiple-value-bind (design1 design2)
+	  (decode-flipping-ink ink)
+	(let ((ink1 (follow-indirect-ink design1 stream))
+	      (ink2 (follow-indirect-ink design2 stream)))
+	  ;; Genera substrate can get confused about this...
+	  (if (or (and (eq ink1 +black+) (eq ink2 +white+))
+		  (and (eq ink1 +white+) (eq ink2 +black+)))
+	      (values boole-xor)
+	    (values
+	      (funcall (tv:sheet-screen window) :exchange-two-colors-aluf
+		       (sheet-decode-color (follow-indirect-ink design1 stream) stream)
+		       (sheet-decode-color (follow-indirect-ink design2 stream) stream)))))))))
+
+(defmethod sheet-decode-color ((ink standard-opacity) stream &optional (stipple-p t))
+  (declare (ignore stream stipple-p))
+  (if (> (slot-value ink 'clim-utils::value) 0.5) boole-1 boole-2))
+
+(defun sheet-decode-raster (raster &optional width height key tiled-p)
+  (multiple-value-bind (swidth sheight)
+      (sys:decode-raster-array raster)
+    (let ((dwidth (if tiled-p (lcm width 32) (* (ceiling (1- width) 32) 32))))
+      (if (and (= swidth dwidth)
+	       (= (sys:array-type-field raster) sys:art-1b))
+	  (values raster)
+	(let ((source raster)
+	      (destination (tv:make-temporary-sheet-bit-raster #*1010 dwidth height)))
+	  (declare (sys:array-register-1d source destination))
+	  ;; If the tiling is going to leave gaps, we need to zero the destination first
+	  (when (or (/= width swidth) (/= height sheight))
+	    (si:fill-array destination nil 0))
+	  (do ((i 0 (1+ i))
+	       (si 0 (+ si swidth))
+	       (di 0 (+ di dwidth)))
+	      ((= i (min height sheight)))
+	    (do ((offset 0 (+ offset width)))
+		((>= offset dwidth))
+	      (let* ((s si)
+		     (d (+ di offset))
+		     (w (min (- dwidth offset) swidth)))
+		(cond ((null key)
+		       (sys:copy-array-portion source s (+ s w)
+					       destination d (+ d w)))
+		      ((integerp key)
+		       (dotimes (ii w)
+			 (declare (ignore ii))
+			 (setf (aref destination d) (if (= (aref source s) key) 1 0))
+			 (incf s)
+			 (incf d)))))))
+	  (values destination))))))
+
+(defmethod sheet-decode-pattern ((ink pattern) stream &optional width height tiled-p)
+  (multiple-value-bind (array designs)
+      (decode-pattern ink)
+    (let ((width (or width (array-dimension array 1)))
+	  (height (or height (array-dimension array 0))))
+      (if (= (length designs) 2)
+	  (let ((raster (sheet-decode-raster array width height nil tiled-p)))
+	    (list
+	      (list raster
+		    (sheet-decode-color
+		      (follow-indirect-ink (aref designs 1) stream) stream nil)
+		    (sheet-decode-color
+		      (follow-indirect-ink (aref designs 0) stream) stream nil)
+		    (and (not tiled-p) width)
+		    (and (not tiled-p) height)
+		    (not (eq raster array)))))
+	(do* ((result (make-list (length designs)))
+	      (i 0 (1+ i))
+	      (l result (cdr l)))
+	     ((null l) result)
+	  (setf (car l) (list (sheet-decode-raster array width height i tiled-p)
+			      (sheet-decode-color
+				(follow-indirect-ink (aref designs i) stream) stream nil)
+			      (if (zerop i) boole-clr boole-2)
+			      (and (not tiled-p) width)
+			      (and (not tiled-p) height)
+			      t)))))))
+
+(defmethod sheet-decode-pattern ((ink design) stream &optional width height tiled-p)
+  (declare (ignore stream width height tiled-p))
+  (error "Arbitrary patterned designs are not supported in this CLIM implementation"))
+
+(defmethod sheet-decode-pattern ((ink color) stream &optional width height tiled-p)
+  (declare (ignore stream width height tiled-p))
+  (error "A pattern must be a bounded design, ~S isn't" ink))
+
+(defmethod sheet-decode-ink ((ink color) stream)
+  (sheet-decode-color ink stream))
+
+(defmethod sheet-decode-ink ((ink flipping-ink) stream)
+  (sheet-decode-color ink stream))
+
+(defmethod sheet-decode-ink ((ink contrasting-ink) stream)
+  (if (slot-value stream 'color-p)
+      (sheet-decode-color (make-color-for-contrasting-ink ink) stream)
+    ;; More efficient than (SHEET-DECODE-COLOR (MAKE-GRAY-COLOR-FOR-CONTRASTING-INK INK))
+    (let ((luminance (with-slots (clim-utils::which-one clim-utils::how-many) ink
+		       (/ clim-utils::which-one clim-utils::how-many)))
+	  (invert-p (not (funcall (tv:sheet-screen (slot-value stream 'window)) :bow-mode))))
+      (cond ((= luminance 0.0) (if invert-p boole-clr boole-set))
+	    ((= luminance 1.0) (if invert-p boole-set boole-clr))
+	    (t
+	     (sheet-decode-luminance (if invert-p (- 1.0 luminance) luminance) t))))))
+
+(defmethod sheet-decode-ink ((ink pattern) stream)
+  (sheet-decode-pattern ink stream))
+
+(defmethod sheet-decode-ink ((ink rectangular-tile) stream)
+  (multiple-value-bind (pattern width height)
+      (decode-rectangular-tile ink)
+    (sheet-decode-pattern pattern stream width height t)))
+
+(defmethod sheet-decode-ink ((ink stencil) stream)
+  (declare (ignore stream))
+  (error "Stencils and opacities are not supported in this CLIM implementation"))
+
+(defmethod sheet-decode-ink ((ink composite-in) stream)
+  (declare (ignore stream))
+  (error "Compositing is not supported in this CLIM implementation"))
+
+(defmethod sheet-decode-ink ((ink composite-out) stream)
+  (declare (ignore stream))
+  (error "Compositing is not supported in this CLIM implementation"))
+
+(flavor:defgeneric with-clim-drawing-state (drawing-state ones-alu zeros-alu
+					    thickness dashes line-style pattern
+					    continuation &rest arguments)
+  (:inline-methods :recursive)
+  (:optimize speed))
+
+(flavor:defmethod (with-clim-drawing-state graphics::raster-drawing-state :before)
+		  (ones-alu zeros-alu thickness dashes line-style pattern
+		   continuation &rest arguments)
+  (declare (ignore thickness dashes line-style continuation arguments))
+  (setq graphics::source-pattern pattern)
+  (setq graphics::ones-alu ones-alu)
+  (setq graphics::zeros-alu zeros-alu))
+
+(flavor:defmethod (with-clim-drawing-state graphics::drawing-state)
+		  (ones-alu zeros-alu thickness dashes line-style pattern
+		   continuation &rest arguments)
+  (declare (ignore zeros-alu))
+  (setq graphics::alu ones-alu)
+  (setq graphics::thickness thickness)
+  (setq graphics::scale-thickness nil)
+  (when (not (null line-style))
+    (setq graphics::dashed (not (null dashes)))
+    (setq graphics::dash-pattern dashes)
+    (setq graphics::line-end-shape (line-style-cap-shape line-style))
+    (setq graphics::line-joint-shape (line-style-joint-shape line-style)))
+  (setq graphics::stipple pattern)
+  (setq graphics::scan-conversion-flags
+	(dpb 1 graphics::%%scan-conversion-host-allowed
+	     (dpb 1 graphics::%%scan-conversion-round-coordinates 0)))
+  #+IMach
+  ;; MacIvories are wierd
+  (when (sys:system-case (:macivory t) (otherwise nil))
+    (setq graphics::color nil graphics::gray-level 1)
+    (when (not (null pattern))
+      (if (let ((width (array-dimension pattern 1))
+		(height (array-dimension pattern 0)))
+	    (and (<= height 8)
+		 (or (= width 32) (<= width 8))))
+	  (setq graphics::stipple pattern)
+	(setf graphics::scan-conversion-flags
+	      (dpb 0 graphics::%%scan-conversion-host-allowed
+		   (dpb 1 graphics::%%scan-conversion-round-coordinates 0))))))
+  (setf (ldb graphics::%%drawing-state-new-parameters graphics::flags) 0)
+  (apply continuation arguments))
+
+;;; The easy continuation is called for simple drawing operations without patterning
+;;; or line style options unsupported by the old Genera window system operations.
+(defmethod with-appropriate-drawing-state
+	   ((stream sheet-implementation-mixin) ink line-style easy hard)
+  (let ((alu (with-slots (ink-cache) stream
+	       (let ((ink (follow-indirect-ink ink stream)))
+		 (or (ink-cache-lookup ink-cache ink)
+		     (ink-cache-replace ink-cache ink (sheet-decode-ink ink stream)))))))
+    (multiple-value-bind (thickness dashes)
+	(if (null line-style)
+	    (values 0 nil)
+	  (values (or (line-style-thickness line-style) 0)
+		  (let ((dashes (line-style-dashes line-style)))
+		    (if (eq dashes t) #(10 10) dashes))))
+      ;; There's no way to get the ALU canonicalization done in a whopper or wrapper
+      ;; without incurring extraordinary performance penalties, so...
+      (macrolet ((with-drawing-state-kludge (drawing-state ones-alu zeros-alu
+					     thickness dashes line-style raster
+					     continuation window)
+		   `(multiple-value-bind (ones-alu zeros-alu)
+			(if (not (and (integerp ,ones-alu) (integerp ,zeros-alu)))
+			    (values ,ones-alu ,zeros-alu)
+			  ;; This is boolean magic to construct a new alu code which
+			  ;; combines the effects of doing a DRAW-xx with ONES-ALU
+			  ;; everywhere there is a 1 in the source and that of doing a
+			  ;; DRAW-xx with ZEROS-ALU everywhere there is a 0 in the
+			  ;; source.
+			  (values (logior (logand ,ones-alu #b0101)
+					  (scl:rot (logand ,zeros-alu #b0101) 1))
+				  ,zeros-alu))
+		      (with-clim-drawing-state ,drawing-state ones-alu zeros-alu
+					       ,thickness ,dashes ,line-style ,raster
+					       ,continuation ,window))))
+	(labels ((kernel (window)
+		   (declare (sys:downward-function))
+		   (if (listp alu)
+		       (dolist (element alu)
+			 (sys:destructuring-bind (raster ones-alu zeros-alu) element
+			   (with-drawing-state-kludge (graphics::get-drawing-state window)
+						      ones-alu zeros-alu
+						      thickness dashes line-style raster
+						      hard window)))
+		     (if (and easy
+			      (not (slot-value stream 'embedded-p))
+			      (null dashes)
+			      (<= thickness 1))
+			 (funcall easy window alu)
+		       (with-drawing-state-kludge (graphics::get-drawing-state window)
+						  alu boole-2
+						  thickness dashes line-style nil
+						  hard window)))))
+	  (with-slots (window) stream
+	    (let ((clipping-region (slot-value stream 'transformed-clipping-region)))
+	      (if (eq clipping-region +everywhere+)
+		  (kernel window)
+		(with-bounding-rectangle* (left top right bottom) clipping-region
+		  (with-stack-list (cr (+ (tv:sheet-left-margin-size window) left)
+				       (+ (tv:sheet-top-margin-size window) top)
+				       (+ (tv:sheet-right-margin-size window) right)
+				       (+ (tv:sheet-bottom-margin-size window) bottom))
+		    (scl:letf (((tv:sheet-clipping-region window) cr))
+		      (kernel window))))))))))))
+
+
+;;;; Drawing primitives
+
+(defmacro round-points (&rest numbers)
+  `(progn ,@(do* ((numbers numbers (cdr numbers))
+		  (number (first numbers) (first numbers))
+		  (forms nil))
+		 ((null numbers) (nreverse forms))
+	      (push `(unless (integerp ,number)
+		       (setf ,number (round ,number)))
+		    forms))
+	  (values)))
+
+(defmethod draw-point-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				x y ink line-style)
+  (when (window-drawing-possible stream)
+    (round-points x y)
+    (translate-positions x-offset y-offset x y)
+    (with-appropriate-drawing-state stream ink line-style
+      #'(lambda (window alu)
+	  (declare (sys:downward-function))
+	  (funcall window :draw-point x y alu))
+      #'(lambda (window)
+	  (declare (sys:downward-function))
+	  (funcall (flavor:generic graphics:draw-point) window x y)))))
+
+(defmethod draw-line-internal ((stream sheet-implementation-mixin) x-offset y-offset
+			       start-x start-y end-x end-y ink line-style)
+  (when (window-drawing-possible stream)
+    (round-points start-x start-y end-x end-y)
+    (translate-positions x-offset y-offset start-x start-y end-x end-y)
+    (with-appropriate-drawing-state stream ink line-style
+      #'(lambda (window alu)
+	  (declare (sys:downward-function))
+	  (funcall window :draw-line start-x start-y end-x end-y alu t))
+      #'(lambda (window)
+	  (declare (sys:downward-function))
+	  (funcall (flavor:generic graphics:draw-line) window start-x start-y end-x end-y)))))
+
+(defmethod draw-rectangle-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				    left top right bottom ink line-style)
+  (when (window-drawing-possible stream)
+    (round-points left top right bottom)
+    (translate-positions x-offset y-offset left top right bottom)
+    (if (and (null line-style)
+	     (typep ink 'pattern))
+	;; Looks like this is DRAW-ICON*
+	(draw-icon-internal stream left top right bottom ink)
+	(with-appropriate-drawing-state stream ink line-style
+	  #'(lambda (window alu)
+	      (declare (sys:downward-function))
+	      (if (null line-style)
+		  (let ((width (abs (- right left)))
+			(height (abs (- bottom top))))
+		    (funcall window :draw-rectangle width height left top alu))
+		  (scl:stack-let ((lines (vector right top left top
+						 left top left bottom
+						 left bottom right bottom
+						 right bottom right top)))
+		    (funcall window :draw-multiple-lines lines alu nil))))
+	  #'(lambda (window)
+	      (declare (sys:downward-function))
+	      (funcall (flavor:generic graphics:draw-rectangle) window left top right bottom
+		       :filled (null line-style)))))))
+
+;; Fall back to DRAW-IMAGE.  INK will be a pattern.
+;;--- We have to resort to this because Genera always tiles.  Sigh.
+(defmethod draw-icon-internal ((stream sheet-implementation-mixin) left top right bottom ink)
+  (with-slots (window ink-cache) stream
+    (let* ((width  (- right left))
+	   (height (- bottom top))
+	   (alus (or (ink-cache-lookup ink-cache ink)
+		     (ink-cache-replace ink-cache ink (sheet-decode-ink ink stream)))))
+      (assert (= (length alus) 1) ()
+	      "CLIM only supports bitmap icons under Genera sheets")
+      (dolist (alu alus)
+	(let ((image (pop alu)))
+	  (graphics:draw-image image left top
+			       :image-right width :image-bottom height
+			       :stream window))))))
+
+(defmethod draw-polygon-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				  points closed ink line-style)
+  (macrolet ((pop-x (p)
+	       `(let ((x (pop ,p)))
+		  (+ (if (integerp x) x (round x)) x-offset)))
+	     (pop-y (p)
+	       `(let ((y (pop ,p)))
+		  (+ (if (integerp y) y (round y)) y-offset))))
+    (when (window-drawing-possible stream)
+      (let ((npoints (length points)))
+	(with-appropriate-drawing-state stream ink line-style
+	  #'(lambda (window alu)
+	      (declare (sys:downward-function))
+	      (if (null line-style)
+		  (case npoints
+		    (6 (let* ((p points)
+			      (x1 (pop-x p)) (y1 (pop-y p))
+			      (x2 (pop-x p)) (y2 (pop-y p))
+			      (x3 (pop-x p)) (y3 (pop-y p)))
+			 (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu)))
+		    (8 (let* ((p points)
+			      (x1 (pop-x p)) (y1 (pop-y p))
+			      (x2 (pop-x p)) (y2 (pop-y p))
+			      (x3 (pop-x p)) (y3 (pop-y p))
+			      (x4 (pop-x p)) (y4 (pop-y p)))
+			 (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu)
+			 (funcall window :draw-triangle x3 y3 x4 y4 x1 y1 alu)))
+		    (otherwise
+		      (with-stack-array (translated-points npoints)
+			(do ((i 0)
+			     (p points))
+			    ((null p))
+			  (setf (aref translated-points (shiftf i (1+ i))) (pop-x p))
+			  (setf (aref translated-points (shiftf i (1+ i))) (pop-y p)))
+			(graphics::triangulate-polygon
+			  #'(lambda (x1 y1 x2 y2 x3 y3)
+			      (funcall window :draw-triangle x1 y1 x2 y2 x3 y3 alu))
+			  translated-points))))
+		  (with-stack-array (lines (* (+ npoints (if closed 0 -2)) 2))
+		    (let* ((p points)
+			   (i 0)
+			   (initial-x (pop-x p))
+			   (initial-y (pop-y p))
+			   (x initial-x)
+			   (y initial-y))
+		      (loop
+			(setf (aref lines (shiftf i (1+ i))) x)
+			(setf (aref lines (shiftf i (1+ i))) y)
+			(setf (aref lines (shiftf i (1+ i))) (setq x (pop-x p)))
+			(setf (aref lines (shiftf i (1+ i))) (setq y (pop-y p)))
+			(when (null p)
+			  (when closed
+			    (setf (aref lines (shiftf i (1+ i))) x)
+			    (setf (aref lines (shiftf i (1+ i))) y)
+			    (setf (aref lines (shiftf i (1+ i))) initial-x)
+			    (setf (aref lines (shiftf i (1+ i))) initial-y))
+			  (return))))
+		    (funcall window :draw-multiple-lines lines alu nil))))
+	  #'(lambda (window)
+	      (declare (sys:downward-function))
+	      (with-stack-array (translated-points npoints)
+		(do ((i 0)
+		     (p points))
+		    ((null p))
+		  (setf (aref translated-points (shiftf i (1+ i))) (pop-x p))
+		  (setf (aref translated-points (shiftf i (1+ i))) (pop-y p)))
+		(if (null line-style)
+		    (funcall (flavor:generic graphics:draw-polygon) window translated-points
+			     :filled t)
+		    (funcall (flavor:generic graphics:draw-lines) window translated-points
+			     :closed closed)))))))))
+
+(defmethod draw-ellipse-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				  center-x center-y
+				  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+				  start-angle end-angle ink line-style)
+  (when (window-drawing-possible stream)
+    (round-points center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
+    (translate-positions x-offset y-offset center-x center-y)
+    (when (and start-angle
+	       (= start-angle 0.0)
+	       (= end-angle 2pi))
+      ;; GRAPHICS:DRAW-CIRCLE draws nothing when given single-precision 2PI
+      (setq end-angle graphics:2pi))
+    (multiple-value-bind (pre-stretch-angle x-radius y-radius axis-rotate-angle)
+	(2x2-singular-value-decomposition radius-1-dx radius-2-dx
+					  radius-1-dy radius-2-dy)
+      (declare (ignore pre-stretch-angle))
+      (setq x-radius (abs x-radius) y-radius (abs y-radius))
+      (if (and (= x-radius y-radius) (null start-angle))
+	  ;; It's a complete circle
+	  (with-appropriate-drawing-state stream ink line-style
+	    #'(lambda (window alu)
+		(declare (sys:downward-function))
+		(if (null line-style)
+		    (funcall window :draw-filled-in-circle center-x center-y x-radius alu)
+		    (funcall window :draw-circle center-x center-y x-radius alu)))
+	    #'(lambda (window)
+		(declare (sys:downward-function))
+		(funcall (flavor:generic graphics:draw-ellipse) window
+			 center-x center-y x-radius y-radius
+			 :filled (null line-style))))
+	;; For general ellipse, let Genera do all the work
+	(with-appropriate-drawing-state stream ink line-style
+	  nil
+	  #'(lambda (window)
+	      (declare (sys:downward-function))
+	      (graphics:saving-graphics-transform (window)
+		(graphics:graphics-translate center-x center-y :stream window)
+		(when (/= axis-rotate-angle 0)
+		  (graphics:graphics-rotate axis-rotate-angle :stream window))
+		(funcall (flavor:generic graphics:draw-ellipse) window
+			 0 0 x-radius y-radius
+			 :start-angle (or start-angle 0)
+			 :end-angle (or end-angle graphics:2pi)
+			 :filled (null line-style)))))))))
+
+(defmethod draw-string-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				 string x y start end align-x align-y text-style ink)
+  (when (window-drawing-possible stream)
+    (round-points x y)
+    (translate-positions x-offset y-offset x y)
+    (unless end
+      (setq end (length string)))
+    ;; ---OK to use this in the Genera implementation
+    (sys:stack-let ((substring (make-string (- end start))))
+      (replace substring string :start2 start :end2 end)
+      (let* ((font (text-style-mapping (slot-value stream 'display-device-type)
+				       *standard-character-set* text-style
+				       (slot-value stream 'window)))
+	     (height (sys:font-char-height font))
+	     (descent (- height (sys:font-baseline font)))
+	     (ascent (- height descent)))
+	(incf x (compute-text-x-adjustment 
+		  align-x stream string text-style start end))
+	(incf y (compute-text-y-adjustment
+		  align-y descent ascent height))
+	(with-stack-list (style :device-font (tv:font-name font) :normal)
+	  (with-appropriate-drawing-state stream ink nil
+	    #'(lambda (window alu)
+		(declare (sys:downward-function))
+		(funcall window :draw-string substring x y (1+ x) y nil style alu))
+	    #'(lambda (window)
+		(declare (sys:downward-function))
+		(funcall (flavor:generic graphics:draw-string) window
+			 substring x y :character-style style))))))))
+
+(defmethod draw-character-internal ((stream sheet-implementation-mixin) x-offset y-offset
+				    character x y align-x align-y text-style ink)
+  (when (window-drawing-possible stream)
+    (round-points x y)
+    (translate-positions x-offset y-offset x y)
+    (let* ((font (text-style-mapping (slot-value stream 'display-device-type)
+				     *standard-character-set* text-style
+				     (slot-value stream 'window)))
+	   (height (sys:font-char-height font))
+	   (descent (- height (sys:font-baseline font)))
+	   (ascent (- height descent)))
+      (incf x (compute-text-x-adjustment 
+		align-x stream character text-style))
+      (incf y (compute-text-y-adjustment
+		align-y descent ascent height))
+      (with-appropriate-drawing-state stream ink nil
+	#'(lambda (window alu)
+	    (declare (sys:downward-function))
+	    (funcall window :draw-glyph (char-code character) font x y alu))
+	#'(lambda (window)
+	    (declare (sys:downward-function))
+	    (funcall (flavor:generic graphics:draw-glyph) window
+		     (char-code character) font x y))))))
+
+
+;;; 13 November 1989: Optimization to make stream-glyph-for-character faster in the case where
+;;; we are calling it a lot, in stream-scan-string-for-writing.  We make this function be a
+;;; macro.
+
+;;; This algorithm is a paraphrase of the apparent contents of TV:%DRAW-STRING-CLIPPED-INTERNAL
+(defmacro with-sheet-stream-glyph-for-character (&body body)
+  `(macrolet ((stream-glyph-for-character (stream character style &optional our-font)
+		`(with-slots (display-device-type) ,stream
+		   (multiple-value-bind (character-set index)
+		       (char-character-set-and-index ,character)
+		     ;; For now we are asserting that each string passed to WRITE-STRING will
+		     ;; have no style changes within it.  This is what our-font is all
+		     ;; about.
+		     (let* ((font (or our-font (text-style-mapping
+						 display-device-type character-set
+						 ,style nil)))
+			    (FIT (sys:font-indexing-table font))
+			    (LKT (sys:font-left-kern-table font))
+			    (CWT (sys:font-char-width-table font))
+			    (escapement-x (if (diacritic-char-p ,character) 0
+					      (if CWT (aref CWT index)
+						  (sys:font-char-width font))))
+			    (escapement-y 0)
+			    (origin-x (if LKT (aref LKT index) 0))
+			    (origin-y (sys:font-baseline font))
+			    (bb-x (if FIT (- (aref FIT (1+ index)) (aref FIT index))
+				      (sys:font-char-width font)))
+			    (bb-y (sys:font-char-height font)))
+		       (values index font escapement-x escapement-y origin-x origin-y
+			       bb-x bb-y (not (or FIT LKT CWT))))))))
+     ,@body))
+
+(defmethod stream-glyph-for-character ((stream sheet-implementation-mixin)
+				       character style &optional our-font)
+  (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y
+		   fixed-width-font-p))
+  (with-sheet-stream-glyph-for-character
+    (stream-glyph-for-character stream character style our-font)))
+
+(defmethod stream-scan-string-for-writing ((stream sheet-implementation-mixin) string
+					   start end style cursor-x max-x
+					   &optional glyph-buffer)
+  (with-sheet-stream-glyph-for-character 
+    (stream-scan-string-for-writing-body)))
+
+(defmethod stream-write-char-1 ((stream sheet-implementation-mixin) index font color x y)
+  (let ((window (slot-value stream 'window)))
+    (when (window-drawing-possible stream)
+      (tv:prepare-sheet (window)
+	(let ((x (+ x (tv:sheet-left-margin-size window)))
+	      (y (+ y (tv:sheet-top-margin-size window))))
+	  ;; There is apparently no way to draw a glyph exactly where you want
+	  ;; it on a sheet!  Draw it on the screen instead...
+	  (tv:sheet-draw-glyph index font x y
+			       (if (eq color (medium-foreground stream))
+				   (tv:sheet-char-aluf window)
+				 (sheet-decode-color (follow-indirect-ink color stream)
+						     stream nil))
+			       window))))))
+
+(defmethod stream-write-string-1 ((stream sheet-implementation-mixin)
+				  glyph-buffer start end font color x y)
+  (when (<= end start) (return-from stream-write-string-1))
+  (let ((window (slot-value stream 'window)))
+    (when (window-drawing-possible stream)
+      (tv:prepare-sheet (window)
+	(let ((glyph-buffer glyph-buffer)
+	      (index start)
+	      (index8 0)
+	      (x (+ x (tv:sheet-left-margin-size window)))
+	      (y (+ y (tv:sheet-top-margin-size window))))
+	  (declare (sys:array-register glyph-buffer))
+	  (sys:with-stack-array (glyphs8 (- end start) :element-type 'string-char)
+	    (declare (sys:array-register glyphs8))
+	    (loop
+	      (when (= index end) (return))
+	      (setf (aref glyphs8 index8) (code-char (aref glyph-buffer index)))
+	      (incf index)
+	      (incf index8))
+	    (tv:sheet-draw-string window
+				  (if (eq color (medium-foreground stream))
+				      (tv:sheet-char-aluf window)
+				    (sheet-decode-color (follow-indirect-ink color stream)
+							stream nil))
+				  x y glyphs8 font 0 index8
+				  (tv:sheet-width window))))))))
+
+
+(defmethod text-style-height ((text-style standard-text-style)
+			      (stream sheet-implementation-mixin))
+  (with-slots (display-device-type window) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (sys:font-char-height font))))
+
+(defmethod text-style-width ((text-style standard-text-style)
+			     (stream sheet-implementation-mixin))
+  (with-slots (display-device-type window) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (sys:font-char-width font))))
+
+(defmethod text-style-ascent ((text-style standard-text-style)
+			      (stream sheet-implementation-mixin))
+  (with-slots (display-device-type window) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (let* ((height (sys:font-char-height font))
+	     (descent (- height (sys:font-baseline font)))
+	     (ascent (- height descent)))
+	ascent))))
+
+(defmethod text-style-descent ((text-style standard-text-style)
+			       (stream sheet-implementation-mixin))
+  (with-slots (display-device-type window) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (let* ((height (sys:font-char-height font))
+	     (descent (- height (sys:font-baseline font))))
+	descent))))
+
+(defmethod text-style-fixed-width-p ((text-style standard-text-style)
+				     (stream sheet-implementation-mixin))
+  (with-slots (display-device-type window) stream
+    (let ((font (text-style-mapping
+		  display-device-type *standard-character-set* text-style window)))
+      (null (sys:font-char-width-table font)))))
+
+(defmethod text-size ((stream sheet-implementation-mixin) string
+		      &key (text-style (stream-merged-text-style stream)) (start 0) end)
+  (when (characterp string)
+    (setq string (string string)
+	  start 0
+	  end nil))
+  (multiple-value-bind (last-x largest-x last-y total-height baseline)
+      (stream-string-output-size stream string :text-style text-style :start start :end end)
+    (values largest-x total-height last-x last-y baseline)))
+
+
+;;; This whole file is #+Genera, right?
+
+(scl:defflavor clim-sheet
+	((selected-inferior nil))
+	(dw::margin-mixin			;scroll bars, labels, borders
+	 tv:no-screen-managing-mixin		;don't auto-select a pane
+	 tv:window)
+  (:default-init-plist :borders nil
+		       :save-bits nil		;adjusted later if top-level
+		       :deexposed-typeout-action :permit
+		       :blinker-p nil
+		       :label nil))
+
+(scl:defflavor temp-clim-sheet
+	()
+	(tv:temporary-window-mixin clim-sheet))
+
+;; All the sheet windows in a given activity (top level window) share the same io-buffer, and
+;; CLIM decides which CLIM window to give the input to.
+;; A top-level window should have a bit save array if we want the screen manager
+;; to do what users expect.
+(scl:defmethod (:init clim-sheet :before) (args)
+  (declare (ignore args))
+  (let ((top-level (not (typep tv:superior 'clim-sheet))))
+    (unless tv:io-buffer
+      (setq tv:io-buffer (if top-level
+			     (tv:make-io-buffer 100)
+			   (scl:send tv:superior :io-buffer))))
+    (when top-level
+      ;; This is like :save-bits :delayed
+      (setf (tv:sheet-save-bits) 1))))
+
+(scl:defmethod (:init temp-clim-sheet :after) (args)
+  (declare (ignore args))
+  (setf (tv:sheet-save-bits) 0))
+
+;;; Interface to Genera scroll bars.
+(scl:defmethod (:y-scroll-position clim-sheet) ()
+  (declare (values top-displayed height-displayed minimum-y maximum-y))
+  (let* ((stream (clim-window-for-host-window scl:self :error-if-no-match nil))
+	 (history (and stream (stream-output-history stream)))
+	 (viewport (and stream (window-viewport stream))))
+    (cond ((and viewport history)
+	   (with-bounding-rectangle* (vleft vtop vright vbottom) viewport
+	     (declare (ignore vleft vright))
+	     (with-bounding-rectangle* (hleft htop hright hbottom) history
+	       (declare (ignore hleft hright))
+	       (values vtop (- vbottom vtop) htop hbottom))))
+	  (t (values 0 0 0 0)))))
+
+(scl:defmethod (:x-scroll-position clim-sheet) ()
+  (let* ((stream (clim-window-for-host-window scl:self :error-if-no-match nil))
+	 (history (and stream (stream-output-history stream)))
+	 (viewport (and stream (window-viewport stream))))
+    (cond ((and viewport history)
+	   (with-bounding-rectangle* (vleft vtop vright vbottom) viewport
+	     (declare (ignore vtop vbottom))
+	     (with-bounding-rectangle* (hleft htop hright hbottom) history
+	       (declare (ignore htop hbottom))
+	       (values vleft (- vright vleft) hleft hright))))
+	  (t (values 0 0 0 0)))))
+
+(defun calculate-new-viewport-position (stream x-or-y type position
+					&optional (context-nlines 1))
+  (declare (ignore context-nlines))
+  (declare (values viewport-left viewport-top))
+  (let ((viewport (window-viewport stream)))
+    (ecase x-or-y
+      (:y
+	(ecase type
+	  (:relative-jump
+	    (values (bounding-rectangle-left viewport)
+		    (+ (bounding-rectangle-top viewport)
+		       (* position (stream-line-height stream))))
+	    #+Ignore
+	    (unless (zerop position)
+	      (let ((index viewport-displayed-strings-start-index)
+		    (max-index (fill-pointer displayed-strings))
+		    (y (box-top cursor-viewport))
+		    (inc (signum position)))
+		(labels ((index-ok-p (index)
+			   (and ( index 0)
+				(< index max-index))))
+		  (loop repeat (abs position)
+			do (loop doing
+			     (let ((new-index (+ index inc)))
+			       (unless (index-ok-p new-index)
+				 (loop-finish))
+			       (setq index new-index))
+			     (let ((new-top (box-top (presentation-displayed-box
+						       (aref displayed-strings index)))))
+			       (when ( new-top y)
+				 (setq y new-top)
+				 (loop-finish))))
+			while (index-ok-p index))
+		  (when (index-ok-p index)
+		    (let ((new-top (box-top (presentation-displayed-box
+					      (aref displayed-strings index)))))
+		      (values (box-left cursor-viewport) new-top)))))))
+	  (:relative 
+	    (values (bounding-rectangle-left viewport)
+		    (+ position (bounding-rectangle-top viewport))))
+	  (:absolute
+	    (values (bounding-rectangle-left viewport)
+		    position))
+	  (:screenful
+	    (with-bounding-rectangle* (vleft vtop vright vbottom) viewport
+	      (declare (ignore vright))
+	      (let ((new-top (+ vtop (* position (- vbottom vtop)))))
+		(setq new-top (min new-top (- vbottom vtop)))
+		(values vleft new-top))))
+	  ))
+      (:x
+	(ecase type
+	  (:relative-jump
+	    (calculate-new-viewport-position
+	      stream :x :relative
+	      (* position (stream-character-width stream #\Space))))
+	  (:relative
+	    (values (+ (bounding-rectangle-left viewport) position)
+		    (bounding-rectangle-top viewport)))
+	  (:absolute
+	    (values position
+		    (bounding-rectangle-top viewport))))))))
+
+(scl:defmethod (:y-scroll-to clim-sheet) (position type)
+  (let* ((stream (clim-window-for-host-window scl:self))
+	 (history (stream-output-history stream))
+	 (left (bounding-rectangle-left (window-viewport stream))))
+    (multiple-value-bind (ignore top)
+	(calculate-new-viewport-position stream :y type position)
+      (declare (ignore ignore))
+      (when history
+	(with-bounding-rectangle* (hleft htop hright hbottom) history
+	  (declare (ignore hleft hright))
+	  (setq top (min (max htop top) hbottom))))
+      (window-set-viewport-position* stream left top))))
+
+(scl:defmethod (:x-scroll-to clim-sheet) (position type)
+  (let* ((stream (clim-window-for-host-window scl:self))
+	 (history (stream-output-history stream))
+	 (top (bounding-rectangle-top (window-viewport stream))))
+    (let ((left (calculate-new-viewport-position stream :x type position)))
+      (when history
+	(with-bounding-rectangle* (hleft htop hright hbottom) history
+	  (declare (ignore htop hbottom))
+	  (setq left (min (max left hleft) hright))))
+      (window-set-viewport-position* stream left top))))
+
+;;; The window manager should manipulate the highest "CLIM sheet" when invoked
+;;; on an inferior.
+(scl:defmethod (:alias-for-selected-windows clim-sheet) ()
+  (if (typep tv:superior 'clim-sheet)
+      (scl:send tv:superior :alias-for-selected-windows)
+      scl:self))
+
+(scl:defmethod (:name-for-selection clim-sheet) ()
+  (or (let ((frame (window-stream-to-frame (clim-window-for-host-window scl:self))))
+	(and frame (frame-pretty-name frame)))
+      (let ((label (scl:send scl:self :label)))
+	(and label (scl:string-search-not-char #\sp label) label))
+      tv:name))
+
+;;; A combination of the methods of pane-mixin and basic-frame
+(scl:defwhopper (:select clim-sheet) (&rest args)
+  (when (scl:send tv:superior :inferior-select scl:self)
+    (cond ((and selected-inferior
+		(scl:send selected-inferior :exposed-p))
+	   (scl:lexpr-send selected-inferior :select args))
+	  ((and (null selected-inferior)
+		tv:inferiors
+		(let ((frame (window-stream-to-frame (clim-window-for-host-window scl:self))))
+		  (when frame
+		    ;; This is a frame whose input focus has not yet been directed to any pane
+		    ;; Choose the interactor pane by default
+		    (let ((stream (frame-query-io frame)))
+		      (when stream
+			(scl:lexpr-send (slot-value stream 'window) :select args)
+			t))))))
+	  (t
+	   (scl:lexpr-continue-whopper args)))))
+
+;;; As for basic-frame
+(scl:defmethod (:inferior-select clim-sheet) (pane)
+  (setq selected-inferior pane)
+  (scl:send tv:superior :inferior-select scl:self))
+
+;;; As for basic-frame
+(scl:defwhopper (:select-relative clim-sheet) ()
+  (if (and selected-inferior
+	   (scl:send selected-inferior :exposed-p))
+      (scl:send selected-inferior :select-relative)
+      (scl:continue-whopper)))
+
+;;; As for pane-mixin
+;;; "When selecting a pane with the mouse, pass the selection request to the frame."
+(scl:defwhopper (:mouse-select clim-sheet) (&rest args)
+  (if (typep tv:superior 'clim-sheet)
+      (scl:lexpr-send tv:superior ':mouse-select args)
+      (scl:lexpr-continue-whopper args)))
+
+(scl:defmethod (:expose clim-sheet :after) (&rest args)
+  (declare (ignore args))
+  (scl:send tv:superior :inferior-expose scl:self))
+
+(scl:defmethod (:inferior-expose clim-sheet) (inferior)
+  (when (eq inferior selected-inferior)
+    (scl:send inferior :select-relative)))
+
+(scl:defmethod (tv:refresh-rectangle clim-sheet) (left top right bottom)
+  (let ((window (clim-window-for-host-window scl:self)))
+    (setf (slot-value window 'highlighted-presentation) nil)
+    (multiple-value-bind (viewport-x viewport-y)
+	(bounding-rectangle-position* (window-viewport window))
+      (frame-replay *application-frame*
+		    window (make-bounding-rectangle (+ left viewport-x)
+						    (+ top viewport-y)
+						    (+ right viewport-x)
+						    (+ bottom viewport-y))))
+    (tv:refresh-margins-rectangle scl:self left top right bottom)))
+
+;;; This is a hideous kludge that attempts to address the problems with moving windows
+;;; within their parents.
+(scl:defwhopper (:set-position clim-sheet) (new-x new-y &optional verify)
+  (ecase verify
+    ((:verify)
+     (scl:continue-whopper new-x new-y verify))
+    ((nil)
+     (let ((old-x tv:x-offset) (old-y tv:y-offset))
+       (multiple-value-prog1 (scl:continue-whopper new-x new-y verify)
+	 (unless (or *synchronous-window-operation-being-processed*
+		     (and (= old-x tv:x-offset) (= old-y tv:y-offset)))
+	   (scl:send scl:self :force-kbd-input
+		     (make-window-size-or-position-change-event
+		       (clim-window-for-host-window scl:self)
+		       nil nil nil nil))))))))
+
+(scl:defmethod (:refresh clim-sheet :before) (&optional (type :complete-redisplay))
+  (declare (ignore type))
+  (let ((stream (clim-window-for-host-window scl:self)))
+    ;; Invalidate all cached inks, so they'll be redecoded taking into account any
+    ;; changed parameters such as reversed video.
+    (let ((cache (slot-value stream 'ink-cache)))
+      (dotimes (i (array-total-size cache))
+	(setf (aref cache i) nil)))
+    (let ((foreground (sheet-decode-color (medium-foreground stream) stream nil))
+	  (background (sheet-decode-color (medium-background stream) stream nil)))
+      (funcall scl:self :set-char-aluf foreground)
+      (funcall scl:self :set-erase-aluf background))))
+
+(scl:defmethod (:refresh clim-sheet :after) (&optional (type :complete-redisplay))
+  (declare (ignore type))
+  (let ((window (clim-window-for-host-window scl:self)))
+    (setf (slot-value window 'highlighted-presentation) nil)
+    (unless *sizing-application-frame*		;avoid replaying twice
+      (frame-replay *application-frame* window (window-viewport window)))))
+
+(scl:defwhopper (:change-of-size-or-margins clim-sheet) (&rest args)
+  (let ((old-x tv:x-offset) (old-y tv:y-offset)
+	(old-width tv:width) (old-height tv:height))
+    (multiple-value-prog1 (scl:lexpr-continue-whopper args)
+      (unless (or *synchronous-window-operation-being-processed*
+		  (and (= old-x tv:x-offset) (= old-y tv:y-offset)
+		       (= old-width tv:width) (= old-height tv:height)))
+	(scl:send scl:self :force-kbd-input
+		  (make-window-size-or-position-change-event
+		    (clim-window-for-host-window scl:self)
+		    nil nil nil nil))))))
+
+(scl:defwhopper (:set-reverse-video-p clim-sheet) (reverse-video-p)
+  (let ((old-reverse-video-p (scl:send scl:self :reverse-video-p)))
+    (multiple-value-prog1
+      (scl:continue-whopper reverse-video-p)
+      (unless (eql reverse-video-p old-reverse-video-p)
+	(labels ((switch-inks (window)
+		   ;; Inhibit refreshing until we're done
+		   (rotatef (slot-value window 'foreground)
+			    (slot-value window 'background))
+		   (dolist (window (window-children window))
+		     (switch-inks window))))
+	  (declare (dynamic-extent #'switch-inks))
+	  (switch-inks (clim-window-for-host-window scl:self))
+	  (scl:send scl:self :refresh))))))
+
+(scl:defmethod (:convert-mouse-coords clim-sheet) (x y in-or-out)
+  (case in-or-out
+    (:in (values (- x tv:left-margin-size)
+		 (- y tv:top-margin-size)))
+    (:out (values (+ x tv:left-margin-size)
+		  (+ y tv:top-margin-size)))))
+
+(scl:defmethod (with-clim-sheet-clipping-region clim-sheet)
+	       (left top right bottom continuation stream)
+  (tv:with-sheet-clipping-region ((+ left tv:left-margin-size) (+ top tv:top-margin-size)
+				  (+ right tv:left-margin-size) (+ bottom tv:top-margin-size))
+    (declare (sys:downward-function))		;yecch
+    (funcall continuation stream)))
+
+(scl:compile-flavor-methods clim-sheet temp-clim-sheet)
+
+
+;;;
+
+(defclass sheet-window-stream
+	  (sheet-implementation-mixin window-stream)
+    ()
+  (:default-initargs :display-device-type nil
+		     :text-cursor (make-instance 'sheet-text-cursor)))
+
+(defun create-sheet-root-window (&key (screen tv:main-screen))
+  (make-instance 'sheet-window-stream
+		 :window screen
+		 :label nil
+		 :scroll-bars nil
+		 :display-device-type
+		   (let (#+IMach (device (scl:send screen :display-device-type)))
+		     (cond
+		       #+IMach
+		       ((and (find-package 'mtb)
+			     (typep device
+				    (intern "SMALL-SCREEN-GENERA-FONTS-MAC-DISPLAY-DEVICE" 'mtb)))
+			*small-sheet-device*)
+		       (t *sheet-device*)))))
+
+
+;; :SHEET and :GENERA are the same thing...
+(define-implementation :sheet  'create-sheet-root-window)
+(define-implementation :genera 'create-sheet-root-window)
+
+(defmethod initialize-instance :after ((stream sheet-window-stream)
+				       &key parent left top right bottom label
+					    (scroll-bars ':both) (borders t)
+					    window save-under)
+  ;; --- can we do this error checking more generally?
+  (cond ((null parent)
+	 ;; :PARENT NIL means open the root window.
+	 (unless window
+	   (error "You must supply a parent window stream or explicitly initilize the WINDOW slot."))
+	 ;; parent nil means 
+	 (when (or left top right bottom)
+	   (error "You cannot specify the size of the root window (i.e. when :PARENT is NIL)."))
+	 (with-slots (left top right bottom) stream
+	   (multiple-value-bind (w h) (scl:send window :size)
+	     (setf left (tv:sheet-x window)
+		   top (tv:sheet-y window)
+		   right (+ (tv:sheet-x window) w)
+		   bottom (+ (tv:sheet-y window) h))))
+	 (setf (stream-pointers stream)
+	       (list (make-instance 'standard-pointer :root stream))))
+	(t
+	 (with-slots (display-device-type) stream
+	   (unless display-device-type
+	     (setf display-device-type (slot-value parent 'display-device-type))))
+	 ;; When parent is supplied, open an inferior
+	 (unless (and left top right bottom)
+	   (error "You must supply :left :top :right and :bottom when creating a window"))
+	 (let ((parent-window (slot-value parent 'window)))
+	   (when parent-window
+	     (multiple-value-bind (wl wt)
+		 (scl:send parent-window :inside-edges)
+	       (translate-positions wl wt left top right bottom)))
+	   (let ((sheet (tv:make-window (if save-under 'temp-clim-sheet 'clim-sheet)
+					:superior parent-window
+					:left left	;see above
+					:top top
+					:right right
+					:bottom bottom
+					;; :edges (list left top right bottom)
+					:margin-components (clim-sheet-margin-components
+							     label scroll-bars borders))))
+	     (setf (slot-value stream 'window) sheet)
+	     (setf (slot-value stream 'color-p) (color:color-stream-p sheet))
+	     ;; EMBEDDED-P indicates that the screen implementation has fast, specific
+	     ;; methods for implementing the Genera graphics substrate.  I'm not sure
+	     ;; if the use of basic-remote-screen is the right test, but it's quick...
+	     (setf (slot-value stream 'embedded-p)
+		   (typep (tv:sheet-screen sheet) 'tv:basic-remote-screen))
+	     (scl:send sheet :set-char-aluf
+		       (sheet-decode-color (medium-foreground stream) stream nil))
+	     (scl:send sheet :set-erase-aluf
+		       (sheet-decode-color (medium-background stream) stream nil))))))
+  (associate-clim-window-with-host-window (slot-value stream 'window) stream))
+
+;;; The margin stuff seems to have changed.
+(defmethod initialize-instance :around ((stream sheet-window-stream) &key label)
+  (call-next-method)
+  (when (slot-value stream 'parent)
+    (scl:send (slot-value stream 'window) :set-label " ")
+    (scl:send (slot-value stream 'window)
+	      :set-label (clim-label->genera-label label stream))))
+
+(defmethod (setf medium-foreground) :after (ink (stream sheet-window-stream))
+  (with-slots (window) stream	   
+    (scl:send window :set-char-aluf (sheet-decode-color ink stream nil))
+    (scl:send window :refresh)))
+
+(defmethod (setf medium-background) :after (ink (stream sheet-window-stream))
+  (with-slots (window) stream	   
+    (scl:send window :set-erase-aluf (sheet-decode-color ink stream nil))
+    (scl:send window :refresh)))
+
+(defun clim-sheet-margin-components (label-p scroll-bar borders-p)
+  `(,@(and borders-p
+	   '((dw::margin-borders )))
+    ,@(and (member scroll-bar '(:vertical :both))
+	   '((dw::margin-scroll-bar :history-noun "history")))
+    ,@(and (member scroll-bar '(:horizontal :both))
+	   '((dw::margin-scroll-bar :margin :bottom :history-noun "history")))
+    ,@(and borders-p
+	   '((dw::margin-white-borders :thickness 2)))
+    ,@(and label-p
+	   '((dw::margin-label )))))
+
+;;; Since sheets have no concept of a "region", we'll just use a Y rectangle
+;;; to represent one.
+
+;;--- This should clip to real regions, not just to bounding-rectangles
+(defmethod invoke-with-clipping-region
+	   ((stream sheet-implementation-mixin) continuation (region standard-bounding-rectangle))
+  (let ((window (slot-value stream 'window)))
+    (multiple-value-bind (vx vy) (window-viewport-position* stream)
+      (declare (type coordinate vx vy))
+      (multiple-value-bind (ml mt) (window-margins stream)
+	(declare (type coordinate ml mt))
+	(with-bounding-rectangle* (left top right bottom) region
+	  ;;--- where should this FIXing be done?
+	  (fix-points left top right bottom vx vy ml mt)
+	  (with-clim-sheet-clipping-region window
+					   (+ (- left vx) ml) (+ (- top vy) mt)
+					   (+ (- right vx) ml) (+ (- bottom vy) mt)
+					   continuation stream))))))
+
+
+;;; Input side
+
+(defmethod stream-clear-input :after ((stream sheet-window-stream))
+  (with-slots (window) stream
+    (scl:send window :clear-input)))
+
+(defun mouse-char-bits->modifier-state (bits)
+  (let ((mask 0))
+    (macrolet ((do-shift (shift)
+		 `(when (si:bit-test (si:name-bit ,shift) bits)
+		    (let ((bit (modifier-key-index ,shift)))
+		      (setf mask (dpb 1 (byte 1 bit) mask))))))
+      ;; why is SHIFT different from sys:%kbd-shifts-shift
+      (when (ldb-test (byte 1 4) bits)
+	(let ((bit (modifier-key-index :shift)))
+	  (setf mask (dpb 1 (byte 1 bit) mask))))
+      (do-shift :control)
+      (do-shift :meta)
+      (do-shift :super)
+      (do-shift :hyper))
+    mask))
+
+(defmethod window-modifier-state ((stream sheet-implementation-mixin))
+  (let* ((window (slot-value stream 'window))
+	 (mouse (tv:sheet-mouse window)))
+    (let ((shifts (tv:mouse-chord-shifts mouse)))
+      (mouse-char-bits->modifier-state shifts))))
+
+(defmethod set-pointer-window-and-location ((stream sheet-window-stream) pointer)
+  (let ((mouse (tv:sheet-mouse (slot-value stream 'window))))
+    (setf (pointer-window pointer)
+	  (clim-window-for-host-window (tv:window-under-mouse-internal mouse)
+				       :error-if-no-match nil))
+    (pointer-set-position* pointer (tv:mouse-x mouse) (tv:mouse-y mouse))))
+
+(defmethod stream-event-handler ((stream sheet-window-stream)
+				 &key (timeout nil) (input-wait-test nil))
+  ;;--- Have to establish correspondence between pointing devices and pointer objects
+  (with-slots (window) stream
+    (let* ((sys:rubout-handler nil)
+	   (mouse (tv:sheet-mouse window))
+	   (pointer (stream-primary-pointer stream))
+	   (old-buttons (tv:mouse-last-buttons mouse))
+	   (old-x (pointer-x-position pointer))
+	   (old-y (pointer-y-position pointer))
+	   ;;--- Why doesn't the pointer object remember these?
+	   (old-shifts (tv:mouse-chord-shifts mouse))
+	   (old-window (pointer-window pointer))
+	   (what-happened (if timeout :timeout :mouse-motion))
+	   ;; If we're inside an encapsulating stream, such as the input editor, and a window
+	   ;; resizing event is received, don't get confused while handling the event
+	   (*original-stream* nil))
+      (labels ((mouse-motion-pending ()
+		 (or (/= (tv:mouse-chord-shifts mouse) old-shifts)
+		     (/= old-buttons (tv:mouse-last-buttons mouse))
+		     (/= old-x (mouse-x))
+		     (/= old-y (mouse-y))
+		     (not (eql old-window (clim-window-for-host-window
+					    (tv:window-under-mouse-internal mouse)
+					    :error-if-no-match nil)))))
+	       (something-pending (sheet)
+		 (cond ((not (tv:sheet-console window)) nil)	;wait for console
+		       ((not (tv:mouse-sheet mouse)) nil)	;..
+		       ((and input-wait-test (funcall input-wait-test stream))
+			(setq what-happened :input-wait-test))
+		       ((mouse-motion-pending)
+			(setq what-happened :mouse-motion)
+			T)
+		       ((scl:send-if-handles sheet :listen)
+			(setq what-happened :listen)
+			T)))
+	       (mouse-x () (tv:mouse-x mouse))
+	       (mouse-y () (tv:mouse-y mouse)))
+	(declare (dynamic-extent #'mouse-motion-pending #'something-pending
+				 #'mouse-x #'mouse-y))
+	(cond ((eql timeout 0)			;avoid consing bignums
+	       (something-pending window))
+	      (timeout
+	       (scl:process-wait-with-timeout si:*whostate-awaiting-user-input* (* timeout 60)
+		 #'something-pending window))
+	      (t
+	       (scl:process-wait si:*whostate-awaiting-user-input*
+		 #'something-pending window)))
+	(ecase what-happened
+	  (:listen
+	    (let ((character (scl:send window :any-tyi)))
+	      (cond ((typep character 'window-size-or-position-change-event)
+		     (let* ((window (event-window character))
+			    (window-win (slot-value window 'window))
+			    (parent (window-parent window))
+			    (parent-win (slot-value parent 'window)))
+		       (multiple-value-bind (left top right bottom)
+			   (scl:send window-win :edges)
+			 (when (null (tv:sheet-superior parent-win))
+			   (multiple-value-bind (wl wt)
+			       (scl:send parent-win :inside-edges)
+			     (translate-positions (- wl) (- wt) left top right bottom)))
+			 (window-note-size-or-position-change
+			   window left top right bottom))))
+		    ((listp character)
+		     (case (first character)
+		       (:mouse-button
+			 (scl:destructuring-bind (blip-type char mouse-window x y) character
+			   (declare (ignore blip-type))
+			   (setf (pointer-button-state pointer)
+				 (tv:mouse-last-buttons mouse))
+			   ;; we don't need to translate x and y by the root-offsets
+			   ;; because they're already in window coordinates...
+			   (let ((pw (clim-window-for-host-window mouse-window)))
+			     (setf (pointer-window pointer) pw)
+			     (multiple-value-bind (xm ym) (scl:send mouse-window :margins)
+			       ;; X and Y are presumed to be fixnums here
+			       (stream-note-pointer-button-press
+				 pw pointer (ash 1 (si:mouse-char-button char))
+				 (mouse-char-bits->modifier-state (si:mouse-char-bits char))
+				 (- x xm) (- y ym))))))))
+		    (t (queue-put (stream-input-buffer stream) character)))))
+	  (:mouse-motion
+	    ;; ---
+	    (pointer-set-position* pointer (mouse-x) (mouse-y))
+	    (let ((window (clim-window-for-host-window (tv:window-under-mouse-internal mouse)
+						       :error-if-no-match nil)))
+	      (setf (pointer-window pointer) window)
+	      (when window
+		(setf (pointer-motion-pending window pointer) T))))
+	  (:input-wait-test  :input-wait-test)
+	  (:timeout  :timeout))
+	what-happened))))
+
+(defmethod set-stream-pointer-in-screen-coordinates ((stream sheet-window-stream) pointer x y)
+  (declare (ignore pointer))			;Sigh.
+  (let ((mouse (tv:sheet-mouse (slot-value stream 'window))))
+    (tv:mouse-warp x y mouse)))
+
+(defmethod stream-pointer-input-rectangle* ((stream sheet-window-stream) pointer
+					    &key left top right bottom)
+  (declare (ignore pointer))
+  (multiple-value-bind (dx dy) (window-viewport-position* stream)
+    (setq left (if (typep left 'real) (round left) dx))
+    (setq top  (if (typep top  'real) (round top) dy))
+    (setq right  (if (typep right  'real) (round right) (+ left 50)))
+    (setq bottom (if (typep bottom 'real) (round bottom) (+ top 50)))
+    ;; TV:MOUSE-RESHAPE-RECTANGLE deals with values in TV:MAIN-SCREEN coordinates.
+    (multiple-value-bind (lm tm) (window-offset stream)
+      (decf dx lm)
+      (decf dy tm))
+    (multiple-value-bind (bleft btop bright bbottom)
+	(dw::box-edges 
+	  (tv:mouse-reshape-rectangle
+	    :initial-box (dw:make-box (- left dx) (- top dy) (- right dx) (- bottom dy))
+	    :sheet (slot-value stream 'window)))
+      (values (+ bleft dx)
+	      (+ btop dy)
+	      (+ bright dx)
+	      (+ bbottom dy)))))
+
+(defmethod mouse-documentation-window ((window sheet-implementation-mixin))
+  (let ((console (tv:sheet-console (slot-value window 'window))))
+    (if (eq console sys:*main-console*)
+	tv:who-line-documentation-window
+	(let ((who-screen (tv:console-who-line-screen console)))
+	  (and who-screen
+	       (tv:get-who-line-field :mouse-documentation who-screen))))))
+
+
+;;; Text styles for sheets
+
+(defclass sheet-device (display-device) ())
+
+(defmethod text-style-mapping :around
+	   ((display-device sheet-device) character-set style &optional window)
+  (declare (ignore window))
+  (let* ((font-symbol (call-next-method))
+	 (font (if (symbolp font-symbol) (symbol-value font-symbol) font-symbol)))
+    (unless (typep font 'sys:font)
+      (error "Mapping for ~A characters in ~A character set is not a font"
+	     style character-set))
+    font))
+
+(defparameter *sheet-logical-size-alist*
+	      '((:tiny       6)
+		(:very-small 8)
+		(:small	     10)
+		(:normal     12)
+		(:large	     14)
+		(:very-large 20)
+		(:huge	     24)))
+
+(defmethod standardize-text-style ((display-device sheet-device) character-set style)
+  (standardize-text-style-1
+    display-device style character-set *sheet-logical-size-alist*))
+
+(define-display-device *sheet-device* sheet-device
+  :font-for-undefined-style fonts:boxfont)
+
+(define-text-style-mappings *sheet-device* *standard-character-set*
+  (:family :fix (:face :roman (:size 20 fonts:bigfnt
+				     14 fonts:medfnt
+				     12 fonts:cptfont
+				     10 fonts:tvfont
+				      8 fonts:einy7
+				      6 fonts:tiny)
+		       :italic (:size 20 fonts:bigfnti
+				      14 fonts:medfnti
+				      12 fonts:cptfonti
+				      10 fonts:tvfonti
+				       8 fonts:einy7
+				       6 fonts:tiny)
+		       :bold (:size 20 fonts:bigfntb
+				    14 fonts:medfntb
+				    12 fonts:cptfontcb
+				    10 fonts:tvfontb
+				     8 fonts:einy7
+				     6 fonts:tiny)
+		       (:bold :italic) (:size 20 fonts:bigfntbi
+					      14 fonts:medfntbi
+					      12 fonts:cptfontbi
+					      10 fonts:tvfontbi
+					       8 fonts:einy7
+					       6 fonts:tiny)
+		       (:bold :extended) (:size 12 fonts:cptfontb
+						10 fonts:tvfontb)
+		       :condensed (:size 12 fonts:cptfontc)
+		       (:extra :condensed) (:size 12 fonts:cptfontcc
+						  10 fonts:tvfont))))
+
+(define-text-style-mappings *sheet-device* *standard-character-set*
+  (:family :serif (:face :roman (:size 20 fonts:dutch20
+				       14 fonts:dutch14
+				       12 fonts:tr12
+				       10 fonts:tr10
+				        8 fonts:tr8)
+			 :italic (:size 20 fonts:dutch20I
+					14 fonts:dutch14I
+					12 fonts:tr12I
+					10 fonts:tr10I
+				 	 8 fonts:tr8I)
+			 :bold (:size 20 fonts:dutch20B
+				      14 fonts:dutch14B
+				      12 fonts:tr12B
+				      10 fonts:tr10B
+				       8 fonts:tr8B)
+			 (:bold :italic) (:size 20 fonts:dutch20BI
+						14 fonts:dutch14BI
+						12 fonts:tr12BI
+						10 fonts:tr10BI
+						 8 fonts:tr8BI))))
+
+(define-text-style-mappings *sheet-device* *standard-character-set*
+  (:family :sans-serif (:face :roman (:size 20 fonts:swiss20
+					    14	fonts:hl14
+					    12	fonts:hl12
+					    10	fonts:hl10
+					     8 fonts:hl8)
+			      :italic (:size 20 fonts:swiss20I
+					     14 fonts:hl14I
+					     12 fonts:hl12I
+					     10 fonts:hl10I
+					      8 fonts:hl8I)
+			      :bold (:size 20 fonts:swiss20B
+					   14 fonts:hl14B
+					   12 fonts:hl12B
+					   10 fonts:hl10B
+					    8 fonts:hl8B)
+			      (:bold :italic) (:size 20 fonts:swiss20BI
+						     14 fonts:hl14BI
+						     12 fonts:hl12BI
+						     10 fonts:hl10BI
+						      8 fonts:hl8BI))))
+
+#+IMach
+(defclass small-sheet-device (sheet-device) ())
+
+#+IMach
+(defparameter *small-sheet-logical-size-alist*
+	      '((:tiny       6)
+		(:very-small 8)
+		(:small	     10)
+		(:normal     12)
+		(:large	     14)
+		(:very-large 20)
+		(:huge	     24)))
+
+#+IMach
+(defmethod standardize-text-style ((display-device small-sheet-device) character-set style)
+  (standardize-text-style-1
+    display-device style character-set *small-sheet-logical-size-alist*))
+
+#+IMach
+(define-display-device *small-sheet-device* small-sheet-device
+  :font-for-undefined-style fonts:boxfont)
+
+#+IMach
+(define-text-style-mappings *small-sheet-device* *standard-character-set*
+  (:family :fix (:face :roman (:size 20 fonts:medfnt
+				     14 fonts:cptfont
+				     12 fonts:tvfont
+				     10 fonts:einy7
+				      8 fonts:einy7
+				      6 fonts:einy7)
+		       :italic (:size 20 fonts:medfnti
+				      14 fonts:cptfonti
+				      12 fonts:tvfonti 
+				      10 fonts:einy7
+				       8 fonts:einy7
+				       6 fonts:einy7)
+		       :bold (:size 20 fonts:medfntb
+				    14 fonts:cptfontcb
+				    12 fonts:tvfontb 
+				    10 fonts:einy7
+				     8 fonts:einy7
+				     6 fonts:einy7)
+		       (:bold :italic) (:size 20 fonts:medfntbi
+					      14 fonts:cptfontbi
+					      12 fonts:tvfontbi
+					      10 fonts:einy7
+					       8 fonts:einy7
+					       6 fonts:einy7)
+		       (:bold :extended) (:size 12 fonts:tvfontb
+						10 fonts:cptfontb)
+		       :condensed (:size 12 fonts:cptfontc)
+		       (:extra :condensed) (:size 12 fonts:cptfontcc
+						  10 fonts:tvfont))))
+
+#+IMach
+(define-text-style-mappings *small-sheet-device* *standard-character-set*
+  (:family :serif (:face :roman (:size 20 fonts:dutch14
+				       14 fonts:tr12
+				       12 fonts:tr10
+				       10 fonts:tr8
+				        8 fonts:tr8)
+			 :italic (:size 20 fonts:dutch14I
+					14 fonts:tr12I
+					12 fonts:tr10I
+					10 fonts:tr8I
+					 8 fonts:tr8I)
+			 :bold (:size 20 fonts:dutch14B
+				      14 fonts:tr12B
+				      12 fonts:tr10B
+				      10 fonts:tr8B
+				       8 fonts:tr8B)
+			 (:bold :italic) (:size 20 fonts:dutch14BI
+						14 fonts:tr12BI
+						12 fonts:tr10BI
+						10 fonts:tr8BI
+						 8 fonts:tr8BI))))
+
+#+IMach
+(define-text-style-mappings *small-sheet-device* *standard-character-set*
+  (:family :sans-serif (:face :roman (:size 20 fonts:hl14
+					    14 fonts:hl12
+					    12 fonts:hl10
+					    10 fonts:hl8
+					     8 fonts:hl8)
+			      :italic (:size 20 fonts:hl14I
+					     14 fonts:hl12I
+					     12 fonts:hl10I
+					     10 fonts:hl8I
+					      8 fonts:hl8I)
+			      :bold (:size 20 fonts:hl14B
+					   14 fonts:hl12B
+					   12 fonts:hl10B
+					   10 fonts:hl8B
+					    8 fonts:hl8B)
+			      (:bold :italic) (:size 20 fonts:hl14BI
+						     14 fonts:hl12BI
+						     12 fonts:hl10BI
+						     10 fonts:hl8BI
+						      8 fonts:hl8BI))))
+
+
+;;; Text Cursors for sheets
+
+(defclass sheet-text-cursor
+	  (cursor)
+    ((x :initarg :x :initform 0)		;needed if cursor is scrolled off viewport
+     (y :initarg :y :initform 0)
+     (stream :initarg :stream)
+     (active :initform nil)			;false if visibility is :inactive
+     (blinker :initform nil)))			;Genera window system blinker to be used
+
+(defmethod cursor-active-p ((cursor sheet-text-cursor))
+  (not (null (slot-value cursor 'active))))
+
+(defmethod (setf cursor-stream) (new-value (cursor sheet-text-cursor))
+  (setf (slot-value cursor 'stream) new-value)
+  (let ((blinker (slot-value cursor 'blinker)))
+    (when blinker
+      (tv:blinker-set-sheet blinker (slot-value new-value 'window))))
+  new-value)
+
+#-Silica
+(defmethod cursor-position* ((cursor sheet-text-cursor))
+  (values (slot-value cursor 'x) (slot-value cursor 'y)))
+
+#-Silica
+(defmethod cursor-set-position* ((cursor sheet-text-cursor) x y)
+  (setf (slot-value cursor 'x) x
+	(slot-value cursor 'y) y)
+  (let ((blinker (slot-value cursor 'blinker)))
+    (when blinker
+      (multiple-value-bind (x y)
+	  (drawing-surface-to-viewport-coordinates (slot-value cursor 'stream) x y)
+	(tv:blinker-set-cursorpos blinker x y)))))
+
+(defmethod cursor-visibility ((cursor sheet-text-cursor))
+  (let ((active (slot-value cursor 'active))
+	(blinker (slot-value cursor 'blinker)))
+    (cond ((not active) :inactive)
+	  ((not blinker) :off)
+	  ((member (tv:blinker-visibility blinker) '(:blink :on t)) :on)
+	  (t :off))))
+
+(defmethod (setf cursor-visibility) (new-visibility (cursor sheet-text-cursor))
+  (setf (slot-value cursor 'active) (not (eq new-visibility :inactive)))
+  (let ((stream (slot-value cursor 'stream))
+	(blinker (slot-value cursor 'blinker)))
+    (when (and (null blinker) (eq new-visibility :on))
+      ;; It isn't safe to create the blinker any earlier than this, because of the
+      ;; order of initializations while creating a sheet-window-stream
+      (setq blinker 
+	    (setf (slot-value cursor 'blinker)
+		  (flavor:make-instance 'tv:rectangular-blinker
+					:sheet (slot-value stream 'window)
+					:visibility nil
+					:deselected-visibility nil
+					:follow-p nil)))
+      (multiple-value-bind (x y)
+	  (drawing-surface-to-viewport-coordinates stream (slot-value cursor 'x)
+							  (slot-value cursor 'y))
+	(tv:blinker-set-cursorpos blinker x y)))
+    (when blinker
+      (tv:blinker-set-visibility blinker (if (eq new-visibility :on)
+					     (if (tv:sheet-selected-p
+						   (slot-value stream 'window))
+						 :blink
+						 :on)
+					     nil))
+      (scl:send blinker :set-deselected-visibility (if (eq new-visibility :on) :on nil))))
+  new-visibility)
+
+;; The window system draws it, so we don't have to
+(defmethod draw-cursor ((cursor sheet-text-cursor) on-p)
+  on-p)
diff --git a/pre-silica/graphics-generics.lisp b/pre-silica/graphics-generics.lisp
new file mode 100644
index 00000000..b4635645
--- /dev/null
+++ b/pre-silica/graphics-generics.lisp
@@ -0,0 +1,387 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: graphics-generics.lisp,v 1.4 91/03/26 12:48:01 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+(define-graphics-operation draw-point (x y)
+  :arguments ((point x y))
+  :drawing-options :point
+  :method-body
+    (with-transformed-arguments
+      (draw-point-internal stream 0 0 x y
+			   (medium-ink stream) (medium-line-style stream))))
+
+(defun draw-points (stream point-seq &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream point-seq &key . #.(all-drawing-options-lambda-list :point)))
+  (flet ((trampoline ()
+	   (if (listp point-seq)
+	       (loop
+		 (when (null point-seq) (return))
+		 (let ((point (pop point-seq)))
+		   (draw-point-method stream (point-x point) (point-y point))))
+	       (do ((i 0 (+ i 1)))
+		   ((= i (length point-seq)))
+		 (let ((point (aref point-seq i)))
+		   (draw-point-method stream (point-x point) (point-y point)))))))
+    (declare (dynamic-extent #'trampoline))
+    (if args
+	(apply #'invoke-with-drawing-options stream #'trampoline args)
+	(trampoline))))
+
+(defun draw-points* (stream coord-seq &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream coord-seq &key . #.(all-drawing-options-lambda-list :point)))
+  (flet ((trampoline ()
+	   (if (listp coord-seq)
+	       (loop
+		 (when (null coord-seq) (return))
+		 (draw-point-method stream (pop coord-seq) (pop coord-seq)))
+	     (do ((i 0 (+ i 2)))
+		 ((= i (length coord-seq)))
+	       (draw-point-method stream (aref coord-seq i) (aref coord-seq (1+ i)))))))
+    (declare (dynamic-extent #'trampoline))
+    (if args
+	(apply #'invoke-with-drawing-options stream #'trampoline args)
+	(trampoline))))
+
+;; QuickDraw and X support a drawing state with a pattern, thickness at the lowest
+;; level.  Only Genera needs to turn lines into rectangles or polygons.
+(define-graphics-operation draw-line (x1 y1 x2 y2)
+  :arguments ((point x1 y1 x2 y2))
+  :drawing-options :line-cap
+  :method-body
+    (with-transformed-arguments
+      (draw-line-internal stream 0 0 x1 y1 x2 y2
+			  (medium-ink stream) (medium-line-style stream))))
+
+(defun draw-lines (stream point-seq &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream point-seq &key . #.(all-drawing-options-lambda-list :line-cap)))
+  (flet ((trampoline ()
+	   (if (listp point-seq)
+	       (loop
+		 (when (null point-seq) (return))
+		 (let* ((point1 (pop point-seq))
+			(point2 (pop point-seq)))
+		   (draw-line-method stream
+				     (point-x point1) (point-y point1)
+				     (point-x point2) (point-y point2))))
+	     (do ((i 0 (+ i 2)))
+		 ((= i (length point-seq)))
+	       (let* ((point1 (aref point-seq i))
+		      (point2 (aref point-seq (1+ i))))
+		 (draw-line-method stream
+				   (point-x point1) (point-y point1)
+				   (point-x point2) (point-y point2)))))))
+    (declare (dynamic-extent #'trampoline))
+    (if args
+	(apply #'invoke-with-drawing-options stream #'trampoline args)
+	(trampoline))))
+
+(defun draw-lines* (stream coord-seq &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream coord-seq &key . #.(all-drawing-options-lambda-list :line-cap)))
+  (flet ((trampoline ()
+	   (if (listp coord-seq)
+	       (loop
+		 (when (null coord-seq) (return))
+		 (draw-line-method stream
+				   (pop coord-seq) (pop coord-seq)
+				   (pop coord-seq) (pop coord-seq)))
+	     (do ((i 0 (+ i 4)))
+		 ((= i (length coord-seq)))
+	       (draw-line-method stream
+				 (aref coord-seq i) (aref coord-seq (1+ i))
+				 (aref coord-seq (+ i 2)) (aref coord-seq (+ i 3)))))))
+    (declare (dynamic-extent #'trampoline))
+    (if args
+	(apply #'invoke-with-drawing-options stream #'trampoline args)
+	(trampoline))))
+
+(define-graphics-operation draw-arrow (x1 y1 x2 y2
+				       &key (from-head nil) (to-head t)
+					    (head-length 10) (head-width 5))
+  :arguments ((point x1 y1 x2 y2))
+  :drawing-options :line-cap
+  :method-body
+    (with-transformed-arguments
+      (let* ((dx (- x2 x1))
+	     (dy (- y2 y1))
+	     (norm (if (zerop dx)
+		       (if (zerop dy) nil (/ 1.0 (abs dy)))
+		       (if (zerop dy) (/ 1.0 (abs dx)) (/ (sqrt (+ (* dx dx) (* dy dy))))))))
+	(when norm
+	  (let* ((length-norm (* head-length norm))
+		 (ldx (* dx length-norm))
+		 (ldy (* dy length-norm))
+		 (base-norm (* head-width norm 0.5))
+		 (bdx (* dy base-norm))
+		 (bdy (* dx base-norm))
+		 (ink (medium-ink stream))
+		 (line-style (medium-line-style stream)))
+	    (draw-line-internal stream 0 0 x1 y1 x2 y2 ink line-style)
+	    (when from-head
+	      (let ((xa (+ x1 ldx)) (ya (+ y1 ldy)))
+		(with-stack-list (points x1 y1 (+ xa bdx) (- ya bdy) (- xa bdx) (+ ya bdy))
+		  (draw-polygon-internal stream 0 0 points t ink nil))
+		(setq x1 xa y1 ya)))
+	    (when to-head
+	      (let ((xa (- x2 ldx)) (ya (- y2 ldy)))
+		(with-stack-list (points x2 y2 (+ xa bdx) (- ya bdy) (- xa bdx) (+ ya bdy))
+		  (draw-polygon-internal stream 0 0 points t ink nil)
+		  (setq x2 xa y2 ya)))))))))
+
+;;; More complicated.  It has to decide when to call
+;;; draw-rectangle-internal vs. draw-polygon-internal
+(define-graphics-operation draw-rectangle (x1 y1 x2 y2 &key (filled t))
+  :arguments ((point x1 y1 x2 y2))
+  :drawing-options :line-joint
+  :method-body
+    (let ((transform (medium-transformation stream)))
+      (cond ((rectilinear-transformation-p transform)
+	     (with-transformed-arguments
+	       ;; "optimized" case
+	       ;; left, top, right, bottom might not actually be those points
+	       ;; if we've rotated by a multiple of pi.
+	       (let ((ll (min x1 x2))
+		     (tt (min y1 y2))
+		     (rr (max x1 x2))
+		     (bb (max y1 y2)))
+		 (draw-rectangle-internal stream 0 0 ll tt rr bb
+					  (medium-ink stream)
+					  (and (not filled)
+					       (medium-line-style stream))))))
+	    (t
+	     ;; massively inefficient 
+	     ;; --- note that "stream" and is a magic name here.
+	     (with-stack-list (list x1 y1 x2 y1 x2 y2 x1 y2)
+	       (draw-polygon-method stream list t filled))))))
+
+(defun draw-icon* (stream icon x y &key clipping-region transformation)
+  (check-type icon pattern)
+  (let ((width (pattern-width icon))
+	(height (pattern-height icon)))
+    (if (or clipping-region transformation)
+	(with-drawing-options (stream :clipping-region clipping-region
+				      :transformation transformation))
+	(draw-rectangle* stream x y (+ x width) (+ y height)
+			 :filled t :ink icon))))
+
+(defvar *float-tolerance* .00001)
+(defun float-= (n1 n2)
+  (< (abs (- n1 n2)) *float-tolerance*))
+
+(define-graphics-operation draw-ellipse (center-x center-y
+					 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+					 &key start-angle end-angle (filled t))
+  :arguments ((point center-x center-y)
+	      (distance radius-1-dx radius-1-dy radius-2-dx radius-2-dy))
+  :drawing-options :line-cap
+  :method-body
+    (with-transformed-arguments
+      (when (and start-angle (null end-angle))
+	(setq end-angle 2pi))
+      (when (and end-angle (null start-angle))
+	(setq start-angle 0))
+      (let ((transform (medium-transformation stream))
+	    (ink (medium-ink stream))
+	    (line-style (and (not filled) (medium-line-style stream))))
+	(when start-angle
+	  (when (reflection-transformation-p transform)
+	    (rotatef start-angle end-angle))
+	  (unless (<= 0f0 (abs (- end-angle start-angle)) 2pi)
+	    (nyi)))
+	(draw-ellipse-internal stream 0 0 center-x center-y 
+			       radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			       start-angle end-angle
+			       ink line-style))))
+
+(defun draw-circle (stream center radius &rest keys)
+  (declare (dynamic-extent keys))
+  (declare (arglist stream center radius
+		    &key start-angle end-angle (filled t)
+			 . #.(all-drawing-options-lambda-list :line-cap)))
+  (apply #'draw-ellipse stream center radius 0 0 radius keys))
+
+(defun draw-circle* (stream center-x center-y radius &rest keys)
+  (declare (dynamic-extent keys))
+  (declare (arglist stream center-x center-y radius
+		    &key start-angle end-angle (filled t)
+			 . #.(all-drawing-options-lambda-list :line-cap)))
+  (apply #'draw-ellipse* stream center-x center-y radius 0 0 radius keys))
+
+(define-graphics-operation draw-oval (center-x center-y x-radius y-radius
+				      &key (filled t))
+  :arguments ((point center-x center-y)
+	      (distance x-radius y-radius))
+  :drawing-options :line-cap
+  :method-body
+    (with-transformed-arguments
+      (let ((left (- center-x x-radius))
+	    (right (+ center-x x-radius))
+	    (top (- center-y y-radius))
+	    (bottom (+ center-y y-radius))
+	    (ink (medium-ink stream))
+	    (line-style (and (not filled) (medium-line-style stream))))
+	(cond ((or (= x-radius y-radius) 
+		   (zerop x-radius))
+	       (draw-ellipse-internal stream 0 0
+				      center-x center-y y-radius 0 0 y-radius
+				      nil nil ink line-style))
+	      ((zerop y-radius)
+	       (draw-ellipse-internal stream 0 0
+				      center-x center-y x-radius 0 0 x-radius
+				      nil nil ink line-style))
+	      ((> x-radius y-radius)
+	       (let ((rect-left (+ left y-radius))
+		     (rect-right (- right y-radius)))
+		 (cond (line-style
+			(draw-line-internal stream 0 0 
+					    rect-left top rect-right top
+					    ink line-style)
+			(draw-line-internal stream 0 0
+					    rect-left bottom rect-right bottom
+					    ink line-style))
+		       (t
+			(draw-rectangle-internal stream 0 0
+						 rect-left top rect-right bottom
+						 ink line-style)))
+		 (let ((north (float (* pi 1/2) 0.0))
+		       (south (float (* pi 3/2) 0.0)))
+		   (draw-ellipse-internal stream 0 0
+					  rect-left center-y y-radius 0 0 y-radius
+					  north south ink line-style)
+		   (draw-ellipse-internal stream 0 0
+					  rect-right center-y y-radius 0 0 y-radius
+					  south north ink line-style))))
+	      (t
+	       (let ((rect-top (+ top x-radius))
+		     (rect-bottom (- bottom x-radius)))
+		 (cond (line-style
+			(draw-line-internal stream 0 0 
+					    left rect-top left rect-bottom
+					    ink line-style)
+			(draw-line-internal stream 0 0 
+					    right rect-top right rect-bottom
+					    ink line-style))
+		       (t
+			(draw-rectangle-internal stream 0 0
+						 left rect-top right rect-bottom
+						 ink line-style)))
+		 (let ((east 0.0)
+		       (west (float pi 0.0)))
+		   (draw-ellipse-internal stream 0 0
+					  center-x rect-top x-radius 0 0 x-radius
+					  west east ink line-style)
+		   (draw-ellipse-internal stream 0 0
+					  center-x rect-bottom x-radius 0 0 x-radius
+					  east west ink line-style))))))))
+
+(define-graphics-operation draw-polygon (list-of-x-and-ys &key (closed t) (filled t))
+  :arguments ((point-sequence list-of-x-and-ys))
+  :drawing-options :line-joint-cap
+  :method-body
+    (with-transformed-arguments
+      (draw-polygon-internal stream 0 0 list-of-x-and-ys closed
+			     (medium-ink stream)
+			     (and (not filled) (medium-line-style stream)))))
+
+(defun draw-regular-polygon* (stream x1 y1 x2 y2 nsides
+			      &rest args &key (handedness :left) (closed t) &allow-other-keys)
+  (declare (dynamic-extent args))
+  (declare (arglist stream x1 y1 x2 y2 nsides
+		    &key (filled t) (handedness :left) (closed t)
+			 . #.(all-drawing-options-lambda-list :line-joint-cap)))
+  (let* ((theta (* (float (* pi (/ 2.0 nsides)) 0.0)
+		   (ecase handedness
+		     (:left +1)
+		     (:right -1))))
+	 (transform (make-rotation-transformation theta))
+	 (coordinates (list x1 y1 x2 y2))
+	 (dx (- x2 x1))
+	 (dy (- y2 y1))
+	 (next-x x2)
+	 (next-y y2))
+    (dotimes (i (- nsides 2))
+      #-(or Allegro Minima) (declare (ignore i))
+      (multiple-value-setq (dx dy)
+	(transform-distance transform dx dy))
+      (incf next-x dx)
+      (incf next-y dy)
+      (setq coordinates (append coordinates (list next-x next-y))))
+    (when closed
+      (setq coordinates (append coordinates (list x1 y1))))
+    (with-keywords-removed (args args '(:handedness))
+      (apply #'draw-polygon* stream coordinates args))))
+
+(defun draw-regular-polygon (stream point1 point2 nsides &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream point1 point2 nsides
+		    &key (handedness :left) (closed t) (filled t)
+			 . #.(all-drawing-options-lambda-list :line-joint-cap)))
+  (apply #'draw-regular-polygon* stream
+				 (point-x point1) (point-y point1)
+				 (point-x point2) (point-y point2)
+				 nsides args))
+
+(defun draw-triangle (stream p1 p2 p3 &rest keys)
+  (declare (dynamic-extent keys))
+  (declare (arglist stream p1 p2 p3
+		    &key (filled t) . #.(all-drawing-options-lambda-list :line-joint)))
+  (with-stack-list (points p1 p2 p3)
+    (apply #'draw-polygon stream points :closed t keys)))
+
+(defun draw-triangle* (stream x1 y1 x2 y2 x3 y3 &rest keys)
+  (declare (dynamic-extent keys))
+  (declare (arglist stream x1 y1 x2 y2 x3 y3
+		    &key (filled t) . #.(all-drawing-options-lambda-list :line-joint)))
+  (with-stack-list (points x1 y1 x2 y2 x3 y3)
+    (apply #'draw-polygon* stream points :closed t keys)))
+
+(define-graphics-operation draw-string (string x y
+					&key (start 0) end
+					     (align-x :left)	 ;:center, :right
+					     (align-y :baseline));:top, :center, :bottom
+  :arguments ((point x y))
+  :drawing-options :text
+  :method-body
+    (with-transformed-arguments
+      (draw-string-internal stream 0 0
+			    string x y start end align-x align-y
+			    (stream-merged-text-style stream)
+			    (medium-ink stream))))
+
+(define-graphics-operation draw-character (character x y
+					   &key (align-x :left)	    ;:center, :right
+						(align-y :baseline));:top, :center, :bottom  
+  :arguments ((point x y))
+  :drawing-options :text
+  :method-body
+    (with-transformed-arguments
+      (draw-character-internal stream 0 0
+			       character x y align-x align-y
+			       (stream-merged-text-style stream)
+			       (medium-ink stream))))
+
+(defun draw-text (stream text point &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream text point
+		    &key (start 0) end (align-x :left) (align-y :baseline)
+			 . #.(all-drawing-options-lambda-list :text)))
+  (if (characterp text)
+      (apply #'draw-character stream text point args)
+      (apply #'draw-string stream text point args)))
+
+(defun draw-text* (stream text x y &rest args)
+  (declare (dynamic-extent args))
+  (declare (arglist stream text x y
+		    &key (start 0) end (align-x :left) (align-y :baseline)
+			 . #.(all-drawing-options-lambda-list :text)))
+  (if (characterp text)
+      (apply #'draw-character* stream text x y args)
+      (apply #'draw-string* stream text x y args)))
diff --git a/pre-silica/graphics-internals.lisp b/pre-silica/graphics-internals.lisp
new file mode 100644
index 00000000..b847c862
--- /dev/null
+++ b/pre-silica/graphics-internals.lisp
@@ -0,0 +1,427 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: graphics-internals.lisp,v 1.4 91/03/26 12:48:02 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+(defmacro with-half-thickness ((lthickness rthickness) line-style &body body)
+  (let ((thickness '#:thickness))
+    `(let* ((,thickness  (if ,line-style (line-style-thickness ,line-style) 0))
+	    (,lthickness (floor ,thickness 2))
+	    (,rthickness (- ,thickness ,lthickness)))
+       ,@body)))
+
+;; Note that points and paths themselves have no thickness.  The stroking
+;; model CLIM uses is that, when a path is stroked, the pen is centered on
+;; the path, so that the thickness of the stroke is divided on both sides
+;; of the path.  For even-width pens, the extra ink appears on the left
+;; (or below) the path.
+(define-graphics-internal draw-point-internal (x y ink line-style)
+  :points-to-convert (x y)
+  :bounding-rectangle
+    (with-half-thickness (lthickness rthickness) line-style
+      (fix-rectangle (- x lthickness) (- y lthickness)
+		     (+ x rthickness) (+ y rthickness))))
+
+(defun make-design-from-output-record (record)
+  (multiple-value-bind (xoff yoff) (compute-output-record-offsets record)
+    (make-design-from-output-record-1 record xoff yoff)))
+
+(defmethod make-design-from-output-record-1
+	   ((record output-record-mixin) x-offset y-offset)
+  (let ((designs nil))
+    (flet ((make-design (record)
+	     (multiple-value-bind (xoff yoff) (output-record-position* record)
+	       (declare (type coordinate xoff yoff))
+	       (let ((design
+		       (make-design-from-output-record-1
+			 record
+			 (+ x-offset xoff) (+ y-offset yoff))))
+		 (when design (push design designs))))))
+      (declare (dynamic-extent #'make-design))
+      (map-over-output-records #'make-design record))
+    (make-instance 'composite-over :designs (apply #'vector designs))))
+			
+(defmethod make-design-from-output-record-1
+	   ((point point-displayed-output-record) x-offset y-offset)
+  (with-slots (x y ink) point
+    (compose-in
+      ink
+      (make-point (+ x x-offset) (+ y y-offset)))))
+
+(defgeneric draw-design (design stream &rest args)
+  (declare (arglist design stream &key . #.(all-drawing-options-lambda-list nil))))
+
+(defmethod draw-design ((point standard-point) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (multiple-value-bind (x y) (point-position* point)
+    (apply #'draw-point* stream x y args)))
+
+
+(define-graphics-internal draw-line-internal (x1 y1 x2 y2 ink line-style)
+  :points-to-convert (x1 y1 x2 y2)
+  :bounding-rectangle
+    (with-half-thickness (lthickness rthickness) line-style
+      (fix-rectangle (- (min x1 x2) lthickness) (- (min y1 y2) lthickness)
+		     (+ (max x1 x2) rthickness) (+ (max y1 y2) rthickness)))
+  :highlighting-test
+    ((x y)
+     (with-slots (x1 y1 x2 y2 line-style) record
+       (point-close-to-line-p x y x1 y1 x2 y2 (line-style-thickness line-style))))
+  :highlighting-function
+    ((stream state)
+     (declare (ignore state))					;for now.
+     (multiple-value-bind (xoff yoff)
+	 (convert-from-relative-to-absolute-coordinates
+	   stream (output-record-parent record))
+       (with-slots (x1 y1 x2 y2 line-style) record
+	 (outline-line-with-hexagon stream xoff yoff
+				    x1 y1 x2 y2 (line-style-thickness line-style))))))
+
+(defmethod make-design-from-output-record-1
+	   ((line line-displayed-output-record) x-offset y-offset)
+  (with-slots (x1 x2 y1 y2 ink) line
+    (compose-in
+      ink
+      (make-line* (+ x1 x-offset) (+ y1 y-offset)
+		  (+ x2 x-offset) (+ y2 y-offset)))))
+
+(defmethod draw-design ((line standard-line) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (multiple-value-bind (x1 y1) (line-start-point* line)
+    (multiple-value-bind (x2 y2) (line-end-point* line)
+      (apply #'draw-line* stream x1 y1 x2 y2 args))))
+
+(defun outline-line-with-hexagon (stream xoff yoff
+				  from-x from-y to-x to-y &optional (thickness 1))
+  (let ((distance (1+ (round thickness 2))))
+    (multiple-value-bind (x1 y1 x2 y2 x3 y3 x4 y4 x5 y5 x6 y6)
+	(cond ((eq (minusp (- to-x from-x)) (minusp (- to-y from-y)))
+	       (values (- from-x distance) (- from-y distance)
+		       (- from-x distance) (+ from-y distance)
+		       (- to-x distance) (+ to-y distance)
+		       (+ to-x distance) (+ to-y distance)
+		       (+ to-x distance) (- to-y distance)
+		       (+ from-x distance) (- from-y distance)))
+	      (t
+	       (when (> to-y from-y)
+		 ;; Make line go down to right.
+		 (rotatef to-x from-x)
+		 (rotatef to-y from-y))
+	       (values (- from-x distance) (+ from-y distance)
+		       (- from-x distance) (- from-y distance)
+		       (- to-x distance) (- to-y distance)
+		       (+ to-x distance) (- to-y distance)
+		       (+ to-x distance) (+ to-y distance)
+		       (+ from-x distance) (+ from-y distance))))
+      (macrolet ((line (x1 y1 x2 y2)
+		   `(draw-line-internal stream xoff yoff
+					,x1 ,y1 ,x2 ,y2
+					+flipping-ink+ +highlighting-line-style+)))
+	(with-output-recording-options (stream :record nil)
+	  (line x1 y1 x2 y2)
+	  (line x2 y2 x3 y3)
+	  (line x3 y3 x4 y4)
+	  (line x4 y4 x5 y5)
+	  (line x5 y5 x6 y6)
+	  (line x6 y6 x1 y1))))))
+
+
+(define-graphics-internal draw-rectangle-internal (x1 y1 x2 y2 ink line-style)
+  :points-to-convert (x1 y1 x2 y2)
+  :bounding-rectangle
+    (with-half-thickness (lthickness rthickness) line-style
+      (fix-rectangle (- x1 lthickness) (- y1 lthickness)
+		     (+ x2 rthickness) (+ y2 rthickness)))
+  :highlighting-test
+    ((x y)
+     (with-slots (x1 y1 x2 y2 line-style) record
+       (or (null line-style)
+	   (with-half-thickness (lthickness rthickness) line-style
+	     ;; Don't use LTRB-CONTAINS-POINT*-P, since that expects fixnums
+	     ;;---- Not any more!
+	     (not (and (<= (+ x1 rthickness) x)
+		       (<= (+ y1 rthickness) y)
+		       (>= (- x2 lthickness) x)
+		       (>= (- y2 lthickness) y)))))))
+  :highlighting-function
+    ((stream state)
+     (declare (ignore state))
+     (multiple-value-bind (xoff yoff)
+	 (convert-from-relative-to-absolute-coordinates
+	   stream (output-record-parent record))
+       (with-slots (x1 y1 x2 y2 line-style) record
+	 (with-output-recording-options (stream :record nil)
+	   (with-half-thickness (lthickness rthickness) line-style
+	     (draw-rectangle-internal
+	       stream xoff yoff
+	       (- x1 lthickness 1) (- y1 lthickness 1)
+	       (+ x2 rthickness 1) (+ y2 rthickness 1)
+	       +flipping-ink+ +highlighting-line-style+)))))))
+
+(defmethod make-design-from-output-record-1
+	   ((rectangle rectangle-displayed-output-record) x-offset y-offset)
+  (with-slots (x1 x2 y1 y2 line-style ink) rectangle
+    (compose-in
+      ink
+      (if (null line-style)
+	  (make-rectangle* (+ x1 x-offset) (+ y1 y-offset)
+			   (+ x2 x-offset) (+ y2 y-offset))
+          (make-polyline* (list (+ x1 x-offset) (+ y1 y-offset)
+				(+ x2 x-offset) (+ y1 y-offset)
+				(+ x2 x-offset) (+ y2 y-offset)
+				(+ x1 x-offset) (+ y2 y-offset))
+			  :closed t)))))
+
+(defmethod draw-design ((rectangle standard-rectangle) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rectangle)
+    (apply #'draw-rectangle* stream x1 y1 x2 y2 :filled t args)))
+
+
+;;--- This needs a :HIGHLIGHTING-TEST and :HIGHLIGHTING-FUNCTION
+(define-graphics-internal draw-polygon-internal (list-of-x-and-ys closed ink line-style)
+  :point-sequence-to-convert list-of-x-and-ys
+  :bounding-rectangle
+    (let* ((min-x (first list-of-x-and-ys))
+	   (min-y (second list-of-x-and-ys))
+	   (max-x min-x)
+	   (max-y min-y))
+      (dorest (position list-of-x-and-ys cddr)
+	(minf min-x (first position))
+	(minf min-y (second position))
+	(maxf max-x (first position))
+	(maxf max-y (second position)))
+      (with-half-thickness (lthickness rthickness) line-style
+	(fix-rectangle (- min-x lthickness) (- min-y lthickness)
+		       (+ max-x rthickness) (+ max-y rthickness)))))
+
+(defmethod make-design-from-output-record-1
+	   ((polygon polygon-displayed-output-record) x-offset y-offset)
+  (with-slots (list-of-xs-and-ys closed line-style ink) polygon
+    (let ((coords (copy-list list-of-xs-and-ys)))
+      (translate-point-sequence x-offset y-offset coords)
+      (compose-in
+	ink
+	(if (null line-style)
+	    (make-polygon* coords)
+            (make-polyline* coords :closed closed))))))
+
+(defmethod draw-design ((polygon standard-polygon) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (apply #'draw-polygon stream (polygon-points polygon) :closed t :filled t args))
+
+(defmethod draw-design ((polyline standard-polyline) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (with-slots (closed) polyline
+    (apply #'draw-polygon stream (polygon-points polyline) :closed closed :filled nil args)))
+
+
+;; By the time we get here, START-ANGLE and END-ANGLE are either both NIL
+;; or are both an angle measured in radians.
+(define-graphics-internal draw-ellipse-internal
+			  (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			   start-angle end-angle ink line-style)
+  :points-to-convert (center-x center-y)
+  :bounding-rectangle
+    (multiple-value-bind (left top right bottom)
+	(elliptical-arc-box center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			    start-angle end-angle
+			    (and line-style (line-style-thickness line-style)))
+      ;;--- Make this a bit too big because most hosts rasterize
+      ;;--- ellipses to be a shade too big on the right
+      (values left top (1+ right) (1+ bottom)))
+  :highlighting-test
+    ((x y)
+     (with-slots (center-x center-y
+		  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+		  start-angle end-angle ink line-style) record
+       (and (or (null start-angle)
+		;; NYI - check for within the proper angle
+		t)
+	    (if (null line-style)
+		(point-inside-ellipse-p (- x center-x) (- y center-y)
+					radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
+		(point-on-thick-ellipse-p (- x center-x) (- y center-y)
+					  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+					  (ceiling (line-style-thickness line-style) 2))))))
+  :highlighting-function
+    ((stream state)
+     (declare (ignore state))
+     (multiple-value-bind (xoff yoff)
+	 (convert-from-relative-to-absolute-coordinates
+	   stream (output-record-parent record))
+       (with-slots (center-x center-y
+		    radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+		    start-angle end-angle ink line-style) record
+	 (let ((delta 2)
+	       (radius-1 (sqrt (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy))))
+	       (radius-2 (sqrt (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy)))))
+	   (when line-style
+	     (incf delta (ceiling (line-style-thickness line-style) 2)))
+	   (let ((delta-1-dx (round (* delta radius-1-dx) radius-1))
+		 (delta-1-dy (round (* delta radius-1-dy) radius-1))
+		 (delta-2-dx (round (* delta radius-2-dx) radius-2))
+		 (delta-2-dy (round (* delta radius-2-dy) radius-2)))
+	     (with-output-recording-options (stream :record nil)
+	       (draw-ellipse-internal
+		 stream xoff yoff
+		 center-x center-y
+		 (+ radius-1-dx delta-1-dx) (+ radius-1-dy delta-1-dy)
+		 (+ radius-2-dx delta-2-dx) (+ radius-2-dy delta-2-dy)
+		 start-angle end-angle
+		 +flipping-ink+ +highlighting-line-style+))))))))
+
+(defmethod make-design-from-output-record-1
+	   ((ellipse ellipse-displayed-output-record) x-offset y-offset)
+  (with-slots (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+	       start-angle end-angle line-style ink) ellipse
+    (compose-in
+      ink
+      (if (null line-style)
+	  (make-ellipse* (+ center-x x-offset) (+ center-y y-offset)
+			 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			 :start-angle start-angle :end-angle end-angle)
+          (make-elliptical-arc* (+ center-x x-offset) (+ center-y y-offset)
+				radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+				:start-angle start-angle :end-angle end-angle)))))
+
+(defmethod draw-design ((ellipse standard-ellipse) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (multiple-value-bind (center-x center-y)
+      (ellipse-center-point* ellipse)
+    (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
+	(ellipse-radii ellipse)
+      (apply #'draw-ellipse* stream center-x center-y
+			     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			     :start-angle (ellipse-start-angle ellipse)
+			     :end-angle (ellipse-end-angle ellipse)
+			     :filled t args))))
+
+(defmethod draw-design ((ellipse standard-elliptical-arc) stream &rest args &key ink line-style)
+  (declare (dynamic-extent args)
+	   (ignore ink line-style))
+  (multiple-value-bind (center-x center-y)
+      (ellipse-center-point* ellipse)
+    (multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
+	(ellipse-radii ellipse)
+      (apply #'draw-ellipse* stream center-x center-y
+			     radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			     :start-angle (ellipse-start-angle ellipse)
+			     :end-angle (ellipse-end-angle ellipse)
+			     :filled nil args))))
+
+
+(define-graphics-internal draw-string-internal
+			  (string x y start end align-x align-y text-style ink)
+  :points-to-convert (x y)
+  ;; Don't want temporary strings to make it into the history
+  :output-recording-hook (setq string (evacuate-temporary-string string))
+  :bounding-rectangle
+    ;;--- How are we allowed to call STREAM-STRING-WIDTH if this isn't
+    ;;--- an extended output stream??
+    (let ((width (stream-string-width stream string :text-style text-style))
+	  (height (stream-line-height stream text-style))
+	  vx vt vr vb)
+      (declare (type coordinate width height))
+      (ecase align-x
+	(:left (setq vx x
+		     vr (+ x width)))
+	(:right (setq vx (- x width)
+		      vr x))
+	(:center (setq vx (- x (round width 2))
+		       vr (+ x (round width 2)))))
+      (ecase align-y
+	;;--- Using STREAM-LINE-HEIGHT for baseline isn't right.
+	(:baseline (setq vt (- y height)
+			 vb y))
+	(:top (setq vt y
+		    vb (+ y height)))
+	(:bottom (setq vt (- y height)
+		       vb y))
+	;;--- Use FLOOR and CEILING, no?
+	(:center (setq vt (- y (round height 2))
+		       vb (+ y (round height 2)))))
+      (fix-rectangle vx vt vr vb)))
+
+(define-graphics-internal draw-character-internal
+			  (character x y align-x align-y text-style ink)
+  :points-to-convert (x y)
+  ;;--- This has to deal with align-x and -y
+  :bounding-rectangle 
+    ;;--- How are we allowed to call STREAM-CHARACTER-WIDTH if this isn't
+    ;;--- an extended output stream?
+    (multiple-value-bind (width height)
+	(stream-character-size stream character text-style)
+      (declare (type coordinate width height))
+      (let (vx vt vr vb)
+	(ecase align-x
+	  (:left (setq vx x
+		       vr (+ x width)))
+	  (:right (setq vx (- x width)
+			vr x))
+	  (:center (setq vx (- x (round width 2))
+			 vr (+ x (round width 2)))))
+	(ecase align-y
+	  (:baseline (setq vt (- y height)
+			   vb y))
+	  (:top (setq vt y
+		      vb (+ y height)))
+	  (:bottom (setq vt (- y height)
+			 vb y))
+	  ;;--- Use FLOOR and CEILING, no?
+	  (:center (setq vt (- y (round height 2))
+			 vb (+ y (round height 2)))))
+	(fix-rectangle vx vt vr vb))))
+
+
+;;; Simple rendering of composite designs
+
+(defmethod draw-design ((composite composite-over) stream &rest args)
+  (declare (dynamic-extent args))
+  (with-slots ((designs clim-utils::designs)) composite
+    (dovector (design designs :from-end t)
+      (apply #'draw-design design stream args))))
+
+(defmethod draw-design ((composite composite-in) stream &rest args &key ink &allow-other-keys)
+  (declare (dynamic-extent args))
+  (with-slots ((designs clim-utils::designs)) composite
+    (let ((ink (or ink (aref designs 0)))	;should be COMPOSE-OVER
+	  (design (aref designs 1)))
+      ;; Clips INK to the inside of DESIGN.
+      (apply #'draw-design design stream :ink ink args))))
+
+(defmethod draw-design ((composite composite-out) stream &rest args &key ink &allow-other-keys)
+  (declare (dynamic-extent args))
+  (with-slots ((designs clim-utils::designs)) composite
+    (let ((ink (or ink (aref designs 0)))	;should be COMPOSE-OVER
+	  (design (aref designs 1)))
+      ;;--- Should clip INK to the outside of DESIGN, but I don't know how
+      (nyi))))
+
+(defmethod draw-design ((region standard-region-union) stream &rest args)
+  (declare (dynamic-extent args))
+  (with-slots ((regions clim-utils::regions)) region
+    (dolist (region regions)
+      (apply #'draw-design region stream args))))
+
+(defmethod draw-design ((region standard-region-intersection) stream &rest args)
+  (declare (dynamic-extent args))
+  (with-slots ((regions clim-utils::regions)) region
+    ;;--- Should draw just the intersection, but I dunno how to do that in general
+    (nyi)))
+
+(defmethod draw-design ((region standard-region-difference) stream &rest args)
+  (declare (dynamic-extent args))
+  (with-slots ((region1 clim-utils::region1)
+	       (region2 clim-utils::region2)) region
+    ;;--- Should draw just the difference, but I dunno how to do that in general
+    (nyi)))
diff --git a/pre-silica/laserwriter-metrics.lisp b/pre-silica/laserwriter-metrics.lisp
new file mode 100644
index 00000000..40c543d3
--- /dev/null
+++ b/pre-silica/laserwriter-metrics.lisp
@@ -0,0 +1,2145 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: laserwriter-metrics.lisp,v 1.4 91/03/26 12:48:11 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; Font Metrics for Apple Laser Writer builtin fonts
+
+;;; Note that the X values in the bounding box are incorrect.  I don't
+;;; know how this data was generated (it was inherited from the Genera
+;;; LGP2 support) but it is apparent that the font box information
+;;; (/FontBBox element of a PostScript fnt dictionary) was not scaled by
+;;; the font's matrix (/FontMatrix).  For the fonts that I tested (using
+;;; the PostScript program at the end of this file), the Y values were
+;;; correct but some of the X values were not.  Fortunately nothing uses
+;;; them.  [1/9/90 naha]
+
+(setup-laserwriter-metrics
+  '(("Times-Roman" 1000 (-167 -252 1004 904))
+    (#o040 250.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 408.0 "quotedbl")
+    (#o043 500.0 "numbersign")
+    (#o044 500.0 "dollar")
+    (#o045 833.0 "percent")
+    (#o046 778.0 "ampersand")
+    (#o047 333.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 500.0 "asterisk")
+    (#o053 564.0 "plus")
+    (#o054 250.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 250.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 500.0 "zero")
+    (#o061 500.0 "one")
+    (#o062 500.0 "two")
+    (#o063 500.0 "three")
+    (#o064 500.0 "four")
+    (#o065 500.0 "five")
+    (#o066 500.0 "six")
+    (#o067 500.0 "seven")
+    (#o070 500.0 "eight")
+    (#o071 500.0 "nine")
+    (#o072 278.0 "colon")
+    (#o073 278.0 "semicolon")
+    (#o074 564.0 "less")
+    (#o075 564.0 "equal")
+    (#o076 564.0 "greater")
+    (#o077 444.0 "question")
+    (#o100 921.0 "at")
+    (#o101 722.0 "A")
+    (#o102 667.0 "B")
+    (#o103 667.0 "C")
+    (#o104 722.0 "D")
+    (#o105 611.0 "E")
+    (#o106 556.0 "F")
+    (#o107 722.0 "G")
+    (#o110 722.0 "H")
+    (#o111 333.0 "I")
+    (#o112 389.0 "J")
+    (#o113 722.0 "K")
+    (#o114 611.0 "L")
+    (#o115 889.0 "M")
+    (#o116 722.0 "N")
+    (#o117 722.0 "O")
+    (#o120 556.0 "P")
+    (#o121 722.0 "Q")
+    (#o122 667.0 "R")
+    (#o123 556.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 722.0 "V")
+    (#o127 944.0 "W")
+    (#o130 722.0 "X")
+    (#o131 722.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 333.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 333.0 "bracketright")
+    (#o136 469.0 "asciicircum")
+    (#o137 500.0 "underscore")
+    (#o140 333.0 "quoteleft")
+    (#o141 444.0 "a")
+    (#o142 500.0 "b")
+    (#o143 444.0 "c")
+    (#o144 500.0 "d")
+    (#o145 444.0 "e")
+    (#o146 333.0 "f")
+    (#o147 500.0 "g")
+    (#o150 500.0 "h")
+    (#o151 278.0 "i")
+    (#o152 278.0 "j")
+    (#o153 500.0 "k")
+    (#o154 278.0 "l")
+    (#o155 778.0 "m")
+    (#o156 500.0 "n")
+    (#o157 500.0 "o")
+    (#o160 500.0 "p")
+    (#o161 500.0 "q")
+    (#o162 333.0 "r")
+    (#o163 389.0 "s")
+    (#o164 278.0 "t")
+    (#o165 500.0 "u")
+    (#o166 500.0 "v")
+    (#o167 722.0 "w")
+    (#o170 500.0 "x")
+    (#o171 500.0 "y")
+    (#o172 444.0 "z")
+    (#o173 480.0 "braceleft")
+    (#o174 200.0 "bar")
+    (#o175 480.0 "braceright")
+    (#o176 541.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 500.0 "cent")
+    (#o243 500.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 500.0 "yen")
+    (#o246 500.0 "florin")
+    (#o247 500.0 "section")
+    (#o250 500.0 "currency")
+    (#o251 180.0 "quotesingle")
+    (#o252 444.0 "quotedblleft")
+    (#o253 500.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 556.0 "fi")
+    (#o257 556.0 "fl")
+    (#o261 500.0 "endash")
+    (#o262 500.0 "dagger")
+    (#o263 500.0 "daggerdbl")
+    (#o264 250.0 "periodcentered")
+    (#o266 453.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 333.0 "quotesinglbase")
+    (#o271 444.0 "quotedblbase")
+    (#o272 444.0 "quotedblright")
+    (#o273 500.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 444.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 889.0 "AE")
+    (#o343 276.0 "ordfeminine")
+    (#o350 611.0 "Lslash")
+    (#o351 722.0 "Oslash")
+    (#o352 889.0 "OE")
+    (#o353 310.0 "ordmasculine")
+    (#o361 667.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 500.0 "oslash")
+    (#o372 722.0 "oe")
+    (#o373 500.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Times-Italic" 1000 (-176 -252 998 930))
+    (#o040 250.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 420.0 "quotedbl")
+    (#o043 500.0 "numbersign")
+    (#o044 500.0 "dollar")
+    (#o045 833.0 "percent")
+    (#o046 778.0 "ampersand")
+    (#o047 333.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 500.0 "asterisk")
+    (#o053 675.0 "plus")
+    (#o054 250.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 250.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 500.0 "zero")
+    (#o061 500.0 "one")
+    (#o062 500.0 "two")
+    (#o063 500.0 "three")
+    (#o064 500.0 "four")
+    (#o065 500.0 "five")
+    (#o066 500.0 "six")
+    (#o067 500.0 "seven")
+    (#o070 500.0 "eight")
+    (#o071 500.0 "nine")
+    (#o072 333.0 "colon")
+    (#o073 333.0 "semicolon")
+    (#o074 675.0 "less")
+    (#o075 675.0 "equal")
+    (#o076 675.0 "greater")
+    (#o077 500.0 "question")
+    (#o100 920.0 "at")
+    (#o101 611.0 "A")
+    (#o102 611.0 "B")
+    (#o103 667.0 "C")
+    (#o104 722.0 "D")
+    (#o105 611.0 "E")
+    (#o106 611.0 "F")
+    (#o107 722.0 "G")
+    (#o110 722.0 "H")
+    (#o111 333.0 "I")
+    (#o112 444.0 "J")
+    (#o113 667.0 "K")
+    (#o114 556.0 "L")
+    (#o115 833.0 "M")
+    (#o116 667.0 "N")
+    (#o117 722.0 "O")
+    (#o120 611.0 "P")
+    (#o121 722.0 "Q")
+    (#o122 611.0 "R")
+    (#o123 500.0 "S")
+    (#o124 556.0 "T")
+    (#o125 722.0 "U")
+    (#o126 611.0 "V")
+    (#o127 833.0 "W")
+    (#o130 611.0 "X")
+    (#o131 556.0 "Y")
+    (#o132 556.0 "Z")
+    (#o133 389.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 389.0 "bracketright")
+    (#o136 422.0 "asciicircum")
+    (#o137 500.0 "underscore")
+    (#o140 333.0 "quoteleft")
+    (#o141 500.0 "a")
+    (#o142 500.0 "b")
+    (#o143 444.0 "c")
+    (#o144 500.0 "d")
+    (#o145 444.0 "e")
+    (#o146 278.0 "f")
+    (#o147 500.0 "g")
+    (#o150 500.0 "h")
+    (#o151 278.0 "i")
+    (#o152 278.0 "j")
+    (#o153 444.0 "k")
+    (#o154 278.0 "l")
+    (#o155 722.0 "m")
+    (#o156 500.0 "n")
+    (#o157 500.0 "o")
+    (#o160 500.0 "p")
+    (#o161 500.0 "q")
+    (#o162 389.0 "r")
+    (#o163 389.0 "s")
+    (#o164 278.0 "t")
+    (#o165 500.0 "u")
+    (#o166 444.0 "v")
+    (#o167 667.0 "w")
+    (#o170 444.0 "x")
+    (#o171 444.0 "y")
+    (#o172 389.0 "z")
+    (#o173 400.0 "braceleft")
+    (#o174 275.0 "bar")
+    (#o175 400.0 "braceright")
+    (#o176 541.0 "asciitilde")
+    (#o241 389.0 "exclamdown")
+    (#o242 500.0 "cent")
+    (#o243 500.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 500.0 "yen")
+    (#o246 500.0 "florin")
+    (#o247 500.0 "section")
+    (#o250 500.0 "currency")
+    (#o251 214.0 "quotesingle")
+    (#o252 556.0 "quotedblleft")
+    (#o253 500.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 500.0 "fi")
+    (#o257 500.0 "fl")
+    (#o261 500.0 "endash")
+    (#o262 500.0 "dagger")
+    (#o263 500.0 "daggerdbl")
+    (#o264 250.0 "periodcentered")
+    (#o266 523.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 333.0 "quotesinglbase")
+    (#o271 556.0 "quotedblbase")
+    (#o272 556.0 "quotedblright")
+    (#o273 500.0 "guillemotright")
+    (#o274 889.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 500.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 889.0 "emdash")
+    (#o341 889.0 "AE")
+    (#o343 276.0 "ordfeminine")
+    (#o350 556.0 "Lslash")
+    (#o351 722.0 "Oslash")
+    (#o352 944.0 "OE")
+    (#o353 310.0 "ordmasculine")
+    (#o361 667.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 500.0 "oslash")
+    (#o372 667.0 "oe")
+    (#o373 500.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Times-Bold" 1000 (-172 -257 1008 965))
+    (#o040 250.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 555.0 "quotedbl")
+    (#o043 500.0 "numbersign")
+    (#o044 500.0 "dollar")
+    (#o045 1000.0 "percent")
+    (#o046 833.0 "ampersand")
+    (#o047 333.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 500.0 "asterisk")
+    (#o053 570.0 "plus")
+    (#o054 250.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 250.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 500.0 "zero")
+    (#o061 500.0 "one")
+    (#o062 500.0 "two")
+    (#o063 500.0 "three")
+    (#o064 500.0 "four")
+    (#o065 500.0 "five")
+    (#o066 500.0 "six")
+    (#o067 500.0 "seven")
+    (#o070 500.0 "eight")
+    (#o071 500.0 "nine")
+    (#o072 333.0 "colon")
+    (#o073 333.0 "semicolon")
+    (#o074 570.0 "less")
+    (#o075 570.0 "equal")
+    (#o076 570.0 "greater")
+    (#o077 500.0 "question")
+    (#o100 930.0 "at")
+    (#o101 722.0 "A")
+    (#o102 667.0 "B")
+    (#o103 722.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 611.0 "F")
+    (#o107 778.0 "G")
+    (#o110 778.0 "H")
+    (#o111 389.0 "I")
+    (#o112 500.0 "J")
+    (#o113 778.0 "K")
+    (#o114 667.0 "L")
+    (#o115 944.0 "M")
+    (#o116 722.0 "N")
+    (#o117 778.0 "O")
+    (#o120 611.0 "P")
+    (#o121 778.0 "Q")
+    (#o122 722.0 "R")
+    (#o123 556.0 "S")
+    (#o124 667.0 "T")
+    (#o125 722.0 "U")
+    (#o126 722.0 "V")
+    (#o127 1000.0 "W")
+    (#o130 722.0 "X")
+    (#o131 722.0 "Y")
+    (#o132 667.0 "Z")
+    (#o133 333.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 333.0 "bracketright")
+    (#o136 581.0 "asciicircum")
+    (#o137 500.0 "underscore")
+    (#o140 333.0 "quoteleft")
+    (#o141 500.0 "a")
+    (#o142 556.0 "b")
+    (#o143 444.0 "c")
+    (#o144 556.0 "d")
+    (#o145 444.0 "e")
+    (#o146 333.0 "f")
+    (#o147 500.0 "g")
+    (#o150 556.0 "h")
+    (#o151 278.0 "i")
+    (#o152 333.0 "j")
+    (#o153 556.0 "k")
+    (#o154 278.0 "l")
+    (#o155 833.0 "m")
+    (#o156 556.0 "n")
+    (#o157 500.0 "o")
+    (#o160 556.0 "p")
+    (#o161 556.0 "q")
+    (#o162 444.0 "r")
+    (#o163 389.0 "s")
+    (#o164 333.0 "t")
+    (#o165 556.0 "u")
+    (#o166 500.0 "v")
+    (#o167 722.0 "w")
+    (#o170 500.0 "x")
+    (#o171 500.0 "y")
+    (#o172 444.0 "z")
+    (#o173 394.0 "braceleft")
+    (#o174 220.0 "bar")
+    (#o175 394.0 "braceright")
+    (#o176 520.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 500.0 "cent")
+    (#o243 500.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 500.0 "yen")
+    (#o246 500.0 "florin")
+    (#o247 500.0 "section")
+    (#o250 500.0 "currency")
+    (#o251 278.0 "quotesingle")
+    (#o252 500.0 "quotedblleft")
+    (#o253 500.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 556.0 "fi")
+    (#o257 556.0 "fl")
+    (#o261 500.0 "endash")
+    (#o262 500.0 "dagger")
+    (#o263 500.0 "daggerdbl")
+    (#o264 250.0 "periodcentered")
+    (#o266 540.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 333.0 "quotesinglbase")
+    (#o271 500.0 "quotedblbase")
+    (#o272 500.0 "quotedblright")
+    (#o273 500.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 500.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 1000.0 "AE")
+    (#o343 300.0 "ordfeminine")
+    (#o350 667.0 "Lslash")
+    (#o351 778.0 "Oslash")
+    (#o352 1000.0 "OE")
+    (#o353 330.0 "ordmasculine")
+    (#o361 722.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 500.0 "oslash")
+    (#o372 722.0 "oe")
+    (#o373 556.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Times-BoldItalic" 1000 (-183 -250 1004 973))
+    (#o040 250.0 "space")
+    (#o041 389.0 "exclam")
+    (#o042 555.0 "quotedbl")
+    (#o043 500.0 "numbersign")
+    (#o044 500.0 "dollar")
+    (#o045 833.0 "percent")
+    (#o046 778.0 "ampersand")
+    (#o047 333.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 500.0 "asterisk")
+    (#o053 570.0 "plus")
+    (#o054 250.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 250.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 500.0 "zero")
+    (#o061 500.0 "one")
+    (#o062 500.0 "two")
+    (#o063 500.0 "three")
+    (#o064 500.0 "four")
+    (#o065 500.0 "five")
+    (#o066 500.0 "six")
+    (#o067 500.0 "seven")
+    (#o070 500.0 "eight")
+    (#o071 500.0 "nine")
+    (#o072 333.0 "colon")
+    (#o073 333.0 "semicolon")
+    (#o074 570.0 "less")
+    (#o075 570.0 "equal")
+    (#o076 570.0 "greater")
+    (#o077 500.0 "question")
+    (#o100 832.0 "at")
+    (#o101 667.0 "A")
+    (#o102 667.0 "B")
+    (#o103 667.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 667.0 "F")
+    (#o107 722.0 "G")
+    (#o110 778.0 "H")
+    (#o111 389.0 "I")
+    (#o112 500.0 "J")
+    (#o113 667.0 "K")
+    (#o114 611.0 "L")
+    (#o115 889.0 "M")
+    (#o116 722.0 "N")
+    (#o117 722.0 "O")
+    (#o120 611.0 "P")
+    (#o121 722.0 "Q")
+    (#o122 667.0 "R")
+    (#o123 556.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 667.0 "V")
+    (#o127 889.0 "W")
+    (#o130 667.0 "X")
+    (#o131 611.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 333.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 333.0 "bracketright")
+    (#o136 570.0 "asciicircum")
+    (#o137 500.0 "underscore")
+    (#o140 333.0 "quoteleft")
+    (#o141 500.0 "a")
+    (#o142 500.0 "b")
+    (#o143 444.0 "c")
+    (#o144 500.0 "d")
+    (#o145 444.0 "e")
+    (#o146 333.0 "f")
+    (#o147 500.0 "g")
+    (#o150 556.0 "h")
+    (#o151 278.0 "i")
+    (#o152 278.0 "j")
+    (#o153 500.0 "k")
+    (#o154 278.0 "l")
+    (#o155 778.0 "m")
+    (#o156 556.0 "n")
+    (#o157 500.0 "o")
+    (#o160 500.0 "p")
+    (#o161 500.0 "q")
+    (#o162 389.0 "r")
+    (#o163 389.0 "s")
+    (#o164 278.0 "t")
+    (#o165 556.0 "u")
+    (#o166 444.0 "v")
+    (#o167 667.0 "w")
+    (#o170 500.0 "x")
+    (#o171 444.0 "y")
+    (#o172 389.0 "z")
+    (#o173 348.0 "braceleft")
+    (#o174 220.0 "bar")
+    (#o175 348.0 "braceright")
+    (#o176 570.0 "asciitilde")
+    (#o241 389.0 "exclamdown")
+    (#o242 500.0 "cent")
+    (#o243 500.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 500.0 "yen")
+    (#o246 500.0 "florin")
+    (#o247 500.0 "section")
+    (#o250 500.0 "currency")
+    (#o251 278.0 "quotesingle")
+    (#o252 500.0 "quotedblleft")
+    (#o253 500.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 556.0 "fi")
+    (#o257 556.0 "fl")
+    (#o261 500.0 "endash")
+    (#o262 500.0 "dagger")
+    (#o263 500.0 "daggerdbl")
+    (#o264 250.0 "periodcentered")
+    (#o266 500.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 333.0 "quotesinglbase")
+    (#o271 500.0 "quotedblbase")
+    (#o272 500.0 "quotedblright")
+    (#o273 500.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 500.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 944.0 "AE")
+    (#o343 266.0 "ordfeminine")
+    (#o350 611.0 "Lslash")
+    (#o351 722.0 "Oslash")
+    (#o352 944.0 "OE")
+    (#o353 300.0 "ordmasculine")
+    (#o361 722.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 500.0 "oslash")
+    (#o372 722.0 "oe")
+    (#o373 500.0 "germandbls")
+    ))
+
+
+(setup-laserwriter-metrics
+  '(("Helvetica" 1000 (-174 -234 1001 941))
+    (#o040 278.0 "space")
+    (#o041 278.0 "exclam")
+    (#o042 355.0 "quotedbl")
+    (#o043 556.0 "numbersign")
+    (#o044 556.0 "dollar")
+    (#o045 889.0 "percent")
+    (#o046 667.0 "ampersand")
+    (#o047 222.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 389.0 "asterisk")
+    (#o053 584.0 "plus")
+    (#o054 278.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 278.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 556.0 "zero")
+    (#o061 556.0 "one")
+    (#o062 556.0 "two")
+    (#o063 556.0 "three")
+    (#o064 556.0 "four")
+    (#o065 556.0 "five")
+    (#o066 556.0 "six")
+    (#o067 556.0 "seven")
+    (#o070 556.0 "eight")
+    (#o071 556.0 "nine")
+    (#o072 278.0 "colon")
+    (#o073 278.0 "semicolon")
+    (#o074 584.0 "less")
+    (#o075 584.0 "equal")
+    (#o076 584.0 "greater")
+    (#o077 556.0 "question")
+    (#o100 1015.0 "at")
+    (#o101 667.0 "A")
+    (#o102 667.0 "B")
+    (#o103 722.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 611.0 "F")
+    (#o107 778.0 "G")
+    (#o110 722.0 "H")
+    (#o111 278.0 "I")
+    (#o112 500.0 "J")
+    (#o113 667.0 "K")
+    (#o114 556.0 "L")
+    (#o115 833.0 "M")
+    (#o116 722.0 "N")
+    (#o117 778.0 "O")
+    (#o120 667.0 "P")
+    (#o121 778.0 "Q")
+    (#o122 722.0 "R")
+    (#o123 667.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 667.0 "V")
+    (#o127 944.0 "W")
+    (#o130 667.0 "X")
+    (#o131 667.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 278.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 278.0 "bracketright")
+    (#o136 469.0 "asciicircum")
+    (#o137 556.0 "underscore")
+    (#o140 222.0 "quoteleft")
+    (#o141 556.0 "a")
+    (#o142 556.0 "b")
+    (#o143 500.0 "c")
+    (#o144 556.0 "d")
+    (#o145 556.0 "e")
+    (#o146 278.0 "f")
+    (#o147 556.0 "g")
+    (#o150 556.0 "h")
+    (#o151 222.0 "i")
+    (#o152 222.0 "j")
+    (#o153 500.0 "k")
+    (#o154 222.0 "l")
+    (#o155 833.0 "m")
+    (#o156 556.0 "n")
+    (#o157 556.0 "o")
+    (#o160 556.0 "p")
+    (#o161 556.0 "q")
+    (#o162 333.0 "r")
+    (#o163 500.0 "s")
+    (#o164 278.0 "t")
+    (#o165 556.0 "u")
+    (#o166 500.0 "v")
+    (#o167 722.0 "w")
+    (#o170 500.0 "x")
+    (#o171 500.0 "y")
+    (#o172 500.0 "z")
+    (#o173 334.0 "braceleft")
+    (#o174 260.0 "bar")
+    (#o175 334.0 "braceright")
+    (#o176 584.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 556.0 "cent")
+    (#o243 556.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 556.0 "yen")
+    (#o246 556.0 "florin")
+    (#o247 556.0 "section")
+    (#o250 556.0 "currency")
+    (#o251 191.0 "quotesingle")
+    (#o252 333.0 "quotedblleft")
+    (#o253 556.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 500.0 "fi")
+    (#o257 500.0 "fl")
+    (#o261 556.0 "endash")
+    (#o262 556.0 "dagger")
+    (#o263 556.0 "daggerdbl")
+    (#o264 278.0 "periodcentered")
+    (#o266 537.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 222.0 "quotesinglbase")
+    (#o271 333.0 "quotedblbase")
+    (#o272 333.0 "quotedblright")
+    (#o273 556.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 611.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 1000.0 "AE")
+    (#o343 370.0 "ordfeminine")
+    (#o350 556.0 "Lslash")
+    (#o351 778.0 "Oslash")
+    (#o352 1000.0 "OE")
+    (#o353 365.0 "ordmasculine")
+    (#o361 889.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 222.0 "lslash")
+    (#o371 611.0 "oslash")
+    (#o372 944.0 "oe")
+    (#o373 611.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Helvetica-Oblique" 1000 (-174 -234 1001 941))
+    (#o040 278.0 "space")
+    (#o041 278.0 "exclam")
+    (#o042 355.0 "quotedbl")
+    (#o043 556.0 "numbersign")
+    (#o044 556.0 "dollar")
+    (#o045 889.0 "percent")
+    (#o046 667.0 "ampersand")
+    (#o047 222.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 389.0 "asterisk")
+    (#o053 584.0 "plus")
+    (#o054 278.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 278.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 556.0 "zero")
+    (#o061 556.0 "one")
+    (#o062 556.0 "two")
+    (#o063 556.0 "three")
+    (#o064 556.0 "four")
+    (#o065 556.0 "five")
+    (#o066 556.0 "six")
+    (#o067 556.0 "seven")
+    (#o070 556.0 "eight")
+    (#o071 556.0 "nine")
+    (#o072 278.0 "colon")
+    (#o073 278.0 "semicolon")
+    (#o074 584.0 "less")
+    (#o075 584.0 "equal")
+    (#o076 584.0 "greater")
+    (#o077 556.0 "question")
+    (#o100 1015.0 "at")
+    (#o101 667.0 "A")
+    (#o102 667.0 "B")
+    (#o103 722.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 611.0 "F")
+    (#o107 778.0 "G")
+    (#o110 722.0 "H")
+    (#o111 278.0 "I")
+    (#o112 500.0 "J")
+    (#o113 667.0 "K")
+    (#o114 556.0 "L")
+    (#o115 833.0 "M")
+    (#o116 722.0 "N")
+    (#o117 778.0 "O")
+    (#o120 667.0 "P")
+    (#o121 778.0 "Q")
+    (#o122 722.0 "R")
+    (#o123 667.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 667.0 "V")
+    (#o127 944.0 "W")
+    (#o130 667.0 "X")
+    (#o131 667.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 278.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 278.0 "bracketright")
+    (#o136 469.0 "asciicircum")
+    (#o137 556.0 "underscore")
+    (#o140 222.0 "quoteleft")
+    (#o141 556.0 "a")
+    (#o142 556.0 "b")
+    (#o143 500.0 "c")
+    (#o144 556.0 "d")
+    (#o145 556.0 "e")
+    (#o146 278.0 "f")
+    (#o147 556.0 "g")
+    (#o150 556.0 "h")
+    (#o151 222.0 "i")
+    (#o152 222.0 "j")
+    (#o153 500.0 "k")
+    (#o154 222.0 "l")
+    (#o155 833.0 "m")
+    (#o156 556.0 "n")
+    (#o157 556.0 "o")
+    (#o160 556.0 "p")
+    (#o161 556.0 "q")
+    (#o162 333.0 "r")
+    (#o163 500.0 "s")
+    (#o164 278.0 "t")
+    (#o165 556.0 "u")
+    (#o166 500.0 "v")
+    (#o167 722.0 "w")
+    (#o170 500.0 "x")
+    (#o171 500.0 "y")
+    (#o172 500.0 "z")
+    (#o173 334.0 "braceleft")
+    (#o174 260.0 "bar")
+    (#o175 334.0 "braceright")
+    (#o176 584.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 556.0 "cent")
+    (#o243 556.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 556.0 "yen")
+    (#o246 556.0 "florin")
+    (#o247 556.0 "section")
+    (#o250 556.0 "currency")
+    (#o251 191.0 "quotesingle")
+    (#o252 333.0 "quotedblleft")
+    (#o253 556.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 500.0 "fi")
+    (#o257 500.0 "fl")
+    (#o261 556.0 "endash")
+    (#o262 556.0 "dagger")
+    (#o263 556.0 "daggerdbl")
+    (#o264 278.0 "periodcentered")
+    (#o266 537.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 222.0 "quotesinglbase")
+    (#o271 333.0 "quotedblbase")
+    (#o272 333.0 "quotedblright")
+    (#o273 556.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 611.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 1000.0 "AE")
+    (#o343 370.0 "ordfeminine")
+    (#o350 556.0 "Lslash")
+    (#o351 778.0 "Oslash")
+    (#o352 1000.0 "OE")
+    (#o353 365.0 "ordmasculine")
+    (#o361 889.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 222.0 "lslash")
+    (#o371 611.0 "oslash")
+    (#o372 944.0 "oe")
+    (#o373 611.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Helvetica-Bold" 1000 (-173 -241 1003 936))
+    (#o040 278.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 474.0 "quotedbl")
+    (#o043 556.0 "numbersign")
+    (#o044 556.0 "dollar")
+    (#o045 889.0 "percent")
+    (#o046 722.0 "ampersand")
+    (#o047 278.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 389.0 "asterisk")
+    (#o053 584.0 "plus")
+    (#o054 278.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 278.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 556.0 "zero")
+    (#o061 556.0 "one")
+    (#o062 556.0 "two")
+    (#o063 556.0 "three")
+    (#o064 556.0 "four")
+    (#o065 556.0 "five")
+    (#o066 556.0 "six")
+    (#o067 556.0 "seven")
+    (#o070 556.0 "eight")
+    (#o071 556.0 "nine")
+    (#o072 333.0 "colon")
+    (#o073 333.0 "semicolon")
+    (#o074 584.0 "less")
+    (#o075 584.0 "equal")
+    (#o076 584.0 "greater")
+    (#o077 611.0 "question")
+    (#o100 975.0 "at")
+    (#o101 722.0 "A")
+    (#o102 722.0 "B")
+    (#o103 722.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 611.0 "F")
+    (#o107 778.0 "G")
+    (#o110 722.0 "H")
+    (#o111 278.0 "I")
+    (#o112 556.0 "J")
+    (#o113 722.0 "K")
+    (#o114 611.0 "L")
+    (#o115 833.0 "M")
+    (#o116 722.0 "N")
+    (#o117 778.0 "O")
+    (#o120 667.0 "P")
+    (#o121 778.0 "Q")
+    (#o122 722.0 "R")
+    (#o123 667.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 667.0 "V")
+    (#o127 944.0 "W")
+    (#o130 667.0 "X")
+    (#o131 667.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 333.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 333.0 "bracketright")
+    (#o136 584.0 "asciicircum")
+    (#o137 556.0 "underscore")
+    (#o140 278.0 "quoteleft")
+    (#o141 556.0 "a")
+    (#o142 611.0 "b")
+    (#o143 556.0 "c")
+    (#o144 611.0 "d")
+    (#o145 556.0 "e")
+    (#o146 333.0 "f")
+    (#o147 611.0 "g")
+    (#o150 611.0 "h")
+    (#o151 278.0 "i")
+    (#o152 278.0 "j")
+    (#o153 556.0 "k")
+    (#o154 278.0 "l")
+    (#o155 889.0 "m")
+    (#o156 611.0 "n")
+    (#o157 611.0 "o")
+    (#o160 611.0 "p")
+    (#o161 611.0 "q")
+    (#o162 389.0 "r")
+    (#o163 556.0 "s")
+    (#o164 333.0 "t")
+    (#o165 611.0 "u")
+    (#o166 556.0 "v")
+    (#o167 778.0 "w")
+    (#o170 556.0 "x")
+    (#o171 556.0 "y")
+    (#o172 500.0 "z")
+    (#o173 389.0 "braceleft")
+    (#o174 280.0 "bar")
+    (#o175 389.0 "braceright")
+    (#o176 584.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 556.0 "cent")
+    (#o243 556.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 556.0 "yen")
+    (#o246 556.0 "florin")
+    (#o247 556.0 "section")
+    (#o250 556.0 "currency")
+    (#o251 238.0 "quotesingle")
+    (#o252 500.0 "quotedblleft")
+    (#o253 556.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 611.0 "fi")
+    (#o257 611.0 "fl")
+    (#o261 556.0 "endash")
+    (#o262 556.0 "dagger")
+    (#o263 556.0 "daggerdbl")
+    (#o264 278.0 "periodcentered")
+    (#o266 556.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 278.0 "quotesinglbase")
+    (#o271 500.0 "quotedblbase")
+    (#o272 500.0 "quotedblright")
+    (#o273 556.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 611.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 1000.0 "AE")
+    (#o343 370.0 "ordfeminine")
+    (#o350 611.0 "Lslash")
+    (#o351 778.0 "Oslash")
+    (#o352 1000.0 "OE")
+    (#o353 365.0 "ordmasculine")
+    (#o361 889.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 611.0 "oslash")
+    (#o372 944.0 "oe")
+    (#o373 611.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Helvetica-BoldOblique" 1000 (-173 -241 1003 936))
+    (#o040 278.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 474.0 "quotedbl")
+    (#o043 556.0 "numbersign")
+    (#o044 556.0 "dollar")
+    (#o045 889.0 "percent")
+    (#o046 722.0 "ampersand")
+    (#o047 278.0 "quoteright")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 389.0 "asterisk")
+    (#o053 584.0 "plus")
+    (#o054 278.0 "comma")
+    (#o055 333.0 "hyphen")
+    (#o056 278.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 556.0 "zero")
+    (#o061 556.0 "one")
+    (#o062 556.0 "two")
+    (#o063 556.0 "three")
+    (#o064 556.0 "four")
+    (#o065 556.0 "five")
+    (#o066 556.0 "six")
+    (#o067 556.0 "seven")
+    (#o070 556.0 "eight")
+    (#o071 556.0 "nine")
+    (#o072 333.0 "colon")
+    (#o073 333.0 "semicolon")
+    (#o074 584.0 "less")
+    (#o075 584.0 "equal")
+    (#o076 584.0 "greater")
+    (#o077 611.0 "question")
+    (#o100 975.0 "at")
+    (#o101 722.0 "A")
+    (#o102 722.0 "B")
+    (#o103 722.0 "C")
+    (#o104 722.0 "D")
+    (#o105 667.0 "E")
+    (#o106 611.0 "F")
+    (#o107 778.0 "G")
+    (#o110 722.0 "H")
+    (#o111 278.0 "I")
+    (#o112 556.0 "J")
+    (#o113 722.0 "K")
+    (#o114 611.0 "L")
+    (#o115 833.0 "M")
+    (#o116 722.0 "N")
+    (#o117 778.0 "O")
+    (#o120 667.0 "P")
+    (#o121 778.0 "Q")
+    (#o122 722.0 "R")
+    (#o123 667.0 "S")
+    (#o124 611.0 "T")
+    (#o125 722.0 "U")
+    (#o126 667.0 "V")
+    (#o127 944.0 "W")
+    (#o130 667.0 "X")
+    (#o131 667.0 "Y")
+    (#o132 611.0 "Z")
+    (#o133 333.0 "bracketleft")
+    (#o134 278.0 "backslash")
+    (#o135 333.0 "bracketright")
+    (#o136 584.0 "asciicircum")
+    (#o137 556.0 "underscore")
+    (#o140 278.0 "quoteleft")
+    (#o141 556.0 "a")
+    (#o142 611.0 "b")
+    (#o143 556.0 "c")
+    (#o144 611.0 "d")
+    (#o145 556.0 "e")
+    (#o146 333.0 "f")
+    (#o147 611.0 "g")
+    (#o150 611.0 "h")
+    (#o151 278.0 "i")
+    (#o152 278.0 "j")
+    (#o153 556.0 "k")
+    (#o154 278.0 "l")
+    (#o155 889.0 "m")
+    (#o156 611.0 "n")
+    (#o157 611.0 "o")
+    (#o160 611.0 "p")
+    (#o161 611.0 "q")
+    (#o162 389.0 "r")
+    (#o163 556.0 "s")
+    (#o164 333.0 "t")
+    (#o165 611.0 "u")
+    (#o166 556.0 "v")
+    (#o167 778.0 "w")
+    (#o170 556.0 "x")
+    (#o171 556.0 "y")
+    (#o172 500.0 "z")
+    (#o173 389.0 "braceleft")
+    (#o174 280.0 "bar")
+    (#o175 389.0 "braceright")
+    (#o176 584.0 "asciitilde")
+    (#o241 333.0 "exclamdown")
+    (#o242 556.0 "cent")
+    (#o243 556.0 "sterling")
+    (#o244 167.0 "fraction")
+    (#o245 556.0 "yen")
+    (#o246 556.0 "florin")
+    (#o247 556.0 "section")
+    (#o250 556.0 "currency")
+    (#o251 238.0 "quotesingle")
+    (#o252 500.0 "quotedblleft")
+    (#o253 556.0 "guillemotleft")
+    (#o254 333.0 "guilsinglleft")
+    (#o255 333.0 "guilsinglright")
+    (#o256 611.0 "fi")
+    (#o257 611.0 "fl")
+    (#o261 556.0 "endash")
+    (#o262 556.0 "dagger")
+    (#o263 556.0 "daggerdbl")
+    (#o264 278.0 "periodcentered")
+    (#o266 556.0 "paragraph")
+    (#o267 350.0 "bullet")
+    (#o270 278.0 "quotesinglbase")
+    (#o271 500.0 "quotedblbase")
+    (#o272 500.0 "quotedblright")
+    (#o273 556.0 "guillemotright")
+    (#o274 1000.0 "ellipsis")
+    (#o275 1000.0 "perthousand")
+    (#o277 611.0 "questiondown")
+    (#o301 333.0 "grave")
+    (#o302 333.0 "acute")
+    (#o303 333.0 "circumflex")
+    (#o304 333.0 "tilde")
+    (#o305 333.0 "macron")
+    (#o306 333.0 "breve")
+    (#o307 333.0 "dotaccent")
+    (#o310 333.0 "dieresis")
+    (#o312 333.0 "ring")
+    (#o313 333.0 "cedilla")
+    (#o315 333.0 "hungarumlaut")
+    (#o316 333.0 "ogonek")
+    (#o317 333.0 "caron")
+    (#o320 1000.0 "emdash")
+    (#o341 1000.0 "AE")
+    (#o343 370.0 "ordfeminine")
+    (#o350 611.0 "Lslash")
+    (#o351 778.0 "Oslash")
+    (#o352 1000.0 "OE")
+    (#o353 365.0 "ordmasculine")
+    (#o361 889.0 "ae")
+    (#o365 278.0 "dotlessi")
+    (#o370 278.0 "lslash")
+    (#o371 611.0 "oslash")
+    (#o372 944.0 "oe")
+    (#o373 611.0 "germandbls")
+    ))
+
+
+;;; In fact, the Courier metrics never get used because they are fixed-width
+;;; fonts that get handled specially by the PostScript code itself.
+
+(setup-laserwriter-metrics
+  '(("Courier" 1000 (0 -251 600 700))
+    (#o040 600.0 "space")
+    (#o041 600.0 "exclam")
+    (#o042 600.0 "quotedbl")
+    (#o043 600.0 "numbersign")
+    (#o044 600.0 "dollar")
+    (#o045 600.0 "percent")
+    (#o046 600.0 "ampersand")
+    (#o047 600.0 "quoteright")
+    (#o050 600.0 "parenleft")
+    (#o051 600.0 "parenright")
+    (#o052 600.0 "asterisk")
+    (#o053 600.0 "plus")
+    (#o054 600.0 "comma")
+    (#o055 600.0 "hyphen")
+    (#o056 600.0 "period")
+    (#o057 600.0 "slash")
+    (#o060 600.0 "zero")
+    (#o061 600.0 "one")
+    (#o062 600.0 "two")
+    (#o063 600.0 "three")
+    (#o064 600.0 "four")
+    (#o065 600.0 "five")
+    (#o066 600.0 "six")
+    (#o067 600.0 "seven")
+    (#o070 600.0 "eight")
+    (#o071 600.0 "nine")
+    (#o072 600.0 "colon")
+    (#o073 600.0 "semicolon")
+    (#o074 600.0 "less")
+    (#o075 600.0 "equal")
+    (#o076 600.0 "greater")
+    (#o077 600.0 "question")
+    (#o100 600.0 "at")
+    (#o101 600.0 "A")
+    (#o102 600.0 "B")
+    (#o103 600.0 "C")
+    (#o104 600.0 "D")
+    (#o105 600.0 "E")
+    (#o106 600.0 "F")
+    (#o107 600.0 "G")
+    (#o110 600.0 "H")
+    (#o111 600.0 "I")
+    (#o112 600.0 "J")
+    (#o113 600.0 "K")
+    (#o114 600.0 "L")
+    (#o115 600.0 "M")
+    (#o116 600.0 "N")
+    (#o117 600.0 "O")
+    (#o120 600.0 "P")
+    (#o121 600.0 "Q")
+    (#o122 600.0 "R")
+    (#o123 600.0 "S")
+    (#o124 600.0 "T")
+    (#o125 600.0 "U")
+    (#o126 600.0 "V")
+    (#o127 600.0 "W")
+    (#o130 600.0 "X")
+    (#o131 600.0 "Y")
+    (#o132 600.0 "Z")
+    (#o133 600.0 "bracketleft")
+    (#o134 600.0 "backslash")
+    (#o135 600.0 "bracketright")
+    (#o136 600.0 "asciicircum")
+    (#o137 600.0 "underscore")
+    (#o140 600.0 "quoteleft")
+    (#o141 600.0 "a")
+    (#o142 600.0 "b")
+    (#o143 600.0 "c")
+    (#o144 600.0 "d")
+    (#o145 600.0 "e")
+    (#o146 600.0 "f")
+    (#o147 600.0 "g")
+    (#o150 600.0 "h")
+    (#o151 600.0 "i")
+    (#o152 600.0 "j")
+    (#o153 600.0 "k")
+    (#o154 600.0 "l")
+    (#o155 600.0 "m")
+    (#o156 600.0 "n")
+    (#o157 600.0 "o")
+    (#o160 600.0 "p")
+    (#o161 600.0 "q")
+    (#o162 600.0 "r")
+    (#o163 600.0 "s")
+    (#o164 600.0 "t")
+    (#o165 600.0 "u")
+    (#o166 600.0 "v")
+    (#o167 600.0 "w")
+    (#o170 600.0 "x")
+    (#o171 600.0 "y")
+    (#o172 600.0 "z")
+    (#o173 600.0 "braceleft")
+    (#o174 600.0 "bar")
+    (#o175 600.0 "braceright")
+    (#o176 600.0 "asciitilde")
+    (#o241 600.0 "exclamdown")
+    (#o242 600.0 "cent")
+    (#o243 600.0 "sterling")
+    (#o244 600.0 "fraction")
+    (#o245 600.0 "yen")
+    (#o246 600.0 "florin")
+    (#o247 600.0 "section")
+    (#o250 600.0 "currency")
+    (#o251 600.0 "quotesingle")
+    (#o252 600.0 "quotedblleft")
+    (#o253 600.0 "guillemotleft")
+    (#o254 600.0 "guilsinglleft")
+    (#o255 600.0 "guilsinglright")
+    (#o256 600.0 "fi")
+    (#o257 600.0 "fl")
+    (#o261 600.0 "endash")
+    (#o262 600.0 "dagger")
+    (#o263 600.0 "daggerdbl")
+    (#o264 600.0 "periodcentered")
+    (#o266 600.0 "paragraph")
+    (#o267 600.0 "bullet")
+    (#o270 600.0 "quotesinglbase")
+    (#o271 600.0 "quotedblbase")
+    (#o272 600.0 "quotedblright")
+    (#o273 600.0 "guillemotright")
+    (#o274 600.0 "ellipsis")
+    (#o275 600.0 "perthousand")
+    (#o277 600.0 "questiondown")
+    (#o301 600.0 "grave")
+    (#o302 600.0 "acute")
+    (#o303 600.0 "circumflex")
+    (#o304 600.0 "tilde")
+    (#o305 600.0 "macron")
+    (#o306 600.0 "breve")
+    (#o307 600.0 "dotaccent")
+    (#o310 600.0 "dieresis")
+    (#o312 600.0 "ring")
+    (#o313 600.0 "cedilla")
+    (#o315 600.0 "hungarumlaut")
+    (#o316 600.0 "ogonek")
+    (#o317 600.0 "caron")
+    (#o320 600.0 "emdash")
+    (#o341 600.0 "AE")
+    (#o343 600.0 "ordfeminine")
+    (#o350 600.0 "Lslash")
+    (#o351 600.0 "Oslash")
+    (#o352 600.0 "OE")
+    (#o353 600.0 "ordmasculine")
+    (#o361 600.0 "ae")
+    (#o365 600.0 "dotlessi")
+    (#o370 600.0 "lslash")
+    (#o371 600.0 "oslash")
+    (#o372 600.0 "oe")
+    (#o373 600.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Courier-Oblique" 1000 (0 -251 600 700))
+    (#o040 600.0 "space")
+    (#o041 600.0 "exclam")
+    (#o042 600.0 "quotedbl")
+    (#o043 600.0 "numbersign")
+    (#o044 600.0 "dollar")
+    (#o045 600.0 "percent")
+    (#o046 600.0 "ampersand")
+    (#o047 600.0 "quoteright")
+    (#o050 600.0 "parenleft")
+    (#o051 600.0 "parenright")
+    (#o052 600.0 "asterisk")
+    (#o053 600.0 "plus")
+    (#o054 600.0 "comma")
+    (#o055 600.0 "hyphen")
+    (#o056 600.0 "period")
+    (#o057 600.0 "slash")
+    (#o060 600.0 "zero")
+    (#o061 600.0 "one")
+    (#o062 600.0 "two")
+    (#o063 600.0 "three")
+    (#o064 600.0 "four")
+    (#o065 600.0 "five")
+    (#o066 600.0 "six")
+    (#o067 600.0 "seven")
+    (#o070 600.0 "eight")
+    (#o071 600.0 "nine")
+    (#o072 600.0 "colon")
+    (#o073 600.0 "semicolon")
+    (#o074 600.0 "less")
+    (#o075 600.0 "equal")
+    (#o076 600.0 "greater")
+    (#o077 600.0 "question")
+    (#o100 600.0 "at")
+    (#o101 600.0 "A")
+    (#o102 600.0 "B")
+    (#o103 600.0 "C")
+    (#o104 600.0 "D")
+    (#o105 600.0 "E")
+    (#o106 600.0 "F")
+    (#o107 600.0 "G")
+    (#o110 600.0 "H")
+    (#o111 600.0 "I")
+    (#o112 600.0 "J")
+    (#o113 600.0 "K")
+    (#o114 600.0 "L")
+    (#o115 600.0 "M")
+    (#o116 600.0 "N")
+    (#o117 600.0 "O")
+    (#o120 600.0 "P")
+    (#o121 600.0 "Q")
+    (#o122 600.0 "R")
+    (#o123 600.0 "S")
+    (#o124 600.0 "T")
+    (#o125 600.0 "U")
+    (#o126 600.0 "V")
+    (#o127 600.0 "W")
+    (#o130 600.0 "X")
+    (#o131 600.0 "Y")
+    (#o132 600.0 "Z")
+    (#o133 600.0 "bracketleft")
+    (#o134 600.0 "backslash")
+    (#o135 600.0 "bracketright")
+    (#o136 600.0 "asciicircum")
+    (#o137 600.0 "underscore")
+    (#o140 600.0 "quoteleft")
+    (#o141 600.0 "a")
+    (#o142 600.0 "b")
+    (#o143 600.0 "c")
+    (#o144 600.0 "d")
+    (#o145 600.0 "e")
+    (#o146 600.0 "f")
+    (#o147 600.0 "g")
+    (#o150 600.0 "h")
+    (#o151 600.0 "i")
+    (#o152 600.0 "j")
+    (#o153 600.0 "k")
+    (#o154 600.0 "l")
+    (#o155 600.0 "m")
+    (#o156 600.0 "n")
+    (#o157 600.0 "o")
+    (#o160 600.0 "p")
+    (#o161 600.0 "q")
+    (#o162 600.0 "r")
+    (#o163 600.0 "s")
+    (#o164 600.0 "t")
+    (#o165 600.0 "u")
+    (#o166 600.0 "v")
+    (#o167 600.0 "w")
+    (#o170 600.0 "x")
+    (#o171 600.0 "y")
+    (#o172 600.0 "z")
+    (#o173 600.0 "braceleft")
+    (#o174 600.0 "bar")
+    (#o175 600.0 "braceright")
+    (#o176 600.0 "asciitilde")
+    (#o241 600.0 "exclamdown")
+    (#o242 600.0 "cent")
+    (#o243 600.0 "sterling")
+    (#o244 600.0 "fraction")
+    (#o245 600.0 "yen")
+    (#o246 600.0 "florin")
+    (#o247 600.0 "section")
+    (#o250 600.0 "currency")
+    (#o251 600.0 "quotesingle")
+    (#o252 600.0 "quotedblleft")
+    (#o253 600.0 "guillemotleft")
+    (#o254 600.0 "guilsinglleft")
+    (#o255 600.0 "guilsinglright")
+    (#o256 600.0 "fi")
+    (#o257 600.0 "fl")
+    (#o261 600.0 "endash")
+    (#o262 600.0 "dagger")
+    (#o263 600.0 "daggerdbl")
+    (#o264 600.0 "periodcentered")
+    (#o266 600.0 "paragraph")
+    (#o267 600.0 "bullet")
+    (#o270 600.0 "quotesinglbase")
+    (#o271 600.0 "quotedblbase")
+    (#o272 600.0 "quotedblright")
+    (#o273 600.0 "guillemotright")
+    (#o274 600.0 "ellipsis")
+    (#o275 600.0 "perthousand")
+    (#o277 600.0 "questiondown")
+    (#o301 600.0 "grave")
+    (#o302 600.0 "acute")
+    (#o303 600.0 "circumflex")
+    (#o304 600.0 "tilde")
+    (#o305 600.0 "macron")
+    (#o306 600.0 "breve")
+    (#o307 600.0 "dotaccent")
+    (#o310 600.0 "dieresis")
+    (#o312 600.0 "ring")
+    (#o313 600.0 "cedilla")
+    (#o315 600.0 "hungarumlaut")
+    (#o316 600.0 "ogonek")
+    (#o317 600.0 "caron")
+    (#o320 600.0 "emdash")
+    (#o341 600.0 "AE")
+    (#o343 600.0 "ordfeminine")
+    (#o350 600.0 "Lslash")
+    (#o351 600.0 "Oslash")
+    (#o352 600.0 "OE")
+    (#o353 600.0 "ordmasculine")
+    (#o361 600.0 "ae")
+    (#o365 600.0 "dotlessi")
+    (#o370 600.0 "lslash")
+    (#o371 600.0 "oslash")
+    (#o372 600.0 "oe")
+    (#o373 600.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Courier-Bold" 1000 (0 -251 600 700))
+    (#o040 600.0 "space")
+    (#o041 600.0 "exclam")
+    (#o042 600.0 "quotedbl")
+    (#o043 600.0 "numbersign")
+    (#o044 600.0 "dollar")
+    (#o045 600.0 "percent")
+    (#o046 600.0 "ampersand")
+    (#o047 600.0 "quoteright")
+    (#o050 600.0 "parenleft")
+    (#o051 600.0 "parenright")
+    (#o052 600.0 "asterisk")
+    (#o053 600.0 "plus")
+    (#o054 600.0 "comma")
+    (#o055 600.0 "hyphen")
+    (#o056 600.0 "period")
+    (#o057 600.0 "slash")
+    (#o060 600.0 "zero")
+    (#o061 600.0 "one")
+    (#o062 600.0 "two")
+    (#o063 600.0 "three")
+    (#o064 600.0 "four")
+    (#o065 600.0 "five")
+    (#o066 600.0 "six")
+    (#o067 600.0 "seven")
+    (#o070 600.0 "eight")
+    (#o071 600.0 "nine")
+    (#o072 600.0 "colon")
+    (#o073 600.0 "semicolon")
+    (#o074 600.0 "less")
+    (#o075 600.0 "equal")
+    (#o076 600.0 "greater")
+    (#o077 600.0 "question")
+    (#o100 600.0 "at")
+    (#o101 600.0 "A")
+    (#o102 600.0 "B")
+    (#o103 600.0 "C")
+    (#o104 600.0 "D")
+    (#o105 600.0 "E")
+    (#o106 600.0 "F")
+    (#o107 600.0 "G")
+    (#o110 600.0 "H")
+    (#o111 600.0 "I")
+    (#o112 600.0 "J")
+    (#o113 600.0 "K")
+    (#o114 600.0 "L")
+    (#o115 600.0 "M")
+    (#o116 600.0 "N")
+    (#o117 600.0 "O")
+    (#o120 600.0 "P")
+    (#o121 600.0 "Q")
+    (#o122 600.0 "R")
+    (#o123 600.0 "S")
+    (#o124 600.0 "T")
+    (#o125 600.0 "U")
+    (#o126 600.0 "V")
+    (#o127 600.0 "W")
+    (#o130 600.0 "X")
+    (#o131 600.0 "Y")
+    (#o132 600.0 "Z")
+    (#o133 600.0 "bracketleft")
+    (#o134 600.0 "backslash")
+    (#o135 600.0 "bracketright")
+    (#o136 600.0 "asciicircum")
+    (#o137 600.0 "underscore")
+    (#o140 600.0 "quoteleft")
+    (#o141 600.0 "a")
+    (#o142 600.0 "b")
+    (#o143 600.0 "c")
+    (#o144 600.0 "d")
+    (#o145 600.0 "e")
+    (#o146 600.0 "f")
+    (#o147 600.0 "g")
+    (#o150 600.0 "h")
+    (#o151 600.0 "i")
+    (#o152 600.0 "j")
+    (#o153 600.0 "k")
+    (#o154 600.0 "l")
+    (#o155 600.0 "m")
+    (#o156 600.0 "n")
+    (#o157 600.0 "o")
+    (#o160 600.0 "p")
+    (#o161 600.0 "q")
+    (#o162 600.0 "r")
+    (#o163 600.0 "s")
+    (#o164 600.0 "t")
+    (#o165 600.0 "u")
+    (#o166 600.0 "v")
+    (#o167 600.0 "w")
+    (#o170 600.0 "x")
+    (#o171 600.0 "y")
+    (#o172 600.0 "z")
+    (#o173 600.0 "braceleft")
+    (#o174 600.0 "bar")
+    (#o175 600.0 "braceright")
+    (#o176 600.0 "asciitilde")
+    (#o241 600.0 "exclamdown")
+    (#o242 600.0 "cent")
+    (#o243 600.0 "sterling")
+    (#o244 600.0 "fraction")
+    (#o245 600.0 "yen")
+    (#o246 600.0 "florin")
+    (#o247 600.0 "section")
+    (#o250 600.0 "currency")
+    (#o251 600.0 "quotesingle")
+    (#o252 600.0 "quotedblleft")
+    (#o253 600.0 "guillemotleft")
+    (#o254 600.0 "guilsinglleft")
+    (#o255 600.0 "guilsinglright")
+    (#o256 600.0 "fi")
+    (#o257 600.0 "fl")
+    (#o261 600.0 "endash")
+    (#o262 600.0 "dagger")
+    (#o263 600.0 "daggerdbl")
+    (#o264 600.0 "periodcentered")
+    (#o266 600.0 "paragraph")
+    (#o267 600.0 "bullet")
+    (#o270 600.0 "quotesinglbase")
+    (#o271 600.0 "quotedblbase")
+    (#o272 600.0 "quotedblright")
+    (#o273 600.0 "guillemotright")
+    (#o274 600.0 "ellipsis")
+    (#o275 600.0 "perthousand")
+    (#o277 600.0 "questiondown")
+    (#o301 600.0 "grave")
+    (#o302 600.0 "acute")
+    (#o303 600.0 "circumflex")
+    (#o304 600.0 "tilde")
+    (#o305 600.0 "macron")
+    (#o306 600.0 "breve")
+    (#o307 600.0 "dotaccent")
+    (#o310 600.0 "dieresis")
+    (#o312 600.0 "ring")
+    (#o313 600.0 "cedilla")
+    (#o315 600.0 "hungarumlaut")
+    (#o316 600.0 "ogonek")
+    (#o317 600.0 "caron")
+    (#o320 600.0 "emdash")
+    (#o341 600.0 "AE")
+    (#o343 600.0 "ordfeminine")
+    (#o350 600.0 "Lslash")
+    (#o351 600.0 "Oslash")
+    (#o352 600.0 "OE")
+    (#o353 600.0 "ordmasculine")
+    (#o361 600.0 "ae")
+    (#o365 600.0 "dotlessi")
+    (#o370 600.0 "lslash")
+    (#o371 600.0 "oslash")
+    (#o372 600.0 "oe")
+    (#o373 600.0 "germandbls")
+    ))
+
+(setup-laserwriter-metrics
+  '(("Courier-BoldOblique" 1000 (0 -251 600 700))
+    (#o040 600.0 "space")
+    (#o041 600.0 "exclam")
+    (#o042 600.0 "quotedbl")
+    (#o043 600.0 "numbersign")
+    (#o044 600.0 "dollar")
+    (#o045 600.0 "percent")
+    (#o046 600.0 "ampersand")
+    (#o047 600.0 "quoteright")
+    (#o050 600.0 "parenleft")
+    (#o051 600.0 "parenright")
+    (#o052 600.0 "asterisk")
+    (#o053 600.0 "plus")
+    (#o054 600.0 "comma")
+    (#o055 600.0 "hyphen")
+    (#o056 600.0 "period")
+    (#o057 600.0 "slash")
+    (#o060 600.0 "zero")
+    (#o061 600.0 "one")
+    (#o062 600.0 "two")
+    (#o063 600.0 "three")
+    (#o064 600.0 "four")
+    (#o065 600.0 "five")
+    (#o066 600.0 "six")
+    (#o067 600.0 "seven")
+    (#o070 600.0 "eight")
+    (#o071 600.0 "nine")
+    (#o072 600.0 "colon")
+    (#o073 600.0 "semicolon")
+    (#o074 600.0 "less")
+    (#o075 600.0 "equal")
+    (#o076 600.0 "greater")
+    (#o077 600.0 "question")
+    (#o100 600.0 "at")
+    (#o101 600.0 "A")
+    (#o102 600.0 "B")
+    (#o103 600.0 "C")
+    (#o104 600.0 "D")
+    (#o105 600.0 "E")
+    (#o106 600.0 "F")
+    (#o107 600.0 "G")
+    (#o110 600.0 "H")
+    (#o111 600.0 "I")
+    (#o112 600.0 "J")
+    (#o113 600.0 "K")
+    (#o114 600.0 "L")
+    (#o115 600.0 "M")
+    (#o116 600.0 "N")
+    (#o117 600.0 "O")
+    (#o120 600.0 "P")
+    (#o121 600.0 "Q")
+    (#o122 600.0 "R")
+    (#o123 600.0 "S")
+    (#o124 600.0 "T")
+    (#o125 600.0 "U")
+    (#o126 600.0 "V")
+    (#o127 600.0 "W")
+    (#o130 600.0 "X")
+    (#o131 600.0 "Y")
+    (#o132 600.0 "Z")
+    (#o133 600.0 "bracketleft")
+    (#o134 600.0 "backslash")
+    (#o135 600.0 "bracketright")
+    (#o136 600.0 "asciicircum")
+    (#o137 600.0 "underscore")
+    (#o140 600.0 "quoteleft")
+    (#o141 600.0 "a")
+    (#o142 600.0 "b")
+    (#o143 600.0 "c")
+    (#o144 600.0 "d")
+    (#o145 600.0 "e")
+    (#o146 600.0 "f")
+    (#o147 600.0 "g")
+    (#o150 600.0 "h")
+    (#o151 600.0 "i")
+    (#o152 600.0 "j")
+    (#o153 600.0 "k")
+    (#o154 600.0 "l")
+    (#o155 600.0 "m")
+    (#o156 600.0 "n")
+    (#o157 600.0 "o")
+    (#o160 600.0 "p")
+    (#o161 600.0 "q")
+    (#o162 600.0 "r")
+    (#o163 600.0 "s")
+    (#o164 600.0 "t")
+    (#o165 600.0 "u")
+    (#o166 600.0 "v")
+    (#o167 600.0 "w")
+    (#o170 600.0 "x")
+    (#o171 600.0 "y")
+    (#o172 600.0 "z")
+    (#o173 600.0 "braceleft")
+    (#o174 600.0 "bar")
+    (#o175 600.0 "braceright")
+    (#o176 600.0 "asciitilde")
+    (#o241 600.0 "exclamdown")
+    (#o242 600.0 "cent")
+    (#o243 600.0 "sterling")
+    (#o244 600.0 "fraction")
+    (#o245 600.0 "yen")
+    (#o246 600.0 "florin")
+    (#o247 600.0 "section")
+    (#o250 600.0 "currency")
+    (#o251 600.0 "quotesingle")
+    (#o252 600.0 "quotedblleft")
+    (#o253 600.0 "guillemotleft")
+    (#o254 600.0 "guilsinglleft")
+    (#o255 600.0 "guilsinglright")
+    (#o256 600.0 "fi")
+    (#o257 600.0 "fl")
+    (#o261 600.0 "endash")
+    (#o262 600.0 "dagger")
+    (#o263 600.0 "daggerdbl")
+    (#o264 600.0 "periodcentered")
+    (#o266 600.0 "paragraph")
+    (#o267 600.0 "bullet")
+    (#o270 600.0 "quotesinglbase")
+    (#o271 600.0 "quotedblbase")
+    (#o272 600.0 "quotedblright")
+    (#o273 600.0 "guillemotright")
+    (#o274 600.0 "ellipsis")
+    (#o275 600.0 "perthousand")
+    (#o277 600.0 "questiondown")
+    (#o301 600.0 "grave")
+    (#o302 600.0 "acute")
+    (#o303 600.0 "circumflex")
+    (#o304 600.0 "tilde")
+    (#o305 600.0 "macron")
+    (#o306 600.0 "breve")
+    (#o307 600.0 "dotaccent")
+    (#o310 600.0 "dieresis")
+    (#o312 600.0 "ring")
+    (#o313 600.0 "cedilla")
+    (#o315 600.0 "hungarumlaut")
+    (#o316 600.0 "ogonek")
+    (#o317 600.0 "caron")
+    (#o320 600.0 "emdash")
+    (#o341 600.0 "AE")
+    (#o343 600.0 "ordfeminine")
+    (#o350 600.0 "Lslash")
+    (#o351 600.0 "Oslash")
+    (#o352 600.0 "OE")
+    (#o353 600.0 "ordmasculine")
+    (#o361 600.0 "ae")
+    (#o365 600.0 "dotlessi")
+    (#o370 600.0 "lslash")
+    (#o371 600.0 "oslash")
+    (#o372 600.0 "oe")
+    (#o373 600.0 "germandbls")
+    ))
+
+
+(setup-laserwriter-metrics
+  '(("Symbol" 1000 (-180 -293 1090 1010))
+    (#o040 250.0 "space")
+    (#o041 333.0 "exclam")
+    (#o042 713.0 "universal")
+    (#o043 500.0 "numbersign")
+    (#o044 549.0 "existential")
+    (#o045 833.0 "percent")
+    (#o046 778.0 "ampersand")
+    (#o047 439.0 "suchthat")
+    (#o050 333.0 "parenleft")
+    (#o051 333.0 "parenright")
+    (#o052 500.0 "asteriskmath")
+    (#o053 549.0 "plus")
+    (#o054 250.0 "comma")
+    (#o055 549.0 "minus")
+    (#o056 250.0 "period")
+    (#o057 278.0 "slash")
+    (#o060 500.0 "zero")
+    (#o061 500.0 "one")
+    (#o062 500.0 "two")
+    (#o063 500.0 "three")
+    (#o064 500.0 "four")
+    (#o065 500.0 "five")
+    (#o066 500.0 "six")
+    (#o067 500.0 "seven")
+    (#o070 500.0 "eight")
+    (#o071 500.0 "nine")
+    (#o072 278.0 "colon")
+    (#o073 278.0 "semicolon")
+    (#o074 549.0 "less")
+    (#o075 549.0 "equal")
+    (#o076 549.0 "greater")
+    (#o077 444.0 "question")
+    (#o100 549.0 "congruent")
+    (#o101 696.0 "Alpha")
+    (#o102 660.0 "Beta")
+    (#o103 710.0 "Chi")
+    (#o104 612.0 "Delta")
+    (#o105 652.0 "Epsilon")
+    (#o106 763.0 "Phi")
+    (#o107 603.0 "Gamma")
+    (#o110 765.0 "Eta")
+    (#o111 351.0 "Iota")
+    (#o112 631.0 "theta1")
+    (#o113 724.0 "Kappa")
+    (#o114 686.0 "Lambda")
+    (#o115 918.0 "Mu")
+    (#o116 739.0 "Nu")
+    (#o117 750.0 "Omicron")
+    (#o120 768.0 "Pi")
+    (#o121 741.0 "Theta")
+    (#o122 580.0 "Rho")
+    (#o123 592.0 "Sigma")
+    (#o124 632.0 "Tau")
+    (#o125 690.0 "Upsilon")
+    (#o126 439.0 "sigma1")
+    (#o127 768.0 "Omega")
+    (#o130 645.0 "Xi")
+    (#o131 795.0 "Psi")
+    (#o132 650.0 "Zeta")
+    (#o133 333.0 "bracketleft")
+    (#o134 863.0 "therefore")
+    (#o135 333.0 "bracketright")
+    (#o136 658.0 "perpendicular")
+    (#o137 500.0 "underscore")
+    (#o140 500.0 "radicalex")
+    (#o141 631.0 "alpha")
+    (#o142 549.0 "beta")
+    (#o143 549.0 "chi")
+    (#o144 494.0 "delta")
+    (#o145 439.0 "epsilon")
+    (#o146 521.0 "phi")
+    (#o147 411.0 "gamma")
+    (#o150 603.0 "eta")
+    (#o151 329.0 "iota")
+    (#o152 603.0 "phi1")
+    (#o153 549.0 "kappa")
+    (#o154 549.0 "lambda")
+    (#o155 576.0 "mu")
+    (#o156 521.0 "nu")
+    (#o157 549.0 "omicron")
+    (#o160 549.0 "pi")
+    (#o161 521.0 "theta")
+    (#o162 549.0 "rho")
+    (#o163 603.0 "sigma")
+    (#o164 439.0 "tau")
+    (#o165 576.0 "upsilon")
+    (#o166 713.0 "omega1")
+    (#o167 686.0 "omega")
+    (#o170 493.0 "xi")
+    (#o171 686.0 "psi")
+    (#o172 494.0 "zeta")
+    (#o173 480.0 "braceleft")
+    (#o174 200.0 "bar")
+    (#o175 480.0 "braceright")
+    (#o176 549.0 "similar")
+    (#o241 620.0 "Upsilon1")
+    (#o242 247.0 "minute")
+    (#o243 549.0 "lessequal")
+    (#o244 167.0 "fraction")
+    (#o245 713.0 "infinity")
+    (#o246 500.0 "florin")
+    (#o247 753.0 "club")
+    (#o250 753.0 "diamond")
+    (#o251 753.0 "heart")
+    (#o252 753.0 "spade")
+    (#o253 1042.0 "arrowboth")
+    (#o254 987.0 "arrowleft")
+    (#o255 603.0 "arrowup")
+    (#o256 987.0 "arrowright")
+    (#o257 603.0 "arrowdown")
+    (#o260 400.0 "degree")
+    (#o261 549.0 "plusminus")
+    (#o262 411.0 "second")
+    (#o263 549.0 "greaterequal")
+    (#o264 549.0 "multiply")
+    (#o265 713.0 "proportional")
+    (#o266 494.0 "partialdiff")
+    (#o267 460.0 "bullet")
+    (#o270 549.0 "divide")
+    (#o271 549.0 "notequal")
+    (#o272 549.0 "equivalence")
+    (#o273 549.0 "approxequal")
+    (#o274 1000.0 "ellipsis")
+    (#o275 603.0 "arrowvertex")
+    (#o276 1000.0 "arrowhorizex")
+    (#o277 658.0 "carriagereturn")
+    (#o300 823.0 "aleph")
+    (#o301 686.0 "Ifraktur")
+    (#o302 795.0 "Rfraktur")
+    (#o303 987.0 "weierstrass")
+    (#o304 768.0 "circlemultiply")
+    (#o305 768.0 "circleplus")
+    (#o306 823.0 "emptyset")
+    (#o307 768.0 "intersection")
+    (#o310 768.0 "union")
+    (#o311 713.0 "propersuperset")
+    (#o312 713.0 "reflexsuperset")
+    (#o313 713.0 "notsubset")
+    (#o314 713.0 "propersubset")
+    (#o315 713.0 "reflexsubset")
+    (#o316 713.0 "element")
+    (#o317 713.0 "notelement")
+    (#o320 768.0 "angle")
+    (#o321 713.0 "gradient")
+    (#o322 790.0 "registerserif")
+    (#o323 790.0 "copyrightserif")
+    (#o324 890.0 "trademarkserif")
+    (#o325 823.0 "product")
+    (#o326 549.0 "radical")
+    (#o327 250.0 "dotmath")
+    (#o330 713.0 "logicalnot")
+    (#o331 603.0 "logicaland")
+    (#o332 603.0 "logicalor")
+    (#o333 1042.0 "arrowdblboth")
+    (#o334 987.0 "arrowdblleft")
+    (#o335 603.0 "arrowdblup")
+    (#o336 987.0 "arrowdblright")
+    (#o337 603.0 "arrowdbldown")
+    (#o340 494.0 "lozenge")
+    (#o341 329.0 "angleleft")
+    (#o342 790.0 "registersans")
+    (#o343 790.0 "copyrightsans")
+    (#o344 786.0 "trademarksans")
+    (#o345 713.0 "summation")
+    (#o346 384.0 "parenlefttp")
+    (#o347 384.0 "parenleftex")
+    (#o350 384.0 "parenleftbt")
+    (#o351 384.0 "bracketlefttp")
+    (#o352 384.0 "bracketleftex")
+    (#o353 384.0 "bracketleftbt")
+    (#o354 494.0 "bracelefttp")
+    (#o355 494.0 "braceleftmid")
+    (#o356 494.0 "braceleftbt")
+    (#o357 494.0 "braceex")
+    (#o360 790.0 "apple")
+    (#o361 329.0 "angleright")
+    (#o362 274.0 "integral")
+    (#o363 686.0 "integraltp")
+    (#o364 686.0 "integralex")
+    (#o365 686.0 "integralbt")
+    (#o366 384.0 "parenrighttp")
+    (#o367 384.0 "parenrightex")
+    (#o370 384.0 "parenrightbt")
+    (#o371 384.0 "bracketrighttp")
+    (#o372 384.0 "bracketrightex")
+    (#o373 384.0 "bracketrightbt")
+    (#o374 494.0 "bracerighttp")
+    (#o375 494.0 "bracerightmid")
+    (#o376 494.0 "bracerightbt")
+    ))
+
+
+;;; If you suspect the numbers above, you can run this postscript program
+;;; (probably by copying it to a file and printing that file) and compare
+;;; the numbers that get printed with those of the corresponding fonts and
+;;; characters above.  Remember that the numbers above are scaled to be
+;;; 1000 times as big (second element of the car of the first argument of
+;;; SETUP-LASERWRITER-METRICS is the scale factor) as the widths this
+;;; program will print.
+
+#||
+%!
+% Postscript program to print out the widths of a representative set of 
+% characters in each of several fonts.
+
+% By Mark Nahabedian, 1/8/90, Symbolics Inc.
+
+% Sample set of characters toprint out widths for:
+/TheseChars (1AaMN.ilI!) def
+
+% Sample sets of fonts to print out widths of characters for:
+/TheseFonts [ /Helvetica-BoldOblique /Times-Roman ] def
+/CourierFonts [ /Courier /Courier-Bold /Courier-Oblique /Courier-BoldOblique ] def
+
+% Text 'cursor' positioning stuff:
+/StartPage { /y 700 def } def
+/NextLine { /y y 20 sub def } def
+/Space { (  ) show } def
+/Tab0 { 30 y moveto } def
+/Tab1 { 178 y moveto } def
+/Tab2 { 230 y moveto } def
+
+/stringbuf 100 string def
+
+% single character string interval
+/DoChar {
+	Tab1 scaled setfont
+	dup show
+	    Tab2 unscaled setfont
+	    stringwidth pop stringbuf cvs
+	    scaled setfont show NextLine
+} def
+
+% fontname
+/FontSetup {
+	findfont dup /unscaled exch def
+		     /scaled exch 10 scalefont def
+} def
+
+% X Y
+/ShowXandY {
+	stringbuf cvs show Space
+	stringbuf cvs show
+} def
+
+% fontdict
+/ShowFontBBox {
+	([ ) show
+	dup /FontMatrix get dup  3 -1 roll	% stack:  fontdict, FontMatrix, FontMatrix
+	/FontBBox get 	dup 0 get exch
+			dup 1 get exch
+	% stack:  BBox, BBox[1], BBox[0], FontMatrix, FontMatrix
+				4 1 roll  3 -1 roll
+				transform exch ShowXandY Space
+			dup 2 get exch
+			    3 get
+	% stack:  BBox[3], BBox[2], FontMatrix
+				3 -1 roll
+				transform exch ShowXandY Space
+	( ]) show
+} def
+
+% fontname
+/DoFont { 
+	dup FontSetup
+	    scaled setfont Tab0
+	    stringbuf cvs show Tab1
+	unscaled ShowFontBBox NextLine
+	0 1 TheseChars length 1 sub { TheseChars exch 1 getinterval DoChar } for
+} def
+
+% I tried doing this with forall but it didn't work.
+
+StartPage
+0 1 TheseFonts length 1 sub { TheseFonts exch get DoFont } for
+showpage
+
+StartPage
+0 1 CourierFonts length 1 sub { CourierFonts exch get DoFont } for
+showpage
+
+||#
diff --git a/pre-silica/postscript-implementation.lisp b/pre-silica/postscript-implementation.lisp
new file mode 100644
index 00000000..6fdd387b
--- /dev/null
+++ b/pre-silica/postscript-implementation.lisp
@@ -0,0 +1,1211 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: postscript-implementation.lisp,v 1.5 91/03/26 12:48:27 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; This does not conform to the conventions described under Appendix C:
+;;; Structuring Conventions of the PostScript Language Reference Manual.
+;;; Part of the reason for non-conformance is the maybe-send-feature
+;;; hack.  Were it possible for this implementation to send more than
+;;; one page to the printer, then the stuff downloaded using the
+;;; maybe-send-feature hack would be associated with a single page
+;;; rather than with the whole document and reordering of the pages by
+;;; some other tool could cause features which were first generated by
+;;; one page and later referenced by another to become undefined if
+;;; those pages were reordered.  The %% comments do conform except for
+;;; %%Page and the feature reordering problem.
+
+;;; Line thickness currently uses "1 setlinewidth" for minimum line
+;;; thickness.  This can produce a line 2 pixels wide since there can be
+;;; 2 pixels that are less than or equal to 1/2 away from the line.  "0
+;;; setlinewidth" means to use the minimum for the resolution of the
+;;; device.  At least now, for the case of line thickness of 1 :normal, this
+;;; will use 0 setlinewidth for output to the Apple Laser Writer.
+
+(defparameter *ps-magic-baseline-factor* 0.2)	;estimation of % baseline to bottom.
+
+(defparameter *1-pixel=points* 1.2)		;1 "average" pixel is about 1.2 points
+
+(defmacro round-up (x)
+  `(floor (+ ,x 0.5)))
+
+;;--- Convert CLIM units ("pixels") to (printers') points
+(defmacro pixels-to-points (&rest pixels)
+  (let ((forms nil))
+    (dolist (pixel pixels)
+      (push `(setq ,pixel (* ,pixel *1-pixel=points*)) forms))
+    `(progn ,@(nreverse forms))))
+
+;;--- Convert (printers') points to CLIM units ("pixels")
+(defmacro points-to-pixels (&rest points)
+  (let ((forms nil))
+    (dolist (point points)
+      (push `(setq ,point (round-up (/ ,point *1-pixel=points*))) forms))
+    `(progn ,@(nreverse forms))))
+
+(defvar *annotate-postscript* nil)
+
+(defmacro annotating-postscript ((stream printer-stream) &body body)
+  `(when *annotate-postscript*
+     (let* ((,printer-stream (slot-value ,stream 'printer-stream))
+	    (text (with-output-to-string (,printer-stream) ,@body))
+	    (start 0))
+       (loop
+	 (let ((newline (position #\newline text :start start)))
+	   (write-string "% " ,printer-stream)
+	   (write-string text ,printer-stream :start start :end newline)
+	   (unless newline (return))
+	   (setq start (1+ newline))))
+       (fresh-line ,printer-stream))))
+
+
+;;; How the font hackery works:
+
+;;; For each CLIM text style used in the output, a corresponding scaled
+;;; font must exist in the PostScript engine.  (The PostScript books
+;;; recommend that for efficiency you cache the results of operations
+;;; like scalefont).  There is one PS-FONT-COMPAT-KLUDGE structure
+;;; created for each CLIM text style used.  These structures are stored
+;;; in the FONT-MAP slot of POSTSCRIPT-IMPLEMENTATION-MIXIN streams.
+;;; Inside the PostScript engine there is a corresponding array named
+;;; fontarray, whose i'th element contains the scaled postscript font
+;;; object described by the i'th element of FONT-MAP.
+
+;;; The function GET-FONT-COMPAT-STR is used to find the
+;;; PS-FONT-COMPAT-KLUDGE object corresponding to a CLIM text style.
+;;; The first time a CLIM text style is encounterred,
+;;; GET-FONT-COMPAT-STR creates a PS-FONT-COMPAT-KLUDGE object for it,
+;;; stores it in FONT-MAP and generates postscript code to construct the
+;;; corresponding scaled postscript font and store it in fontarray
+;;; using the postscript estfont procedure defined in the preamble.
+
+;;; CONVERT-CLIM-TO-PS-FONT-DESCRIPTION converts a CLIM text style, eg.
+;;; (:serif :bold :large) to a postscript font description, eg. ("Times"
+;;; :bold 12).   When estfont is used, it interns a font "Times-Bold" of
+;;; size 12 as the appropriate element of fontarray.
+
+;;; This structure is used to represent a PostScript font masquerading as a
+;;; CLIM-world entity.  They populate the font-map array of the stream.
+(defstruct (ps-font-compat-kludge (:conc-name psfck-))
+  index						;index into stream's array.
+  style-descriptor				;parse-text-style output.
+  true-ps-descriptor				;("Times" :italic 6 [pts])
+  points					;point-size
+  clim-height					;equivalent size in CLIM "pixels"
+  clim-ascent					;top-to-baseline, "pixels"
+  clim-descent					;baseline-to-bottom
+  width-table)					;width array or constant #.
+
+;;; Each element is ((family face) width-or-width-table-array height ascent descent)
+(defvar *char-width-tables* nil)
+
+(defun make-new-fcs (text-style index)
+  (let ((fcs (make-ps-font-compat-kludge
+	       :index index
+	       :style-descriptor text-style
+	       :true-ps-descriptor (convert-clim-to-ps-font-description text-style))))
+    (initialize-fcs fcs)
+    fcs))
+
+(defun initialize-fcs (fcs)
+  (let* ((points (third (psfck-true-ps-descriptor fcs)))
+	 (key `(,(first (psfck-true-ps-descriptor fcs))
+		,(second (psfck-true-ps-descriptor fcs))))
+	 (metrics (assoc key *char-width-tables* :test #'equal)))
+    (unless metrics
+      (error "No font metrics for ~S" key))
+    (setf (psfck-points fcs) points)
+    (let ((width-table (second metrics))
+	  (height (third metrics))
+	  (ascent (fourth metrics))
+	  (descent (fifth metrics)))
+      (setf (psfck-clim-height fcs) (* points height))
+      (setf (psfck-clim-ascent fcs) (* points ascent))
+      (setf (psfck-clim-descent fcs) (* points descent))
+      (setf (psfck-width-table fcs) width-table)))
+  nil)
+
+;;; Each element is composed of:
+;;;      - a CLIM text family keyword,
+;;;      - the name of a font to use for that family,
+;;;      - a list of point sizes corresponding to the text size keywords
+;;;        in the corresponding positions in *psftd-keywords*.
+;;; We should be able to phjase this out since we have a
+;;; STANDARDIZE-STYLE method for postscript devices.
+(defparameter *postscript-font-translate-data*
+	     '((:fix "Courier" (4 6 7 9 11 14 18))
+	       (:sans-serif "Helvetica" (5 7 8 10 12 16 20))
+	       (:serif "Times" (5 7 8 10 12 16 20))))
+
+(defparameter *psftd-keywords* '(:tiny :very-small :small :normal :large :very-large :huge))
+
+;; The second element is a character size, which is either a number or a
+;; place to go looking to get the character width table
+(defparameter *ps-font-family-data*
+	      '(("Times" 
+		 (nil "tir" "Times-Roman")
+		 (:bold "tib" "Times-Bold")
+		 (:italic "tii" "Times-Italic")
+		 (:bold-italic "tibi" "Times-BoldItalic"))
+		("Helvetica"
+		 (nil "he" "Helvetica")
+		 (:bold "heb" "Helvetica-Bold")
+		 (:italic "heo" "Helvetica-Oblique")
+		 (:bold-italic "hebo" "Helvetica-BoldOblique"))
+		("Courier"
+		 (nil 0.6 "Courier")
+		 (:bold 0.6 "Courier-Bold")
+		 (:italic 0.6 "Courier-Oblique")
+		 (:bold-italic 0.6 "Courier-BoldOblique"))))
+
+(defun get-ps-fam-face-name (fcs)
+  (let ((fam (first (psfck-true-ps-descriptor fcs)))
+	(face (second (psfck-true-ps-descriptor fcs))))
+    (let ((famdata (cdr (or (assoc fam *ps-font-family-data* :test #'string-equal)
+			    (error "No info for PostScript font family ~A" fam)))))
+      (third (or (assoc face famdata)
+		 (error "No info for PostScript family ~A face ~A." fam face))))))
+	
+;; Value is a 3 element list acceptable as a returned value from
+;; CONVERT-CLIM-TO-PS-FONT-DESCRIPTION:  a postscript family name as
+;; appears in the CARs of the elements of *PS-FONT-FAMILY-DATA*, a face
+;; keyword as returned by the function KEYWORDIFY-STYLE-FACE, and a
+;; size in points.
+(defparameter *ps-font-description-for-undefined-style* '("Courier" nil 4))	      
+
+(defun convert-clim-to-ps-font-description (style)
+  (let ((size (text-style-size style))
+	(face (keywordify-style-face (text-style-face style)))
+	(family (text-style-family style)))
+    (if (and *ps-font-description-for-undefined-style*
+	     (eq style *undefined-text-style*))
+	;;--- Probably pointless to issue any sort of warning here
+	*ps-font-description-for-undefined-style*
+	(let* ((famdat (or (assoc family *postscript-font-translate-data*)
+			   (error "Don't have PostScript support for family ~A." family)))
+	       (points (if (numberp size)
+			   size
+			   (point-size-for-size-keyword size famdat)))
+	       (psname (second famdat)))
+	  `(,psname ,face ,points)))))
+
+(defun keywordify-style-face (n)
+  (let ((tem (face-code->face n)))
+    (cond ((eq tem ':roman) nil)
+	  ((atom tem) tem)
+	  ((equal tem '(:bold :italic)) :bold-italic)
+	  ((equal tem '(:italic :bold)) :bold-italic)
+	  (t (list :numeric-code n)))))
+
+(defun point-size-for-size-keyword (size-keyword family-data)
+  (nth (or (position size-keyword *psftd-keywords*)
+	   (error "Don't have PostScript support for size ~A." size-keyword))
+       (third family-data)))
+
+;;; This actually reads metrics for the Apple LaserWriter.  Some day we
+;;; should make the font width table stuff device independent.
+;;; The metrics are in sys:clim;laserwriter-metrics.lisp.newest.
+;;; That file consists of invocations of this function.
+;;; Don't bother loading the width information for fixed width fonts like Courrier
+;;; which already have their width hard-coded in *ps-font-family-data*?
+(defun setup-laserwriter-metrics (font-info)
+  (let ((char-widths (cdr font-info))
+	(name (caar font-info))
+	(scale (cadar font-info))
+	(box (caddar font-info))
+	(width-table nil))
+    (multiple-value-bind (family face size-kludge)
+	(find-family-and-face-for-postscript-font-name name)
+      ;; if the kludgy size element of the font's description in
+      ;; *ps-font-family-data* is a number, just use it instead of
+      ;; building the width table.
+      (cond ((numberp size-kludge)
+	     (setq width-table size-kludge))
+	    (t
+	     (setq width-table (make-array 256))
+	     (dolist (char-info char-widths)
+	       (let ((char-code (first char-info))
+		     (char-width (/ (second char-info) scale)))
+		 (setf (aref width-table char-code) char-width)))))
+      (let ((key `(,family ,face)))
+	(when (car key)				;check family to make sure we found the name
+	  (let* ((temp (assoc key *char-width-tables* :test #'equal))
+		 (height (abs (/ (- (fourth box) (second box)) scale)))
+		 (ascent (abs (/ (fourth box) scale)))
+		 (descent (abs (/ (second box) scale)))
+		 (data `(,width-table ,height ,ascent ,descent)))
+	    (if temp
+		(setf (cdr temp) data)
+		(push `(,key ,@data) *char-width-tables*))))))))
+
+(defun find-family-and-face-for-postscript-font-name (name)
+  (dolist (family-data *ps-font-family-data*)
+    (let ((family (car family-data)))
+      (dolist (face-data (cdr family-data))
+	(let ((face (first face-data))
+	      (size-kludge (second face-data))
+	      (fname (third face-data)))
+	  (when (string= name fname)
+	    (return-from find-family-and-face-for-postscript-font-name
+	      (values family face size-kludge))))))))
+
+
+(defclass postscript-implementation-mixin ()
+     ((printer-stream :initarg :stream)
+      (current-color :initform nil)		;for decoding stippled inks
+      (features-sent :initform nil)
+      (curfont :initform nil)			;a psfck structure
+      (ch1buf :initform (make-array 1 :element-type 'extended-char))	;used for char ops.
+      (font-map :initform (make-array 30 :initial-element nil))
+      (header-comments :initform nil :initarg :header-comments)
+      (orientation :initform :portrait :initarg :orientation)
+      ;; For multi-page output, analogous to a window's scroll position
+      (viewport-x :initform 0)
+      (viewport-y :initform 0)))
+
+(defmethod implementation-pixels-per-point ((stream postscript-implementation-mixin))
+  (/ *1-pixel=points*))
+
+(defmethod stream-force-output ((stream postscript-implementation-mixin))
+  (force-output (slot-value stream 'printer-stream)))
+
+(defmethod stream-clear-output ((stream postscript-implementation-mixin))
+  (clear-output (slot-value stream 'printer-stream)))
+
+(defmethod stream-finish-output ((stream postscript-implementation-mixin))
+  (finish-output (slot-value stream 'printer-stream)))
+
+;;; Methods that might be needed:
+;;; what about other "window" protocols?
+;;; host-window-margins
+;;; window-margins (being flushed, should return (values 0 0 0 0))
+;;; window-beep
+;;; window-clear (do a fresh-page?)
+
+;;; Support routines
+
+(defmacro making-ps-array ((printer-stream) &body body)
+  `(progn (write-string " [ " ,printer-stream)
+	  ,@body
+	  (write-string " ] " ,printer-stream)))
+
+(defmacro making-ps-hex-string ((printer-stream) &body body)
+  `(progn (write-char #\< ,printer-stream)
+	  ,@body
+	  (write-char #\> ,printer-stream)))
+
+(defmacro with-postscript-gsave (stream &body body)
+  `(flet ((with-gsave-body () ,@body))
+     (declare (dynamic-extent #'with-gsave-body))
+     (invoke-with-postscript-gsave ,stream #'with-gsave-body)))
+
+(defmethod invoke-with-postscript-gsave ((stream postscript-implementation-mixin) continuation)
+  (with-slots (printer-stream) stream
+    (format printer-stream " gsave~%")
+    (funcall continuation)
+    (format printer-stream " grestore~%")))
+
+(defmethod maybe-send-feature ((stream postscript-implementation-mixin)
+			       feature-name
+			       code)
+  (with-slots (features-sent printer-stream) stream
+    (unless (member feature-name features-sent)
+      (annotating-postscript (stream printer-stream)
+	(format printer-stream "---------------- Feature ~A ----------------"
+	  feature-name))
+      (write-string code printer-stream)
+      (annotating-postscript (stream printer-stream)
+	(format printer-stream "---------------- End Feature ~A ----------------"
+	  feature-name))
+      (push feature-name features-sent))))
+
+(defmethod ps-pos-op ((stream postscript-implementation-mixin) op x y &rest args)
+  (declare (dynamic-extent args))
+  (pixels-to-points x y)
+  (with-slots (printer-stream display-device-type) stream
+    (write-char #\space printer-stream)
+    (ps-optimal-flonize
+      (+ (* (slot-value display-device-type 'page-indent)
+	    (slot-value display-device-type 'device-units-per-inch)) x)
+      printer-stream)
+    (write-char #\space printer-stream)
+    (ps-optimal-flonize
+      (- (* (slot-value display-device-type 'page-height)
+	    (slot-value display-device-type 'device-units-per-inch)) y)
+      printer-stream)
+    (dolist (arg args)
+      (write-char #\space printer-stream)
+      (if (numberp arg)
+	  (ps-optimal-flonize arg printer-stream)
+	  (write arg :stream printer-stream :escape nil)))
+    (format printer-stream " ~A" op)
+    (if (string-equal op "m")
+	(write-char #\space printer-stream)
+	(terpri printer-stream))))
+
+(defmethod ps-rel-pos-op ((stream postscript-implementation-mixin) op x y &rest args)
+  (declare (dynamic-extent args))
+  (pixels-to-points x y)
+  (with-slots (printer-stream) stream
+    (write-char #\space printer-stream)
+    (ps-optimal-flonize x printer-stream)
+    (write-char #\space printer-stream)
+    (ps-optimal-flonize (- y) printer-stream)
+    (dolist (arg args)
+      (write-char #\space printer-stream)
+      (if (numberp arg)
+	  (ps-optimal-flonize arg printer-stream)
+	  (write arg :stream printer-stream :escape nil)))
+    (format printer-stream " ~A~%" op)))
+
+;;; the software that drives the LGP2 (sys:hardcopy;postscript.lisp)
+;;; uses LGP:FAST-PRINT-NUM except for writing transformation matrices,
+;;; for which it uses 
+;;;       (prin1 (if (fixp elem) elem (float elem)) output-stream)
+;;; and also some cases of Format ~D.
+(defun ps-optimal-flonize (n stream)
+  ;; lifted from definition of LGP:FAST-PRINT-NUM in "Q:>sys>hardcopy>postscript.lisp.1679"
+  (if (and (not (zerop n))
+	   (< -1 n 1))
+      (format stream "~F" (float n))
+      (multiple-value-bind (integer frac)
+	  (etypecase n
+	    (integer (values (abs n) 0))
+	    (float (truncate (round (* (abs n) 100.)) 100))
+	    (rational (truncate (round (* (abs n) 100.)) 100)))
+	(if (>= integer 10000.)
+	    (if (integerp n)
+		(write n :stream stream :escape nil :base 10 :radix nil)
+		(format stream "~$" n))
+	    (let ((from 8)
+		  (negative-p nil))
+	      (when (minusp n)
+		(setq negative-p t))
+	      (with-stack-array (string from :element-type 'extended-char)
+		(macrolet ((add-char (char)
+			     `(setf (aref string (decf from)) ,char)))
+		  (when (/= frac 0)
+		    (multiple-value-bind (frac1 frac2)
+			(truncate frac 10.)
+		      (when (/= frac2 0)
+			(add-char (code-char (+ (char-code #\0) frac2))))
+		      (add-char (code-char (+ (char-code #\0) frac1))))
+		    (add-char #\.))
+		  (let ((digit 0))
+		    (loop
+		      (multiple-value-setq (integer digit)
+			(truncate integer 10.))
+		      (add-char (code-char (+ (char-code #\0) digit)))
+		      (when (zerop integer) (return))))
+		  (when negative-p (add-char #\-))
+		  (write-string string stream :start from)
+		  n)))))))
+
+(defun use-line-style (stream line-style)
+  (let ((thickness (case (line-style-unit line-style)
+		     (:normal (normal-line-thickness (stream-display-device-type stream)
+						     (line-style-thickness line-style)))
+		     (:points (line-style-thickness line-style))))
+	(dashes (line-style-dashes line-style)))
+    (with-slots (printer-stream) stream
+      (format printer-stream " ~D setlinewidth~%" thickness)
+      (when dashes
+	(making-ps-array (printer-stream)
+	  (let ((limit (length dashes)))
+	    (dotimes (i limit)
+	      (write (elt dashes i) :stream printer-stream :escape nil)
+	      (unless (>= (1+ i) limit)
+		(write-char #\space printer-stream)))))
+	(format printer-stream "0 setdash~%")))))
+
+(defun color-equal (c1 c2)
+  (or (eq c1 c2)
+      (and (colorp c1)
+	   (colorp c2)
+	   (multiple-value-bind (r1 g1 b1) (color-rgb c1)
+	     (multiple-value-bind (r2 g2 b2) (color-rgb c2)
+	       (and (= r1 r2) (= g1 g2) (= b1 b2)))))))
+
+(defmethod maybe-set-color
+	   ((stream postscript-implementation-mixin) (ink (eql +foreground-ink+)))
+  (maybe-set-color stream (or (slot-value stream 'current-color) +black+)))
+
+(defmethod maybe-set-color
+	   ((stream postscript-implementation-mixin) (ink (eql +background-ink+)))
+  (maybe-set-color stream +white+))
+
+(defmethod maybe-set-color
+	   ((stream postscript-implementation-mixin) (ink flipping-ink))
+  (error "Postscript devices can't draw with flipping inks."))
+
+(defmethod maybe-set-color ((stream postscript-implementation-mixin) (ink color))
+  (with-slots (current-color printer-stream) stream
+    (when (or (null current-color)
+	      (not (color-equal current-color ink)))
+      (setf current-color ink)
+      (multiple-value-bind (r g b) (color-rgb ink)
+	(format printer-stream  " ~,2F ~,2F ~,2F setrgbcolor~%" r g b)))))
+
+(defmethod maybe-set-color ((stream postscript-implementation-mixin) (ink rectangular-tile))
+  ;; Handled in the patterned fill/stroke case
+  )
+
+(defmethod maybe-set-color
+	   ((stream postscript-implementation-mixin) (ink contrasting-ink))
+  (maybe-set-color stream (make-color-for-contrasting-ink ink)))
+
+;; "Not suitable for ritual use."
+(defparameter *ps-ellipse-code*
+"
+/emtrx matrix def
+/elpd 8 dict def
+/ellipse {{arc} ellipsei} def
+/ellipsen {{arcn} ellipsei} def
+/ellipsei {elpd begin /arcp exch def /ea exch def /sa exch def /yra exch def /xra exch def
+      /y exch def /x exch def
+emtrx currentmatrix
+x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def
+")
+
+(defparameter *pattern-code*
+        ;; for drawing filled patterns
+        "/imgdict 12 dict def
+%draw image.  One source pixel to one user space unit.
+%width width-rounded-up height
+/img { imgdict begin
+        [/height /bitwidth /width ] {exch def} forall
+        /nbits bitwidth height mul def
+        /str 100 string def
+        nbits 0 ne {
+          gsave width height scale
+          bitwidth height true [bitwidth 0 0 height neg 0 height] 
+            {   nbits 800 ge {/nbits nbits 800 sub def str} 
+                               {nbits 8 idiv string /nbits 0 def}
+                            ifelse 
+                  currentfile exch readhexstring pop}
+          imagemask grestore
+        } if end
+        } def
+/fmod { 2 copy div floor mul sub } bind def
+%draw patterned rectangle.  One source pixel to scale device units (ignoring user scale).
+%width height pattern scale
+/pat { imgdict begin gsave
+        [/scal /patseq ] {exch def} forall
+        /patheight patseq length def
+        /patwidth patseq 0 get length 8 mul def
+%back up to an even phase boundary
+        /pswidth patwidth scal mul def
+        /psheight patheight scal mul def
+        pswidth psheight idtransform
+        0 0 transform psheight fmod neg exch pswidth fmod neg exch idtransform
+        3 -1 roll exch dup 0 gt {add} {exch pop} ifelse
+        3 1 roll dup 0 gt {add} {exch pop} ifelse exch 2 copy translate
+        3 -1 roll exch abs add 3 1 roll abs add exch dtransform
+        psheight div abs ceiling cvi patheight mul /height exch def
+        pswidth div abs ceiling cvi patwidth mul /width exch def
+        width 0 ne { height 0 ne {
+        /scanline -1 def /linebits 0 def
+        width height idtransform abs scale scal dup scale
+        width height true [width 0 0 height neg 0 height] 
+        { linebits 0 le { /linebits width def
+                          /scanline scanline 1 add patheight mod def
+                          /linepat patseq scanline get def
+                        } if
+        /linebits linebits patwidth sub def linepat }
+        imagemask } if } if grestore end
+      } def
+%draw pattern in all of visible area.
+%pattern scale opaque-p
+/patfill1 { initmatrix clippath
+%condition-case for nocurrentpoint, returning empty rectangle
+             errordict begin
+               /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def 
+                 pathbbox
+               6 -2 roll def end
+             4 2 roll 2 copy translate 4 -2 roll
+             3 -1 roll sub 3 1 roll exch sub exch
+             3 -1 roll { 2 copy gsave 1 setgray newpath
+                         0 0 moveto 0 exch lineto 0 rlineto currentpoint pop 0 lineto
+                         closepath fill grestore } if
+             4 -2 roll pat } def
+%like fill, etc. but with pattern, scale and opaque-p options.
+/patfill { gsave clip patfill1 grestore newpath } def
+/pateofill { gsave eoclip patfill1 grestore newpath } def
+/patstroke { gsave strokepath clip patfill1 grestore newpath } def
+ ")
+
+(defvar *postscript-prologue*
+        "statusdict /waittimeout 30 put
+/fontarray 30 array def
+/f {fontarray exch get setfont} def
+/estfont {findfont exch scalefont fontarray 3 1 roll put} def
+/m {moveto} def
+")
+
+(defmethod postscript-prologue ((stream postscript-implementation-mixin))
+  (with-slots (printer-stream header-comments display-device-type orientation) stream
+    (format printer-stream "%! nonconforming~%")
+    (format printer-stream "%%Creator: CLIM 1.0~%")
+    (let ((title (getf header-comments :title)))
+      (when title
+        (format printer-stream "%%Title: ~A~%" title)))
+    (let ((for (or (getf header-comments :for) #+Genera zl:user-id)))
+      (when for
+        (format printer-stream "%%For: ~A~%" for)))
+    #+Genera (format printer-stream "%%CreationDate: ~\\date\\~%" (get-universal-time))
+    (format printer-stream "%%DocumentFonts: (atend)~%")
+    (format printer-stream "%%EndComments~%")
+    (write-string *postscript-prologue* printer-stream)
+    (ecase orientation
+      (:portrait
+        (format printer-stream
+            "/format-rotation 0 def ~%/format-y-translation 0 def~%"))
+      (:landscape
+        (format printer-stream
+            "/format-rotation -90 def ~%/format-y-translation ~D def~%" 
+          (* (slot-value display-device-type 'page-width)
+             (slot-value display-device-type 'device-units-per-inch)))))
+    (format printer-stream
+        "/new-matrix {0 format-y-translation translate
+		      format-rotation rotate} def
+	 /new-page {showpage new-matrix} def")
+    (format printer-stream "%%EndProlog~%")
+    (format printer-stream "~%new-matrix~%")))
+
+(defmethod postscript-epilogue ((stream postscript-implementation-mixin))
+  (with-slots (printer-stream font-map) stream
+    (format printer-stream "showpage~%")
+    (format printer-stream "%%Trailer~%")
+    (let ((font-names-used nil))
+      (dotimes (index (length font-map))
+        (let ((fcs (aref font-map index)))
+          (when fcs
+            (pushnew (get-ps-fam-face-name fcs) font-names-used :test #'string-equal))))
+      (format printer-stream "%%DocumentFonts:~{~^ ~A~}~%" (nreverse font-names-used)))))
+
+(defun send-pattern (stream printer-stream pattern)
+  (maybe-send-feature stream 'pattern-program *pattern-code*)
+  (making-ps-array (printer-stream)
+    (let ((height (array-dimension pattern 0))
+	  (width (array-dimension pattern 1)))
+      (dotimes (j height)
+	(making-ps-hex-string (printer-stream)
+	  (send-raster printer-stream pattern 0 j width (1+ j) nil)))))
+  (terpri printer-stream)
+  (write-string " 4 true " printer-stream))
+
+(defun send-raster (printer-stream raster left top right bottom &optional (terpri t))
+  (assert (= bottom (1+ top)))
+  (unless (zerop (rem right 8))
+    (error "Sorry, can't hack right /= 0 (mod 8); you have ~D" right))
+  (with-stack-array (arr (array-total-size raster) :element-type '(unsigned-byte 8)
+						   :displaced-to raster)
+    (with-temporary-string (buf :length 100)
+      (let ((bytes-per-row (truncate (array-dimension raster 1) 8))
+	    (bytes-per-raster (ceiling (- right left) 8)))
+	(let ((toprow (* top bytes-per-row))
+	      (botrow (* bottom bytes-per-row))
+	      (bigend-digit-char "084c2a6e195d3b7f")
+	      (j 0)
+	      #+Genera (buf buf)
+	      #+Genera (arr arr))
+	  #+Genera (declare (sys:array-register bigend-digit-char buf arr))
+	  (flet ((force-buf ()
+		   (setf (fill-pointer buf) j)
+		   (with-temporary-substring (subbuf buf 0 j)
+		     (write-string subbuf printer-stream)
+		     (when terpri
+		       (terpri printer-stream)))))
+	    (do* ((index (- botrow bytes-per-row) (- index bytes-per-row))
+		  (i index index))
+		 ((< index toprow))
+	      (dotimes (n bytes-per-raster)
+		#-(or Allegro Minima) (declare (ignore n))
+		(let ((byte (aref arr i)))
+		  (setf (aref buf j) 
+			(aref bigend-digit-char (ldb (byte 4 0) byte)))
+		  (setf (aref buf (1+ j))
+			(aref bigend-digit-char (ldb (byte 4 4) byte)))
+		  (incf i)
+		  (incf j 2)
+		  (when (> j 80) (force-buf)))))
+	    (when (> j 0) (force-buf))))))))
+
+(defun ps-fill (stream printer-stream ink)
+  (cond ((typep ink 'rectangular-tile)
+	 ;;--- Kludgy way to determine whether to use patterned drawing
+	 (multiple-value-bind (array width height)
+	     (decode-tile-as-stipple ink)
+	   (declare (ignore width height))
+	   (unless array
+	     (error "Rectangular tiles other than stipples are not supported yet."))
+	   (send-pattern stream printer-stream array)
+	   (format printer-stream " patfill~%")))
+	(t
+	 (format printer-stream " fill~%"))))
+
+(defun ps-stroke (stream printer-stream ink)
+  (cond ((typep ink 'rectangular-tile)
+	 ;;--- Kludgy way to determine whether to use patterned drawing
+	 (multiple-value-bind (array width height)
+	     (decode-tile-as-stipple ink)
+	   (declare (ignore width height))
+	   (unless array
+	     (error "Rectangular tiles other than stipples are not supported yet."))
+	   (send-pattern stream printer-stream array)
+	   (format printer-stream " patstroke~%")))
+	(t
+	 (format printer-stream " stroke~%"))))
+	
+(defmacro with-postscript-drawing-options ((stream printer-stream-var
+					    &key ink line-style epilogue (newpath T))
+					   &body body)
+  (let ((printer-stream (or printer-stream-var (make-symbol "printer-stream"))))
+    `(let ((,printer-stream (slot-value ,stream 'printer-stream)))
+       (when ,line-style
+	 (use-line-style ,stream ,line-style))
+       (maybe-set-color ,stream ,ink)
+       ,@(when newpath `((format ,printer-stream " newpath~%")))
+       ,@body
+       ,@(case epilogue
+	   (:default `((if (null ,line-style)
+			   (ps-fill ,stream ,printer-stream ,ink)
+			   (ps-stroke ,stream ,printer-stream ,ink))))
+	   (:fill `((ps-fill ,stream ,printer-stream ,ink)))
+	   (:stroke `((ps-stroke ,stream ,printer-stream ,ink)))))))
+
+(defmethod draw-point-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				x y ink line-style)
+  (translate-positions x-offset y-offset x y)
+  (with-postscript-drawing-options (stream printer-stream
+				    :epilogue :stroke
+				    :ink ink :line-style line-style)
+    (ps-pos-op stream "m" x y)
+    (ps-rel-pos-op stream "rlineto" 0 0))
+  (annotating-postscript (stream printer-stream)
+    (format printer-stream "        (draw-point-internal ~D ~D ~D ~D ...)"
+      x-offset y-offset x y)))
+
+(defmethod draw-line-internal ((stream postscript-implementation-mixin) x-offset y-offset
+			       start-x start-y end-x end-y ink line-style)
+  (translate-positions x-offset y-offset start-x start-y end-x end-y)
+  (with-postscript-drawing-options (stream printer-stream
+				    :epilogue :stroke
+				    :ink ink :line-style line-style)
+    (ps-pos-op stream "m" start-x start-y)
+    (ps-pos-op stream "lineto" end-x end-y))
+  (annotating-postscript (stream printer-stream)
+    (format printer-stream "        (draw-line-internal ~D ~D ~D ~D ~D ~D ...)"
+      x-offset y-offset start-x start-y end-x end-y)))
+
+(defmethod draw-rectangle-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				    left top right bottom ink line-style)
+  (translate-positions x-offset y-offset left top right bottom)
+  (with-postscript-drawing-options (stream printer-stream
+				    :epilogue :default
+				    :ink ink :line-style line-style)
+    (ps-pos-op stream "m" left top)
+    (ps-pos-op stream "lineto" right top)
+    (ps-pos-op stream "lineto" right bottom)
+    (ps-pos-op stream "lineto" left bottom)
+    (format printer-stream " closepath "))	;no cr
+  (annotating-postscript (stream printer-stream)
+    (format printer-stream "        (draw-rectangle-internal ~D ~D ~D ~D ~D ~D ...)"
+      x-offset y-offset left top right bottom)))
+
+(defmethod draw-polygon-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				  list-of-x-and-ys closed ink line-style)
+  (let ((points (translate-point-sequence x-offset y-offset list-of-x-and-ys)))
+    (with-postscript-drawing-options (stream printer-stream
+				      :epilogue :default
+				      :ink ink :line-style line-style)
+      (let ((start-x (first points))
+	    (start-y (second points)))
+	(ps-pos-op stream "m" start-x start-y)
+	(do* ((points (cddr points) (cddr points))
+	      (ex (first points) (first points))
+	      (ey (second points) (second points)))
+	     ((null points)
+	      (when closed
+		(format printer-stream " closepath ")))
+	  (ps-pos-op stream "lineto" ex ey)))
+      (annotating-postscript (stream printer-stream)
+	(format printer-stream "        (draw-polygon-internal ~D ~D ~A ...)"
+	  x-offset y-offset list-of-x-and-ys)))))
+
+(defmethod draw-ellipse-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				  center-x center-y
+				  radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+				  start-angle end-angle ink line-style)
+  (maybe-send-feature stream 'ellipse *ps-ellipse-code*)
+  (translate-positions x-offset y-offset center-x center-y)
+  (when (null start-angle)
+    (setq start-angle 0
+	  end-angle 2pi))
+  (when (< end-angle start-angle)
+    (setq end-angle (+ end-angle 2pi)))
+  (multiple-value-bind (x-radius y-radius)
+      (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+	     (values (abs radius-2-dx) (abs radius-1-dy)))
+	    ((and (= radius-2-dx 0) (= radius-1-dy 0))
+	     (values (abs radius-1-dx) (abs radius-2-dy)))
+	    (t (nyi)))
+    (pixels-to-points x-radius y-radius)
+    (flet ((skew-angle (a)
+	     (atan (* (sin a) x-radius)
+		   (* (cos a) y-radius))))
+      (with-postscript-drawing-options (stream printer-stream
+					:epilogue :default
+					:ink ink :line-style line-style)
+	(ps-pos-op stream "ellipse" center-x center-y
+		   x-radius y-radius
+		   ;; don't allow the common full-circle case to be
+		   ;; screwed up by floating point error:
+		   (if (zerop start-angle)
+		       0
+		       (radians->degrees (skew-angle start-angle)))
+		   (if (= end-angle 2pi)
+		       360
+		       (radians->degrees (skew-angle end-angle)))))
+      (annotating-postscript (stream printer-stream)
+	(format printer-stream
+	    "        (draw-ellipse-internal ~D ~D ~D ~D ~D ~D ~D ~D ~D ~D ...)"
+	  x-offset y-offset
+	  center-x center-y
+	  radius-1-dx radius-1-dy
+	  radius-2-dx radius-2-dy
+	  start-angle end-angle)))))
+
+;; These 2 clones of draw-string would be much more modular if there
+;; were a reasonable way of passing arguments transparently, so that
+;; we might be able to share code.
+(defmethod draw-string-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				 string x y start end align-x align-y text-style ink)
+  (unless end
+    (setq end (length string)))
+  (translate-positions x-offset y-offset x y)
+  (let* ((fcs (get-font-compat-str stream text-style))
+	 (height (round-up (psfck-clim-height fcs)))
+	 (descent (round-up (psfck-clim-descent fcs)))
+	 (ascent (- height descent)))
+    (incf x (compute-text-x-adjustment
+	      align-x stream string text-style start end))
+    (incf y (compute-text-y-adjustment
+	      align-y descent ascent height))
+    ;; do raster/ink stuff.
+    (set-font-if-needed stream fcs)
+    (with-postscript-drawing-options (stream printer-stream
+				      :epilogue nil :newpath nil
+				      :ink ink)
+      (ps-pos-op stream "m" x y)
+      (carefully-output-ps-showstring printer-stream string start end))
+    (annotating-postscript (stream printer-stream)
+      (format printer-stream "      (draw-string-internal ~D ~D ~S ~D ~D ~D ~D ~S ~S ...)"
+	x-offset y-offset string x y start end align-x align-y))))
+
+(defmethod draw-character-internal ((stream postscript-implementation-mixin) x-offset y-offset
+				    character x y align-x align-y text-style ink)
+  (translate-positions x-offset y-offset x y)
+  (with-slots (printer-stream ch1buf) stream
+    (setf (aref ch1buf 0) character)
+    (let* ((fcs (get-font-compat-str stream text-style))
+	   (height (round-up (psfck-clim-height fcs)))
+	   (descent (round-up (psfck-clim-descent fcs)))
+	   (ascent (- height descent)))
+      (incf x (compute-text-x-adjustment
+		align-x stream character text-style))
+      (incf y (compute-text-y-adjustment
+		align-y descent ascent height))
+      ;; do raster/ink stuff.
+      (set-font-if-needed stream fcs)
+      (with-postscript-drawing-options (stream printer-stream
+					:epilogue nil :newpath nil
+					:ink ink)
+	(ps-pos-op stream "m" x y)
+	(carefully-output-ps-showstring printer-stream ch1buf 0 1))
+      (annotating-postscript (stream printer-stream)
+	(format printer-stream "      (draw-character-internal ~D ~D ~C ~D ~D ~S ~S ...)"
+	  x-offset y-offset character x y align-x align-y)))))
+
+(defmethod draw-vertical-string-internal ((stream postscript-implementation-mixin)
+					  x-offset y-offset
+					  string x y start end
+					  align-x align-y text-style ink)
+  (unless end
+    (setq end (length string)))
+  (unless text-style
+    (setq text-style (stream-merged-text-style stream)))
+  (translate-positions x-offset y-offset x y)
+  (let* ((fcs (get-font-compat-str stream text-style))
+	 (height (round-up (psfck-clim-height fcs)))
+	 (descent (round-up (psfck-clim-descent fcs)))
+	 (ascent (- height descent)))
+    (let ((x-adjust (compute-text-x-adjustment
+		      align-x stream string text-style start end))
+	  (y-adjust (compute-text-y-adjustment
+		      align-y descent ascent height)))
+      (set-font-if-needed stream fcs)
+      (with-postscript-drawing-options (stream printer-stream
+					:epilogue nil :newpath nil
+					:ink ink)
+	(with-postscript-gsave stream 
+	  (ps-pos-op stream "m" x y)
+	  (format printer-stream " currentpoint translate 90 rotate ")
+	  (ps-rel-pos-op stream "rmoveto" x-adjust y-adjust)
+	  (carefully-output-ps-showstring printer-stream string start end))))))
+
+;;; provide a way for the "user" to start a new page.
+;;; Should this have a different name?
+;;; Should this functionality be invoked by wriuting the #\page character?
+(defmethod new-page ((stream postscript-implementation-mixin))
+  (with-slots (printer-stream orientation) stream
+    (format printer-stream "new-page~%"))
+  ;; simulate WINDOW-CLEAR:
+  (clear-output-history stream)
+  (when (extended-output-stream-p stream)	;can we assume this?
+    (stream-set-cursor-position* stream 0 0)
+    (setf (stream-baseline stream) 0
+	  (stream-current-line-height stream) 0)))
+
+(defmacro with-ps-stream-glyph-for-character (&body body)
+  `(macrolet ((stream-glyph-for-character (stream character style &optional our-font)
+		`(with-slots (display-device-type) ,stream
+		   (multiple-value-bind (character-set index)
+		       (char-character-set-and-index ,character)
+		     (declare (ignore character-set))
+		     ;; For now we are asserting that each string passed to WRITE-STRING will
+		     ;; have no style changes within it.  This is what our-font is all
+		     ;; about.
+		     (let* ((fcs (or our-font (get-font-compat-str stream ,style)))
+			    (CWT (psfck-width-table fcs))
+			    (relwidth (if (numberp CWT) 
+					  CWT
+					  (aref CWT index)))
+			    (escapement-x (round-up (* (psfck-clim-height fcs) relwidth)))
+			    (escapement-y 0)
+			    (origin-x 0)
+			    (origin-y (round-up (psfck-clim-ascent fcs)))
+			    ;; really ought know real dope, but not avl yet
+			    (bb-x escapement-x)
+			    (bb-y (round-up (psfck-clim-height fcs))))
+		       (values index fcs escapement-x escapement-y origin-x origin-y
+			       bb-x bb-y (numberp cwt)))))))
+     ,@body))
+
+(defmethod stream-glyph-for-character ((stream postscript-implementation-mixin)
+				       character style &optional our-font)
+  (declare (values index font escapement-x escapement-y origin-x origin-y bb-x bb-y
+		   fixed-width-font-p))
+  (with-ps-stream-glyph-for-character
+    (stream-glyph-for-character stream character style our-font)))
+
+(defmethod stream-scan-string-for-writing ((stream postscript-implementation-mixin) string
+					   start end style cursor-x max-x
+					   &optional glyph-buffer)
+  (declare (type coordinate cursor-x max-x))
+  (declare (fixnum start end))
+  (with-ps-stream-glyph-for-character 
+    (stream-scan-string-for-writing-body)))
+
+(defmethod stream-write-string-1 ((stream postscript-implementation-mixin)
+				  glyph-buffer start end font color x y)
+  (when (<= end start) (return-from stream-write-string-1))
+  (let* ((index start)
+	 (index8 0)
+	 (fcs font)
+	 (ascent (round-up (psfck-clim-ascent fcs)))
+	 #+Genera (glyph-buffer glyph-buffer))
+    #+Genera (declare (sys:array-register glyph-buffer))
+    (with-slots (printer-stream) stream
+      (with-temporary-string (glyphs8 :length (- end start))
+	#+Genera (declare (sys:array-register glyphs8))
+	(setf (fill-pointer glyphs8) (- end start))
+	(loop
+	  (when (= index end) (return))
+	  (setf (aref glyphs8 index8) (code-char (aref glyph-buffer index)))
+	  (incf index)
+	  (incf index8))
+	(set-font-if-needed stream fcs)
+	(maybe-set-color stream color)
+	(ps-pos-op stream "m" x (+ y ascent))
+	(carefully-output-ps-showstring printer-stream glyphs8 0 (- end start))))))
+
+;;--- It's really marginal that characters don't get buffered into a
+;;--- string to be sent all at once.  
+(defmethod stream-write-char-1 ((stream postscript-implementation-mixin) index font color x y)
+  (let* ((c (code-char index))
+	 (fcs font)
+	 (ascent (round-up (psfck-clim-ascent fcs))))
+    (with-slots (printer-stream ch1buf) stream
+      (setf (aref ch1buf 0) c)
+      (set-font-if-needed stream fcs)
+      (maybe-set-color stream color)
+      (ps-pos-op stream "m" x (+ y ascent))
+      (carefully-output-ps-showstring printer-stream ch1buf 0 1))))
+
+(defmethod set-font-if-needed ((stream postscript-implementation-mixin) fcs)
+  (with-slots (printer-stream curfont) stream
+    (unless (eq curfont fcs)
+      (format printer-stream "~D f " (psfck-index fcs))
+      (setf curfont fcs))))
+
+(defun carefully-output-ps-showstring (printer-stream data start end)
+  (assert (<= end (length data)))
+  (write-char #\( printer-stream)
+  (loop
+    (let ((next-special (position-if #'(lambda (char)
+					 (or (eql char #\( )
+					     (eql char #\) )
+					     (eql char #\\ )))
+				     data :start start :end end)))
+      (write-string data printer-stream :start start :end (or next-special end))
+      (when next-special
+	(write-char #\\ printer-stream)
+	(write-char (elt data next-special) printer-stream))
+      (unless next-special (return))
+      (setq start (1+ next-special))))
+  (format printer-stream ") show~%"))
+
+(defmethod get-font-compat-str ((stream postscript-implementation-mixin) text-style)
+  (with-slots (font-map printer-stream) stream 
+    (let ((styledesc (parse-text-style text-style))
+	  (al (length font-map)))
+      (do ((i 0 (1+ i)))
+	  ((>= i al)
+	   (error "Font map overflow for ~S" stream))
+	(let ((fcs (aref font-map i)))
+	  (when (null fcs)
+	    (setq fcs (make-new-fcs styledesc i))
+	    (setf (aref font-map i) fcs)
+	    (format printer-stream "~D ~D /~A estfont~%" 
+	      (psfck-index fcs) (psfck-points fcs) (get-ps-fam-face-name fcs))
+	    (return fcs))
+	  (when (eq styledesc (psfck-style-descriptor fcs))
+	    (return fcs)))))))
+
+
+;; PostScript's "default user space" is measured in printers' points.
+;; Should these force the stream to map the font and then get the
+;; information from the FCS?
+
+(defmethod text-style-width (text-style (medium postscript-implementation-mixin))
+  ;; an 'M' is often square and of height approximating the point size of the font.
+  ;; should probably consult real metrics.
+  (text-style-size-in-points text-style medium))
+
+(defmethod text-style-height ((text-style standard-text-style)
+			      (medium postscript-implementation-mixin))
+  (text-style-size-in-points text-style medium))
+
+(defmethod text-style-ascent ((text-style standard-text-style)
+			      (medium postscript-implementation-mixin))
+  (* (text-style-height text-style medium) (- 1 *ps-magic-baseline-factor*)))
+
+(defmethod text-style-descent ((text-style standard-text-style)
+			       (medium postscript-implementation-mixin))
+  (* (text-style-height text-style medium) *ps-magic-baseline-factor*))
+
+;;;--- This can probably go away when we have standardized text styles.
+(defmethod text-style-size-in-points ((text-style standard-text-style)
+				      (medium postscript-implementation-mixin))
+  (let* ((family (text-style-family text-style))
+	 (size (text-style-size text-style))
+	 (famdat (or (assoc family *postscript-font-translate-data*)
+		     (error "Don't have PostScript support for family ~A." family)))
+	 (points (if (numberp size)
+		     size
+		     (point-size-for-size-keyword size famdat))))
+    points))
+
+(defmethod text-style-fixed-width-p ((text-style standard-text-style)
+				     (stream postscript-implementation-mixin))
+  (let* ((family (text-style-family text-style))
+	 (face (text-style-face text-style))
+	 (psfam (or (second (assoc family *postscript-font-translate-data*))
+		    (error "Don't have PostScript support for family ~A." family)))
+	 (famdat (cdr (or (assoc psfam *ps-font-family-data* :test #'string-equal)
+			  (error "No info for PostScript font family ~A?" psfam))))
+	 (info (cdr (or (assoc face famdat)
+			(error "No info for PostScript family ~A face ~A." psfam face))))
+ 	 (cname (first info)))
+    (numberp cname)))
+
+(defmethod text-size ((stream postscript-implementation-mixin) string
+		      &key (text-style (stream-merged-text-style stream)) (start 0) end)
+  (when (characterp string)
+    (setq string (string string)
+	  start 0
+	  end nil))
+  (multiple-value-bind (last-x largest-x last-y total-height baseline)
+      (stream-string-output-size stream string :text-style text-style :start start :end end)
+    (values largest-x total-height last-x last-y baseline)))
+
+
+(defclass postscript-device (display-device)
+    ;; 72 points per inch on PostScript devices
+    ((device-units-per-inch :initform 72 :allocation :class)))
+
+(defmethod standardize-text-style ((device postscript-device) character-set style)
+  (declare (ignore character-set))
+  (let ((size (text-style-size style)))
+    (if (numberp size)
+	style
+      (let* ((family (text-style-family style))
+	     (sizes (third (assoc family *postscript-font-translate-data*)))
+	     (position (position size *psftd-keywords*))
+	     (new-size (and position (nth position sizes))))
+	(cond (new-size
+	       (make-text-style family (text-style-face style) new-size))
+	      ((eql family :stand-in-for-undefined-style)
+	       (make-text-style family (text-style-face style) 10))
+	      (t
+	       (cerror "Use the undefined text style stand-in instead"
+		       "This display device does not know how to map the logical text ~
+                        style size ~S in ~S"
+		       size style)
+	       *undefined-text-style*))))))
+
+(defclass apple-laser-writer (postscript-device)
+    ((x-resolution :initform 300 :allocation :class)	;pixels per inch
+     (y-resolution :initform 300 :allocation :class)
+     (page-indent :initform  0.5 :allocation :class)	;in inches
+     (page-width  :initform  7.5 :allocation :class)
+     (page-height :initform 10.5 :allocation :class)))
+
+;;; allow a display device to do something appropriate for a line thickness in :normal units
+(defgeneric normal-line-thickness (display-device thickness))
+  
+(defmethod normal-line-thickness ((postscript-device display-device) (thickness number))
+  thickness)
+
+(defmethod normal-line-thickness ((postscript-device apple-laser-writer) (thickness number))
+  (if (= thickness 1)
+      0
+      (* 0.5 thickness (/ (slot-value postscript-device 'device-units-per-inch)
+			  (slot-value postscript-device 'x-resolution)))))
+
+(define-display-device *postscript-device* apple-laser-writer
+  :font-for-undefined-style "Courier")
+
+(defclass postscript-stream
+	  (postscript-implementation-mixin
+	   ;; Following classes' protocols are disjoint
+	   graphics-output-recording
+	   ;; A little wierd, but we need it so that the "viewport" stuff gets
+	   ;; handled during REPLAY of multi-page output
+	   #-Silica output-and-window-protocol-intermediary
+	   output-and-recording-protocol-intermediary
+	   output-recording-mixin
+	   graphics-mixin
+	   output-protocol-mixin)
+     ()
+  (:default-initargs :display-device-type *postscript-device*
+		     :default-text-margin 1000))
+
+(defmethod initialize-instance :after ((stream postscript-stream) &key)
+  (postscript-prologue stream))
+
+(defun make-postscript-stream (stream)
+  (make-instance 'postscript-stream :stream stream))
+
+(defmethod close ((stream postscript-stream) &key abort)
+  (declare (ignore abort))
+  (postscript-epilogue stream))
+
+(defmethod window-inside-width ((stream postscript-implementation-mixin))
+  (with-slots (display-device-type) stream
+    (/ (* (slot-value display-device-type 'page-width)
+	  (slot-value display-device-type 'device-units-per-inch))
+       *1-pixel=points*)))
+
+(defmethod drawing-surface-to-viewport-coordinates
+	   ((stream postscript-implementation-mixin) dsx dsy)
+  (declare (type coordinate dsx dsy))
+  (with-slots (viewport-x viewport-y) stream
+    (declare (type coordinate vx vy))
+    (values (- dsx viewport-x) (- dsy viewport-y))))
+
+(defmethod stream-ensure-cursor-visible ((stream postscript-implementation-mixin)
+					 &optional cx cy)
+  (declare (ignore cx cy))
+  nil)
+
+(defmethod stream-move-for-line-height-change ((stream postscript-implementation-mixin)
+					       movement old-height cursor-x cursor-y)
+  (declare (ignore movement old-height cursor-x cursor-y)))
+
+;; Replay some PostScript output, breaking it into multiple pages
+(defmethod stream-replay ((stream postscript-implementation-mixin) &optional region)
+  (with-slots (output-record record-p draw-p display-device-type 
+	       printer-stream orientation viewport-x viewport-y) stream
+    (when draw-p
+      (when output-record
+	(letf-globally ((record-p nil))
+	  (if region 
+	      (replay output-record stream region)
+	    (with-bounding-rectangle* (left top right bottom) output-record
+	      (let* ((page-width
+		       (floor (* (slot-value display-device-type 'page-width)
+				 (slot-value display-device-type 'device-units-per-inch))
+			      *1-pixel=points*))
+		     (page-height
+		       (floor (* (slot-value display-device-type 'page-height)
+				 (slot-value display-device-type 'device-units-per-inch))
+			      *1-pixel=points*))
+		     (first-page t))
+		(setq viewport-x 0 viewport-y 0)
+		;; Draw each chunk of output on its own page
+		(unwind-protect
+		    (do ((y top (+ y page-height)))
+			((> y bottom))
+		      (do ((x left (+ x page-width)))
+			  ((> x right))
+			(if first-page
+			    (setq first-page nil)
+			    (format printer-stream "new-page~%"))
+			(let ((region (make-bounding-rectangle
+					x y (+ x page-width) (+ y page-height))))
+			  (replay output-record stream region))
+			(incf viewport-x page-width))
+		      (setf viewport-x 0)
+		      (incf viewport-y page-height))
+		(setq viewport-x 0 viewport-y 0))))))))))
+		
+
+(defmacro with-output-to-postscript-stream ((stream-var file-stream &rest args) &body body)
+  (declare (arglist (stream-var file-stream
+		     &key (display-device *postscript-device*)
+			  header-comments multi-page 
+			  (orientation :portrait))
+		    &body body))
+  `(flet ((postscript-output-body (,stream-var) ,@body))
+     (declare (dynamic-extent #'postscript-output-body))
+     (invoke-with-output-to-postscript-stream ,file-stream #'postscript-output-body ,@args)))
+
+;; This could really be WITH-OPEN-STREAM, but that isn't going to call CLIM:CLOSE.
+;; Fixed in the CLOS stream system.
+(defun invoke-with-output-to-postscript-stream (file-stream continuation
+						&key (display-device *postscript-device*)
+						     header-comments multi-page
+						     (orientation :portrait))
+  (let ((postscript-stream (make-instance 'postscript-stream
+					  :stream file-stream
+					  :display-device-type display-device
+					  :header-comments header-comments
+					  :orientation orientation))
+	(abort-p t))
+    (with-output-recording-options (postscript-stream :record t :draw (not multi-page))
+      (unwind-protect
+	  (multiple-value-prog1
+	    (funcall continuation postscript-stream)
+	    (when multi-page
+	      ;; In the case of multi-page output, we have not actually output
+	      ;; anything to the printer yet.  Do so now, breaking the output
+	      ;; up into multiple pages.
+	      (with-output-recording-options (postscript-stream :record nil :draw t)
+		(frame-replay *application-frame* postscript-stream)))
+	    (setq abort-p nil))
+	(close postscript-stream :abort abort-p)))))
diff --git a/pre-silica/protocol-intermediaries.lisp b/pre-silica/protocol-intermediaries.lisp
new file mode 100644
index 00000000..94c3603f
--- /dev/null
+++ b/pre-silica/protocol-intermediaries.lisp
@@ -0,0 +1,98 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: protocol-intermediaries.lisp,v 1.4 91/03/26 12:48:44 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1989, 1990 International Lisp Associates.  All rights reserved."
+
+;;; Methods for streams that are both windows and extended input streams
+
+(defmethod stream-note-pointer-button-press :around
+  ((window input-and-window-protocol-intermediary) pointer button modifier-state x y)
+  (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y)
+    (call-next-method window pointer button modifier-state nx ny)))
+
+(defmethod stream-note-pointer-button-release :around
+  ((window input-and-window-protocol-intermediary) pointer button modifier-state x y)
+  (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y)
+    (call-next-method window pointer button modifier-state nx ny)))
+
+(defmethod stream-pointer-position* :around ((window input-and-window-protocol-intermediary)
+					     &rest args)
+  (declare (ignore args))
+  (multiple-value-bind (x y)
+      (call-next-method)
+    (viewport-to-drawing-surface-coordinates window x y)))
+
+(defmethod stream-set-pointer-position* :around
+  ((window input-and-window-protocol-intermediary) x y &key pointer)
+  (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y)
+    (call-next-method window nx ny :pointer pointer)))
+
+(defmethod stream-set-cursor-position* :after ((window input-and-window-protocol-intermediary)
+					       x y)
+  (let ((cursor (stream-text-cursor window)))
+    (when cursor
+      (cursor-set-position* cursor x y))))
+
+(defmethod stream-set-cursor-position*-internal :after
+	   ((window input-and-window-protocol-intermediary) x y)
+  (let ((cursor (stream-text-cursor window)))
+    (when cursor
+      (cursor-set-position* cursor x y))))
+
+
+;;; Methods for streams that are both windows and extended output streams
+
+(defmethod stream-write-string-1 :around ((window output-and-window-protocol-intermediary)
+					  glyph-buffer start end font color x y)
+  (multiple-value-bind (nx ny) (drawing-surface-to-viewport-coordinates window x y)
+    (call-next-method window glyph-buffer start end font color nx ny)))
+
+(defmethod stream-write-char-1 :around ((window output-and-window-protocol-intermediary)
+					index font color x y)
+  (multiple-value-bind (nx ny) (drawing-surface-to-viewport-coordinates window x y)
+    (call-next-method window index font color nx ny)))
+
+(defmethod window-note-size-or-position-change :around
+  ((window output-and-window-protocol-intermediary)
+   new-left new-top new-right new-bottom)
+  ;; we have to use UNWIND-PROTECT because some method may throw...
+  ;; Yecch.  Can't there be a better way?
+  (unwind-protect
+      (call-next-method window new-left new-top new-right new-bottom)
+    (let ((width (window-inside-width window)))
+      (setf (stream-default-text-margin window) width))))
+
+#-Silica
+(defmethod bounding-rectangle-set-edges :after
+	   ((window output-and-window-protocol-intermediary)
+	    new-left new-top new-right new-bottom)
+  (declare (ignore new-left new-top new-right new-bottom))
+  (let ((width (window-inside-width window)))
+    (setf (stream-default-text-margin window) width)))
+
+#-Silica
+(defmethod bounding-rectangle-set-width :after
+	   ((window output-and-window-protocol-intermediary) width height)
+  (declare (ignore width height))
+  (let ((width (window-inside-width window)))
+    (setf (stream-default-text-margin window) width)))
+
+
+;;; Methods for streams that are both output recording and extended input streams
+
+(defmethod invoke-with-output-recording-options :around
+           ((stream output-and-recording-protocol-intermediary) continuation record draw)
+  (let ((restore-p (and record
+			(not draw)
+			(not (stream-recording-p stream)))))
+    (multiple-value-bind (old-x old-y)
+	(when restore-p (stream-cursor-position* stream))
+      (unwind-protect
+	  (progn
+	    (stream-close-text-output-record stream)
+	    (call-next-method stream continuation record draw))
+	(when restore-p (stream-set-cursor-position* stream old-x old-y))))))
+
diff --git a/pre-silica/vertical-string.lisp b/pre-silica/vertical-string.lisp
new file mode 100644
index 00000000..9d6326c6
--- /dev/null
+++ b/pre-silica/vertical-string.lisp
@@ -0,0 +1,45 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: vertical-string.lisp,v 1.4 91/03/26 12:49:04 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1988, 1989, 1990 International Lisp Associates.  All rights reserved."
+
+;;; A utility for placing glyphs along a vertical path.  Does not do any work yet
+;;; to obtain a rotated font; but Bob said that could be a "future".
+(defun draw-vertical-string* (stream string x y
+				     &key (start 0) end
+				     (align-x ':left) (align-y ':top))
+  (when (null end) (setq end (length string)))
+    ;; What kind of font metrics do we get for the rotated font?  Do we
+    ;; get "normal" metrics and then rotate them 90 degrees (i.e. use
+    ;; the char width for vertical alignment spacing) or use the font's
+    ;; height as the spacing increment?  This currently just uses the
+    ;; height.
+  (let* ((y-span (stream-line-height stream))
+	 (x-span (stream-string-width stream "W"))
+	 (count (- end start))
+	 (total-y-span (* count y-span))
+	 start-x start-y)
+    (ecase align-x
+      (:left (setq start-y y))
+      (:right (setq start-y (+ y total-y-span)))
+      (:center (setq start-y (+ y (round total-y-span 2)))))
+    (ecase align-y
+      (:top (setq start-x x))
+      (:bottom (setq start-x (- x x-span)))
+      (:center (setq start-x (- x (round x-span 2))))
+      ;; --- just using "bottom" for now
+      (:baseline (setq start-x (- x x-span))))
+    ;; draw string from bottom to top, assuming glyphs will be rotated
+    ;; 90 degrees left.
+    (dovector (char string :start start :end end)
+      (draw-character* stream char start-x start-y)
+      (decf start-y y-span))))
+
+(defun draw-vertical-string (stream string point &key (start 0) end
+				    (align-x ':left) (align-y ':top))
+  (draw-vertical-string* stream string (point-x point) (point-y point)
+			 :start start :end end
+			 :align-x align-x :align-y align-y))
diff --git a/pre-silica/wheader.lisp b/pre-silica/wheader.lisp
new file mode 100644
index 00000000..2cdd0a36
--- /dev/null
+++ b/pre-silica/wheader.lisp
@@ -0,0 +1,1634 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: wheader.lisp,v 1.4 91/03/26 12:49:06 cer Exp $
+
+;;; "Translated" from \sys\include\windows.h
+
+(in-package :win)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+#||
+;;; OEMRESOURCE
+(defconstant OBM_CLOSE		32767)
+(defconstant OBM_SIZE		32766)
+(defconstant OBM_UPARROW	32765)
+(defconstant OBM_DNARROW	32764)
+(defconstant OBM_RGARROW	32763)
+(defconstant OBM_LFARROW	32762)
+(defconstant OBM_BTSIZE		32761)
+(defconstant OBM_CHECK		32760)
+(defconstant OBM_CHECKBOXES	32759)
+(defconstant OBM_BTNCORNERS	32758)
+(defconstant OBM_REDUCE		32757)
+(defconstant OBM_ZOOM		32756)
+(defconstant OBM_RESTORE	32755)
+(defconstant OCR_NORMAL		32512)
+(defconstant OCR_IBEAM		32513)
+(defconstant OCR_WAIT		32514)
+(defconstant OCR_CROSS		32515)
+(defconstant OCR_UP		32516)
+(defconstant OCR_SIZE		32640)
+(defconstant OCR_ICON		32641)
+(defconstant OCR_SIZENWSE	32642)
+(defconstant OCR_SIZENESW	32643)
+(defconstant OCR_SIZEWE		32644)
+(defconstant OCR_SIZENS		32645)
+(defconstant OCR_SIZEALL	32646)
+
+(defconstant OIC_SAMPLE	32512)
+(defconstant OIC_HAND	32513)
+(defconstant OIC_QUES	32514)
+(defconstant OIC_BANG	32515)
+(defconstant OIC_NOTE	32516)
+||#
+
+#| Scroll bar constants |#
+(defconstant SB_HORZ	0)
+(defconstant SB_VERT	1)
+(defconstant SB_CTL	2)
+(defconstant SB_BOTH	3)
+
+#| Scroll Commands |#
+
+(defconstant SB_LINEUP		0)
+(defconstant SB_LINEDOWN	1)
+(defconstant SB_PAGEUP		2)
+(defconstant SB_PAGEDOWN	3)
+(defconstant SB_THUMBPOSITION	4)
+(defconstant SB_THUMBTRACK	5)
+(defconstant SB_TOP		6)
+(defconstant SB_BOTTOM		7)
+(defconstant SB_ENDSCROLL	8)
+
+
+#| ShowWindow commands |#
+
+(defconstant SW_HIDE		0)
+(defconstant SW_SHOWNORMAL	1)
+(defconstant SW_RESTORE		1)
+(defconstant SW_NORMAL		1)
+(defconstant SW_SHOWMINIMIZED	2)
+(defconstant SW_SHOWMAXIMIZED	3)
+(defconstant SW_MAXIMIZE	3)
+(defconstant SW_SHOWNOACTIVATE	4)
+(defconstant SW_SHOW		5)
+(defconstant SW_MINIMIZE	6)
+(defconstant SW_SHOWMINNOACTIVE	7)
+(defconstant SW_SHOWNA		8)
+
+#||
+#| Old showwindow commands |#
+
+(defconstant HIDE_WINDOW		0)
+(defconstant SHOW_OPENWINDOW		1)
+(defconstant SHOW_ICONWINDOW		2)
+(defconstant SHOW_FULLSCREEN		3)
+(defconstant SHOW_OPENNOACTIVATE	4)
+
+#| identifiers for the WM_SHOWWINDOW message |#
+(defconstant SW_PARENTCLOSING	1)
+(defconstant SW_OTHERZOOM	2)
+(defconstant SW_PARENTOPENING	3)
+(defconstant SW_OTHERUNZOOM	4)
+
+#| flags for regions |#
+(defconstant ERROR		0)
+(defconstant NULLREGION		1)
+(defconstant SIMPLEREGION	2)
+(defconstant COMPLEXREGION	3)
+
+#| styles for CombineRgn |#
+(defconstant RGN_AND	1)
+(defconstant RGN_OR	2)
+(defconstant RGN_XOR	3)
+(defconstant RGN_DIFF	4)
+(defconstant RGN_COPY	5)
+
+#| Virtual Keys, Standard Set |#
+
+(defconstant VK_LBUTTON	#x01)
+(defconstant VK_RBUTTON	#x02)
+(defconstant VK_CANCEL	#x03)
+(defconstant VK_MBUTTON	#x04)	#| NOT contiguous with L & RBUTTON |#
+(defconstant VK_BACK	#x08)
+(defconstant VK_TAB	#x09)
+(defconstant VK_CLEAR	#x0C)
+(defconstant VK_RETURN	#x0D)
+(defconstant VK_SHIFT	#x10)
+(defconstant VK_CONTROL	#x11)
+(defconstant VK_MENU	#x12)
+(defconstant VK_PAUSE	#x13)
+(defconstant VK_CAPITAL	#x14)
+(defconstant VK_ESCAPE	#x1B)
+(defconstant VK_SPACE	#x20)
+
+(defconstant VK_PRIOR	#x21)
+(defconstant VK_NEXT	#x22)
+(defconstant VK_END	#x23)
+(defconstant VK_HOME	#x24)
+(defconstant VK_LEFT	#x25)
+(defconstant VK_UP	#x26)
+(defconstant VK_RIGHT	#x27)
+(defconstant VK_DOWN	#x28)
+
+#| VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z' |#
+#| VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '0' |#
+
+(defconstant VK_SELECT	#x29)
+(defconstant VK_PRINT	#x2A)
+(defconstant VK_EXECUTE	#x2B)
+(defconstant VK_COPY	#x2C)
+(defconstant VK_INSERT	#x2D)
+(defconstant VK_DELETE	#x2E)
+(defconstant VK_HELP	#x2F)
+
+(defconstant VK_NUMPAD0	#x60)
+(defconstant VK_NUMPAD1	#x61)
+(defconstant VK_NUMPAD2	#x62)
+(defconstant VK_NUMPAD3	#x63)
+(defconstant VK_NUMPAD4	#x64)
+(defconstant VK_NUMPAD5	#x65)
+(defconstant VK_NUMPAD6	#x66)
+(defconstant VK_NUMPAD7	#x67)
+(defconstant VK_NUMPAD8	#x68)
+(defconstant VK_NUMPAD9	#x69)
+(defconstant VK_MULTIPLY #x6A)
+(defconstant VK_ADD	#x6B)
+(defconstant VK_SEPARATOR #x6C)
+(defconstant VK_SUBTRACT #x6D)
+(defconstant VK_DECIMAL	#x6E)
+(defconstant VK_DIVIDE	#x6F)
+
+(defconstant VK_F1	#x70)
+(defconstant VK_F2	#x71)
+(defconstant VK_F3	#x72)
+(defconstant VK_F4	#x73)
+(defconstant VK_F5	#x74)
+(defconstant VK_F6	#x75)
+(defconstant VK_F7	#x76)
+(defconstant VK_F8	#x77)
+(defconstant VK_F9	#x78)
+(defconstant VK_F10	#x79)
+(defconstant VK_F11	#x7A)
+(defconstant VK_F12	#x7B)
+(defconstant VK_F13	#x7C)
+(defconstant VK_F14	#x7D)
+(defconstant VK_F15	#x7E)
+(defconstant VK_F16	#x7F)
+
+(defconstant VK_NUMLOCK	#x90)
+
+
+#| SetWindowsHook codes |#
+(defconstant WH_MSGFILTER	-1)
+(defconstant WH_JOURNALRECORD	0)
+(defconstant WH_JOURNALPLAYBACK	1)
+(defconstant WH_KEYBOARD	2)
+(defconstant WH_GETMESSAGE	3)
+(defconstant WH_CALLWNDPROC	4)
+(defconstant WH_CBT		5)
+(defconstant WH_SYSMSGFILTER	6)
+(defconstant WH_WINDOWMGR	7)
+
+#| HC_* Hook Codes |#
+(defconstant HC_LPLPFNNEXT	-2)
+(defconstant HC_LPFNNEXT	-1)
+(defconstant HC_ACTION		0)
+(defconstant HC_GETNEXT		1)
+(defconstant HC_SKIP		2)
+(defconstant HC_NOREM		3)
+(defconstant HC_NOREMOVE	3)
+
+#| CBT hook codes |#
+(defconstant HCBT_MOVESIZE	0)
+(defconstant HCBT_MINMAX	1)
+(defconstant HCBT_QS		2)
+
+#| WH_MSGFILTER filter proc codes |#
+(defconstant MSGF_DIALOGBOX	0)
+(defconstant MSGF_MESSAGEBOX	1)
+(defconstant MSGF_MENU		2)
+(defconstant MSGF_MOVE		3)
+(defconstant MSGF_SIZE		4)
+(defconstant MSGF_SCROLLBAR	5)
+(defconstant MSGF_NEXTWINDOW	6)
+
+#| Define window manager hook codes |#
+(defconstant WC_INIT		1)
+(defconstant WC_SWP		2)
+(defconstant WC_DEFWINDOWPROC	3)
+(defconstant WC_MINMAX		4)
+(defconstant WC_MOVE		5)
+(defconstant WC_SIZE		6)
+(defconstant WC_DRAWCAPTION	7)
+||#
+
+#| Binary raster ops |#
+(defconstant R2_BLACK		1)	#| 0	|#
+(defconstant R2_NOTMERGEPEN	2)	#| DPon	|#
+(defconstant R2_MASKNOTPEN	3)	#| DPna	|#
+(defconstant R2_NOTCOPYPEN	4)	#| PN	|#
+(defconstant R2_MASKPENNOT	5)	#| PDna	|#
+(defconstant R2_NOT		6)	#| Dn	|#
+(defconstant R2_XORPEN		7)	#| DPx	|#
+(defconstant R2_NOTMASKPEN	8)	#| DPan	|#
+(defconstant R2_MASKPEN		9)	#| DPa	|#
+(defconstant R2_NOTXORPEN	10)	#| DPxn	|#
+(defconstant R2_NOP		11)	#| D	|#
+(defconstant R2_MERGENOTPEN	12)	#| DPno	|#
+(defconstant R2_COPYPEN		13)	#| P	|#
+(defconstant R2_MERGEPENNOT	14)	#| PDno	|#
+(defconstant R2_MERGEPEN	15)	#| DPo	|#
+(defconstant R2_WHITE		16)	#| 1	|#
+
+#||
+#| Ternary raster operations |#
+(defconstant SRCCOPY	#x00CC0020)	#| dest=source |#
+(defconstant SRCPAINT	#x00EE0086)	#| dest=source OR dest |#
+(defconstant SRCAND	#x008800C6)	#| dest=source AND dest |#
+(defconstant SRCINVERT	#x00660046)	#| dest=source XOR	dest |#
+(defconstant SRCERASE	#x00440328)	#| dest=source AND (not dest ) |#
+(defconstant NOTSRCCOPY	#x00330008)	#| dest=(not source) |#
+(defconstant NOTSRCERASE #x001100A6)	#| dest=(not source) AND (not dest) |#
+(defconstant MERGECOPY	#x00C000CA)	#| dest=(source AND pattern) |#
+(defconstant MERGEPAINT	#x00BB0226)	#| dest=(NOT source) OR dest |#
+(defconstant PATCOPY	#x00F00021)	#| dest=pattern |#
+(defconstant PATPAINT	#x00FB0A09)	#| dest=DPSnoo |#
+(defconstant PATINVERT	#x005A0049)	#| dest=pattern XOR dest |#
+(defconstant DSTINVERT	#x00550009)	#| dest=(not dest) |#
+(defconstant BLACKNESS	#x00000042)	#| dest=BLACK |#
+(defconstant WHITENESS	#x00FF0062)	#| dest=WHITE |#
+
+#| StretchBlt() modes |#
+(defconstant BLACKONWHITE	1)
+(defconstant WHITEONBLACK	2)
+(defconstant COLORONCOLOR	3)
+
+#| PolyFill modes |#
+(defconstant ALTERNATE	1)
+(defconstant WINDING	2)
+
+#| text alignment options |#
+(defconstant TA_UPDATECP	1)
+(defconstant TA_NOUPDATECP	0)
+
+(defconstant TA_LEFT	0)
+(defconstant TA_RIGHT	2)
+(defconstant TA_CENTER	6)
+
+(defconstant TA_TOP		0)
+(defconstant TA_BOTTOM		8)
+(defconstant TA_BASELINE	24)
+
+(defconstant ETO_GRAYED		1)
+(defconstant ETO_OPAQUE		2)
+(defconstant ETO_CLIPPED	4)
+
+
+
+(defconstant ASPECT_FILTERING #x00000001)
+
+#| Meta file function numbers |#
+(defconstant META_SETBKCOLOR		#x0201)
+(defconstant META_SETBKMODE		#x0102)
+(defconstant META_SETMAPMODE		#x0103)
+(defconstant META_SETROP2		#x0104)
+(defconstant META_SETRELABS		#x0105)
+(defconstant META_SETPOLYFILLMODE	#x0106)
+(defconstant META_SETSTRETCHBLTMODE	#x0107)
+(defconstant META_SETTEXTCHAREXTRA	#x0108)
+(defconstant META_SETTEXTCOLOR		#x0209)
+(defconstant META_SETTEXTJUSTIFICATION	#x020A)
+(defconstant META_SETWINDOWORG		#x020B)
+(defconstant META_SETWINDOWEXT		#x020C)
+(defconstant META_SETVIEWPORTORG	#x020D)
+(defconstant META_SETVIEWPORTEXT	#x020E)
+(defconstant META_OFFSETWINDOWORG	#x020F)
+(defconstant META_SCALEWINDOWEXT	#x0400)
+(defconstant META_OFFSETVIEWPORTORG	#x0211)
+(defconstant META_SCALEVIEWPORTEXT	#x0412)
+(defconstant META_LINETO		#x0213)
+(defconstant META_MOVETO		#x0214)
+(defconstant META_EXCLUDECLIPRECT	#x0415)
+(defconstant META_INTERSECTCLIPRECT	#x0416)
+(defconstant META_ARC			#x0817)
+(defconstant META_ELLIPSE		#x0418)
+(defconstant META_FLOODFILL		#x0419)
+(defconstant META_PIE			#x081A)
+(defconstant META_RECTANGLE		#x041B)
+(defconstant META_ROUNDRECT		#x061C)
+(defconstant META_PATBLT		#x061D)
+(defconstant META_SAVEDC		#x001E)
+(defconstant META_SETPIXEL		#x041F)
+(defconstant META_OFFSETCLIPRGN		#x0220)
+(defconstant META_TEXTOUT		#x0521)
+(defconstant META_BITBLT		#x0922)
+(defconstant META_STRETCHBLT		#x0B23)
+(defconstant META_POLYGON		#x0324)
+(defconstant META_POLYLINE		#x0325)
+(defconstant META_ESCAPE		#x0626)
+(defconstant META_RESTOREDC		#x0127)
+(defconstant META_FILLREGION		#x0228)
+(defconstant META_FRAMEREGION		#x0429)
+(defconstant META_INVERTREGION		#x012A)
+(defconstant META_PAINTREGION		#x012B)
+(defconstant META_SELECTCLIPREGION	#x012C)
+(defconstant META_SELECTOBJECT		#x012D)
+(defconstant META_SETTEXTALIGN		#x012E)
+(defconstant META_DRAWTEXT		#x062F)
+(defconstant META_CHORD			#x0630)
+(defconstant META_CREATEBRUSH		#x00F8)
+(defconstant META_CREATEPATTERNBRUSH	#x01F9)
+(defconstant META_CREATEPENINDIRECT	#x02FA)
+(defconstant META_CREATEFONTINDIRECT	#x02FB)
+(defconstant META_CREATEBRUSHINDIRECT	#x02FC)
+(defconstant META_CREATEBITMAPINDIRECT	#x02FD)
+(defconstant META_CREATEBITMAP		#x06FE)
+(defconstant META_CREATEREGION		#x06FF)
+
+#| GDI escapes |#
+(defconstant NEWFRAME		1)
+(defconstant ABORTDOC		2)
+(defconstant NEXTBAND		3)
+(defconstant SETCOLORTABLE	4)
+(defconstant GETCOLORTABLE	5)
+(defconstant FLUSHOUTPUT	6)
+(defconstant DRAFTMODE		7)
+(defconstant QUERYESCSUPPORT	8)
+(defconstant SETABORTPROC	9)
+(defconstant STARTDOC		10)
+(defconstant ENDDOC		11)
+(defconstant GETPHYSPAGESIZE	12)
+(defconstant GETPRINTINGOFFSET	13)
+(defconstant GETSCALINGFACTOR	14)
+(defconstant MFCOMMENT		15)	#| Metafile comment escape |#
+(defconstant GETPENWIDTH	16)
+(defconstant SETCOPYCOUNT	17)
+(defconstant SELECTPAPERSOURCE	18)
+(defconstant DEVICEDATA		19)
+(defconstant PASSTHROUGH	19)
+(defconstant GETTECHNOLGY	20)
+(defconstant SETENDCAP		21)
+(defconstant SETLINEJOIN	22)
+(defconstant SETMITERLIMIT	23)
+(defconstant BANDINFO		24)
+(defconstant DRAWPATTERNRECT	25)
+(defconstant GETVECTORPENSIZE	26)
+(defconstant GETVECTORBRUSHSIZE	27)
+(defconstant ENABLEDUPLEX	28)
+(defconstant ENABLEMANUALFEED	29)
+
+
+
+(defconstant GETEXTENDEDTEXTMETRICS	256)
+(defconstant GETEXTENTTABLE		257)
+(defconstant GETPAIRKERNTABLE		258)
+(defconstant GETTRACKKERNTABLE		259)
+
+(defconstant EXTTEXTOUT			512)
+
+(defconstant ENABLERELATIVEWIDTHS	768)
+(defconstant ENABLEPAIRKERNING		769)
+(defconstant SETKERNTRACK		770)
+(defconstant STRETCHBLT			2048)
+
+
+#| spooler error code |#
+(defconstant SP_NOTREPORTED	#x4000)	#| set if GDI did not report error |#
+(defconstant SP_ERROR		-1)	
+		#| general errors who know what went wrong |#
+(defconstant SP_APPABORT	-2)
+		#| app aborted the job - callback function returned false |#
+(defconstant SP_USERABORT	-3)
+		#| user aborted the job through spooler's front end |#
+(defconstant SP_OUTOFDISK	-4)	#| not enough disk space to spool |#
+(defconstant SP_OUTOFMEMORY	-5)
+
+#| spooler WM_SPOOLERSTATUS wparm classes |#
+
+(defconstant PR_JOBSTATUS	#x0000)
+
+#| Object definitions for GDI EnumObjects. |#
+(defconstant OBJ_PEN	1)
+(defconstant OBJ_BRUSH	2)
+
+#| Window field offsets for GetWindowLong & GetWindowWord |#
+(defconstant GWL_WNDPROC	-4)
+(defconstant GWW_HINSTANCE	-6)
+(defconstant GWW_HWNDPARENT	-8)
+(defconstant GWW_HWNDTEXT	-10)
+(defconstant GWW_ID		-12)
+(defconstant GWL_STYLE		-16)
+
+#| Class field offsets for GetClassLong & GetClassWord |#
+(defconstant GCL_MENUNAME	-8)
+(defconstant GCW_HBRBACKGROUND	-10)
+(defconstant GCW_HCURSOR	-12)
+(defconstant GCW_HICON		-14)
+(defconstant GCW_HMODULE	-16)
+(defconstant GCW_CBWNDEXTRA	-18)
+(defconstant GCW_CBCLSEXTRA	-20)
+(defconstant GCL_WNDPROC	-24)
+(defconstant GCW_STYLE		-26)
+
+#| ** Window Procedure Messages |#
+
+(defconstant WM_NULL		#x0000)
+(defconstant WM_CREATE		#x0001)
+(defconstant WM_DESTROY		#x0002)
+||#
+(defconstant WM_MOVE		#x0003)
+#||
+(defconstant WM_SIZEWAIT	#x0004)
+||#
+(defconstant WM_SIZE		#x0005)
+#||
+(defconstant WM_ACTIVATE	#x0006)
+(defconstant WM_SETFOCUS	#x0007)
+(defconstant WM_KILLFOCUS	#x0008)
+(defconstant WM_SETVISIBLE	#x0009)
+(defconstant WM_ENABLE		#x000a)
+(defconstant WM_SETREDRAW	#x000b)
+(defconstant WM_SETTEXT		#x000c)
+(defconstant WM_GETTEXT		#x000d)
+(defconstant WM_GETTEXTLENGTH	#x000e)
+||#
+(defconstant WM_PAINT		#x000f)
+#||
+(defconstant WM_CLOSE		#x0010)
+(defconstant WM_QUERYENDSESSION	#x0011)
+(defconstant WM_QUIT		#x0012)
+(defconstant WM_QUERYOPEN	#x0013)
+(defconstant WM_ERASEBKGND	#x0014)
+(defconstant WM_SYSCOLORCHANGE	#x0015)
+(defconstant WM_ENDSESSION	#x0016)
+(defconstant WM_SYSTEMERROR	#x0017)
+(defconstant WM_SHOWWINDOW	#x0018)
+(defconstant WM_CTLCOLOR	#x0019)
+(defconstant WM_WININICHANGE	#x001A)
+(defconstant WM_DEVMODECHANGE	#x001B)
+(defconstant WM_ACTIVATEAPP	#x001C)
+(defconstant WM_FONTCHANGE	#x001D)
+(defconstant WM_TIMECHANGE	#x001E)
+(defconstant WM_CANCELMODE	#x001F)
+(defconstant WM_SETCURSOR	#x0020)
+(defconstant WM_MOUSEACTIVATE	#x0021)
+(defconstant WM_CHILDACTIVATE	#x0022)
+(defconstant WM_QUEUESYNC	#x0023)
+(defconstant WM_GETMINMAXINFO	#x0024)
+(defconstant WM_PAINTICON	#x0026)
+(defconstant WM_ICONERASEBKGND	#x0027)
+(defconstant WM_NEXTDLGCTL	#x0028)
+(defconstant WM_ALTTABACTIVE	#x0029)	#| for win386 only |#
+(defconstant WM_SPOOLERSTATUS	#x002A)
+
+
+(defconstant WM_NCCREATE	#x0081)
+(defconstant WM_NCDESTROY	#x0082)
+(defconstant WM_NCCALCSIZE	#x0083)
+(defconstant WM_NCHITTEST	#x0084)
+(defconstant WM_NCPAINT		#x0085)
+(defconstant WM_NCACTIVATE	#x0086)
+(defconstant WM_GETDLGCODE	#x0087)
+(defconstant WM_SYNCPAINT	#x0088)
+(defconstant WM_SYNCTASK	#x0089)
+
+(defconstant ST_BEGINSWP	0)
+(defconstant ST_ENDSWP		1)
+
+(defconstant WM_NCMOUSEMOVE	#x00a0)
+(defconstant WM_NCLBUTTONDOWN	#x00a1)
+(defconstant WM_NCLBUTTONUP	#x00a2)
+(defconstant WM_NCLBUTTONDBLCLK	#x00a3)
+(defconstant WM_NCRBUTTONDOWN	#x00a4)
+(defconstant WM_NCRBUTTONUP	#x00a5)
+(defconstant WM_NCRBUTTONDBLCLK	#x00a6)
+(defconstant WM_NCMBUTTONDOWN	#x00a7)
+(defconstant WM_NCMBUTTONUP	#x00a8)
+(defconstant WM_NCMBUTTONDBLCLK	#x00a9)
+
+#| WINWhere area codes |#
+(defconstant HTERROR		-2)
+(defconstant HTTRANSPARENT	-1)
+(defconstant HTNOWHERE		0)
+(defconstant HTCLIENT		1)
+(defconstant HTCAPTION		2)
+(defconstant HTSYSMENU		3)
+(defconstant HTGROWBOX		4)
+(defconstant HTSIZE		HTGROWBOX)
+(defconstant HTMENU		5)
+(defconstant HTHSCROLL		6)
+(defconstant HTVSCROLL		7)
+(defconstant HTREDUCE		8)
+(defconstant HTZOOM		9)
+(defconstant HTLEFT		10)
+(defconstant HTRIGHT		11)
+(defconstant HTTOP		12)
+(defconstant HTTOPLEFT		13)
+(defconstant HTTOPRIGHT		14)
+(defconstant HTBOTTOM		15)
+(defconstant HTBOTTOMLEFT	16)
+(defconstant HTBOTTOMRIGHT	17)
+(defconstant HTSIZEFIRST	HTLEFT)
+(defconstant HTSIZELAST		HTBOTTOMRIGHT)
+
+#| WM_MOUSEACTIVATE return codes |#
+(defconstant MA_ACTIVATE	1)
+(defconstant MA_ACTIVATEANDEAT	2)
+(defconstant MA_NOACTIVATE	3)
+
+(defconstant WM_KEYFIRST	#x0100)
+(defconstant WM_KEYLAST		#x0108)
+
+||#
+(defconstant WM_KEYDOWN		#x0100)
+(defconstant WM_KEYUP		#x0101)
+(defconstant WM_CHAR		#x0102)
+(defconstant WM_SYSCHAR		#x0106)
+#||
+(defconstant WM_DEADCHAR	#x0103)
+(defconstant WM_SYSKEYDOWN	#x0104)
+(defconstant WM_SYSKEYUP	#x0105)
+
+(defconstant WM_SYSDEADCHAR	#x0107)
+(defconstant WM_YOMICHAR	#x0108)
+(defconstant WM_CONVERTREQUEST	#x010A)
+(defconstant WM_CONVERTRESULT	#x010B)
+
+(defconstant WM_INITDIALOG	#x0110)
+(defconstant WM_COMMAND		#x0111)
+(defconstant WM_SYSCOMMAND	#x0112)
+(defconstant WM_TIMER		#x0113)
+||#
+(defconstant WM_HSCROLL		#x0114)
+(defconstant WM_VSCROLL		#x0115)
+#||
+(defconstant WM_INITMENU	#x0116)
+(defconstant WM_INITMENUPOPUP	#x0117)
+(defconstant WM_SYSTIMER	#x0118)
+(defconstant WM_MENUSELECT	#x011f)
+(defconstant WM_MENUCHAR	#x0120)
+(defconstant WM_ENTERIDLE	#x0121)
+
+
+(defconstant WM_MOUSEFIRST	#x0200)
+(defconstant WM_MOUSELAST	#x0209)
+||#
+(defconstant WM_MOUSEMOVE	#x0200)	#| mouse related constants |#
+(defconstant WM_LBUTTONDOWN	#x0201)
+(defconstant WM_LBUTTONUP	#x0202)
+(defconstant WM_LBUTTONDBLCLK	#x0203)
+(defconstant WM_RBUTTONDOWN	#x0204)
+(defconstant WM_RBUTTONUP	#x0205)
+(defconstant WM_RBUTTONDBLCLK	#x0206)
+(defconstant WM_MBUTTONDOWN	#x0207)
+(defconstant WM_MBUTTONUP	#x0208)
+(defconstant WM_MBUTTONDBLCLK	#x0209)
+#||
+(defconstant WM_KANJIFIRST	#x0280)
+(defconstant WM_KANJILAST	#x029f)
+
+#| clipboard messages |#
+(defconstant WM_CUT		#x0300)
+(defconstant WM_COPY		#x0301)
+(defconstant WM_PASTE		#x0302)
+(defconstant WM_CLEAR		#x0303)
+(defconstant WM_UNDO		#x0304)
+(defconstant WM_RENDERFORMAT	#x0305)
+(defconstant WM_RENDERALLFORMATS #x0306)
+(defconstant WM_DESTROYCLIPBOARD #x0307)
+(defconstant WM_DRAWCLIPBOARD	#x0308)
+(defconstant WM_PAINTCLIPBOARD	#x0309)
+(defconstant WM_VSCROLLCLIPBOARD #x030A)
+(defconstant WM_SIZECLIPBOARD	#x030B)
+(defconstant WM_ASKCBFORMATNAME	#x030C)
+(defconstant WM_CHANGECBCHAIN	#x030D)
+(defconstant WM_HSCROLLCLIPBOARD #x030E)
+
+#| #x03f0 to #x03ff are reserved |#
+#| private window messages start here |#
+(defconstant WM_USER		#x0400)
+||#
+
+#| Size message commands |#
+(defconstant SIZENORMAL		0)
+(defconstant SIZEICONIC		1)
+(defconstant SIZEFULLSCREEN	2)
+(defconstant SIZEZOOMSHOW	3)
+(defconstant SIZEZOOMHIDE	4)
+#| Key state masks for mouse messages |#
+(defconstant MK_LBUTTON	#x0001)
+(defconstant MK_RBUTTON	#x0002)
+(defconstant MK_SHIFT	#x0004)
+(defconstant MK_CONTROL	#x0008)
+(defconstant MK_MBUTTON	#x0010)
+
+
+#| Window styles |#
+;;;*** Note: we've shifted these right by 4 bits to make them fixnums;
+;;;***  see the definition of STORE-28BIT.
+(defconstant WS_TILED		#x0000000)
+(defconstant WS_OVERLAPPED	WS_TILED)
+(defconstant WS_ICONICPOPUP	#xc000000)
+(defconstant WS_POPUP		#x8000000)
+(defconstant WS_CHILD		#x4000000)
+(defconstant WS_MINIMIZE	#x2000000)
+(defconstant WS_VISIBLE		#x1000000)
+(defconstant WS_DISABLED	#x0800000)
+(defconstant WS_CLIPSIBLINGS	#x0400000)
+(defconstant WS_CLIPCHILDREN	#x0200000)
+(defconstant WS_MAXIMIZE	#x0100000)
+
+(defconstant WS_BORDER		#x0080000)
+(defconstant WS_CAPTION		#x00c0000)
+(defconstant WS_DLGFRAME	#x0040000)
+(defconstant WS_VSCROLL		#x0020000)
+(defconstant WS_HSCROLL		#x0010000)
+(defconstant WS_SYSMENU		#x0008000)
+(defconstant WS_SIZEBOX		#x0004000)
+(defconstant WS_THICKFRAME	#x0004000)
+(defconstant WS_GROUP		#x0002000)
+(defconstant WS_TABSTOP		#x0001000)
+
+(defconstant WS_MINIMIZEBOX	#x0002000)
+(defconstant WS_MAXIMIZEBOX	#x0001000)
+
+(defconstant WS_ICONIC		WS_MINIMIZE)
+
+#| Class styles |#
+(defconstant CS_VREDRAW		#x0001)
+(defconstant CS_HREDRAW		#x0002)
+(defconstant CS_KEYCVTWINDOW	#x0004)
+(defconstant CS_DBLCLKS		#x0008)
+(defconstant CS_OEMCHARS	#x0010)
+(defconstant CS_OWNDC		#x0020)
+(defconstant CS_CLASSDC		#x0040)
+(defconstant CS_PARENTDC	#x0080)
+(defconstant CS_NOKEYCVT	#x0100)
+(defconstant CS_SAVEBITS	#x0800)
+(defconstant CS_NOCLOSE		#x0200)
+(defconstant CS_BYTEALIGNCLIENT #x1000)
+(defconstant CS_BYTEALIGNWINDOW #x2000)
+
+#| Shorthand for the common cases |#
+(defconstant WS_TILEDWINDOW	(logior WS_TILED WS_CAPTION WS_SYSMENU
+				 WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX))
+(defconstant WS_OVERLAPPEDWINDOW	WS_TILEDWINDOW)
+(defconstant WS_POPUPWINDOW	(logior WS_POPUP WS_BORDER WS_SYSMENU))
+(defconstant WS_CHILDWINDOW	WS_CHILD)
+
+#||
+#| clipboard metafile picture structure |#
+
+#| predefined clipboard formats |#
+(defconstant CF_TEXT		1)
+(defconstant CF_BITMAP		2)
+(defconstant CF_METAFILEPICT	3)
+(defconstant CF_SYLK		4)
+(defconstant CF_DIF		5)
+(defconstant CF_TIFF		6)
+(defconstant CF_OEMTEXT		7)
+
+(defconstant CF_OWNERDISPLAY	#x80)	#| owner display |#
+(defconstant CF_DSPTEXT		#x81)	#| display text |#
+(defconstant CF_DSPBITMAP	#x82)	#| display bitmap |#
+(defconstant CF_DSPMETAFILEPICT	#x83)	#| display metafile |#
+
+#| Private clipboard format range |#
+(defconstant CF_PRIVATEFIRST	#x200)	#| Anything in this range doesn't |#
+(defconstant CF_PRIVATELAST	#x2FF)	#| get GlobalFree'd |#
+(defconstant CF_GDIOBJFIRST	#x300)	#| Anything in this range gets |#
+(defconstant CF_GDIOBJLAST	#x3FF)	#| DeleteObject'ed |#
+
+#| Logical font constants |#
+
+(defconstant OUT_DEFAULT_PRECIS		0)
+(defconstant OUT_STRING_PRECIS		1)
+(defconstant OUT_CHARACTER_PRECIS	2)
+(defconstant OUT_STROKE_PRECIS		3)
+
+(defconstant CLIP_DEFAULT_PRECIS	0)
+(defconstant CLIP_CHARACTER_PRECIS	1)
+(defconstant CLIP_STROKE_PRECIS		2)
+
+(defconstant DEFAULT_QUALITY	0)
+(defconstant DRAFT_QUALITY	1)
+(defconstant PROOF_QUALITY	2)
+
+(defconstant DEFAULT_PITCH	0)
+(defconstant FIXED_PITCH	1)
+(defconstant VARIABLE_PITCH	2)
+
+(defconstant ANSI_CHARSET	0)
+(defconstant SHIFTJIS_CHARSET	128)	#| Kanji CharSet |#
+(defconstant OEM_CHARSET	255)
+
+#| GDI font families. |#
+(defconstant FF_DONTCARE 0)	#| Don't care or don't know. |#
+(defconstant FF_ROMAN	16)	#| Variable stroke width, serifed. |#
+				#| Times Roman, Century Schoolbook, etc. |#
+(defconstant FF_SWISS	32)	#| Variable stroke width, sans-serifed. |#
+				#| Helvetica, Swiss, etc. |#
+(defconstant FF_MODERN	48)	#| Constant stroke width, serif or sans. |#
+				#| Pica, Elite, Courier, etc. |#
+(defconstant FF_SCRIPT	64)	#| Cursive, etc. |#
+(defconstant FF_DECORATIVE 80)	#| Old English, etc. |#
+
+#| Font weights lightest to darkest. |#
+(defconstant FW_DONTCARE	0)
+(defconstant FW_THIN		100)
+(defconstant FW_EXTRALIGHT	200)
+(defconstant FW_LIGHT		300)
+(defconstant FW_NORMAL		400)
+(defconstant FW_MEDIUM		500)
+(defconstant FW_SEMIBOLD	600)
+(defconstant FW_BOLD		700)
+(defconstant FW_EXTRABOLD	800)
+(defconstant FW_HEAVY		900)
+
+(defconstant FW_ULTRALIGHT	FW_EXTRALIGHT)
+(defconstant FW_REGULAR		FW_NORMAL)
+(defconstant FW_DEMIBOLD	FW_SEMIBOLD)
+(defconstant FW_ULTRABOLD	FW_EXTRABOLD)
+(defconstant FW_BLACK		FW_HEAVY)
+
+
+#| EnumFonts masks. |#
+(defconstant RASTER_FONTTYPE #x0001)
+(defconstant DEVICE_FONTTYPE #x0002)
+
+#| GDI rgb values packed into a dword |#
+
+#| +++ make these into Lisp macros!
+(defconstant RGB(r,g,b) (( ((b) << 8 | (g)) << 8) | (r)))
+(defconstant GetRValue(rgb) ((BYTE)(rgb)))
+(defconstant GetGValue(rgb) ((BYTE)(((WORD)(rgb)) >> 8)))
+(defconstant GetBValue(rgb) ((BYTE)((rgb)>>16)))
+|#
+
+#| GDI Background Modes |#
+
+(defconstant TRANSPARENT	1)
+(defconstant OPAQUE		2)
+
+#| GDI map modes |#
+(defconstant MM_TEXT		1)
+(defconstant MM_LOMETRIC	2)
+(defconstant MM_HIMETRIC	3)
+(defconstant MM_LOENGLISH	4)
+(defconstant MM_HIENGLISH	5)
+(defconstant MM_TWIPS		6)
+(defconstant MM_ISOTROPIC	7)
+(defconstant MM_ANISOTROPIC	8)
+
+#| GDI coordinate modes |#
+
+(defconstant ABSOLUTE	1)
+(defconstant RELATIVE	2)
+||#
+
+#| Stock Logical Objects |#
+(defconstant WHITE_BRUSH	0)
+(defconstant LTGRAY_BRUSH	1)
+(defconstant GRAY_BRUSH		2)
+(defconstant DKGRAY_BRUSH	3)
+(defconstant BLACK_BRUSH	4)
+(defconstant NULL_BRUSH		5)
+(defconstant HOLLOW_BRUSH	NULL_BRUSH)
+(defconstant WHITE_PEN		6)
+(defconstant BLACK_PEN		7)
+(defconstant NULL_PEN		8)
+(defconstant OEM_FIXED_FONT	10)
+(defconstant ANSI_FIXED_FONT	11)
+(defconstant ANSI_VAR_FONT	12)
+(defconstant SYSTEM_FONT	13)
+(defconstant DEVICEDEFAULT_FONT 14)
+
+#| GDI Brush Style definitions. |#
+
+(defconstant BS_SOLID	0)
+(defconstant BS_NULL	1)
+(defconstant BS_HOLLOW	BS_NULL)
+(defconstant BS_HATCHED	2)
+(defconstant BS_PATTERN	3)
+(defconstant BS_INDEXED	4)
+
+#| GDI Hatch Style definitions. |#
+
+(defconstant HS_HORIZONTAL	0)	#| ----- |#
+(defconstant HS_VERTICAL	1)	#| ||||| |#
+(defconstant HS_FDIAGONAL	2)	#| ///// |#
+(defconstant HS_BDIAGONAL	3)	#| \\\\\ |#
+(defconstant HS_CROSS		4)	#| +++++ |#
+(defconstant HS_DIAGCROSS	5)	#| xxxxx |#
+
+
+#| GDI Pen Style definitions |#
+(defconstant PS_SOLID		0)	#| solid pen |#
+(defconstant PS_DASH		1)	#| ------- |#
+(defconstant PS_DOT		2)	#| ....... |#
+(defconstant PS_DASHDOT		3)	#| _._._._ |#
+(defconstant PS_DASHDOTDOT	4)	#| _.._.._ |#
+(defconstant PS_NULL		5)	#|         |#
+
+#||
+#| Device Parameters for GetDeviceCaps() |#
+
+(defconstant DRIVERVERSION	0)	#| Device driver version |#
+(defconstant TECHNOLOGY		2)	#| Device classification |#
+(defconstant HORZSIZE		4)	#| Horizontal size in millimeters |#
+(defconstant VERTSIZE		6)	#| Vertical size in millimeters |#
+(defconstant HORZRES		8)	#| Horizontal width in pixels |#
+(defconstant VERTRES		10)	#| Vertical width in pixels |#
+(defconstant BITSPIXEL		12)	#| Number of bits per pixel |#
+(defconstant PLANES		14)	#| Number of planes |#
+(defconstant NUMBRUSHES		16)	#| Number of brushes the device has |#
+(defconstant NUMPENS		18)	#| Number of pens the device has |#
+(defconstant NUMMARKERS		20)	#| Number of markers the device has |#
+(defconstant NUMFONTS		22)	#| Number of fonts the device has |#
+(defconstant NUMCOLORS		24)
+(defconstant PDEVICESIZE	26)	#| Size required for device descriptor |#
+(defconstant CURVECAPS		28)	#| Curves capabilities |#
+(defconstant LINECAPS		30)	#| Line	capabilities |#
+(defconstant POLYGONALCAPS	32)	#| Polygonal capabilities |#
+(defconstant TEXTCAPS		34)	#| Text	capabilities |#
+(defconstant CLIPCAPS		36)	#| Clipping	capabilities |#
+(defconstant RASTERCAPS		38)	#| Bitblt	capabilities |#
+(defconstant ASPECTX		40)	#| Length of the X leg |#
+(defconstant ASPECTY		42)	#| Length of the Y leg |#
+(defconstant ASPECTXY		44)	#| Length of the hypotenuse |#
+
+(defconstant LOGPIXELSX		88)	#| Logical pixels/inch in X |#
+(defconstant LOGPIXELSY		90)	#| Logical pixels/inch in Y |#
+
+#| Device capability masks |#
+#| Device Technologies |#
+
+(defconstant DT_PLOTTER		0)	#| Vector plotter |#
+(defconstant DT_RASDISPLAY	1)	#| Raster display |#
+(defconstant DT_RASPRINTER	2)	#| Raster printer |#
+(defconstant DT_RASCAMERA	3)	#| Raster camera |#
+(defconstant DT_CHARSTREAM	4)	#| Character-stream, PLP |#
+(defconstant DT_METAFILE	5)	#| Metafile, VDM |#
+(defconstant DT_DISPFILE	6)	#| Display-file |#
+
+#| Curve Capabilities |#
+
+(defconstant CC_NONE		0)	#| Curves not supported |#
+(defconstant CC_CIRCLES		1)	#| Can do circles |#
+(defconstant CC_PIE		2)	#| Can do pie wedges |#
+(defconstant CC_CHORD		4)	#| Can do chord arcs |#
+(defconstant CC_ELLIPSES	8)	#| Can do ellipese |#
+(defconstant CC_WIDE		16)	#| Can do wide lines |#
+(defconstant CC_STYLED		32)	#| Can do styled lines |#
+(defconstant CC_WIDESTYLED	64)	#| Can do wide styled lines|#
+(defconstant CC_INTERIORS	128)	#| Can do interiors |#
+
+#| Line Capabilities |#
+
+(defconstant LC_NONE		0)	#| Lines not supported |#
+(defconstant LC_POLYLINE	2)	#| Can do polylines |#
+(defconstant LC_MARKER		4)	#| Can do markers |#
+(defconstant LC_POLYMARKER	8)	#| Can do polymarkers |#
+(defconstant LC_WIDE		16)	#| Can do wide lines |#
+(defconstant LC_STYLED		32)	#| Can do styled lines |#
+(defconstant LC_WIDESTYLED	64)	#| Can do wide styled lines|#
+(defconstant LC_INTERIORS	128)	#| Can do interiors |#
+
+#| Polygonal Capabilities |#
+
+(defconstant PC_NONE		0)	#| Polygonals not supported|#
+(defconstant PC_POLYGON		1)	#| Can do polygons |#
+(defconstant PC_RECTANGLE	2)	#| Can do rectangles |#
+(defconstant PC_TRAPEZOID	4)	#| Can do trapezoids |#
+(defconstant PC_SCANLINE	8)	#| Can do scanlines |#
+(defconstant PC_WIDE		16)	#| Can do wide borders |#
+(defconstant PC_STYLED		32)	#| Can do styled borders |#
+(defconstant PC_WIDESTYLED	64)	#| Can do wide styled borders|#
+(defconstant PC_INTERIORS	128)	#| Can do interiors |#
+
+#| Polygonal Capabilities |#
+
+(defconstant CP_NONE		0)	#| no clipping of Output |#
+(defconstant CP_RECTANGLE	1)	#| Output clipped to Rects |#
+
+#| Text Capabilities |#
+
+(defconstant TC_OP_CHARACTER	#x0001)	#| Can do OutputPrecision CHARACTER |#
+(defconstant TC_OP_STROKE	#x0002)	#| Can do OutputPrecision STROKE |#
+(defconstant TC_CP_STROKE	#x0004)	#| Can do ClipPrecision	STROKE |#
+(defconstant TC_CR_90		#x0008)	#| Can do CharRotAbility	90 |#
+(defconstant TC_CR_ANY		#x0010)	#| Can do CharRotAbility	ANY |#
+(defconstant TC_SF_X_YINDEP	#x0020)	#|  " " ScaleFreedom X_YINDEPENDENT |#
+(defconstant TC_SA_DOUBLE	#x0040)	#| Can do ScaleAbility DOUBLE |#
+(defconstant TC_SA_INTEGER	#x0080)	#| Can do ScaleAbility INTEGER |#
+(defconstant TC_SA_CONTIN	#x0100)	#| Can do ScaleAbility CONTINUOUS |#
+(defconstant TC_EA_DOUBLE	#x0200)	#| Can do EmboldenAbility DOUBLE |#
+(defconstant TC_IA_ABLE		#x0400)	#| Can do ItalisizeAbility ABLE |#
+(defconstant TC_UA_ABLE		#x0800)	#| Can do UnderlineAbility ABLE |#
+(defconstant TC_SO_ABLE		#x1000)	#| Can do StrikeOutAbility ABLE |#
+(defconstant TC_RA_ABLE		#x2000)	#| Can do RasterFontAble ABLE |#
+(defconstant TC_VA_ABLE		#x4000)	#| Can do VectorFontAble ABLE |#
+(defconstant TC_RESERVED	#x8000)	#| Reserved. |#
+
+#| Raster Capabilities |#
+
+(defconstant RC_BITBLT 		1)	#| Can do standard non-stretching, non-inverting BLT. |#
+(defconstant RC_BANDING		2)	#| Device requires banding support |#
+(defconstant RC_SCALING		4)	#| Device requires scaling support |#
+(defconstant RC_BITMAP64	8)	#| Device can support >64K bitmap |#
+
+
+#| PeekMessage options |#
+(defconstant PM_REMOVE		1)
+(defconstant PM_NOREMOVE	0)
+(defconstant PM_NOYIELD		2)
+
+(defconstant CW_USEDEFAULT	#x8000)	#|used on both x and cx |#
+||#
+
+#| SetWindowPos flags |#
+
+(defconstant SWP_NOSIZE		#x01)
+(defconstant SWP_NOMOVE		#x02)
+(defconstant SWP_NOZORDER	#x04)
+(defconstant SWP_NOREDRAW	#x08)
+(defconstant SWP_NOACTIVATE	#x10)
+(defconstant SWP_DRAWFRAME	#x20)
+(defconstant SWP_SHOWWINDOW	#x40)
+(defconstant SWP_HIDEWINDOW	#x80)
+(defconstant SWP_NOCOPYBITS	#x0100)
+(defconstant SWP_NOREPOSITION	#x200)
+
+#||
+#| DrawFrame and associated defines |#
+(defconstant DF_SHIFT0		#x0000)
+(defconstant DF_SHIFT1		#x0001)
+(defconstant DF_SHIFT2		#x0002)
+(defconstant DF_SHIFT3		#x0003)
+(defconstant DF_PATCOPY		#x0000)
+(defconstant DF_PATINVERT	#x0004)
+
+#| +++ Fix these !!!
+(defconstant DF_SCROLLBAR	(COLOR_SCROLLBAR << 3))
+(defconstant DF_BACKGROUND	(COLOR_BACKGROUND << 3))
+(defconstant DF_ACTIVECAPTION	(COLOR_ACTIVECAPTION << 3))
+(defconstant DF_INACTIVECAPTION	(COLOR_INACTIVECAPTION << 3))
+(defconstant DF_MENU		(COLOR_MENU << 3))
+(defconstant DF_WINDOW		(COLOR_WINDOW << 3))
+(defconstant DF_WINDOWFRAME	(COLOR_WINDOWFRAME << 3))
+(defconstant DF_MENUTEXT	(COLOR_MENUTEXT << 3))
+(defconstant DF_WINDOWTEXT	(COLOR_WINDOWTEXT << 3))
+(defconstant DF_CAPTIONTEXT	(COLOR_CAPTIONTEXT << 3))
+(defconstant DF_ACTIVEBORDER	(COLOR_ACTIVEBORDER << 3))
+(defconstant DF_INACTIVEBORDER	(COLOR_INACTIVEBORDER << 3))
+(defconstant DF_APPWORKSPACE	(COLOR_APPWORKSPACE << 3))
+(defconstant DF_GRAY		(DF_APPWORKSPACE + (1 << 3)))
+|#
+
+#| DrawText format flags |#
+(defconstant DT_LEFT		#x00)
+(defconstant DT_CENTER		#x01)
+(defconstant DT_RIGHT		#x02)
+(defconstant DT_TOP		#x00)
+(defconstant DT_VCENTER		#x04)
+(defconstant DT_BOTTOM		#x08)
+(defconstant DT_WORDBREAK	#x10)
+(defconstant DT_SINGLELINE	#x20)
+(defconstant DT_EXPANDTABS	#x40)
+(defconstant DT_TABSTOP		#x80)
+(defconstant DT_NOCLIP		#x100)
+(defconstant DT_EXTERNALLEADING #x200)
+(defconstant DT_CALCRECT	#x400)
+(defconstant DT_NOPREFIX	#x800)
+(defconstant DT_INTERNAL	#x1000)
+
+#| GetSystemMetrics codes |#
+(defconstant SM_CXSCREEN	0)
+(defconstant SM_CYSCREEN	1)
+(defconstant SM_CXVSCROLL	2)
+(defconstant SM_CYHSCROLL	3)
+(defconstant SM_CYCAPTION	4)
+(defconstant SM_CXBORDER	5)
+(defconstant SM_CYBORDER	6)
+(defconstant SM_CXDLGFRAME	7)
+(defconstant SM_CYDLGFRAME	8)
+(defconstant SM_CYVTHUMB	9)
+(defconstant SM_CXHTHUMB	10)
+(defconstant SM_CXICON		11)
+(defconstant SM_CYICON		12)
+(defconstant SM_CXCURSOR	13)
+(defconstant SM_CYCURSOR	14)
+(defconstant SM_CYMENU		15)
+(defconstant SM_CXFULLSCREEN	16)
+(defconstant SM_CYFULLSCREEN	17)
+(defconstant SM_CYKANJIWINDOW	18)
+(defconstant SM_MOUSEPRESENT	19)
+(defconstant SM_CYVSCROLL	20)
+(defconstant SM_CXHSCROLL	21)
+(defconstant SM_DEBUG		22)
+(defconstant SM_SWAPBUTTON	23)
+(defconstant SM_RESERVED1	24)
+(defconstant SM_RESERVED2	25)
+(defconstant SM_RESERVED3	26)	#| new additions since 2.0 |#
+(defconstant SM_RESERVED4	27)
+(defconstant SM_CXMIN		28)
+(defconstant SM_CYMIN		29)
+(defconstant SM_CXSIZE		30)
+(defconstant SM_CYSIZE		31)
+(defconstant SM_CXFRAME		32)
+(defconstant SM_CYFRAME		33)
+(defconstant SM_CXMINTRACK	34)
+(defconstant SM_CYMINTRACK	35)
+(defconstant SM_CMETRICS	36)
+
+#| MessageBox type flags |#
+(defconstant MB_OK		#x0000)
+(defconstant MB_OKCANCEL	#x0001)
+(defconstant MB_ABORTRETRYIGNORE #x0002)
+(defconstant MB_YESNOCANCEL	#x0003)
+(defconstant MB_YESNO		#x0004)
+(defconstant MB_RETRYCANCEL	#x0005)
+
+(defconstant MB_ICONHAND	#x0010)
+(defconstant MB_ICONQUESTION	#x0020)
+(defconstant MB_ICONEXCLAMATION	#x0030)
+(defconstant MB_ICONASTERISK	#x0040)
+
+(defconstant MB_DEFBUTTON1	#x0000)
+(defconstant MB_DEFBUTTON2	#x0100)
+(defconstant MB_DEFBUTTON3	#x0200)
+
+(defconstant MB_APPLMODAL	#x0000)
+(defconstant MB_SYSTEMMODAL	#x1000)
+(defconstant MB_NOFOCUS		#x8000)
+(defconstant MB_MISCMASK	#xC000)
+(defconstant MB_TYPEMASK	#x000F)
+(defconstant MB_ICONMASK	#x00F0)
+(defconstant MB_DEFMASK		#x0F00)
+(defconstant MB_MODEMASK	#x3000)
+
+#| color type indices |#
+#| for the WM_CTLCOLOR message |#
+(defconstant CTLCOLOR_MSGBOX	0)
+(defconstant CTLCOLOR_EDIT	1)
+(defconstant CTLCOLOR_LISTBOX	2)
+(defconstant CTLCOLOR_BTN	3)
+(defconstant CTLCOLOR_DLG	4)
+(defconstant CTLCOLOR_SCROLLBAR	5)
+(defconstant CTLCOLOR_STATIC	6)
+(defconstant CTLCOLOR_MAX	8)	#| three bits max |#
+
+(defconstant COLOR_SCROLLBAR		0)
+(defconstant COLOR_BACKGROUND		1)
+(defconstant COLOR_ACTIVECAPTION	2)
+(defconstant COLOR_INACTIVECAPTION	3)
+(defconstant COLOR_MENU			4)
+(defconstant COLOR_WINDOW		5)
+(defconstant COLOR_WINDOWFRAME		6)
+(defconstant COLOR_MENUTEXT		7)
+(defconstant COLOR_WINDOWTEXT		8)
+(defconstant COLOR_CAPTIONTEXT		9)
+(defconstant COLOR_ACTIVEBORDER		10)
+(defconstant COLOR_INACTIVEBORDER	11)
+(defconstant COLOR_APPWORKSPACE		12)
+
+(defconstant CP_GETBEEP		1)
+(defconstant CP_SETBEEP		2)
+(defconstant CP_GETMOUSE	3)
+(defconstant CP_SETMOUSE	4)
+(defconstant CP_GETBORDER	5)
+(defconstant CP_SETBORDER	6)
+(defconstant CP_TIMEOUTS	7)
+(defconstant CP_KANJIMENU	8)
+
+#| Flags for GetTempFileName |#
+(defconstant TF_FORCEDRIVE	#x80)	#| Forces use of current dir of |#
+					#| passed drive |#
+#| Flags for OpenFile |#
+(defconstant OF_REOPEN	#x8000)
+(defconstant OF_EXIST	#x4000)
+(defconstant OF_PROMPT	#x2000)
+(defconstant OF_CREATE	#x1000)
+(defconstant OF_CANCEL	#x0800)
+(defconstant OF_VERIFY	#x0400)
+(defconstant OF_DELETE	#x0200)
+(defconstant OF_PARSE	#x0100)
+
+(defconstant OF_READ		0)
+(defconstant OF_WRITE		1)
+(defconstant OF_READWRITE	2)
+
+#| Interface to global memory manager |#
+(defconstant GMEM_FIXED		#x0000)
+(defconstant GMEM_MOVEABLE	#x0002)
+(defconstant GMEM_NOCOMPACT	#x0010)
+(defconstant GMEM_NODISCARD	#x0020)
+(defconstant GMEM_ZEROINIT	#x0040)
+(defconstant GMEM_MODIFY	#x0080)
+(defconstant GMEM_DISCARDABLE	#x0F00)
+(defconstant GHND		(logior GMEM_MOVEABLE GMEM_ZEROINIT))
+(defconstant GPTR		(logior GMEM_FIXED GMEM_ZEROINIT))
+(defconstant GMEM_SHARE		#x2000)
+(defconstant GMEM_DDESHARE	#x2000)
+(defconstant GMEM_NOT_BANKED	#x1000)
+(defconstant GMEM_NOTIFY	#x4000)
+(defconstant GMEM_LOWER		GMEM_NOT_BANKED)
+
+#| Flags returned by GlobalFlags (in addition to GMEM_DISCARDABLE) |#
+(defconstant GMEM_DISCARDED	#x4000)
+(defconstant GMEM_SWAPPED	#x8000)
+(defconstant GMEM_LOCKCOUNT	#x00FF)
+
+#| Interface to local memory manager |#
+
+(defconstant LMEM_FIXED		#x0000)
+(defconstant LMEM_MOVEABLE	#x0002)
+(defconstant LMEM_NOCOMPACT	#x0010)
+(defconstant LMEM_NODISCARD	#x0020)
+(defconstant LMEM_ZEROINIT	#x0040)
+(defconstant LMEM_MODIFY	#x0080)
+(defconstant LMEM_DISCARDABLE	#x0F00)
+(defconstant LHND		(logior LMEM_MOVEABLE LMEM_ZEROINIT))
+(defconstant LPTR		(logior LMEM_FIXED LMEM_ZEROINIT))
+(defconstant NONZEROLHND	LMEM_MOVEABLE)
+(defconstant NONZEROLPTR	LMEM_FIXED)
+
+(defconstant LNOTIFY_OUTOFMEM 0)
+(defconstant LNOTIFY_MOVE	1)
+(defconstant LNOTIFY_DISCARD	2)
+
+#| Flags returned by LocalFlags (in addition to LMEM_DISCARDABLE) |#
+(defconstant LMEM_DISCARDED	#x4000)
+(defconstant LMEM_LOCKCOUNT	#x00FF)
+
+#| Predefined resource types |#
+(defconstant RT_CURSOR		1)
+(defconstant RT_BITMAP	 	2)
+(defconstant RT_ICON		3)
+(defconstant RT_MENU	 	4)
+(defconstant RT_DIALOG	 	5)
+(defconstant RT_STRING	 	6)
+(defconstant RT_FONTDIR	 	7)
+(defconstant RT_FONT		8)
+(defconstant RT_ACCELERATOR	9)
+(defconstant RT_RCDATA		10)
+
+#| GetWindow() and constants |#
+(defconstant GW_HWNDFIRST	0)
+(defconstant GW_HWNDLAST	1)
+(defconstant GW_HWNDNEXT	2)
+(defconstant GW_HWNDPREV	3)
+(defconstant GW_OWNER		4)
+(defconstant GW_CHILD		5)
+
+#| Menu flags for Add/Check/EnableMenuItem |#
+(defconstant MF_CHANGE		#x0080)
+(defconstant MF_INSERT		#x0000)
+(defconstant MF_APPEND		#x0100)
+(defconstant MF_DELETE		#x0200)
+(defconstant MF_BYPOSITION	#x0400)
+(defconstant MF_SEPARATOR	#x0800)
+(defconstant MF_REMOVE		#x1000)
+(defconstant MF_BYCOMMAND	#x0000)
+(defconstant MF_GRAYED		#x0001)
+(defconstant MF_DISABLED	#x0002)
+(defconstant MF_ENABLED		#x0000)
+(defconstant MF_CHECKED		#x0008)
+(defconstant MF_UNCHECKED	#x0000)
+(defconstant MF_BITMAP		#x0004)
+(defconstant MF_STRING		#x0000)
+(defconstant MF_POPUP		#x0010)
+(defconstant MF_MENUBARBREAK 	#x0020)
+(defconstant MF_MENUBREAK	#x0040)
+(defconstant MF_HILITE		#x0080)
+(defconstant MF_UNHILITE	#x0000)
+(defconstant MF_HELP		#x4000)
+(defconstant MF_SYSMENU		#x2000)
+(defconstant MF_MOUSESELECT	#x8000)
+
+#| System Menu Command Values |#
+(defconstant SC_SIZE		#xF000)
+(defconstant SC_MOVE		#xF010)
+(defconstant SC_MINIMIZE	#xF020)
+(defconstant SC_MAXIMIZE	#xF030)
+(defconstant SC_NEXTWINDOW	#xF040)
+(defconstant SC_PREVWINDOW	#xF050)
+(defconstant SC_CLOSE		#xF060)
+(defconstant SC_VSCROLL		#xF070)
+(defconstant SC_HSCROLL		#xF080)
+(defconstant SC_MOUSEMENU	#xF090)
+(defconstant SC_KEYMENU		#xF100)
+(defconstant SC_ARRANGE		#xF110)
+(defconstant SC_RESTORE		#xF120)
+(defconstant SC_ICON		SC_MINIMIZE)
+(defconstant SC_ZOOM		SC_MAXIMIZE)
+||#
+
+#| Standard cursor IDs |#
+(defconstant IDC_ARROW		32512)
+(defconstant IDC_IBEAM		32513)
+(defconstant IDC_WAIT		32514)
+(defconstant IDC_CROSS		32515)
+(defconstant IDC_UPARROW	32516)
+(defconstant IDC_SIZE		32640)
+(defconstant IDC_ICON		32641)
+(defconstant IDC_SIZENWSE	32642)
+(defconstant IDC_SIZENESW	32643)
+(defconstant IDC_SIZEWE		32644)
+(defconstant IDC_SIZENS		32645)
+
+#||
+#| Standard icon IDs |#
+(defconstant IDI_APPLICATION	32512)
+(defconstant IDI_HAND		32513)
+(defconstant IDI_QUESTION	32514)
+(defconstant IDI_EXCLAMATION	32515)
+(defconstant IDI_ASTERISK	32516)
+
+(defconstant CP_HWND	0)
+(defconstant CP_OPEN	1)
+(defconstant CP_DIRECT	2)
+
+#| VK from the keyboard driver |#
+(defconstant VK_KANA		#x15)
+(defconstant VK_ROMAJI		#x16)
+(defconstant VK_ZENKAKU		#x17)
+(defconstant VK_HIRAGANA	#x18)
+(defconstant VK_KANJI		#x19)
+
+#| VK to send to Applications |#
+(defconstant VK_CONVERT		#x1C)
+(defconstant VK_NONCONVERT	#x1D)
+(defconstant VK_ACCEPT		#x1E)
+(defconstant VK_MODECHANGE	#x1F)
+
+#| Conversion function numbers |#
+(defconstant KNJ_START		#x01)
+(defconstant KNJ_END		#x02)
+(defconstant KNJ_QUERY		#x03)
+
+(defconstant KNJ_LEARN_MODE	#x10)
+(defconstant KNJ_GETMODE	#x11)
+(defconstant KNJ_SETMODE	#x12)
+
+(defconstant KNJ_CODECONVERT	#x20)
+(defconstant KNJ_CONVERT	#x21)
+(defconstant KNJ_NEXT		#x22)
+(defconstant KNJ_PREVIOUS	#x23)
+(defconstant KNJ_ACCEPT		#x24)
+
+(defconstant KNJ_LEARN		#x30)
+(defconstant KNJ_REGISTER	#x31)
+(defconstant KNJ_REMOVE		#x32)
+(defconstant KNJ_CHANGE_UDIC	#x33)
+
+#| note: DEFAULT= 0
+	JIS1	= 1
+	JIS2	= 2
+	SJIS2	= 3
+	JIS1KATAKANA	= 4
+	SJIS2HIRAGANA	= 5
+	SJIS2KATAKANA	= 6
+	OEM	= F
+|#
+
+(defconstant KNJ_JIS1toJIS1KATAKANA	#x14)
+(defconstant KNJ_JIS1toSJIS2		#x13)
+(defconstant KNJ_JIS1toSJIS2HIRAGANA	#x15)
+(defconstant KNJ_JIS1toSJIS2KATAKANA	#x16)
+(defconstant KNJ_JIS1toDEFAULT		#x10)
+(defconstant KNJ_JIS1toSJIS2OEM		#x1F)
+(defconstant KNJ_JIS2toSJIS2		#x23)
+(defconstant KNJ_SJIS2toJIS2		#x32)
+
+#| see KNJ_GETMODE for definition |#
+(defconstant KNJ_MD_ALPHA	#x01)
+(defconstant KNJ_MD_HIRAGANA	#x02)
+(defconstant KNJ_MD_HALF	#x04)
+(defconstant KNJ_MD_JIS		#x08)
+(defconstant KNJ_MD_SPECIAL	#x10)
+
+#| conversion modes, low word of lParam when VK_CONVERT is sent to the app |#
+(defconstant KNJ_CVT_NEXT	#x01)
+(defconstant KNJ_CVT_PREV	#x02)
+(defconstant KNJ_CVT_KATAKANA	#x03)
+(defconstant KNJ_CVT_HIRAGANA	#x04)
+(defconstant KNJ_CVT_JIS1	#x05)
+(defconstant KNJ_CVT_SJIS2	#x06)
+(defconstant KNJ_CVT_DEFAULT	#x07)
+(defconstant KNJ_CVT_TYPED	#x08)
+
+#| Conventional dialog box and message box command IDs |#
+(defconstant IDOK	1)
+(defconstant IDCANCEL	2)
+(defconstant IDABORT	3)
+(defconstant IDRETRY	4)
+(defconstant IDIGNORE	5)
+(defconstant IDYES	6)
+(defconstant IDNO	7)
+
+#| Control manager structures & definitions |#
+#| Edit control class stuff |#
+
+#| styles |#
+(defconstant ES_LEFT		0)
+(defconstant ES_CENTER		1)
+(defconstant ES_RIGHT		2)
+(defconstant ES_MULTILINE	4)
+(defconstant ES_AUTOVSCROLL	64)
+(defconstant ES_AUTOHSCROLL	128)
+(defconstant ES_NOHIDESEL	256)
+
+#| notification codes |#
+(defconstant EN_SETFOCUS	#x0100)
+(defconstant EN_KILLFOCUS	#x0200)
+(defconstant EN_CHANGE		#x0300)
+(defconstant EN_UPDATE		#x0400)
+(defconstant EN_ERRSPACE	#x0500)
+(defconstant EN_HSCROLL		#x0601)
+(defconstant EN_VSCROLL		#x0602)
+
+#| control messages: |#
+#| +++ Fix these!
+(defconstant EM_GETSEL		(WM_USER+0)
+(defconstant EM_SETSEL		(WM_USER+1)
+(defconstant EM_GETRECT		(WM_USER+2)
+(defconstant EM_SETRECT		(WM_USER+3)
+(defconstant EM_SETRECTNP	(WM_USER+4)
+(defconstant EM_SCROLL		(WM_USER+5)
+(defconstant EM_LINESCROLL	(WM_USER+6)
+(defconstant EM_GETMODIFY	(WM_USER+8)
+(defconstant EM_SETMODIFY	(WM_USER+9)
+(defconstant EM_GETLINECOUNT	(WM_USER+10)
+(defconstant EM_LINEINDEX	(WM_USER+11)
+(defconstant EM_SETHANDLE	(WM_USER+12)
+(defconstant EM_GETHANDLE	(WM_USER+13)
+(defconstant EM_GETTHUMB	(WM_USER+14)
+(defconstant EM_LINELENGTH	(WM_USER+17)
+(defconstant EM_REPLACESEL	(WM_USER+18)
+(defconstant EM_SETFONT		(WM_USER+19)
+(defconstant EM_GETLINE		(WM_USER+20)
+(defconstant EM_LIMITTEXT	(WM_USER+21)
+(defconstant EM_CANUNDO		(WM_USER+22)
+(defconstant EM_UNDO		(WM_USER+23)
+(defconstant EM_FMTLINES	(WM_USER+24)
+(defconstant EM_LINEFROMCHAR	(WM_USER+25)
+(defconstant EM_SETWORDBREAK	(WM_USER+26)
+|#
+
+#| button control styles |#
+(defconstant BS_PUSHBUTTON	0)
+(defconstant BS_DEFPUSHBUTTON	1)
+(defconstant BS_CHECKBOX	2)
+(defconstant BS_AUTOCHECKBOX	3)
+(defconstant BS_RADIOBUTTON	4)
+(defconstant BS_3STATE		5)
+(defconstant BS_AUTO3STATE	6)
+(defconstant BS_GROUPBOX	7)
+(defconstant BS_USERBUTTON	8)
+(defconstant BS_AUTORADIOBUTTON 9)
+(defconstant BS_PUSHBOX		10)
+(defconstant BS_LEFTTEXT	#x20)
+
+#| user button notification codes |#
+(defconstant BN_CLICKED		0)
+(defconstant BN_PAINT		1)
+(defconstant BN_HILITE		2)
+(defconstant BN_UNHILITE	3)
+(defconstant BN_DISABLE		4)
+(defconstant BN_DOUBLECLICKED	5)
+
+#| control messages |#
+#| +++ Fix these!
+(defconstant BM_GETCHECK	WM_USER+0)
+(defconstant BM_SETCHECK	WM_USER+1)
+(defconstant BM_GETSTATE	WM_USER+2)
+(defconstant BM_SETSTATE	WM_USER+3)
+(defconstant BM_SETSTYLE	WM_USER+4)
+|#
+
+#| Static control constants |#
+
+(defconstant SS_LEFT		0)
+(defconstant SS_CENTER		1)
+(defconstant SS_RIGHT		2)
+(defconstant SS_ICON		3)
+(defconstant SS_BLACKRECT	4)
+(defconstant SS_GRAYRECT	5)
+(defconstant SS_WHITERECT	6)
+(defconstant SS_BLACKFRAME	7)
+(defconstant SS_GRAYFRAME	8)
+(defconstant SS_WHITEFRAME	9)
+(defconstant SS_USERITEM	10)
+(defconstant SS_SIMPLE		11)
+(defconstant SS_NOPREFIX	128)	#| #x80 - don't do "&" character translation |#
+
+#| Dialog style bits |#
+(defconstant DS_ABSALIGN	#x000000001)
+(defconstant DS_SYSMODAL	#x000000002)
+(defconstant DS_LOCALEDIT	#x000000020)	#| Edit items get Local storage. |#
+
+#| +++ Fix these!
+(defconstant DM_GETDEFID (WM_USER+0)
+(defconstant DM_SETDEFID (WM_USER+1)
+|#
+(defconstant DC_HASDEFID #x534B)
+
+#| Dialog codes (returned by WM_GETDLGCODE message): |#
+
+(defconstant DLGC_WANTARROWS	#x01)	#| control wants arrow keys |#
+(defconstant DLGC_WANTTAB	#x02)	#| control wants tab keys |#
+(defconstant DLGC_WANTALLKEYS	#x04)	#| control wants all keys |#
+(defconstant DLGC_WANTMESSAGE	#x04)	#| pass message to control |#
+(defconstant DLGC_HASSETSEL	#x08)	#| understands EM_SETSEL message |#
+(defconstant DLGC_DEFPUSHBUTTON	#x10)	#| Default pushbutton |#
+(defconstant DLGC_UNDEFPUSHBUTTON #x20)	#| Non-default pushbutton |#
+(defconstant DLGC_RADIOBUTTON	#x40)	#| radio button |#
+(defconstant DLGC_WANTCHARS	#x80)	#| Want WM_CHAR messages |#
+(defconstant DLGC_STATIC	#x100)	#| Static item: don't include |#
+(defconstant DLGC_BUTTON	#x2000)	#| Button item: can be checked |#
+
+(defconstant LB_CTLCODE	0)
+
+#| Listbox control return values |#
+(defconstant LB_OKAY		0)
+(defconstant LB_ERR		-1)
+(defconstant LB_ERRSPACE	-2)
+
+#| listbox notification codes |#
+(defconstant LBN_ERRSPACE	-2)
+(defconstant LBN_SELCHANGE	1)
+(defconstant LBN_DBLCLK		2)
+
+#| listbox messages |#
+#| +++ Fix these!
+(defconstant LB_ADDSTRING	(1+WM_USER)
+(defconstant LB_INSERTSTRING	(2+WM_USER)
+(defconstant LB_DELETESTRING	(3+WM_USER)
+(defconstant LB_RESETCONTENT	(5+WM_USER)
+(defconstant LB_SETSEL		(6+WM_USER)
+(defconstant LB_SETCURSEL	(7+WM_USER)
+(defconstant LB_GETSEL		(8+WM_USER)
+(defconstant LB_GETCURSEL	(9+WM_USER)
+(defconstant LB_GETTEXT		(10+WM_USER)
+(defconstant LB_GETTEXTLEN	(11+WM_USER)
+(defconstant LB_GETCOUNT	(12+WM_USER)
+(defconstant LB_SELECTSTRING	(13+WM_USER)
+(defconstant LB_DIR		(14+WM_USER)
+(defconstant LB_GETTOPINDEX	(15+WM_USER)
+(defconstant LB_MSGMAX		(16+WM_USER)
+|#
+
+#| listbox style bits |#
+(defconstant LBS_NOTIFY		#x0001)
+(defconstant LBS_SORT		#x0002)
+(defconstant LBS_NOREDRAW	#x0004)
+(defconstant LBS_MULTIPLESEL	#x0008)
+(defconstant LBS_STANDARD	(logior LBS_NOTIFY LBS_SORT
+					WS_VSCROLL WS_BORDER))
+
+#| scroll bar styles |#
+(defconstant SBS_HORZ			#x0000)
+(defconstant SBS_VERT			#x0001)
+(defconstant SBS_TOPALIGN		#x0002)
+(defconstant SBS_LEFTALIGN		#x0002)
+(defconstant SBS_BOTTOMALIGN		#x0004)
+(defconstant SBS_RIGHTALIGN		#x0004)
+(defconstant SBS_SIZEBOXTOPLEFTALIGN	#x0002)
+(defconstant SBS_SIZEBOXBOTTOMRIGHTALIGN #x0004)
+(defconstant SBS_SIZEBOX		#x0008)
+
+#| constants used to specify return condition for WaitSoundState |#
+
+(defconstant S_QUEUEEMPTY	0)
+(defconstant S_THRESHOLD	1)
+(defconstant S_ALLTHRESHOLD	2)
+
+#| constants used to specify accent mode |#
+
+(defconstant S_NORMAL	0)
+(defconstant S_LEGATO	1)
+(defconstant S_STACCATO	2)
+
+#| constants used to specify source in SetSoundNoise |#
+(defconstant S_PERIOD512	0)	#| freq = N/512 high pitch, less coarse hiss |#
+(defconstant S_PERIOD1024	1)	#| freq = N/1024 |#
+(defconstant S_PERIOD2048	2)	#| freq = N/2048 low pitch, more coarse hiss |#
+(defconstant S_PERIODVOICE	3)	#| source is frequency from voice channel (3) |#
+
+(defconstant S_WHITE512		4)	#| freq = N/512 high pitch, less coarse hiss |#
+(defconstant S_WHITE1024	5)	#| freq = N/1024 |#
+(defconstant S_WHITE2048	6)	#| freq = N/2048 low pitch, more coarse hiss |#
+(defconstant S_WHITEVOICE	7)	#| source is frequency from voice channel (3) |#
+
+(defconstant S_SERDVNA	-1)	#| device not available |#
+(defconstant S_SEROFM	-2)	#| out of memory |#
+(defconstant S_SERMACT	-3)	#| music active |#
+(defconstant S_SERQFUL	-4)	#| queue full |#
+(defconstant S_SERBDNT	-5)	#| invalid note |#
+(defconstant S_SERDLN	-6)	#| invalid note length |#
+(defconstant S_SERDCC	-7)	#| invalid note count |#
+(defconstant S_SERDTP	-8)	#| invalid tempo |#
+(defconstant S_SERDVL	-9)	#| invalid volume |#
+(defconstant S_SERDMD	-10)	#| invalid mode |#
+(defconstant S_SERDSH	-11)	#| invalid shape |#
+(defconstant S_SERDPT	-12)	#| invalid pitch |#
+(defconstant S_SERDFQ	-13)	#| invalid frequency |#
+(defconstant S_SERDDR	-14)	#| invalid duration |#
+(defconstant S_SERDSR	-15)	#| invalid source |#
+(defconstant S_SERDST	-16)	#| invalid state |#
+
+
+#|
+**
+** dcb field definitions.
+**
+|#
+
+(defconstant NOPARITY	0)
+(defconstant ODDPARITY	1)
+(defconstant EVENPARITY	2)
+(defconstant MARKPARITY	3)
+(defconstant SPACEPARITY 4)
+
+(defconstant ONESTOPBIT		0)
+(defconstant ONE5STOPBITS	1)
+(defconstant TWOSTOPBITS	2)
+
+(defconstant IGNORE	0)	#| Ignore signal |#
+(defconstant INFINITE	#xFFFF)	#| Infinite timeout |#
+
+
+
+#|
+**
+** Comm Device Driver Error Bits.
+**
+|#
+
+(defconstant CE_RXOVER		#x0001)	#| Receive Queue overflow |#
+(defconstant CE_OVERRUN		#x0002)	#| Receive Overrun Error |#
+(defconstant CE_RXPARITY	#x0004)	#| Receive Parity Error |#
+(defconstant CE_FRAME		#x0008)	#| Receive Framing error |#
+(defconstant CE_BREAK		#x0010)	#| Break Detected |#
+(defconstant CE_CTSTO		#x0020)	#| CTS Timeout |#
+(defconstant CE_DSRTO		#x0040)	#| DSR Timeout |#
+(defconstant CE_RLSDTO		#x0080)	#| RLSD Timeout |#
+(defconstant CE_TXFULL		#x0100)	#| TX Queue is full |#
+(defconstant CE_PTO		#x0200)	#| LPTx Timeout |#
+(defconstant CE_IOE		#x0400)	#| LPTx I/O Error |#
+(defconstant CE_DNS		#x0800)	#| LPTx Device not selected |#
+(defconstant CE_OOP		#x1000)	#| LPTx Out-Of-Paper |#
+(defconstant CE_MODE		#x8000)	#| Requested mode unsupported |#
+
+
+#|************************************************************************
+**
+** Initialization Error Codes
+**
+************************************************************************|#
+
+(defconstant IE_BADID		-1)	#| Invalid or unsupported id |#
+(defconstant IE_OPEN		-2)	#| Device Already Open |#
+(defconstant IE_NOPEN		-3)	#| Device Not Open |#
+(defconstant IE_MEMORY		-4)	#| Unable to allocate queues |#
+(defconstant IE_DEFAULT		-5)	#| Error in default parameters |#
+(defconstant IE_HARDWARE	-10)	#| Hardware Not Present |#
+(defconstant IE_BYTESIZE	-11)	#| Illegal Byte Size |#
+(defconstant IE_BAUDRATE	-12)	#| Unsupported BaudRate |#
+
+
+#|************************************************************************
+**
+** Event Definitions
+**
+************************************************************************|#
+
+(defconstant EV_RXCHAR	#x0001)	#| Any Character received |#
+(defconstant EV_RXFLAG	#x0002)	#| Received certain character |#
+(defconstant EV_TXEMPTY	#x0004)	#| Transmitt Queue Empty |#
+(defconstant EV_CTS	#x0008)	#| CTS changed state |#
+(defconstant EV_DSR	#x0010)	#| DSR changed state |#
+(defconstant EV_RLSD	#x0020)	#| RLSD changed state |#
+(defconstant EV_BREAK	#x0040)	#| BREAK received |#
+(defconstant EV_ERR	#x0080)	#| Line status error occurred |#
+(defconstant EV_RING	#x0100)	#| Ring signal detected |#
+(defconstant EV_PERR	#x0200)	#| Printer error occured |#
+
+
+#|************************************************************************
+**
+** Escape Functions
+**
+************************************************************************|#
+
+(defconstant SETXOFF	1)	#| Simulate XOFF received |#
+(defconstant SETXON	2)	#| Simulate XON received |#
+(defconstant SETRTS	3)	#| Set RTS high |#
+(defconstant CLRRTS	4)	#| Set RTS low |#
+(defconstant SETDTR	5)	#| Set DTR high |#
+(defconstant CLRDTR	6)	#| Set DTR low |#
+(defconstant RESETDEV	7)	#| Reset device if possible |#
+||#
diff --git a/pre-silica/window-protocol.lisp b/pre-silica/window-protocol.lisp
new file mode 100644
index 00000000..2d074130
--- /dev/null
+++ b/pre-silica/window-protocol.lisp
@@ -0,0 +1,500 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: window-protocol.lisp,v 1.7 91/03/29 18:01:14 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; So we don't process operations twice, once when *we* process it,
+;;; again when the implementation layer says "Hey, guess what?"
+(defvar *synchronous-window-operation-being-processed* nil)
+
+(define-stream-protocol-class window ())
+
+#-Silica
+(progn
+
+(defclass window-mixin
+	  (standard-bounding-rectangle window)
+     ((parent :accessor window-parent :initarg :parent)
+      (children :accessor window-children :initform nil)
+      ;; --- better term than console?
+      (console :accessor window-console :initarg :console)
+      (name :accessor window-name :initarg :name)
+      (label :accessor window-label :initarg :label)
+      (depth :accessor window-depth :initarg :depth)	;is this bits-per-pixel?
+      (viewport :accessor window-viewport :initarg :viewport)
+      (update-region :accessor window-update-region :initform nil)
+      (visibility :accessor window-visibility :initform nil)
+      #+Ignore
+      (input-process :accessor window-input-process)
+      (inside-width-cache :initform nil))
+  (:default-initargs :parent nil :console nil :name nil :label nil))
+
+;; Prevent using the instance-ref instructions on these, since they
+;; usually have :BEFORE/:AFTER qualifiers on the SETF methods that will
+;; cause the instance-ref instructions to take a slow trap.
+#+(or Genera Minima)
+(progn
+  (declaim (notinline window-label      (setf window-label)))
+  (declaim (notinline window-visibility (setf window-visibility))))
+
+;;; Runs :AROUND so that edges will be set up by primary method and :AFTER method
+;;; for the specific implementation.
+(defmethod initialize-instance :around ((window window-mixin)
+					&key parent scroll-bars borders)
+  ;; All ports accept these standard window decoration options
+  ;; Accept them here for the benefit of warn-if-pane-descriptions-invalid
+  scroll-bars borders  ;ignored, declare ignore doesn't work here
+  (call-next-method)
+  (when parent
+    (push window (window-children parent)))
+  (with-slots (viewport left top right bottom) window
+    ;; Make initial viewport the same size as the window rooted at the origin.
+    ;; (window edges are in parent's coordinate system, while viewport edges are in window's)
+
+    ;; --- Is this right?  At least it works...
+    (multiple-value-bind (width height) (window-inside-size window)
+      (setf viewport (make-bounding-rectangle 0 0 width height))
+      ; --- cross protocol violation, but we're moving to Silica anyway
+      (when (extended-output-stream-p window)
+	(setf (stream-default-text-margin window)
+	      width)))))
+
+;;; WINDOW-ERASE-VIEWPORT req'd
+;;; WINDOW-STACK-ON-TOP req'd
+;;; WINDOW-STACK-ON-BOTTOM req'd
+;;; COPY-AREA req'd
+
+(defmethod window-refresh :around ((stream window-mixin))
+  (when (window-drawing-possible stream)
+    (call-next-method)))
+
+(defmethod window-stream-stack-on-top :around ((window window-mixin))
+  (let ((*synchronous-window-operation-being-processed* t))
+    (call-next-method)))
+
+(defmethod bounding-rectangle-set-edges :around ((window window-mixin) left top right bottom)
+  (declare (ignore left top right bottom))
+  (let ((*synchronous-window-operation-being-processed* T))
+    (call-next-method)))
+
+(defmethod bounding-rectangle-set-position* :around ((window window-mixin) nx ny)
+  (declare (ignore nx ny))
+  (let ((*synchronous-window-operation-being-processed* t))
+    (call-next-method)))
+
+(defmethod bounding-rectangle-set-size :around ((window window-mixin) width height)
+  (declare (ignore width height))
+  (let ((*synchronous-window-operation-being-processed* t))
+    (call-next-method)))
+
+;;; These methods are needed for hooks on other mixins to work.
+(defmethod window-viewport-position* ((window window-mixin))
+  (with-slots (viewport) window
+    (bounding-rectangle-position* viewport)))
+
+(defmethod window-set-viewport-position* ((window window-mixin) x y)
+  (with-slots (viewport) window
+    (bounding-rectangle-set-position* viewport x y)))
+
+(defmethod window-with-zero-viewport-position
+	   ((window window-mixin) continuation)
+  ;;--- should be on window-and-graphics-intermediary??
+  ;; Margin components should not respect the stream transform
+  (letf-globally (((medium-transformation window) +identity-transformation+))
+    (let ((viewport (window-viewport window)))
+      (multiple-value-bind (x y) (bounding-rectangle-position* viewport)
+	(unwind-protect
+	    (progn (bounding-rectangle-set-position* viewport 0 0)
+		   (funcall continuation))
+	  (bounding-rectangle-set-position* viewport x y))))))
+
+)	;#-Silica
+
+(defmethod window-clear ((window #-Silica window-mixin #+Silica t))
+  #-Silica
+  (window-erase-viewport window)
+  (when (extended-output-stream-p window)	;can we assume this?
+    (stream-set-cursor-position* window 0 0)
+    (setf (stream-baseline window) 0
+	  (stream-current-line-height window) 0))
+  #-Silica
+  (bounding-rectangle-set-position* (window-viewport window) 0 0)
+  #+Ignore
+  (window-set-viewport-position* window 0 0))
+
+;;; Basically a hook for other mixins.
+(defmethod window-refresh ((window #-Silica window-mixin #+Silica t))
+  (window-erase-viewport window))
+
+(defmethod window-expose ((window #-Silica window-mixin #+Silica t))
+  (setf (window-visibility window) t)
+  #-Silica
+  (window-stack-on-top window))
+
+
+;;; --- This needs to be on window-output...
+;(defmethod window-fresh-page ((stream window-mixin))
+;  (multiple-value-call #'window-set-viewport-position*
+;		       window
+;		       (window-stream-cursor-position* stream)))
+;
+
+(defun window-size-viewport-to-fit (window)
+  (multiple-value-bind (w h) (window-inside-size window)
+    (multiple-value-bind (lm rm tm bm) (window-margins window)
+      (declare (ignore lm tm))
+      (bounding-rectangle-set-size (window-viewport window) (- w rm) (- h bm)))))
+
+
+;;; Coordinate translations
+
+#-Silica
+(progn
+
+;;;--- FIXNUM stuff
+
+;;; The true interfaces: 
+;;; WINDOW-TO-SCREEN-COORDINATES Window-X Window-Y -> Screen-X Screen-Y
+(defmethod window-to-screen-coordinates ((window window-mixin) x y)
+  (declare (type coordinate x y))
+  (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window)
+    (declare (type coordinate dx dy))
+    (values (the fixnum (+ x dx)) (the fixnum (+ y dy)))))
+
+(defmethod screen-to-window-coordinates ((window window-mixin) x y)
+  (declare (type coordinate x y))
+  (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window)
+    (declare (type coordinate dx dy))
+    (values (the fixnum (- x dx)) (the fixnum (- y dy)))))
+	   
+;;; An internal routine
+(defmethod window-to-screen-coordinate-translations ((window window-mixin))
+  (with-slots (left top viewport parent) window
+    (declare (fixnum left top))
+    (multiple-value-bind (left-translation top-translation) (window-margins window)
+      (declare (fixnum left-translation top-translation))
+      (setq left-translation (the fixnum (+ left-translation left)))
+      (setq top-translation (the fixnum (+ top-translation top)))
+      (when parent
+	(multiple-value-bind (parent-left parent-top)
+	    (window-to-screen-coordinate-translations parent)
+	  (declare (fixnum parent-left parent-top))
+	  (setq left-translation (the fixnum (+ left-translation parent-left)))
+	  (setq top-translation (the fixnum (+ top-translation parent-top)))))
+      (when viewport
+	(multiple-value-bind (viewport-left viewport-top)
+	    (bounding-rectangle-position* viewport)
+	  (declare (fixnum viewport-left viewport-top))
+	  (setq left-translation (the fixnum (- left-translation viewport-left)))
+	  (setq top-translation (the fixnum (- top-translation viewport-top)))))
+      (values left-translation top-translation))))
+
+(defmethod drawing-surface-to-viewport-coordinates ((window window-mixin) dsx dsy)
+  (declare (fixnum dsx dsy))
+  (multiple-value-bind (vx vy) (window-viewport-position* window)
+    (declare (fixnum vx vy))
+    (multiple-value-bind (ml mt) (window-margins window)
+      (declare (fixnum ml mt))
+      (values (the fixnum (+ (the fixnum (- dsx vx)) ml))
+	      (the fixnum (+ (the fixnum (- dsy vy)) mt))))))
+
+(defmethod viewport-to-drawing-surface-coordinates ((window window-mixin) x y)
+  (declare (fixnum x y))
+  (multiple-value-bind (vx vy) (window-viewport-position* window)
+    (declare (fixnum vx vy))
+    (multiple-value-bind (ml mt) (window-margins window)
+      (declare (fixnum ml mt))
+      (values (the fixnum (- (the fixnum (+ x vx)) ml))
+	      (the fixnum (- (the fixnum (+ y vy)) mt))))))
+
+)	;#-Silica
+
+#-Silica
+(progn
+
+;;;--- FIXNUM stuff
+;;; Hmm.
+(defmethod bounding-rectangle-set-edges :after ((window window-mixin) left top right bottom)
+  (declare (ignore left top right bottom))
+  (window-size-viewport-to-fit window)
+  (setf (slot-value window 'inside-width-cache) nil))
+
+(defmethod bounding-rectangle-set-size :after ((window window-mixin) width height)
+  (declare (ignore width height))
+  (window-size-viewport-to-fit window)
+  (setf (slot-value window 'inside-width-cache) nil))
+
+(defmethod window-inside-size ((window window-mixin))
+  (multiple-value-bind (left top right bottom) (window-inside-edges window)
+    (declare (fixnum left top right bottom))
+    (values (the fixnum (- right left)) (the fixnum (- bottom top)))))
+
+(defmethod window-inside-edges ((stream window-mixin))
+  (multiple-value-bind (lm tm rm bm) (host-window-margins stream)
+    (declare (fixnum lm tm rm bm))
+    (with-bounding-rectangle* (left top right bottom) stream
+      (values (the fixnum (+ left lm))  (the fixnum (+ top tm))
+	      (the fixnum (- right rm)) (the fixnum (- bottom bm))))))
+
+(defmethod window-set-inside-edges ((stream window-mixin) 
+				    new-left new-top new-right new-bottom)
+  (declare (fixnum new-left new-top new-right new-bottom))
+  (multiple-value-bind (lm tm rm bm) (host-window-margins stream)
+    (declare (fixnum lm tm rm bm))
+    (bounding-rectangle-set-edges
+      stream
+      (the fixnum (- new-left lm))  (the fixnum (- new-top tm))
+      (the fixnum (+ new-right rm)) (the fixnum (+ new-bottom bm)))))
+
+;; the port needs to define host-window-margins
+
+(defmethod window-set-inside-size ((window window-mixin) new-width new-height)
+  (multiple-value-bind (left top) (window-inside-edges window)
+    (window-set-inside-edges window left top (+ left new-width) (+ top new-height))))
+
+(defmacro define-window-inside-methods (useless &aux code)
+  (labels ((emit-methods (vars primitive)
+	     (do* ((i 0 (1+ i))
+		   (names vars (cdr names)))
+		  ((null names))
+	       (emit-method (method-name (car names) 'window-inside) i vars primitive)))
+	   (method-name (name prefix) (fintern "~A-~A" prefix name))
+	   (emit-method (name nth-value vars called-method)
+	     (push `(defmethod ,name ((window window-mixin))
+		      ,(if (= nth-value 0) `(values (,called-method window))
+			   `(multiple-value-bind ,(subseq vars 0 (1+ nth-value))
+				(,called-method window)
+			      (declare (ignore ,@(subseq vars 0 nth-value)))
+			      ,(nth nth-value vars))))
+		   code)))
+    (emit-methods '(left top right bottom) 'window-inside-edges)
+    (emit-methods '(width height) 'window-inside-size))
+  `(define-group ,useless define-window-inside-methods ,@(nreverse code)))
+
+(define-window-inside-methods methods)
+
+(defmethod window-inside-width :around ((window window-mixin))
+   (with-slots (inside-width-cache) window
+     (or inside-width-cache
+	 (setf inside-width-cache (call-next-method)))))
+
+)	;#-Silica
+
+#+Genera
+(defgeneric stream-compatible-inside-size (window)
+  (:selector :inside-size))
+
+#+Genera
+(defmethod stream-compatible-inside-size ((window window-mixin))
+  (bounding-rectangle-size (window-viewport window)))
+
+#+Genera
+(defgeneric stream-compatible-visible-cursorpos-limits (window &optional unit)
+  (:selector :visible-cursorpos-limits))
+
+#+Genera
+(defmethod stream-compatible-visible-cursorpos-limits ((window window-mixin)
+						       &optional (unit ':pixel))
+  (with-bounding-rectangle* (left top right bottom) (window-viewport window)
+    (ecase unit
+      (:pixel (values left top right bottom))
+      (:character (let ((char-width (stream-character-width window #\M))
+			(line-height (stream-line-height window)))
+		    (values (floor left char-width) (floor top line-height)
+			    (floor right char-width) (floor bottom line-height)))))))
+
+#+Genera
+(defgeneric stream-compatible-size-in-characters (window)
+  (:selector :size-in-characters))
+
+#+Genera
+(defmethod stream-compatible-size-in-characters ((window window-mixin))
+  (with-bounding-rectangle* (left top right bottom) (window-viewport window)
+    (let ((char-width (stream-character-width window #\M))
+	  (line-height (stream-line-height window)))
+      (values (floor (- right left) char-width)
+	      (floor (- bottom top) line-height)))))
+
+#-Silica
+(progn
+
+(defmethod window-label-size ((window window-mixin) &optional (label (window-label window)))
+  (declare (ignore label))
+  ;; default method returns nothing.
+  (values 0 0))
+
+(defmethod window-note-size-or-position-change ((window window-mixin)
+						new-left new-top new-right new-bottom)
+  ;;
+  (with-slots (left top right bottom) window
+    (setf left new-left)
+    (setf top new-top)
+    (setf right new-right)
+    (setf bottom new-bottom))
+  ;; for the time being, make the viewport fill the window
+  (window-size-viewport-to-fit window))
+
+;;;--- FIXNUM stuff
+
+;;; Offset from root
+(defun window-offset (stream)
+  (let ((x-offset 0)
+	(y-offset 0))
+    (declare (fixnum x-offset y-offset))
+    (do ((s stream (window-parent s)))
+	((null s) nil)
+      (multiple-value-bind (x y) (bounding-rectangle-position* s)
+	(declare (fixnum x y))
+	(multiple-value-bind (ml mt) (host-window-margins s)
+	  (declare (fixnum ml mt))
+	  (setq x-offset (the fixnum (+ x-offset x ml)))
+	  (setq y-offset (the fixnum (+ y-offset y mt))))))
+    (values x-offset y-offset)))
+
+)	;#-Silica
+
+;; This is called by OUTPUT-RECORDING-MIXIN's whopper on set-viewport-position*.
+;; It shifts a region of the "host screen" that's visible to some other visible
+;; location.  It does NOT do any cleaning up after itself.  It does not side-effect
+;; the output history of the window.  It calls COPY-AREA whose contract is to 
+;; do the above, the whole above, and nothing but the above.
+(defmethod window-shift-visible-region ((window #-Silica window-mixin #+Silica t)
+					old-left old-top old-right old-bottom
+					new-left new-top new-right new-bottom)
+  (declare (type coordinate new-left new-top new-right new-bottom))
+  (declare (ignore old-right old-bottom new-right new-bottom))
+  (let ((delta-x (- old-left new-left))
+	(delta-y (- old-top new-top)))
+    (multiple-value-bind (stream-width stream-height)
+	#-Silica (window-inside-size window)
+	#+Silica (bounding-rectangle-size (pane-viewport-region window))
+      (declare (type coordinate stream-width stream-height))
+      (let (from-x from-y)
+	(cond ((and (>= delta-x 0)
+		    (>= delta-y 0))
+	       ;; shifting down and to the right
+	       (setq from-x 0
+		     from-y 0))
+	      ((and (>= delta-x 0)
+		    (<= delta-y 0))
+	       ;; shifting up and to the right
+	       (setq from-x 0
+		     from-y (abs delta-y)))
+	      ((>= delta-y 0)
+	       ;; shifting down and to the left
+	       (setq from-x (abs delta-x)
+		     from-y 0))
+	      (t
+	       ;; shifting up and to the left
+	       (setq from-x (abs delta-x)
+		     from-y (abs delta-y))))
+	(let ((width (- stream-width (abs delta-x)))
+	      (height (- stream-height (abs delta-y))))
+	  (multiple-value-bind (ml mt) 
+	      #+Silica (values 0 0)
+	      #-Silica (window-margins window)
+	    (declare (type coordinate ml mt))
+	    (translate-fixnum-positions ml mt from-x from-y)
+	    (copy-area window
+		       from-x from-y
+		       (+ from-x width) (+ from-y height)
+		       (+ from-x delta-x) (+ from-y delta-y))))))))
+
+
+#+Silica
+(defun window-viewport-position* (stream)
+  (bounding-rectangle-position* (pane-viewport-region stream)))
+
+#+Silica
+(defun window-set-viewport-position* (stream x y)
+  (scroll-extent stream :x x :y y))
+
+
+
+
+#+Silica
+(defun-inline window-parent (window)
+  (sheet-parent window))
+
+(defun window-root (window)
+  (do ((win window (window-parent win)))
+      ((null (window-parent win))
+       win)))
+
+(defun window-top-level-window (window)
+  (do* ((win window parent)
+	(parent (window-parent win) parent-parent)
+	(parent-parent (if parent (window-parent parent) T) (window-parent parent)))
+       ((null parent-parent) win)
+    (when (eql parent-parent T) (return nil))))
+
+#-Silica
+(progn
+
+;;; Make sure cursor is always visible.
+(defmethod stream-advance-cursor-line :after ((stream output-and-window-protocol-intermediary))
+  (stream-ensure-cursor-visible stream))
+
+(defmethod stream-set-cursor-position* :after ((stream output-and-window-protocol-intermediary)
+					      new-x new-y)
+  (stream-ensure-cursor-visible stream new-x new-y))
+
+(defmethod stream-set-cursor-position*-internal :after
+	   ((stream output-and-window-protocol-intermediary) new-x new-y)
+  (stream-ensure-cursor-visible stream new-x new-y))
+
+(defmethod stream-ensure-cursor-visible ((stream output-and-window-protocol-intermediary)
+					 &optional cx cy)
+  (when (or (not (output-recording-stream-p stream))
+	    (stream-drawing-p stream))
+    (unless cy (multiple-value-setq (cx cy) (stream-cursor-position* stream)))
+    (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream)
+      (let ((new-x nil)
+	    (new-y nil))
+	;; Vertical case
+	(unless (eql (stream-end-of-page-action stream) ':allow)
+	  (incf cy (min (- vbottom vtop)
+			(* 2 (stream-line-height stream))))
+	  (unless (<= vtop cy vbottom)
+	    (setf new-y (max 0 (- cy (- vbottom vtop))))))
+	;; Horizontal case
+	(unless (eql (stream-end-of-line-action stream) ':allow)
+	  (unless (<= vleft cx vright)
+	    (setf new-x (max 0 (- cx (- vright vleft 
+					(* 4 (stream-character-width stream #\W))))))))
+	(when (or new-x new-y)
+	  (window-set-viewport-position* stream (or new-x vleft) (or new-y vtop)))))))
+
+)	;#-Silica
+
+;;; rudimentary audio
+
+#-Silica
+(progn
+
+(defmethod window-beep ((stream t))
+  #+Genera (scl:beep)
+  #+CCL-2 (ccl::ed-beep)
+  nil)
+
+(defun beep (&optional (stream *standard-output*))
+  (window-beep stream))
+
+(defun whistle (&key (direction ':down))
+  #-Genera (declare (ignore direction))
+  #+Genera (compiler:inhibit-style-warnings (dbg:whistle :direction direction))
+  #-Genera (dotimes (i 3) (beep)))
+
+)	;#-Silica
+
+#+Silica
+(defun beep (&optional (stream *standard-output*))
+  (silica::sheet-beep stream))
+
+
+(defun window-inside-size (w)
+  (bounding-rectangle-size (pane-viewport-region w)))
diff --git a/pre-silica/windows.lisp b/pre-silica/windows.lisp
new file mode 100644
index 00000000..94121a5b
--- /dev/null
+++ b/pre-silica/windows.lisp
@@ -0,0 +1,1334 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: windows.lisp,v 1.4 91/03/26 12:49:09 cer Exp $
+
+(in-package :win)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+(export '(START-WINDOWS))
+;;; Buffer commands (MUST BE KEPT CONSISTENT WITH VMWIN.H!)
+
+;;; Takes a one byte argument and sets the state.  This command is currently
+;;; only processed by the windows side
+(defconstant *VM-BCOM-SET-STATE* #x01)
+(defconstant *VM-STATE-INITIALIZED* #x01)
+(defconstant *VM-STATE-INPUT-WAIT* #x02)
+(defconstant *VM-STATE-RUN* #x03)
+(defconstant *VM-STATE-STOP* #x04)
+(defconstant *VM-STATE-BREAK* #x05)
+
+;;; Sends 2 byte wParam from windows message, which is the character code.
+;;; When sent to windows, 2 byte character to output
+(defconstant *VM-BCOM-CHARACTER* #x02)
+
+;;; Get ready to received menu items.  No args.
+(defconstant *VM-BCOM-START-MENU* #x03)
+
+;;; Add a menu item.  Bytes are a null-terminated string.
+(defconstant *VM-BCOM-MENU-ITEM* #x04)
+
+;;; Expose and get a selection from the menu
+(defconstant *VM-BCOM-MENU-CHOOSE* #x05)
+
+;;; Returned to VM.  The menu item number selected in first byte, second
+;;; byte 0 if single or 1 if double click
+(defconstant *VM-BCOM-MENU-SELECTION* #x06)
+
+(defconstant *VM-BCOM-MENU-CAPTION* #x07)
+
+;;; Get pathname from user, blocks until response is generated
+(defconstant *VM-BCOM-GET-PATHNAME* #x08)
+
+;;; Draws a line, 4 16 bit args are X0, Y0, X1, Y1
+(defconstant *VM-BCOM-DRAW-LINE* #x09)
+
+;;; Draws a character at a particular point, args are char, X, Y
+(defconstant *VM-BCOM-DRAW-CHAR* #x0A)
+
+;;; Returned to VM: A two-byte short window handle (HWND)
+(defconstant *VM-BCOM-WINDOW-VALUE* #x0B)
+
+;;; Returned to VM: A two-byte short device context handle (HDC)
+(defconstant *VM-BCOM-DC-VALUE* #x0C)
+
+;;; Returned to VM: A two-byte short handle (HANDLE)
+(defconstant *VM-BCOM-HANDLE-VALUE* #x0D)
+
+;;; Returned to VM: A many-byte text metric structure
+(defconstant *VM-BCOM-METRIC-VALUE* #x0E)
+
+;;; Returned to VM: An eight-byte rectangle structure
+(defconstant *VM-BCOM-RECT-VALUE* #x0F)
+
+;;; Messages below are generic interface functions.
+;;; The functions that interpret them are in winfe.c.
+(defconstant *VM-BCOM-MOVE-TO* #x10)
+(defconstant *VM-BCOM-LINE-TO* #x11)
+(defconstant *VM-BCOM-TEXT-OUT* #x12)
+(defconstant *VM-BCOM-ELLIPSE* #x13)
+(defconstant *VM-BCOM-CREATE-WINDOW* #x14)
+(defconstant *VM-BCOM-SHOW-WINDOW* #x15)
+(defconstant *VM-BCOM-DESTROY-WINDOW* #x16)
+(defconstant *VM-BCOM-SCROLL-DC* #x17)
+(defconstant *VM-BCOM-GET-DC* #x18)
+(defconstant *VM-BCOM-RELEASE-DC* #x19)
+(defconstant *VM-BCOM-ARC* #x1A)
+(defconstant *VM-BCOM-CREATE-PEN* #x1B)
+(defconstant *VM-BCOM-CREATE-SOLID-BRUSH* #x1C)
+(defconstant *VM-BCOM-CREATE-PATTERN-BRUSH* #x1D)
+(defconstant *VM-BCOM-SET-BRUSH-ORG* #x1E)
+(defconstant *VM-BCOM-GET-STOCK-OBJECT* #x1F)
+(defconstant *VM-BCOM-SELECT-OBJECT* #x20)
+(defconstant *VM-BCOM-GET-TERM-WINDOW* #x21)
+(defconstant *VM-BCOM-BEGIN-PAINT* #x22)
+(defconstant *VM-BCOM-END-PAINT* #x23)
+(defconstant *VM-BCOM-STRING-ARG* #x24)
+(defconstant *VM-BCOM-PIE* #x25)
+(defconstant *VM-BCOM-RECTANGLE* #x26)
+(defconstant *VM-BCOM-DELETE-OBJECT* #x27)
+(defconstant *VM-BCOM-GET-ROP2* #x28)
+(defconstant *VM-BCOM-SET-ROP2* #x29)
+(defconstant *VM-BCOM-POLYGON* #x2A)
+(defconstant *VM-BCOM-VANILLA-EVENT* #x2B)
+(defconstant *VM-BCOM-SET-FOCUS* #x2C)
+(defconstant *VM-BCOM-MOVE-WINDOW* #x2D)
+(defconstant *VM-BCOM-CREATE-BITMAP* #x2E)
+(defconstant *VM-BCOM-CREATE-FONT* #x2F)
+(defconstant *VM-BCOM-GET-TEXT-METRICS* #x30)
+(defconstant *VM-BCOM-WINDOW-FROM-POINT* #x31)
+(defconstant *VM-BCOM-GET-UPDATE-RECT* #x32)
+(defconstant *VM-BCOM-PAINT-EVENT* #x33)
+(defconstant *VM-BCOM-SELECT-BRUSH* #x34)
+(defconstant *VM-BCOM-SELECT-PEN* #x35)
+(defconstant *VM-BCOM-SELECT-BITMAP* #x36)
+(defconstant *VM-BCOM-SELECT-FONT* #x37)
+(defconstant *VM-BCOM-SELECT-REGION* #x38)
+(defconstant *VM-BCOM-SET-TEXT-COLOR* #x39)
+(defconstant *VM-BCOM-BEEP* #x3A)
+(defconstant *VM-BCOM-SET-SCROLL-POSITION* #x3B)
+(defconstant *VM-BCOM-SET-BACKGROUND-COLOR* #x3C)
+(defconstant *VM-BCOM-GET-CLIENT-RECTANGLE* #x3D)
+(defconstant *VM-BCOM-GET-TEXT-EXTENT* #x3E)
+(defconstant *VM-BCOM-CREATE-FONT-INDIRECT* #x3F)
+(defconstant *VM-BCOM-SET-ERASE-BRUSH* #x40)
+(defconstant *VM-BCOM-GET-SCREEN-SIZE* #x41)
+(defconstant *VM-BCOM-SCREEN-SIZE* #x42)
+(defconstant *VM-BCOM-DRAW-BITMAP* #x43)
+(defconstant *VM-BCOM-SET-POINTER-POS* #x44)
+(defconstant *VM-BCOM-GET-POINTER-POS* #x45)
+(defconstant *VM-BCOM-POINTER-POSITION* #x45)
+(defconstant *VM-BCOM-READ-BITMAP* #x46)
+(defconstant *VM-BCOM-LOADCURSOR* #x47)
+(defconstant *VM-BCOM-SET-MOUSE-CURSOR* #x48)
+(defconstant *VM-BCOM-SET-WINDOW-TEXT* #x49)
+(defconstant *VM-BCOM-SET-WINDOW-POS* #x4A)
+(defconstant *VM-BCOM-IS-ICONIC* #x4B)
+(defconstant *VM-BCOM-GET-WINDOW-RECTANGLE* #x4C)
+(defconstant *VM-BCOM-SHOW-SCROLL-BAR* #x4D)
+(defconstant *VM-BCOM-POLYLINE* #x4E)
+(defconstant *VM-BCOM-NOTIFY-USER* #x4F)
+(defconstant *VM-BCOM-IS-WINDOW-VISIBLE* #x50)
+(defconstant *VM-BCOM-WINDOW-EXEC* #x51)
+(defconstant *VM-BCOM-CHANGE-DIR* #x52)
+(defconstant *VM-BCOM-GET-FOCUS* #x53)
+(defconstant *VM-BCOM-SHOW-CARET* #x54)
+(defconstant *VM-BCOM-SET-CARET-POS* #x55)
+(defconstant *VM-BCOM-HIDE-CARET* #x56)
+(defconstant *VM-BCOM-LOAD-BITMAP* #x57)
+(defconstant *VM-BCOM-NONCLIENT-PAINT* #x59)
+
+;;; Unique ID: sets the unique ID for the next command that requests a
+;;; return value, or the return unique ID.  A UID is one byte.
+(defconstant *VM-BCOM-UID* #xFC)
+
+;;; Special long message operator
+(defconstant *VM-BCOM-LONG-MESSAGE* #xFD)
+
+;;; General cancellation
+(defconstant *VM-BCOM-CANCEL* #xFE)
+
+;;; No message available now
+(defconstant *VM-BCOM-NULL* #xFF)
+
+
+(defvar *windows-enabled* nil)
+(defvar *stream*)
+(defvar *old-terminal-io*)
+(defvar *win2-com* nil)
+(defvar *win3-com* nil)
+(defvar *winfe-exe* "winfe.exe") ; "\\clim\\winfe.exe"
+(defvar *win-com-file* "WIN.COM")
+(defvar *win-cloe-file* "CLOEWIN.COM")
+
+(defvar *windows-standard-mode* t)
+(defvar *standard-stub* "STDSTUB.EXE")
+
+(defvar *win-3-binary* '#x(EB 09 58 57 00 00 00 00
+			   00 00 00 E8 71 06 BB 3C))
+
+;;; Patches to WIN.COM V3.  Must be in numerical order by offset.
+(defvar *win-3-patches* '#x((8C4 5D 00) (8E6 40 01)))
+
+;;; Find the windows .COM file in the specified directory.  If it's
+;;; a Windows 3 .COM and not converted for CLOE, do the conversion.
+(defun find-windows-com-1 (dir)
+  (setf dir (concatenate 'string dir "\\"))
+  (let ((cloe-pn (merge-pathnames dir *win-cloe-file*))
+        (win-pn (merge-pathnames dir *win-com-file*)))
+    ;; First try for the converted file
+    (when (probe-file cloe-pn) 
+      (return-from find-windows-com-1
+	(values (namestring cloe-pn) t t)))
+    (unless (probe-file win-pn)
+      (return-from find-windows-com-1 nil))
+    (with-open-file (win-com win-pn :direction :input 
+    				    :element-type '(unsigned-byte 8))
+      (when win-com
+        (let ((first-bytes (loop repeat 16 collect (read-byte win-com))))
+	  (cond ((not (equal first-bytes *win-3-binary*))
+	  	 (return-from find-windows-com-1 
+		   (namestring win-pn) nil nil))
+		(t
+		 ;; Have a windows 3 .COM, patch it
+		 (with-open-file (cloe-com cloe-pn :direction :output
+		 	          :element-type '(unsigned-byte 8))
+		   (dolist (n first-bytes) (write-byte n cloe-com))
+		   (format t "~&Creating ~A..." (namestring cloe-pn))
+		   (loop with patches = *win-3-patches*
+		   	 for n = (read-byte win-com nil nil)
+		         for idx from 16
+		         until (null n)
+			 when (neq idx (first (first patches)))
+			 do (write-byte n cloe-com)
+			 else 
+			 do (when (not (= n (second (first patches))))
+			      (error "Value to be patched at ~X is wrong: is ~X, expected ~X"
+			      	     idx n (second (first patches))))
+			    (write-byte (third (first patches)) cloe-com)
+			    (pop patches)))
+    		 (format t "done~%")
+                 (values (namestring cloe-pn) t t))))))))
+
+;;; Find the windows WIN.COM file by searching PATH
+(defun find-windows-com ()
+  (cond (*win2-com* (values *win-com* nil nil))
+        (*win3-com* (values *win3-com* t nil))
+        (t
+	 (flet ((check (dir)
+		  (declare (sys:downward-function))
+		  (multiple-value-bind (com win3-p cloe-p)
+		      (find-windows-com-1 dir)
+		    (when com
+		      (return-from find-windows-com
+			(values com win3-p cloe-p))))))
+	   (check ".")
+	   (map-over-path #'check)
+	   (check "\\WINDOWS")
+	   (error "Cannot find windows .COM file")))))
+
+(defun find-winfe-exe ()
+  (cond ((position #\\ *winfe-exe*)
+	 (let ((path (merge-pathnames *winfe-exe*)))
+	   (when (probe-file path)
+	     (return-from find-winfe-exe (namestring path)))))
+	(t
+	 (map-over-path
+	   #'(lambda (dir)
+	       (declare (sys:downward-function))
+	       (let ((path (merge-pathnames (concatenate 'string dir "\\" *winfe-exe*))))
+		 (when (probe-file path)
+		   (return-from find-winfe-exe (namestring path))))))))
+  (error "Cannot find the Winfe.exe file: ~A" *winfe-exe*))
+
+;;note, this always causes 'unbalanced paren' error in zmacs, pay no mind
+(defun map-over-path (continuation)
+  (let ((path (sys::getenv "PATH")))
+    (loop for oidx = 0 then (1+ idx)
+	  for idx = (position #\; path :start oidx)
+	  for dir = (subseq path oidx idx)
+	  do (funcall continuation dir)
+	  while idx)))
+
+(defvar *command-string-in-use* nil)
+(defvar *command-string* (make-array 260 :element-type 'string-char))
+
+(defmacro with-fast-command ((command code length &key reply) &body body)
+  (when (null command) (setf command '.command.))
+  `(multiple-value-prog1
+     (let ((,command *command-string*)
+	   (*command-string-in-use* t))
+       (setf (schar ,command 0) (code-char ,code))
+       (setf (schar ,command 1) (code-char ,length))
+       ,@body
+       ,(if reply
+	    `(send-command-await-response nil ,command)
+	    `(send-command-string nil ,command)))
+     (exit-gc-cursor)))
+
+(defvar *gc-cursor*)
+(defvar *old-cursor* nil)
+
+(defun enter-gc-cursor (&rest ignore)
+  (when (and (not *command-string-in-use*)
+	     (not *processing-vanilla-event*)
+	     (null *old-cursor*))
+    (setq *old-cursor* (set-mouse-cursor *gc-cursor*))))
+
+(defun exit-gc-cursor (&rest ignore)
+  (when (and (not *command-string-in-use*)
+	     (not *processing-vanilla-event*)
+	     *old-cursor*)
+    (set-mouse-cursor (shiftf *old-cursor* nil))))
+
+(defun si::*gc-start-hook* (x)
+  (funcall si::*gc-start-hook* x))
+
+(defun si::*gc-stop-hook* (x)
+  (funcall si::*gc-stop-hook* x))
+
+(defun replace-com-string (com)
+   (concatenate 'string (subseq com 0 (1+ (position #\\ com :from-end t)))
+                *standard-stub*))
+
+
+(defun start-windows ()
+  (when *windows-enabled*
+    (error "Windows is already started."))
+  (multiple-value-bind (com win3-p) (find-windows-com)
+    (when *windows-standard-mode*
+          (setf com (replace-com-string com)))
+    (let ((command-string (format nil "  ~:[~;/R ~]~A" win3-p 
+				  (find-winfe-exe)))
+	  (startup-directory (si::getcwd)))
+      (format t "~&Starting WINDOWS ~:[2~;3~]: ~A~A~%" win3-p com command-string)
+      (setf (aref command-string 0) (code-char (1- (length command-string))))
+      
+      (si::win%open com command-string)
+      ;;restore the startup directory, which gets munged by standard mode
+      (change-directory startup-directory)))
+  (setq *old-terminal-io* *terminal-io*)
+  (setq *stream* (si::make-encapsulated-primitive-stream lisp::*windows-io*))
+  (setq *terminal-io* *stream*
+        rh::*raw-outstream* *stream*
+        rh::*stream* *stream*)
+  (setq *windows-enabled* t)
+  (setq *gc-cursor* (loadcursor IDC_WAIT))
+  (setq si::*gc-start-hook* 'enter-gc-cursor
+        si::*gc-stop-hook* 'exit-gc-cursor)
+  t)
+
+(defun stop-windows ()
+  (setq si::*gc-start-hook* nil
+        si::*gc-stop-hook* nil)
+  (setq *windows-enabled* nil)
+  (setq *terminal-io* *old-terminal-io*
+        rh::*raw-outstream* *old-terminal-io*
+        rh::*stream* *old-terminal-io*)
+  (with-fast-command (command *vm-bcom-set-state* 1)
+    (setf (schar command 2) (code-char *VM-STATE-STOP*)))
+  (loop doing (si::win%idle)))
+
+
+(defvar *uid-string* (make-array 3 :element-type 'string-char))
+
+(defun send-command-string (code string &optional (zero-term nil) (uid nil))
+  ;; First, process any events that might be pending
+  (await-response -1 nil nil)
+  (when uid
+    (setf (schar *uid-string* 0) (code-char *VM-BCOM-UID*))
+    (setf (schar *uid-string* 1) (code-char 1))
+    (setf (schar *uid-string* 2) (code-char uid))
+    (si::win%send *uid-string*))
+  (cond ((null code)
+	 ;; Superfast case
+	 (si::win%send string))
+	(t
+	 ;; Need to copy
+	 (let ((string-remaining (length string))
+	       (*command-string-in-use* t))
+	   (declare (fixnum string-remaining))
+	   (cond ((< string-remaining 255)
+		  ;; Fast case
+		  (dotimes (i string-remaining)
+		    (declare (fixnum i))
+		    (setf (schar *command-string* (+ i 2)) (aref string i)))
+		  (setf (schar *command-string* 0) (code-char code))
+		  (cond (zero-term
+			 (setf (schar *command-string* 1) (code-char (1+ string-remaining)))
+			 (setf (schar *command-string* (+ string-remaining 2)) (code-char 0)))
+			(t
+			 (setf (schar *command-string* 1) (code-char string-remaining))))
+		  (si::win%send *command-string*))
+		 (t
+		  (loop with string-idx = 0
+			with idx
+			for first-time = t then nil
+			for string-remaining = (length string) then (- string-remaining 255)
+			for this-len = (max 0 (min 255 string-remaining))
+			while (or first-time (> string-remaining 0) zero-term)
+			do (setq idx 2)
+			   (dotimes (i this-len)
+			     (setf (schar *command-string* idx) (aref string string-idx))
+			     (incf idx)
+			     (incf string-idx))
+			   (when (and (< this-len 255) zero-term)
+			     ;; Need zero termination and have room
+			     (setf (schar *command-string* idx) (code-char 0))
+			     (setq zero-term nil)
+			     (incf this-len))
+			   (setf (schar *command-string* 1) (code-char this-len))
+			   (setf (schar *command-string* 0)
+				 (if (and (<= string-remaining 255) (not zero-term))
+				     (code-char code)
+				     (code-char *VM-BCOM-LONG-MESSAGE*)))
+			   (si::win%send *command-string*)))))
+	 (exit-gc-cursor))))
+
+(defconstant *bcom-max-uid* 16)
+(defvar *bcom-uid-array* (make-array *bcom-max-uid*))
+(defvar *bcom-uid* 0)
+
+(defun await-response (uid wait-p event-p)
+    (loop with code and length and args and ruid and res
+          do (multiple-value-setq (code length args)
+                 (receive-command-string wait-p t))
+             (cond ((or (null code) (eq code T))
+	            ;; An event or no wait; if a response for us came back
+		    ;; somewhere else, return it.  Else, if an event and want
+		    ;; to wake up, return, else loop.  Otherwise, wait flag
+		    ;; must be false, just return NIL.
+ 		    (cond ((and (>= uid 0)
+		    	        (setq res (aref *bcom-uid-array* uid)))
+		           (return (values-list res)))
+			  (t (return nil))))
+	           ((/= code *VM-BCOM-UID*)
+	            ;; Didn't get a UID back!  Hope this is the right response
+		    ;; and just return it.
+		    (return (values code length args)))
+	           ((= (setq ruid (char-code (aref args 0))) uid)
+		    ;; The next result is for us.  WINFE guarantees that there
+		    ;; will be no intervening responses between the UID and
+		    ;; the real response.
+		    (return (receive-command-string t nil)))
+		   (t ;; This result is for someone else
+                    (multiple-value-setq (code length args) 
+		      (receive-command-string t nil))
+		    (setf (aref *bcom-uid-array* ruid)
+		          (list code length (copy-seq args)))))))
+
+(defun send-command-await-response (code string &optional (zero-term nil))
+  (let ((uid (setq *bcom-uid* (mod (1+ *bcom-uid*) *bcom-max-uid*))))
+    (setf (aref *bcom-uid-array* uid) nil)
+    (send-command-string code string zero-term uid)
+    (await-response uid t nil)))
+
+(defvar *response-string* (make-array 260 :element-type 'string-char))
+(defvar *args-portion* (make-array (- (length *response-string*) 2)
+                                   :displaced-to *response-string*
+				   :displaced-index-offset 2
+                                   :element-type 'string-char))
+
+(defvar *processing-vanilla-event* nil)
+
+(defun receive-command-string (&optional (wait-p t) event-p)
+  (when *processing-vanilla-event*
+    (error "Can't send commands from the event handler."))
+  (let ((events nil)
+	(*processing-vanilla-event* t))
+    (loop 
+      (unless (si::win%receive *response-string* wait-p)
+	(return events))
+      (let ((code (char-code (schar *response-string* 0)))
+	    (length (char-code (schar *response-string* 1)))
+	    (args *args-portion*))
+	(declare (fixnum code length))
+	(unless (or (= code *VM-BCOM-VANILLA-EVENT*)
+		    (= code *VM-BCOM-PAINT-EVENT*))
+	  (return (values code length args)))
+	(vanilla-event code length args)
+	(when event-p
+	  (setf events t)
+	  (setf wait-p nil))))))
+
+;;make it so we don't have to load cloe-eve after reloading this.
+(unless (fboundp 'vanilla-event)
+  (defun vanilla-event (code length args)
+    (declare (ignore code length args))
+    nil))
+
+(defmacro get-16bit (string index)
+  `(let ((.low. (char-code (aref ,string ,index)))
+         (.high. (char-code (aref ,string (+ ,index 1)))))
+     (declare (fixnum .high. .low.))
+     (logior .low. (ash  .high. 8))))
+
+(defun menu-choose (caption &rest items)
+  (if *windows-enabled*
+      (menu-choose-windows caption items)
+      (menu-choose-dumb caption items)))
+
+(defun menu-choose-dumb (caption items)
+  (setq caption (string caption))
+  (format t "~&~A~%" caption)
+  (if (null items)
+      nil
+      (let ((count 0))
+        (dolist (item items)
+	  (format t "~D: ~A~%" (incf count) item))
+	(format t "Choice: ")
+	(loop for response = (read)
+	      when (and (typep response 'fixnum) 
+	      		(> response 0) 
+			(<= response count))
+              return (values (nth (- response 1) items)
+                             (- response 1) 0)
+	      do (format t "~&Please try again: ")))))
+
+(defun menu-choose-windows (caption items)
+  (send-command-string *VM-BCOM-START-MENU* "")
+  (when caption
+    (send-command-string *VM-BCOM-MENU-CAPTION* (string caption) t))
+  (dolist (i items)
+    (send-command-string *VM-BCOM-MENU-ITEM* 
+      (format nil "  ~A  " (string i)) t))
+  (multiple-value-bind (command l cstring)
+      (send-command-await-response *VM-BCOM-MENU-CHOOSE* "")
+    (cond ((= command *VM-BCOM-MENU-SELECTION*)
+           (values (nth (setq l (char-code (aref cstring 0))) items)
+                   l
+		   (char-code (aref cstring 1))))
+          (t ;(= command *VM-BCOM-CANCEL*)
+            nil))))
+
+
+(defun get-pathname (&optional (default "*.*"))
+  (if *windows-enabled*
+      (get-pathname-windows (win::get-focus) :default default)
+      (get-pathname-dumb default)))
+
+(defun get-pathname-dumb (default)
+  (format t "~&Enter a filename (default ~A): " default)
+  (merge-pathnames (parse-namestring (read-line))
+                   (parse-namestring default))
+  )
+
+(defun get-pathname-windows (window &key (default "*.*") 
+				    (caption "File Choose"))
+  (store-string-arg default)
+  (store-string-arg caption)
+  (multiple-value-bind (command l cstring)
+    (with-fast-command (*window* *VM-BCOM-GET-PATHNAME* 2 :reply t)
+      (store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-GET-PATHNAME*)
+	(subseq cstring 0 l)
+	;(get-16bit cstring 0)
+	nil)))
+
+(defmacro store-16bit (string index value)
+  (typecase value
+    ((or integer symbol)
+     `(progn
+	(setf (schar ,string ,index) (code-char (logand ,value #x0FF)))
+	(setf (schar ,string (+ ,index 1)) (code-char (logand (ash ,value -8) #x0FF)))))
+    (otherwise
+      `(let ((.value. ,value))
+	 (declare (fixnum .value.))
+	 (store-16bit ,string ,index .value.)))))
+
+;;;*** Anti-bignum kludge.  Take a 28-bit fixnum, and store it so
+;;;*** the C side will see it as a 32-bit fixnum with the four low
+;;;*** bits 0.  This is useful for create-window flags and for
+;;;*** RGB values, neither of which use the low bits.
+(defmacro store-28bit (string index value)
+  `(let ((.low. (ash (logand ,value #x0FFF) 4))
+         (.high. (logand (ash ,value -12) #x0FFFF)))
+     (declare (fixnum .high. .low.))
+     (store-16bit ,string ,index .low.)
+     (store-16bit ,string (+ ,index 2) .high.)))
+
+(defmacro store-24bit (string index value)
+  `(let ((.low. (logand ,value #x0FFFF))
+         (.high. (logand (ash ,value -16) #x00FF)))
+      (declare (fixnum .high. .low.))
+    (store-16bit ,string ,index .low.)
+    (store-16bit ,string (+ ,index 2) .high.)))
+
+(defun store-string-arg (string)
+  (send-command-string *VM-BCOM-STRING-ARG* string t))
+
+(defun draw-line (x0 y0 x1 y1)
+  (declare (fixnum x0 y0 x1 y1))
+  (with-fast-command (*line* *VM-BCOM-DRAW-LINE* 8)
+    (store-16bit *line* 2 x0)
+    (store-16bit *line* 4 y0)
+    (store-16bit *line* 6 x1)
+    (store-16bit *line* 8 y1)))
+
+(defun draw-char (char x y)
+  (declare (fixnum x y))
+  (with-fast-command (*char* *VM-BCOM-DRAW-CHAR* 5)
+    (setf (schar *char* 2) char)
+    (store-16bit *char* 3 x)
+    (store-16bit *char* 5 y)))
+
+;;; Generic windows functions
+
+(defun get-term-window ()
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (nil *VM-BCOM-GET-TERM-WINDOW* 0 :reply t))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun get-dc (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*window* *VM-BCOM-GET-DC* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-DC-VALUE*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun release-dc (window dc)
+  (declare (fixnum window dc))
+  (with-fast-command (*release* *VM-BCOM-RELEASE-DC* 4)
+    (store-16bit *release* 2 window)
+    (store-16bit *release* 4 dc)))
+
+(defun begin-paint (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*window* *VM-BCOM-BEGIN-PAINT* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-DC-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun end-paint (window)
+  (declare (fixnum window))
+  (with-fast-command (*window* *VM-BCOM-END-PAINT* 2)
+    (store-16bit *window* 2 window)))
+
+(defun create-window (cname wname style x y w h parent menu instance param)
+  (declare (fixnum style x y w h parent menu instance))
+  (store-string-arg cname)	/* ClassName */
+  (store-string-arg wname)	/* WindowName */
+  (store-string-arg param)
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*cwindow* *VM-BCOM-CREATE-WINDOW* 18 :reply t)
+	(store-28bit *cwindow* 2 style)
+	(store-16bit *cwindow* 6 x)
+	(store-16bit *cwindow* 8 y)
+	(store-16bit *cwindow* 10 w)
+	(store-16bit *cwindow* 12 h)
+	(store-16bit *cwindow* 14 parent)
+	(store-16bit *cwindow* 16 menu)
+	(store-16bit *cwindow* 18 instance))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun move-window (window x y w h repaint)
+  (declare (fixnum window x y w h))
+  (with-fast-command (*mwindow* *VM-BCOM-MOVE-WINDOW* 12)
+    (store-16bit *mwindow* 2 window)
+    (store-16bit *mwindow* 4 x)
+    (store-16bit *mwindow* 6 y)
+    (store-16bit *mwindow* 8 w)
+    (store-16bit *mwindow* 10 h)
+    (store-16bit *mwindow* 12 (if repaint 1 0))))
+
+(defun move-to (dc x y)
+  (declare (fixnum dc x y))
+  (with-fast-command (*dcxy* *VM-BCOM-MOVE-TO* 6)
+    (store-16bit *dcxy* 2 dc)
+    (store-16bit *dcxy* 4 x)
+    (store-16bit *dcxy* 6 y)))
+
+(defun line-to (dc x y)
+  (declare (fixnum dc x y))
+  (with-fast-command (*dcxy* *VM-BCOM-LINE-TO* 6)
+    (store-16bit *dcxy* 2 dc)
+    (store-16bit *dcxy* 4 x)
+    (store-16bit *dcxy* 6 y)))
+
+(defun text-out (dc x y string &aux (slen (length string)))
+  (declare (fixnum dc x y slen))
+  (store-string-arg string)
+  (with-fast-command (*text-out* *VM-BCOM-TEXT-OUT* 8)
+    (store-16bit *text-out* 2 dc)
+    (store-16bit *text-out* 4 x)
+    (store-16bit *text-out* 6 y)
+    (store-16bit *text-out* 8 slen)))
+
+(defun ellipse (dc xLeft yTop xRight yBottom)
+  (declare (fixnum dc xLeft yTop xRight yBottom))
+  (with-fast-command (*ellipse* *VM-BCOM-ELLIPSE* 10)
+    (store-16bit *ellipse* 2 dc)
+    (store-16bit *ellipse* 4 xLeft)
+    (store-16bit *ellipse* 6 yTop)
+    (store-16bit *ellipse* 8 xRight)
+    (store-16bit *ellipse* 10 yBottom)))
+
+(defun rectangle (dc xLeft yTop xRight yBottom)
+  (declare (fixnum dc xLeft yTop xRight yBottom))
+  (incf xRight)
+  (incf yBottom)
+  (with-fast-command (*rectangle* *VM-BCOM-RECTANGLE* 10)
+    (store-16bit *rectangle* 2 dc)
+    (store-16bit *rectangle* 4 xLeft)
+    (store-16bit *rectangle* 6 yTop)
+    (store-16bit *rectangle* 8 xRight)
+    (store-16bit *rectangle* 10 yBottom)))
+
+(defun show-window (window &key (type :show-maximized))
+  (declare (fixnum window))
+  (let ((command (ecase type
+		   (:hide sw_hide)
+		   (:minimize sw_minimize)
+		   (:show-normal sw_shownormal) (:restore sw_restore)
+		   (:show sw_show)
+		   (:show-maximized sw_showmaximized)
+		   (:show-minimized sw_showminimized)
+		   (:show-minimized-no-activate sw_showminnoactive)
+		   (:show-na sw_showna)
+		   (:show-no-activate sw_shownoactivate))))
+    (with-fast-command (*show-window* *VM-BCOM-SHOW-WINDOW* 4)
+      (store-16bit *show-window* 2 window)
+      (store-16bit *show-window* 4 command))))
+
+(defun destroy-window (window)
+  (declare (fixnum window))
+  (with-fast-command (*window* *VM-BCOM-DESTROY-WINDOW* 2)
+    (store-16bit *window* 2 window)))
+
+(defun set-focus (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*window* *VM-BCOM-SET-FOCUS* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun get-focus ()
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (nil *VM-BCOM-GET-FOCUS* 0 :reply t))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun get-update-rect (window erasep)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*selobject* *VM-BCOM-GET-UPDATE-RECT* 4 :reply t)
+	(store-16bit *selobject* 2 window)
+	(store-16bit *selobject* 4 (if erasep 1 0)))
+    (if (= command *VM-BCOM-RECT-VALUE*)
+	(values (get-16bit cstring 0)		; left
+		(get-16bit cstring 2)		; top
+		(get-16bit cstring 4)		; bottom
+		(get-16bit cstring 6)		; right
+		)
+	nil)))
+
+(defun get-client-rectangle (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*window* *VM-BCOM-GET-CLIENT-RECTANGLE* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-RECT-VALUE*)
+	(values  (get-16bit cstring 0)		; left
+		 (get-16bit cstring 2)		; top
+		 (get-16bit cstring 4)		; bottom
+		 (get-16bit cstring 6)		; right
+		 )
+        nil)))
+
+(defun window-from-point (x y)
+  (declare (fixnum x y))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*selobject* *VM-BCOM-WINDOW-FROM-POINT* 4 :reply t)
+	(store-16bit *selobject* 2 x)
+	(store-16bit *selobject* 4 y))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun scroll-dc (dc x y l1 t1 r1 b1 l2 t2 r2 b2)
+  (declare (fixnum dc x y l1 t1 r1 b1 l2 t2 r2 b2))
+  (with-fast-command (*scroll* *VM-BCOM-SCROLL-DC* 22)
+    (store-16bit *scroll* 2 dc)
+    (store-16bit *scroll* 4 x)
+    (store-16bit *scroll* 6 y)
+    (store-16bit *scroll* 8 l1)
+    (store-16bit *scroll* 10 t1)
+    (store-16bit *scroll* 12 r1)
+    (store-16bit *scroll* 14 b1)
+    (store-16bit *scroll* 16 l2)
+    (store-16bit *scroll* 18 t2)
+    (store-16bit *scroll* 20 r2)
+    (store-16bit *scroll* 22 b2)))
+
+(defun arc (dc x1 y1 x2 y2 x3 y3 x4 y4)
+  (declare (fixnum dc x1 y1 x2 y2 x3 y3 x4 y4))
+  (with-fast-command (*arc* *VM-BCOM-ARC* 18)
+    (store-16bit *arc* 2 dc)
+    (store-16bit *arc* 4 x1)
+    (store-16bit *arc* 6 y1)
+    (store-16bit *arc* 8 x2)
+    (store-16bit *arc* 10 y2)
+    (store-16bit *arc* 12 x3)
+    (store-16bit *arc* 14 y3)
+    (store-16bit *arc* 16 x4)
+    (store-16bit *arc* 18 y4)))
+
+(defun pie (dc x1 y1 x2 y2 x3 y3 x4 y4)
+  (declare (fixnum dc x1 y1 x2 y2 x3 y3 x4 y4))
+  (with-fast-command (*arc* *VM-BCOM-PIE* 18)
+    (store-16bit *arc* 2 dc)
+    (store-16bit *arc* 4 x1)
+    (store-16bit *arc* 6 y1)
+    (store-16bit *arc* 8 x2)
+    (store-16bit *arc* 10 y2)
+    (store-16bit *arc* 12 x3)
+    (store-16bit *arc* 14 y3)
+    (store-16bit *arc* 16 x4)
+    (store-16bit *arc* 18 y4)))
+
+(defvar *polygon* (make-array 1 :element-type 'string-char :fill-pointer 0))
+
+(defun polygon (dc list-of-points &optional (x-offset 0) (y-offset 0))
+  (declare (fixnum dc))
+  (let* ((len (length list-of-points))
+	 (alen (+ (* 2 len) 4)))
+    (declare (fixnum len alen))
+    (when (oddp len) (error "Polygons must have even number of points"))
+    (cond ((< alen 255)
+	   (with-fast-command (command *VM-BCOM-POLYGON* alen)
+	     (store-16bit command 2 dc)
+	     (store-16bit command 4 (the fixnum (truncate len 2)))
+	     (let ((list list-of-points)
+		   (ind 6))
+	       (declare (fixnum ind))
+	       (loop
+		 (when (null list) (return))
+		 (store-16bit command ind (round (+ (pop list) x-offset)))
+		 (incf ind 2)
+		 (store-16bit command ind (round (+ (pop list) y-offset)))
+		 (incf ind 2)))))
+	  (t
+	   (when (< (array-total-size *polygon*) alen)
+	     (setf *polygon* (make-array alen :element-type 'string-char :fill-pointer 0)))
+	   (setf (fill-pointer *polygon*) alen)
+	   (store-16bit *polygon* 0 dc)
+	   (store-16bit *polygon* 2 (the fixnum (truncate len 2)))
+	   (let ((list list-of-points)
+		 (ind 4))
+	     (declare (fixnum ind))
+	     (loop
+	       (when (null list) (return))
+	       (store-16bit *polygon* ind (round (+ (pop list) x-offset)))
+	       (incf ind 2)
+	       (store-16bit *polygon* ind (round (+ (pop list) y-offset)))
+	       (incf ind 2)))
+	   (send-command-string *VM-BCOM-POLYGON* *polygon*)))))
+
+(defun polyline (dc list-of-points &optional closed (x-offset 0) (y-offset 0))
+  (declare (fixnum dc x-offset y-offset))
+  (let* ((len (+ (length list-of-points) (if closed 2 0)))
+	 (alen (+ (* 2 len) 4)))
+    (declare (fixnum len alen))
+    (when (oddp len) (error "Polygons must have even number of points"))
+    (cond ((< alen 255)
+	   (with-fast-command (command *VM-BCOM-POLYLINE* alen)
+	     (store-16bit command 2 dc)
+	     (store-16bit command 4 (the fixnum (truncate len 2)))
+	     (let ((list list-of-points)
+		   (ind 6))
+	       (declare (fixnum ind))
+	       (loop
+		 (when (null list) (return))
+		 (store-16bit command ind (round (+ (pop list) x-offset)))
+		 (incf ind 2)
+		 (store-16bit command ind (round (+ (pop list) y-offset)))
+		 (incf ind 2))
+	       (when closed
+		 (store-16bit command ind (round (+ (first list-of-points) x-offset)))
+		 (incf ind 2)
+		 (store-16bit command ind (round (+ (second list-of-points) y-offset)))
+		 (incf ind 2)))))
+	  (t
+	   (when (< (array-total-size *polygon*) alen)
+	     (setf *polygon* (make-array alen :element-type 'string-char :fill-pointer 0)))
+	   (setf (fill-pointer *polygon*) alen)
+	   (store-16bit *polygon* 0 dc)
+	   (store-16bit *polygon* 2 (the fixnum (truncate len 2)))
+	   (let ((list list-of-points)
+		 (ind 4))
+	     (declare (fixnum ind))
+	     (loop
+	       (when (null list) (return))
+	       (store-16bit *polygon* ind (round (+ (pop list) x-offset)))
+	       (incf ind 2)
+	       (store-16bit *polygon* ind (round (+ (pop list) y-offset)))
+	       (incf ind 2))
+	     (when closed
+	       (store-16bit *polygon* ind (round (+ (first list-of-points) x-offset)))
+	       (incf ind 2)
+	       (store-16bit *polygon* ind (round (+ (second list-of-points) y-offset)))
+	       (incf ind 2)))
+	   (send-command-string *VM-BCOM-POLYLINE* *polygon*)))))
+
+(defun create-pen (style width color)
+  (declare (fixnum style width color))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*create-pen* *VM-BCOM-CREATE-PEN* 8 :reply t)
+	(store-16bit *create-pen* 2 style)
+	(store-16bit *create-pen* 4 width)
+	(store-24bit *create-pen* 6 color))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun create-font (height width escapement orientation weight
+		    italic underline strikeout charset outputprecision
+		    clipprecision quality pitchandfamily facename)
+  (declare (fixnum height width escapement orientation weight
+		   italic underline strikeout charset outputprecision
+		   clipprecision quality pitchandfamily))
+  (store-string-arg facename)
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*create-font* *VM-BCOM-CREATE-FONT* 26 :reply t)
+	(store-16bit *create-font* 2 height)
+	(store-16bit *create-font* 4 width)
+	(store-16bit *create-font* 6 escapement)
+	(store-16bit *create-font* 8 orientation)
+	(store-16bit *create-font* 10 weight)
+	(store-16bit *create-font* 12 italic)
+	(store-16bit *create-font* 14 underline)
+	(store-16bit *create-font* 16 strikeout)
+	(store-16bit *create-font* 18 charset)
+	(store-16bit *create-font* 20 outputprecision)
+	(store-16bit *create-font* 22 clipprecision)
+	(store-16bit *create-font* 24 quality)
+	(store-16bit *create-font* 26 pitchandfamily))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun get-text-metrics (dc)
+  (declare (fixnum dc))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*dc* *VM-BCOM-GET-TEXT-METRICS* 2 :reply t)
+	(store-16bit *dc* 2 dc))
+    (if (= command *VM-BCOM-METRIC-VALUE*)
+        (values (get-16bit cstring 0)		;height
+		(get-16bit cstring 2)		;ascent
+		(get-16bit cstring 4)		; descent
+		(get-16bit cstring 6)		; internal leading
+		(get-16bit cstring 8)		; external leading
+		(get-16bit cstring 10)		; average char width
+		(get-16bit cstring 12)		; max char width
+		(get-16bit cstring 14)		; weight
+		(char-code (char cstring 16))	;italic
+		(char-code (char cstring 17))	;underlined
+		(char-code (char cstring 18))	;struckout
+		(char-code (char cstring 19))	;first char
+		(char-code (char cstring 20))	;last char
+		(char-code (char cstring 21))	;default char
+		(char-code (char cstring 22))	;break char
+		(char-code (char cstring 23))	;pitch and family
+		(char-code (char cstring 24))	;char set
+		(get-16bit cstring 25)		;overhang
+		(get-16bit cstring 27)		;digitized aspect x
+		(get-16bit cstring 29)		;digitized aspect y
+		)
+	nil)))
+
+(defun create-solid-brush (color)
+  (declare (fixnum color))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*create-solid-brush* *VM-BCOM-CREATE-SOLID-BRUSH* 4 :reply t)
+	(store-24bit *create-solid-brush* 2 color))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defvar *bitmap* (make-array (+ (* 2 8) 8) :element-type 'string-char :fill-pointer 0))
+
+(defun create-bitmap (bitarray)
+  (multiple-value-bind (command l cstring)
+      (let* ((len (array-total-size bitarray))
+	     (alen (+ (* 2 len) 8)))
+	(declare (fixnum len alen))
+	(cond ((< alen 255)
+	       (with-fast-command (command *VM-BCOM-CREATE-BITMAP* alen :reply t)
+		 (store-16bit command 2 8)	;width
+		 (store-16bit command 4 8)	;height
+		 (store-16bit command 6 1)	; nplanes
+		 (store-16bit command 8 1)	; nbitcount
+		 (dotimes (i len)
+		   (store-16bit command (+ 10 (* 2 i)) (aref bitarray i)))))	       
+	      (t
+	       (when (< (array-total-size *bitmap*) alen)
+		 (setf *bitmap* (make-array alen :element-type 'string-char :fill-pointer 0)))
+	       (setf (fill-pointer *bitmap*) alen)
+	       (store-16bit *bitmap* 0 8)	;width
+	       (store-16bit *bitmap* 2 8)	;height
+	       (store-16bit *bitmap* 4 1)	; nplanes
+	       (store-16bit *bitmap* 6 1)	; nbitcount
+	       (dotimes (i len)
+		 (store-16bit *bitmap* (+ 8 (* 2 i)) (aref bitarray i)))
+	       (send-command-await-response *VM-BCOM-CREATE-BITMAP* *bitmap*))))
+    (if (= command *vm-bcom-handle-value*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun create-pattern-brush (bitmap)
+  (declare (fixnum bitmap))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*create-pattern-brush* *VM-BCOM-CREATE-PATTERN-BRUSH* 2 :reply t)
+	(store-16bit *create-pattern-brush* 2 bitmap))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun set-brush-org (dc x y)
+  (declare (fixnum dc x y))
+  (with-fast-command (*dcxy* *VM-BCOM-SET-BRUSH-ORG* 6)
+    (store-16bit *dcxy* 2 dc)
+    (store-16bit *dcxy* 4 x)
+    (store-16bit *dcxy* 6 y)))
+
+(defun get-stock-object (n)
+  (declare (fixnum n))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*object* *VM-BCOM-GET-STOCK-OBJECT* 2 :reply t)
+	(store-16bit *object* 2 n))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+	nil)))
+
+(defun delete-object (object)
+  (declare (fixnum object))
+  (with-fast-command (*object* *VM-BCOM-DELETE-OBJECT* 2)
+    (store-16bit *object* 2 object)))
+
+(defun get-rop2 (dc)
+  (declare (fixnum dc))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*object* *VM-BCOM-GET-ROP2* 2 :reply t)
+	(store-16bit *object* 2 dc))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun set-rop2 (dc rop)
+  (declare (fixnum dc rop))
+  (with-fast-command (*setrop2* *VM-BCOM-SET-ROP2* 4)
+    (store-16bit *setrop2* 2 dc)
+    (store-16bit *setrop2* 4 rop)))
+
+(defun set-text-color (dc color)
+ (declare (fixnum dc color))
+ (with-fast-command (*set-text-color* *VM-BCOM-SET-TEXT-COLOR* 6)
+   (store-16bit *set-text-color* 2 dc)
+   (store-24bit *set-text-color* 4 color)))
+
+(defun message-beep ()
+  (with-fast-command (nil *VM-BCOM-BEEP* 0)))
+
+(defun set-scroll-position (window bar position &optional (draw-p t))
+  (declare (fixnum window position))
+  (with-fast-command (*set-scroll-position* *VM-BCOM-SET-SCROLL-POSITION* 8)
+    (store-16bit *set-scroll-position* 2 window)
+    (store-16bit *set-scroll-position* 4 bar)
+    (store-16bit *set-scroll-position* 6 position)
+    (store-16bit *set-scroll-position* 8 (if draw-p 1 0))))
+
+(defun set-background-color (dc color)
+ (declare (fixnum dc color))
+ (with-fast-command (*set-background-color* *VM-BCOM-SET-BACKGROUND-COLOR* 6)
+   (store-16bit *set-background-color* 2 dc)
+   (store-24bit *set-background-color* 4 color)))
+
+(defun set-erase-brush (dc color)
+ (declare (fixnum dc color))
+ (with-fast-command (*set-background-color* *VM-BCOM-SET-ERASE-BRUSH* 6)
+   (store-16bit *set-background-color* 2 dc)
+   (store-24bit *set-background-color* 4 color)))
+
+(defun select-object (dc n)
+  (declare (fixnum dc n))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*selobject* *VM-BCOM-SELECT-OBJECT* 4 :reply t)
+	(store-16bit *selobject* 2 dc)
+	(store-16bit *selobject* 4 n))
+    (if (= command *VM-BCOM-HANDLE-VALUE*)
+	(get-16bit cstring 0)
+        nil)))
+
+(defun select-brush (dc n)
+  (declare (fixnum dc n))
+  (with-fast-command (*selobject* *VM-BCOM-SELECT-BRUSH* 4)
+    (store-16bit *selobject* 2 dc)
+    (store-16bit *selobject* 4 n)))
+
+(defun select-pen (dc n)
+  (declare (fixnum dc n))
+  (with-fast-command (*selobject* *VM-BCOM-SELECT-PEN* 4)
+    (store-16bit *selobject* 2 dc)
+    (store-16bit *selobject* 4 n)))
+
+(defun select-bitmap (dc n)
+  (declare (fixnum dc n))
+  (with-fast-command (*selobject* *VM-BCOM-SELECT-BITMAP* 4)
+    (store-16bit *selobject* 2 dc)
+    (store-16bit *selobject* 4 n)))
+
+(defun select-font (dc n)
+  (declare (fixnum dc n))
+  (with-fast-command (*selobject* *VM-BCOM-SELECT-FONT* 4)
+    (store-16bit *selobject* 2 dc)
+    (store-16bit *selobject* 4 n)))
+
+(defun select-region (dc n)
+  (declare (fixnum dc n))
+  (with-fast-command (*selobject* *VM-BCOM-SELECT-REGION* 4)
+    (store-16bit *selobject* 2 dc)
+    (store-16bit *selobject* 4 n)))
+
+(defun get-text-extent (dc string)
+  (declare (fixnum dc))
+  (store-string-arg string)
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*get-text-extent* *VM-BCOM-GET-TEXT-EXTENT* 4 :reply t)
+	(store-16bit *get-text-extent* 2 dc)
+	(store-16bit *get-text-extent* 4 (length string)))
+    (if (= command *VM-BCOM-RECT-VALUE*)
+        (values (get-16bit cstring 4)		;right
+		(get-16bit cstring 6)		;bottom
+		)
+        nil)))
+
+(defmacro with-dc ((dc-variable window) &body body)
+  `(let ((,dc-variable ,window))
+    ,@body))
+
+#+old-code
+(defmacro with-dc ((dc-variable window) &body body)
+  `(let ((,dc-variable (get-dc ,window)))
+     (unwind-protect
+       (progn
+         ,@body)
+       (release-dc ,window ,dc-variable))))
+
+#+old-code
+(defmacro with-term-dc ((dc-variable) &body body)
+  `(let ((,dc-variable (get-dc (get-term-window))))
+     (unwind-protect
+       (progn
+         ,@body)
+       (release-dc (get-term-window) ,dc-variable))))
+
+(defun get-screen-size ()
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (nil *VM-BCOM-GET-SCREEN-SIZE* 0 :reply t))
+    (values (get-16bit cstring 0)
+	    (get-16bit cstring 2))))
+
+(defun get-pointer-position ()
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (nil *VM-BCOM-GET-POINTER-POSITION* 0 :reply t))
+    (values (get-16bit cstring 0)
+	    (get-16bit cstring 2))))
+
+(defun set-pointer-position (screen-x screen-y)
+  (declare (fixnum screen-x screen-y))
+  (with-fast-command (*xyposition* *VM-BCOM-SET-POINTER-POS* 4)
+	(store-16bit *xyposition* 2 screen-x)
+	(store-16bit *xyposition* 4 screen-y)))
+
+;;; Mouse cursor stuff
+
+;;; Calls LoadCursor with id as 16 bit arg and returns the handle
+(defun loadcursor (id)
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*cursobject* *VM-BCOM-LOADCURSOR* 2 :reply t)
+	(store-16bit *cursobject* 2 id))
+    (get-16bit cstring 0)))
+
+;;; Sets the mouse cursor for all WINFE windows, and returns the either
+;;; the current cursor, if WINFE has the focus, or the current value of
+;;; WINFE's cursor as last set.
+(defun set-mouse-cursor (hcursor)
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*cursobject* *VM-BCOM-SET-MOUSE-CURSOR* 2 :reply t)
+	(store-16bit *cursobject* 2 hcursor))
+    (get-16bit cstring 0)))
+
+;;;for moving the window position and stacking order
+
+(defun set-window-position (window after-window x y w h flags)
+  (declare (fixnum window after-window x y w flags))
+  (with-fast-command (*swindowp* *VM-BCOM-SET-WINDOW-POS* 14)
+    (store-16bit *swindowp* 2 window)
+    (store-16bit *swindowp* 4 after-window)
+    (store-16bit *swindowp* 6 x)
+    (store-16bit *swindowp* 8 y)
+    (store-16bit *swindowp* 10 w)
+    (store-16bit *swindowp* 12 h)
+    (store-16bit *swindowp* 14 flags)))
+
+;;sets the windows title pane
+(defun set-window-text (window text)
+  (declare (fixnum window))
+  (store-string-arg text)
+  (with-fast-command (*window* *VM-BCOM-SET-WINDOW-TEXT* 2)
+    (store-16bit *window* 2 window)))
+
+(defun get-window-rectangle (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring)
+      (with-fast-command (*window* *VM-BCOM-GET-WINDOW-RECTANGLE* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-RECT-VALUE*)
+	(values  (get-16bit cstring 0)		; left
+		 (get-16bit cstring 2)		; top
+		 (get-16bit cstring 4)		; bottom
+		 (get-16bit cstring 6)		; right
+		 )
+        nil)))
+
+(defun show-scroll-bar (window wbar show-p)
+  (declare (fixnum window))
+  (with-fast-command (*scroll-bar* *VM-BCOM-SHOW-SCROLL-BAR* 6)
+    (store-16bit *scroll-bar* 2 window)
+    (store-16bit *scroll-bar* 4 wbar)
+    (store-16bit *scroll-bar* 6 (if show-p 1 0))))
+
+(defun is-iconic (window)
+  (declare (fixnum window))
+  (multiple-value-bind (command l cstring) 
+      (with-fast-command (*window* *VM-BCOM-IS-ICONIC* 2 :reply t)
+	(store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(not (zerop (get-16bit cstring 0)))
+	;;probably not important, but avoid confusion vs returning nil
+	(progn         
+          (cerror "Return T anyway" "Is-iconic didn't return")
+          (values t)))))
+
+
+(defun notify-user (window message)
+  (declare (fixnum window)(string message))
+  (store-string-arg message)
+  (with-fast-command (*window* *VM-BCOM-NOTIFY-USER* 2)
+    (store-16bit *window* 2 window)))
+
+(defun run-windows-application (application &optional (show SW_NORMAL))
+  (declare (string application)(fixnum show))
+  (store-string-arg application)
+  (multiple-value-bind (command l cstring) 
+    (with-fast-command (*window* *VM-BCOM-WINDOW-EXEC* 2 :reply t)
+      (store-16bit *window* 2 show))
+    (if (= command *VM-BCOM-WINDOW-VALUE*)
+	(let ((return-value (get-16bit cstring 0)))
+	  (declare (fixnum return-value))
+	  ;;a value less than 32 means it couldn't do it
+	  (unless (> return-value 32)
+	    (error "Unable to start ~A, error code returned was ~D"
+		   application return-value))))
+  t))
+
+;;this should probably be in the low-level CLOE sources, with
+;;getcwd, but it was easier and quicker here.
+(defun change-directory (path)
+  (declare (string path))
+  (store-string-arg path)
+  (multiple-value-bind (command l cstring) 
+    (with-fast-command (nil *VM-BCOM-CHANGE-DIR* 0))))
+
+
+;;these functions set up the blinking cursor, it needs to be 
+;;cleaned up more before making it the default
+
+(defun show-caret (window)
+  (declare (fixnum window))
+  (with-fast-command (*window* *VM-BCOM-SHOW-CARET* 2)))
+
+(defun hide-caret ()
+  (with-fast-command (nil *VM-BCOM-HIDE-CARET* 0)))
+
+
+(defun set-caret-pos (x y)
+  (declare (fixnum x y))
+  (with-fast-command (*coordinates* *VM-BCOM-SET-CARET-POS* 4)
+    (store-16bit *coordinates* 2 x)
+    (store-16bit *coordinates* 4 y)))
+
+;;;
+
+(defun select-file-dialog-box (window &key (default "*.*") 
+				    (caption "File Choose"))
+  (store-string-arg default)
+  (store-string-arg caption)
+  (multiple-value-bind (command l cstring)
+    (with-fast-command (*window* *VM-BCOM-GET-PATHNAME* 2 :reply t)
+      (store-16bit *window* 2 window))
+    (if (= command *VM-BCOM-GET-PATHNAME*); cancel returned if no selection
+	(subseq cstring 0 l)
+	nil)))
+
+
+;;helps to redraw scrollbar buttons when they don't appear, but
+;;calling this only works some times
+(defun paint-nonclient-area (window)
+  (declare (fixnum window))
+  (with-fast-command (*window* *VM-BCOM-NONCLIENT-PAINT* 2)
+    (store-16bit *window* 2 window)))
+
+
+(defvar *editor-for-windows* "epsilon")
+
+(in-package 'user)  ;;;NOTE!!!!!
+
+;;starts up dos, then you can switch back and forth using ^tab
+;;if you give it a string, it will do that command and then exit
+(defun command (&optional string)
+  (win::run-windows-application  
+    (if string 
+	(concatenate 'string "command.com /c " string)
+	"command.com")))
+
+;;poor mans editor
+(defun notepad (&optional file)
+    (win::run-windows-application (concatenate 'string
+					       "notepad "
+					       file)))
+
+
+
+;;Frob the ed function to work for both windows and cloe
+(defvar non-windows-ed nil)
+(setf (symbol-function 'non-windows-ed) (symbol-function 'ed))
+
+;;real editor, exit brings you back to windows
+;;This needs to actually be merged with ED that works when
+;;windows is not enabled...
+(defun ed (&optional file)
+  (if (not win::*windows-enabled*)
+      (non-windows-ed file)
+      (win::run-windows-application (concatenate 'string
+						 "command.com /c "
+						 *editor-for-windows*
+						 " "
+						 file))))
+
+(in-package 'win)  ;; so when more code gets added
+
+
+
+
diff --git a/utils/ccl-streams.lisp b/utils/ccl-streams.lisp
new file mode 100644
index 00000000..cc6d8e37
--- /dev/null
+++ b/utils/ccl-streams.lisp
@@ -0,0 +1,16 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;; If we were really being clever, we could put CCL methods for
+;; STREAM-CLOSE and STREAM-ABORT onto FUNDAMENTAL-STREAM here.  That
+;; would require having someplace to write down that the stream had
+;; been aborted so when it got closed we could do something clever with
+;; that information, though, so we won't do it for now...
+(defgeneric close (stream &key abort))
+
+(defmethod close ((stream t) &key abort)
+  (common-lisp:close stream :abort abort))
+
diff --git a/utils/cl-stream-classes.lisp b/utils/cl-stream-classes.lisp
new file mode 100644
index 00000000..8408f8a4
--- /dev/null
+++ b/utils/cl-stream-classes.lisp
@@ -0,0 +1,77 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; All of this is taken from the STREAM-DEFINITION-BY-USER proposal to
+;;; the X3J13 committee, made by David Gray of TI on 22 March 1989.  No
+;;; Lisp implementation yet supports this proposal, so we implement it
+;;; here in this separate package.  This way we will be ready when some
+;;; Lisp implementation adopts it (or something like it).
+
+;;; This file defines classes in the Gray proposal, plus class-based
+;;; predicates.  This file is entirely #-CLIM-uses-Lisp-stream-classes,
+;;; which means that any class and function names are shadowed in this
+;;; package (not inherited from the CL package).
+
+(defmacro define-class-and-predicate (class-name predicate-name &body superclasses)
+  `(clim-utils:define-group ,class-name define-class-and-predicate
+     (defclass ,class-name ,@superclasses ())
+     ;;--- Genera can't put both a class and methods on that class in the same group.
+     ,@(when predicate-name
+	 `((define-stream-predicate-trampoline ,predicate-name ,class-name)))))
+
+(defmacro define-stream-predicate-trampoline (predicate-name class-name
+					      &key lucid-kludge)
+  #-Lucid (declare (ignore lucid-kludge))
+  (let ((lisp-predicate (or #+Lucid lucid-kludge
+			    (find-symbol
+			      (symbol-name predicate-name)
+			      ;; #+Genera *Sigh*.  OPEN-STREAM-P is in
+			      ;; FUTURE-COMMON-LISP only.  Of course, it's
+			      ;; not defined yet, but at least it's exported.
+			      #+Genera "FUTURE-COMMON-LISP"
+			      #-Genera "COMMON-LISP"))))
+    (when (null lisp-predicate)
+      (error "No symbol ~S found in the Common-Lisp package." predicate-name))
+    `(clim-utils:define-group ,predicate-name define-stream-predicate-trampoline
+       (defgeneric ,predicate-name (object))
+       (defmethod  ,predicate-name ((object t)) (,lisp-predicate object))
+       ,@(when class-name
+	   `((defmethod ,predicate-name ((object ,class-name)) 't))))))
+
+
+;;; The classes themselves.
+
+(define-class-and-predicate fundamental-stream streamp
+  (#+CCL-2 ccl::stream))
+
+(define-class-and-predicate fundamental-input-stream input-stream-p
+  (fundamental-stream #+CCL-2 ccl:input-stream))
+
+(define-class-and-predicate fundamental-output-stream output-stream-p
+  (fundamental-stream #+CCL-2 ccl:output-stream))
+
+(define-class-and-predicate fundamental-character-stream nil
+  (fundamental-stream))
+
+(define-class-and-predicate fundamental-binary-stream nil
+  (fundamental-stream))
+
+(define-class-and-predicate fundamental-character-input-stream nil
+  (fundamental-input-stream fundamental-character-stream))
+							
+(define-class-and-predicate fundamental-character-output-stream nil
+  (fundamental-output-stream fundamental-character-stream))
+							 
+(define-class-and-predicate fundamental-binary-input-stream nil
+  (fundamental-input-stream fundamental-binary-stream))
+						     
+(define-class-and-predicate fundamental-binary-output-stream nil
+  (fundamental-output-stream fundamental-binary-stream))
+
+(define-stream-predicate-trampoline open-stream-p nil
+  ;;--- For now.  PW will dig up the right predicate
+  :lucid-kludge (lambda (stream) (streamp stream)))
diff --git a/utils/cl-stream-functions.lisp b/utils/cl-stream-functions.lisp
new file mode 100644
index 00000000..d1363ea3
--- /dev/null
+++ b/utils/cl-stream-functions.lisp
@@ -0,0 +1,197 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; All of this is taken from the STREAM-DEFINITION-BY-USER proposal to
+;;; the X3J13 committee, made by David Gray of TI on 22 March 1989.  No
+;;; Lisp implementation yet supports this proposal, so we implement it
+;;; here in this separate package.  This way we will be ready when some
+;;; Lisp implementation adopts it (or something like it).
+
+;;; This file defines functions in the Gray proposal.  This file is
+;;; entirely #-CLIM-uses-Lisp-stream-functions, which means that any
+;;; class and function names are shadowed in this package (not
+;;; inherited from the CL package).
+
+
+;;; Output functions
+
+(defmacro write-forwarding-cl-output-stream-function (name args)
+  (let* ((cl-name (find-symbol (symbol-name name) (find-package 'lisp)))
+	 (method-name (intern (lisp:format nil "STREAM-~A" (symbol-name name))))
+	 (optional-args (or (member '&optional args) (member '&key args)))
+	 (required-args (ldiff args optional-args))
+	 (optional-parameters (mapcan #'(lambda (arg)
+					  (cond ((member arg lambda-list-keywords) nil)
+						((atom arg) (list arg))
+						(t (list (car arg)))))
+				      optional-args))
+	 (pass-args (append required-args optional-parameters))
+	 ;; optional-args are &optional in the method,
+	 ;; even if &key in the Common Lisp function
+	 (method-args (if (eq (first optional-args) '&key)
+			  (append required-args '(&optional) (cdr optional-args))
+			  args))
+	 (pass-keys (if (eq (first optional-args) '&key)
+			(mapcan #'(lambda (arg)
+				    (unless (atom arg)
+				      (setq arg (car arg)))
+				    (list (intern (string arg) "KEYWORD") arg))
+				(cdr optional-args))
+			optional-parameters)))
+    (when (eq (first optional-args) '&optional)
+      (pop optional-args))
+    `(clim-utils:define-group ,name write-forwarding-cl-output-stream-function
+       (eval-when (compile load eval) (proclaim '(inline ,name)))
+       (defun ,name (,@required-args &optional stream ,@optional-args)
+	 (cond ((null stream) (setq stream *standard-output*))
+	       ((eql stream t) (setq stream *terminal-io*)))
+	 (,method-name stream ,@pass-args))
+
+       ;; Define a default method for the generic function that calls back to the
+       ;; system stream implementation.  Call back via a message if there is one,
+       ;; otherwise via the Common Lisp function.
+       ;; Uses T as a parameter specializer name as a standin for cl:stream,
+       ;; which Genera doesn't support as a builtin class
+       (defmethod ,method-name ((stream t) ,@method-args)
+	 (,cl-name ,@required-args stream ,@pass-keys)))))
+
+(write-forwarding-cl-output-stream-function write-byte (integer))
+
+(write-forwarding-cl-output-stream-function write-char (character))
+
+(write-forwarding-cl-output-stream-function write-string (string &key (start 0) end))
+
+(write-forwarding-cl-output-stream-function terpri ())
+
+(write-forwarding-cl-output-stream-function fresh-line ())
+
+(write-forwarding-cl-output-stream-function force-output ())
+
+(write-forwarding-cl-output-stream-function finish-output ())
+
+(write-forwarding-cl-output-stream-function clear-output ())
+
+
+;;; Input functions
+
+(defmacro write-forwarding-cl-input-stream-function (name lambda-list
+						     &key eof
+							  additional-arguments)
+  (let* ((cl-name (find-symbol (symbol-name name) (find-package 'lisp)))
+	 (method-name (intern (lisp:format nil "STREAM-~A" (symbol-name name))))
+	 (method-lambda-list (remove 'stream lambda-list))
+	 (args (mapcar #'(lambda (var) (if (atom var) var (first var)))
+		       (remove-if #'(lambda (x) (member x lambda-list-keywords))
+				  lambda-list)))
+	 (stream-args (remove 'stream args))
+	 (cleanup `(cond ((null stream) (setq stream *standard-input*))
+			 ((eql stream t) (setq stream *terminal-io*))))
+	 (call-method `(,method-name stream ,@stream-args)))
+    (when (member (first (last method-lambda-list)) lambda-list-keywords)
+      (setf method-lambda-list (butlast method-lambda-list)))
+    `(clim-utils:define-group ,name write-forwarding-cl-input-stream-function
+       (eval-when (compile load eval) (proclaim '(inline ,name)))
+       ,(if eof
+	    (let ((args `(eof-error-p eof-value ,@(and (not (eq eof :no-recursive))
+						       '(recursive-p)))))
+	      `(defun ,name (,@lambda-list ,@args)
+		 ,cleanup
+		 (let ((result ,call-method))
+		   (cond ((not (eq result :eof))
+			  result)
+			 (eof-error-p
+			  (signal-stream-eof stream ,@(and (not (eq eof :no-recursive))
+							   '(recursive-p))))
+			 (t
+			  eof-value)))))
+	    `(defun ,name ,lambda-list
+	       ,cleanup
+	       ,call-method))
+
+       ;; Define a default method for the generic function that calls back to the
+       ;; system stream implementation.  Call back via a message if there is one,
+       ;; otherwise via the Common Lisp function.
+       (defmethod ,method-name ((stream t) ,@method-lambda-list)
+	 (,cl-name ,@additional-arguments ,@args ,@(and eof `(nil :eof)))))))
+
+(write-forwarding-cl-input-stream-function read-byte (&optional stream) :eof :no-recursive)
+
+(write-forwarding-cl-input-stream-function read-char (&optional stream) :eof t)
+
+(write-forwarding-cl-input-stream-function unread-char (character &optional stream))
+
+(write-forwarding-cl-input-stream-function read-char-no-hang (&optional stream) :eof t)
+
+;;(write-forwarding-cl-input-stream-function peek-char (&optional stream)
+;;					     :eof t :additional-arguments (nil))
+
+;;; Rewritten for true Gray stream proposal.
+;;; STREAM-PEEK-CHAR doesn't get a peek-type; that's all handled at the PEEK-CHAR level.
+(defun peek-char (&optional peek-type input-stream (eof-error-p t)
+			    eof-value recursive-p)
+  (declare (ignore recursive-p))
+  (case input-stream
+    ((nil) (setf input-stream *standard-input*))
+    ((t)   (setf input-stream *standard-output*)))
+  (assert (or (null peek-type) (eq peek-type t) (characterp peek-type))
+      (peek-type)
+    "Illegal peek type ~S" peek-type)
+  (loop
+    (let ((ch (stream-peek-char input-stream)))
+      (cond ((eq ch :eof)
+	     (if eof-error-p
+		 (signal-stream-eof input-stream recursive-p)
+		 (return-from peek-char eof-value)))
+	    ((or (null peek-type)
+		 (and (eq peek-type t)
+		      ;; --- Sorry, bad modularity.  Fixed in 2.0 packages
+		      (not (clim-internals::whitespace-char-p ch)))
+		 (eq peek-type ch))
+	     (return-from peek-char ch))))))
+
+(write-forwarding-cl-input-stream-function listen (&optional stream))
+
+(write-forwarding-cl-input-stream-function read-line (&optional stream) :eof t)
+
+(write-forwarding-cl-input-stream-function clear-input (&optional stream))
+
+(defun signal-stream-eof (stream &optional recursive-p)
+  (declare (ignore recursive-p))
+  (error 'end-of-file :stream stream))
+
+
+;;; PATHNAME and TRUENAME
+
+(defgeneric pathname (stream))
+
+(defmethod pathname (stream)
+  (lisp:pathname stream))
+
+(deftype pathname () 'lisp:pathname)
+
+
+(defgeneric truename (stream))
+
+(defmethod truename (stream)
+  (lisp:truename stream))
+
+
+;;; Make CLIM-LISP:FORMAT do something useful on CLIM windows.
+
+(defun format (stream format-control &rest format-args)
+  (when (null stream)
+    (return-from format
+      (apply #'lisp:format nil format-control format-args)))
+  (when (eq stream 't)
+    (setq stream *standard-output*))
+  (cond ((streamp stream)
+	 ;; this isn't going to quite work for ~&,
+	 ;; but it's better than nothing.
+	 (write-string (apply #'lisp:format nil format-control format-args) stream)
+	 nil)
+	(t
+	 (apply #'lisp:format stream format-control format-args))))
diff --git a/utils/clim-macros.lisp b/utils/clim-macros.lisp
new file mode 100644
index 00000000..df089b63
--- /dev/null
+++ b/utils/clim-macros.lisp
@@ -0,0 +1,123 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: clim-defs.lisp,v 1.4 91/03/26 12:47:12 cer Exp $
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+;;--- These need to be moved into CLIM-UTILS somewhere...
+(defmacro default-output-stream (stream &optional must-be-variable-macro-name)
+  `(cond ((member ,stream '(t nil))
+	  (setq ,stream '*standard-output*))
+	 ,@(when must-be-variable-macro-name
+	     `(((not (and (symbolp ,stream)
+			  (not (keywordp ,stream))))
+		(warn "The stream argument to ~S, ~S, is invalid.~@
+		       This argument must be a variable that can be bound to a new stream."
+		      ',must-be-variable-macro-name ,stream)
+		(setq ,stream '*standard-output*))))))
+
+(defmacro default-input-stream (stream &optional must-be-variable-macro-name)
+  `(cond ((member ,stream '(t nil))
+	  (setq ,stream '*standard-input*))
+	 ,@(when must-be-variable-macro-name
+	     `(((not (and (symbolp ,stream)
+			  (not (keywordp ,stream))))
+		(warn "The stream argument to ~S, ~S, is invalid.~@
+		       This argument must be a variable that can be bound to a new stream."
+		      ',must-be-variable-macro-name ,stream)
+		(setq ,stream '*standard-input*))))))
+
+(defmacro default-query-stream (stream &optional must-be-variable-macro-name)
+  `(cond ((member ,stream '(t nil))
+	  (setq ,stream '*query-io*))
+	 ,@(when must-be-variable-macro-name
+	     `(((not (and (symbolp ,stream)
+			  (not (keywordp ,stream))))
+		(warn "The stream argument to ~S, ~S, is invalid.~@
+		       This argument must be a variable that can be bound to a new stream."
+		      ',must-be-variable-macro-name ,stream)
+		(setq ,stream '*query-io*))))))
+
+
+;;; Drawing state macros
+
+(defmacro with-clipping-region ((stream region) &body body)
+  (default-output-stream stream with-clipping-region)
+  `(flet ((with-clipping-region-body (,stream) ,@body))
+     (declare (dynamic-extent #'with-clipping-region-body))
+     (invoke-with-clipping-region ,stream #'with-clipping-region-body ,region)))
+
+(defmacro with-drawing-options ((medium &rest options) &body body)
+  (declare (arglist (medium
+		     &key ink clipping-region transformation
+			  line-style line-unit line-thickness line-dashes
+			  line-joint-shape line-cap-shape
+			  text-style text-family text-face text-size)))
+  #+Genera (declare (zwei:indentation 0 3 1 1))
+  (default-output-stream medium)
+  `(flet ((with-drawing-options-body () ,@body))
+     (declare (dynamic-extent #'with-drawing-options-body))
+     (invoke-with-drawing-options ,medium #'with-drawing-options-body ,@options)))
+
+(defmacro with-identity-transformation ((medium) &body body)
+  `(letf-globally (((medium-transformation ,medium) +identity-transformation+))
+     ,@body))
+
+(defmacro with-translation ((medium dx dy) &body body)
+  `(with-drawing-options (,medium
+			  :transformation (make-translation-transformation ,dx ,dy))
+     ,@body))
+ 
+(defmacro with-scaling ((medium sx &optional (sy nil sy-p)) &body body)
+  `(with-drawing-options (,medium
+			  :transformation (let* ((scale-x ,sx)
+						 (scale-y ,(if sy-p sy 'scale-x)))
+					    (make-scaling-transformation scale-x scale-y)))
+     ,@body))
+ 
+(defmacro with-rotation ((medium angle &optional (origin nil origin-p)) &body body)
+  `(with-drawing-options (,medium
+			  :transformation (make-rotation-transformation ,angle
+									,@(if origin-p `(,origin) nil)))
+     ,@body))
+
+;; Establish a local +Y-downward coordinate system at the current cursor position,
+;; and execute the body
+(defmacro with-local-coordinates ((&optional stream x y) &body body)
+  (default-output-stream stream with-local-coordinates)
+  (let ((cx '#:cx) (cy '#:cy)
+	(tx '#:tx) (ty '#:ty))
+    `(let ((,cx ,x)
+	   (,cy ,y))
+       (unless (and ,cx ,cy)
+	 (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream)))
+       (multiple-value-bind (,tx ,ty)
+	   (transform-point* (medium-transformation ,stream) 0 0)
+	 (with-drawing-options
+	     (,stream :transformation (make-translation-transformation
+					(- ,cx ,tx) (- ,cy ,ty)))
+	   ,@body)))))
+
+;; Establish a local +Y-upward coordinate system at the current cursor position,
+;; and execute the body
+(defmacro with-first-quadrant-coordinates ((&optional stream x y) &body body)
+  (default-output-stream stream with-first-quadrant-coordinates)
+  (let ((cx '#:cx) (cy '#:cy)
+	(tx '#:tx) (ty '#:ty))
+    `(let ((,cx ,x)
+	   (,cy ,y))
+       (unless (and ,cx ,cy)
+	 (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream)))
+       (multiple-value-bind (,tx ,ty)
+	   (transform-point* (medium-transformation ,stream) 0 0)
+	 (with-drawing-options
+	     ;; Don't flip the stream over if we already have
+	     (,stream :transformation (if (silica::medium-+Y-upward-p ,stream)
+					  +identity-transformation+
+					  (make-transformation 1 0 0 -1
+							       (- ,cx ,tx) (- ,cy ,ty))))
+	   (letf-globally (((silica::medium-+Y-upward-p ,stream) t))
+	     ,@body))))))
diff --git a/utils/clim-streams.lisp b/utils/clim-streams.lisp
new file mode 100644
index 00000000..83b2df26
--- /dev/null
+++ b/utils/clim-streams.lisp
@@ -0,0 +1,24 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: clim-defs.lisp,v 1.4 91/03/26 12:47:12 cer Exp $
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+;; STANDARD-ENCAPSULATING-STREAM needs to be defined early on, because many methods are
+;; written on this class.
+
+(define-protocol-class encapsulating-stream (fundamental-stream))
+
+;; These aren't really "encapsulating" streams, they're "delegating streams."
+;; What about the delegation ("multiple self", "xstream") problem?
+;; See *ORIGINAL-STREAM* for some more information.
+(defclass standard-encapsulating-stream 
+	  (encapsulating-stream)
+    ((stream :initarg :stream
+	     :reader encapsulating-stream-stream))
+  #+Allegro (:default-initargs :element-type 'extended-char))
+
+
diff --git a/utils/coral-char-bits.lisp b/utils/coral-char-bits.lisp
new file mode 100644
index 00000000..5872eaf1
--- /dev/null
+++ b/utils/coral-char-bits.lisp
@@ -0,0 +1,44 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1991 International Lisp Associates.  All rights reserved."
+
+;; What a pain.  Symbolics wrote the code to deal with CHAR-BITS, but
+;; there ain't no such thing in ANSI CL.  Here in Coral, at least, we
+;; can temporarily kludge around it.
+(defun %set-char-bits (ch b)
+  (declare (fixnum ch)) ; a lie
+  (let ((mask (ash b (- 8 3)))) ; fixnums are "shifted left" three bits
+    (declare (fixnum mask))
+    ; I'm so ashamed
+    (logior ch mask)))
+
+(defun char-bits (ch)
+  (declare (fixnum ch))
+  ;; Extremely gross
+  (ccl::lsh (logand ch (ash #x0000FF00 -3)) -5))
+
+;; CHAR= has been shadowed in PKGDCL
+(declaim (inline char=))
+
+(defun char= (ch1 ch2)
+  (declare (fixnum ch1 ch2))
+  ;; Really gross!
+  (ccl::require-type ch1 'character)
+  (ccl::require-type ch2'character)
+  (= ch1 ch2))
+
+(defmacro shadow-char-p-function (name)
+  (let ((lisp-name (intern (symbol-name name) 'lisp)))
+    `(defun ,name (char)
+       (let ((bits (char-bits char)))
+         (cond ((zerop bits)
+                (,lisp-name char))
+               (t nil))))))
+
+(shadow-char-p-function graphic-char-p)
+(shadow-char-p-function standard-char-p)
+(shadow-char-p-function alpha-char-p)
+
+;; --- do we need to shadow ALPHANUMERICP ?
diff --git a/utils/genera-streams.lisp b/utils/genera-streams.lisp
new file mode 100644
index 00000000..77d91396
--- /dev/null
+++ b/utils/genera-streams.lisp
@@ -0,0 +1,116 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;; Genera doesn't define STREAM-ELEMENT-TYPE as a generic function, so
+;; we need to shadow it here.
+(defgeneric stream-element-type (stream)
+  (:selector :stream-element-type))
+
+(defmethod stream-element-type ((stream si:stream))
+  (common-lisp:stream-element-type stream))
+
+;; Ditto, CLOSE
+(defgeneric close (stream &key abort))
+
+(defmethod close ((stream t) &key abort)
+  (common-lisp:close stream :abort abort))
+
+
+(defgeneric pathname (stream))
+
+(defmethod pathname (stream)
+  (lisp:pathname stream))
+
+(deftype pathname () 'lisp:pathname)
+
+
+(defgeneric truename (stream))
+
+(defmethod truename (stream)
+  (lisp:truename stream))
+
+
+;;; Define the "reverse trampolines" for Genera, that is, stream methods on
+;;; non-CLIM streams that trampoline back into Genera stream operations.
+
+(defgeneric stream-read-byte (stream))
+(defmethod stream-read-byte ((stream t))
+  (or (scl:send stream :tyi nil)
+      :eof))
+
+(defgeneric stream-read-char (stream))
+(defmethod stream-read-char ((stream t))
+  (or (scl:send stream :tyi nil)
+      :eof))
+
+(defgeneric stream-unread-char (stream character)
+  (:selector :untyi))
+(defmethod stream-unread-char ((stream t) character)
+  (scl:send stream :untyi character))
+
+(defgeneric stream-read-char-no-hang (stream))
+(defmethod stream-read-char-no-hang ((stream t))
+  (or (scl:send stream :tyi-no-hang nil)
+      :eof))
+
+(defgeneric stream-peek-char (stream))
+(defmethod stream-peek-char ((stream t))
+  (or (scl:send stream :tyipeek nil)
+      :eof))
+
+(defgeneric stream-listen (stream)
+  (:selector :listen))
+(defmethod stream-listen ((stream t))
+  (scl:send stream :listen))
+
+(defgeneric stream-read-line (stream)
+  (:selector :line-in))
+(defmethod stream-read-line ((stream t))
+  (read-line stream nil :eof)) ;; Doesn't map well into :LINE-IN.
+
+(defgeneric stream-clear-input (stream)
+  (:selector :clear-input))
+(defmethod stream-clear-input ((stream t))
+  (scl:send stream :clear-input))
+
+
+(defgeneric stream-write-byte (stream char))
+(defmethod stream-write-byte ((stream t) integer)
+  (scl:send stream :tyo integer))
+
+(defgeneric stream-write-char (stream char)
+  (:selector :tyo))
+(defmethod stream-write-char ((stream t) character)
+  (scl:send stream :tyo character))
+
+(defgeneric stream-write-string (stream string &optional start end)
+  (:selector :string-out))
+(defmethod stream-write-string ((stream t) string &optional (start 0) end)
+  (scl:send stream :string-out string start end))
+
+(defgeneric stream-terpri (stream))
+(defmethod stream-terpri ((stream t))
+  (scl:send stream :tyo #\Newline))
+
+(defgeneric stream-fresh-line (stream)
+  (:selector :fresh-line))
+(defmethod stream-fresh-line ((stream t))
+  (scl:send stream :fresh-line))
+
+(defgeneric stream-force-output (stream)
+  (:selector :force-output))
+(defmethod stream-force-output ((stream t))
+  (scl:send stream :force-output))
+
+(defgeneric stream-finish-output (stream)
+  (:selector :finish))
+(defmethod stream-finish-output ((stream t))
+  (scl:send stream :finish))
+
+(defgeneric stream-clear-output (stream)
+  (:selector :clear-output))
+(defmethod stream-clear-output ((stream t))
+  (scl:send stream :clear-output))
diff --git a/utils/lisp-package-fixups.lisp b/utils/lisp-package-fixups.lisp
new file mode 100644
index 00000000..e599d936
--- /dev/null
+++ b/utils/lisp-package-fixups.lisp
@@ -0,0 +1,69 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10 -*-
+
+#+ANSI-90 (in-package :cl-user)
+
+#-ANSI-90 (in-package :user)
+
+"Copyright (c) 1991 by International Lisp Associates.  All Rights Reserved."
+
+;;; The point of this file is to give CLIM a consistent naming scheme
+;;; for the LISP and USER packages, no matter what they are actually
+;;; called in any given Lisp environment.
+
+;;; These two forms should be merged into one facility that does the
+;;; right thing, but I am trying to make the minimal change since it
+;;; is shortly before the MCL CLIM release.  The two forms were both
+;;; loaded as part of building CLIM before I moved them into this
+;;; file, so they ought to work as well together in this file as they
+;;; did separately in defsystem and sysdcl.
+;;;
+;;; I only moved them at all so that the magic they do to packages did
+;;; not rely on having the "extra-CLIM" files DEFSYSTEM and SYSDCL
+;;; loaded in order to load or run CLIM.  That is, I moved the forms
+;;; from files that are loaded only to compile/build CLIM into a file
+;;; that is actually part of CLIM.
+
+;;; *** A temporary workaround, easier than fixing all references to
+;;; *** LISP:<foo>.  --RWK 20.Nov.90
+;;; Copied here from defsystem.lisp by York, 5 June 91.
+;;; The point of this is to add all the common old aliases for
+;;; the ANSI-named COMMON-LISP and COMMON-LISP-USER packages.
+;;; I left a copy of this form in defsystem.lisp so that defsystem
+;;; can be compiled (it has lots of references to LISP: symbols).
+#+ANSI-90
+(eval-when (eval compile load)
+  (flet ((fix-package (pack-name add-name)
+	   (setq add-name (string add-name))
+	   (let ((pack (find-package pack-name)))
+	     (assert (not (null pack)) ()
+		     "Attempting to add the name ~S to package ~S, which doesn't exist")
+	     (when (null (find-package add-name))
+	       (let (#+excl(excl::*enable-package-locked-errors* nil))
+		 (rename-package pack (package-name pack)
+				 (list* add-name (package-nicknames pack))))))))
+    (fix-package "COMMON-LISP" "LISP")
+    (fix-package "COMMON-LISP" "CL") ;; ??
+    (fix-package "COMMON-LISP-USER" "USER")
+    (fix-package "COMMON-LISP-USER" "CL-USER")) ;; ??
+  (when (null (find-package "SYSTEM"))
+    (defpackage system))
+)	;eval-when
+
+;;; Moved here from sysdcl.lisp, York, 5 June 91 The point of this one
+;;; is really to add the ANSI names COMMON-LISP and COMMON-LISP-USER
+;;; to the LISP and USER packages found in non-ANSI Lisps.
+(eval-when (compile load eval)
+  (flet ((clean-up-package (old-package-name primary-name required-nicknames)
+	   (let* ((package (or (find-package old-package-name)
+			       (find-package primary-name)))
+		  (old-name (package-name package))
+		  (old-nicknames (package-nicknames package)))
+	     (let (#+excl(excl::*enable-package-locked-errors* nil))
+	       (rename-package package primary-name
+			       (remove primary-name (union (cons old-name old-nicknames)
+							   required-nicknames
+							   :test #'string-equal)
+				       :test #'string-equal))))))
+    (clean-up-package "LISP" "COMMON-LISP" '("CL"))
+    (clean-up-package "USER" "COMMON-LISP-USER" '("CL-USER")))
+  )					;eval-when
diff --git a/utils/minima-stream-classes.lisp b/utils/minima-stream-classes.lisp
new file mode 100644
index 00000000..7c31b266
--- /dev/null
+++ b/utils/minima-stream-classes.lisp
@@ -0,0 +1,39 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+;;; Disgusting but apparently effective...
+(setf (find-class 'fundamental-stream)
+      (find-class 'minima-internals::stream))
+(setf (find-class 'fundamental-input-stream)
+      (find-class 'minima-internals::input-stream))
+(setf (find-class 'fundamental-output-stream)
+      (find-class 'minima-internals::output-stream))
+(setf (find-class 'fundamental-character-stream)
+      (find-class 'minima-internals::character-stream))
+(setf (find-class 'fundamental-binary-stream)
+      (find-class 'minima-internals::binary-stream))
+(setf (find-class 'fundamental-character-input-stream)
+      (find-class 'minima-internals::character-input-stream))
+(setf (find-class 'fundamental-character-output-stream)
+      (find-class 'minima-internals::character-output-stream))
+(setf (find-class 'fundamental-binary-input-stream)
+      (find-class 'minima-internals::binary-input-stream))
+(setf (find-class 'fundamental-binary-output-stream)
+      (find-class 'minima-internals::binary-output-stream))
+
+#+Minima-Runtime
+(defun sqrt (x)
+  (etypecase x
+    (rational
+      (let* ((num (numerator x))
+	     (den (denominator x))
+	     (shift (- 10 (min (integer-length num) (integer-length den) 10))))
+	(/ (isqrt (ash num shift)) (isqrt (ash den shift)))))
+    ))
+
+(defun char-bits (char)
+  (declare (ignore char))
+  0)
diff --git a/utils/processes.lisp b/utils/processes.lisp
new file mode 100644
index 00000000..5751f565
--- /dev/null
+++ b/utils/processes.lisp
@@ -0,0 +1,259 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-utils)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+;;; Processes and locks
+
+(defvar *multiprocessing-p* 
+  #{
+    (or Allegro Genera Lucid Lispworks Minima) T
+    otherwise nil
+    }
+    )
+  
+#+Allegro
+(unless (excl::scheduler-running-p)
+  (mp:start-scheduler))
+
+(defmacro with-lock-held ((place &optional state) &body forms)
+  #+(or Allegro Xerox Genera ccl Minima)
+  (declare (ignore state #+ccl place))
+  #{
+    Allegro	`(mp:with-process-lock (,place) ,@forms)
+    Lucid	`(lcl:with-process-lock (,place ,@(if state (cons state nil)))
+		   ,@forms)
+    lispworks	`(mp::with-lock (,place) ,@forms)
+    Xerox	`(il:with.monitor ,place ,@forms)
+    Cloe-Runtime `(progn ,@forms)
+    Genera	`(process:with-lock (,place) ,@forms)
+    Minima	`(minima:with-lock (,place) ,@forms)
+    CCL-2	`(progn ,@forms)
+    }
+  )
+
+(defun make-lock (&optional (lock-name "a CLIM lock"))
+  #-(or Genera Minima) (declare (ignore lock-name))
+  #{
+    Allegro	(mp::make-process-lock)
+    lispworks	(mp::make-lock)
+    Lucid	nil
+    CCL-2	nil
+    Xerox	(il:create.monitorlock)
+    Cloe-Runtime nil
+    Genera	(process:make-lock lock-name)
+    Minima	(minima:make-lock lock-name)
+   }
+  )
+
+;;; A lock that CAN be relocked by the same process.
+#-(or Genera Minima)
+(defmacro with-simple-recursive-lock ((lock &optional (state "Unlock")) &body forms)
+  `(flet ((foo () ,@forms))
+     (declare (dynamic-extent #'foo))
+     (invoke-with-simple-recursive-lock ,lock ,state #'foo)))
+
+#-(or Genera Minima)
+(defun invoke-with-simple-recursive-lock (place state continuation)
+  (let ((store-value (current-process))
+	(place-value (first place)))
+    (if (and place-value (eql place-value store-value))
+	(funcall continuation)
+	(progn
+	  (unless (null place-value)
+	    (flet ((waiter ()
+		     (null (first place))))
+	      (declare (dynamic-extent #'waiter))
+	      (process-wait state #'waiter)))
+	  (unwind-protect
+	      (progn (rplaca place store-value)
+		     (funcall continuation))
+	    (rplaca place nil))))))
+
+(defmacro with-recursive-lock-held ((place &optional state) &body forms)
+  #+(or Allegro Xerox Genera ccl Minima)
+  (declare (ignore state #+ccl place))
+  #{Genera `(process:with-lock (,place) ,@forms)
+    Minima `(minima:with-lock (,place) ,@forms)
+    CCL-2 `(progn ,@forms)
+    otherwise `(with-simple-recursive-lock (,place ,state) ,@forms)
+    }
+  )
+
+(defun make-recursive-lock (&optional (lock-name "a recursive CLIM lock"))
+  #-(or Genera Minima) (declare (ignore lock-name))
+  #{CCL-2 nil
+    Genera (process:make-lock lock-name :recursive T)
+    Minima (minima:make-lock lock-name :recursive T)
+    otherwise (cons nil nil)
+   }
+  )
+
+(defmacro without-scheduling (&body forms)
+  "Evaluate the forms w/o letting any other process run."
+  #{
+    Allegro    `(mp:without-scheduling ,@forms)
+    lispworks  `(sys::without-scheduling ,@forms)
+    Lucid      `(lcl:with-scheduling-inhibited ,@forms)
+    Xerox      `(progn ,@forms)
+    Cloe-Runtime `(progn ,@forms)
+    ;; should be process:with-no-other-processes if this is used as
+    ;; a global locking mechanism
+    Genera     `(scl:without-interrupts ,@forms)
+    Minima     `(minima:with-no-other-processes ,@forms)
+    CCL-2      `(ccl:without-interrupts ,@forms) ; slh
+   }
+   )
+
+(defun make-process (function &key name)
+  #+(or ccl) (declare (ignore function name))
+  (when *multiprocessing-p*
+    #{
+    lispworks  (mp:process-run-function name nil function)
+    Lucid      (lcl:make-process :function function :name name)
+    Allegro    (mp:process-run-function name function)
+    Xerox      (il:add.process (funcall function) 'il:name name)
+    Genera     (scl:process-run-function name function)
+    Minima     (minima:make-process name :initial-function function)
+    otherwise  (warn "No implementation of MAKE-PROCESS for this system.")
+    }))
+
+(eval-when (compile load eval) (proclaim '(inline processp)))
+(defun processp (object)
+  #{
+  ccl        (member object '(:user :event :interrupt))
+  Lucid	     (lcl:processp object)
+  Allegro    (mp::process-p object)
+  lispworks  (mp::process-p object)
+  ;; In 7.3 and after it is `(process:process-p ,object)
+  Genera     (process:process-p object)
+  Minima     (typep object 'minima-internals::basic-process)
+  otherwise  (progn (warn "No implementation of PROCESSP for this system.")
+		    nil)
+  }
+  )
+
+(defun destroy-process (p)
+  #+(or ccl) (declare (ignore p))
+  #{
+  Lucid      (lcl:kill-process p)
+  Allegro    (mp:process-kill p)
+  lispworks  (mp:process-kill p)
+  Xerox	     (il:del.process p)
+  Genera     (scl:process-kill p)
+  Minima     (minima:process-kill p)
+  CCL-2	     nil
+  otherwise  (warn "No implementation of DESTROY-PROCESS for this system.")
+  }
+  )
+
+#+CCL-2
+(defvar *current-process* :user)
+
+(eval-when (compile load eval) (proclaim '(inline current-process)))
+(defun current-process ()
+  #{
+  Lucid      lcl:*current-process*
+  Allegro    mp:*current-process*
+  lispworks  mp:*current-process*
+  Xerox	     (il:this.process)
+  Genera     scl:*current-process*
+  Minima     (minima:current-process)
+  CCL-2	     *current-process*
+  Cloe-Runtime nil
+  }
+  )
+
+(eval-when (compile load eval) (proclaim '(inline all-processes)))
+(defun all-processes ()
+  #{
+  Lucid      lcl:*all-processes*
+  Allegro    mp:*all-processes*
+  lispworks  (mp::list-all-processes)
+  Genera     sys:all-processes
+  CCL-2	     (adjoin *current-process* '(:user))
+  Cloe-Runtime nil
+  }
+  )
+
+(defun show-processes ()
+  #{
+       Lucid	  (lcl::show-processes)
+       Genera	  (si:com-show-processes)
+       otherwise  (all-processes)
+  }
+  )
+  
+(eval-when (compile load eval) (proclaim '(inline process-yield)))
+(defun process-yield ()
+  #{
+  Lucid      (lcl:process-allow-schedule)
+  Allegro    (mp:process-allow-schedule)
+  lispworks  (mp::process-allow-scheduling)
+  Xerox	     (il:block)
+  Genera     (scl:process-allow-schedule)
+  Minima     (sleep 1/10)
+  CCL-2	     (ccl:event-dispatch)
+  Cloe-Runtime nil
+  }
+  )
+
+(defun process-wait (wait-reason predicate)
+  "Cause the current process to go to sleep until the predicate returns TRUE."
+  #{
+  Lucid      (lcl:process-wait wait-reason predicate)
+  Allegro    (mp:process-wait wait-reason predicate)
+  lispworks  (mp:process-wait wait-reason predicate)
+  Xerox	     (let ((il:*who-line-state* wait-reason))
+	       (loop
+		 (il:block)
+		 (when (and (funcall predicate))
+		   (return))))
+  CCL-2	     (ccl::process-wait wait-reason predicate)
+  Cloe-Runtime nil
+  Genera     (scl:process-wait wait-reason predicate)
+  Minima     (minima:process-wait wait-reason predicate)
+  otherwise  (progn (compile-time-warn "Need an implementation for PROCESS-WAIT")
+		    (error "~S doesn't have a definition.  Args are ~S ~S"
+			   'process-wait wait-reason predicate))
+  }
+  )
+
+(defun process-wait-with-timeout (wait-reason timeout predicate)
+  "Cause the current process to go to sleep until the predicate returns TRUE or
+   timeout seconds have gone by." 
+  (when (null timeout)
+    ;; ensure genera semantics, timeout = NIL means indefinite timeout
+    (return-from process-wait-with-timeout
+      (process-wait wait-reason predicate)))
+  #{
+  Allegro    (mp:process-wait-with-timeout wait-reason timeout predicate)
+  lispworks  (mp:process-wait-with-timeout wait-reason timeout predicate)
+  Lucid	     (lcl:process-wait-with-timeout wait-reason timeout predicate)
+  Genera     (sys:process-wait-with-timeout wait-reason (* timeout 60.) predicate)
+  CCL-2	     (ccl::process-wait-with-timeout wait-reason timeout predicate)
+  otherwise  (progn (compile-time-warn "Need an implementation for process-wait-with-timeout")
+		    (error "~S doesn't have a definition.  Args are ~S ~S ~S"
+			   'process-wait-with-timeout timeout wait-reason predicate))
+  }
+  )
+
+(defun process-interrupt (process closure)
+  (declare #+CCL-2 (ignore process))
+  #{
+  Lucid     (lcl:interrupt-process process closure)
+  Allegro   (mp:process-interrupt process closure)
+  ;; ---    Is Lispworks' the same as Allegro?
+  ;; ---    It is for everything else except ALL-PROCESSES.
+  Genera    (scl:process-interrupt process closure)
+  CCL-2     (let ((*current-process* :interrupt))
+	      (funcall closure))
+  Minima    (minima:process-interrupt process closure)
+  otherwise (progn
+	      (compile-time-warn "Need an implementation for process-interrupt")
+	      (error "~S doesn't have a definition.  Args are ~S ~S"
+		     'process-interrupt process closure))
+  }
+  )
-- 
GitLab