From 3c273fc0787c4e5dfe96222e26ce6dc1d4f9a322 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Fri, 22 May 1992 19:29:39 +0000
Subject: [PATCH] miscfixes

---
 Makefile                          |  24 +-
 clim/accept-values.lisp           | 406 +++++++++++++------------
 clim/basic-translators.lisp       |   4 +-
 clim/command-processor.lisp       |   4 +-
 clim/command.lisp                 |  17 +-
 clim/cursor.lisp                  |   8 +-
 clim/db-stream.lisp               | 165 +++++------
 clim/drag-and-drop.lisp           |   5 +-
 clim/frames.lisp                  | 323 ++++++++++----------
 clim/gadget-output.lisp           | 294 +++++++++---------
 clim/gestures.lisp                | 104 +++++--
 clim/graph-formatting.lisp        |  15 +-
 clim/graphics-recording.lisp      | 215 ++++++--------
 clim/incremental-redisplay.lisp   |   6 +-
 clim/input-editor-commands.lisp   |  35 ++-
 clim/input-protocol.lisp          | 138 ++-------
 clim/interactive-defs.lisp        |  21 +-
 clim/interactive-protocol.lisp    |  57 ++--
 clim/item-list-manager.lisp       |   6 +-
 clim/menus.lisp                   | 147 ++-------
 clim/noting-progress.lisp         |   6 +
 clim/output-protocol.lisp         | 232 ++++++---------
 clim/pixmap-streams.lisp          |  22 +-
 clim/presentations.lisp           |  25 +-
 clim/ptypes1.lisp                 |  12 +-
 clim/ptypes2.lisp                 |   8 +-
 clim/recording-protocol.lisp      | 109 +------
 clim/stream-class-defs.lisp       |  23 +-
 clim/stream-defprotocols.lisp     | 100 +------
 clim/table-formatting.lisp        |  11 +-
 clim/text-recording.lisp          | 210 ++++++-------
 clim/tracking-pointer.lisp        |  99 +++----
 clim/view-defs.lisp               |   4 +-
 clim/window-stream.lisp           | 140 +--------
 clx/clx-frames.lisp               |  34 ++-
 clx/clx-medium.lisp               | 159 ++++++----
 clx/clx-mirror.lisp               |   7 +-
 clx/clx-port.lisp                 |   9 +-
 demo/address-book.lisp            |  10 +-
 demo/cad-demo.lisp                |   4 +-
 demo/demo-driver.lisp             |  14 +-
 demo/graphics-demos.lisp          |  19 +-
 demo/listener.lisp                |  33 +--
 demo/navfun.lisp                  |   4 +-
 demo/puzzle.lisp                  |   4 +-
 demo/sysdcl.lisp                  |   4 +-
 demo/thinkadot.lisp               |   4 +-
 genera/genera-frames.lisp         | 122 +++++++-
 genera/genera-medium.lisp         | 167 +++++++----
 genera/genera-mirror.lisp         |   8 +-
 genera/genera-port.lisp           |  14 +-
 instclimol.lisp                   |   7 +-
 instclimxm.lisp                   |   6 +-
 misc/compile-1.lisp               |  10 +-
 misc/dev-load-1.lisp              |  10 +-
 silica/classes.lisp               |   5 +-
 silica/db-box.lisp                | 107 ++++---
 silica/db-button.lisp             | 106 +++----
 silica/db-layout.lisp             | 230 +++++++--------
 silica/db-scroll.lisp             | 327 ++++++++++-----------
 silica/db-slider.lisp             |  40 +--
 silica/event.lisp                 |  91 +++---
 silica/framem.lisp                |  49 ++-
 silica/gadgets.lisp               | 239 ++++++++-------
 silica/graphics.lisp              | 230 ++++++---------
 silica/layout.lisp                |  29 +-
 silica/medium.lisp                |   5 +-
 silica/mirror.lisp                |  36 +--
 silica/port.lisp                  |   7 +-
 silica/protocols.lisp             |   4 +-
 silica/sheet.lisp                 |  31 +-
 sys/defsystem.lisp                |  42 +--
 sys/sysdcl.lisp                   | 125 +++-----
 test/chess.lisp                   |  98 +++---
 test/test-suite.lisp              |  25 +-
 test/test.lisp                    | 474 +++++++++++++++---------------
 tk-silica/ol-frames.lisp          | 150 +++++++++-
 tk-silica/ol-gadgets.lisp         | 387 +++++++++++++++++++++---
 tk-silica/ol-silica.lisp          |  53 +++-
 tk-silica/xm-frames.lisp          | 232 +++++++++------
 tk-silica/xm-gadgets.lisp         | 154 +++++-----
 tk-silica/xm-menus.lisp           | 213 +-------------
 tk-silica/xm-silica.lisp          |  48 +--
 tk-silica/xt-frames.lisp          | 130 +++++++-
 tk-silica/xt-gadgets.lisp         |  22 +-
 tk-silica/xt-graphics.lisp        |  37 +--
 tk-silica/xt-silica.lisp          | 164 +++++++----
 tk/callbacks.lisp                 |   3 +-
 tk/event.lisp                     |   5 +-
 tk/font.lisp                      |   5 +-
 tk/foreign.lisp                   |  22 +-
 tk/gcontext.lisp                  |   8 +-
 tk/load-ol.lisp                   |  12 +-
 tk/load-xm.lisp                   |  19 +-
 tk/make-classes.lisp              |   2 +-
 tk/ol-callbacks.lisp              |  17 +-
 tk/ol-defs.lisp                   |   5 +-
 tk/ol-funs.lisp                   |   8 +-
 tk/ol-init.lisp                   |   3 +-
 tk/resources.lisp                 |  10 +-
 tk/widget.lisp                    |  17 +-
 tk/xlib.lisp                      |  28 +-
 tk/xt-funs.lisp                   |   2 +-
 tk/xt-init.lisp                   |   3 +-
 utils/autoconstructor.lisp        |   6 +-
 utils/cl-stream-classes.lisp      |   3 +-
 utils/clos.lisp                   |   6 +-
 utils/defpackage.lisp             |   4 +-
 utils/defun.lisp                  |   6 +-
 utils/excl-verification.lisp      |   7 +-
 utils/lisp-package-fixups.lisp    |  13 +-
 utils/lucid-stream-functions.lisp |  16 +-
 utils/packages.lisp               |  72 +++--
 utils/reader.lisp                 |   4 +-
 utils/regions.lisp                |   6 +-
 xlib/ffi.lisp                     |   3 +-
 xlib/load-xlib.lisp               |   9 +-
 xlib/pkg.lisp                     |   2 +-
 xlib/x11-keysyms.lisp             |   6 +-
 119 files changed, 3932 insertions(+), 3934 deletions(-)

diff --git a/Makefile b/Makefile
index 316a0d4d..d77e260e 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.28 92/05/13 17:11:04 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.29 92/05/13 17:16:09 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
@@ -7,8 +7,9 @@ DUMP-CL	= $(CL)
 CLOPTS	= -qq
 
 # Training
-TRAIN_LISP= (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \
+TRAIN_LISP= (load \"tk-silica/test-clim.lisp\") \
 		(clim-user::train-clim-2) \
+		(compile-file "misc/clos-preload.cl") \
 		(exit 0) 
 
 TRAIN_TEXT = \
@@ -36,7 +37,7 @@ NEWSPACE = 5000000
 CLIM	= ./slim
 CLIM-SMALL	= ./slim-small
 
-PUBDIRS	= sys utils silica clim demo test genera clx
+PUBDIRS	= sys utils silica clim demo test genera clx pre-silica
 DIRS0	=  tk tk-silica misc
 DIRS	= $(PUBDIRS) xlib $(DIRS0)
 CHEAP_CLEAN	= $(PUBDIRS) $(DIRS0)
@@ -98,10 +99,8 @@ FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o `
 #
 DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \
 	     xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl \
-	     tk/xt-defs.fasl tk/xm-defs.fasl 
+	     tk/xt-defs.fasl tk/xm-defs.fasl tk/ol-defs.fasl
 
-# This should be in the clim-debug file but it seems a pain to have to compile it up
-# tk/ol-defs.fasl
 
 #
 # "Load time objects" -- these go into clim.fasl
@@ -194,8 +193,10 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \
                         clim/command-processor.fasl \
                         clim/basic-translators.fasl \
                         clim/frames.fasl \
+			clim/noting-progress.fasl \
                         clim/menus.fasl \
                         clim/accept-values.fasl \
+			clim/drag-and-drop.fasl \
                         clim/item-list-manager.fasl \
                         clim/pixmap-streams.fasl \
                         clim/stream-trampolines.fasl
@@ -239,6 +240,7 @@ OL-CLIM-OBJS = tk/ol-classes.fasl \
 		tk/xt-funs.fasl \
 		tk/ol-funs.fasl \
                 tk/ol-init.fasl \
+		tk/ol-widgets.fasl \
                 tk/ol-callbacks.fasl \
                 tk/make-widget.fasl
 
@@ -339,6 +341,16 @@ clim-debug.fasl:	$(DEBUG-OBJS)
 	ls -lt clim-debug.fasl >> Clim-sizes.n
 	ls -lt clim-debug.fasl
 
+# We should only run these rules when
+# We do this because we because we might have only compiled one port
+
+tk/xm-defs.fasl : tk/xm-defs.lisp
+	echo Foo
+
+tk/ol-defs.fasl	: tk/ol-defs.lisp
+	echo Bar
+
+
 # Building
 
 clim-xm:	FORCE
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index d2d1d530..3e8fbc79 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: accept-values.lisp,v 1.19 92/05/06 15:37:34 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.20 92/05/07 13:11:54 cer Exp $
 
 (in-package :clim-internals)
 
@@ -106,10 +106,10 @@
 (defmethod find-or-add-query ((stream accept-values-stream) query-identifier ptype prompt
 			      default default-supplied-p active-p)
   (let ((avv-record
-	  #-ignore (slot-value stream 'avv-record)
-	  #+ignore (find-accept-values-record
-		     (or (stream-current-output-record stream)
-			 (stream-output-history stream)))))
+	  #---ignore (slot-value stream 'avv-record)
+	  #+++ignore (find-accept-values-record
+		       (or (stream-current-output-record stream)
+			   (stream-output-history stream)))))
     (with-slots (query-table) avv-record
       (multiple-value-bind (query found-p)
 	  (gethash query-identifier query-table)
@@ -145,7 +145,8 @@
 				 :history ptype
 				 :present-p `(accept-values-choice ,query)
 				 :query-identifier query))
-		      ((and found-p (presentation-typep (accept-values-query-value query) ptype))
+		      ((and found-p
+			    (presentation-typep (accept-values-query-value query) ptype))
 		       ;; The programmer supplied no default, but a previous edit
 		       ;; has put something in the query that we now must use as
 		       ;; the default.
@@ -168,40 +169,55 @@
 	  (setf (gethash query-identifier query-table) query))
 	query))))
 
+;;--- These frames should be resourced
 (define-application-frame accept-values ()
     ((stream :initarg :stream)
      (exit-button-stream :initarg :exit-button-stream)
      (continuation :initarg :continuation)
-     (own-window :initform nil :initarg :own-window)
-     (own-window-x-position :initform nil :initarg :x-position)
-     (own-window-y-position :initform nil :initarg :y-position)
-     (own-window-width :initform nil :initarg :width)
-     (own-window-height :initform nil :initarg :height)
-     (own-window-right-margin :initform nil :initarg :right-margin)
-     (own-window-bottom-margin :initform nil :initarg :bottom-margin)
      (exit-boxes :initform nil :initarg :exit-boxes)
      (selected-item :initform nil)
      ;;--- Do this through RUN-FRAME-TOP-LEVEL?
      (initially-select-query-identifier :initform nil
 					:initarg :initially-select-query-identifier)
      (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass)
-     (check-overlapping :initform t :initarg :check-overlapping))
+     (check-overlapping :initform t :initarg :check-overlapping)
+     (own-window :initform nil :initarg :own-window))
   (:top-level (accept-values-top-level))
   (:command-definer t))
 
+;; Ignore extra initargs...
+(defmethod initialize-instance :after ((frame accept-values) 
+				       &key own-window
+					    x-position y-position width height
+					    right-margin bottom-margin)
+  (declare (ignore own-window
+		   x-position y-position width height
+		   right-margin bottom-margin)))
+
+#+what-the-\!
+(defmethod frame-top-level-sheet ((frame accept-values))
+  (frame-top-level-sheet (frame-calling-frame frame)))
+
+;;--- These frames should be resourced
 (define-application-frame accept-values-own-window (accept-values)
-    ()
+    ((own-window :initarg :own-window)
+     (own-window-x-position :initform nil :initarg :x-position)
+     (own-window-y-position :initform nil :initarg :y-position)
+     (own-window-width :initform nil :initarg :width)
+     (own-window-height :initform nil :initarg :height)
+     (own-window-right-margin :initform nil :initarg :right-margin)
+     (own-window-bottom-margin :initform nil :initarg :bottom-margin))
   (:pane 
-    (with-slots (stream own-window  exit-button-stream) *application-frame*
+    (with-slots (stream own-window exit-button-stream) *application-frame*
       (vertically ()
 	(outlining ()
 	  (scrolling (:scroll-bars :dynamic)
 	    (progn
 	      (setq stream
 		    (make-instance 'accept-values-stream
-				   :stream (setf own-window
-						 (make-pane 'clim-stream-pane
-							    :initial-cursor-visibility nil))))
+		      :stream (setf own-window 
+				    (make-pane 'clim-stream-pane
+					       :initial-cursor-visibility nil))))
 	      own-window)))
 	(outlining ()
 	  (setf exit-button-stream
@@ -215,68 +231,15 @@
 ;; So the continuation can run with the proper value of *APPLICATION-FRAME*
 (defvar *avv-calling-frame*)
 
-#-Silica
-(defun invoke-accepting-values (stream continuation
-				&key frame-class own-window exit-boxes
-				     (initially-select-query-identifier nil)
-				     (resynchronize-every-pass nil) (check-overlapping t)
-				     label x-position y-position width height)
-  (incf *accept-values-tick*)
-  (let ((*current-accept-values-tick* *accept-values-tick*)
-	(the-own-window nil)
-	(right-margin 10)
-	(bottom-margin 10))
-    (unwind-protect
-	(progn
-	  (when own-window
-	    (setq the-own-window
-		  (allocate-resource 'menu stream (window-root stream)))
-	    ;;--- make the window big.  We shouldn't have to do this.
-	    (multiple-value-bind (width height)
-		(window-inside-size (slot-value the-own-window 'parent))
-	      (bounding-rectangle-set-size the-own-window width height))
-	    (setf (window-label the-own-window) label)
-	    (when (listp own-window)
-	      (setf right-margin
-		    (process-spacing-arg the-own-window (getf own-window :right-margin 10)
-					 'accepting-values :right-margin))
-	      (setf bottom-margin
-		    (process-spacing-arg the-own-window (getf own-window :bottom-margin 10)
-					 'accepting-values :bottom-margin))))
-	  
-	  (using-resource (avv-stream accept-values-stream (or the-own-window stream))
-	    ;;--- This should resource the AVV application frame, too
-	    (let ((frame 
-		    (make-application-frame 'accept-values
-					    :parent (slot-value avv-stream 'stream)
-					    :frame-class frame-class
-					    :stream avv-stream
-					    :exit-boxes exit-boxes
-					    :continuation continuation
-					    :own-window the-own-window
-					    :x-position x-position
-					    :y-position y-position
-					    :width width :height height
-					    :right-margin right-margin
-					    :bottom-margin bottom-margin
-					    :initially-select-query-identifier
-					      initially-select-query-identifier
-					    :resynchronize-every-pass
-					      resynchronize-every-pass
-					    :check-overlapping check-overlapping)))
-	      (when (frame-top-level-sheet frame)
-		(window-expose (frame-top-level-sheet frame)))
-	      ;; Run the AVV and return its values
-	      (let ((*avv-calling-frame* *application-frame*))
-		(run-frame-top-level frame)))))
-      (when (and the-own-window (windowp the-own-window))
-	;; Deallocate menu resources deexposes them for us
-	(deallocate-resource 'menu the-own-window)))))
-
-#+Silica
+(defmethod frame-manager-default-exit-boxes ((framem standard-frame-manager))
+  '((:abort) (:exit)))
+
 (defun invoke-accepting-values (stream continuation
-				 &key frame-class own-window
-				      exit-boxes (resize-frame nil)
+				 &key frame-class own-window 
+				      (exit-boxes 
+				       (frame-manager-default-exit-boxes
+					(frame-manager stream)))
+				      (resize-frame t)
 				      (initially-select-query-identifier nil)
 				      (resynchronize-every-pass nil) (check-overlapping t)
 				      label x-position y-position width height)
@@ -288,13 +251,11 @@
      (if own-window
 	 (let ((frame (make-application-frame (or frame-class 'accept-values-own-window)
 					      :calling-frame *application-frame*
-					      :parent
-					      *application-frame*
+					      :parent *application-frame*
 					      :pretty-name label
 					      :continuation continuation
 					      :exit-boxes exit-boxes
 					      :own-window the-own-window
-					      :pretty-name label
 					      :width width :height height
 					      :x-position x-position
 					      :y-position y-position
@@ -303,12 +264,12 @@
 					      :initially-select-query-identifier
 					        initially-select-query-identifier
 					      :resynchronize-every-pass
-					      resynchronize-every-pass
-					      :resize-frame resize-frame 
+					        resynchronize-every-pass
 					      :check-overlapping
-					        check-overlapping)))
-	   ;; What do we do about sizing?????
-	   ;; What do we do about positioning????
+					        check-overlapping
+					      :resize-frame resize-frame)))
+	   ;;--- What do we do about sizing?
+	   ;;--- What do we do about positioning?
 	   (let ((*avv-calling-frame* *application-frame*))
 	     (run-frame-top-level frame)))
        (using-resource (avv-stream accept-values-stream (or the-own-window stream))
@@ -318,11 +279,6 @@
 					      :stream avv-stream
 					      :continuation continuation
 					      :exit-boxes exit-boxes
-					      :own-window the-own-window
-					      :x-position x-position
-					      :y-position y-position
-					      :right-margin right-margin
-					      :bottom-margin bottom-margin
 					      :initially-select-query-identifier
 						initially-select-query-identifier
 					      :resynchronize-every-pass
@@ -344,48 +300,55 @@
 	       own-window-width own-window-height
 	       own-window-right-margin own-window-bottom-margin
 	       exit-button-stream) frame
-    (let ((command-table (frame-command-table frame))
-	  (original-view (stream-default-view stream))
-	  (return-values nil)
-	  (initial-query nil)
-	  exit-button-record
-	  avv avv-record)
+    (let* ((command-table (frame-command-table frame))
+	   (original-view (stream-default-view stream))
+	   (return-values nil)
+	   (initial-query nil)
+	   exit-button-record
+	   avv avv-record
+	   (help-window nil)
+	   (*accept-help-displayer*
+	     (if own-window
+		 #'(lambda (function stream &rest args)
+		     (declare (dynamic-extent args))
+		     (setq help-window (apply #'display-own-window-help
+					      function help-window own-window stream args)))
+		 *accept-help-displayer*)))
       (letf-globally (((stream-default-view stream) 
-		       (port-dialog-view (port stream))))
+		       (frame-manager-dialog-view (frame-manager frame))))
 	(labels ((run-continuation (stream avv-record)
-		 (setf (slot-value stream 'avv-record) avv-record)
-		 (setf (slot-value stream 'avv-frame) frame)
-		 (with-output-recording-options (stream :draw nil :record t)
-		   (setq return-values (multiple-value-list
-					 (let ((*application-frame* *avv-calling-frame*))
-					   (funcall continuation stream))))
-		   (unless own-window
-		     (display-exit-boxes frame stream
-					 (stream-default-view stream)))))
-	       (run-avv ()
-		 (when (and initially-select-query-identifier
-			    (setq initial-query
-				  (find-query avv-record initially-select-query-identifier)))
-		   (com-edit-avv-choice initial-query)
-		   (redisplay avv stream :check-overlapping check-overlapping))
-		 (loop
-		   (when (frame-resizable frame)
-		     (size-panes-appropriately))
-		   (let ((command
-			   (let ((command-stream (slot-value stream 'stream)))
-			     ;; While we're reading commands, restore the view
-			     ;; to what it was before we started.
-			     (letf-globally (((stream-default-view command-stream)
-					      original-view))
-			       (read-command command-table
-					     :stream command-stream
-					     :command-parser 'menu-command-parser
-					     :use-keystrokes t)))))
-		     (if (and command (not (keyboard-event-p command)))
-			 (execute-frame-command frame command)
+		   (setf (slot-value stream 'avv-record) avv-record)
+		   (setf (slot-value stream 'avv-frame) frame)
+		   (with-output-recording-options (stream :draw nil :record t)
+		     (setq return-values (multiple-value-list
+					   (let ((*application-frame* *avv-calling-frame*))
+					     (funcall continuation stream))))
+		     (unless own-window
+		       (display-exit-boxes frame stream
+					   (stream-default-view stream)))))
+		 (run-avv ()
+		   (when (and initially-select-query-identifier
+			      (setq initial-query
+				    (find-query avv-record initially-select-query-identifier)))
+		     (com-edit-avv-choice initial-query)
+		     (redisplay avv stream :check-overlapping check-overlapping))
+		   (loop
+		     (let ((command
+			     (let ((command-stream (slot-value stream 'stream)))
+			       ;; While we're reading commands, restore the view
+			       ;; to what it was before we started.
+			       (letf-globally (((stream-default-view command-stream)
+						original-view))
+				 (read-command command-table
+					       :stream command-stream
+					       :command-parser 'menu-command-parser
+					       :use-keystrokes t)))))
+		       (if (and command (not (keyboard-event-p command)))
+			   (execute-frame-command frame command)
 		       (beep stream)))
-		   (with-defered-gadget-updates
-		       (when (or resynchronize-every-pass (slot-value avv-record 'resynchronize))
+		     (with-deferred-gadget-updates
+		       (when (or resynchronize-every-pass
+				 (slot-value avv-record 'resynchronize))
 			 ;; When the user has asked to resynchronize every pass, that
 			 ;; means we should run the continuation an extra time to see
 			 ;; that all visible stuff is up to date.  That's all!
@@ -393,26 +356,29 @@
 			   (redisplay avv stream :check-overlapping check-overlapping)))
 		     (setf (slot-value avv-record 'resynchronize) nil)
 		     (when exit-button-record
-		       (redisplay exit-button-record exit-button-stream))
+ 		       (redisplay exit-button-record exit-button-stream))
 		     (redisplay avv stream :check-overlapping
-				check-overlapping))))
+				check-overlapping))
+		     (when (frame-resizable frame)
+		       (size-panes-appropriately))))
 	       (size-panes-appropriately ()
 		 (changing-space-requirements ()
-                    ;; We really want to specify the min/max sizes of
-                    ;; the exit-button pane also
-                    (size-menu-appropriately
-		     exit-button-stream
-		     :size-fn
-		     #'(lambda (pane w h)
-			 (change-space-requirements pane 
-			  :width w :min-width w :max-width w
-			  :height h :min-height h :max-height h)))
-		    (size-menu-appropriately own-window
-					     :width own-window-width
-					     :height own-window-height
-					     :right-margin own-window-right-margin
-					     :bottom-margin own-window-bottom-margin))))
-	  (declare (dynamic-extent #'run-continuation #'run-avv))
+		   ;; We really want to specify the min/max sizes of
+		   ;; the exit-button pane also
+		   (size-menu-appropriately exit-button-stream
+ 		     :size-setter
+ 		       #'(lambda (pane w h)
+			   (change-space-requirements pane 
+			     :width w :min-width w :max-width w
+			     :height h :min-height h :max-height h)))
+		   (when own-window
+		     (size-menu-appropriately own-window
+		       :width own-window-width
+		       :height own-window-height
+		       :right-margin own-window-right-margin
+		       :bottom-margin own-window-bottom-margin)))))
+	  (declare (dynamic-extent #'run-continuation #'run-avv
+				   #'size-panes-appropriately))
 	  (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog")
 	    (setq avv
 		  (updating-output (stream)
@@ -434,11 +400,8 @@
 		(cond (own-window
 		       (size-panes-appropriately)
 		       (multiple-value-bind (x y)
-			   #-Silica
-			   (stream-pointer-position-in-window-coordinates
-			    (window-parent own-window))
-			   #+Silica
-			   (values 500 500)
+			   #+++ignore (pointer-position (port-pointer (port own-window)))
+			   #---ignore (values 100 100)
 			 (when (and own-window-x-position own-window-y-position)
 			   (setq x own-window-x-position
 				 y own-window-y-position))
@@ -455,6 +418,8 @@
 		       (stream-ensure-cursor-visible stream)
 		       (replay avv stream)
 		       (run-avv)))
+	      (when help-window
+		(deallocate-resource 'menu help-window))
 	      (unless own-window
 		(move-cursor-beyond-output-record (slot-value stream 'stream) avv))))
 	  (values-list return-values))))))
@@ -476,36 +441,64 @@
 				     :right-margin own-window-right-margin
 				     :bottom-margin own-window-bottom-margin)))))))
 
+(defun display-own-window-help (function stream near-window original-stream &rest args)
+  (declare (values help-window))
+  (declare (dynamic-extent args))
+  (if stream
+      (setf (window-visibility stream) nil)
+      (setq stream (allocate-resource 'menu original-stream (window-root original-stream))))
+  (let ((*original-stream* nil)			;--- reset *INPUT-CONTEXT*, too?
+	(*accept-help-displayer* 'funcall))
+    (window-clear stream)
+    (with-output-recording-options (stream :draw t :record t)
+      (with-end-of-line-action (stream :allow)
+	(with-end-of-page-action (stream :allow)
+	  (apply function stream args)
+	  (fresh-line stream)
+	  (with-text-face (stream :italic)
+	    (write-line "Press any key to remove this window" stream)))))
+    (size-menu-appropriately stream)
+    (when near-window
+      (multiple-value-bind (x y) (bounding-rectangle-position near-window)
+	(position-window-near-carefully stream x y)))
+    (window-expose stream)
+    (clear-input stream)
+    (unwind-protect
+	(read-gesture :stream stream)
+      (setf (window-visibility stream) nil)))
+  stream)
+
+
 (define-presentation-type accept-values-exit-box ())
 
 ;;; Applications can create their own AVV class and specialize this method in
 ;;; order to get different exit boxes.
+
+(defmethod frame-manager-exit-box-labels ((frame t) (framem standard-frame-manager))
+  '(
+    (:exit  "<End> uses these values")
+    (:abort  "<Abort> aborts")))
+
 (defmethod display-exit-boxes ((frame accept-values) stream (view view))
   ;; Do the fresh-line *outside* of the updating-output so that it
   ;; doesn't get repositioned relatively in the X direction if the
   ;; previous line gets longer.  Maybe there should be some better
   ;; way of ensuring this.
   (fresh-line stream)
-  (with-slots (exit-boxes) frame
-    (let ((exit  (or (second (assoc :exit  exit-boxes)) "<End> uses these values"))
-	  (abort (or (second (assoc :abort exit-boxes)) "<Abort> aborts")))
-      (updating-output (stream :unique-id stream
-			       :cache-value 'exit-boxes)
-	(with-output-as-presentation (stream ':abort 'accept-values-exit-box)
-	  #-CCL-2 (write-string abort stream)
-	  ;; Kludge to print the cloverleaf char in MCL.
-	  ;; Needs an accompanying kludge in STREAM-WRITE-CHAR so that
-	  ;; #\CommandMark doesn't get lozenged.
-	  #+CCL-2 (progn
-		    (with-text-style (stream '(:mac-menu :roman :normal))
-		      (write-char #\CommandMark stream))
-		    (write-string "-. aborts" stream)))
-	(write-string ", " stream)
-	(with-output-as-presentation (stream ':done 'accept-values-exit-box)
-	  (write-string exit stream))))))
+  (let ((labels (frame-manager-exit-box-labels frame (frame-manager frame))))
+    (updating-output (stream :unique-id stream :cache-value 'exit-boxes)
+		     (with-slots (exit-boxes) frame
+		       (dolist (exit-box exit-boxes)
+			 (let* ((name (if (consp exit-box) (car exit-box) exit-box))
+				(label (or (if (consp exit-box) (second exit-box))
+					   (second (assoc name labels)))))
+			   (with-output-as-presentation (stream name 'accept-values-exit-box)
+			     ;;--- :ccl-2 had some code in here
+			     (write-string label stream))))))))
+
 
 ;;--- Get this right
-(defmethod frame-pointer-documentation-output ((frame accept-values))
+(defmethod frame-pointer-documentation-output ((frame accept-values-own-window))
   nil)
 
 
@@ -905,8 +898,7 @@
 (defun accept-values-pane-displayer (frame pane
 				     &key displayer
 					  resynchronize-every-pass (check-overlapping t))
-  (let* ((stream-and-record (and #-Silica (not *frame-layout-changing-p*)
-				 (gethash pane *pane-to-avv-stream-table*)))
+  (let* ((stream-and-record (and (gethash pane *pane-to-avv-stream-table*)))
 	 (avv-stream (car stream-and-record))
 	 (avv-record (cdr stream-and-record)))
     (cond (avv-stream
@@ -981,8 +973,7 @@
      (pane 't))
   (funcall (slot-value button 'continuation))
   (when (slot-value button 'resynchronize)
-    (let* ((stream-and-record (and #-Silica (not *frame-layout-changing-p*)
-				   (gethash pane *pane-to-avv-stream-table*)))
+    (let* ((stream-and-record (and (gethash pane *pane-to-avv-stream-table*)))
 	   (avv-stream (car stream-and-record))
 	   (avv-record (cdr stream-and-record)))
       (when avv-stream
@@ -1033,7 +1024,7 @@
     :scroll-bars nil
     :initial-cursor-visibility :off))
 
-#-silica
+#-Silica
 (defmethod size-frame-pane ((window window-mixin)
 			    (frame standard-application-frame)
 			    (type (eql :accept-values))
@@ -1068,31 +1059,32 @@
 
 (defmethod display-exit-boxes ((frame accept-values) stream (view gadget-dialog-view))
   (fresh-line stream)
-  (with-slots (exit-boxes) frame
-    (let ((exit  (or (second (assoc :exit  exit-boxes)) "<End> uses these values"))
-	  (abort (or (second (assoc :abort exit-boxes)) "<Abort> aborts")))
+  (let ((labels (frame-manager-exit-box-labels frame (frame-manager frame))))
+    (with-slots (exit-boxes) frame
       (updating-output (stream :unique-id stream
 			       :cache-value 'exit-boxes)
-	(formatting-item-list (stream :n-columns 2 :initial-spacing nil)
-	 (formatting-cell (stream)
-	  (with-output-as-gadget (stream)
-	    (make-pane 'push-button
-		       :label abort
-		       :client frame :id :abort
-		       :activate-callback
-		         #'(lambda (gadget)
-			     (declare (ignore gadget))
-			     (com-abort-avv)))))
-	 (formatting-cell (stream)
-	  (with-output-as-gadget (stream)
-	    (make-pane 'push-button
-		       :label exit
-		       :client frame :id :exit
-		       :activate-callback
-		         #'(lambda (gadget)
-			    (declare (ignore gadget))
-			    (com-exit-avv))))))))))
-
+	  (formatting-item-list (stream :n-columns (length exit-boxes)
+					:initial-spacing nil)
+	      (dolist (exit-box exit-boxes)
+		(let* ((name (if (consp exit-box) (car exit-box) exit-box))
+		       (label (or (if (consp exit-box) (second exit-box))
+				  (second (assoc name labels)))))
+		  (formatting-cell (stream)
+		      (with-output-as-gadget (stream)
+			(make-pane 'push-button
+				   :label label
+				   :client frame :id name
+				   :activate-callback
+				   #'invoke-avv-gadget-action))))))))))
+
+(defun invoke-avv-gadget-action (gadget)
+  (let ((id (gadget-id gadget)))
+    (case id
+      (:exit (com-exit-avv))
+      (:abort (com-abort-avv))
+      (t (funcall id)))))
+	    
+	    
 ;; It's OK that this is only in the ACCEPT-VALUES command table because
 ;; we're going to execute it manually in the callbacks below
 (define-command (com-change-query :command-table accept-values)
@@ -1102,22 +1094,21 @@
     (setf value new-value
 	  changed-p t)))
 
-(defmethod accept-values-value-changed-callback (gadget new-value stream query)
-  (declare (ignore gadget))
+(defmethod accept-values-value-changed-callback ((gadget value-gadget) new-value stream query)
   (when (accept-values-query-valid-p query (accept-values-query-presentation query))
     ;; Only call the callback if the query is still valid
     (do-avv-command new-value stream query)))
 
-(defun make-accept-values-value-changed-callback (stream query)
-  ;; We attach a callback function directly now
-  `(,#'accept-values-value-changed-callback ,stream ,query))
-
 (defmethod accept-values-value-changed-callback ((gadget radio-box) new-value stream query-id)
   (call-next-method gadget (gadget-id new-value) stream query-id))
 
-(defmethod accept-values-value-changed-callback ((gadget silica::check-box) new-value stream query-id)
+(defmethod accept-values-value-changed-callback ((gadget check-box) new-value stream query-id)
   (call-next-method gadget (mapcar #'gadget-id new-value) stream query-id))
 
+(defun make-accept-values-value-changed-callback (stream query)
+  ;; We attach a callback function directly now
+  `(,#'accept-values-value-changed-callback ,stream ,query))
+
 (defun do-avv-command (new-value client query)
   (throw-highlighted-presentation
    (make-instance 'standard-presentation
@@ -1170,3 +1161,4 @@
 				  :y 0
 				  :modifiers 0
 				  :button +pointer-left-button+)))))))))
+
diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp
index 15532910..d40f99f7 100644
--- a/clim/basic-translators.lisp
+++ b/clim/basic-translators.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: basic-translators.lisp,v 1.4 92/03/04 16:21:08 cer Exp $
+;; $fiHeader: basic-translators.lisp,v 1.5 92/04/15 11:46:06 cer Exp $
 
 (in-package :clim-internals)
 
@@ -185,7 +185,7 @@
 			     (print-possibility possibility stream)))))))
 	    (declare (dynamic-extent #'print-possibility #'menu-choose-body))
 	    (with-menu (menu window)
-	      #-Silica (setf (window-label menu) "Menu of completions")
+	      (setf (window-label menu) "Menu of completions")
 	      (with-end-of-line-action (menu :allow)
 		(let ((object
 			(menu-choose-from-drawer menu type #'menu-choose-body)))
diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp
index b9fffe54..fcebd6c1 100644
--- a/clim/command-processor.lisp
+++ b/clim/command-processor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: command-processor.lisp,v 1.6 92/03/24 19:37:45 cer Exp $
+;; $fiHeader: command-processor.lisp,v 1.7 92/04/15 11:46:13 cer Exp $
 
 (in-package :clim-internals)
 
@@ -156,7 +156,7 @@
 	 ;; There must be a value following, no?
 	 (funcall delimiter-parser stream :args)))
 
-#+ignore	;this is slow and useless, don't bother
+#+++ignore	;this is slow and useless, don't bother
 (defun build-command (command-name &rest partial-command-args)
   (declare (dynamic-extent partial-command-args))
   (flet ((arg-parser (&rest args)
diff --git a/clim/command.lisp b/clim/command.lisp
index c21baab1..5e4a0cd3 100644
--- a/clim/command.lisp
+++ b/clim/command.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: command.lisp,v 1.7 92/04/15 11:46:15 cer Exp $
+;; $fiHeader: command.lisp,v 1.8 92/05/07 13:12:02 cer Exp $
 
 (in-package :clim-internals)
 
@@ -532,9 +532,11 @@
 		       (extract-command-menu-item-value item t)))
 	 (text-style (getf (command-menu-item-options item) :text-style)))
     (flet ((body (stream)
-	     (if keystroke
-		 (format stream "~A (~C)" menu keystroke)
-	         (format stream "~A" menu))
+	     (format stream "~A" menu)
+	     (when keystroke
+	       (write-string "(" stream)
+	       (describe-gesture-spec keystroke :stream stream)
+	       (write-string ")" stream))
 	     (when (eq type ':menu)
 	       (write-string " >" stream))))
       (declare (dynamic-extent #'body))
@@ -556,10 +558,9 @@
 					(initial-spacing t) move-cursor)
   (unless (or max-width max-height)
     (multiple-value-bind (width height)
-	#+Silica (bounding-rectangle-size (sheet-region stream))
-	#-Silica (window-inside-size stream)
-	(unless max-width (setf max-width width))
-	(unless max-height (setf max-height height))))
+	(bounding-rectangle-size (sheet-region stream))
+      (unless max-width (setf max-width width))
+      (unless max-height (setf max-height height))))
   (let ((menu (slot-value (find-command-table command-table) 'menu)))
     (if (zerop (count-if #'(lambda (x) (not (null (first x)))) menu))
 	(with-text-face (stream :italic)
diff --git a/clim/cursor.lisp b/clim/cursor.lisp
index 3367ed7d..f02a517e 100644
--- a/clim/cursor.lisp
+++ b/clim/cursor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cursor.lisp,v 1.9 92/04/15 11:46:20 cer Exp $
+;; $fiHeader: cursor.lisp,v 1.10 92/05/07 13:12:07 cer Exp $
 
 (in-package :clim-internals)
 
@@ -32,7 +32,7 @@
 
 ;;--- The positions here should be a COORDINATE pair, no?
 (defclass text-cursor
-	  (cursor #+Silica region)
+	  (cursor region)			;--- why REGION?
     ((x :initarg :x :type coordinate)
      (y :initarg :y :type coordinate)
      (stream :initarg :stream)
@@ -224,9 +224,9 @@
 (defmethod cursor-visibility ((cursor cursor))
   (cursor-active cursor))
  
-(defmethod (setf cursor-visibility) (nv (cursor cursor))
+(defmethod (setf cursor-visibility) (visibility (cursor cursor))
   (setf (cursor-active cursor) 
-	(case nv
+	(case visibility
 	  (:off nil)
 	  ((nil) nil)
 	  ((t :on) t))))
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index b6bf5a91..e42054eb 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1990 by Xerox Corporations.  All rights reserved.
 ;;;
-;; $fiHeader: db-stream.lisp,v 1.16 92/05/07 13:12:08 cer Exp Locker: cer $
+;; $fiHeader: db-stream.lisp,v 1.17 92/05/12 18:24:56 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -33,6 +33,8 @@
 
 ;;--- How to keep PANE-BACKGROUND/FOREGROUND in sync with the medium?
 ;;--- I'm not convinced that including WINDOW-STREAM here is right...
+;;--- Note the this allows you to specify default text style, but it
+;;--- doesn't pass it along to the medium, so it has no effect.
 (defclass clim-stream-sheet 
 	  (window-stream			;includes output recording
 	   sheet-permanently-enabled-mixin
@@ -101,6 +103,10 @@
        :reader pane-display-time
        :initarg :display-time :initform :command-loop		
        :type (member nil :command-loop t))))
+	   
+(defmethod initialize-instance :after 
+	   ((pane clim-stream-pane) &key &allow-other-keys)
+  (setf (sheet-transformation pane) +identity-transformation+))
 
 (defmethod pane-needs-redisplay ((pane clim-stream-pane))
   (with-slots (display-time) pane
@@ -111,140 +117,131 @@
 
 (defmethod pane-needs-redisplay ((pane pane)) nil)
 
-(defmethod initialize-instance :after 
-	   ((pane clim-stream-pane) &key &allow-other-keys)
-  (setf (sheet-transformation pane) +identity-transformation+))
-
-;;-- Althought the unit options are mostly applicable here I guess
-;;-- other classes might want to use it also
-;;-- Perhaps we add a compose-space method on pane which does this.
-;;-- Perhaps the class hierarchy needs a big sort out
-
+;;--- Although the unit options are mostly applicable here I guess
+;;--- other classes might want to use it also.
+;;--- Perhaps we add a COMPOSE-SPACE method on pane which does this.
+;;--- Perhaps the class hierarchy needs a big sort out.
 (defmacro with-space-requirement ((sr &rest vars) &body body)
   ;; A handy macro that makes it slightly easy to manipulate space requirements
   (unless vars
     (setq vars '(sr-width sr-min-width sr-max-width sr-height sr-min-height sr-max-height)))
-  `(multiple-value-bind
-       ,vars
+  `(multiple-value-bind ,vars
        (space-requirement-components ,sr) 
      (macrolet ((do-with-space-req-components (operator var vars &body body)
-		 `(,operator
-		   ,@(mapcar #'(lambda (a-var)
-				 `(symbol-macrolet ((,var ,a-var))
-				    ,@body))
-			     vars)))
+		  `(,operator
+		    ,@(mapcar #'(lambda (a-var)
+				  `(symbol-macrolet ((,var ,a-var))
+				     ,@body))
+			      vars)))
 		(make-sr ()
 		  `,'(make-space-requirement
-		    ,@(mapcan #'list '(:width :min-width :max-width
-				       :height :min-height :max-height)
-			      vars))))
+		       ,@(mapcan #'list '(:width :min-width :max-width
+					  :height :min-height :max-height)
+				 vars))))
        ,@body)))
 
 (defmethod compose-space ((pane clim-stream-pane) &key width height)
   (let ((sr (call-next-method)))
     (labels ((process-compute-space-requirements ()
 	       (with-space-requirement (sr)
-		 (when (do-with-space-req-components 
-			or sr-component 
-			(sr-width sr-min-width
-				  sr-max-width sr-height
-				  sr-min-height sr-max-height) 
-			(eq sr-component :compute))
+		 (when (do-with-space-req-components or
+			   sr-component 
+			   (sr-width sr-min-width sr-max-width
+			    sr-height sr-min-height sr-max-height) 
+			 (eq sr-component :compute))
 		   (multiple-value-bind (width height)
 		       (let ((record
-			      (with-output-to-output-record (pane)
-				(invoke-pane-redisplay-function 
-				 (pane-frame pane) pane
-				 ;;--- Are all pane display functions prepared to
-				 ;;--- ignore these arguments?  I think not...
-				 :max-width width
-				 :max-height height))))
+			       (with-output-to-output-record (pane)
+				 (invoke-pane-redisplay-function 
+				   (pane-frame pane) pane
+				   ;;--- Are all pane display functions prepared to
+				   ;;--- ignore these arguments?  I think not...
+				   :max-width width
+				   :max-height height))))
 			 (bounding-rectangle-size record))
-		     (do-with-space-req-components
-		      progn sr-component (sr-width sr-min-width sr-max-width)
-		      (when (eq sr-component :compute) (setq sr-component width)))
-		     (do-with-space-req-components
-		      progn sr-component (sr-height sr-min-height sr-max-height)
-		      (when (eq sr-component :compute) (setq sr-component height))))
+		     (do-with-space-req-components progn
+		         sr-component (sr-width sr-min-width sr-max-width)
+		       (when (eq sr-component :compute)
+			 (setq sr-component width)))
+		     (do-with-space-req-components progn
+		         sr-component (sr-height sr-min-height sr-max-height)
+		       (when (eq sr-component :compute)
+			 (setq sr-component height))))
 		   (setq sr (make-sr)))))
 	     (process-unit-space-requirements ()
 	       (with-space-requirement (sr)
 		 (let ((changed nil))
-		   (do-with-space-req-components 
-		    progn sr-component 
-		    (sr-width sr-min-width
-			      sr-max-width sr-height
-			      sr-min-height sr-max-height) 
-		    (when (unit-space-requirement-p sr-component)
-		      (setq sr-component
-			(process-unit-space-requirement pane sr-component)
-			changed t)))
+		   (do-with-space-req-components progn
+		       sr-component 
+		       (sr-width sr-min-width sr-max-width
+			sr-height sr-min-height sr-max-height) 
+		     (when (unit-space-requirement-p sr-component)
+		       (setq sr-component (process-unit-space-requirement pane sr-component)
+			     changed t)))
 		   (when changed
 		     (setq sr (make-sr))))))
 	     (process-relative-space-requirements ()
 	       (with-space-requirement (sr)
 		 (unless (and (numberp sr-width)
 			      (numberp sr-height)
-			      (do-with-space-req-components 
-			       and sr-component 
-			       ( sr-min-width
-				 sr-max-width
-				 sr-min-height 
-				 sr-max-height) 
-			       (or (numberp sr-component)
-				   (relative-space-requirement-p
-				    sr-component))))
+			      (do-with-space-req-components and
+				  sr-component 
+				  (sr-min-width sr-max-width
+				   sr-min-height sr-max-height) 
+				(or (numberp sr-component)
+				    (relative-space-requirement-p sr-component))))
 		   (error "Illegal space requirement ~S" sr))
 		 (let ((changed nil))
 		   (when (relative-space-requirement-p sr-min-width)
-		     (setq sr-min-width (- sr-width
-					   (process-unit-space-requirement pane (car sr-min-width)))
+		     (setq sr-min-width (- sr-width (process-unit-space-requirement
+						      pane (car sr-min-width)))
 			   changed t))
 		   (when (relative-space-requirement-p sr-max-width)
-		     (setq sr-max-width (+ sr-width
-					   (process-unit-space-requirement pane (car sr-max-width)))
+		     (setq sr-max-width (+ sr-width (process-unit-space-requirement
+						      pane (car sr-max-width)))
 			   changed t))
 		   (when (relative-space-requirement-p sr-min-height)
-		     (setq sr-min-height (- sr-height
-					    (process-unit-space-requirement pane (car sr-min-height)))
+		     (setq sr-min-height (- sr-height (process-unit-space-requirement
+							pane (car sr-min-height)))
 			   changed t))
 		   (when (relative-space-requirement-p sr-max-height)
-		     (setq sr-max-height (+ sr-height
-					    (process-unit-space-requirement pane (car sr-max-height)))
+		     (setq sr-max-height (+ sr-height (process-unit-space-requirement
+							pane (car sr-max-height)))
 			   changed t))
 		   (when changed
 		     (setq sr (make-sr)))))))
+      (declare (dynamic-extent #'process-compute-space-requirements
+			       #'process-unit-space-requirements
+			       #'process-relative-space-requirements))
       (process-compute-space-requirements)
       (process-unit-space-requirements)
       (process-relative-space-requirements)
       sr)))
 
-
 (defun relative-space-requirement-p (sr)
   (and (consp sr)
        (= (length sr) 2)
        (or (numberp (second sr))
 	   (unit-space-requirement-p (second sr)))))
 
-
 (defun unit-space-requirement-p (sr)
   (and (consp sr)
        (= (length sr) 2)
        (member (second sr) '(:line :character :mm :point :pixel))))
 
 (defun process-unit-space-requirement (pane sr)
-  (destructuring-bind
-      (number unit) sr
+  (destructuring-bind (number unit) sr
     (let ((graft (graft pane)))
       (ecase unit
 	(:pixel number)
-	(:mm (* number (/ (silica::graft-pixel-width graft) (silica::graft-mm-width graft))))
+	(:mm (* number (/ (silica::graft-pixel-width graft)
+			  (silica::graft-mm-width graft))))
 	(:point (* number (silica::graft-pixels-per-point graft)))
 	(:character (* number (stream-string-width pane "M")))
 	(:line (+ (* number (stream-line-height pane))
 		  (* (1- number) (stream-vertical-spacing pane))))))))
 
-#+ignore
+#+++ignore
 (defmethod note-sheet-grafted :after ((pane clim-stream-pane))
   (let ((xform (sheet-transformation pane)))
     (setq xform (make-scaling-transformation 1 -1))
@@ -254,7 +251,7 @@
 ;;; CLIM-STREAM-PANE is a child of the old-style viewport.  It shouldn't
 ;;; get called under the new viewport scheme.
 
-#+ignore
+#+++ignore
 (defmethod allocate-space :after ((pane clim-stream-pane) width height)
   (declare (ignore width height))
   (ecase (graft-origin (graft pane))
@@ -265,10 +262,10 @@
        ;; --- stream-panes ALWAYS have to have a parent to manage the
        ;; viewport clipping, etc.
        (setq xform (compose-transformations
-		    xform
-		    (make-translation-transformation
-		     0 (1- (bounding-rectangle-height
-			    (sheet-parent pane))))))
+		     xform
+		     (make-translation-transformation
+		       0 (1- (bounding-rectangle-height
+			       (sheet-parent pane))))))
        (setf (sheet-transformation pane) xform)))))
 
 (defmethod pane-stream ((pane clim-stream-pane))
@@ -277,7 +274,7 @@
 	   'pane-stream pane))
   pane)
 
-#+ignore
+#+++ignore
 (defmethod update-region ((pane clim-stream-pane) width height
 			  &key no-repaint &allow-other-keys)
   (when (pane-scroller pane)
@@ -296,13 +293,13 @@
   (multiple-value-bind (history-width history-height)
       (if (stream-current-output-record pane)
 	  (bounding-rectangle-size (stream-current-output-record pane))
-	(values width height))
+	  (values width height))
     ;; Don't ever shrink down smaller than our contents.
     (if (and (numberp width)
 	     (numberp height))
 	(apply #'call-next-method pane :width (max width history-width)
-	       :height (max height history-height) keys)
-      (call-next-method))))
+				       :height (max height history-height) keys)
+	(call-next-method))))
 
 
 (defclass interactor-pane (clim-stream-pane) ())
@@ -387,8 +384,7 @@
 (defmethod window-erase-viewport ((stream window-stream))
   (with-sheet-medium (medium stream)
     (multiple-value-call #'draw-rectangle*
-      medium
-      (bounding-rectangle* (or (pane-viewport stream) stream))
+      medium (bounding-rectangle* (or (pane-viewport stream) stream))
       :ink +background-ink+)))
 
 (defmethod window-expose ((stream clim-stream-sheet))
@@ -398,8 +394,8 @@
 (defmethod (setf window-label) (label (stream clim-stream-sheet))
   nil)
 
-(defmethod (setf window-visibility) (nv (stream clim-stream-sheet))
-  (if nv 
+(defmethod (setf window-visibility) (visibility (stream clim-stream-sheet))
+  (if visibility 
       (enable-frame (pane-frame stream))
       (disable-frame (pane-frame stream))))
 
@@ -422,7 +418,6 @@
 (defmethod window-set-inside-size ((stream clim-stream-sheet) width height)
   (change-space-requirements stream :width width :height height :resize-frame t))
 
-
 (defun-inline window-parent (window)
   (sheet-parent window))
 
diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp
index 763850a6..6567b2a1 100644
--- a/clim/drag-and-drop.lisp
+++ b/clim/drag-and-drop.lisp
@@ -2,6 +2,8 @@
 
 (in-package :clim-internals)
 
+;;; $fiHeader$
+
 "Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
 
 
@@ -168,7 +170,8 @@
       (declare (dynamic-extent #'find-translator))
       (macrolet ((feedback (x y state)
 		   `(funcall feedback frame from-presentation window 
-				      initial-x initial-y ,x ,y ,state))
+
+			     initial-x initial-y ,x ,y ,state))
 		 (highlight (presentation state)
 		   `(when ,presentation
 		      (funcall highlighting frame ,presentation window 
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 9b5964fc..b3d4691d 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.20 92/05/12 18:24:58 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.21 92/05/13 17:10:54 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -14,43 +14,43 @@
 ;;--- processes can queue up requests.  This queue should be managed
 ;;--- like other event queues.  It can contains "command" events, too.
 (defclass standard-application-frame (application-frame)
-	  ;;--- Is it right for these to be SHEET accessors??
-	  ((name :initarg :name :accessor frame-name)
-	   (pretty-name :initarg :pretty-name :accessor frame-pretty-name)
-	   (command-table :initarg :command-table 
-			  :initform (find-command-table 'user-command-table)
-			  :accessor frame-command-table)
-	   (disabled-commands :initarg :disabled-commands :initform nil)
-	   ;; One of  T, NIL, or a command-table; used by the menu-bar
-	   (menu-bar :initarg :menu-bar :initform nil)
-	   (histories :initform nil)
-	   (frame-manager :reader frame-manager)
-	   (calling-frame :reader frame-calling-frame :initarg :calling-frame)
-	   ;; PANES is the description of all of the named panes,
-	   ;; ALL-PANES is an alist that stores all of the named panes that
-	   ;; have actually been realized so far
-	   (panes :initarg :panes :accessor frame-panes)
-	   (all-panes :initform nil)
-	   (current-panes :initform nil :accessor frame-current-panes)
-	   (initialized-panes :initform nil)
-	   (pane-constructors :initarg :pane-constructors)
-	   (top-level-sheet :accessor frame-top-level-sheet :initform nil)
-	   (state :initform :disowned :accessor frame-state 
-		  :type (member :disowned :disabled :enabled :shrunk))
-	   (top-level :initarg :top-level  :accessor frame-top-level)
-	   (current-layout :initarg :default-layout :initform nil
-			   :reader frame-current-layout)
-	   (geometry :initform nil :initarg :geometry :reader frame-geometry)
-	   (icon :initform nil :initarg :icon :reader frame-icon)
-	   (shell :accessor frame-shell)
-	   (pointer-documentation-p :initarg :pointer-documentation
-				    :reader frame-pointer-documentation-p)
-	   (pointer-documentation-pane :initform nil)
-	   (properties :initform nil :initarg :properties
-		       :accessor frame-properties)
-	   (resizable :initarg :resize-frame
-		      :reader frame-resizable)
-	   (layout :initarg :layout :reader frame-layouts))
+    ;;--- Is it right for these to be SHEET accessors??
+    ((name :initarg :name :accessor frame-name)
+     (pretty-name :initarg :pretty-name :accessor frame-pretty-name)
+     (command-table :initarg :command-table 
+		    :initform (find-command-table 'user-command-table)
+		    :accessor frame-command-table)
+     (disabled-commands :initarg :disabled-commands :initform nil)
+     ;; One of  T, NIL, or a command-table; used by the menu-bar
+     (menu-bar :initarg :menu-bar :initform nil)
+     (histories :initform nil)
+     (frame-manager :reader frame-manager)
+     (calling-frame :reader frame-calling-frame :initarg :calling-frame)
+     ;; PANES is the description of all of the named panes,
+     ;; ALL-PANES is an alist that stores all of the named panes that
+     ;; have actually been realized so far
+     (panes :initarg :panes :accessor frame-panes)
+     (all-panes :initform nil)
+     (current-panes :initform nil :accessor frame-current-panes)
+     (initialized-panes :initform nil)
+     (pane-constructors :initarg :pane-constructors)
+     (top-level-sheet :accessor frame-top-level-sheet :initform nil)
+     (state :initform :disowned :accessor frame-state 
+	    :type (member :disowned :disabled :enabled :shrunk))
+     (top-level :initarg :top-level  :accessor frame-top-level)
+     (current-layout :initarg :default-layout :initform nil
+		     :reader frame-current-layout)
+     (geometry :initform nil :initarg :geometry :reader frame-geometry)
+     (icon :initform nil :initarg :icon :reader frame-icon)
+     (shell :accessor frame-shell)
+     (pointer-documentation-p :initarg :pointer-documentation
+			      :reader frame-pointer-documentation-p)
+     (pointer-documentation-pane :initform nil)
+     (properties :initform nil :initarg :properties
+		 :accessor frame-properties)
+     (resizable :initarg :resize-frame
+		:reader frame-resizable)
+     (layout :initarg :layout :reader frame-layouts))
   (:default-initargs :pointer-documentation nil
     :layout nil
     :resize-frame nil
@@ -70,16 +70,13 @@
 (defmethod initialize-instance :after ((frame standard-application-frame) 
 				       &rest args
 				       &key frame-manager
-					    geometry
-					    icon
+					    geometry icon
 					    (parent frame-manager))
   (declare (ignore args))
-  
   (destructuring-bind (&key x y width height) geometry
     (declare (ignore x y width height)))
   (destructuring-bind (&key name pixmap clipping-mask) icon
     (declare (ignore name pixmap clipping-mask)))
-  
   (let ((frame-manager
 	  (etypecase parent
 	    (null (find-frame-manager))
@@ -98,7 +95,7 @@
 
 (eval-when (eval compile load)
 (defun define-application-frame-1 (name state-variables pane-descriptions
-				   &key top-level layout
+				   &key top-level layouts
 					command-table disabled-commands)
   (let* ((command-table-name (first command-table)))
     ;; If we're going to be defining commands for this application frame,
@@ -111,7 +108,7 @@
 (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 (pane panes layout top-level menu-bar pointer-documentation
+    (let (pane panes layouts top-level menu-bar pointer-documentation
 	  command-definer command-table disabled-commands
 	  icon geometry default-initargs)
       (macrolet ((extract (name keyword default &optional (pair t))
@@ -130,7 +127,7 @@
 					   options (delete entry options)))))))))
 	(extract pane :pane nil)
 	(extract panes :panes nil nil)
-	(extract layout :layout nil nil)
+	(extract layouts :layouts nil nil)
 	(extract top-level :top-level '(default-frame-top-level))
 	(extract menu-bar :menu-bar t)
 	(extract pointer-documentation :pointer-documentation nil)
@@ -145,16 +142,16 @@
       (check-type slots list)
       (check-type pane list)
       (check-type panes list)
-      (check-type layout list)
+      (check-type layouts list)
       (check-type top-level list)
       (check-type disabled-commands list)
       (when (and pane panes)
 	(error "The ~S and ~S options cannot be used together" :pane :panes))
-      (when (and pane layout)
-	(error "The ~S and ~S options cannot be used together" :pane :layout))
-      (when (or (and panes (null layout))
-		(and layout (null panes)))
-	(error "The ~S and ~S options must be used together" :panes :layout))
+      (when (and pane layouts)
+	(error "The ~S and ~S options cannot be used together" :pane :layouts))
+      (when (or (and panes (null layouts))
+		(and layouts (null panes)))
+	(error "The ~S and ~S options must be used together" :panes :layouts))
       (when (null superclasses)
 	(setq superclasses '(standard-application-frame)))
       (when (eq command-definer 't)
@@ -167,7 +164,7 @@
       (when (eq (first command-table) 't)
 	(setq command-table (list* name (rest command-table))))
     #-Silica (warn-if-pane-descriptions-invalid name pane-descriptions)
-    #-Silica (warn-if-layout-invalid name layout pane-descriptions)
+    #-Silica (warn-if-layouts-invalid name layouts pane-descriptions)
     (let ((pane-constructors 
 	    (cond (panes
 		   (compute-pane-constructor-code panes))
@@ -178,7 +175,7 @@
 	   (when ',command-table
 	     (setf (compile-time-property ',(first command-table) 'command-table-name) t))
 	   (define-application-frame-1 ',name ',slots ,pane-constructors
-				       :layout ',layout
+				       :layouts ',layouts
 				       :top-level ',top-level
 				       :command-table ',command-table))
 	 (define-group ,name define-application-frame
@@ -191,7 +188,7 @@
 	       ,@(and command-table `(:command-table ',(car command-table)))
 	       ,@(and top-level `(:top-level ',top-level))
 	       ,@(and panes `(:pane-constructors ,pane-constructors))
-	       ,@(and layout `(:default-layout ',(caar layout)))
+	       ,@(and layouts `(:default-layout ',(caar layouts)))
 	       ,@(and icon `(:icon (list ,@icon)))
 	       ,@(and geometry `(:geometry (list ,@geometry)))
 	       ,@default-initargs))
@@ -212,7 +209,7 @@
 	   ;;--- Need to handle DISABLED-COMMANDS properly, 
 	   ;;--- which entails doing a COPY-LIST
 	   (define-application-frame-1 ',name ',slots ,pane-constructors
-				       :layout ',layout
+				       :layouts ',layouts
 				       :top-level ',top-level
 				       :command-table ',command-table
 				       :disabled-commands ',disabled-commands)
@@ -220,7 +217,7 @@
 	   (cloe:define-program ,name ()
 	     :main ,name
 	     :debugger-hook cloe-debugger-hook)
-	   ,@(compute-generate-panes-code name pane panes layout)))))))
+	   ,@(compute-generate-panes-code name pane panes layouts)))))))
 
 #+Genera
 (scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name)
@@ -331,14 +328,6 @@
 					`(,name ,panes)))
 				  layouts)))))))))))
 
-(defmethod find-or-make-pane-named ((frame standard-application-frame) name)
-  (with-slots (all-panes pane-constructors) frame
-    (second (or (assoc name all-panes)
-		(car (push (list name 
-				 (funcall (second (assoc name pane-constructors))
-					  frame (frame-manager frame)))
-			   all-panes))))))
-
 (defun compute-pane-constructor-code (panes)
   `(list ,@(mapcar #'(lambda (pane-spec)
 		       (destructuring-bind (name code &rest options) pane-spec
@@ -397,7 +386,7 @@
   `(make-pane 'text-field ,@options))
 
 (define-pane-type text-editor (&rest options)
-  `(make-pane 'silicatext-editor ,@options))
+  `(make-pane 'text-editor ,@options))
 
 (define-pane-type toggle-button (&rest options)
   `(make-pane 'toggle-button ,@options))
@@ -414,7 +403,7 @@
   (with-slots (all-panes pane-constructors) frame
     (second (or (assoc name all-panes)
 		(car (push (list name 
-				 (funcall (second (assoc name pane-constructors))
+ 				 (funcall (second (assoc name pane-constructors))
 					  frame (frame-manager frame)))
 			   all-panes))))))
 
@@ -426,25 +415,25 @@
 	(let ((sr (compose-space panes)))
 	  (setq width  (space-requirement-width sr)
 		height (space-requirement-height sr))
-	  (multiple-value-bind
-	      (gw gh) (bounding-rectangle-size (graft frame))
+	  ;;--- This looks dubious  --SWM
+	  (multiple-value-bind (gw gh)
+	      (bounding-rectangle-size (graft frame))
 	    (minf width (* 0.9 gw))
-	    (minf height (* 0.9 gh)))))
+ 	    (minf height (* 0.9 gh)))))
       ;;--- Don't bother with this if the size didn't change?
-      (let ((top (or (frame-top-level-sheet frame) panes)))
-	(if (and (sheet-enabled-p top)
+      (let ((top-sheet (or (frame-top-level-sheet frame) panes)))
+	(if (and (sheet-enabled-p top-sheet)
 		 (not (frame-resizable frame)))
-	    (multiple-value-call 
-		#'allocate-space 
-	      top
-	      (bounding-rectangle-size top))
+	    (multiple-value-call #'allocate-space 
+	      top-sheet (bounding-rectangle-size top-sheet))
 	  (resize-sheet* 
-	   top
+	   top-sheet
 	   width height))))))
 
-(defmethod (setf frame-current-layout) (nv (frame standard-application-frame))
-  (unless (eq (frame-current-layout frame) nv)
-    (setf (slot-value frame 'current-layout) nv)
+
+(defmethod (setf frame-current-layout) (layout (frame standard-application-frame))
+  (unless (eq (frame-current-layout frame) layout)
+    (setf (slot-value frame 'current-layout) layout)
     ;; First disown all the children
     (dolist (name-and-pane (slot-value frame 'all-panes))
       (let ((sheet (second name-and-pane)))
@@ -458,27 +447,32 @@
     (sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame))
     
     (let ((layout-space-requirements 
-	   (cddr (assoc nv (frame-layouts frame)))))
+	   (cddr (assoc layout (frame-layouts frame)))))
       (changing-space-requirements (:layout nil)
-          (flet ((adjust-layout (sheet)
-		   (when (typep sheet 'space-requirement-mixin)
-		     (silica::change-space-requirements-to
-		      sheet (silica::pane-initial-space-requirements sheet)))
-		   (let ((x (and 
-			     (panep sheet)
-			     (assoc (pane-name sheet) layout-space-requirements))))
-		     (when x (apply #'change-space-requirements sheet (cdr x))))))
-	    (declare (dynamic-extent #'adjust-layout))
-	    (map-over-sheets #'adjust-layout (frame-top-level-sheet frame)))))
-    
+	   (flet ((adjust-layout (sheet)
+		    (change-pane-requirements-to-default sheet)
+		    (let ((x (and (panep sheet)
+				  (assoc (pane-name sheet) layout-space-requirements))))
+		      (when x (apply #'change-space-requirements sheet (cdr x))))))
+	     (declare (dynamic-extent #'adjust-layout))
+	     (map-over-sheets #'adjust-layout (frame-top-level-sheet frame)))))
     (multiple-value-call #'layout-frame
       frame (bounding-rectangle-size (frame-top-level-sheet frame)))
     (throw 'layout-changed nil)))
-		 
+
+
+;;-- Should be elsewhere.  
+
+(defmethod change-pane-space-requirements-to-default ((pane t))
+  nil)
+
+(defmethod change-pane-space-requirements-to-default ((pane space-requirement-mixin))
+  (silica::change-space-requirements-to pane (silica::pane-initial-space-requirements pane)))
+
 #+CLIM-1-compatibility
 (define-compatibility-function (set-frame-layout (setf frame-current-layout))
-			       (frame new-layout)
-  (setf (frame-current-layout frame) new-layout))
+			       (frame layout)
+  (setf (frame-current-layout frame) layout))
 
 (defun make-application-frame (frame-name &rest options 
 			       &key frame-class
@@ -492,19 +486,19 @@
     (setq frame-class frame-name))
   (when (or x y width height)
     (when (getf options :geometry)
-      (error "Cannot specify :geometry and :x,:y,:width or :height at ~
-the same time " options))
+      (error "Cannot specify ~S and ~S, S, ~S, or ~S at the same time"
+	     :geometry :x :y :width :height))
     (setf (getf options :geometry)
-      (append (and x `(:x ,x))
-	      (and y `(:y ,y))
-	      (and width `(:width ,width))
-	      (and height `(:height ,height)))))
+	  (append (and x `(:x ,x))
+		  (and y `(:y ,y))
+		  (and width `(:width ,width))
+		  (and height `(:height ,height)))))
   (with-keywords-removed (options options 
 			  '(:frame-class :pretty-name
 			    :enable :x :y :width :height :save-under))
       (let ((frame (apply #'make-instance frame-class
 			  :name frame-name
-			  ;;-- Perhaps this should be a default-initarg?
+			  ;;--- Perhaps this should be a default-initarg?
 			  :pretty-name (or pretty-name
 					   (title-capitalize (string frame-name)))
 			  :properties `(:save-under ,save-under)
@@ -521,23 +515,23 @@ the same time " options))
 
 (defmethod enable-frame ((frame standard-application-frame))
   (unless (frame-manager frame)
-    (error "Cannot enabled :disowned frame ~S" frame))
-  (destructuring-bind
-      (&key width height &allow-other-keys) (frame-geometry frame)
+    (error "Cannot enabled a disowned frame ~S" frame))
+  (destructuring-bind (&key width height &allow-other-keys)
+      (frame-geometry frame)
     (ecase (frame-state frame)
       (:enabled)
       ((:disabled :disowned)
        (let ((old (frame-state frame)))
 	 (setf (frame-state frame) :enabled)
-	 ;; IF this is a new frame then if the user specified a width
+	 ;; If this is a new frame then if the user specified a width
 	 ;; then we should be using that
-	 ;; IF the frame already exists then we probably should be using
+	 ;; If the frame already exists then we probably should be using
 	 ;; the top level sheet size
 	 (multiple-value-call #'layout-frame 
 	   frame
 	   (ecase old
 	     (:disowned 
-	       (if (and width height)
+ 	       (if (and width height)
 		   (values width height)
 		   (values)))
 	     (:disabled
@@ -572,8 +566,7 @@ the same time " options))
 (defmethod run-frame-top-level :around ((frame standard-application-frame))
   (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame))
     (unwind-protect
-	(let (#-Silica (*frame-layout-changing-p* *frame-layout-changing-p*)
-	      ;; Reset the state of the input editor and the presentation
+	(let (;; 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.
@@ -590,33 +583,33 @@ the same time " options))
 	      (*input-context* nil)
 	      (*accept-help* nil)
 	      (*assume-all-commands-enabled* nil)
-	      #-Silica (*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) 
 	      (*application-frame* frame))
-	  (loop
-	    (with-simple-restart (nil "~A top level" (frame-pretty-name frame))
-	      (loop
-		(catch 'layout-changed
-		  (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)))))))))
+	  (with-frame-manager ((frame-manager frame))
+	    (loop
+	      (with-simple-restart (nil "~A top level" (frame-pretty-name frame))
+		(loop
+		  (catch 'layout-changed
+		    (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))))))))))
       (disable-frame frame))))
 
 (defmethod run-frame-top-level ((frame standard-application-frame))
@@ -657,15 +650,14 @@ the same time " options))
 		       #'command-line-read-remaining-arguments-for-partial-command
 		       #'menu-read-remaining-arguments-for-partial-command)))
 	     (command-stream
-	      ;;-- We have to ask the frame since we do not want to
-	      ;; just pick up a stream from the dynamic environment
-	      (let ((si (or (frame-standard-input frame)
-			    (frame-standard-output frame))))
-	      ;;--- I'm not really convinced that this is right
-	      ;; Who is not convinced
-	       (typecase si
-		 (output-protocol-mixin si)
-		 (t (frame-top-level-sheet frame))))))
+	       ;;--- We have to ask the frame since we do not want to
+	       ;;--- just pick up a stream from the dynamic environment
+	       (let ((si (or (frame-standard-input frame)
+			     (frame-standard-output frame))))
+		 ;;--- I'm not really convinced that this is right  --SWM
+		 (typecase si
+		   (output-protocol-mixin si)
+		   (t (frame-top-level-sheet frame))))))
 	#+Allegro
 	(unless (typep *standard-input* 'excl::bidirectional-terminal-stream)
 	  (assert (port *standard-input*)))
@@ -746,7 +738,6 @@ the same time " options))
 
 ;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc?
 ;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR?
-
 (defun redisplay-frame-pane (frame pane &key force-p)
   (when (symbolp pane)
     (setq pane (get-frame-pane frame pane)))
@@ -926,17 +917,18 @@ the same time " options))
   (not (null (find-frame-pane-of-type frame 'interactor-pane))))
 
 (defmethod notify-user (frame message &rest options) 
-  (when frame (setf (getf options :frame) frame))
-  (apply #'port-notify-user 
-	 (if frame (port frame) (find-port))
-	 message
-	 options))
+  (declare (dynamic-extent options))
+  (when frame
+    (setf (getf options :frame) frame))
+  (apply #'frame-manager-notify-user 
+	 (if frame (frame-manager frame) (find-frame-manager)) message options))
 
 (defmethod select-file (frame &rest options) 
-  (when frame (setf (getf options :frame) frame))
-  (apply #'port-select-file 
-	 (if frame (port frame) (find-port))
-	 options))
+  (declare (dynamic-extent options))
+  (when frame
+    (setf (getf options :frame) frame))
+  (apply #'frame-manager-select-file
+	 (if frame (frame-manager frame) (find-frame-manager)) options))
 
 
 ;;; Pointer documentation
@@ -945,20 +937,19 @@ the same time " options))
 	(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)))
+  (frame-manager-display-pointer-documentation
+    (frame-manager frame) frame presentation input-context window x y stream))
+
+(defmethod frame-manager-display-pointer-documentation
+	   ((framem standard-frame-manager)
+	    frame presentation input-context window x y stream)
+  (when stream
     ;; 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))
+      (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))
@@ -967,19 +958,9 @@ the same time " options))
       (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))
+	(return-from frame-manager-display-pointer-documentation 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)
@@ -1100,5 +1081,3 @@ the same time " options))
 	    middle middle-presentation middle-context
 	    right  right-presentation  right-context)))
 
-#+Genera
-(defmethod mouse-documentation-window ((window window-stream)) nil)
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index da639f92..7d719ce7 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gadget-output.lisp,v 1.15 92/05/07 13:12:16 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.lisp,v 1.16 92/05/12 18:25:02 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -32,91 +32,81 @@
     ((gadget :initform nil
 	     :accessor output-record-gadget)))
 
-(defmethod associate-record-and-gadget (rec gadget stream x y)
+(defmethod associate-record-and-gadget (record gadget stream x y)
   ;; Just in case
   (setf (sheet-enabled-p gadget) nil)
   (sheet-adopt-child stream gadget)
   ;; In order to be able to determine the space the widget has to be
   ;; added to the parent and hopefully grafted
   (assert (port stream))
-  (setf (output-record-gadget rec) gadget)
+  (setf (output-record-gadget record) gadget)
   (let ((sr (compose-space gadget)))
     (multiple-value-bind (abs-x abs-y)
 	(point-position
 	 (stream-output-history-position stream))
       (decf x abs-x)
       (decf y abs-y)
-
-      #-ignore
       (multiple-value-bind (cx cy)
 	  (stream-cursor-position stream)
 	(declare (type coordinate cx cy))
-	(with-slots (start-x start-y) rec
-	  (setq start-x (- cx abs-x) start-y (- cy abs-y))))
-      
+	(with-slots (start-x start-y) record
+	  (setq start-x (- cx abs-x)
+		start-y (- cy abs-y))))
       (bounding-rectangle-set-edges
-       rec
-       x y (+ x (space-requirement-width sr)) 
-       (+ y (space-requirement-height sr)))
-      
-      #-ignore
-      (when (output-record-parent rec)
-	(tree-recompute-extent rec)))
-    
-    (when (output-record-stream rec)
-      (update-gadget-position rec)
+	record
+	x y (+ x (space-requirement-width sr)) (+ y (space-requirement-height sr)))
+      ;;--- We can probably use RECOMPUTE-EXTENT-FOR-CHANGED-CHILD
+      (when (output-record-parent record)
+ 	(tree-recompute-extent record)))
+    (when (output-record-stream record)
+      (update-gadget-position record)
       (setf (sheet-enabled-p gadget) t))))
 
+(defmethod tree-recompute-extent-1 ((record gadget-output-record))
+  (bounding-rectangle* record))
+
 ;; Three ways
 
 (defmethod note-output-record-moved ((record gadget-output-record) dx1 dy1 dx2 dy2)
   (declare (ignore dx1 dy1 dx2 dy2))
   (update-gadget-position record))
 
-;;; Since this class is an output-record-mixin we do not need this.
-
-;(defmethod bounding-rectangle-set-position :after ((rec gadget-output-record) x y)
-;  (declare (ignore x y))
-;  (update-gadget-position rec))
-
-;;;--- We should not need this one either except that the one on
-;;;--- recording protocol seems weird
-
-(defmethod bounding-rectangle-set-edges :after ((rec gadget-output-record) 
+(defmethod bounding-rectangle-set-edges :after ((record gadget-output-record) 
 						left top right bottom)
   (declare (ignore left top right bottom))
-  (update-gadget-position rec))
+  (update-gadget-position record))
+
+
+(defmethod bounding-rectangle-set-position :after ((record gadget-output-record) x y)
+  (declare (ignore x y))
+  (update-gadget-position record))
 
-(defmethod bounding-rectangle-set-size :after ((rec gadget-output-record) a b)
-  (declare (ignore  a b))
-  (update-gadget-position rec))
+(defmethod bounding-rectangle-set-size :after ((record gadget-output-record) width height)
+  (declare (ignore width height))
+  (update-gadget-position record))
 
-#+ignore
+#+++ignore
 (defmethod update-gadget-position (record) 
   (let ((gadget (output-record-gadget record)))
     (when gadget
       (with-bounding-rectangle* (left top right bottom) record
         (let ((xoff (coordinate 0))
 	      (yoff (coordinate 0)))
-	  (multiple-value-setq
-		(xoff yoff)
-	      (convert-from-relative-to-absolute-coordinates 
-	       (sheet-parent gadget) 
-	       record))
+	  (multiple-value-setq (xoff yoff)
+	    (convert-from-relative-to-absolute-coordinates 
+	      (sheet-parent gadget) record))
 	  (move-and-resize-sheet* gadget
 				  (+ left xoff) (+ top yoff)
 				  (- right left) (- bottom top)))))))
 
-
-#-ignore
+#---ignore
 (defmethod update-gadget-position (record) 
   (let ((gadget (output-record-gadget record)))
     (when gadget
-      (multiple-value-bind
-	  (xoff yoff)
+      (multiple-value-bind (xoff yoff)
 	  (convert-from-relative-to-absolute-coordinates
-	   (output-record-stream record)
-	   (output-record-parent record))
+	    (output-record-stream record)
+	    (output-record-parent record))
 	(with-bounding-rectangle* (left top right bottom) record
 	  (move-and-resize-sheet* gadget
 				  (+ left xoff) (+ top yoff)
@@ -145,15 +135,14 @@
 	     (with-look-and-feel-realization (,fm ,f) ,@body)) 
 	 ,@args))))
 
-#+ignore
+#+++ignore
 (defmethod invoke-with-output-as-gadget (stream continuation &key)
   ;;--- (PANE-FRAME STREAM) or *APPLICATION-FRAME*?
   (let* ((frame (pane-frame stream))
 	 (framem (frame-manager frame)))
     (assert frame)
     (assert framem)
-    (multiple-value-bind (x y)
-	(stream-cursor-position stream)
+    (multiple-value-bind (x y) (stream-cursor-position stream)
       (let* (gadget
 	     (record
 	      (with-new-output-record (stream 'gadget-output-record record)
@@ -162,39 +151,35 @@
 		;;--- release the gadget?
 		(unless (setq gadget (output-record-gadget record))
 		  (associate-record-and-gadget
-		   record
-		   (setq gadget (funcall continuation framem frame))
-		   stream x y)))))
+		    record
+		    (setq gadget (funcall continuation framem frame))
+		    stream x y)))))
 	(move-cursor-beyond-output-record stream record)
 	(values gadget record)))))
 	    
-#-ignore
+#---ignore
 (defmethod invoke-with-output-as-gadget (stream continuation &key)
   (let* ((frame (pane-frame stream))
 	 (framem (frame-manager frame)))
     (assert frame)
     (assert framem)
-    (multiple-value-bind (x y)
-	(stream-cursor-position stream)
+    (multiple-value-bind (x y) (stream-cursor-position stream)
       (let* (new
 	     gadget
 	     (record
 	      (with-new-output-record (stream 'gadget-output-record record)
 		(unless (setq gadget (output-record-gadget record))
-		  (setq new t 
-			gadget (funcall continuation framem frame))))))
-	(when new
-	  (associate-record-and-gadget
-	   record
-	   gadget
-	   stream x y))
+		  (setq gadget (funcall continuation framem frame)
+			new t)))))
+	(when new 
+	  (associate-record-and-gadget record gadget stream x y))
 	(move-cursor-beyond-output-record stream record)
 	(values gadget record)))))
 
 
 ;; incf redisplay wanted this!
 
-(defmethod clear-output-record ((rec gadget-output-record))
+(defmethod clear-output-record ((record gadget-output-record))
   nil)
 
 ;; kludge because of clear-output-record :after
@@ -202,13 +187,13 @@
 ;;  If think is because the clear-output-record stuff should be on
 ;;  composite-output-records rather than displayed output-records 
 
-(defmethod bounding-rectangle-set-edges	:around ((rec gadget-output-record)
-						 minx miny maxx maxy)
-  (unless (= minx miny maxx maxy)
+(defmethod bounding-rectangle-set-edges	:around ((record gadget-output-record)
+						 left top right bottom)
+  (unless (= left top right bottom)
     (call-next-method)))
 
-#+ignore
-(defmethod add-output-record :after ((child gadget-output-record) (parent t))
+#+++ignore
+(defmethod add-output-record :after ((record gadget-output-record) (parent t))
   (do ((p parent (output-record-parent p)))
       ((null p) 
        (warn "Parent is not a output-history"))
@@ -217,41 +202,42 @@
   ;; Perhaps we should enable the gadget at this point
   nil)
 
-(defvar *with-deffered-gadget-updates* nil)
+(defmethod note-output-record-attached :after ((record gadget-output-record) stream)
+  (declare (ignore stream))
+  (when (output-record-gadget record)
+    (update-gadget-position record)
+    (update-output-record-gadget-state record t)))
+
+(defmethod note-output-record-detached :after ((record gadget-output-record))
+  (update-output-record-gadget-state record nil))
+
+
+(defvar *with-deferred-gadget-updates* nil)
 
-(defmacro with-defered-gadget-updates (&body body)
-  `(flet ((with-defered-gadget-updates-body ()
+(defmacro with-deferred-gadget-updates (&body body)
+  `(flet ((with-deferred-gadget-updates-body ()
 	    ,@body))
-     (if *with-deffered-gadget-updates*
-	 (with-defered-gadget-updates-body)
-       (let ((*with-deffered-gadget-updates* (list nil)))
-	 (multiple-value-prog1
-	     (with-defered-gadget-updates-body)
-	   (complete-gadget-updates))))))
+     (declare (dynamic-extent #'with-deferred-gadget-updates-body))
+     (if *with-deferred-gadget-updates*
+	 (with-deferred-gadget-updates-body)
+	 (let ((*with-deferred-gadget-updates* (list nil)))
+	   (multiple-value-prog1
+	     (with-deferred-gadget-updates-body)
+	     (complete-gadget-updates))))))
 
 (defun complete-gadget-updates ()
   (mapc #'(lambda (x)
-	    (setf (sheet-enabled-p (car x)) (cadr x)))
-	(remove-duplicates (cdr *with-deffered-gadget-updates*)
-			   :key #'car
-			   :test #'eq
-			   :from-end t)))
-
-(defun update-output-rec-gadget-state (rec state)
-  (if *with-deffered-gadget-updates*
-      (push (list (output-record-gadget rec) state)
-	    (cdr *with-deffered-gadget-updates*))
-    (setf (sheet-enabled-p (output-record-gadget rec)) state)))
-
-(defmethod note-output-record-attached :after ((rec gadget-output-record) stream)
-  (declare (ignore stream))
-  (when (output-record-gadget rec)
-    (update-gadget-position rec)
-    (update-output-rec-gadget-state rec t)))
+	    (setf (sheet-enabled-p (first x)) (second x)))
+	(remove-duplicates (cdr *with-deferred-gadget-updates*)
+			   :key #'car :from-end t)))
 
-(defmethod note-output-record-detached :after ((rec gadget-output-record))
-  (update-output-rec-gadget-state rec nil))
+(defun update-output-record-gadget-state (record state)
+  (if *with-deferred-gadget-updates*
+      (push (list (output-record-gadget record) state)
+	    (cdr *with-deferred-gadget-updates*))
+      (setf (sheet-enabled-p (output-record-gadget record)) state)))
 
+
 ;;; Completion gadget
 
 ;;--- Gadget currently does not include prompt
@@ -262,18 +248,17 @@
 						    present-p query-identifier
 						    &key (prompt t))
   (declare (ignore present-p))
-  ;; value-key, test, sequence
   (with-output-as-gadget (stream)
     (let* (gadget frame-pane)
       (setq frame-pane
-	(outlining ()
-		   (setq gadget
-		     (make-pane 'radio-box 
-				:label (and (stringp prompt) prompt)
-				:client stream :id query-identifier
-				:value-changed-callback
-				(make-accept-values-value-changed-callback
-				 stream query-identifier)))))
+	    (outlining ()
+	      (setq gadget
+		    (make-pane 'radio-box 
+			       :label (and (stringp prompt) prompt)
+			       :client stream :id query-identifier
+			       :value-changed-callback
+			         (make-accept-values-value-changed-callback
+				   stream query-identifier)))))
       (dolist (element (reverse sequence))
 	(make-pane 'toggle-button 
 		   :label (funcall name-key element)
@@ -286,40 +271,39 @@
 		   :parent gadget))
       frame-pane)))
 
-;;; Subset
+
+;;; Subset completion gadget
 
 (define-presentation-method accept-present-default ((type subset-completion) 
 						    stream
-						    (view gadget-dialog-view)
-						    default default-supplied-p
-						    present-p query-identifier
-						    &key (prompt t))
+ 						    (view gadget-dialog-view)
+ 						    default default-supplied-p
+ 						    present-p query-identifier
+ 						    &key (prompt t))
   (declare (ignore present-p))
-  ;; value-key, test, sequence
   (with-output-as-gadget (stream)
     (let* (gadget frame-pane)
       (setq frame-pane
-	(outlining ()
-		   (setq gadget
-		     (make-pane 'check-box 
-				:label (and (stringp prompt) prompt)
-				:client stream :id query-identifier
-				:value-changed-callback
-				(make-accept-values-value-changed-callback
-				 stream query-identifier)))))
+	    (outlining ()
+	      (setq gadget
+		    (make-pane 'check-box 
+			       :label (and (stringp prompt) prompt)
+			       :client stream :id query-identifier
+			       :value-changed-callback
+			         (make-accept-values-value-changed-callback
+				   stream query-identifier)))))
       (dolist (element (reverse sequence))
-	(make-pane 'toggle-button 
-		   :label (funcall name-key element)
-		   :value (and default-supplied-p
-			       (member (funcall value-key default)
-				       sequence
-				       :test test
-				       :key value-key))
-		   :idicator-type :some-of
-		   :id element
-		   :parent gadget))
+ 	(make-pane 'toggle-button 
+ 		   :label (funcall name-key element)
+ 		   :indicator-type :some-of
+ 		   :value (and default-supplied-p
+ 			       (member (funcall value-key default) sequence
+ 				       :test test :key value-key))
+ 		   :id element
+ 		   :parent gadget))
       frame-pane)))
 
+
 ;;; Boolean gadget
 
 (define-presentation-method gadget-includes-prompt-p 
@@ -336,28 +320,30 @@
   (let (gadget)
     (with-output-as-gadget (stream)
       (outlining ()
-	  (setq gadget
-	    (make-pane 'toggle-button
-		       :label (and (stringp prompt) prompt)
-		       :value default
-		       :client stream :id query-identifier
-		       :value-changed-callback
-		         (make-accept-values-value-changed-callback
-			   stream query-identifier)))))
-    ;;--- We end up not making a new gadget sometimes, I think because
-    ;;--- we find a gadget already in the record so we need to modify
-    ;;--- the value!
-    ;;--- I am no longer sure that this is true cos the graphics
-    ;;--- dialog seems to work fine.
-    #+ignore
+	(setq gadget
+	      (make-pane 'toggle-button
+			 :label (and (stringp prompt) prompt)
+			 :value default
+			 :client stream :id query-identifier
+			 :value-changed-callback
+		           (make-accept-values-value-changed-callback
+			     stream query-identifier)))))
+    ;;--- We end up not making a new gadget sometimes, I think because we
+    ;;--- find a gadget already in the record so we need to modify the value!
+    ;;--- I am no longer sure that this is true because the graphics dialog
+    ;;--- in the test suite seems to work fine.
+    #+++ignore
     (setf (gadget-value gadget) default)))
 
-#+ignore
+
+;;; Numeric gadgets
+
+#+++ignore
 (define-presentation-method gadget-includes-prompt-p
 			    ((type integer) (stream t) (view gadget-view))
   t)
 
-#+ignore
+#+++ignore
 (define-presentation-method accept-present-default ((type integer)
 						    stream
 						    (view gadget-dialog-view)
@@ -367,21 +353,23 @@
   (declare (ignore present-p))
   (with-output-as-gadget (stream)
     (outlining ()
-	       (make-pane 'slider
-			  :label (and (stringp prompt) prompt)
-			  :value (if default-supplied-p default 0)
-			  :client stream :id query-identifier
-			  :value-changed-callback
-			  (make-accept-values-value-changed-callback
-			   stream query-identifier)))))
-
-
-
+      (make-pane 'slider
+		 :label (and (stringp prompt) prompt)
+		 :value (if default-supplied-p default 0)
+		 :client stream :id query-identifier
+		 :value-changed-callback
+		   (make-accept-values-value-changed-callback
+		     stream query-identifier)))))
+
+
 ;;--- These should be defined in the standard DEFOPERATION way...
 
 (defmethod sheet-medium ((x standard-encapsulating-stream))
   (sheet-medium (slot-value x 'stream)))
 
+(defmethod sheet-parent ((x standard-encapsulating-stream))
+  (sheet-parent (slot-value x 'stream)))
+
 (defmethod port ((x standard-encapsulating-stream))
   (port (slot-value x 'stream)))
 
diff --git a/clim/gestures.lisp b/clim/gestures.lisp
index e3f4bd0d..f585ca2c 100644
--- a/clim/gestures.lisp
+++ b/clim/gestures.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gestures.lisp,v 1.5 92/03/10 10:12:36 cer Exp $
+;; $fiHeader: gestures.lisp,v 1.6 92/04/15 11:46:36 cer Exp $
 
 (in-package :clim-internals)
 
@@ -38,23 +38,6 @@
 	(setf state (dpb 1 (byte 1 bit) state))))
     state))
 
-#+ignore
-(defun print-modifier-state (state stream &optional brief-p)
-  (let ((n (length *modifier-keys*)))
-    (dotimes (i n)
-      (let ((bit (- n i 1)))
-        (let ((name (modifier-key-index-name bit)))
-          (when (ldb-test (byte 1 bit) state)
-            (if brief-p
-		(format stream "~A-"
-		  (ecase name
-		    (:shift "sh")
-		    (:control "c")
-		    (:meta "m")
-		    (:super "s")
-		    (:hyper "h")))
-              (format stream "~:(~A-~)" name))))))))
-
 ;; A table indexed by mouse button and modifier state [now (3 x 32)].
 ;; Each bucket in the table contains a sequence of gesture names.
 (defvar *button-and-modifier-key->gesture*
@@ -109,15 +92,6 @@
   nil)
 
 #||
-(defun modifier-state-keys (state)
-  ;; This could be table-driven, also, if it's called frequently
-  (let ((shifts nil))
-    (dotimes (bit (length *modifier-keys*))
-      (let ((name (modifier-key-index-name bit)))
-	(when (ldb-test (byte 1 bit) state)
-	  (push name shifts))))
-    (nreverse shifts)))
-
 ;;; Returns an alist of (button . gestures)
 (defun gestures-for-modifier-state (state)
   ;; Eventually, cache this result because it's a common question
@@ -133,12 +107,10 @@
   (declare (dynamic-extent shift-names))
   (let ((state (apply #'make-modifier-state shift-name)))
     (gestures-for-modifier-state state)))
-
 ||#
 
 ;; We typically have our hands on a button index and a modifier key state,
 ;; and we need to know if it matches a named gesture
-
 (defun-inline button-and-modifier-state-matches-gesture-name-p (button state gesture-name)
   (or (eq gesture-name 't)
       (member gesture-name (button-and-modifier-state-gesture-names button state))))
@@ -165,6 +137,7 @@
       modifier-state gesture-name)))
 
 ;; GESTURE-NAME either names a gesture, or is a canonicalized gesture spec
+;;--- Control-? doesn't match (:? :control), but does match (:? :control :shift)
 (defun keyboard-event-matches-gesture-name-p (event gesture-name)
   (when (and (characterp event)
 	     (characterp gesture-name)
@@ -234,6 +207,79 @@
     ;;--- and so forth.
     (values button (nreverse modifiers))))
 
+
+(defvar *modifier-state-specifiers* nil)
+
+(defun modifier-state-keys (state)
+  (when (null *modifier-state-specifiers*)
+    ;; Fill the cache if it hasn't been done yet
+    (setq *modifier-state-specifiers* (make-array (ash 1 (length *modifier-keys*))))
+    (dotimes (state (ash 1 (length *modifier-keys*)))
+      (let ((shifts nil))
+	(dotimes (bit (length *modifier-keys*))
+	  (let ((name (modifier-key-index-name bit)))
+	    (when (ldb-test (byte 1 bit) state)
+	      (push name shifts))))
+	(setf (aref *modifier-state-specifiers* state) shifts))))
+  (aref *modifier-state-specifiers* state))
+
+(defun gesture-specs-from-gesture-name (gesture-name)
+  (let ((gesture-specs nil))
+    (do-button-and-modifier-state (button modifier-state bucket)
+      (when (member gesture-name bucket)
+	(push (list* (button-index-name button) (modifier-state-keys modifier-state))
+	      gesture-specs)))
+    (dotimes (modifier-state (ash 1 (length *modifier-keys*)))
+      (let ((bucket (aref *keysym-and-modifier-key->gesture* modifier-state)))
+	(dolist (entry bucket)
+	  (when (member gesture-name (cdr entry))
+	    (push (list* (car entry) (modifier-state-keys modifier-state))
+		  gesture-specs)))))
+    (nreverse gesture-specs)))
+
+(defun describe-gesture-spec (gesture-spec
+			      &key (stream *standard-output*) (brief t))
+  (let ((alist (if brief 
+		   '((:hyper   "h-")
+		     (:super   "s-")
+		     (:meta    "m-")
+		     (:control "c-")
+		     (:shift   "sh-"))
+		   '((:hyper   "hyper-")
+		     (:super   "super-")
+		     (:meta    "meta-")
+		     (:control "control-")
+		     (:shift   "shift-")))))
+    (dolist (shift alist)
+      (when (member (first shift) (rest gesture-spec))
+	(princ (second shift) stream)))
+    (let ((keysym (first gesture-spec)))
+      (when (and (characterp keysym)
+		 (char<= #\A keysym #\A)
+		 (not (member :shift (rest gesture-spec))))
+	(princ (second (assoc :shift alist)) stream))
+      (when (and (not brief)
+		 (find keysym *pointer-buttons*))
+	(princ "Mouse-" stream))
+      (format stream "~:(~A~)" keysym))))
+
+#+++ignore
+(defun print-modifier-state (state stream &optional brief-p)
+  (let ((n (length *modifier-keys*)))
+    (dotimes (i n)
+      (let ((bit (- n i 1)))
+        (let ((name (modifier-key-index-name bit)))
+          (when (ldb-test (byte 1 bit) state)
+            (if brief-p
+		(format stream "~A-"
+		  (ecase name
+		    (:shift "sh")
+		    (:control "c")
+		    (:meta "m")
+		    (:super "s")
+		    (:hyper "h")))
+              (format stream "~:(~A-~)" name))))))))
+
 
 (defun add-gesture-name (name type gesture-spec &key (unique t))
   (check-type name symbol)
diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp
index 4aa3aa0c..10be93a4 100644
--- a/clim/graph-formatting.lisp
+++ b/clim/graph-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graph-formatting.lisp,v 1.8 92/04/15 11:46:37 cer Exp $
+;; $fiHeader: graph-formatting.lisp,v 1.9 92/05/07 13:12:20 cer Exp $
 
 (in-package :clim-internals)
 
@@ -176,16 +176,13 @@
 				 root-objects object-printer inferior-producer
 				 &key duplicate-key duplicate-test)
   (declare (ignore duplicate-key duplicate-test))
-  (let ((cutoff-depth (slot-value graph 'cutoff-depth))
-	(depth 0))
-    (labels ((format-node (object)
-	       (when cutoff-depth
-		 (incf depth)
-		 (when (> depth cutoff-depth)
-		   (return-from format-node nil)))
+  (let ((cutoff-depth (slot-value graph 'cutoff-depth)))
+    (labels ((format-node (object &optional (depth 1))
+	       (when (and cutoff-depth (> depth cutoff-depth))
+		 (return-from format-node nil))
 	       (let ((children nil))
 		 (dolist (inferior (funcall inferior-producer object))
-		   (let ((node (format-node inferior)))
+		   (let ((node (format-node inferior (1+ depth))))
 		     (when (and node (not (member node children)))
 		       ;; Don't add the same node to the children more than
 		       ;; once, which can come up during redisplay
diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp
index 5fc94501..5600d430 100644
--- a/clim/graphics-recording.lisp
+++ b/clim/graphics-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-recording.lisp,v 1.5 92/04/28 09:25:47 cer Exp Locker: cer $
+;; $fiHeader: graphics-recording.lisp,v 1.6 92/05/07 13:12:25 cer Exp $
 
 (in-package :clim-internals)
 
@@ -14,36 +14,35 @@
 				       highlighting-function)
   (destructuring-bind (function-args
 		       &key points-to-transform point-sequences-to-transform
-		       distances-to-transform
-		       optional-points-to-transform
+			    optional-points-to-transform distances-to-transform
 		       &allow-other-keys)
       (get-drawing-function-description name)
     ;; Gross me right out!
     (setq function-args
-      (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
-	      function-args))
-    (setq optional-points-to-transform
-      (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
-	      optional-points-to-transform))
+	  (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
+		  function-args))
     (setq points-to-transform
-      (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
-	      points-to-transform))
+	  (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
+		  points-to-transform))
     (setq point-sequences-to-transform
-      (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
-	      point-sequences-to-transform))
+	  (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
+		  point-sequences-to-transform))
+    (setq optional-points-to-transform
+	  (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
+		  optional-points-to-transform))
     (setq distances-to-transform
-      (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
-	      distances-to-transform))
+	  (mapcar #'(lambda (x) (intern (symbol-name x) *package*))
+		  distances-to-transform))
     (let* ((medium-graphics-function*
-	    (intern (format nil "~A~A*" 'medium- name)))
+	     (intern (format nil "~A~A*" 'medium- name)))
 	   (superclasses '(output-record-element-mixin 
 			   graphics-displayed-output-record))
 	   (slots
-	    (remove 'filled (append medium-components function-args)))
+	     (remove 'filled (append medium-components function-args)))
 	   (slot-descs 
-	    (mapcar #'(lambda (x)
-			(list x :initarg (intern (symbol-name x) *keyword-package*)))
-		    slots)))
+	     (mapcar #'(lambda (x)
+			 (list x :initarg (intern (symbol-name x) *keyword-package*)))
+			 slots)))
       `(progn
 	 (defclass ,class ,superclasses ,slot-descs)
 	 ;;--- Need to define a speedy constructor
@@ -52,9 +51,9 @@
 	   (when (stream-recording-p medium)
 	     (let ((transformation (medium-transformation medium))
 		   ,@(mapcar #'(lambda (medium-component)
-				 (list medium-component
-				       `(,(fintern"~A~A" 'medium- medium-component)
-					 medium)))
+					  (list medium-component
+						`(,(fintern"~A~A" 'medium- medium-component)
+						  medium)))
 			     medium-components))
 	       ;; Overload FILLED and LINE-STYLE -- when FILLED is T,
 	       ;; the LINE-STYLE is ignored and must be NIL
@@ -72,24 +71,24 @@
 		       ((null pts)
 			(nreverse r))
 		     (push 
-		      (if (member (car pts)
-				  optional-points-to-transform)
-			  `(when ,(car pts)
-			     (transform-positions (transformation) ,(car pts) ,(cadr pts)))
-			`(transform-positions (transformation) ,(car pts) ,(cadr pts)))
-		      r))
+		       (if (member (first pts) optional-points-to-transform)
+			   `(when ,(first pts)
+			      (transform-positions (transformation)
+				,(first pts) ,(second pts)))
+			   `(transform-positions (transformation)
+			      ,(first pts) ,(second pts)))
+		       r))
 		 (transform-distances (transformation) ,@distances-to-transform)
 		 (let ((record
-			(make-instance ',class
-				       ,@(mapcan #'(lambda (x)
-						     (list (intern (symbol-name x) *keyword-package*) x))
-						 slots))))
+			 (make-instance ',class
+			   ,@(mapcan #'(lambda (x)
+					 (list (intern (symbol-name x) *keyword-package*) x))
+				     slots))))
 		   (multiple-value-bind (lf tp rt bt)
 		       (progn ,bounding-rectangle)
 		     (declare (type coordinate lf tp rt bt))
-		     (bounding-rectangle-set-edges
-		      record
-		      (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y))
+		     (bounding-rectangle-set-edges record
+		       (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y))
 		     (multiple-value-bind (cx cy) (stream-cursor-position medium)
 		       (declare (type coordinate cx cy))
 		       ;; Doing this directly beats calling
@@ -105,15 +104,15 @@
 		     ,@(when points-to-transform
 			 `((with-slots ,points-to-transform record
 			     ,@(do ((p points-to-transform (cddr p))
-					  r)
-					 ((null p) (nreverse r))
-				 (let ((b `(setf
-					    ,(first p) (- ,(first p) abs-x)
-					    ,(second p) (- ,(second p) abs-y))))
+				    r)
+				   ((null p) (nreverse r))
+				 (let ((b `(setf ,(first p)  (- ,(first p) abs-x)
+						 ,(second p) (- ,(second p) abs-y))))
 				   (push
-				    (if (member (car p) optional-points-to-transform)
-					`(when ,(car p) ,b) b) 
-				    r)))))))
+				     (if (member (car p) optional-points-to-transform)
+					 `(when ,(car p) ,b)
+					 b) 
+				     r)))))))
 		   (stream-add-output-record medium record)))))
 	   (when (stream-drawing-p medium)
 	     (call-next-method)))
@@ -127,33 +126,34 @@
 	   (with-slots (,@slots) record
 	     (with-sheet-medium (medium stream)
 	       (letf-globally (((medium-transformation medium) +identity-transformation+))
-			      (with-drawing-options 
-				  (medium ,@(mapcan #'(lambda (medium-component)
-							(list (intern (symbol-name medium-component)
-								      *keyword-package*)
-							      medium-component))
-						    medium-components))
-				(let (,@(when (and (member 'filled function-args)
-						   (member 'line-style medium-components))
-					  `((filled (not line-style))))
-				      ,@(mapcar #'(lambda (p) (list p p))
-						points-to-transform)
-				      ,@(mapcar #'(lambda (p) (list p p))
-						point-sequences-to-transform))
-				  ,@(mapcar #'(lambda (p)
-						`(setq ,p (adjust-point-sequence 
-							   ,p (- x-offset) (- y-offset))))
-					    point-sequences-to-transform)
-				  ,@(do ((p points-to-transform (cddr p))
-					 r)
-					((null p) (nreverse r))
-				      (let ((b `(setf
-						 ,(first p) (+ ,(first p) x-offset)
-						 ,(second p) (+ ,(second p) y-offset))))
-					(push
-					 (if (member (car p) optional-points-to-transform)
-					     `(when ,(car p) ,b) b) r)))
-				  (,medium-graphics-function* medium ,@function-args)))))))
+		 (with-drawing-options 
+		     (medium ,@(mapcan #'(lambda (medium-component)
+					   (list (intern (symbol-name medium-component)
+							 *keyword-package*)
+						 medium-component))
+				       medium-components))
+		   (let (,@(when (and (member 'filled function-args)
+				      (member 'line-style medium-components))
+			     `((filled (not line-style))))
+			 ,@(mapcar #'(lambda (p) (list p p))
+				   points-to-transform)
+			 ,@(mapcar #'(lambda (p) (list p p))
+				   point-sequences-to-transform))
+		     ,@(mapcar #'(lambda (p)
+				   `(setq ,p (adjust-point-sequence 
+					       ,p (- x-offset) (- y-offset))))
+			       point-sequences-to-transform)
+		     ,@(do ((p points-to-transform (cddr p))
+			    r)
+			   ((null p) (nreverse r))
+			 (let ((b `(setf ,(first p) (+ ,(first p) x-offset)
+					 ,(second p) (+ ,(second p) y-offset))))
+			   (push
+			     (if (member (car p) optional-points-to-transform)
+				 `(when ,(car p) ,b)
+				 b)
+			     r)))
+		     (,medium-graphics-function* medium ,@function-args)))))))
 	 
 	 ,@(when highlighting-test
 	     (let ((args (first highlighting-test))
@@ -547,53 +547,30 @@
 
 ;;--- Where is DRAW-TEXT?  and/or DRAW-STRING and DRAW-CHARACTER?
 
-
-(define-output-recorder text-output-record
-    draw-text (text-style ink)
-    :bounding-rectangle
-    (text-bounding-box medium
-		       transformation
-		       string-or-char 
-		       x y start end align-x
-		       align-y 
-		       text-style 
-		       towards-x
-		       towards-y
-		       transform-glyphs))
-
-(defun text-bounding-box (stream transformation
-			  string x y start end align-x
-			  align-y text-style
-			  towards-x
-			  towards-y
-			  transform-glyphs)
-  (port-text-bounding-box
-   (port stream)
-   stream
-   string x y start end align-x
-   align-y text-style
-   towards-x
-   towards-y
-   transform-glyphs))
-
-(defmethod port-text-bounding-box ((port port)
-				   stream
-				   string x y start end align-x
-				   align-y text-style
-				   towards-x
-				   towards-y
-				   transform-glyphs)
+(define-output-recorder text-output-record draw-text (text-style ink)
+  :bounding-rectangle
+    (text-bounding-box medium transformation string-or-char x y 
+		       start end align-x align-y text-style
+		       towards-x towards-y transform-glyphs))
+
+(defun text-bounding-box (stream transformation string x y
+			  start end align-x align-y text-style
+			  towards-x towards-y transform-glyphs)
+  (port-text-bounding-box (port stream) stream string x y 
+			  start end align-x align-y text-style
+			  towards-x towards-y transform-glyphs))
+
+(defmethod port-text-bounding-box ((port port) stream string x y
+				   start end align-x align-y text-style
+ 				   towards-x towards-y transform-glyphs)
   (declare (ignore towards-x towards-y transform-glyphs))
   (let* ((width (stream-string-width stream string
-				     :start start
-				     :end end
-				     :text-style text-style))
-	 ;;-- Is this the correct?
-	 ;;-- Text-style-foo does not take a port!
-	 (ascent (text-style-ascent text-style (port stream)))
-	 (descent (text-style-descent text-style (port stream)))
-	 (height (+ ascent descent))
-	 vx vt vr vb)
+ 				     :start start :end end
+ 				     :text-style text-style))
+ 	 (ascent (text-style-ascent text-style (port stream)))
+ 	 (descent (text-style-descent text-style (port stream)))
+ 	 (height (+ ascent descent))
+ 	 vx vt vr vb)
     (ecase align-x
       (:left (setq vx x
 		   vr (+ x width)))
@@ -602,15 +579,13 @@
       (: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 ascent)
+      (:baseline (setq vt (- y height)
 		       vb (+ y descent)))
       (: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)))))
+      (:center (setq vt (- y (floor height 2))
+		     vb (+ y (ceiling height 2)))))
     (values (coordinate vx) (coordinate vt) 
 	    (coordinate vr) (coordinate vb))))
diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp
index f12b66ea..b6f5bea3 100644
--- a/clim/incremental-redisplay.lisp
+++ b/clim/incremental-redisplay.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: incremental-redisplay.lisp,v 1.5 92/04/15 11:46:44 cer Exp $
+;; $fiHeader: incremental-redisplay.lisp,v 1.6 92/05/07 13:12:28 cer Exp $
 
 (in-package :clim-internals)
 
@@ -656,7 +656,7 @@
 ;;
 ;; The question is what the default behavior should be.  The current behavior
 ;; is sort of minimalist.
-#+ignore
+#+++ignore
 (defmethod compute-new-output-records ((record output-record-mixin) stream)
   ;; walk over children?
   )
@@ -751,7 +751,7 @@
 					   (bounding-rectangle record)))))))))))
 
 ;; just use default, for now.
-#+ignore
+#+++ignore
 (defmethod find-child-output-record ((record standard-updating-output-record)
 				     use-old-children record-type &rest init-args
 				     &key unique-id id-test &allow-other-keys)
diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp
index 825348ea..2bef2a18 100644
--- a/clim/input-editor-commands.lisp
+++ b/clim/input-editor-commands.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-editor-commands.lisp,v 1.7 92/04/15 11:46:47 cer Exp $
+;; $fiHeader: input-editor-commands.lisp,v 1.8 92/05/07 13:12:32 cer Exp $
 
 (in-package :clim-internals)
 
@@ -64,7 +64,10 @@
 (define-gesture-name :complete :keyboard (:tab))
 (define-gesture-name :complete :keyboard (:complete))
 (define-gesture-name :help     :keyboard (:help))
+;;--- Both of these because of a bug in KEYBOARD-EVENT-MATCHES-GESTURE-NAME-P
+;;--- that causes control-? not to match sometimes
 (define-gesture-name :possibilities :keyboard (:? :control))
+(define-gesture-name :possibilities :keyboard (:? :control :shift))
 
 ;; These need to be on a per-implementation basis, naturally
 ;;--- If you change these, change *MAGIC-COMPLETION-GESTURES* too
@@ -95,19 +98,19 @@
 			   #.(logior +control-key+ +meta-key+ +super-key+ +hyper-key+))))
 	   (cond ((and (eq aarray *input-editor-command-aarray*)
 		       bucky-p
-		       (member keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9)))
-		  ;; A numeric argument...
-		  (position keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9)))
+		       ;; If a numeric argument, return the digit
+		       (position keysym '#(:|0| :|1| :|2| :|3| :|4| 
+					   :|5| :|6| :|7| :|8| :|9|))))
 		 ((and (eq aarray *input-editor-command-aarray*)
 		       bucky-p
-		       (eq keysym ':-))		;a smiley face indeed!
+		       (eq keysym ':|-|))
 		  -1)
 		 (t
 		  (second (find gesture aarray 
 				:key #'first 
 				:test #'keyboard-event-matches-gesture-name-p))))))))
 
-(defmacro define-input-editor-command ((name &key (rescan T) (type 'motion) history)
+(defmacro define-input-editor-command ((name &key (rescan t) (type 'motion) history)
 				       arglist &body body)
   (multiple-value-bind (arglist ignores)
       (canonicalize-and-match-lambda-lists *ie-command-arglist* arglist)
@@ -309,32 +312,36 @@
 
 (define-input-editor-command (com-ie-forward-character :rescan nil)
 			     (stream input-buffer numeric-argument)
-  (repeat numeric-argument 
-    (let ((p (forward-or-backward input-buffer (insertion-pointer stream) nil #'true)))
+  (repeat (abs numeric-argument)
+    (let ((p (forward-or-backward input-buffer (insertion-pointer stream)
+				  (minusp numeric-argument) #'true)))
       (if p
 	  (setf (insertion-pointer stream) p)
 	  (return (beep stream))))))
 
 (define-input-editor-command (com-ie-forward-word :rescan nil)
 			     (stream input-buffer numeric-argument)
-  (repeat numeric-argument
-    (let ((p (move-over-word input-buffer (insertion-pointer stream) nil)))
+  (repeat (abs numeric-argument)
+    (let ((p (move-over-word input-buffer (insertion-pointer stream) 
+			     (minusp numeric-argument))))
       (if p
 	  (setf (insertion-pointer stream) p)
 	  (return (beep stream))))))
 
 (define-input-editor-command (com-ie-backward-character :rescan nil)
 			     (stream input-buffer numeric-argument)
-  (repeat numeric-argument
-    (let ((p (forward-or-backward input-buffer (insertion-pointer stream) t #'true)))
+  (repeat (abs numeric-argument)
+    (let ((p (forward-or-backward input-buffer (insertion-pointer stream)
+				  (plusp numeric-argument) #'true)))
       (if p
 	  (setf (insertion-pointer stream) p)
 	  (return (beep stream))))))
 
 (define-input-editor-command (com-ie-backward-word :rescan nil)
 			     (stream input-buffer numeric-argument)
-  (repeat numeric-argument
-    (let ((p (move-over-word input-buffer (insertion-pointer stream) t)))
+  (repeat (abs numeric-argument)
+    (let ((p (move-over-word input-buffer (insertion-pointer stream)
+			     (plusp numeric-argument))))
       (if p
 	  (setf (insertion-pointer stream) p)
 	  (return (beep stream))))))
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 18afb5d8..ba15bbb1 100644
--- a/clim/input-protocol.lisp
+++ b/clim/input-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-protocol.lisp,v 1.12 92/04/21 16:13:08 cer Exp Locker: cer $
+;; $fiHeader: input-protocol.lisp,v 1.13 92/05/07 13:12:34 cer Exp $
 
 (in-package :clim-internals)
 
@@ -76,29 +76,20 @@
 						   :root (window-root stream)))))))
 
 (defmethod initialize-instance :after ((stream input-protocol-mixin)
-				       &key 
-				       #+Silica (initial-cursor-visibility t)
-				       #-Silica (initial-cursor-visibility ':inactive))
+				       &key (initial-cursor-visibility t))
   (with-slots (text-cursor) stream
-    #+Silica
     (when text-cursor
       (setf (cursor-active text-cursor) initial-cursor-visibility)
-      (setf (cursor-stream text-cursor) stream))
-    #-Silica
-    (when text-cursor
-      (setf (cursor-stream text-cursor) stream)
-      (setf (cursor-visibility text-cursor) initial-cursor-visibility))))
+      (setf (cursor-stream text-cursor) stream))))
 
-;;; --- Cross-protocol violation here because CURSOR-POSITION is a method on
-;;; --- extended-OUTPUT-protocol right now.  Secondly, this should probably be a
-;;; --- method on the abstract class, anyway.
-#+Silica
+;;--- Cross-protocol violation here because CURSOR-POSITION is a method on
+;;--- extended-OUTPUT-protocol right now.  Secondly, this should probably be a
+;;--- method on the abstract class, anyway.
 (defmethod stream-set-cursor-position :after ((stream input-protocol-mixin) x y)
   (let ((cursor (stream-text-cursor stream)))
     (when cursor
       (cursor-set-position cursor x y))))
 
-#+Silica
 (defmethod stream-set-cursor-position-internal :after ((stream input-protocol-mixin) x y)
   (let ((cursor (stream-text-cursor stream)))
     (when cursor
@@ -111,7 +102,6 @@
     (when cursor
       (setf (cursor-active cursor) nil))))
 
-#+Silica
 (defmethod handle-repaint :after ((stream input-protocol-mixin) medium (region nowhere))
   (declare (ignore medium))
   ;; Repainting nowhere, don't repaint the cursor
@@ -136,25 +126,19 @@
 
 (defmethod pointer-motion-pending ((stream input-protocol-mixin)
 				   &optional
-				   (pointer #+Ignore (stream-primary-pointer stream)))
+				   (pointer #+++ignore (stream-primary-pointer stream)))
   (declare (ignore pointer))					;---
   (with-slots (pointer-motion-pending) stream
     (prog1 pointer-motion-pending
 	   (setf pointer-motion-pending nil))))
 
-(defmethod (setf pointer-motion-pending) (new-value
-					   (stream input-protocol-mixin)
-					   &optional (pointer 
-						       #+Ignore (stream-primary-pointer stream)))
+(defmethod (setf pointer-motion-pending) (new-value (stream input-protocol-mixin)
+					  &optional (pointer #+++ignore (stream-primary-pointer stream)))
   (declare (ignore pointer))					;---
   (with-slots (pointer-motion-pending) stream
     (setf pointer-motion-pending new-value)))
 
-#+Silica
-(progn 
 
-;;; --- assumes that input-protocol-mixin will be mixed in with a sheet that
-;;; has standard-input-contract
 (defmethod queue-event ((stream input-protocol-mixin) (event key-press-event))
   (let ((char (keyboard-event-character event))
 	(keysym (keyboard-event-key-name event)))
@@ -224,18 +208,11 @@
 (defmethod queue-event ((stream input-protocol-mixin) (event window-repaint-event))
   (queue-put (stream-input-buffer stream) (copy-event event)))
 
-)	;#+Silica
 
 (defmethod (setf window-visibility) :after (visibility (stream input-protocol-mixin))
   (declare (ignore visibility))
   (ensure-pointer-window stream))
 
-(defmethod window-stack-on-top :after ((stream input-protocol-mixin))
-  (ensure-pointer-window stream))
-
-(defmethod window-stack-on-bottom :after ((stream input-protocol-mixin))
-  (ensure-pointer-window stream))
-
 (defun ensure-pointer-window (window)
   #-Silica
   (dolist (pointer (stream-pointers window))
@@ -304,7 +281,6 @@
 	      (funcall input-wait-handler stream)))
 	  (otherwise 
 	    (when input-happened
-	      #+Silica
 	      (let ((gesture (queue-get (stream-input-buffer stream))))
 		(when gesture
 		  ;;--- What we *should* do is to reinstate a separate input
@@ -322,33 +298,7 @@
 			     gesture)))
 		    (when new-gesture
 		      (when peek-p (queue-unget (stream-input-buffer stream) gesture))
-		      (return-from stream-read-gesture new-gesture)))))
-	      #-Silica
-	      (with-slots (input-buffer) stream
-		(let ((gesture (queue-get input-buffer)))
-		  (when gesture
-		    (when peek-p
-		      (queue-unget input-buffer gesture))
-		    ;; --- Foo.  I can't find a general way to communicate from the outside
-		    ;; (i.e. the global event process) that something has happened that the
-		    ;; application should care about.
-		    ;; Add this kludge until BSG's gesture preprocessor (or something) gets
-		    ;; installed.  This could throw when there is no catch tag, but I don't
-		    ;; know how to tell if we are within run-frame-top-level.
-		    (cond ((and (characterp gesture)
-				(member gesture *accelerator-gestures*))
-			   (signal 'accelerator-gesture
-				   :event gesture
-				   :numeric-argument (or *accelerator-numeric-argument* 1)))
-			  ((and (characterp gesture)
-				(member gesture *abort-gestures*))
-			   (let ((cursor (slot-value stream 'text-cursor)))
-			     (when (and cursor
-					(cursor-active-p cursor))
-			       (write-string "[Abort]" stream)
-			       (force-output stream)))
-			   (error 'abort-gesture :event gesture))
-			  (t (return-from stream-read-gesture gesture)))))))))))))
+		      (return-from stream-read-gesture new-gesture))))))))))))
 
 ;; Presentation translators have probably already run...
 (defmethod receive-gesture
@@ -359,6 +309,15 @@
 	     nil)
       gesture))
 
+;;--- This is horrible.  --cer
+;;--- A higher level will have to ignore this in some cases, or else we
+;;--- get release events in input buffers (such as after clicking on
+;;--- something to invoke a translator).  --SWM
+(defmethod receive-gesture
+	   ((stream input-protocol-mixin) (gesture pointer-button-release-event))
+  ;; don't translate it
+  gesture)
+
 (defmethod receive-gesture
 	   ((stream input-protocol-mixin) (gesture (eql ':resynchronize)))
   (throw 'resynchronize t))
@@ -420,14 +379,7 @@
 (defmethod receive-gesture ((stream input-protocol-mixin) (gesture event))
   (process-event-locally stream gesture)
   nil)
-
-;;;--- This is horrible
-
-(defmethod receive-gesture
-	   ((stream input-protocol-mixin) (gesture pointer-button-release-event))
-  ;; don't translate it
-  gesture)
-
+  
 (defmethod receive-gesture
 	   ((stream input-protocol-mixin) gesture)
   ;; don't translate it
@@ -582,7 +534,7 @@
   (with-slots (input-buffer) stream
     (unless (queue-empty-p input-buffer)
       (return-from stream-input-wait t))
-    ;; Non-silica version is always one-process
+    ;; Non-Silica version is always one-process
     (loop
       (let ((flag (stream-event-handler stream :timeout timeout
 					       :input-wait-test input-wait-test)))
@@ -604,8 +556,8 @@
     ;; Will go blocked if there are no pending events, which unfortunately puts
     ;; the input-wait-test function out of commission.  Need to get the "process-wait"
     ;; story straight.
-    ;; Non-silica version is always one-process
-
+    ;; Silica version is always multi-process
+    ;;--- This won't work on Cloe, what can we steal from the #-Silica stuff?
     (let* ((flag nil)
 	   (start-time (get-internal-real-time))
 	   (end-time (and timeout
@@ -710,61 +662,19 @@
   (stream-set-pointer-position stream x y))
 
 ;;; The primitive we are interested in.  The pointer is in inside-host-window coords.
-#+Silica
 (defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer)
   (declare (ignore timeout))
   (let ((pointer (or pointer (stream-primary-pointer stream))))
     (pointer-position pointer)))
 
-#-Silica
-(defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer)
-  ;; Process any pending pointer motion events.
-  (stream-event-handler stream :timeout timeout)
-  (let ((pointer (or pointer (stream-primary-pointer stream))))
-    (multiple-value-bind (left top) (window-offset stream)
-      (declare (type coordinate left top))
-      (if pointer
-	  (multiple-value-bind (x y) (pointer-position pointer)
-	    (declare (type coordinate x y))
-	    (values (- x left) (- y top)))
-	  (values (coordinate 0) (coordinate 0))))))
-
 (defun set-stream-pointer-position-in-window-coordinates (stream x y &key pointer)
   (declare (type real x y))
   (unless pointer (setf pointer (stream-primary-pointer stream)))
   (setf (pointer-position-changed pointer) t)
-  #+Silica
-  (pointer-set-position pointer x y)
-  #-Silica
-  (multiple-value-bind (left top) (window-offset stream)
-    (declare (type coordinate left top))
-    (set-stream-pointer-in-screen-coordinates
-      stream pointer (+ x left) (+ y top))))
-
-#-Silica
-(defmethod stream-note-pointer-button-press ((stream input-protocol-mixin)
-					     pointer button modifier-state x y)
-  (declare (ignore pointer))
-  (with-slots (input-buffer) stream
-    (queue-put input-buffer
-	       (make-button-press-event stream 
-					(coordinate x) (coordinate y)
-					button modifier-state))))
-
-#-Silica
-(defmethod stream-note-pointer-button-release ((stream input-protocol-mixin)
-					       pointer button modifier-state x y)
-  (declare (ignore pointer))
-  (with-slots (input-buffer) stream
-    (queue-put input-buffer
-	       (make-button-release-event stream
-					  (coordinate x) (coordinate y)
-					  button modifier-state))))
+  (pointer-set-position pointer x y))
 
-#+Silica
 (defmethod stream-set-input-focus ((stream input-protocol-mixin))
   (setf (port-keyboard-input-focus (port stream)) stream))
 
-#+Silica
 (defmethod stream-restore-input-focus ((stream input-protocol-mixin) old-focus)
   (setf (port-keyboard-input-focus (port stream)) old-focus))
diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp
index b1f647e3..b5854b74 100644
--- a/clim/interactive-defs.lisp
+++ b/clim/interactive-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: interactive-defs.lisp,v 1.7 92/03/10 15:40:12 cer Exp $
+;; $fiHeader: interactive-defs.lisp,v 1.8 92/05/07 13:12:36 cer Exp $
 
 (in-package :clim-internals)
 
@@ -51,12 +51,12 @@
      ,@body))
 
 (defun activation-gesture-p (gesture)
-  (and (not (typep gesture 'pointer-button-release-event))
+  (and (not (typep gesture 'pointer-event))	;--- kludge
        (dolist (set *activation-gestures*)
 	 (when (if (listp set)
 		   (member gesture set 
 			   :test #'keyboard-event-matches-gesture-name-p)
-		 (funcall set gesture))
+		   (funcall set gesture))
 	   (return-from activation-gesture-p t)))))
 
 #+CLIM-1-compatibility
@@ -89,12 +89,13 @@
      ,@body))
 
 (defun delimiter-gesture-p (gesture)
-  (dolist (set *delimiter-gestures*)
-    (when (if (listp set)
-	      (member gesture set 
-		      :test #'keyboard-event-matches-gesture-name-p)
-	      (funcall set gesture))
-      (return-from delimiter-gesture-p t))))
+  (and (not (typep gesture 'pointer-event))	;---kludge
+       (dolist (set *delimiter-gestures*)
+	 (when (if (listp set)
+		   (member gesture set 
+			   :test #'keyboard-event-matches-gesture-name-p)
+		   (funcall set gesture))
+	   (return-from delimiter-gesture-p t)))))
 
 #+CLIM-1-compatibility
 (progn
@@ -168,7 +169,7 @@
 		       ((ordinary-char-p gesture)
 			(vector-push-extend gesture string)
 			;;--- haven't updated WRITE-CHAR yet
-			#+ignore (write-char gesture stream))
+			#+++ignore (write-char gesture stream))
 		       (t (beep stream))))
 		(t (return-token gesture))))))))
 
diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp
index f4300202..51376adb 100644
--- a/clim/interactive-protocol.lisp
+++ b/clim/interactive-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: interactive-protocol.lisp,v 1.7 92/04/15 11:46:51 cer Exp $
+;; $fiHeader: interactive-protocol.lisp,v 1.8 92/05/07 13:12:37 cer Exp $
 
 (in-package :clim-internals)
 
@@ -187,7 +187,7 @@
 	       (setq noise-string next-char)	;---so what do we do with NOISE-STRING?
 	       (incf scan-pointer))
 	      (t (when (< scan-pointer insertion-pointer)
-		   #+ignore (error "Trying to make a noise string while rescanning")
+		   #+++ignore (error "Trying to make a noise string while rescanning")
 		   (return-from prompt-for-accept (values)))
 		 (setq noise-string
 		       (make-noise-string 
@@ -761,36 +761,29 @@
 			       &optional (start-position 0))
 
   (with-slots (stream) istream
-    ;; --- should we just require that the encapsulated stream
-    ;; support the graphics protocol??    
-    ;; To avoid different kinds of input editors for the two commonest cases.
-    (cond (#+Silica t
-	   #-Silica (graphics-stream-p stream)
-	   (let (oleft otop oright obottom)
-	     ;; Assumptions: 1. Erasure happens left-to-right, top-to-bottom (just
-	     ;; like text output).  2. Nothing interesting appears on the screen below
-	     ;; and to the right of text from the input editor.  We merge erasures so
-	     ;; as to erase as few rectangles as possible.
-	     (labels ((erase-merged-stuff ()
-			(draw-rectangle-internal stream (coordinate 0) (coordinate 0)
-						 oleft otop oright obottom
-						 +background-ink+ nil))
-		      (erase-screen-piece (left top right bottom extra)
-			(declare (ignore extra))
-			(cond ((null oleft)	;First rectangle
-			       (setf oleft left otop top oright right obottom bottom))
-			      ((= otop top)	;Same line
-			       (maxf oright right) (maxf obottom bottom) (minf oleft left))
-			      ((<= oleft left)	;Further down, same or larger indent
-			       (maxf oright right) (maxf obottom bottom))
-			      (t		;next line is further left than previous
-			       (erase-merged-stuff)
-			       (setf oleft left otop top oright right obottom bottom)))))
-	       (declare (dynamic-extent #'erase-merged-stuff #'erase-screen-piece))
-	       (do-input-buffer-screen-real-estate istream #'erase-screen-piece start-position)
-	       (when oleft (erase-merged-stuff)))))
-	  ;; just reprompt on the next line.
-	  (t (terpri stream)))))
+    (let (oleft otop oright obottom)
+      ;; Assumptions: 1. Erasure happens left-to-right, top-to-bottom (just
+      ;; like text output).  2. Nothing interesting appears on the screen below
+      ;; and to the right of text from the input editor.  We merge erasures so
+      ;; as to erase as few rectangles as possible.
+      (labels ((erase-merged-stuff ()
+		 (draw-rectangle-internal stream (coordinate 0) (coordinate 0)
+					  oleft otop oright obottom
+					  +background-ink+ nil))
+	       (erase-screen-piece (left top right bottom extra)
+		 (declare (ignore extra))
+		 (cond ((null oleft)		;First rectangle
+			(setf oleft left otop top oright right obottom bottom))
+		       ((= otop top)		;Same line
+			(maxf oright right) (maxf obottom bottom) (minf oleft left))
+		       ((<= oleft left)		;Further down, same or larger indent
+			(maxf oright right) (maxf obottom bottom))
+		       (t			;next line is further left than previous
+			(erase-merged-stuff)
+			(setf oleft left otop top oright right obottom bottom)))))
+	(declare (dynamic-extent #'erase-merged-stuff #'erase-screen-piece))
+	(do-input-buffer-screen-real-estate istream #'erase-screen-piece start-position)
+	(when oleft (erase-merged-stuff))))))
 
 ;;--- This mechanism is only partially implemented.  In order to work better,
 ;;--- it requires that the IE maintain its own concept of the prompt.
diff --git a/clim/item-list-manager.lisp b/clim/item-list-manager.lisp
index 46d50c38..0a79dd52 100644
--- a/clim/item-list-manager.lisp
+++ b/clim/item-list-manager.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: item-list-manager.lisp,v 1.1 92/01/31 14:27:57 cer Exp $
+;; $fiHeader: item-list-manager.lisp,v 1.2 92/02/24 13:08:00 cer Exp $
 
 (in-package :clim-internals)
 
@@ -31,7 +31,7 @@
 	(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
+	   #+++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)
@@ -40,7 +40,7 @@
 	       (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
+	   #+++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)
diff --git a/clim/menus.lisp b/clim/menus.lisp
index c5b0360b..4e646793 100644
--- a/clim/menus.lisp
+++ b/clim/menus.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: menus.lisp,v 1.21 92/05/06 15:37:41 cer Exp Locker: cer $
+;; $fiHeader: menus.lisp,v 1.22 92/05/07 13:12:39 cer Exp $
 
 (in-package :clim-internals)
 
@@ -9,9 +9,8 @@
 
 (defvar *abort-menus-when-buried* t)
 
-#+Silica
 (define-application-frame menu-frame ()
-  (menu)
+    (menu)
   (:pane
     (with-slots (menu) *application-frame*
       (outlining ()
@@ -24,101 +23,28 @@
   (and (boundp '*application-frame*)
        *application-frame*))
 
+;; Returns a stream that corresponds to the pane holding the menu
 (defun get-menu (&key port)
   (let ((frame (make-application-frame 'menu-frame
 				       :parent port
 				       :save-under t)))
     (values (slot-value frame 'menu) frame)))
 
-;; This stub is used by implementations to create a new subclass
-;; (of window-stream) for menus if desired
-#-Silica
-(defmethod menu-class-name (root)
-  (class-name (class-of root)))
-
-;;--- This associated-window/root stuff is pretty irksome.
-;;--- Menus should really be application frames.
-#-Silica
-(defresource menu (associated-window root)
-  :constructor (open-window-stream :parent root	;"random" size
-				   :left 100 :top 100 :width 300 :height 200
-				   :scroll-bars ':vertical
-				   :window-class (menu-class-name root)
-				   :save-under T)
-  ;; We used to have an initializer that set RECORD-P, cleared the window,
-  ;; and set the size.  RECORD-P is unnecessary because we explicitly bind it
-  ;; below when drawing the menu contents.  (Also, it should always be T
-  ;; anyway.)  Clearing the window is unnecessary because it's done in the
-  ;; deinitializer.  Setting the size is also unnecessary.  Any application
-  ;; that's formatting into a menu is required to use WITH-END-OF-LINE-ACTION
-  ;; and WITH-END-OF-PAGE-ACTION or set the size first itself.
-  :initializer (initialize-menu menu associated-window)
-  ;; Deexpose the menu, and clear it so that the GC can reclaim any
-  ;; garbage output records.
-  :deinitializer (progn
-		   (setf (window-visibility menu) nil)
-		   (window-clear menu)
-		   (setf (window-label menu) nil))
-  :matcher (eq (window-parent menu) root))
-
-#+Silica
 (defresource menu (associated-window root)
   :constructor (let* ((port (if (null root) (find-port) (port root))))
 		 (get-menu :port port))
   :deinitializer (window-clear menu)
-  ;; We used to have an initializer that set record-p, cleared the window, and set
-  ;; the size.  Record-p is unnecessary because we explicitly bind it below
-  ;; when drawing the menu contents.  (Also, it should always be T anyway.)
-  ;; Clearing the window is unnecessary because it's done in the deinitializer.
-  ;; Setting the size is also unnecessary.  Any application that's formatting
-  ;; into a menu is required to use with-end-of-line-action and with-end-of-page-action
-  ;; or set the size first itself.
   :initializer (initialize-menu (port menu) menu associated-window)
-  ;; horrible kludge in the case where no associated window is passed in.
+  ;; Horrible kludge in the case where no associated window is passed in.
   :matcher (eq (port menu) (port root)))
 
-#-Silica 
-;; no window-mixin
-(defmethod initialize-menu ((menu window-mixin) associated-window)
-  (declare (ignore associated-window))
-  )
-
-#+Silica
 (defmethod initialize-menu ((port port) window associated-window)
   (declare (ignore window associated-window))
   )
 
-#-Silica
-(defun size-menu-appropriately (menu &key width height (right-margin 10) (bottom-margin 10))
-  (with-slots (output-record parent) menu
-    (with-bounding-rectangle* (left top right bottom) output-record
-      (let ((width (or width (- right left)))
-	    (height (or height (- bottom top))))
-	(multiple-value-bind (label-width label-height)
-	    (window-label-size menu)
-	  (multiple-value-bind (parent-width parent-height)
-	      (window-inside-size parent)
-	    (multiple-value-bind (lm tm rm bm)
-		(host-window-margins menu)
-	      (multiple-value-bind (wlm wtm wrm wbm)
-		  (window-margins menu)
-		(bounding-rectangle-set-size 
-		  menu
-		  (min (+ (max label-width width) right-margin wlm wrm lm rm)
-		       parent-width)
-		  (min (+ (max label-height height) bottom-margin wtm wbm tm bm)
-		       parent-height)))))))
-      (window-set-viewport-position menu left top)
-      ;; blech
-      (clear-input menu))))
-
-#+Silica
-(defun size-menu-appropriately (menu &key 
-				     width height
-				     (right-margin 10) 
-				     (bottom-margin 10)
-				     (size-fn 
-				      #'window-set-inside-size))
+(defun size-menu-appropriately (menu &key width height
+					  (right-margin 10) (bottom-margin 10)
+					  (size-setter #'window-set-inside-size))
   (with-slots (output-record) menu
     (with-bounding-rectangle* (left top right bottom) output-record
       (let* ((graft (graft menu))
@@ -126,13 +52,11 @@
 	     (gh (bounding-rectangle-height (sheet-region graft)))
 	     (width (min gw (+ (or width (- right left)) right-margin)))
 	     (height (min gh (+ (or height (- bottom top)) bottom-margin))))
-	(funcall size-fn menu width height)
+	(funcall size-setter menu width height)
 	(window-set-viewport-position menu left top)))))
 
-
-#-Silica
 (defun position-window-near-carefully (window x y)
-  ;; unfortunately, the mouse-position is in window-parent coordinates
+  #-Silica
   (multiple-value-bind (width height) (bounding-rectangle-size window)
     (multiple-value-bind (parent-width parent-height)
 	(window-inside-size (window-parent window))
@@ -147,22 +71,11 @@
 	(bounding-rectangle-set-position window
 					 (max 0 left) (max 0 top))))))
 
-#-Silica
 (defun position-window-near-pointer (window &optional x y)
   (unless (and x y)
     (multiple-value-setq (x y)
-      (stream-pointer-position-in-window-coordinates (window-parent window))))
-  (position-window-near-carefully window x y))
-
-#+Silica
-(defun position-window-near-carefully (window x y)
-  )
-
-#+Silica
-(defun position-window-near-pointer (window &optional x y)
-  (unless (and x y)
-    (multiple-value-setq (x y) #+++ignore (poll-pointer (graft window))
-			       #---ignore (values 100 100)))
+      #+++ignore (pointer-position (port-pointer (port window)))
+      #---ignore (values 100 100)))
   (position-window-near-carefully window x y))
 
 ;; items := (item*)
@@ -335,28 +248,30 @@
 			     (cell-align-x ':left) (cell-align-y ':top)
 			     pointer-documentation)
   (declare (values value chosen-item gesture))
-  (declare (ignore default-item default-style
+  (declare (ignore associated-window
+		   default-item default-style
 		   label printer presentation-type
 		   cache unique-id id-test cache-value cache-test
 		   max-width max-height n-rows n-columns
 		   x-spacing y-spacing cell-align-x cell-align-y
 		   pointer-documentation))
   (declare (dynamic-extent keys))
-  (apply #'port-menu-choose (port associated-window) items keys))
+  (apply #'frame-manager-menu-choose (frame-manager *application-frame*) items keys))
 
 ;; Specific ports can put :AROUND methods on this in order to use their own
 ;; kinds of menus.
-(defmethod port-menu-choose ((port t) items &rest keys
-			     &key (associated-window
-				    (frame-top-level-sheet *application-frame*))
-				  default-item default-style
-				  label printer presentation-type
-				  (cache nil) (unique-id items) (id-test #'equal)
-				  (cache-value items) (cache-test #'equal)
-				  max-width max-height n-rows n-columns
-				  x-spacing y-spacing 
-				  (cell-align-x ':left) (cell-align-y ':top)
-				  pointer-documentation)
+(defmethod frame-manager-menu-choose
+	   ((framem standard-frame-manager) items &rest keys
+	    &key (associated-window
+		   (frame-top-level-sheet *application-frame*))
+		 default-item default-style
+		 label printer presentation-type
+		 (cache nil) (unique-id items) (id-test #'equal)
+		 (cache-value items) (cache-test #'equal)
+		 max-width max-height n-rows n-columns
+		 x-spacing y-spacing 
+		 (cell-align-x ':left) (cell-align-y ':top)
+		 pointer-documentation)
   (declare (values value chosen-item gesture))
   (declare (ignore keys))
   (flet ((present-item (item stream)
@@ -370,7 +285,7 @@
 	  #+Lucid (items items))
       (with-menu (menu associated-window)
 	(setf (window-label menu) label)
-	#+Silica (reset-frame (pane-frame menu) :title label)
+	(reset-frame (pane-frame menu) :title label)
 	(with-text-style (menu default-style)
 	  (with-end-of-line-action (menu :allow)
 	    (loop
@@ -398,7 +313,7 @@
 			     default-item nil
 			     cache nil)
 		       (clear-output-history menu))
-		      (t (return-from port-menu-choose
+		      (t (return-from frame-manager-menu-choose
 			   (values (menu-item-value item) item gesture))))))))))))
 
 
@@ -417,9 +332,6 @@
 (defmethod invoke-with-menu-as-popup ((window t) continuation)
   (funcall continuation))
 
-#+Allegro
-(defvar *click-outside-menu-handler* nil)
-
 ;; The drawer gets called with (stream presentation-type &rest drawer-args).
 ;; It can use presentation-type for its own purposes.  The most common uses are:
 ;;  1) Using that type as the presentation-type of the presentations it makes for each item
@@ -452,7 +364,6 @@
 	 (*input-context* nil)
 	 (*accept-help* nil)
 	 (*assume-all-commands-enabled* nil)
-	 #-Silica (*sizing-application-frame* nil)
 	 (*command-parser* 'command-line-command-parser)
 	 (*command-unparser* 'command-line-command-unparser)
 	 (*partial-command-parser*
@@ -649,7 +560,7 @@
 				:presentation-type presentation-type
 				:drawer-args drawer-args)))
 
-;;--- How to get PORT-MENU-CHOOSE into the act here?
+;;--- How to get FRAME-MANAGER-MENU-CHOOSE into the act here?
 (defmethod menu-choose ((static-menu static-menu)
 			&rest keys
 			&key (associated-window (frame-top-level-sheet *application-frame*))
diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp
index 5680c2a6..80fae920 100644
--- a/clim/noting-progress.lisp
+++ b/clim/noting-progress.lisp
@@ -2,8 +2,14 @@
 
 (in-package :clim-internals)
 
+;;; $fiHeader$
+
 "Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
 
+;;;; frame-manager-clear-progress-note: called to make it go away
+;;;; frame-manager-display-progress-note: Called to display it and
+;;;; update it.
+;;;; We probably need a frame-manager-make-progress-note also.
 
 (defvar *progress-notes* ())
 (defvar *current-progress-note*)
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 94430822..9250fd12 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: output-protocol.lisp,v 1.12 92/04/30 09:09:33 cer Exp Locker: cer $
+;; $fiHeader: output-protocol.lisp,v 1.13 92/05/07 13:12:41 cer Exp $
 
 (in-package :clim-internals)
 
@@ -46,35 +46,15 @@
       (text-margin :initarg :text-margin)
       (default-text-margin :accessor stream-default-text-margin
 			   :initarg :default-text-margin)
-      #-Silica
-      (display-device-type :initarg :display-device-type
-			   :accessor stream-display-device-type
-			   :initform (error "You must supply a :DISPLAY-DEVICE-TYPE for ~
-					     character output devices."))
-      #-Silica
-      (default-text-style :initarg :default-text-style
-			  :accessor medium-default-text-style
-			  :initform *default-text-style*)
-      #-Silica
-      (current-text-style :accessor medium-text-style
-			  :initform *null-text-style*)
       (output-glyph-buffer :accessor stream-output-glyph-buffer
                            :initarg :output-glyph-buffer)
-      #-Silica
-      (merged-text-style :initform *default-text-style*)
-      #-Silica
-      (merged-text-style-valid :initform nil
-			       :accessor medium-merged-text-style-valid)
-      #+Silica
-      (user-transformation :initform +identity-transformation+
-			   :accessor stream-user-transformation)
       (default-view :initform +textual-view+
 		    :accessor stream-default-view))
   (:default-initargs :end-of-line-action :wrap
 		     :end-of-page-action :scroll
-		     ;;-- Is this correct
+		     ;;--- Is this really appropriate?
 		     :default-text-margin +largest-coordinate+
-                     ;;--- 16 bit indices into fonts big enough?
+		     ;;--- 16 bit indices into fonts big enough?
                      :output-glyph-buffer (make-array 512 :element-type '(unsigned-byte 16)
 							  :initial-element 0)
 		     :text-margin nil))
@@ -93,19 +73,14 @@
 				       &key text-margin)
   (when text-margin
     (setq text-margin (process-spacing-arg stream text-margin 'stream-text-margin))
-    (setf (slot-value stream 'text-margin) text-margin))
-  #-Silica
-  (setf (slot-value stream 'default-text-style)
-	(parse-text-style (slot-value stream 'default-text-style))))
+    (setf (slot-value stream 'text-margin) text-margin)))
     
-#+Silica
 (defmethod (setf medium-foreground) :after (new-value (stream output-protocol-mixin))
   (let ((medium (sheet-medium stream)))
     ;; Watch out for uninitialized MEDIUM slot.
     (when (and medium (typep medium 'medium))
       (setf (medium-foreground medium) new-value))))
 
-#+Silica
 (defmethod (setf medium-background) :after (new-value (stream output-protocol-mixin))
   (let ((medium (sheet-medium stream)))
     ;; Watch out for uninitialized MEDIUM slot.
@@ -125,16 +100,19 @@
     (setq current-text-style (parse-text-style current-text-style))
     (setq merged-text-style-valid nil)))
 
-(defmethod engraft-medium :after ((medium medium) port
-						  (stream output-protocol-mixin))
+(defmethod engraft-medium :after ((medium medium) port (stream output-protocol-mixin))
   (declare (ignore port))
   ;;--- What about text style stuff, too?
   ;; We set the slots directly in order to avoid running any per-port
   ;; :AFTER methods (or whatever).  That work should be done by similar
   ;; per-port methods on ENGRAFT-MEDIUM.
   (with-slots (silica::foreground silica::background) medium
-    (setf silica::foreground (or (medium-foreground stream) +black+)
-	  silica::background (or (medium-background stream) +white+))))
+    (setf silica::foreground (or (medium-foreground stream)
+				 (setf (medium-foreground stream)
+				   +black+))
+	  silica::background (or (medium-background stream)
+				 (setf (medium-background stream)
+				   +white+)))))
 
 ;;--- I sure don't like having to do this to make string streams work
 (defmethod stream-default-view ((stream t)) +textual-view+)
@@ -151,10 +129,6 @@
   (let ((text-margin (process-spacing-arg stream new-value 'stream-text-margin)))
     (setf (slot-value stream 'text-margin) text-margin)))
 
-#+Silica
-(defmethod get-transformation ((stream output-protocol-mixin))
-  (stream-user-transformation stream))
-
 ;;; Genera supports passing an environment to CONSTANTP and EVAL.  Allegro doesn't.
 ;;; Until we test all other candidates, be conservative.
 (defmacro with-end-of-page-action (#+CLIM-1-compatibility (stream &optional action)
@@ -209,16 +183,6 @@
 		    ,wrapped-body)))
     wrapped-body))
 
-#-Silica
-(defmethod medium-merged-text-style ((stream output-protocol-mixin))
-  (with-slots (current-text-style default-text-style
-	       merged-text-style merged-text-style-valid) stream
-    (if merged-text-style-valid
-	merged-text-style
-	(prog1 (setf merged-text-style (merge-text-styles current-text-style
-							  default-text-style))
-	       (setf merged-text-style-valid t)))))
-
 (defmethod stream-cursor-position ((stream output-protocol-mixin))
   (with-slots (cursor-x cursor-y) stream
     (values cursor-x cursor-y)))
@@ -232,8 +196,6 @@
 	(setf current-line-height (coordinate 0)	;going to a new line
 	      baseline (coordinate 0)))
       (setf cursor-y (coordinate y))))
-  #+Silica
-  ;;--- In the non-Silica case, this happens via an intermediary class
   (stream-ensure-cursor-visible stream x y))
 
 #+CLIM-1-compatibility
@@ -259,8 +221,6 @@
 	(setf current-line-height (coordinate 0)	;going to a new line
 	      baseline (coordinate 0)))
       (setf cursor-y (coordinate y))))
-  #+Silica
-  ;;--- In the non-Silica case, this happens via an intermediary class
   (stream-ensure-cursor-visible stream x y))
 
 #+Genera
@@ -338,11 +298,9 @@
 )	;#+CLIM-1-compatibility
 
 
-#+Silica
 (defmethod stream-force-output ((stream output-protocol-mixin))
   (port-force-output (port stream)))
 
-#+Silica
 (defmethod stream-finish-output ((stream output-protocol-mixin))
   (port-finish-output (port stream)))
 
@@ -355,16 +313,14 @@
 ;stream-finish-output
 ;stream-force-output
 ;stream-clear-output
-;stream-write-string-1
-;stream-write-char-1
 
 (defmethod stream-start-line-p ((output-stream output-protocol-mixin))
   (zerop (slot-value output-stream 'cursor-x)))
 
 (defmethod stream-line-column ((output-stream output-protocol-mixin))
   (multiple-value-bind (origin-x origin-y space-width)
-      (stream-glyph-for-character output-stream #\space
-				  (medium-merged-text-style output-stream))
+      (port-glyph-for-character (port output-stream) #\space
+				(medium-merged-text-style output-stream))
     (declare (ignore origin-x origin-y))
     (multiple-value-bind (column remainder)
 	(floor (slot-value output-stream 'cursor-x) space-width)
@@ -373,8 +329,8 @@
 
 (defmethod stream-advance-to-column ((output-stream output-protocol-mixin) column)
   (multiple-value-bind (origin-x origin-y space-width)
-      (stream-glyph-for-character output-stream #\space
-				  (medium-merged-text-style output-stream))
+      (port-glyph-for-character (port output-stream) #\space
+				(medium-merged-text-style output-stream))
     (declare (ignore origin-x origin-y))
     (let ((new-x (floor (* column space-width))))
       (when (< (slot-value output-stream 'cursor-x) new-x)
@@ -413,12 +369,9 @@
     (setf baseline (coordinate 0)
 	  current-line-height (coordinate 0))))
 
-;;; --- Should probably be on some intermediary class, since it can only
-;;; be run when the stream is part of a WINDSHIELD hierarchy.
-#+Silica
-;; --- See comment on stream-set-cursor-position
-(defmethod stream-ensure-cursor-visible ((stream output-protocol-mixin)
-					 &optional cx cy)
+;;;--- Should probably be on some intermediary class, since it can only
+;;;--- be run when the stream is part of a WINDSHIELD hierarchy.
+(defmethod stream-ensure-cursor-visible ((stream output-protocol-mixin) &optional cx cy)
   (when (and (or (not (output-recording-stream-p stream))
 		 (stream-drawing-p stream))
 	     (pane-scroller stream))
@@ -470,12 +423,12 @@
                ;; Special case so that we don't lozenge this.  It is up to
                ;; the caller to have established the correct text style.
                #+CCL-2 (eql character #\CommandMark))
-	   (let (#+Silica (medium (sheet-medium stream))
+	   (let ((medium (sheet-medium stream))
 		 (ink (medium-ink stream)))
 	     (dotimes (i 2)
 	       (multiple-value-bind (no-wrap new-cursor-x new-baseline new-height font index)
-		   (stream-scan-character-for-writing stream #+Silica medium
-						      character style cursor-x max-x)
+		   (stream-scan-character-for-writing 
+		     stream medium character style cursor-x max-x)
 		 (declare (type coordinate new-cursor-x new-baseline new-height))
 		 (when no-wrap
 		   (when record-p
@@ -489,16 +442,11 @@
 		       (setf baseline new-baseline))
 		     ;;--- need draw-glyphs, which will take a port-specific font object, 
 		     ;;--- as well as the :INK option.
-		     #+Silica
 		     (with-identity-transformation (medium)
 		       (draw-text* medium character ; (code-char index)??
 				   cursor-x (+ cursor-y (- baseline new-baseline))
 				   :text-style style
-				   :align-x :left :align-y :top))
-		     #-Silica
-		     (stream-write-char-1
-		       stream index font ink
-		       cursor-x (+ cursor-y (- baseline new-baseline))))
+				   :align-x :left :align-y :top)))
 		   (encode-stream-after-writing stream new-cursor-x cursor-y
 						(max baseline new-baseline)
 						(max height new-height))
@@ -619,14 +567,13 @@
     (declare (type coordinate cursor-x cursor-y baseline height max-x))
     (unless (or draw-p record-p)
       (return-from stream-write-string string))	;No deeds to do
-    (let (#+Silica (medium (sheet-medium stream))
+    (let ((medium (sheet-medium stream))
 	  (ink (medium-ink stream)))
       (loop
 	(multiple-value-bind (write-char next-char-index
 			      new-cursor-x new-baseline new-height font)
-	    (stream-scan-string-for-writing stream #+Silica medium
-					    string start end style
-					    cursor-x max-x glyph-buffer)
+	    (stream-scan-string-for-writing 
+	      stream medium string start end style cursor-x max-x glyph-buffer)
 	  (declare (type coordinate new-cursor-x new-baseline new-height))
 	  (when record-p
 	    (stream-add-string-output
@@ -643,21 +590,12 @@
 	      (unless (zerop amount)
 		;; --- need draw-glyphs, which will take a port-specific font object,
 		;; as well as the :INK option.
-		#+Silica
 		(with-identity-transformation (medium)
 		  (draw-text* medium string
 			      cursor-x (+ cursor-y (- baseline new-baseline))
 			      :text-style style
 			      :start start :end next-char-index
-			      :align-x :left :align-y :top))
-		#-Silica
-                (if glyph-buffer
-		    (stream-write-string-1
-		      stream glyph-buffer 0 (the fixnum (- next-char-index start)) font
-		      ink cursor-x (+ cursor-y (- baseline new-baseline)))
-                    (stream-write-string-1
-		      stream string start next-char-index font
-		      ink cursor-x (+ cursor-y (- baseline new-baseline)))))))
+			      :align-x :left :align-y :top)))))
 	  (setf baseline (max baseline new-baseline)
 		height (max height new-height)
 		cursor-x new-cursor-x)
@@ -687,13 +625,13 @@
 (defmethod stream-move-for-line-height-change ((stream output-protocol-mixin)
 					       movement old-height cursor-x cursor-y)
   ;;--- This doesn't appear to work yet, and it's "not cheap"
-  #+ignore (copy-area stream
-		      0 cursor-y
-		      cursor-x (+ cursor-y old-height)
-		      0 (+ cursor-y movement))
-  #+ignore (window-clear-area stream
-			      0 cursor-y
-			      cursor-x (+ cursor-y movement)))
+  #+++ignore (copy-area stream
+			0 cursor-y
+			cursor-x (+ cursor-y old-height)
+			0 (+ cursor-y movement))
+  #+++ignore (window-clear-area stream
+				0 cursor-y
+				cursor-x (+ cursor-y movement)))
 
 ;;; Simple version: does no wrapping, assumes we start at leftmost
 ;;; column.  It doesn't do what Genera :STRING-LENGTH message does,
@@ -709,13 +647,12 @@
 	(baseline (coordinate 0))
 	(largest-x (coordinate 0)))
     (declare (type coordinate cursor-x cursor-y height baseline largest-x))
-    (let (#+Silica (medium (sheet-medium stream)))
+    (let ((medium (sheet-medium stream)))
       (loop
 	(when (>= start end) (return))
 	(multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height)
-	    (stream-scan-string-for-writing stream #+Silica medium
-					    string start end style
-					    cursor-x +largest-coordinate+)
+	    (stream-scan-string-for-writing
+	      stream medium string start end style cursor-x +largest-coordinate+)
 	  (declare (type coordinate new-cursor-x new-baseline new-height))
 	  (maxf largest-x new-cursor-x)
 	  (maxf baseline new-baseline)
@@ -723,7 +660,7 @@
 	  (setf cursor-x new-cursor-x
 		start next-char-index)
 	  (when write-char
-	    (cond #+Ignore ;; Can't happen at the moment.
+	    (cond #+++ignore ;; Can't happen at the moment.
 		  ((or (graphic-char-p write-char) (diacritic-char-p write-char))
 		   (multiple-value-bind (no-wrap new-cursor-x new-baseline new-height)
 		       (stream-scan-character-for-writing stream character style
@@ -765,7 +702,7 @@
     (cond ((or (graphic-char-p character) (diacritic-char-p character))
 	   (multiple-value-bind  (index font escapement-x escapement-y
 				  origin-x origin-y bb-x bb-y)
-	       (stream-glyph-for-character stream character style)
+	       (port-glyph-for-character (port stream) character style)
 	     (declare (ignore index font escapement-x escapement-y origin-x origin-y))
 	     (values bb-x bb-y)))
 	  ((or (eql character #\Newline)
@@ -786,37 +723,21 @@
   (let ((current-line-height (stream-current-line-height stream)))
     (if (or text-style (zerop current-line-height))
 	(multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y)
-	    (stream-glyph-for-character stream #\Space
-					(or text-style
-					    (medium-merged-text-style stream)))
+	    (port-glyph-for-character (port stream) #\Space
+				      (or text-style
+					  (medium-merged-text-style stream)))
 	  (declare (ignore index font escapement-x escapement-y origin-x origin-y bb-x))
 	  (coordinate bb-y))
 	current-line-height)))
 
 (defmethod stream-tab-size ((stream output-protocol-mixin) text-style)
   (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y)
-      (stream-glyph-for-character stream #\n	;En space
-				  (or text-style
-				      (medium-merged-text-style stream)))
+      (port-glyph-for-character (port stream) #\n	;En space
+				(or text-style
+				    (medium-merged-text-style stream)))
     (declare (ignore index font escapement-y origin-x origin-y bb-y))
     (coordinate (* (max bb-x escapement-x) 8.))))
 
-;;;--- These forwarding methods are for Silica conversion convenience only.
-;;; Their callers should be changed to invoke the method on the medium directly.
-#+Silica
-(defmethod stream-glyph-for-character ((stream output-protocol-mixin) character appearance &optional our-font)
-  (stream-glyph-for-character (sheet-medium stream) character appearance our-font))
-
-#+Silica
-(defmethod stream-write-char-1 ((stream output-protocol-mixin) index x-font color x y)
-  (stream-write-char-1 (sheet-medium stream) index x-font color x y))
-
-;;;--- This forwarding method is for Silica conversion convenience only.
-#+Silica
-(defmethod stream-write-string-1 ((stream output-protocol-mixin)
-				  glyph-buffer start end x-font color x y)
-  (stream-write-string-1 (sheet-medium stream) glyph-buffer start end x-font color x y))
-
 
 ;;; A few utilities for string writing.
 
@@ -917,13 +838,11 @@
 	     (values character start cursor-x baseline height our-font)))
 	 (multiple-value-bind (index font escapement-x escapement-y
 			       origin-x origin-y bb-x bb-y fixed-width-font-p)
-	     ;; --- For now we are asserting that each string passed to WRITE-STRING
-	     ;; will have no character style changes within it.  So, we can
-	     ;; eliminate a call to TEXT-STYLE-MAPPING within 
-	     ;; STREAM-GLYPH-FOR-CHARACTER, which saves a >lot< of time.
-	     (stream-glyph-for-character
-	       #-Silica stream #+Silica medium 
-	       character style our-font)
+	     ;;--- For now we are asserting that each string passed to WRITE-STRING
+	     ;;--- will have no character style changes within it.  So, we can
+	     ;;--- eliminate a call to TEXT-STYLE-MAPPING within 
+	     ;;--- PORT-GLYPH-FOR-CHARACTER, which saves a lot of time.
+	     (port-glyph-for-character (port medium) character style our-font)
 	   (declare (ignore escapement-y origin-x bb-x))
 	   (declare (type fixnum index))
 	  (let ((origin-y (coordinate origin-y))
@@ -978,7 +897,7 @@
 	   (setf our-font font)
 	   (setq start (the fixnum (+ start 1)))))))))
 
-(defmethod stream-scan-string-for-writing ((stream output-protocol-mixin) #+Silica medium
+(defmethod stream-scan-string-for-writing ((stream output-protocol-mixin) medium
 					   string start end style
 					   cursor-x max-x &optional glyph-buffer)
   (declare (values write-char next-char-index new-cursor-x new-baseline new-height font))
@@ -989,12 +908,12 @@
 ;;; This function returns NIL as its first value if the character won't
 ;;; fit on the current line.  It is never called on non-graphic
 ;;; characters; they are handled in WRITE-CHAR instead.
-(defmethod stream-scan-character-for-writing ((stream output-protocol-mixin) #+Silica medium
+(defmethod stream-scan-character-for-writing ((stream output-protocol-mixin) medium
 					      character style cursor-x max-x)
   (declare (values char-normal new-cursor-x new-baseline new-height font))
   (declare (type coordinate cursor-x max-x))
   (multiple-value-bind (index font escapement-x escapement-y origin-x origin-y bb-x bb-y)
-      (stream-glyph-for-character medium character style)
+      (port-glyph-for-character (port medium) character style)
     (declare (ignore escapement-y origin-x bb-x))
     (when (> (+ cursor-x escapement-x *character-wrap-indicator-width*) max-x)
       (return-from stream-scan-character-for-writing 
@@ -1031,6 +950,46 @@
   (let ((tab-size (stream-tab-size stream style)))
     (coordinate (* tab-size (ceiling (1+ cursor-x) tab-size)))))
 
+
+;;; Speedy, bare-bones drawing functions for things like highlighting
+
+(defun draw-line-internal
+       (stream xoff yoff x1 y1 x2 y2 ink style)
+  (let ((medium (sheet-medium stream)))
+    (letf-globally (((medium-line-style medium)
+		     (or style (medium-line-style medium)))
+		    ((medium-transformation medium) +identity-transformation+)
+		    ((medium-ink medium) ink))
+      (medium-draw-line* medium
+			 (+ x1 xoff) (+ y1 yoff)
+			 (+ x2 xoff) (+ y2 yoff)))))
+
+(defun draw-rectangle-internal
+       (stream xoff yoff left top right bottom ink style)
+  (let ((medium (sheet-medium stream)))
+    (letf-globally (((medium-line-style medium)
+		     (or style (medium-line-style medium)))
+		    ((medium-transformation medium) +identity-transformation+)
+		    ((medium-ink medium) ink))
+      (medium-draw-rectangle* medium
+			      (+ left xoff) (+ top yoff)
+			      (+ right xoff) (+ bottom yoff)
+			      (not style)))))
+
+(defun draw-ellipse-internal
+       (stream xoff yoff center-x center-y
+	radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+	start-angle end-angle ink style)
+  (let ((medium (sheet-medium stream)))
+    (letf-globally (((medium-line-style medium)
+		     (or style (medium-line-style medium)))
+		    ((medium-transformation medium) +identity-transformation+)
+		    ((medium-ink medium) ink))
+      (medium-draw-ellipse* medium
+			    (+ center-x xoff) (+ center-y yoff)
+			    radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+			    start-angle end-angle (not style)))))
+
 
 ;;; Genera hooks
 
@@ -1127,14 +1086,13 @@
   (unless start (setq start 0))
   (unless end (setq end (length string)))
   (let ((vsp (stream-vertical-spacing stream))
-	#+Silica (medium (sheet-medium stream)))
+	(medium (sheet-medium stream)))
     (loop
       (when (>= start end)
 	(return (values cursor-x cursor-y height baseline)))
       (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height)
-	  (stream-scan-string-for-writing stream #+Silica medium
-					  string start end style
-					  cursor-x max-x)
+	  (stream-scan-string-for-writing 
+	    stream medium string start end style cursor-x max-x)
 	(maxf height new-height)
 	(maxf baseline new-baseline) 
 	(setf start next-char-index)
diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp
index d8f3b381..7e49b469 100644
--- a/clim/pixmap-streams.lisp
+++ b/clim/pixmap-streams.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pixmap-streams.lisp,v 1.4 92/04/21 16:13:12 cer Exp Locker: cer $
+;; $fiHeader: pixmap-streams.lisp,v 1.5 92/05/07 13:12:43 cer Exp $
 
 (in-package :clim-internals)
 
@@ -43,20 +43,16 @@
 (defmethod update-mirror-region ((port port) (sheet pixmap-stream))
   nil)
 
-(defmethod initialize-instance :after ((stream pixmap-stream) &key 
-							      port
-							      pixmap
-							      width
-							      height
-							      sheet)
+(defmethod initialize-instance :after ((stream pixmap-stream) 
+				       &key port sheet pixmap
+				       width height)
   (setf (sheet-direct-mirror stream) pixmap
 	(port stream) port
 	(sheet-transformation stream) +identity-transformation+
 	(sheet-region stream) (make-bounding-rectangle 0 0 width height)
-	;;-- What about text style
-	(medium-foreground stream) (medium-foreground sheet)
-	(medium-background stream) (medium-background sheet)))
-
+	;;--- What about text style?
+	(medium-foreground stream) (or (medium-foreground sheet) +black+)
+	(medium-background stream) (or (medium-background sheet) +white+)))
 
 ;; Interface to this stuff
 
@@ -80,12 +76,12 @@
 
 (defmethod allocate-pixmap-stream (sheet pixmap width height)
   (make-instance 'pixmap-stream 
-		 :sheet sheet
 		 :default-text-margin width
 		 :pixmap pixmap 
 		 :width width
 		 :height height
-		 :port (port sheet)))
+		 :port (port sheet)
+		 :sheet sheet))
 
 (defun copy-from-pixmap (pixmap pixmap-x pixmap-y width height
 			 stream window-x window-y)
diff --git a/clim/presentations.lisp b/clim/presentations.lisp
index 732d2bc1..00e0dcc9 100644
--- a/clim/presentations.lisp
+++ b/clim/presentations.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: presentations.lisp,v 1.8 92/04/15 11:47:04 cer Exp $
+;; $fiHeader: presentations.lisp,v 1.9 92/05/07 13:12:50 cer Exp $
 
 (in-package :clim-internals)
 
@@ -383,16 +383,14 @@
 		   (highlight-output-record 
 		     history-window highlighted-presentation :unhighlight)
 		   (setf highlighted-presentation nil)
-		   (when *pointer-documentation-output*
-		     (frame-document-highlighted-presentation
-		       frame highlighted-presentation
-		       input-context history-window px py
-		       *pointer-documentation-output*)))
+		   (frame-document-highlighted-presentation
+		     frame highlighted-presentation
+		     input-context history-window px py
+		     *pointer-documentation-output*))
 		  ((eq presentation highlighted-presentation)
 		   ;; Over the same presentation as before
-		   (when (and *pointer-documentation-output*
-			      (/= (window-modifier-state history-window)
-				  *last-pointer-documentation-modifier-state*))
+		   (when (/= (window-modifier-state history-window)
+			     *last-pointer-documentation-modifier-state*)
 		     (frame-document-highlighted-presentation
 		       frame presentation
 		       input-context history-window px py
@@ -405,11 +403,10 @@
 		       history-window highlighted-presentation :unhighlight))
 		   (highlight-output-record history-window presentation :highlight)
 		   (setf highlighted-presentation presentation)
-		   (when *pointer-documentation-output*
-		     (frame-document-highlighted-presentation
-		       frame presentation
-		       input-context history-window px py
-		       *pointer-documentation-output*))))))))))
+		   (frame-document-highlighted-presentation
+		     frame presentation
+		     input-context history-window px py
+		     *pointer-documentation-output*)))))))))
 
 (defun highlighted-presentation (stream &optional (prefer-pointer-window t))
   (let ((history-window (if prefer-pointer-window (find-appropriate-window stream) stream)))
diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp
index 39193b36..6c52f91a 100644
--- a/clim/ptypes1.lisp
+++ b/clim/ptypes1.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: ptypes1.lisp,v 1.10 92/04/15 11:47:07 cer Exp $
+;; $fiHeader: ptypes1.lisp,v 1.11 92/05/07 13:12:51 cer Exp $
 
 (in-package :clim-internals)
 
@@ -280,7 +280,7 @@
   ;; The following would be "the right thing," but it doesn't work because some compilers
   ;; evaluate the MAKE-LOAD-FORM forms out of order with the top-level forms, so the
   ;; presentation type class might not be defined yet when this is evaluated.
-  #+ignore `(find-presentation-type-class ',(class-presentation-type-name object))
+  #+++ignore `(find-presentation-type-class ',(class-presentation-type-name object))
   ;; So do this instead
   `(load-reference-to-presentation-type-class
      ',(class-presentation-type-name object #+(or Genera Minima) 'compile-file)
@@ -397,14 +397,6 @@
 (defmethod acceptable-presentation-type-class ((class ccl::compile-time-class))
   nil)
 
-#+Allegro
-(progn
-(warn "~S for ~S should be elsewhere" 'clos::class-prototype 'clos::structure-class)
-
-(defmethod clos::class-prototype ((class clos::structure-class)) 
-  (allocate-instance class))
-)	;#+Allegro
-
 
 ;;;; Retrieving Information about a Presentation Type or P.T. Abbreviation
 
diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp
index b764be15..e3589ef8 100644
--- a/clim/ptypes2.lisp
+++ b/clim/ptypes2.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: ptypes2.lisp,v 1.6 92/04/15 11:47:10 cer Exp $
+;; $fiHeader: ptypes2.lisp,v 1.7 92/05/07 13:12:54 cer Exp $
 
 (in-package :clim-internals)
 
@@ -96,11 +96,7 @@
 	(describe-presentation-type presentation-type stream plural-count))
       (let ((type (expand-presentation-type-abbreviation presentation-type)))
 	(with-presentation-type-decoded (nil nil options) type
-	  (let ((description 
-		  (or (getf options :description)
-		      (with-presentation-type-decoded (name) presentation-type
-			(gethash (find-presentation-type-class name)
-				 *presentation-type-description-table* name)))))
+	  (let ((description (getf options :description)))
 	    (if description
 		(default-describe-presentation-type description stream plural-count)
 		(funcall-presentation-generic-function describe-presentation-type
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index a0286437..b22d3568 100644
--- a/clim/recording-protocol.lisp
+++ b/clim/recording-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: recording-protocol.lisp,v 1.10 92/05/06 15:37:43 cer Exp Locker: cer $
+;; $fiHeader: recording-protocol.lisp,v 1.11 92/05/07 13:12:55 cer Exp $
 
 (in-package :clim-internals)
 
@@ -104,20 +104,19 @@
 	(setf right  (+ nx width)
 	      bottom (+ ny height))))))
 
-#+ignore
+#+++ignore
 (defmethod bounding-rectangle-set-position :around ((record output-record-element-mixin) nx ny)
   (with-bounding-rectangle* (x1 y1 x2 y2) record
     (call-next-method)
     (note-output-record-moved record (- nx x1) (- ny y1) (- nx x2) (- ny y2))))
 
-#+ignore
+#+++ignore
 (defmethod bounding-rectangle-set-edges :around ((record output-record-element-mixin) 
 						 left top right bottom)
   (with-bounding-rectangle* (x1 y1 x2 y2) record
     (call-next-method)
     (note-output-record-moved record (- left x1) (- top y1) (- right x2) (- bottom y2))))
 
-#+Silica
 (defmethod note-output-record-moved ((record output-record-element-mixin) dx1 dy1 dx2 dy2)
   (declare (ignore dx1 dy1 dx2 dy2))
   nil)
@@ -414,7 +413,6 @@
 
 (defmethod children-never-overlap-p ((record output-record-mixin)) nil)
 
-#+Silica
 (defmethod note-output-record-moved :after ((record output-record-mixin) dx1 dy1 dx2 dy2)
   (unless (and (zerop dx1)
 	       (zerop dy1)
@@ -425,7 +423,6 @@
       (declare (dynamic-extent #'note-moved))
       (map-over-output-records #'note-moved record))))
 
-#+Silica
 (defmethod bounding-rectangle-set-position :around ((record output-record-mixin) nx ny)
   (multiple-value-bind (ox oy)
       (output-record-position record)
@@ -435,7 +432,6 @@
 				(coordinate 1) (coordinate 1)
 				(coordinate 1) (coordinate 1)))))
 
-#+Silica
 (defmethod bounding-rectangle-set-edges :around ((record output-record-mixin) 
 						 left top right bottom)
   (declare (ignore  left top right bottom))
@@ -689,12 +685,15 @@
 		     #'replay-1 record region 
 		     (- x-offset) (- y-offset)
 		     (+ x-offset xoff) (+ y-offset yoff))
-		   ;;--- Nasty hack to get around nasty bug
+		   ;;--- Nasty hack to get around nasty bug caused by
+		   ;;--- doing things this way
+		   #+++ignore
 		   (note-output-record-replayed record stream region x-offset y-offset))
 		 (replay-output-record record stream region x-offset y-offset))))
     (declare (dynamic-extent #'replay-1))
     (replay-1 record x-offset y-offset)))
 
+#+++ignore
 (defmethod note-output-record-replayed ((record output-record-mixin) stream
 					&optional region x-offset y-offset)
   (declare (ignore stream region x-offset y-offset))
@@ -1074,8 +1073,8 @@
 
 (defmethod bounding-rectangle-set-edges ((record stream-output-history-mixin)
 					 nleft ntop nright nbottom)
-  #+ignore (assert (<= nleft nright))
-  #+ignore (assert (<= ntop  nbottom))
+  #+++ignore (assert (<= nleft nright))
+  #+++ignore (assert (<= ntop  nbottom))
   (with-slots (left top right bottom parent stream) record
     ;; Top-level output records must not have their upper left corner any
     ;; "later" than (0,0), or else scroll bars and scrolling will not do
@@ -1091,7 +1090,6 @@
 	    bottom (coordinate nbottom))))
   record)
 
-#+Silica
 (defmethod bounding-rectangle-set-edges :around ((record stream-output-history-mixin) 
 						 nleft ntop nright nbottom)
   (let ((nleft (coordinate nleft))
@@ -1238,7 +1236,6 @@
       (stream-close-text-output-record stream))))
 
 ;;; This method should cover a multitude of sins.
-#+Silica
 (defmethod repaint-sheet :after ((stream output-recording-mixin) region)
   ;;--- Who should establish the clipping region?
   ;;--- Is it here or in the handle-repaint method
@@ -1249,93 +1246,11 @@
 		     (bounding-rectangle stream)))))
     (unless (eq clear +nowhere+)
       (with-sheet-medium (medium stream)
-	(with-bounding-rectangle* (a b c d) clear
-				  (draw-rectangle*
-				   medium
-				   a b c d
-				   :ink +background-ink+)))
+	(with-bounding-rectangle* (left top right bottom) clear
+	  (draw-rectangle* medium left top right bottom
+			   :ink +background-ink+)))
       (stream-replay stream region))))
 
-
-;;; For Silica
-;;;--- Consider these old methods on a case-by-case basis to see if the
-;;; general handle-repaint method subsumes them.
-
-;;; --- should merge our process-update-region with handle-repaint
-;;; Do we use it anywhere where Silica isn't generating handle-repaint?
-
-;;; Mix in window-output-recording when you have mixed together
-;;; something supporting the window protocol and something supporting
-;;; the output recording protocol.
-#-Silica
-(progn
-
-(defmethod window-process-update-region :around ((stream window-output-recording))
-  (let ((update-region (slot-value stream 'update-region)))
-    (when update-region
-      (with-output-recording-options (stream :draw t :record nil)
-	(let ((highlighted-presentation (slot-value stream 'highlighted-presentation)))
-	  (when highlighted-presentation
-	    (highlight-output-record stream highlighted-presentation :unhighlight))
-	  (call-next-method)
-	  (dolist (region update-region)
-	    (with-clipping-region (stream region)
-	      (frame-replay *application-frame* stream region)))
-	  (when highlighted-presentation
-	    (highlight-output-record stream highlighted-presentation :highlight))))
-      (window-flush-update-region stream))))
-
-;;;--- We need some version of this code to do the area copying.
-(defmethod window-set-viewport-position :around ((stream window-output-recording)
-						  new-x new-y)
-  (declare (ignore new-x new-y))
-  (with-bounding-rectangle* (left top right bottom) (window-viewport stream)
-    (call-next-method)
-    ;; now replay
-    (with-bounding-rectangle* (nl nt nr nb) (window-viewport stream)
-      (cond
-	;; if some of the stuff that was previously on display is still on display
-	;; bitblt it into the proper place and redraw the rest.
-	((ltrb-overlaps-ltrb-p left top right bottom
-			       nl nt nr nb)
-	 ;; move the old stuff to the new position
-	 (window-shift-visible-region stream left top right bottom
-				      nl nt nr nb)
-	 (window-process-update-region stream))
-	;; otherwise, just redraw the whole visible viewport
-	;; Adjust for the left and top margins by hand so clear-area doesn't erase
-	;; the margin components.
-	(t (multiple-value-bind (ml mt) (window-margins stream)
-	     (declare (type coordinate ml mt))
-	     (multiple-value-bind (vw vh) (window-inside-size stream)
-	       (declare (type coordinate vw vh))
-	       (window-clear-area stream
-				  ml mt (+ ml vw) (+ mt vh))))
-	   (frame-replay *application-frame* stream (window-viewport stream)))))))
-
-(defmethod window-refresh :after ((stream window-output-recording))
-  ;; don't bother me, it takes too long and is useless since
-  ;; we'll refresh this again when it eventually becomes visible
-  (when (window-drawing-possible stream)
-    (frame-replay *application-frame* stream (window-viewport stream))
-    (let ((text-record (stream-text-output-record stream)))
-      (when text-record (replay text-record stream)))
-    (redisplay-decorations stream)))
-
-;;; I don't think that this is needed.
-(defmethod window-note-size-or-position-change :after ((stream window-output-recording)
-						       left top right bottom)
-  (declare (ignore left top right bottom))
-  #+Ignore
-  (when (window-visibility stream)
-    (window-refresh stream)))
-
-;;; --- Define Silica version of this.
-(defmethod window-clear :before ((stream window-output-recording))
-  (clear-output-history stream))
-
-) ; end of #-Silica PROGN
-
 
 ;;; Genera compatibility
 
diff --git a/clim/stream-class-defs.lisp b/clim/stream-class-defs.lisp
index fe44262e..7ef28cc6 100644
--- a/clim/stream-class-defs.lisp
+++ b/clim/stream-class-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: stream-class-defs.lisp,v 1.5 92/04/15 11:47:19 cer Exp $
+;; $fiHeader: stream-class-defs.lisp,v 1.6 92/05/07 13:13:02 cer Exp $
 
 (in-package :clim-internals)
 
@@ -89,25 +89,8 @@
 )	;#+CLIM-1-compatibility
 
 
-;;; Exists to hang window&output-recording :around methods on.
-#-Silica
+;; For any window-specific output recording methods
 (defclass window-output-recording () ())
 
-;;; Exists to hang window&graphics :around methods on.
+;; For any window-specific graphics output recording methods
 (defclass graphics-output-recording () ())
-
-;;; This is the class you mix in (in addition) when you've mixed together
-;;; the extended-input-protocol and the window-protocol.
-#-Silica
-(defclass input-and-window-protocol-intermediary () ())
-
-;;; This is the class you mix in (in addition) when you've mixed together
-;;; the extended-output-protocol and the window-protocol.
-#-Silica
-(defclass output-and-window-protocol-intermediary () ())
-
-;;; This is the class you mix in (in addition) when you've mixed together
-;;; the extended-output-protocol and output-recording-mixin.
-#-Silica
-(defclass output-and-recording-protocol-intermediary () ())
-
diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp
index ef6a79bf..f28f8a2b 100644
--- a/clim/stream-defprotocols.lisp
+++ b/clim/stream-defprotocols.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: stream-defprotocols.lisp,v 1.6 92/04/15 11:47:21 cer Exp $
+;; $fiHeader: stream-defprotocols.lisp,v 1.7 92/05/07 13:13:03 cer Exp $
 
 (in-package :clim-internals)
 
@@ -180,15 +180,12 @@
   #+CLIM-uses-lisp-stream-functions (:no-defgeneric t))
 
 (defoperation stream-scan-string-for-writing fundamental-character-output-stream
-  ((stream fundamental-character-output-stream) #+Silica medium
-   string start end style cursor-x max-x &optional glyph-buffer))
+  ((stream fundamental-character-output-stream) 
+   medium string start end style cursor-x max-x &optional glyph-buffer))
 
 (defoperation stream-scan-character-for-writing fundamental-character-output-stream
-  ((stream fundamental-character-output-stream) #+Silica medium
-   character style cursor-x max-x))
-
-(defoperation stream-write-string-1 fundamental-character-output-stream
-  ((stream fundamental-character-output-stream) glyph-buffer start end font color x y))
+  ((stream fundamental-character-output-stream) 
+   medium character style cursor-x max-x))
 
 #+Allegro
 (defoperation excl::stream-interactive-force-output fundamental-output-stream
@@ -347,20 +344,9 @@
 
 ;;; window protocol
 
-#+Silica
 (define-stream-protocol window-mixin)
 
-#-Silica
-(define-stream-protocol window-mixin
-  window-parent
-  window-children
-  window-console
-  window-name
-  window-depth
-  window-viewport
-  window-update-region
-  window-visibility
-  window-label)
+;;--- What about WINDOW-VISIBILITY, and the other "inside edges" generics?
 
 (defoperation window-clear window-mixin
   ((window window-mixin)))
@@ -387,80 +373,9 @@
 (defoperation window-set-inside-size window-mixin
   ((window window-mixin) new-width new-height))
 
-#-Silica (progn
-(defoperation window-stack-on-top window-mixin
-  ((window window-mixin)))
-
-(defoperation window-stack-on-bottom window-mixin
-  ((window window-mixin)))
-
-(defoperation copy-area window-mixin
-  ((window window-mixin)
-   from-left from-top from-right from-bottom to-left to-top))
-
-(defoperation window-drawing-possible window-mixin
-  ((window window-mixin)))
-
-(defoperation redisplay-decorations window-mixin
-  ((window window-mixin)) )
-
-(defoperation window-to-screen-coordinates window-mixin
-  ((window window-mixin) x y))
-
-(defoperation screen-to-window-coordinates window-mixin
-  ((window window-mixin) x y))
-
-(defoperation window-inside-edges window-mixin
-  ((window window-mixin))
-  (declare (values left top right bottom)))
-
-(defoperation window-set-inside-edges window-mixin
-  ((window window-mixin) new-left new-top new-right new-bottom))
-
-(defoperation window-inside-left window-mixin
-  ((window window-mixin)))
-
-(defoperation window-inside-top window-mixin
-  ((window window-mixin)))
-
-(defoperation window-inside-right window-mixin
-  ((window window-mixin)))
-
-(defoperation window-inside-bottom window-mixin
-  ((window window-mixin)))
-
-(defoperation window-inside-width window-mixin
-  ((window window-mixin)))
-
-(defoperation window-inside-height window-mixin
-  ((window window-mixin)))
-
-(defoperation window-label-size window-mixin
-  ((window-mixin window-mixin) &optional (label (window-label window-mixin))))
-
-(defoperation window-note-size-or-position-change window-mixin
-  ((window window-mixin) new-left new-top new-right new-bottom))
-
-(defoperation window-shift-visible-region window-mixin
-  ((window window-mixin) 
-   old-left old-top old-right old-bottom
-   new-left new-top new-right new-bottom))
-
-(defoperation window-flush-update-region window-mixin
-  ((window window-mixin)))
-
-(defoperation window-process-update-region window-mixin
-  ((window window-mixin)))
-
-(defoperation window-beep window-mixin
-  ((window window-mixin)))
-
-;;; What modifier keys are presently down?
 (defoperation window-modifier-state window-mixin
   ((window window-mixin)))
 
-)	;#-Silica
-
 
 ;;; Output recording.
 (define-stream-protocol output-recording-mixin
@@ -494,7 +409,6 @@
 ;;; Input editing stream protocol doesn't need to be encapsulated, for obvious reasons.
 
 
-#+Silica (progn
 (define-stream-protocol pane-protocol)
 
 (defoperation pane-display-function pane-protocol
@@ -508,5 +422,3 @@
 
 (defoperation pane-frame pane-protocol
   ((pane pane-protocol)))
-
-)	;#+Silica
diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp
index 1c0d2307..20075c22 100644
--- a/clim/table-formatting.lisp
+++ b/clim/table-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: table-formatting.lisp,v 1.6 92/04/15 11:47:25 cer Exp $
+;; $fiHeader: table-formatting.lisp,v 1.7 92/05/07 13:13:05 cer Exp $
 
 (in-package :clim-internals)
 
@@ -201,7 +201,7 @@
 	      min-y (coordinate 0)
 	      max-x (coordinate 0)
 	      max-y (coordinate 0)))
-      #+ignore (assert (ltrb-well-formed-p min-x min-y max-x max-y))
+      #+++ignore (assert (ltrb-well-formed-p min-x min-y max-x max-y))
       (translate-coordinates x-offset y-offset min-x min-y max-x max-y)
       (bounding-rectangle-set-edges record min-x min-y max-x max-y)
       (values min-x min-y max-x max-y))))
@@ -391,8 +391,7 @@
       (when (> row-count 5)
 	(with-bounding-rectangle* (tleft ttop tright tbottom) table
 	  (multiple-value-bind (stream-width stream-height)
-	      #-Silica (window-inside-size stream)
-	      #+Silica (bounding-rectangle-size stream)
+	      (bounding-rectangle-size stream)
 	    (declare (type coordinate stream-width)
 		     (ignore stream-height)) ;for now
 	    (let* ((table-width (- tright tleft))
@@ -435,7 +434,7 @@
 
 (defmethod adjust-table-cells ((row standard-row-output-record) stream)
   (declare (ignore stream))
-  #+ignore
+  #+++ignore
   (let ((x-spacing (slot-value (output-record-parent row) 'x-spacing))
 	(x-position (coordinate 0)))
     (map-over-row-cells
@@ -448,7 +447,7 @@
 
 (defmethod adjust-table-cells ((column standard-column-output-record) stream)
   (declare (ignore stream))
-  #+ignore
+  #+++ignore
   (let ((x-spacing (slot-value (output-record-parent column) 'x-spacing))
 	(x-position (coordinate 0)))
     (map-over-row-cells 
diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp
index 4b568b20..84895b88 100644
--- a/clim/text-recording.lisp
+++ b/clim/text-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-recording.lisp,v 1.4 92/04/15 11:47:28 cer Exp $
+;; $fiHeader: text-recording.lisp,v 1.5 92/05/07 13:13:08 cer Exp $
 
 (in-package :clim-internals)
 
@@ -74,63 +74,50 @@
 	 (start 0)
 	 (end (length string))
 	 (text-style (medium-default-text-style stream))
-	 #+Silica (port (port stream))
-	 (baseline (- (text-style-height text-style #-Silica stream #+Silica port)
-		      (text-style-descent text-style #-Silica stream #+Silica port)))
+	 (port (port stream))
+	 (baseline (- (text-style-height text-style port)
+		      (text-style-descent text-style port)))
 	 (glyph-buffer (stream-output-glyph-buffer stream))
 	 (color (slot-value record 'ink)))
     (declare (type fixnum start end))
-    (#-Silica progn
-     #+Silica with-sheet-medium #+Silica (medium stream)
-     (macrolet
-      ((do-it (end-position)
-	 `(loop
-	    (when (>= start ,end-position) (return))
-	    (multiple-value-bind (write-char next-char-index
-				  new-cursor-x new-baseline new-height font)
-		(stream-scan-string-for-writing stream #+Silica medium
-						string start ,end-position text-style
-						cursor-x +largest-coordinate+
-						glyph-buffer)
-	      ;; GLYPH-BUFFER NIL => pass the string to the port-specific code.
-	      #-Silica
-	      (if glyph-buffer
-		  (stream-write-string-1
-		    stream glyph-buffer 0 (the fixnum (- next-char-index start))
-		    font color
-		    cursor-x (+ cursor-y (- baseline new-baseline)))
-		  (stream-write-string-1
-		    stream string start next-char-index
-		    font color
-		    cursor-x (+ cursor-y (- baseline new-baseline))))
-	      #+Silica
-	      (with-identity-transformation (medium)
-		(draw-text* medium string
-			    cursor-x (+ cursor-y (- baseline new-baseline))
-			    :start start :end next-char-index 
-			    :align-y :top
-			    :text-style text-style :ink color))
-	      (setf cursor-x new-cursor-x start next-char-index)
-	      (when write-char
-		(cond ((eql write-char #\Tab)	;Only non-lozenged exception char?
-		       (setf cursor-x (stream-next-tab-column stream cursor-x text-style)))
-		      (t 
-		       (multiple-value-bind (new-cursor-x new-cursor-y)
-			   (stream-draw-lozenged-character
-			     stream write-char cursor-x cursor-y new-baseline new-height
-			     text-style +largest-coordinate+ nil t)
-			 (setf cursor-x new-cursor-x
-			       cursor-y new-cursor-y))))
-		(incf start))))))
-      (multiple-value-bind (cursor-x cursor-y) 
-	  (output-record-start-cursor-position record)
-	(declare (type coordinate cursor-x cursor-y))
-	(translate-coordinates x-offset y-offset cursor-x cursor-y)
-	(do-it end)
-	#-Silica
-	(when (slot-value record 'wrapped-p)
-	  (draw-character-wrap-indicator
-	    stream cursor-y (bounding-rectangle-height record) (stream-text-margin stream) nil)))))))
+    (with-sheet-medium (medium stream)
+      (macrolet
+	((do-it (end-position)
+	   `(loop
+	      (when (>= start ,end-position) (return))
+	      (multiple-value-bind (write-char next-char-index
+				    new-cursor-x new-baseline new-height font)
+		  (stream-scan-string-for-writing 
+		    stream medium string start ,end-position text-style
+		    cursor-x +largest-coordinate+ glyph-buffer)
+		(with-identity-transformation (medium)
+		  (draw-text* medium string
+			      cursor-x (+ cursor-y (- baseline new-baseline))
+			      :start start :end next-char-index 
+			      :align-y :top
+			      :text-style text-style :ink color))
+		(setf cursor-x new-cursor-x start next-char-index)
+		(when write-char
+		  (cond ((eql write-char #\Tab)	;Only non-lozenged exception char?
+			 (setf cursor-x (stream-next-tab-column stream cursor-x text-style)))
+			(t 
+			 (multiple-value-bind (new-cursor-x new-cursor-y)
+			     (stream-draw-lozenged-character
+			       stream write-char cursor-x cursor-y new-baseline new-height
+			       text-style +largest-coordinate+ nil t)
+			   (setf cursor-x new-cursor-x
+				 cursor-y new-cursor-y))))
+		  (incf start))))))
+	(multiple-value-bind (cursor-x cursor-y) 
+	    (output-record-start-cursor-position record)
+	  (declare (type coordinate cursor-x cursor-y))
+	  (translate-coordinates x-offset y-offset cursor-x cursor-y)
+	  (do-it end)
+	  #-Silica				;--- what about this?
+	  (when (slot-value record 'wrapped-p)
+	    (draw-character-wrap-indicator
+	      stream cursor-y (bounding-rectangle-height record)
+	      (stream-text-margin stream) nil)))))))
 
 (defmethod replay-output-record ((record styled-text-output-record) stream
 				 &optional region 
@@ -145,63 +132,50 @@
 	 (glyph-buffer (stream-output-glyph-buffer stream))
 	 (color (slot-value record 'ink)))
     (declare (type fixnum start end))
-    (#-Silica progn
-     #+Silica with-sheet-medium #+Silica (medium stream)
-     (macrolet
-      ((do-it (end-position)
-	 `(loop
-	    (when (>= start ,end-position) (return))
-	    (multiple-value-bind (write-char next-char-index
-				  new-cursor-x new-baseline new-height font)
-		(stream-scan-string-for-writing stream #+Silica medium
-						string start ,end-position text-style
-						cursor-x +largest-coordinate+
-						glyph-buffer)
-	      #-Silica
-	      (if glyph-buffer
-		  (stream-write-string-1
-		    stream glyph-buffer 0 (the fixnum (- next-char-index start))
-		    font color
-		    cursor-x (+ cursor-y (- baseline new-baseline)))
-		  (stream-write-string-1
-		    stream string start next-char-index
-		    font color
-		    cursor-x (+ cursor-y (- baseline new-baseline))))
-	      #+Silica
-	      (with-identity-transformation (medium)
-		(draw-text* medium string
-			    cursor-x (+ cursor-y (- baseline new-baseline))
-			    :start start :end next-char-index 
-			    :align-y :top
-			    :text-style text-style :ink color))
-	      (setf cursor-x new-cursor-x start next-char-index)
-	      (when write-char
-		(cond ((eql write-char #\Tab)	;Only non-lozenged exception char?
-		       (setf cursor-x (stream-next-tab-column stream cursor-x text-style)))
-		      (t 
-		       (multiple-value-bind (new-cursor-x new-cursor-y)
-			   (stream-draw-lozenged-character
-			     stream write-char cursor-x cursor-y new-baseline new-height
-			     text-style +largest-coordinate+ nil t)
-			 (setf cursor-x new-cursor-x
-			       cursor-y new-cursor-y))))
-		(incf start))))))
-      (multiple-value-bind (cursor-x cursor-y) 
-	  (output-record-start-cursor-position record)
-	(declare (type coordinate cursor-x cursor-y))
-	(translate-coordinates x-offset y-offset cursor-x cursor-y)
-	(dolist (text-style-change (slot-value record 'text-style-changes))
-	  (let ((new-text-style (car text-style-change))
-		(change-position (cdr text-style-change)))
-	    (do-it change-position)
-	    (setf text-style new-text-style
-		  start change-position)))
-	(do-it end)
-	#-Silica
-	(when (slot-value record 'wrapped-p)
-	  (draw-character-wrap-indicator
-	    stream cursor-y (bounding-rectangle-height record) 
-	    (stream-text-margin stream) nil)))))))
+    (with-sheet-medium (medium stream)
+      (macrolet
+	((do-it (end-position)
+	   `(loop
+	      (when (>= start ,end-position) (return))
+	      (multiple-value-bind (write-char next-char-index
+				    new-cursor-x new-baseline new-height font)
+		  (stream-scan-string-for-writing 
+		    stream medium string start ,end-position text-style
+		    cursor-x +largest-coordinate+ glyph-buffer)
+		(with-identity-transformation (medium)
+		  (draw-text* medium string
+			      cursor-x (+ cursor-y (- baseline new-baseline))
+			      :start start :end next-char-index 
+			      :align-y :top
+			      :text-style text-style :ink color))
+		(setf cursor-x new-cursor-x start next-char-index)
+		(when write-char
+		  (cond ((eql write-char #\Tab)	;Only non-lozenged exception char?
+			 (setf cursor-x (stream-next-tab-column stream cursor-x text-style)))
+			(t 
+			 (multiple-value-bind (new-cursor-x new-cursor-y)
+			     (stream-draw-lozenged-character
+			       stream write-char cursor-x cursor-y new-baseline new-height
+			       text-style +largest-coordinate+ nil t)
+			   (setf cursor-x new-cursor-x
+				 cursor-y new-cursor-y))))
+		  (incf start))))))
+	(multiple-value-bind (cursor-x cursor-y) 
+	    (output-record-start-cursor-position record)
+	  (declare (type coordinate cursor-x cursor-y))
+	  (translate-coordinates x-offset y-offset cursor-x cursor-y)
+	  (dolist (text-style-change (slot-value record 'text-style-changes))
+	    (let ((new-text-style (car text-style-change))
+		  (change-position (cdr text-style-change)))
+	      (do-it change-position)
+	      (setf text-style new-text-style
+		    start change-position)))
+	  (do-it end)
+	  #-Silica				;--- what about this?
+	  (when (slot-value record 'wrapped-p)
+	    (draw-character-wrap-indicator
+	      stream cursor-y (bounding-rectangle-height record) 
+	      (stream-text-margin stream) nil)))))))
 
 (defmethod bounding-rectangle-set-edges :around
 	   ((record standard-text-output-record) new-left new-top new-right new-bottom)
@@ -426,11 +400,11 @@
 (defmethod stylize-text-output-record ((record standard-text-output-record) style stream)
   (with-slots (ink string wrapped-p left top right bottom
 	       start-x start-y end-x end-y) record
-    (let* (#+Silica (port (port stream))
+    (let* ((port (port stream))
 	   (new-record (make-styled-text-output-record-1
 			 ink string wrapped-p
-			 style (- (text-style-height style #-Silica stream #+Silica port)
-				  (text-style-descent style #-Silica stream #+Silica port)))))
+			 style (- (text-style-height style port)
+				  (text-style-descent style port)))))
       (with-slots ((new-left left) (new-top top) (new-right right) (new-bottom bottom)
 		   (new-sx start-x) (new-sy start-y) (new-ex end-x) (new-ey end-y)
 		   (new-wrapped-p wrapped-p)) new-record
@@ -451,7 +425,7 @@
   ;; the first baseline but more likely to look good with misaligned things.
   (let ((baseline (coordinate 0))
 	(style (medium-default-text-style stream))
-	#+Silica (port (port stream)))
+	(port (port stream)))
     (declare (type coordinate baseline))
     (labels ((find-or-recurse (record y-offset)
 	       (declare (type coordinate y-offset))
@@ -461,8 +435,8 @@
 		 (standard-text-output-record
 		   (maxf baseline
 			 (+ y-offset 
-			    (- (text-style-height style #-Silica stream #+Silica port)
-			       (text-style-descent style #-Silica stream #+Silica port)))))
+			    (- (text-style-height style port)
+			       (text-style-descent style port)))))
 		 (t
 		   (multiple-value-bind (xoff yoff) (output-record-position record)
 		     (declare (type coordinate yoff))
diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp
index cfa86f13..490f7fa4 100644
--- a/clim/tracking-pointer.lisp
+++ b/clim/tracking-pointer.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: tracking-pointer.lisp,v 1.6 92/03/10 10:12:59 cer Exp $
+;; $fiHeader: tracking-pointer.lisp,v 1.7 92/04/15 11:47:30 cer Exp $
 
 (in-package :clim-internals)
 
@@ -149,27 +149,17 @@
 	     ;; doing this, so we'll do it by hand right here.
 	     (make-release-event (window pointer buttons)
 	       (multiple-value-bind (px py) (pointer-position pointer)
-		 (multiple-value-bind (ox oy)
-		     #+Silica (values (coordinate 0) (coordinate 0))
-		     #-Silica (window-offset window)
-		   (let ((wx (- px ox))
-			 (wy (- py oy))
-			 (mask (tv:mouse-chord-shifts genera-mouse)))
-		     #-Silica
-		     (multiple-value-setq (wx wy)
-		       (viewport-to-drawing-surface-coordinates current-window wx wy))
-		     (let ((event (make-instance 'pointer-button-release-event
-				    :sheet window
-				    :button buttons
-				    :modifiers mask
-				    :x wx :y wy)))
-		       (when transformp
-			 (multiple-value-bind (tx ty)
-			     (transform-position (medium-transformation window)
-						 wx wy)
-			   (setq wx (floor tx)
-				 wy (floor ty))))
-		       (values event wx wy)))))))
+		 (let ((event (make-instance 'pointer-button-release-event
+				:sheet window
+				:button buttons
+				:modifiers (tv:mouse-chord-shifts genera-mouse)
+				:x px :y py)))
+		   (when transformp
+		     (multiple-value-bind (tx ty)
+			 (transform-position (medium-transformation window) px py)
+		       (setq px (coordinate tx)
+			     py (coordinate ty))))
+		   (values event px py)))))
 	#+Genera (declare (dynamic-extent #'make-release-event))
 	#+Genera (when (and button-release-function
 			    generate-release-events
@@ -191,41 +181,29 @@
 		      (setq last-x x last-y y
 			    last-window current-window)
 		      ;; Pointer position is in root coordinates
-		      ;;--- What to do about window offset and drawing-to-surface-coordinates?
-		      (multiple-value-bind (ox oy) 
-			  #+Silica (values (coordinate 0) (coordinate 0))
-			  #-Silica (window-offset current-window)
-			(declare (type coordinate ox oy))
-			(let ((wx (- x ox))
-			      (wy (- y oy)))
-			  (declare (type coordinate wx wy))
-			  #-Silica
-			  (multiple-value-setq (wx wy)
-			    (viewport-to-drawing-surface-coordinates current-window wx wy))
-			  (when (or presentation-motion-function highlight)
-			    (let ((presentation
-				    (frame-find-innermost-applicable-presentation
-				      *application-frame* *input-context*
-				      current-window wx wy)))
-			      (when presentation
-				(when highlight
-				  (unless (eq presentation highlighted-presentation)
-				    (unhighlight)
-				    (highlight presentation)))
-				(when presentation-motion-function
-				  (funcall presentation-motion-function
-					   presentation current-window wx wy))
-				(return-from handle-simple-motion))))
-			  (unhighlight)
-			  (when motion-function
-			    (when transformp
-			      (multiple-value-bind (tx ty)
-				  (transform-position (medium-transformation current-window)
-						      wx wy)
-				(setq wx (floor tx)
-				      wy (floor ty))))
-			    (funcall motion-function
-				     current-window wx wy))))))))
+		      (when (or presentation-motion-function highlight)
+			(let ((presentation
+				(frame-find-innermost-applicable-presentation
+				  *application-frame* *input-context*
+				  current-window x y)))
+			  (when presentation
+			    (when highlight
+			      (unless (eq presentation highlighted-presentation)
+				(unhighlight)
+				(highlight presentation)))
+			    (when presentation-motion-function
+			      (funcall presentation-motion-function
+				       presentation current-window x y))
+			    (return-from handle-simple-motion))))
+		      (unhighlight)
+		      (when motion-function
+			(when transformp
+			  (multiple-value-bind (tx ty)
+			      (transform-position (medium-transformation current-window)
+						  x y)
+			    (setq x (coordinate tx)
+				  y (coordinate ty))))
+			(funcall motion-function current-window x y))))))
 	      (block input-wait
 		(loop
 		  ;; Handle any clicks or characters, otherwise wait for something
@@ -280,8 +258,8 @@
 				 (multiple-value-bind (tx ty)
 				     (transform-position (medium-transformation current-window)
 							 px py)
-				   (setq wx (floor tx)
-					 wy (floor ty))))
+				   (setq wx (coordinate tx)
+					 wy (coordinate ty))))
 			       (typecase gesture
 				 (pointer-button-press-event
 				   #+Genera (when generate-release-events
@@ -365,8 +343,7 @@
     (when rectangle
       (multiple-value-setq (left top right bottom)
 	(bounding-rectangle* rectangle)))
-    (multiple-value-call
-      #'make-bounding-rectangle
+    (multiple-value-call #'make-bounding-rectangle
       (pointer-input-rectangle* :left left :top top
 				:right right :bottom bottom
 				:stream stream
diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp
index 8132c7f0..215d68c0 100644
--- a/clim/view-defs.lisp
+++ b/clim/view-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: view-defs.lisp,v 1.3 92/01/31 14:59:01 cer Exp $
+;; $fiHeader: view-defs.lisp,v 1.4 92/02/24 13:08:50 cer Exp $
 
 (in-package :clim-internals)
 
@@ -44,6 +44,6 @@
 )	;#+CLIM-1-compatibility
 
 
-(defmethod port-dialog-view ((port t))
+(defmethod frame-manager-dialog-view ((framem standard-frame-manager))
   +textual-dialog-view+)
 
diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp
index 301390f2..88aa22b7 100644
--- a/clim/window-stream.lisp
+++ b/clim/window-stream.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: window-stream.lisp,v 1.5 92/03/10 10:13:02 cer Exp $
+;; $fiHeader: window-stream.lisp,v 1.6 92/04/15 11:47:33 cer Exp $
 
 (in-package :clim-internals)
 
@@ -12,48 +12,21 @@
      ((key-table :accessor console-key-table)
       (pointer-list :initform nil :accessor console-pointer-list)))
 
-#-Silica (progn
-;;; Table to associate host windows with their CLIM window "owners".
-(defvar *host-window-to-clim-window-mapping* (make-hash-table))
 
-(defun associate-clim-window-with-host-window (host-window clim-window)
-  (setf (gethash host-window *host-window-to-clim-window-mapping*)
-	clim-window))
-
-(defun clim-window-for-host-window (host-window &key (error-if-no-match t))
-  (let ((clim-window (gethash host-window *host-window-to-clim-window-mapping*)))
-    (if (null clim-window)
-	(if error-if-no-match
-	    (error "Could not find CLIM window associated with ~S" host-window)
-	    nil)
-	clim-window)))
-)	;#-Silica
-
-#+Silica
 (define-stream-protocol-class window ())
 
-;;; Anything to be gained by the CLX drawable/window distinction?
 (defclass window-stream
-	  ;; The ordering of these two groups of classes matters if the
-	  ;; method combinations are going to come out right.  However
-	  ;; the ordering of the classes withing the two levels should not
-	  ;; matter as each class defines its own stand-alone protocol.
 	  (graphics-output-recording
-	   #-Silica window-output-recording
-	   #-Silica input-and-window-protocol-intermediary
-	   #-Silica output-and-window-protocol-intermediary
-	   #-Silica output-and-recording-protocol-intermediary
-	   #-Silica window-mixin
+	   window-output-recording
 	   ;; This part still stands, but we need better layering so that you can
 	   ;; have a window stream with no output recording mixed in.
 	   output-recording-mixin
-	   #-Silica graphics-mixin
 	   input-protocol-mixin
 	   output-protocol-mixin
-	   #+Silica window)
-     ())
+	   window)
+    ())
 
-#-Silica	;no such slots in Silica
+#-Silica	;--- no such slots in Silica
 (defmethod print-object ((window window-stream) stream)
   (print-unreadable-object (window stream :type t :identity t)
     (let ((left (safe-slot-value window 'left))
@@ -65,7 +38,6 @@
 (defmethod window-stream-class-name ((window-stream window-stream))
   (class-name (class-of window-stream)))
 
-#+Silica
 (defmethod window-modifier-state ((window window-stream))
   (let ((pointer (stream-primary-pointer window)))
     (pointer-button-state pointer)))
@@ -73,76 +45,7 @@
 
 ;;; Creation functions
 
-#-Silica
-(defun open-root-window (window-type &rest creation-args)
-  (declare (dynamic-extent creation-args))
-  (assert (member window-type *implementations*) (window-type)
-	  "The implementation type supplied, ~S, is not one of~{ ~S~}"
-	  window-type *implementations*)
-  (apply (window-type-creation-function window-type) creation-args))
-
-#-Silica
-(defun open-window-stream (&rest args
-			   &key parent left top right bottom width height window-class
-			   &allow-other-keys)
-  (declare (dynamic-extent args))
-  (declare (arglist &key parent left top right bottom width height
-		    ;; Initialization arguments to window-stream
-		    ;; that are not supplied below
-		    borders console default-text-margin default-text-style depth
-		    display-device-type draw-p end-of-line-action end-of-page-action
-		    initial-cursor-visibility input-buffer label name output-record
-		    ;((clim-internals::primary-pointer))	;I think we don't want to mention this
-		    record-p save-under scroll-bars window-class
-		    stream-background stream-foreground
-		    text-cursor text-margin viewport vertical-spacing))
-  (assert (not (null parent)) (parent)
-	  "You must supply the ~S option to ~S" ':parent 'open-window-stream)
-  (assert (typep parent 'window-stream) (parent)
-	  "The value of the ~S option to ~S must be a window-stream"
-	  ':parent 'open-window-stream)
-  (let ((p-left 0) (p-top 0) (p-right nil) (p-bottom nil))
-    (multiple-value-setq (p-right p-bottom)
-      (window-inside-size parent))
-    (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")))
-  (with-keywords-removed (window-args args
-			  '(:parent :left :top :right :bottom :width :height :window-class))
-    (let ((class-name (or window-class (window-stream-class-name parent))))
-      (apply #'make-instance class-name
-	     :parent parent :left left :top top :right right :bottom bottom
-	     :pointers (and parent (stream-pointers parent))
-	     window-args))))
-
-;;; These aren't really tested since they aren't the primary way to create sheets.
-#+Silica
-(defun open-root-window (port-type &rest creation-args)
-  (assert (member port-type *port-types* :key #'car) (port-type)
-	  "The implementation type supplied, ~S, is not one of~{ ~S~}"
-	  port-type *port-types*)
-  (let ((port-type (second (assoc port-type *port-types*))))
-    (let ((port (apply #'find-port :port-type port-type creation-args)))
-      (values (find-graft :port port :orientation :nw) port))))
-
-#+Silica
+#+Silica	;--- should we do this?
 (defun open-window-stream (&rest args &key parent left top right bottom width height
 			   &allow-other-keys)
   (declare (dynamic-extent args))
@@ -161,34 +64,3 @@
 		 :parent parent
 		 :left left :top top
 		 :right right :bottom bottom))
-
-
-#-Silica (progn
-
-;;; For hooking up with host window decorations.
-(defmethod window-set-viewport-position :after ((window window-stream) new-x new-y)
-  (declare (ignore new-x new-y))
-  (redisplay-decorations window))
-
-(defmethod bounding-rectangle-set-edges :after ((window window-stream) left top right bottom)
-  (declare (ignore left top right bottom))
-  (redisplay-decorations window))
-
-(defmethod bounding-rectangle-set-position :after ((window window-stream) left top)
-  (declare (ignore left top))
-  (redisplay-decorations window))
-
-(defmethod bounding-rectangle-set-size :after ((window window-stream) width height)
-  (declare (ignore width height))
-  (redisplay-decorations window))
-
-(defmethod window-clear :after ((window window-stream))
-  (redisplay-decorations window))
-
-(defmethod window-refresh :after ((window window-stream))
-  (redisplay-decorations window))
-
-(defmethod redisplay-decorations ((window window-stream))
-  )
-
-)	;#-Silica
diff --git a/clx/clx-frames.lisp b/clx/clx-frames.lisp
index be4fc79d..d60177bb 100644
--- a/clx/clx-frames.lisp
+++ b/clx/clx-frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-frames.lisp,v 1.3 92/03/04 16:20:49 cer Exp $
+;; $fiHeader: clx-frames.lisp,v 1.5 92/04/15 11:45:49 cer Exp $
 
 (in-package :clx-clim)
 
@@ -23,11 +23,12 @@
 	      (make-pane 'command-menu-pane
 			 :display-function 
 			   `(display-command-menu :command-table ,menu-bar)
+			 :default-text-style clim-internals::*command-table-menu-text-style*
 			 :width :compute :height :compute))
 	    pane))
 	pane)))
 
-(defmethod port-dialog-view ((port clx-port))
+(defmethod frame-manager-dialog-view ((framem clx-frame-manager))
   +textual-dialog-view+)
   
 ;;--- Should "ungray" the command button, if there is one
@@ -38,3 +39,32 @@
 (defmethod note-command-disabled ((framem clx-frame-manager) frame command)
   (declare (ignore frame command)))
 
+(defmethod frame-manager-notify-user
+	   ((framem clx-frame-manager) message-string 
+	    &key (style :inform)
+		 (frame nil frame-p)
+		 (associated-window
+		   (if frame-p
+		       (frame-top-level-sheet frame)
+		       (graft framem)))
+		 (title "Notify user")
+		 documentation
+		 (exit-boxes '(:exit :abort :help))
+		 (name title))
+  )
+
+(defmethod frame-manager-select-file 
+	   ((framem clx-frame-manager) &rest options 
+	    &key (frame nil frame-p)
+		 (associated-window
+		   (if frame-p
+		       (frame-top-level-sheet frame)
+		       (graft framem)))
+		 (title "Select a file")
+		 documentation
+		 file-search-proc
+		 directory-list-label
+		 file-list-label
+		 (exit-boxes '(:exit :abort :help))
+		 (name title))
+  )
diff --git a/clx/clx-medium.lisp b/clx/clx-medium.lisp
index 613288dc..dd2111ec 100644
--- a/clx/clx-medium.lisp
+++ b/clx/clx-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-medium.lisp,v 1.4 92/03/10 10:12:06 cer Exp $
+;; $fiHeader: clx-medium.lisp,v 1.5 92/04/15 11:45:53 cer Exp $
 
 (in-package :clx-clim)
 
@@ -140,6 +140,60 @@
 			       #b0000000000000010
 			       #b0000100000000000
 			       #b0000000000100000))))))
+
+(defvar *clx-opacity-stipples*
+	(mapcar #'(lambda (entry)
+		    (cons (first entry) (apply #'make-stipple-image (second entry))))
+		'((+nowhere+ (1 1 (#b0)))
+		  (0.05 (8 16 (#b1000000000000000
+			       #b0000001000000000
+			       #b0000000000001000
+			       #b0010000000000000
+			       #b0000000010000000
+			       #b0000000000000010
+			       #b0000100000000000
+			       #b0000000000100000)))
+		  (0.1 (8 8 (#b10000000
+			     #b00010000
+			     #b00000010
+			     #b01000000
+			     #b00001000
+			     #b00000001
+			     #b00100000
+			     #b00000100)))
+		  (0.2 (4 4 (#b1000
+			     #b0010
+			     #b0100
+			     #b0001)))
+		  (0.3 (3 3 (#b100
+			     #b010
+			     #b001)))
+		  (0.4 (2 2 (#b10
+			     #b01)))
+		  (0.6 (3 3 (#b011
+			     #b101
+			     #b110)))
+		  (0.7 (4 4 (#b0111
+			     #b1101
+			     #b1011
+			     #b1110)))
+		  (0.8 (8 8 (#b01111111
+			     #b11101111
+			     #b11111101
+			     #b10111111
+			     #b11110111
+			     #b11111110
+			     #b11011111
+			     #b11111011)))
+		  (0.9 (8 16 (#b0111111111111111
+			      #b1111110111111111
+			      #b1111111111110111
+			      #b1101111111111111
+			      #b1111111101111111
+			      #b1111111111111101
+			      #b1111011111111111
+			      #b1111111111011111)))
+		  (+everywhere+ (1 1 (#b1))))))
 		
 ;; The xlib:image objects are created at load time to save run time & space.
 ;; Here a '0' means white, '1' black.
@@ -154,6 +208,20 @@
 	      (when (< luminance l)
 		(return-from clx-decode-luminance stipple)))))))
 
+(defun clx-decode-opacity (opacity)
+  (let ((opacities *clx-opacity-stipples*))
+    (cond ((eq opacity +nowhere+)
+	   (cdr (first opacities)))
+	  ((eq opacity +everywhere+)
+	   (cdr (first (last opacities))))
+	  (t
+	   (let ((last-op (cdr (first opacities)))
+		 (value (opacity-value opacity)))
+	     (dolist (op (cdr opacities) last-op)
+	       (when (< value (car op))
+		 (return last-op))
+	       (setq last-op (cdr op))))))))
+
 ;; This should only be called on a color screen.
 (defmethod clx-decode-color ((medium clx-medium) (ink color))
   (with-slots (screen color-p black-pixel) medium
@@ -190,6 +258,9 @@
 (defmethod clx-decode-ink ((ink (eql +foreground-ink+)) medium)
   (slot-value medium 'foreground-gc))
 
+(defmethod clx-decode-ink ((ink (eql +everywhere+)) medium)
+  (slot-value medium 'foreground-gc))
+
 (defmethod clx-decode-ink ((ink (eql +background-ink+)) medium)
   (slot-value medium 'background-gc))
 
@@ -542,12 +613,15 @@
 		       start-angle angle-size filled)))))
 
 (defmethod port-draw-string* ((port clx-port) sheet medium
-			      string x y start end align-x align-y)
+			      string x y start end align-x align-y
+			      towards-x towards-y transform-glyphs)
   (let ((transform (sheet-device-transformation sheet))
 	(ink (medium-ink medium))
 	(text-style (medium-merged-text-style medium))
 	(drawable (slot-value medium 'drawable)))
     (convert-to-device-coordinates transform x y)
+    (when towards-x
+      (convert-to-device-coordinates transform towards-x towards-y))
     (unless end
       (setq end (length string)))
     (let* ((font (if text-style
@@ -557,20 +631,28 @@
 	   (descent (xlib:font-descent font))
 	   (height (+ ascent descent))
 	   (gc (clx-decode-ink ink medium)))
-      (incf x (clim-internals::compute-text-x-adjustment 
-		align-x medium string text-style start end))
-      (incf y (clim-internals::compute-text-y-adjustment
-		align-y descent ascent height))
+      (let ((x-adjust (clim-internals::compute-text-x-adjustment 
+			align-x medium string text-style start end))
+	    (y-adjust (clim-internals::compute-text-y-adjustment
+			align-y descent ascent height)))
+	(incf x x-adjust)
+	(incf y y-adjust)
+	(when towards-x
+	  (incf towards-x x-adjust)
+	  (incf towards-y y-adjust)))
       (setf (xlib:gcontext-font gc) font)
       (xlib:draw-glyphs drawable gc x y string :start start :end end))))
 
 (defmethod port-draw-character* ((port clx-port) sheet medium
-				 character x y align-x align-y)
+				 character x y align-x align-y
+				 towards-x towards-y transform-glyphs)
   (let ((transform (sheet-device-transformation sheet))
 	(ink (medium-ink medium))
 	(text-style (medium-merged-text-style medium))
 	(drawable (slot-value medium 'drawable)))
     (convert-to-device-coordinates transform x y)
+    (when towards-x
+      (convert-to-device-coordinates transform towards-x towards-y))
     (let* ((font (if text-style
 		     (text-style-mapping port text-style)
 		     (clx-get-default-font port medium)))
@@ -578,64 +660,29 @@
 	   (descent (xlib:font-descent font))
 	   (height (+ ascent descent))
 	   (gc (clx-decode-ink ink medium)))
-      (incf x (clim-internals::compute-text-x-adjustment 
-		align-x medium character text-style))
-      (incf y (clim-internals::compute-text-y-adjustment
-		align-y descent ascent height))
+      (let ((x-adjust (clim-internals::compute-text-x-adjustment 
+			align-x medium character text-style))
+	    (y-adjust (clim-internals::compute-text-y-adjustment
+			align-y descent ascent height)))
+	(incf x x-adjust)
+	(incf y y-adjust)
+	(when towards-x
+	  (incf towards-x x-adjust)
+	  (incf towards-y y-adjust)))
       (setf (xlib:gcontext-font gc) font)
       (xlib:draw-glyph drawable gc x y character)))) 
 
 (defmethod port-draw-text* ((port clx-port) sheet medium
 			    string-or-char x y start end
 			    align-x align-y
-			    ;; towards-point towards-x towards-y
-			    ;; transform-glyphs
-			    )
+			    towards-x towards-y transform-glyphs)
   (if (characterp string-or-char)
       (port-draw-character* port sheet medium
-			    string-or-char x y align-x align-y)
+			    string-or-char x y align-x align-y
+			    towards-x towards-y transform-glyphs)
       (port-draw-string* port sheet medium
-			 string-or-char x y start end align-x align-y)))
-
-;;--- Is this used any more?
-(defmethod port-write-char-1 ((port clx-port) medium 
-			      index font color x y)
-  (let ((transform (sheet-device-transformation sheet))
-	(ink (medium-ink medium))
-	(text-style (medium-merged-text-style medium))
-	(drawable (slot-value medium 'drawable))
-	(gc (clx-decode-ink ink medium)))
-    (convert-to-device-coordinates transform x y)
-    (setf (xlib:gcontext-font gc) font)
-    ;; Move line down so that the top of the character (not the baseline) is at Y.
-    (xlib:draw-glyph drawable gc (round x) (+ (round y) (xlib:font-ascent font)) index)))
-
-;;--- Is this used any more?
-(defmethod port-write-string-1 ((port clx-port) medium 
-				glyph-buffer start end 
-				font color x y)
-  (when (> end start)
-    (let ((transform (sheet-device-transformation sheet))
-	  (ink (medium-ink medium))
-	  (text-style (medium-merged-text-style medium))
-	  (drawable (slot-value medium 'drawable))
-	  (gc (clx-decode-ink ink medium))
-	  (size (if (find-if #'(lambda (x) (> x 255.)) glyph-buffer :start start :end end)
-		    16 :default)))
-      (setf (xlib:gcontext-font gc) font)
-      ;; Move line down so that the top of the characters (not the baseline) is at Y.
-      (xlib:draw-glyphs drawable gc (round x) (+ (round y) (xlib:font-ascent font))
-			glyph-buffer
-			:start start :end end :translate #'noop-translate-function
-			:size size))))
-
-;;; 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))
-
+			 string-or-char x y start end align-x align-y
+			 towards-x towards-y transform-glyphs)))
 
 (defmethod port-beep ((port clx-port) sheet)
   (declare (ignore sheet))
diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp
index 59f6be17..d5c10ecf 100644
--- a/clx/clx-mirror.lisp
+++ b/clx/clx-mirror.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-mirror.lisp,v 1.3 92/03/04 16:20:54 cer Exp $
+;; $fiHeader: clx-mirror.lisp,v 1.4 92/04/15 11:45:54 cer Exp $
 
 (in-package :clx-clim)
 
@@ -179,9 +179,11 @@
 				:y mouse-y
 				:native-x native-x
 				:native-y native-y
+				:button nil	;--- fill this in
 				:modifiers (current-modifier-state
 					     (make-state-from-buttons mouse-buttons)
 					     (tv:sheet-mouse mouse-window))
+				:pointer (port-pointer port)
 				:sheet sheet)))
 	     t))
 	  ((:button-press :button-release) 
@@ -200,6 +202,7 @@
 			      :button button
 			      :modifiers (current-modifier-state
 					   0 (tv:sheet-mouse window))
+			      :pointer (port-pointer port)
 			      :sheet sheet))
 	     t))
 	  ((:key-press :key-release)
@@ -254,7 +257,7 @@
 	       (setf (sheet-enabled-p sheet) nil))
 	     t))
 	  (:configure-notify (event-window ;x y width height
-			       #+ignore send-event-p)
+			       #+++ignore send-event-p)
 	   (let ((sheet (mirror->sheet port event-window)))
 	     (when sheet
 	       (xlib:with-state (event-window)
diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp
index b74d117c..9d43494e 100644
--- a/clx/clx-port.lisp
+++ b/clx/clx-port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-port.lisp,v 1.6 92/04/15 11:45:56 cer Exp $
+;; $fiHeader: clx-port.lisp,v 1.7 92/05/07 13:11:49 cer Exp $
 
 (in-package :clx-clim)
 
@@ -18,14 +18,15 @@
      (default-grab-cursor :reader default-grab-cursor)
      (context :reader port-context)
      (width-pixels)
-     (height-pixels)
-     (type :allocation :class 
-	   :initform :clx :reader port-type))
+     (height-pixels))
   (:default-initargs :allow-loose-text-style-size-mapping t))
 
 (defmethod find-port-type ((type (eql ':clx)))
   'clx-port)
 
+(defmethod port-type ((port clx-port))
+  ':clx)
+
 (defvar *clx-white-color* (xlib:make-color :red 1 :blue 1 :green 1))
 (defvar *clx-black-color* (xlib:make-color :red 0 :blue 0 :green 0))
 (defvar *cursor-font* nil)
diff --git a/demo/address-book.lisp b/demo/address-book.lisp
index 5c168fcf..a28ec694 100644
--- a/demo/address-book.lisp
+++ b/demo/address-book.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: address-book.lisp,v 1.5 92/04/15 11:48:09 cer Exp $
+;; $fiHeader: address-book.lisp,v 1.6 92/05/07 13:13:33 cer Exp $
 
 (in-package :clim-demo)
 
@@ -44,7 +44,7 @@
   (add-address (make-address :name "John Irwin"
 			     :address "Franz, Inc."
 			     :number "510-548-3600"))
-  (add-address (make-address :name "Scott Mckay"
+  (add-address (make-address :name "Scott McKay"
 			     :address "Symbolics, Inc."
 			     :number "617-221-1000"))
   (add-address (make-address :name "Bill York"
@@ -116,7 +116,7 @@
         (make-pane 'application-pane
 		   :incremental-redisplay t
 		   :display-function 'display-names))))
-  (:layout
+  (:layouts
     (default
       (vertically ()
         (horizontally ()
@@ -203,8 +203,8 @@
       (multiple-value-bind (left top right bottom)
 	  (size-demo-frame root 100 100 500 400)
 	(setq book (make-application-frame 'address-book :parent root
-					   :left left :top top
-					   :right right :bottom bottom)))
+					   :width (- right left)
+					   :height (- bottom top))))
       (push (cons root book) *address-books*))
     (run-frame-top-level book)))
 
diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp
index 5d9385b6..a5b6faa3 100644
--- a/demo/cad-demo.lisp
+++ b/demo/cad-demo.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cad-demo.lisp,v 1.6 92/04/15 11:48:12 cer Exp $
+;; $fiHeader: cad-demo.lisp,v 1.7 92/05/07 13:13:34 cer Exp $
 
 (in-package :clim-demo)
 
@@ -536,7 +536,7 @@
     (design-area 
       (make-pane 'application-pane)))
   (:pointer-documentation t)
-  (:layout
+  (:layouts
     (default
       (scrolling ()
 	design-area)))
diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp
index 6eee8ab8..a2ca1f10 100644
--- a/demo/demo-driver.lisp
+++ b/demo/demo-driver.lisp
@@ -1,14 +1,11 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: aaai-demo-driver.lisp,v 1.4 92/03/04 16:22:56 cer Exp $
+;; $fiHeader: aaai-demo-driver.lisp,v 1.5 92/04/15 11:48:07 cer Exp $
 
 (in-package :clim-demo)
 
 "Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved."
 
-#-Silica
-(defvar *demo-root* nil)
-
 (defvar *demos* nil)
 
 (defmacro define-demo (name start-form)
@@ -42,12 +39,6 @@
 	  (+ desired-left desired-width) (+ desired-top desired-height)))
 
 (defun start-demo (&optional (root #-Silica *demo-root*))
-  #-Silica
-  (unless root
-    (lisp:format t "~&No current value for *DEMO-ROOT*.  Use what value? ")
-    (setq root (eval (lisp:read)))
-    (setq *demo-root* root))
-  #+Silica
   (unless root (setq root (find-graft)))
   (labels ((demo-menu-drawer (stream type &rest args)
 	     (declare (dynamic-extent args))
@@ -74,6 +65,7 @@
 (defparameter *color-stream-p* t)
 (defun color-stream-p (stream)
   #-Genera *color-stream-p*		;--- kludge
-  #+Genera (if (eql (silica:port-type (port stream)) ':genera)
+  #+Genera (if (and stream
+		    (eql (port-type (port stream)) ':genera))
 	       (slot-value stream 'clim-internals::color-p)
 	       *color-stream-p*))
diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp
index 51adc4a2..8fa9c3b9 100644
--- a/demo/graphics-demos.lisp
+++ b/demo/graphics-demos.lisp
@@ -1,27 +1,12 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-demos.lisp,v 1.3 92/04/10 14:27:31 cer Exp Locker: cer $
+;; $fiHeader: graphics-demos.lisp,v 1.4 92/04/15 11:48:16 cer Exp $
 
 (in-package :clim-demo)
 
 "Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
  Portions copyright (c) 1989, 1990 International Lisp Associates."
 
-#-Silica
-(define-application-frame graphics-demo 
-			  ()
-    ()
-  (:panes ((commands :command-menu)
-	   (demo :application)
-	   (explanation :application :scroll-bars nil)))
-  (:layout ((default
-	      (:column 1
-	       (:row :rest
-		(demo :rest)
-		(commands :compute))
-	       (explanation 1/6))))))
-
-#+Silica
 (define-application-frame graphics-demo 
     ()
   ()
@@ -30,7 +15,7 @@
 	  (explanation (scrolling ()
 		         (make-pane 'application-pane
 				    :height 100))))
-  (:layout (:default
+  (:layouts (:default
 	      (vertically () demo explanation))))
 
 (define-graphics-demo-command (com-Exit-Graphics-Demo :menu "Exit")
diff --git a/demo/listener.lisp b/demo/listener.lisp
index f3f7425e..cf3ebab4 100644
--- a/demo/listener.lisp
+++ b/demo/listener.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: listener.lisp,v 1.9 92/04/15 11:48:19 cer Exp Locker: cer $
+;; $fiHeader: listener.lisp,v 1.10 92/04/30 09:09:46 cer Exp $
 
 (in-package :clim-demo)
 
@@ -9,17 +9,12 @@
 (define-application-frame lisp-listener
 			  ()
     ()
-  #-Silica
-  (:panes ((listener :application
-		     :initial-cursor-visibility :off)
-	   (documentation :pointer-documentation)))
-  #+Silica
-  (:panes (listener :application
-		     :initial-cursor-visibility :off))
-  (:layout (:default listener))
+  (:pane (outlining ()
+	   (scrolling ()
+	     (make-pane 'interactor-pane))))
   (:command-table (lisp-listener :inherit-from (user-command-table)))
   (:command-definer t)
-  (:menu-bar nil) 
+  (:menu-bar nil)
   (:top-level (lisp-listener-top-level)))
 
 (defmethod frame-maintain-presentation-histories ((frame lisp-listener)) t)
@@ -49,11 +44,11 @@
   ;; Current stack frame pointer.
   (defvar *current-frame-pointer* nil))
 
-(defvar *lisp-listener-frame* nil)
+(defvar *lisp-listener-frame*)
 
 (defun lisp-listener-top-level (frame)
   "Run a simple Lisp listener using the window provided."
-  #+Silica (enable-frame frame)
+  (enable-frame frame)
   (let* ((*lisp-listener-frame* frame)
 	 (window (frame-query-io frame))
 	 (command-table (frame-command-table frame))
@@ -158,13 +153,13 @@
 
 (defun listener-debugger-hook (condition hook)
   (declare (ignore hook))
-  (let ((*application-frame* *lisp-listener-frame*))
-    (let ((*debug-io* (frame-query-io *application-frame*))
-	  (*error-output* (frame-query-io *application-frame*))
-	  (*debugger-condition* condition)
-	  (*debugger-restarts* (compute-restarts)))
-      (describe-error *error-output*)
-      (lisp-listener-top-level *application-frame*))))
+  (let* ((*application-frame* *lisp-listener-frame*)
+	 (*debug-io* (frame-query-io *application-frame*))
+	 (*error-output* (frame-query-io *application-frame*))
+	 (*debugger-condition* condition)
+	 (*debugger-restarts* (compute-restarts)))
+    (describe-error *error-output*)
+    (lisp-listener-top-level *application-frame*)))
 
 (define-presentation-type restart-name ())
 
diff --git a/demo/navfun.lisp b/demo/navfun.lisp
index c504c2bb..09143bd5 100644
--- a/demo/navfun.lisp
+++ b/demo/navfun.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: navfun.lisp,v 1.6 92/04/15 11:48:21 cer Exp $
+;; $fiHeader: navfun.lisp,v 1.7 92/05/07 13:13:36 cer Exp $
 
 (in-package :clim-demo)
 
@@ -1026,7 +1026,7 @@
   (:panes 
     (display (make-pane 'application-pane))
     (interactor (make-pane 'interactor-pane)))
-  (:layout 
+  (:layouts 
     (default
       (vertically ()
  	(scrolling () display)
diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp
index cf43caa2..3f141693 100644
--- a/demo/puzzle.lisp
+++ b/demo/puzzle.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: puzzle.lisp,v 1.5 92/04/15 11:48:26 cer Exp $
+;; $fiHeader: puzzle.lisp,v 1.6 92/05/07 13:13:38 cer Exp $
 
 (in-package :clim-demo)
 
@@ -21,7 +21,7 @@
 		   :max-height +fill+
 		   :incremental-redisplay T
 		   :display-function 'draw-puzzle))))
-  (:layout
+  (:layouts
     (:default display)))
 
 (defmethod frame-query-io ((puzzle puzzle))
diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp
index 1a17ba9e..3f991d5e 100644
--- a/demo/sysdcl.lisp
+++ b/demo/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.8 92/04/15 11:48:28 cer Exp $
+;; $fiHeader: sysdcl.lisp,v 1.9 92/05/07 13:13:39 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -39,7 +39,7 @@
   ("puzzle"         :load-before-compile ("aaai-demo-driver" "packages"))
   ("address-book"   :load-before-compile ("aaai-demo-driver" "packages"))
   ("thinkadot"      :load-before-compile ("aaai-demo-driver" "packages"))
-  ("demo-prefill" :features (and (not Silica) (or Genera Cloe-Runtime))))
+  ("demo-prefill" :features (or Genera Cloe-Runtime)))
 
 #+Genera
 (clim-defsys:import-into-sct 'clim-demo 
diff --git a/demo/thinkadot.lisp b/demo/thinkadot.lisp
index 2d5e1b43..6985daa4 100644
--- a/demo/thinkadot.lisp
+++ b/demo/thinkadot.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: thinkadot.lisp,v 1.5 92/04/10 14:27:38 cer Exp Locker: cer $
+;; $fiHeader: thinkadot.lisp,v 1.6 92/04/15 11:48:29 cer Exp $
 
 (in-package :clim-demo)
 
@@ -55,7 +55,7 @@
       (make-pane 'application-pane
 		 :display-function 'draw-the-display
 		 :incremental-redisplay t)))
-  (:layout
+  (:layouts
     (:default (scrolling () display))))
 
 (defmethod initialize-instance :after ((frame thinkadot) &key)
diff --git a/genera/genera-frames.lisp b/genera/genera-frames.lisp
index 9fd2d795..4bbded14 100644
--- a/genera/genera-frames.lisp
+++ b/genera/genera-frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: genera-frames.lisp,v 1.4 92/04/15 11:47:51 cer Exp $
+;; $fiHeader: genera-frames.lisp,v 1.5 92/05/07 13:13:24 cer Exp $
 
 (in-package :genera-clim)
 
@@ -23,11 +23,12 @@
 	      (make-pane 'command-menu-pane
 			 :display-function 
 			   `(display-command-menu :command-table ,menu-bar)
+			 :default-text-style clim-internals::*command-table-menu-text-style*
 			 :width :compute :height :compute))
 	    pane))
 	pane)))
 
-(defmethod port-dialog-view ((port genera-port))
+(defmethod frame-manager-dialog-view ((framem genera-frame-manager))
   +textual-dialog-view+)
   
 ;;--- Should "ungray" the command button, if there is one
@@ -39,15 +40,110 @@
   (declare (ignore frame command)))
 
 ;;--- We can do better than this at some point
-(defmethod port-notify-user ((port genera-port) message-string 
-			     &key (style :inform)
-				  (frame nil frame-p)
-				  (associated-window
-				    (if frame-p
-					(frame-top-level-sheet frame)
-					(find-graft :port port)))
-				  (title "Notify user")
-				  documentation
-				  (exit-boxes '(:exit :abort :help))
-				  (name title))
+(defmethod frame-manager-notify-user
+	   ((framem genera-frame-manager) message-string 
+	    &key (style :inform)
+		 (frame nil frame-p)
+		 (associated-window
+		   (if frame-p
+		       (frame-top-level-sheet frame)
+		       (graft framem)))
+		 (title "Notify user")
+		 documentation
+		 (exit-boxes '(:exit :abort :help))
+		 (name title))
   (tv:notify nil message-string))
+
+(defmethod frame-manager-select-file 
+	   ((framem genera-frame-manager) &rest options 
+	    &key (frame nil frame-p)
+		 (associated-window
+		   (if frame-p
+		       (frame-top-level-sheet frame)
+		       (graft framem)))
+		 (title "Select a file")
+		 documentation
+		 file-search-proc
+		 directory-list-label
+		 file-list-label
+		 (exit-boxes '(:exit :abort :help))
+		 (name title))
+  )
+
+
+;;; Pointer documentation and progress notes for Genera
+
+(defmacro with-who-line-stream ((stream-var frame field) &body body)
+  `(let ((,stream-var
+	  (let* ((console (tv:sheet-console (sheet-mirror (frame-top-level-sheet ,frame))))
+		 (who-screen (if (eq console sys:*main-console*)
+				 tv:who-line-screen
+				 (tv:console-who-line-screen console))))
+	    (and who-screen
+		 (tv:get-who-line-field ,field)))))
+     ,@body))
+
+(defmethod clim-internals::frame-manager-clear-progress-note 
+	   ((framem genera-frame-manager) (note clim-internals::progress-note))
+  (with-who-line-stream (stream (slot-value note 'clim-internals::frame) :file-state)
+    (when stream
+      (scl:send stream :clear-window))))
+
+(defmethod clim-internals::frame-manager-display-progress-note
+	   ((framem genera-frame-manager) (note clim-internals::progress-note))
+  (with-who-line-stream (stream (slot-value note 'clim-internals::frame) :file-state)
+    (with-slots clim-internals::(name-displayed bar-length) note
+      (when stream
+	(let* ((stream-width (scl:send stream :inside-width))
+	       (line-height  (- (scl:send stream :inside-height) 2))
+	       (new-bar-length 
+		 (floor (* stream-width (slot-value note 'clim-internals::numerator))
+			(slot-value note 'clim-internals::denominator))))
+	  (unless clim-internals::name-displayed
+	    (scl:send stream :clear-window))
+	  (unless clim-internals::name-displayed
+	    (scl:send stream :set-cursorpos 0 0)
+	    (scl:send stream :string-out (progress-note-name note))
+	    (setq clim-internals::name-displayed t))
+	  (when (< new-bar-length clim-internals::bar-length)
+	    (scl:send stream :draw-rectangle
+			     clim-internals::bar-length 2 0 line-height :erase))
+	  (scl:send stream :draw-rectangle new-bar-length 2 0 line-height :draw)
+	  (setq clim-internals::bar-length new-bar-length))))))
+
+
+(defvar *pointer-documentation-buffer*
+	(make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t))
+
+(defmethod clim-internals::frame-manager-display-pointer-documentation
+	   ((framem genera-frame-manager)
+	    frame presentation input-context window x y stream)
+  (declare (ignore stream))
+  (let ((stream
+	  (let ((console (tv:sheet-console (sheet-mirror (frame-top-level-sheet frame)))))
+	    (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)))))))
+    ;; The documentation should never say anything if we're not over a presentation
+    (when (null presentation) 
+      (scl:send stream :clear-window))
+    ;; Cheap test to not do this work too often
+    (let ((old-modifier-state clim-internals::*last-pointer-documentation-modifier-state*)
+	  (modifier-state (clim-internals::window-modifier-state window))
+	  (last-time clim-internals::*last-pointer-documentation-time*)
+	  (time (get-internal-real-time)))
+      (setq clim-internals::*last-pointer-documentation-modifier-state* modifier-state)
+      (when (and (< time (+ last-time clim-internals::*pointer-documentation-interval*))
+		 (= modifier-state old-modifier-state))
+	(return-from clim-internals::frame-manager-display-pointer-documentation nil))
+      (setq clim-internals::*last-pointer-documentation-time* time))
+    (when presentation
+      (setf (fill-pointer *pointer-documentation-buffer*) 0)
+      (with-output-to-string (stream *pointer-documentation-buffer*)
+	(when (null (clim-internals::frame-document-highlighted-presentation-1
+		      frame presentation input-context window x y stream))
+	  (setq clim-internals::*last-pointer-documentation-time* 0)))
+      (scl:send stream :clear-window)
+      (scl:send stream :string-out *pointer-documentation-buffer*))))
diff --git a/genera/genera-medium.lisp b/genera/genera-medium.lisp
index 2dda47a6..8f976745 100644
--- a/genera/genera-medium.lisp
+++ b/genera/genera-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: genera-medium.lisp,v 1.3 92/04/15 11:47:57 cer Exp $
+;; $fiHeader: genera-medium.lisp,v 1.4 92/05/07 13:13:26 cer Exp $
 
 (in-package :genera-clim)
 
@@ -86,6 +86,7 @@
 (defun-inline follow-indirect-ink (ink medium)
   (cond ((eq ink +foreground-ink+) (medium-foreground medium))
 	((eq ink +background-ink+) (medium-background medium))
+	((eq ink +everywhere+) (medium-foreground medium))
 	(t ink)))
 
 (defmethod genera-decode-color (ink medium &optional (stipple-p t))
@@ -139,6 +140,74 @@
 			       0000000000100000)))
 	(otherwise boole-clr)))))
 
+(defvar *genera-opacity-stipples*
+	(mapcar #'(lambda (entry)
+		    (cons (first entry) (apply #'graphics::make-stipple (second entry))))
+		'((+nowhere+ (1 1 (#b0)))
+		  (0.05 (8 16 (#b1000000000000000
+			       #b0000001000000000
+			       #b0000000000001000
+			       #b0010000000000000
+			       #b0000000010000000
+			       #b0000000000000010
+			       #b0000100000000000
+			       #b0000000000100000)))
+		  (0.1 (8 8 (#b10000000
+			     #b00010000
+			     #b00000010
+			     #b01000000
+			     #b00001000
+			     #b00000001
+			     #b00100000
+			     #b00000100)))
+		  (0.2 (4 4 (#b1000
+			     #b0010
+			     #b0100
+			     #b0001)))
+		  (0.3 (3 3 (#b100
+			     #b010
+			     #b001)))
+		  (0.4 (2 2 (#b10
+			     #b01)))
+		  (0.6 (3 3 (#b011
+			     #b101
+			     #b110)))
+		  (0.7 (4 4 (#b0111
+			     #b1101
+			     #b1011
+			     #b1110)))
+		  (0.8 (8 8 (#b01111111
+			     #b11101111
+			     #b11111101
+			     #b10111111
+			     #b11110111
+			     #b11111110
+			     #b11011111
+			     #b11111011)))
+		  (0.9 (8 16 (#b0111111111111111
+			      #b1111110111111111
+			      #b1111111111110111
+			      #b1101111111111111
+			      #b1111111101111111
+			      #b1111111111111101
+			      #b1111011111111111
+			      #b1111111111011111)))
+		  (+everywhere+ (1 1 (#b1))))))
+
+(defun genera-decode-opacity (opacity)
+  (let ((opacities *genera-opacity-stipples*))
+    (cond ((eq opacity +nowhere+)
+	   (cdr (first opacities)))
+	  ((eq opacity +everywhere+)
+	   (cdr (first (last opacities))))
+	  (t
+	   (let ((last-op (cdr (first opacities)))
+		 (value (opacity-value opacity)))
+	     (dolist (op (cdr opacities) last-op)
+	       (when (< value (car op))
+		 (return last-op))
+	       (setq last-op (cdr op))))))))
+
 (defmethod genera-decode-color ((ink gray-color) medium &optional (stipple-p t))
   (let ((window (slot-value medium 'window))
 	(color-p (slot-value (port medium) 'color-p)))
@@ -627,12 +696,15 @@
 			   :filled filled)))))))))
 
 (defmethod port-draw-string* ((port genera-port) sheet medium
-			      string x y start end align-x align-y)
+			      string x y start end align-x align-y
+			      towards-x towards-y transform-glyphs)
   (when (medium-drawing-possible medium)
     (let ((transform (sheet-device-transformation sheet))
 	  (ink (medium-ink medium))
 	  (text-style (medium-merged-text-style medium)))
       (convert-to-device-coordinates transform x y)
+      (when towards-x
+	(convert-to-device-coordinates transform towards-x towards-y))
       (unless start
 	(setq start 0))
       (unless end
@@ -646,10 +718,15 @@
 	       (height (sys:font-char-height font))
 	       (descent (- height (sys:font-baseline font)))
 	       (ascent (- height descent)))
-	  (incf x (clim-internals::compute-text-x-adjustment 
-		    align-x sheet string text-style start end))
-	  (incf y (clim-internals::compute-text-y-adjustment
-		    align-y descent ascent height))
+	  (let ((x-adjust (clim-internals::compute-text-x-adjustment 
+			    align-x medium string text-style start end))
+		(y-adjust (clim-internals::compute-text-y-adjustment
+			    align-y descent ascent height)))
+	    (incf x x-adjust)
+	    (incf y y-adjust)
+	    (when towards-x
+	      (incf towards-x x-adjust)
+	      (incf towards-y y-adjust)))
 	  (with-stack-list (style :device-font (tv:font-name font) :normal)
 	    (with-appropriate-drawing-state medium ink nil
 	      #'(lambda (window alu)
@@ -661,22 +738,31 @@
 			   substring x y :character-style style)))))))))
 
 (defmethod port-draw-character* ((port genera-port) sheet medium
-				 character x y align-x align-y)
+				 character x y align-x align-y
+				 towards-x towards-y transform-glyphs)
   (when (medium-drawing-possible medium)
     (let ((transform (sheet-device-transformation sheet))
 	  (ink (medium-ink medium))
 	  (text-style (medium-merged-text-style medium)))
       (convert-to-device-coordinates transform x y)
+      (when towards-x
+	(convert-to-device-coordinates transform towards-x towards-y))
       (let* ((font (text-style-mapping 
 		     port text-style *standard-character-set*
 		     (slot-value medium 'window)))
 	     (height (sys:font-char-height font))
 	     (descent (- height (sys:font-baseline font)))
 	     (ascent (- height descent)))
-	(incf x (clim-internals::compute-text-x-adjustment 
-		  align-x sheet character text-style))
-	(incf y (- (clim-internals::compute-text-y-adjustment
-		     align-y descent ascent height) ascent))
+	(let ((x-adjust (clim-internals::compute-text-x-adjustment 
+			  align-x medium character text-style))
+	      (y-adjust (- (clim-internals::compute-text-y-adjustment
+			     align-y descent ascent height)
+			   ascent)))
+	  (incf x x-adjust)
+	  (incf y y-adjust)
+	  (when towards-x
+	    (incf towards-x x-adjust)
+	    (incf towards-y y-adjust)))
 	(with-appropriate-drawing-state medium ink nil
 	  #'(lambda (window alu)
 	      (declare (sys:downward-function))
@@ -689,63 +775,14 @@
 (defmethod port-draw-text* ((port genera-port) sheet medium
 			    string-or-char x y start end
 			    align-x align-y
-			    ;; towards-point towards-x towards-y
-			    ;; transform-glyphs
-			    )
+			    towards-x towards-y transform-glyphs)
   (if (characterp string-or-char)
       (port-draw-character* port sheet medium
-			    string-or-char x y align-x align-y)
+			    string-or-char x y align-x align-y
+			    towards-x towards-y transform-glyphs)
       (port-draw-string* port sheet medium
-			 string-or-char x y start end align-x align-y)))
-
-;;--- Is this used any more?
-(defmethod port-write-char-1 ((port genera-port) medium 
-			      index font color x y)
-  ;;--- Convert X and Y to device coords
-  (let ((window (slot-value medium 'window)))
-    (when (medium-drawing-possible medium)
-      (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 medium))
-				   (tv:sheet-char-aluf window)
-				 (genera-decode-color (follow-indirect-ink color medium)
-						     medium nil))
-			       window))))))
-
-;;--- Is this used any more?
-(defmethod port-write-string-1 ((port genera-port) medium 
-				glyph-buffer start end 
-				font color x y)
-  ;;--- Convert X and Y to device coords
-  (unless (<= end start) 
-    (let ((window (slot-value medium 'window)))
-      (when (medium-drawing-possible medium)
-	(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 medium))
-					(tv:sheet-char-aluf window)
-					(genera-decode-color (follow-indirect-ink color medium)
-							     medium nil))
-				    x y glyphs8 font 0 index8
-				    (tv:sheet-width window)))))))))
-
+			 string-or-char x y start end align-x align-y
+			 towards-x towards-y transform-glyphs)))
 
 (defmethod port-beep ((port genera-port) sheet)
   (scl:beep sheet))
diff --git a/genera/genera-mirror.lisp b/genera/genera-mirror.lisp
index 568ec21b..182b8dfb 100644
--- a/genera/genera-mirror.lisp
+++ b/genera/genera-mirror.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: genera-mirror.lisp,v 1.3 92/04/15 11:48:00 cer Exp $
+;; $fiHeader: genera-mirror.lisp,v 1.4 92/05/07 13:13:28 cer Exp $
 
 (in-package :genera-clim)
 
@@ -559,9 +559,13 @@
 					:y mouse-y
 					:native-x native-x
 					:native-y native-y
+					:button (and (not (zerop mouse-buttons))
+						     (genera-button-number->standard-button-name
+						       (ash mouse-buttons -1)))
 					:modifiers (current-modifier-state
 						     (make-state-from-buttons mouse-buttons)
 						     (tv:sheet-mouse mouse-window))
+					:pointer (port-pointer port)
 					:sheet sheet)))))
 		 (when mouse-button-released
 		   (let ((sheet (and mouse-window (genera-window-sheet mouse-window))))
@@ -579,6 +583,7 @@
 					:modifiers (current-modifier-state
 						     (make-state-from-buttons mouse-buttons)
 						     (tv:sheet-mouse mouse-window))
+					:pointer (port-pointer port)
 					:sheet sheet)))))))))
 	  ;; Handle shift press and release events
 	  ((or shifts-up shifts-down)
@@ -666,6 +671,7 @@
 					    :button button
 					    :modifiers (current-modifier-state
 							 0 (tv:sheet-mouse window))
+					    :pointer (port-pointer port)
 					    :sheet sheet))))))))))))))
 
 ;; See general comments about sheet-native-native-region* and
diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp
index ad7a4253..2af24328 100644
--- a/genera/genera-port.lisp
+++ b/genera/genera-port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: genera-port.lisp,v 1.4 92/04/15 11:48:02 cer Exp $
+;; $fiHeader: genera-port.lisp,v 1.5 92/05/07 13:13:29 cer Exp $
 
 (in-package :genera-clim)
 
@@ -10,9 +10,6 @@
 
 (defvar *genera-default-server-path* `(:genera :host ,net:*local-host*
 					       :screen ,tv:main-screen))
-(warn "Changing the default server path to ~S"
-      (setq *default-server-path* *genera-default-server-path*))
-
 
 (defclass genera-port (port)
     ((screen :initform nil :reader port-display)
@@ -22,14 +19,15 @@
      (cursor-font)
      (cursor-cache :initform nil :type nil)
      (height-pixels)
-     (width-pixels)
-     (type :allocation :class 
-	   :initform :genera :reader port-type))
+     (width-pixels))
   (:default-initargs :allow-loose-text-style-size-mapping nil))
 
 (defmethod find-port-type ((type (eql ':genera)))
   'genera-port)
 
+(defmethod port-type ((port genera-port))
+  ':genera)
+
 (defparameter *genera-use-color* t)		;for debugging monochrome...
 
 (defmethod initialize-instance :after ((port genera-port)
@@ -293,7 +291,7 @@
   (with-genera-glyph-for-character
     (port-glyph-for-character stream character style our-font)))
 
-(defmethod stream-scan-string-for-writing ((port genera-port) #+Silica medium 
+(defmethod stream-scan-string-for-writing ((port genera-port) medium 
 					   string start end style cursor-x max-x
 					   &optional glyph-buffer)
   (with-genera-glyph-for-character 
diff --git a/instclimol.lisp b/instclimol.lisp
index 2825f2c8..8435d8f5 100644
--- a/instclimol.lisp
+++ b/instclimol.lisp
@@ -20,7 +20,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: instclim-2.0.lisp,v 1.1 92/03/30 22:10:04 cer Exp $
+;; $fiHeader: instclimol.lisp,v 1.1 92/05/20 17:20:42 cer Exp Locker: cer $
 
 ;;
 ;; Load CLIM
@@ -28,6 +28,11 @@
 
 (in-package :system)
 
+
+(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
+(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
+(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a")
+
 (load-application (progn 
 		    (require :climol)
 		    (load-patches
diff --git a/instclimxm.lisp b/instclimxm.lisp
index 937fd286..fea55f0a 100644
--- a/instclimxm.lisp
+++ b/instclimxm.lisp
@@ -20,7 +20,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: instclim.cl,v 1.4 92/03/10 17:24:59 cer Exp $
+;; $fiHeader: instclimxm.lisp,v 1.1 92/03/30 22:10:04 cer Exp Locker: cer $
 
 ;;
 ;; Load CLIM
@@ -28,6 +28,10 @@
 
 (in-package :system)
 
+(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
+(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
+(defvar sys::*libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a")
+
 (load-application (progn 
 		    (require :climxm)
 		    (load-patches
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index da85ad8d..7e74c00b 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,15 +20,19 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.5 92/05/07 13:13:46 cer Exp Locker: cer $
+;; $fiHeader: compile-1.lisp,v 1.6 92/05/13 17:11:07 cer Exp Locker: cer $
 
 (in-package :user)
 
-(setq *ignore-package-name-case* t)
+;;This should not matter
+;;;; (setq *ignore-package-name-case* t)
+
 (set-case-mode :case-insensitive-lower)
 (setf (sys:gsgc-switch :print) t)
 (setf (sys:gsgc-switch :stats) t)
 
+(setq *compile-print* nil)
+
 (setq comp:generate-call-count-code-switch
   (named-function |(> debug 1)| 
 		  (lambda (safety size speed debug)
@@ -40,8 +44,6 @@
 		    (declare (ignore safety size debug))
 		    (> speed 2))))
 
-(setq *compile-print* nil)
-
 (unless (find-package 'clim-defsystem)
   (compile-file-if-needed "sys/defsystem")
   (let ((*enable-package-locked-errors* nil))
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index 2b24b04b..c9bef9da 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,11 +20,13 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.5 92/05/07 13:13:47 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.6 92/05/13 17:11:09 cer Exp Locker: cer $
 
 (excl::free (excl::malloc 262145))
 
-(setq *ignore-package-name-case* t)
+;;;;  This should not matter
+;;;; (setq *ignore-package-name-case* t)
+
 (set-case-mode :case-insensitive-lower)
 
 (tenuring
@@ -40,7 +42,6 @@
    (let ((*load-source-file-info* t)
 	 (*load-xref-info* nil)
 	 (excl:*global-gc-behavior* nil))
-     #-ignore
      (ecase sys
        (motif-clim
 	(load "climg.fasl")
@@ -69,7 +70,8 @@
 
     (load "demo/sysdcl")
     (tenuring
-      (clim-defsys::load-system 'clim-demo)))
+     #-ignore
+     (clim-defsys::load-system 'clim-demo)))
   
   (when (probe-file "/scm/4.1/sparc/src/code/")
     (let ((sys::*require-search-list*
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 28522f1e..0aa1941f 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: classes.lisp,v 1.7 92/03/10 10:11:33 cer Exp $
+;; $fiHeader: classes.lisp,v 1.8 92/05/07 13:11:07 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -54,7 +54,8 @@
      ;; Thus each bucket is a list of fonts with the same family and face,
      ;; but different sizes.  They are kept sorted small to large.
      (allow-loose-text-style-size-mapping 
-       :initform nil :initarg :allow-loose-text-style-size-mapping)))
+      :initform nil :initarg :allow-loose-text-style-size-mapping)
+     (framems :initform nil :accessor port-frame-manager)))
 
 ;;--- Make a SHEET protocol class, and call this BASIC-SHEET
 (defclass sheet ()
diff --git a/silica/db-box.lisp b/silica/db-box.lisp
index 04fe13f5..cc120a83 100644
--- a/silica/db-box.lisp
+++ b/silica/db-box.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
-;; $fiHeader: db-box.lisp,v 1.13 92/04/30 09:09:11 cer Exp Locker: cer $
+;; $fiHeader: db-box.lisp,v 1.14 92/05/06 15:37:14 cer Exp $
 
 (in-package :silica)
 
@@ -45,10 +45,11 @@
       ((member :fill))
       (pane (sheet-adopt-child pane child))
       (cons
-       (unless (and (typep (first child) '(or  (member :fill) (real 0 1)))
-		    (panep (second child)))
-	 (error "Invalid box child: ~S" contents))
-       (sheet-adopt-child pane (second child)))))
+	;; Handle top-down layout syntax
+	(unless (and (typep (first child) '(or (member :fill) (real 0 1)))
+		     (panep (second child)))
+	  (error "Invalid box child: ~S" contents))
+	(sheet-adopt-child pane (second child)))))
   (with-slots ((c contents)) pane
     (setf c contents)))
 
@@ -74,26 +75,23 @@
 		 (if (consp entry)
 		     (psetf entry (second entry) 
 			    scale (let ((n (first entry)))
-				    (if (numberp n)
-					(float n) n)))
-		   (setf scale 1.0))
+				    (if (numberp n) (float n) n)))
+		     (setf scale 1.0))
 		 (let ((space-req (apply #'compose-space entry width-or-height)))
-		   (flet ((scale (x) (if (and (numberp scale) (< x +fill+)) (/ x scale) x)))
-		     (if (eq scale :fill)
-			 (incf major+ +fill+)
-		       (progn
-			 (incf major (+ (scale (funcall fn-major space-req)) space))
-			 (incf major+ (if (eq scale :fill)
-					  +fill+
-					(scale (funcall fn-major+ space-req))))))
+		   (flet ((scale (x) 
+			    (if (and (numberp scale) (< x +fill+)) (/ x scale) x)))
+		     (declare (dynamic-extent #'scale))
+		     (cond ((eq scale :fill)
+			    (incf major+ +fill+))
+			   (t
+			    (incf major (+ (scale (funcall fn-major space-req)) space))
+			    (incf major+ (scale (funcall fn-major+ space-req)))))
 		     (incf major- (scale (funcall fn-major- space-req)))
 		     (setq minor (max minor (funcall fn-minor space-req))) 
-		     (setq minor-min
-		       (max minor-min (funcall fn-minor- space-req)))
-		     (setq minor-max
-		       (min minor-max (funcall fn-minor+ space-req))))))))
+		     (maxf minor-min (funcall fn-minor- space-req))
+		     (minf minor-max (funcall fn-minor+ space-req)))))))
 	(decf major space)
-	;; ?? These calcs lead to weirdness when fills are involved.
+	;;--- These calcs lead to weirdness when fills are involved.
 	;;--- This looks like a leftover from the time when +/- were relative
 	;;(setq minor- (max 0 (- minor minor-min)))
 	;;(setq minor+ (max 0 (- minor-max minor)))
@@ -104,6 +102,7 @@
 		       keys 
 		       (list major major+ major- minor minor+ minor-)))))))
 
+
 (defclass hbox-pane (box-pane) ())
 
 (defmethod compose-space ((box-pane hbox-pane) &key width height)
@@ -126,26 +125,27 @@
 	     (cond ((atom x) (compose-space x :height height))
 		   ((eq (car x) :fill) :fill)
 		   (t (make-space-requirement :height 0 :width (* (car x) width))))))
-    (let ((sizes 
-	    (allocate-space-to-items
-	      width
-	      space-requirement
-	      contents
-	      #'space-requirement-min-width
-	      #'space-requirement-width
-	      #'space-requirement-max-width
-	      #'compose))
-	  (x 0))
-      (mapc #'(lambda (sheet size)
-		(when (or (panep sheet)
-			  (and (consp sheet)
-			       (panep (second sheet))
-			       (setq sheet (second sheet))))
-		  (move-and-resize-sheet* sheet 
-					  x 0
-					  (frob-size size width x) height))
-		(incf x size))
-	    contents sizes)))))
+      (declare (dynamic-extent #'compose))
+      (let ((sizes 
+	      (allocate-space-to-items
+		width
+		space-requirement
+		contents
+		#'space-requirement-min-width
+		#'space-requirement-width
+		#'space-requirement-max-width
+		#'compose))
+	    (x 0))
+	(mapc #'(lambda (sheet size)
+		  (when (or (panep sheet)
+			    (and (consp sheet)
+				 (panep (second sheet))
+				 (setq sheet (second sheet))))
+		    (move-and-resize-sheet* sheet 
+					    x 0
+					    (frob-size size width x) height))
+		  (incf x size))
+	      contents sizes)))))
 
 
 (defclass vbox-pane (box-pane) ())
@@ -168,19 +168,18 @@
       (compose-space box-pane :width width :height height))
     (flet ((compose (x)
 	     (cond ((atom x) (compose-space x :width width))
-		   ((eq (car x) :fill) 
-		    :fill)
-		   (t
-		    (make-space-requirement :width 0 :height (* (car x) height))))))
+		   ((eq (car x) :fill) :fill)
+		   (t (make-space-requirement :width 0 :height (* (car x) height))))))
+      (declare (dynamic-extent #'compose))
       (let ((sizes 
-	     (allocate-space-to-items
-	      height
-	      space-requirement
-	      contents
-	      #'space-requirement-min-height
-	      #'space-requirement-height
-	      #'space-requirement-max-height
-	      #'compose))
+	      (allocate-space-to-items
+		height
+		space-requirement
+		contents
+		#'space-requirement-min-height
+		#'space-requirement-height
+		#'space-requirement-max-height
+		#'compose))
 	    (y 0))
 	(mapc #'(lambda (sheet size)
 		  (when (or (panep sheet)
@@ -189,7 +188,7 @@
 				 (setq sheet (second sheet))))
 		    (move-and-resize-sheet* sheet 
 					    0 y
-					    width (frob-size size height y)))
+ 					    width (frob-size size height y)))
 		  (incf y size))
 	      contents sizes)))))
 
diff --git a/silica/db-button.lisp b/silica/db-button.lisp
index 6e202471..7f5bbf46 100644
--- a/silica/db-button.lisp
+++ b/silica/db-button.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-button.lisp,v 1.6 92/04/15 11:45:01 cer Exp $
+;; $fiHeader: db-button.lisp,v 1.7 92/05/07 13:11:10 cer Exp $
 
 "Copyright (c) 1990, 1991 International Lisp Associates.
  Portions copyright (c) 1991, 1992 by Symbolics, Inc.  All rights reserved."
@@ -11,6 +11,10 @@
 (defclass button-pane-mixin 
 	  (space-requirement-mixin
 	   leaf-pane)
+    ;; ARMED has three states:
+    ;;  NIL ==> the button is not armed
+    ;;  T   ==> the button is armed, waiting for a pointer button press
+    ;;  :ACTIVE ==> the button is armed, waiting for a pointer button release
     ((armed :initform nil)))
 
 ;; General highlight-by-inverting method
@@ -19,7 +23,42 @@
     (draw-rectangle* medium left top right bottom
 		     :ink +flipping-ink+ :filled t)))
 
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-enter-event))
+  (with-slots (armed) pane
+    (unless armed
+      (cond ((and (pointer-event-button event)
+		  (not (zerop (pointer-event-button event))))
+	     (setf armed :active)
+	     (with-sheet-medium (medium pane)
+	       (highlight-button pane medium)))
+	    (t (setf armed t)))
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-exit-event))
+  (with-slots (armed) pane
+    (when armed
+      (when (eq armed :active)
+	(with-sheet-medium (medium pane)
+	  (highlight-button pane medium)))
+      (setf armed nil)
+      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-press-event))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed :active)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (activate-callback pane (gadget-client pane) (gadget-id pane)))))
 
+
 ;;; Push buttons
 (defclass push-button-pane (push-button button-pane-mixin)
     ((show-as-default :initarg :show-as-default
@@ -33,7 +72,7 @@
       (compute-gadget-label-size pane)
     (make-space-requirement :width width :height height)))
 
-;; Draw the text, invert the whole button when armed.
+;; Draw the text, invert the whole button when actively armed
 (defmethod repaint-sheet ((pane push-button-pane) region)
   (declare (ignore region))
   (with-sheet-medium (medium pane)
@@ -48,40 +87,7 @@
 		 :text-style text-style
 		 ;;--- :align-x ':center :align-y ':center
 		 :align-x ':left :align-y ':center)
-      (when armed
-	(highlight-button pane medium)))))
-
-(defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event))
-  (with-slots (armed) pane
-    (unless armed
-      (setf armed t)
-      (armed-callback pane (gadget-client pane) (gadget-id pane))
-      (with-sheet-medium (medium pane)
-	(highlight-button pane medium)))))
-
-(defmethod handle-event ((pane push-button-pane) (event pointer-button-release-event))
-  (with-slots (armed) pane
-    (when armed
-      (activate-callback pane (gadget-client pane) (gadget-id pane))
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane))
-      (with-sheet-medium (medium pane)
-	(highlight-button pane medium)))))
-
-(defmethod handle-event ((pane push-button-pane) (event pointer-enter-event))
-  (with-slots (armed) pane
-    (unless armed
-      (setf armed t)
-      (armed-callback pane (gadget-client pane) (gadget-id pane))
-      (with-sheet-medium (medium pane)
-	(highlight-button pane medium)))))
-
-(defmethod handle-event ((pane push-button-pane) (event pointer-exit-event))
-  (with-slots (armed) pane
-    (when armed
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane))
-      (with-sheet-medium (medium pane)
+      (when (eq armed :active)
 	(highlight-button pane medium)))))
 
 
@@ -99,7 +105,6 @@
       (make-space-requirement :width (+ width (* radius 2) 5)
 			      :height (max height (* radius 2))))))
 
-;; Draw the text, invert the whole button when armed.
 (defmethod repaint-sheet ((pane toggle-button-pane) region)
   (declare (ignore region))
   (with-sheet-medium (medium pane)
@@ -133,30 +138,17 @@
 	  (draw-circle* medium cx cy (round radius 2)
 			:ink (if (gadget-value pane) +foreground-ink+ +background-ink+)))))))
 
-(defmethod handle-event ((pane toggle-button-pane) (event pointer-button-press-event))
-  (with-slots (armed) pane
-    (unless armed
-      (setf armed t)
-      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
+;; Highlighting is a no-op
+(defmethod highlight-button ((pane toggle-button-pane) medium)
+  (declare (ignore medium)))
 
 (defmethod handle-event ((pane toggle-button-pane) (event pointer-button-release-event))
   (with-slots (armed) pane
-    (when armed
-      (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane)))
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
-
-(defmethod handle-event ((pane toggle-button-pane) (event pointer-enter-event))
-  (with-slots (armed) pane
-    (unless armed
+    (when (eq armed :active)
       (setf armed t)
-      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
-
-(defmethod handle-event ((pane toggle-button-pane) (event pointer-exit-event))
-  (with-slots (armed) pane
-    (when armed
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))))
 
 
 ;;; Menu buttons
diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp
index d0ff1c62..a6452ee7 100644
--- a/silica/db-layout.lisp
+++ b/silica/db-layout.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
-;; $fiHeader: db-layout.lisp,v 1.16 92/05/07 13:11:11 cer Exp Locker: cer $
+;; $fiHeader: db-layout.lisp,v 1.17 92/05/12 18:24:24 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -69,6 +69,21 @@
 (defmethod change-space-requirements ((pane layout-mixin) &key &allow-other-keys)
   nil)
 
+(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it)
+  (note-layout-mixin-region-changed pane :port port-did-it))
+
+(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port)  
+  (declare (ignore port))
+  (multiple-value-bind (width height) (bounding-rectangle-size pane)
+    (allocate-space pane width height)))
+
+
+(defmacro changing-space-requirements ((&rest options &key resize-frame layout) &body body)
+  (declare (ignore resize-frame))
+  `(flet ((changing-space-requirements-body () ,@body))
+     (declare (dynamic-extent #'changing-space-requirements-body))
+     (invoke-with-changing-space-requirements 
+      #'changing-space-requirements-body ,@options)))
 
 (defmethod change-space-requirements-to ((pane layout-mixin) space-requirement)
   (multiple-value-bind
@@ -79,30 +94,22 @@
        pane :width width :min-width min-width :max-width max-width 
        :height height :min-height min-height :max-height max-height)))
 
-(defmacro changing-space-requirements ((&rest options &key resize-frame layout) &body body)
-  `(flet ((changing-space-requirements-body ()
-	    ,@body))
-     (declare (dynamic-extent #'changing-space-requirements-body))
-     (invoke-with-changing-space-requirements 
-      #'changing-space-requirements-body 
-      ,@options)))
-
 (defvar *inside-changing-space-requirements* nil)
 
 (defun invoke-with-changing-space-requirements (continuation &key resize-frame (layout t))
   (let ((old-inside-changing-space-requirements 
-	 *inside-changing-space-requirements*)
+	  *inside-changing-space-requirements*)
 	(*inside-changing-space-requirements* 
-	 (cons nil *inside-changing-space-requirements*)))
+	  (cons nil *inside-changing-space-requirements*)))
     (multiple-value-prog1
-	(funcall continuation)
+      (funcall continuation)
       (unless (or (not layout) old-inside-changing-space-requirements)
-	;; Layout that frames that need to be laid out
-	;; and relayout the minimal subtrees that need to be laid out
+	;; Layout that frames that need to be laid out and
+	;; re-layout the minimal subtrees that need to be laid out
 	(let* ((frames (remove-duplicates
-			(remove-if-not 
-			#'(lambda (x) (typep x 'application-frame))
-			*inside-changing-space-requirements*)))
+			 (remove-if-not 
+			   #'(lambda (x) (application-frame-p x))
+			   *inside-changing-space-requirements*)))
 	       (panes (remove-if #'(lambda (x)
 				     (or (not (panep x))
 					 (member (pane-frame x) frames)))
@@ -117,30 +124,23 @@
 	      ;; the tree
 	      (clear-space-requirement-caches-in-tree pane) 
 	      (multiple-value-call #'allocate-space 
-		pane (bounding-rectangle-size pane)))))))))
+	        pane (bounding-rectangle-size pane)))))))))
 
 (defmethod note-space-requirement-changed (parent child)
   (multiple-value-call #'allocate-space 
     parent (bounding-rectangle-size parent)))
 
-(defmethod change-space-requirements :around ((pane layout-mixin) &key
-								 resize-frame 
-								 &allow-other-keys)
+(defmethod change-space-requirements :around ((pane layout-mixin) 
+					      &key resize-frame 
+					      &allow-other-keys)
   (call-next-method)
   (if *inside-changing-space-requirements*
       (push (if resize-frame (pane-frame pane) (sheet-parent pane))
 	    (cdr *inside-changing-space-requirements*))
-    (if resize-frame
-	(layout-frame (pane-frame pane))
-      (note-space-requirement-changed (sheet-parent pane) pane))))
+      (if resize-frame
+	  (layout-frame (pane-frame pane))
+	  (note-space-requirement-changed (sheet-parent pane) pane))))
 
-(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it)
-  (note-layout-mixin-region-changed pane :port port-did-it))
-
-(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port)  
-  (declare (ignore port))
-  (multiple-value-bind (width height) (bounding-rectangle-size pane)
-    (allocate-space pane width height)))
 
 (defun map-space-requirement (fn req)
   (setf (space-requirement-width req) (funcall fn (space-requirement-width req))
@@ -412,6 +412,9 @@
   (with-slots (space-requirement) pane
     (setf space-requirement nil)))
 
+(defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key)
+  (clear-space-requirement-cache pane))
+
 (defmethod note-space-requirements-changed :before
 	   (composite (pane space-requirement-cache-mixin))
   (declare (ignore composite))
@@ -422,9 +425,6 @@
 		       (clear-space-requirement-cache sheet))
 		   sheet))
 
-(defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key)
-  (clear-space-requirement-cache pane))
-
 (defun clear-space-requirement-caching-in-ancestors (menu)
   (do ((parent (sheet-parent menu) (sheet-parent parent)))
       ((null parent))
@@ -501,24 +501,24 @@
 
 ;;; Generally useful layout function
 ;;; Used all over to satisfy constraints
+
 ;;--- I think that since coordinates are ultimately integers we loose
 ;;---- along the way, calling fix-coor on alloc helps a little but we
 ;;---- still end up with a gap along the bottom-right edges.
-
-#+ignore
+#+++ignore
 (defun allocate-space-to-items (given wanted items min-size
 				desired-size max-size item-size)
-  (flet ((desired-size (x) (funcall desired-size x))
-	 (min-size (x) (funcall min-size x))
-	 (max-size (x) (funcall max-size x))
-	 (item-size (x) (funcall item-size x)))
+  (macrolet ((desired-size (x) `(funcall desired-size ,x))
+	     (min-size (x) `(funcall min-size ,x))
+	     (max-size (x) `(funcall max-size ,x))
+	     (item-size (x) `(funcall item-size ,x)))
     (let ((stretch-p (>= given (desired-size wanted)))
 	  extra give used sizes)
       (if stretch-p
 	  (setq give (- (max-size wanted) (desired-size wanted))
 		extra (min (- given (desired-size wanted)) give))
-	(setq give (- (desired-size wanted) (min-size wanted))
-	      extra (min (- (desired-size wanted) given) give)))
+	  (setq give (- (desired-size wanted) (min-size wanted))
+		extra (min (- (desired-size wanted) given) give)))
       (dolist (item items)
 	(let (alloc)
 	  (typecase item
@@ -529,93 +529,93 @@
 		   (setq alloc (ceiling alloc))
 		   (fix-coordinates alloc)
 		   (decf give +fill+))
-	       (setq alloc 0)))
+		 (setq alloc 0)))
 	    (t
-	     (let* ((item-size (item-size item)))
-	       (if (eq item-size :fill)
-		   (if stretch-p
-		       (progn
-			 (setq alloc (/ (* +fill+ extra) give))
-			 (setq alloc (ceiling alloc))
-			 (fix-coordinates alloc)
-			 (decf give +fill+))
-		     (setq alloc 0))
-		 (progn
-		   (setq alloc (desired-size item-size))
-		   (when (> give 0)
-		     (if stretch-p
-			 (progn
-			   (setq used (/ (* (- (max-size item-size)
-					       (desired-size item-size))
-					    extra)
-					 give))
-			   (incf alloc used)
-			   (fix-coordinates alloc)
-			   (decf give (- (max-size item-size)
-					 (desired-size item-size))))
-		       (progn
-			 (setq used (/ (* (- (desired-size item-size)
-					     (min-size item-size))
-					  extra)
-				       give))
-			 (decf alloc used)
-			 (fix-coordinates alloc)
-			 (decf give (- (desired-size item-size)
-				       (min-size item-size)))))
-		     (decf extra used)))))))
+	      (let* ((item-size (item-size item)))
+		(if (eq item-size :fill)
+		    (if stretch-p
+			(progn
+			  (setq alloc (/ (* +fill+ extra) give))
+			  (setq alloc (ceiling alloc))
+			  (fix-coordinates alloc)
+			  (decf give +fill+))
+			(setq alloc 0))
+		    (progn
+		      (setq alloc (desired-size item-size))
+		      (when (> give 0)
+			(if stretch-p
+			    (progn
+			      (setq used (/ (* (- (max-size item-size)
+						  (desired-size item-size))
+					       extra)
+					    give))
+			      (incf alloc used)
+			      (fix-coordinates alloc)
+			      (decf give (- (max-size item-size)
+					    (desired-size item-size))))
+			    (progn
+			      (setq used (/ (* (- (desired-size item-size)
+						  (min-size item-size))
+					       extra)
+					    give))
+			      (decf alloc used)
+			      (fix-coordinates alloc)
+			      (decf give (- (desired-size item-size)
+					    (min-size item-size)))))
+			(decf extra used)))))))
 	  (push alloc sizes)))
       (nreverse sizes))))
-
-;;-- This new supa dupa version saves up all the fills to the end and
-;;-- then divides up any leftover space equally amongst them and it
-;;-- seems to work!
-
+	
+;; This new supa dupa version saves up all the fills to the end and
+;; then divides up any leftover space equally amongst them and it
+;; seems to work!
+#---ignore
 (defun allocate-space-to-items (given wanted items min-size
 				desired-size max-size item-size)
-  (flet ((desired-size (x) (funcall desired-size x))
-	 (min-size (x) (funcall min-size x))
-	 (max-size (x) (funcall max-size x))
-	 (item-size (x) (funcall item-size x)))
+  (macrolet ((desired-size (x) `(funcall desired-size ,x))
+	     (min-size (x) `(funcall min-size ,x))
+	     (max-size (x) `(funcall max-size ,x))
+	     (item-size (x) `(funcall item-size ,x)))
     (let ((stretch-p (>= given (desired-size wanted)))
 	  (allocated 0)
 	  extra give used sizes)
       (if stretch-p
 	  (setq give (- (max-size wanted) (desired-size wanted))
 		extra (min (- given (desired-size wanted)) give))
-	(setq give (- (desired-size wanted) (min-size wanted))
-	      extra (min (- (desired-size wanted) given) give)))
+	  (setq give (- (desired-size wanted) (min-size wanted))
+		extra (min (- (desired-size wanted) given) give)))
       (dolist (item items)
 	(let (alloc)
 	  (typecase item
 	    ((member :fill)
 	     (setq alloc :fill))
 	    (t
-	     (let* ((item-size (item-size item)))
-	       (if (eq item-size :fill)
-		   (setq alloc :fill)
-		 (progn
-		   (setq alloc (desired-size item-size))
-		   (when (> give 0)
-		     (if stretch-p
-			 (progn
-			   (setq used (/ (* (- (max-size item-size)
-					       (desired-size item-size))
-					    extra)
-					 give))
-			   (incf alloc used)
-			   (fix-coordinates alloc)
-			   (decf give (- (max-size item-size)
-					 (desired-size item-size))))
-		       (progn
-			 (setq used (/ (* (- (desired-size item-size)
-					     (min-size item-size))
-					  extra)
-				       give))
-			 (decf alloc used)
-			 (fix-coordinates alloc)
-			 (decf give (- (desired-size item-size)
-				       (min-size item-size)))))
-		     (decf extra used)))))))
+	      (let ((item-size (item-size item)))
+		(if (eq item-size :fill)
+		    (setq alloc :fill)
+		    (progn
+		      (setq alloc (desired-size item-size))
+		      (when (> give 0)
+			(if stretch-p
+			    (progn
+			      (setq used (/ (* (- (max-size item-size)
+						  (desired-size item-size))
+					       extra)
+					    give))
+			      (incf alloc used)
+			      (fix-coordinates alloc)
+			      (decf give (- (max-size item-size)
+					    (desired-size item-size))))
+			    (progn
+			      (setq used (/ (* (- (desired-size item-size)
+						  (min-size item-size))
+					       extra)
+					    give))
+			      (decf alloc used)
+			      (fix-coordinates alloc)
+			      (decf give (- (desired-size item-size)
+					    (min-size item-size)))))
+			(decf extra used)))))))
 	  (when (numberp alloc)
 	    (incf allocated alloc))
 	  (push alloc sizes)))
@@ -624,10 +624,11 @@
 	(when (> fills 0)
 	  (let ((x (if (> leftover 0) 
 		       (fix-coordinate (/ leftover fills)) 
-		     0)))
+		       0)))
 	    (setf sizes (nsubstitute x :fill sizes)))))
       (nreverse sizes))))
-	
+
+
 ;;; Most of the layout panes should inherit from this
 
 (defclass layout-pane (sheet-mute-input-mixin
@@ -650,4 +651,3 @@
       (resize-sheet* child 
 		     (space-requirement-width space-req)
 		     (space-requirement-height space-req)))))
-
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index 0577c6a0..ef76416e 100644
--- a/silica/db-scroll.lisp
+++ b/silica/db-scroll.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-scroll.lisp,v 1.19 92/05/06 15:37:16 cer Exp Locker: cer $
+;; $fiHeader: db-scroll.lisp,v 1.20 92/05/07 13:11:13 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -14,14 +14,14 @@
 (defclass scroller-pane (client-space-requirement-mixin
 			 wrapping-space-mixin
 			 layout-pane)
-	  ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy)
-	   (vertical-scroll-bar :initform nil :accessor scroller-pane-vertical-scroll-bar)
-	   (horizontal-scroll-bar :accessor 
-				  scroller-pane-horizontal-scroll-bar
-				  :initform nil)
-	   (scrolling-supplied-by-gadget :initform nil)
-	   contents
-	   viewport)
+    ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy)
+     (vertical-scroll-bar :initform nil 
+			  :accessor scroller-pane-vertical-scroll-bar)
+     (horizontal-scroll-bar :initform nil
+			    :accessor scroller-pane-horizontal-scroll-bar)
+     (scrolling-supplied-by-gadget :initform nil)
+     contents
+     viewport)
   (:default-initargs :scroll-bars :both))
 
 (defmethod pane-viewport ((x sheet))
@@ -44,24 +44,22 @@
   (declare (ignore frame-manager frame ignore contents))
   nil)
 
-(defmethod allocate-space :before ((sp scroller-pane) width height)
+(defmethod allocate-space :before ((scroller scroller-pane) width height)
   (declare (ignore width height))
   ;; Adjust the status of the scrollbars
-  (multiple-value-bind
-      (changedp 
-       hscroll-bar hscroll-bar-enabled-p
-       vscroll-bar vscroll-bar-enabled-p)
-      (compute-dynamic-scroll-bar-values sp)
-    (if changedp
-	(update-dynamic-scroll-bars 
-	 sp
-	 changedp
-	 hscroll-bar hscroll-bar-enabled-p
-	 vscroll-bar vscroll-bar-enabled-p))))
-
-(defmethod compose-space ((sp scroller-pane) &key width height)
+  (multiple-value-bind (changedp 
+			hscroll-bar hscroll-bar-enabled-p
+			vscroll-bar vscroll-bar-enabled-p)
+      (compute-dynamic-scroll-bar-values scroller)
+    (when changedp
+      (update-dynamic-scroll-bars scroller changedp
+				  hscroll-bar hscroll-bar-enabled-p
+				  vscroll-bar vscroll-bar-enabled-p))))
+
+(defmethod compose-space ((scroller scroller-pane) &key width height)
   (declare (ignore width height))
   (let ((sr (copy-space-requirement (call-next-method))))
+    ;;--- Make sure the scroller pane is big enough to hold something
     (maxf (space-requirement-width sr) 50)
     (maxf (space-requirement-height sr) 50)
     sr))
@@ -69,77 +67,75 @@
 ;;--- Ideally we should use a toolkit scrolling window. This will look
 ;;--- exactly right and will deal with user specified placement of scroll-bars.
 ;;--- However the geometry management problems are quite huge.
-
 (defmethod initialize-instance :after ((pane scroller-pane) 
 				       &key contents frame-manager frame
 				       scroll-bars)
-  (let ((x (gadget-supplied-scrolling frame-manager frame contents :scroll-bars scroll-bars)))
+  (let ((x (gadget-supplied-scrolling frame-manager frame contents
+				      :scroll-bars scroll-bars)))
     (if x
 	(progn
 	  (sheet-adopt-child pane x)
 	  (setf (slot-value pane 'scrolling-supplied-by-gadget) t)
 	  x)
-      (progn
-	(check-type scroll-bars
-	    (member :both :dynamic :vertical :horizontal))
-	(with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane
-	  (with-look-and-feel-realization (frame-manager frame)
-	    (let ((verticalp
-		   (member scroll-bars '(:both :dynamic :vertical)))
-		  (horizontalp
-		   (member scroll-bars '(:both :dynamic :horizontal))))
-	      (setf vertical-scroll-bar 
-		(and verticalp
-		     (make-pane 'scroll-bar 
-				:orientation :vertical
-				:client pane
-				:id :vertical))
-		horizontal-scroll-bar 	    
-		(and horizontalp
-		     (make-pane 'scroll-bar 
-				:id :horizontal
-				:client pane
-				:orientation :horizontal))
-		c contents
-		viewport (make-pane 'viewport))
-	      (sheet-adopt-child pane
-				 (cond ((and horizontalp verticalp)
-					(tabling ()
-						 (viewport vertical-scroll-bar)
-						 (horizontal-scroll-bar
-						  nil)))
-				       (verticalp
-					(horizontally ()
-						      viewport
-						      vertical-scroll-bar))
-				       (horizontalp
-					(vertically ()
-						    viewport
-						    horizontal-scroll-bar))
-				       (t (error "Should not have got here"))))
-
-	      (sheet-adopt-child viewport c)
-	      ;;-- Add callbacks
-	      )))))))
-
-
-(defun update-scroll-bars (vp)
-  ;;-- This is not the most efficient thing in the world
-  (multiple-value-bind
-      (changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar
-       vscroll-bar-enabled-p)
-      (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent vp)))
+	(progn
+	  (check-type scroll-bars
+		      (member :both :dynamic :vertical :horizontal))
+	  (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane
+	    (with-look-and-feel-realization (frame-manager frame)
+	      (let ((verticalp
+		      (member scroll-bars '(:both :dynamic :vertical)))
+		    (horizontalp
+		      (member scroll-bars '(:both :dynamic :horizontal))))
+		(setf vertical-scroll-bar 
+		      (and verticalp
+			   (make-pane 'scroll-bar 
+				      :orientation :vertical
+				      :id :vertical
+				      :client pane))
+		      horizontal-scroll-bar 	    
+		      (and horizontalp
+			   (make-pane 'scroll-bar 
+				      :orientation :horizontal
+				      :id :horizontal
+				      :client pane))
+		      c contents
+		      viewport (make-pane 'viewport))
+		(sheet-adopt-child
+		  pane
+		  (cond ((and horizontalp verticalp)
+			 (tabling ()
+			   (viewport vertical-scroll-bar)
+			   (horizontal-scroll-bar nil)))
+			(verticalp
+			 (horizontally ()
+			   viewport
+			   vertical-scroll-bar))
+			(horizontalp
+			 (vertically ()
+			   viewport
+			   horizontal-scroll-bar))
+			(t (error "Internal error laying out scroll bars"))))
+		(sheet-adopt-child viewport c)
+		;;--- Add callbacks
+		)))))))
+
+(defun update-scroll-bars (viewport)
+  ;;--- This is not the most efficient thing in the world
+  (multiple-value-bind (changedp
+			hscroll-bar hscroll-bar-enabled-p
+			vscroll-bar vscroll-bar-enabled-p)
+      (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent viewport)))
     (update-dynamic-scroll-bars
-     (sheet-parent (sheet-parent vp))
-     changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar
-     vscroll-bar-enabled-p t))
-  (with-bounding-rectangle* (minx miny maxx maxy)
-    (viewport-contents-extent vp)
+      (sheet-parent (sheet-parent viewport)) changedp
+      hscroll-bar hscroll-bar-enabled-p 
+      vscroll-bar vscroll-bar-enabled-p t))
+  (with-bounding-rectangle* (minx miny maxx maxy) 
+      (viewport-contents-extent viewport)
     (with-bounding-rectangle* (vminx vminy vmaxx vmaxy)
-      (viewport-viewport-region vp)
+	(viewport-viewport-region viewport)
       (with-accessors ((horizontal-scroll-bar scroller-pane-horizontal-scroll-bar)
 		       (vertical-scroll-bar scroller-pane-vertical-scroll-bar))
-	  (sheet-parent (sheet-parent vp))
+		      (sheet-parent (sheet-parent viewport))
 	(when vertical-scroll-bar
 	  (update-scroll-bar vertical-scroll-bar
 			     miny maxy vminy vmaxy))
@@ -147,53 +143,53 @@
 	  (update-scroll-bar horizontal-scroll-bar
 			     minx maxx vminx vmaxx))))))
 
-
 ;;--- In the case where the viewport is bigger than the window this
 ;;--- code gets things wrong. Check out the thinkadot demo.  It's
 ;;--- because (- (--) (- vmin)) is negative.
-
 (defun update-scroll-bar (scroll-bar min max vmin vmax)
   (declare (optimize (safety 0) (speed 3)))
     (let ((current-size (scroll-bar-current-size scroll-bar))
 	  (current-value (scroll-bar-current-value scroll-bar)))
-    ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size
+      ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size
+      ;; before, and the viewport is bigger than the extent, don't bother with
+      ;; the fancy math.
       (let* ((gmin (float (gadget-min-value scroll-bar) 0s0))
 	     (gmax (float (gadget-max-value scroll-bar) 0s0))
 	     (range (- gmax gmin)))
-      (declare (type single-float range gmin gmax))
-      (if (and (and current-size (= (the single-float current-size) range))
-	       (> (- vmax vmin) (- max min)))
+	(declare (type single-float range gmin gmax))
+	(when (and (and current-size (= (the single-float current-size) range))
+		 (> (- vmax vmin) (- max min)))
 	  (return-from update-scroll-bar))
-      (let* ((size (the single-float
-		     (* range
-			(the single-float
-			  (if (= max min)
-			      1.0
-			    (min 1.0 (the single-float
-				       (/ (float (- vmax vmin) 0.0s0)
-					  (float (- max min) 0.0s0)))))))))
-	     (pos (the single-float
-		    (min 1.0
-			 (the single-float
-			   (max 0.0
-				(the single-float
-				  (if (zerop (- (- max min) (- vmax vmin)))
-				      0.0
-				    (the single-float 
-				      (/ (float (- vmin min) 0.0s0)
-					 (float (- (- max min) (- vmax vmin)) 0.0s0))))))))))
-	     (value (+ (gadget-min-value scroll-bar)
-		       (* (- range size) pos))))
-	(declare (type single-float pos size))
-	(unless (and current-size
-		     current-value
-		     (= current-size size)
-		     (= current-value value))
-	  (setf (scroll-bar-current-size scroll-bar) size
-		(scroll-bar-current-value scroll-bar) value)
-	  (change-scroll-bar-values scroll-bar 
-				   :slider-size size
-				   :value value))))))
+	(let* ((size (the single-float
+		       (* range
+			  (the single-float
+			    (if (= max min)
+				1.0
+			      (min 1.0 (the single-float
+					 (/ (float (- vmax vmin) 0.0s0)
+					    (float (- max min) 0.0s0)))))))))
+	       (pos (the single-float
+		      (min 1.0
+			   (the single-float
+			     (max 0.0
+				  (the single-float
+				    (if (zerop (- (- max min) (- vmax vmin)))
+					0.0
+				      (the single-float 
+					(/ (float (- vmin min) 0.0s0)
+					   (float (- (- max min) (- vmax vmin)) 0.0s0))))))))))
+	       (value (+ (gadget-min-value scroll-bar)
+			 (* (- range size) pos))))
+	  (declare (type single-float pos size))
+	  (unless (and current-size
+		       current-value
+		       (= current-size size)
+		       (= current-value value))
+	    (setf (scroll-bar-current-size scroll-bar) size
+		  (scroll-bar-current-value scroll-bar) value)
+	    (change-scroll-bar-values scroll-bar 
+				      :slider-size size
+				      :value value))))))
 
 
 (defmethod scroll-bar-value-changed-callback :before
@@ -207,18 +203,16 @@
 (defmethod scroll-bar-value-changed-callback
 	   (sheet (client scroller-pane) id value size)
   (with-slots (viewport contents) client
-    ;;--- This TYPEP stuff is a major kludge
     (let* ((extent (viewport-contents-extent viewport))
-	   (vp viewport)
-	   (viewport (viewport-viewport-region vp)))
+	   (region (viewport-viewport-region viewport)))
       (case id
 	(:vertical
 	  (scroll-extent
 	    contents
-	    :x (bounding-rectangle-min-x viewport)
+	    :x (bounding-rectangle-min-x region)
 	    :y (+ (bounding-rectangle-min-y extent)
 		  (* (max 0 (- (bounding-rectangle-height extent)
-			       (bounding-rectangle-height viewport)))
+			       (bounding-rectangle-height region)))
 		     (if (= size (gadget-range sheet))
 			 0
 		       (/ (- value (gadget-min-value sheet))
@@ -227,12 +221,12 @@
 	  (scroll-extent
 	    contents
 	    :x (* (max 0 (- (bounding-rectangle-width extent)
-			    (bounding-rectangle-width viewport)))
+			    (bounding-rectangle-width region)))
 		  (if (= size (gadget-range sheet))
 		      0
 		    (/ (- value (gadget-min-value sheet))
  		       (- (gadget-range sheet) size))))
-	    :y (bounding-rectangle-min-y viewport)))))))
+	    :y (bounding-rectangle-min-y region)))))))
 
 (defun update-region (stream nleft ntop nright nbottom &key no-repaint)
   ;;--- I suspect that we should pass in mins and maxs since this does
@@ -261,56 +255,52 @@
 				     (max (bounding-rectangle-height stream) height))))))
 
 (defun scroll-extent (stream &key (x 0) (y 0))
-  (let ((vp (pane-viewport stream)))
-    (when vp
+  (let ((viewport (pane-viewport stream)))
+    (when viewport
       (with-bounding-rectangle* (left top right bottom) 
-	(pane-viewport-region stream)
+	  (pane-viewport-region stream)
 	;;;---- This should actually bash the sheet-transformation
 	(setf (sheet-transformation stream)
-	  (make-translation-transformation (- x) (- y)))
-	(bounding-rectangle-set-position (viewport-viewport-region vp) x y)
+	      (make-translation-transformation (- x) (- y)))
+	(bounding-rectangle-set-position (viewport-viewport-region viewport) x y)
 	;;--- Is this the correct place?
-	(update-scroll-bars vp)
+	(update-scroll-bars viewport)
 	(with-bounding-rectangle* (nleft ntop nright nbottom) 
-	  (pane-viewport-region stream)
+	    (pane-viewport-region stream)
 	  ;;--- Do we really want to do this here??
 	  (update-region stream nleft ntop nright nbottom)
 	  (cond
-	   ;; if some of the stuff that was previously on display is still on display
-	   ;; bitblt it into the proper place and redraw the rest.
-	   ((ltrb-overlaps-ltrb-p left top right bottom
-				  nleft ntop nright nbottom)
-	    ;; move the old stuff to the new position
-	    (window-shift-visible-region stream 
-					 left top right bottom
-					 nleft ntop nright nbottom)
-	    (let ((rectangles (ltrb-difference nleft ntop nright nbottom
-					       left top right bottom)))
-	      (with-sheet-medium (medium stream)
-		(dolist (region rectangles)
-		  (multiple-value-call #'draw-rectangle*
-		    medium
-		    (bounding-rectangle* region)
-		    :ink +background-ink+ :filled t)
-		  (when (typep stream 'clim-internals::output-recording-mixin)
-		    (replay (stream-output-history stream) stream region))))))
-	   ;; otherwise, just redraw the whole visible viewport
-	   ;; adjust for the left and top margins by hand so clear-area doesn't erase
-	   ;; the margin components.
-	   ((typep stream 'clim-internals::output-recording-mixin)
-	    (let ((region (viewport-viewport-region vp)))
-	      ;;---- we should make the sheet-region bigger at this point
-	      ;; perhaps we do a union of the sheet-region and the viewport
-	      (with-sheet-medium (medium stream)
-		(multiple-value-call #'draw-rectangle* 
-		  medium
-		  (bounding-rectangle* region)
-		  :ink +background-ink+ :filled t))
-	      (replay (stream-output-history stream) stream region)))))
+	    ;; If some of the stuff that was previously on display is still on
+	    ;; display, BITBLT it into the proper place and redraw the rest.
+	    ((ltrb-overlaps-ltrb-p left top right bottom
+				   nleft ntop nright nbottom)
+	     ;; move the old stuff to the new position
+	     (window-shift-visible-region stream 
+					  left top right bottom
+					  nleft ntop nright nbottom)
+	     (let ((rectangles (ltrb-difference nleft ntop nright nbottom
+						left top right bottom)))
+	       (with-sheet-medium (medium stream)
+		 (dolist (region rectangles)
+		   (multiple-value-call #'draw-rectangle*
+		     medium (bounding-rectangle* region)
+		     :ink +background-ink+ :filled t)
+		   (when (output-recording-stream-p stream)
+		     (replay (stream-output-history stream) stream region))))))
+	    ;; Otherwise, just redraw the whole visible viewport
+	    ;; adjust for the left and top margins by hand so clear-area doesn't erase
+	    ;; the margin components.
+	    ((output-recording-stream-p stream)
+	     (let ((region (viewport-viewport-region viewport)))
+	       ;;---- we should make the sheet-region bigger at this point
+	       ;; perhaps we do a union of the sheet-region and the viewport
+	       (with-sheet-medium (medium stream)
+		 (multiple-value-call #'draw-rectangle* 
+		   medium (bounding-rectangle* region)
+		   :ink +background-ink+ :filled t))
+	       (replay (stream-output-history stream) stream region)))))
 	(when (and (/= left x) (/= top y))
-	  (note-viewport-position-changed
-	   (pane-frame stream)
-	   stream))))))
+	  (note-viewport-position-changed (pane-frame stream) stream))))))
 
 (defmethod note-viewport-position-changed (frame pane)
   nil)
@@ -389,10 +379,9 @@
 				       :height shaft-thickness))))))))
 	(sheet-adopt-child pane inferiors)))))
 
-(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) &rest args 
+(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane)
 				     &key slider-size value)
-  (declare (dynamic-extent args))
-  (declare (ignore slider-size value))
+  ;;--- Set the indicator to the proper size and location
   )
 
 
diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp
index 40076c95..5b316a16 100644
--- a/silica/db-slider.lisp
+++ b/silica/db-slider.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-slider.lisp,v 1.6 92/04/15 11:45:05 cer Exp $
+;; $fiHeader: db-slider.lisp,v 1.7 92/05/07 13:11:15 cer Exp $
 
 "Copyright (c) 1990, 1991 International Lisp Associates.
  Portions copyright (c) 1991, 1992 by Symbolics, Inc.  All rights reserved."
@@ -16,6 +16,10 @@
     ((thickness :initarg :thickness :initform 20)
      (show-value :initarg :show-value
 		 :accessor slider-show-value)
+     ;; ARMED has three states:
+     ;;  NIL ==> the slider is not armed
+     ;;  T   ==> the slider is armed, waiting for a pointer button press
+     ;;  :ACTIVE ==> the slider is armed, waiting for a pointer button release
      (armed :initform nil))
   (:default-initargs :value 0
 		     :show-value nil))
@@ -86,11 +90,22 @@
 					(- x dx) mid-y)
 			   :ink ink)))))))
 
-(defmethod handle-event ((pane slider-pane) (event pointer-button-press-event))
+(defmethod handle-event ((pane slider-pane) (event pointer-enter-event))
   (with-slots (armed) pane
     (unless armed
+      (setf armed t)
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-exit-event))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed nil)
+      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-button-press-event))
+  (with-slots (armed) pane
+    (when armed
       (setf armed :active)
-      (armed-callback pane (gadget-client pane) (gadget-id pane))
       (let ((x (pointer-event-x event))
 	    (y (pointer-event-y event)))
 	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
@@ -102,9 +117,8 @@
 
 (defmethod handle-event ((pane slider-pane) (event pointer-button-release-event))
   (with-slots (armed) pane
-    (when armed
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane))
+    (when (eq armed :active)
+      (setf armed t)
       (let ((x (pointer-event-x event))
 	    (y (pointer-event-y event)))
 	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
@@ -118,7 +132,7 @@
 
 (defmethod handle-event ((pane slider-pane) (event pointer-motion-event))
   (with-slots (armed) pane
-    (when (eql armed :active)
+    (when (eq armed :active)
       (let ((x (pointer-event-x event))
 	    (y (pointer-event-y event)))
 	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
@@ -129,18 +143,6 @@
 	      (update-slider-value pane x left right)))))
       (drag-callback pane (gadget-client pane) (gadget-id pane) (gadget-value pane)))))
 
-(defmethod handle-event ((pane slider-pane) (event pointer-enter-event))
-  (with-slots (armed) pane
-    (unless armed
-      (setf armed t)
-      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
-
-(defmethod handle-event ((pane slider-pane) (event pointer-exit-event))
-  (with-slots (armed) pane
-    (when armed
-      (setf armed nil)
-      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
-
 (defmethod update-slider-value ((pane slider-pane) coord min max)
   (let* ((min-value (slot-value pane 'min-value))
 	 (max-value (slot-value pane 'max-value))
diff --git a/silica/event.lisp b/silica/event.lisp
index e8853bf2..7969ed50 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.10 92/05/07 13:11:17 cer Exp Locker: cer $
+;; $fiHeader: event.lisp,v 1.11 92/05/13 17:10:35 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -203,27 +203,27 @@
 
 ;;; This code does not deal with cases (2) and (3) correctly.
 ;;; It will fail to generate enter/exit events for cases
-(defun generate-crossing-events (port sheet x y modifiers button)
+(defun generate-crossing-events (port sheet x y modifiers button pointer)
   (macrolet ((generate-enter-event (sheet)
 	       `(let ((sheet ,sheet))
 		  (dispatch-event
 		    sheet
 		    (make-instance 'pointer-enter-event
-				   :x x
-				   :y y
-				   :button button
 				   :sheet sheet
-				   :modifiers modifiers))))
+				   :x x :y y
+				   :button button
+				   :modifiers modifiers
+				   :pointer pointer))))
 	     (generate-exit-event (sheet)
 	       `(let ((sheet ,sheet))
 		  (dispatch-event
 		    sheet
 		    (make-instance 'pointer-exit-event
-				   :x x
-				   :y y
-				   :button button
 				   :sheet sheet
-				   :modifiers modifiers)))))
+				   :x x :y y
+				   :button button
+				   :modifiers modifiers
+				   :pointer pointer)))))
     (let ((v (port-trace-thing port)))
       ;; Pop up the stack of sheets
       (unless (zerop (fill-pointer v))
@@ -270,13 +270,10 @@
 	      (map-sheet-position-to-child child new-x new-y))
 	    (setq sheet child)
 	    (vector-push-extend child v)))))))
-      
-      
-(warn "Checking for port")
 
-(defun distribute-pointer-event (port mirrored-sheet event-type x y modifiers button)
+(defun distribute-pointer-event (port mirrored-sheet event-type x y modifiers button pointer)
   ;; Generate all the correct enter/exit events
-  (generate-crossing-events port mirrored-sheet x y modifiers button)
+  (generate-crossing-events port mirrored-sheet x y modifiers button pointer)
   ;; dispatch event to the innermost sheet
   (let ((sheet (let ((v (port-trace-thing port)))
 		 (and (not (zerop (fill-pointer v)))
@@ -289,41 +286,45 @@
 	  sheet
 	  (make-instance event-type
 			 :sheet sheet
-			 :native-x x
-			 :native-y y
-			 :x tx
-			 :y ty
+			 :native-x x :native-y y
+			 :x tx :y ty
 			 :modifiers modifiers
-			 :button button))))))
+			 :button button
+			 :pointer pointer))))))
 
 (defmethod distribute-event ((port port) event)
   (distribute-event-1 port event))
 
-(defgeneric distribute-event-1 (port event)
-  (:method ((port port) (event event))
-   (dispatch-event (event-sheet event) event))
-  (:method ((port port) (event keyboard-event))
-   (let ((focus (or (port-keyboard-input-focus port)
-		    (event-sheet event))))
-     ;;--- Is this correct???
-     (setf (slot-value event 'sheet) focus)
-     (dispatch-event focus event)))
-  (:method ((port port) (event window-event))
-   (dispatch-event 
-     (window-event-mirrored-sheet event)
-     event))
-  (:method ((port port) (event pointer-event))
-   (distribute-pointer-event
-     port
-     (event-sheet event)
-     (typecase event
-       ((or pointer-exit-event pointer-enter-event)
-	'pointer-motion-event)
-       (t (type-of event)))
-     (pointer-event-native-x event)
-     (pointer-event-native-y event)
-     (event-modifier-state event)
-     (pointer-event-button event))))
+(defgeneric distribute-event-1 (port event))
+
+(defmethod distribute-event-1 ((port port) (event event))
+  (dispatch-event (event-sheet event) event))
+
+(defmethod distribute-event-1 ((port port) (event keyboard-event))
+  (let ((focus (or (port-keyboard-input-focus port)
+		   (event-sheet event))))
+    ;;--- Is this correct???
+    (setf (slot-value event 'sheet) focus)
+    (dispatch-event focus event)))
+
+(defmethod distribute-event-1 ((port port) (event window-event))
+  (dispatch-event 
+    (window-event-mirrored-sheet event)
+    event))
+
+(defmethod distribute-event-1 ((port port) (event pointer-event))
+  (distribute-pointer-event
+    port
+    (event-sheet event)
+    (typecase event
+      ((or pointer-exit-event pointer-enter-event)
+       'pointer-motion-event)
+      (t (type-of event)))
+    (pointer-event-native-x event)
+    (pointer-event-native-y event)
+    (event-modifier-state event)
+    (pointer-event-button event)
+    (pointer-event-pointer event)))
 	    
 
 ;;; Local event processing
diff --git a/silica/framem.lisp b/silica/framem.lisp
index 5e7649a0..b88922c8 100644
--- a/silica/framem.lisp
+++ b/silica/framem.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: framem.lisp,v 1.6 92/04/21 16:12:39 cer Exp Locker: cer $
+;; $fiHeader: framem.lisp,v 1.7 92/05/06 15:37:18 cer Exp $
 
 (in-package :silica)
 
@@ -29,20 +29,42 @@
     ((port :reader port :initarg :port)
      (frames :accessor frame-manager-frames :initform nil)))
 
-;;-- This is most likely wrong.
-
+;;--- This is most likely wrong
 (defmethod graft ((framem standard-frame-manager))
   (car (port-grafts (port framem))))
 
-(defvar *frame-managers* nil)
+(defvar *default-frame-manager* nil)
+
+(defmacro with-frame-manager ((framem) &body body)
+  `(let ((*default-frame-manager* ,framem))
+     ,@body))
 
 (defun find-frame-manager (&rest options 
-			   &key (port (apply #'find-port options))
+			   &key port
 			   &allow-other-keys)
   (declare (dynamic-extent options))
-  (second (or (assoc port *frame-managers*)
-	      (car (push (list port (make-frame-manager port))
-			 *frame-managers*)))))
+  (unless port 
+    (with-keywords-removed (options options '(:port))
+      (setq port (apply #'find-port options))))
+  (cond 
+   ;; (find-frame-manager) -> default  one
+   ((and (null options) *default-frame-manager*))
+   ;; We specified a port we have to make sure the default on
+   ;; matches it
+   ((and *default-frame-manager*
+	 (framem-matches-options-p
+	  *default-frame-manager*
+	  port options))
+    *default-frame-manager*)
+   ;; Failing that we make one
+   (t
+    (or (port-frame-manager port)
+	(setf (port-frame-manager port)
+	  (make-frame-manager port))))))
+
+(defmethod framem-matches-options-p ((framem standard-frame-manager) port options)
+  (declare (ignore options))
+  (eq (port framem) port))
 
 (defmethod make-frame-manager (port)
   (cerror "Make a default frame manager"
@@ -75,7 +97,6 @@
 (defmethod adopt-frame :after ((framem standard-frame-manager) frame)
   (pushnew frame (frame-manager-frames framem)))
 
-
 (defmethod disown-frame ((framem standard-frame-manager) frame)
   (let ((top (frame-top-level-sheet frame)))
     (when top
@@ -84,9 +105,8 @@
 	    (frame-state frame) :disowned))))
 
 (defmethod disown-frame :after ((framem standard-frame-manager) frame)
-  (setf (frame-manager-frames framem)
-    (delete frame (frame-manager-frames framem))
-    (slot-value frame 'frame-manager) nil))
+  (setf (frame-manager-frames framem) (delete frame (frame-manager-frames framem))
+	(slot-value frame 'frame-manager) nil))
 
 (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame)
   (update-frame-settings framem frame)
@@ -94,9 +114,8 @@
   (when (frame-top-level-sheet frame)
     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)))
 
-(defmethod update-frame-settings ((framem standard-frame-manager) (frame t))
-  nil)
-
 (defmethod note-frame-disabled :after ((framem standard-frame-manager) frame)
   (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil))
 
+(defmethod update-frame-settings ((framem standard-frame-manager) frame)
+  nil)
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index a9e4ff9c..6c2ef8a8 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.21 92/05/07 13:11:19 cer Exp Locker: cer $
+;; $fiHeader: gadgets.lisp,v 1.22 92/05/12 18:24:27 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -32,15 +32,17 @@
 
 
 (defclass gadget (foreground-background-and-text-style-mixin)
-	  ((id :initarg :id :reader gadget-id :initform nil)
-	   (client :initarg :client :initform nil :accessor gadget-client)
-	   (armed-callback :initarg :armed-callback :initform nil
-			   :reader gadget-armed-callback)
-	   (disarmed-callback :initarg :disarmed-callback :initform nil
-			      :reader gadget-disarmed-callback)
-	   (active :initarg :active :accessor gadget-active-p))
+    ((id :initarg :id :reader gadget-id :initform nil)
+     (client :initarg :client :initform nil :accessor gadget-client)
+     (armed-callback :initarg :armed-callback :initform nil
+		     :reader gadget-armed-callback)
+     (disarmed-callback :initarg :disarmed-callback :initform nil
+			:reader gadget-disarmed-callback)
+     (active :initarg :active :accessor gadget-active-p))
   (:default-initargs :active t))
 
+;;; Arming and disarming
+
 (defmethod armed-callback :around ((gadget gadget) (client t) (id t))
   (let ((callback (gadget-armed-callback gadget)))
     (if callback
@@ -59,6 +61,24 @@
 (defmethod disarmed-callback ((gadget gadget) (client t) (id t))
   nil)
 
+;;; Activation and deactivation, not intended to be like callbacks
+
+(defmethod activate-gadget ((gadget gadget))
+  (unless (gadget-active-p gadget)
+    (setf (gadget-active-p gadget) t)
+    (note-gadget-activated (gadget-client gadget) gadget)))
+ 
+(defmethod note-gadget-activated ((client t) (gadget gadget))
+  nil)
+ 
+(defmethod deactivate-gadget ((gadget gadget))
+  (when (gadget-active-p gadget)
+    (setf (gadget-active-p gadget) nil)
+    (note-gadget-deactivated (gadget-client gadget) gadget)))
+ 
+(defmethod note-gadget-deactivated ((client t) (gadget gadget))
+  nil)
+
 
 (defclass value-gadget (gadget) 
     ((value :initarg :value :initform nil
@@ -110,13 +130,13 @@
 
 ;;; Basic gadgets-mixins
 
-(defclass oriented-gadget ()
+(defclass oriented-gadget-mixin ()
     ((orientation :initarg :orientation
 		  :accessor gadget-orientation))
   (:default-initargs :orientation :horizontal))
 
 
-(defclass labelled-gadget ()
+(defclass labelled-gadget-mixin ()
     ((label :initarg :label
 	    :accessor gadget-label)
      (alignment :initarg :align-x
@@ -125,11 +145,11 @@
 
 ;;--- Do the right thing
 #---ignore
-(defmethod compute-gadget-label-size ((pane labelled-gadget))
+(defmethod compute-gadget-label-size ((pane labelled-gadget-mixin))
   (values 50 20))
 
 #+++ignore
-(defun compute-gadget-label-size ((pane labelled-gadget))
+(defun compute-gadget-label-size ((pane labelled-gadget-mixin))
   (let ((text (gadget-label pane))
 	(text-style (slot-value pane 'text-style)))
     (with-sheet-medium (medium pane)
@@ -154,18 +174,16 @@
 ;;; The intent is that the real implementations inherit from these
 
 ;;; Slider
-
 (defclass slider
-	  (value-gadget oriented-gadget range-gadget-mixin labelled-gadget)
+	  (value-gadget oriented-gadget-mixin range-gadget-mixin labelled-gadget-mixin)
     ((drag-callback :initarg :drag-callback :initform nil
 		    :reader slider-drag-callback)
      (decimal-places :initarg :decimal-places
 		     :reader slider-decimal-places)
      (show-value-p :initarg :show-value-p 
 		   :accessor gadget-show-value-p))
-  (:default-initargs
-      :decimal-places 0
-      :show-value-p nil))
+  (:default-initargs :decimal-places 0
+		     :show-value-p nil))
 
 (defmethod drag-callback :around ((gadget slider) (client t) (id t) value)
   (let ((callback (slider-drag-callback gadget)))
@@ -179,9 +197,8 @@
 
 
 ;;; Scroll bar
-
 (defclass scroll-bar
-	  (value-gadget range-gadget-mixin oriented-gadget)
+	  (value-gadget range-gadget-mixin oriented-gadget-mixin)
     ((current-value :initform nil :accessor scroll-bar-current-value)
      (current-size :initform nil :accessor scroll-bar-current-size)
      (drag-callback :initarg :drag-callback :initform nil
@@ -205,27 +222,27 @@
 
 ;;; Push-button
 (defclass push-button 
-	  (action-gadget labelled-gadget) 
+	  (action-gadget labelled-gadget-mixin) 
     ())
 
 
-
-(defclass toggle-button (value-gadget labelled-gadget) 
-	  ((indicator-type :initarg :indicator-type :initform :some-of
-			   :type (member :some-of :one-of)
-			   :reader gadget-indicator-type)))
-
+;;; Toggle button
+(defclass toggle-button 
+	  (value-gadget labelled-gadget-mixin)
+    ((indicator-type :initarg :indicator-type :initform :some-of
+		     :type (member :some-of :one-of)
+		     :reader gadget-indicator-type)))
 
 
 ;;; Menu button
 (defclass menu-button 
-	  (value-gadget labelled-gadget) 
+	  (value-gadget labelled-gadget-mixin) 
     ((indicator-type :initarg :indicator-type :initform :some-of
 		     :reader gadget-indicator-type)))
 
 
 (defclass label-pane
-	  (gadget labelled-gadget)
+	  (gadget labelled-gadget-mixin)
     ())
 
 
@@ -235,7 +252,7 @@
 
 ;;; Radio box [exclusive-choice] .. [inclusive-choice]
 (defclass radio-box 
-	  (value-gadget oriented-gadget) 
+	  (value-gadget oriented-gadget-mixin) 
     ((selections :initform nil 
 		 :reader radio-box-selections)
      ;;--- think about this...
@@ -254,13 +271,12 @@
 		     :value (equal (radio-box-current-selection rb) choice)
 		     :label (if (stringp choice)
 				(string choice)
-			      (gadget-label choice))
+				(gadget-label choice))
 		     :id choice
 		     :parent rb))))))
 
 
-
-;; Check-box
+;;; Check-box
 
 (defclass check-box 
 	  (value-gadget oriented-gadget) 
@@ -271,18 +287,21 @@
  	    :initarg :current-selection
  	    :accessor check-box-current-selection)))
 
-(defmethod initialize-instance :after ((rb check-box) &key choices)
-  (let ((frame (pane-frame rb)))
+(defmethod initialize-instance :after ((cb check-box) &key choices)
+  (let ((frame (pane-frame cb)))
     (with-look-and-feel-realization ((frame-manager frame) frame)
       (dolist (choice choices)
-	(make-pane 'toggle-button 
-		   :value (equal (check-box-current-selection rb) choice)
-		   :label (if (stringp choice)
-			      (string choice)
-			    (gadget-label choice))
-		   :indicator-type :some-of
-		   :id choice
-		   :parent rb)))))
+	(unless (panep choice)
+	  ;; Sometimes the user calls MAKE-PANE within a call to
+	  ;; WITH-RADIO-BOX, so don't mess up
+	  (make-pane 'toggle-button 
+		     :value (equal (check-box-current-selection cb) choice)
+		     :label (if (stringp choice)
+				(string choice)
+				(gadget-label choice))
+		     :indicator-type :some-of
+		     :id choice
+		     :parent cb))))))
 
 
 ;;; Menu-bar
@@ -351,7 +370,7 @@
   (viewport-region-changed (sheet-child viewport) viewport))
 
 ;;--- Work on this
-#+ignore
+#+++ignore
 (defmethod note-sheet-region-changed :around ((viewport viewport) &key port-did-it)
   (declare (ignore port-did-it))
   (multiple-value-bind (changedp 
@@ -365,8 +384,7 @@
 	  vscroll-bar vscroll-bar-enabled-p)
         (call-next-method))))
 
-(defun update-dynamic-scroll-bars (sp 
-				   changedp
+(defun update-dynamic-scroll-bars (scroller changedp
 				   hscroll-bar hscroll-bar-enabled-p
 				   vscroll-bar vscroll-bar-enabled-p
 				   &optional relayout)
@@ -376,38 +394,37 @@
     (when vscroll-bar
       (setf (sheet-enabled-p vscroll-bar) vscroll-bar-enabled-p))
     (when (or (and hscroll-bar (not hscroll-bar-enabled-p))
-	      (and vscroll-bar (not vscroll-bar-enabled-p)))
-      (let* ((contents (slot-value sp 'contents))
-	     (c-extent (viewport-contents-extent
-			(pane-viewport contents))))
-	(multiple-value-bind
-	    (vx vy) (window-viewport-position contents)
-	  
-	  (window-set-viewport-position
-	   contents
-	   (if (and hscroll-bar (not hscroll-bar-enabled-p))
-	       (bounding-rectangle-min-x c-extent)
-	     vx)
-	   (if (and vscroll-bar (not vscroll-bar-enabled-p))
-	       (bounding-rectangle-min-y c-extent)
-	     vy)))))
-    (clear-space-requirement-caches-in-tree sp)
+ 	      (and vscroll-bar (not vscroll-bar-enabled-p)))
+      (let* ((contents (slot-value scroller 'contents))
+ 	     (c-extent (viewport-contents-extent
+			 (pane-viewport contents))))
+ 	(multiple-value-bind (vx vy) 
+	    (window-viewport-position contents)
+ 	  (window-set-viewport-position
+	    contents
+	    (if (and hscroll-bar (not hscroll-bar-enabled-p))
+		(bounding-rectangle-min-x c-extent)
+		vx)
+	    (if (and vscroll-bar (not vscroll-bar-enabled-p))
+		(bounding-rectangle-min-y c-extent)
+		vy)))))
+    (clear-space-requirement-caches-in-tree scroller)
     (when relayout
-      (let ((table (sheet-child sp)))
-	(multiple-value-bind
-	    (w h)
-	    (bounding-rectangle-size table)
-	  (allocate-space table w h))))))
-
-(defun compute-dynamic-scroll-bar-values (sp)
-  (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar sp))
-	 (vscroll-bar (scroller-pane-vertical-scroll-bar sp))
-	 (scroll-bar-policy (scroller-pane-scroll-bar-policy sp)))
+      (let ((table (sheet-child scroller)))
+ 	(multiple-value-bind (width height)
+ 	    (bounding-rectangle-size table)
+ 	  (allocate-space table width height))))))
+
+(defun compute-dynamic-scroll-bar-values (scroller)
+  (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar scroller))
+	 (vscroll-bar (scroller-pane-vertical-scroll-bar scroller))
+	 (scroll-bar-policy (scroller-pane-scroll-bar-policy scroller)))
     (if (eq scroll-bar-policy :dynamic)
-	(multiple-value-bind (vwidth vheight) (bounding-rectangle-size sp)
+	(multiple-value-bind (vwidth vheight) 
+	    (bounding-rectangle-size scroller)
 	  (multiple-value-bind (cwidth cheight) 
 	      (bounding-rectangle-size 
-	       (viewport-contents-extent (slot-value sp 'viewport)))
+		(viewport-contents-extent (slot-value scroller 'viewport)))
 	    (let ((ohenp (sheet-enabled-p hscroll-bar))
 		  (ovenp (sheet-enabled-p vscroll-bar))
 		  (nhenp (> cwidth vwidth))
@@ -422,10 +439,10 @@
         (values nil nil nil nil nil))))
 
 (defun viewport-contents-extent (viewport)
-  (let ((c (sheet-child viewport)))
-    (stream-output-history c)))
-
-
+  (let ((contents (sheet-child viewport)))
+    (if (output-recording-stream-p contents)
+	(stream-output-history contents)
+        contents)))
 
 ;;; Then there is the layout stuff and scrolling macros
 
@@ -441,6 +458,29 @@
 	 :frame frame :frame-manager framem
 	 options))
 
+
+;;; List panes and option menus
+
+(defclass set-gadget-mixin ()
+    ((items :initarg :items :accessor set-gadget-items)
+     (name-key :initarg :name-key :accessor set-gadget-name-key)
+     (value-key :initarg :value-key :accessor set-gadget-value-key)
+     (test :initarg :test :accessor set-gadget-test))
+  (:default-initargs :items nil
+		     :test #'eql
+		     :value-key #'identity
+		     :name-key #'princ-to-string))
+ 
+(defclass list-pane (set-gadget-mixin value-gadget)
+    ((mode :initarg :mode :type (member :exclusive :nonexclusive)
+	   :accessor list-pane-mode))
+  (:default-initargs :mode :exclusive))
+ 
+(defclass option-pane (set-gadget-mixin 
+		       value-gadget 
+		       labelled-gadget)
+    ())
+
 
 ;; Callbacks on widgets generate these events
 
@@ -458,48 +498,3 @@
 
 (defmethod handle-event ((gadget  action-gadget) (event activate-gadget-event))
   (activate-callback gadget (gadget-client gadget) (gadget-id gadget)))
-
-
-;;; Do these have readers and writers?
-
-;;; Activation/Deactivation protocol
-
-(defmethod activate-gadget ((gadget gadget))
-  (unless (gadget-active-p gadget)
-    (setf (gadget-active-p gadget) t)
-    (note-gadget-activated (gadget-client gadget) gadget)))
-
-(defmethod note-gadget-activated ((client t) (gadget gadget))
-  nil)
-
-(defmethod deactivate-gadget ((gadget gadget))
-  (when (gadget-active-p gadget)
-    (setf (gadget-active-p gadget) nil)
-    (note-gadget-deactivated (gadget-client gadget) gadget)))
-
-(defmethod note-gadget-deactivated ((client t) (gadget gadget))
-  nil)
-
-;;; List panes and option menus
-
-(defclass set-gadget-mixin ()
-	  ((items :initarg :items :accessor set-gadget-items)
-	   (name-key :initarg :name-key :accessor set-gadget-name-key)
-	   (value-key :initarg :value-key :accessor set-gadget-value-key)
-	   (test :initarg :test :accessor set-gadget-test))
-  (:default-initargs 
-    :items nil
-    :test #'eql
-    :value-key #'identity
-    :name-key #'princ-to-string))
-
-(defclass list-pane (set-gadget-mixin value-gadget)
-	  ((mode :initarg :mode :type (member :exclusive :nonexclusive)
-		 :accessor list-pane-mode))
-  (:default-initargs :mode :exclusive))
-
-(defclass option-pane (set-gadget-mixin 
-		       value-gadget 
-		       labelled-gadget)
-	  ())
-
diff --git a/silica/graphics.lisp b/silica/graphics.lisp
index 9c4b2bf3..e7af6197 100644
--- a/silica/graphics.lisp
+++ b/silica/graphics.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics.lisp,v 1.10 92/04/28 09:25:19 cer Exp Locker: cer $
+;; $fiHeader: graphics.lisp,v 1.11 92/05/07 13:11:21 cer Exp $
 
 (in-package :silica)
 
@@ -146,20 +146,20 @@
  	  (dolist (x spread-values) (push x spread-argument-names))))
     (let ((original-keywords keyword)
 	  (new-keywords 
-	   (mapcan #'(lambda (x)
-		       (let ((y (assoc (if (consp x) (car x) x) keyword-arguments-to-spread)))
-			 (if y (copy-list (cddr y)) (list x))))
-		   keyword)))
-    (values (nreverse unspread-argument-names)
-	    (nreverse spread-arguments)
-	    (nreverse spread-argument-names)
-	    (mapcar #'(lambda (x) (if (consp x) (car x) x)) new-keywords)
-	    original-keywords
-	    new-keywords
-	    (mapcar #'(lambda (x)
-			(intern (symbol-name (if (consp x) (car x) x))
-				*keyword-package*))
-		    new-keywords)))))
+	    (mapcan #'(lambda (x)
+			(let ((y (assoc (if (consp x) (car x) x)
+					keyword-arguments-to-spread)))
+			  (if y (copy-list (cddr y)) (list x))))
+		    keyword)))
+      (values (nreverse unspread-argument-names)
+	      (nreverse spread-arguments)
+	      (nreverse spread-argument-names)
+	      (mapcar #'(lambda (x) (if (consp x) (car x) x)) new-keywords)
+	      original-keywords
+	      new-keywords
+	      (mapcar #'(lambda (x)
+			  (intern (symbol-name (if (consp x) (car x) x)) :keyword))
+		      new-keywords)))))
 
 (defun transform-graphics-function-call (medium-or-stream
 					 medium-graphics-function-name
@@ -167,9 +167,7 @@
 					 other-keyword-arguments
 					 required-arguments
 					 rest-argument
-					 &optional 
-					 arguments 
-					 keyword-arguments-to-spread)
+					 &optional arguments keyword-arguments-to-spread)
   (let ((drawing-options
 	  (mapcar #'(lambda (x)
 		      (intern (symbol-name x) :keyword))
@@ -217,16 +215,14 @@
 		     ,medium-or-stream-name
 		     ,@required-arguments
 		     ,@(mapcan #'(lambda (kw-arg)
-				   (let ((v
-					  (or (second (assoc (kw-arg-keyword kw-arg) stuff))
-					      (kw-arg-default-value
-					       kw-arg)))
+				   (let ((v (or (second (assoc (kw-arg-keyword kw-arg) stuff))
+						(kw-arg-default-value kw-arg)))
 					 (ks (assoc kw-arg keyword-arguments-to-spread)))
 				     (if ks
 					 (ecase (second ks)
 					   (point (list `(and ,v (point-x ,v))
 							`(and ,v (point-y ,v)))))
-				       (list v))))
+					 (list v))))
 			       other-keyword-arguments)))
 		 (supplied-drawing-options
 		   (mapcan #'(lambda (do)
@@ -245,8 +241,7 @@
 			   ,call)
 		        call))))))))))
 
-)
-	;eval-when
+)	;eval-when
 
 
 (defmacro transform-positions ((transform) &rest positions)
@@ -319,8 +314,6 @@
 					 points-to-transform
 					 distances-to-transform
 					 point-sequences-to-transform)
-  (flet ((kintern (x)
-	   (intern x :keyword)))
   (let* ((spread-name (intern (format nil "~A*" name)))
 	 (drawing-options
 	   (all-drawing-options-lambda-list drawing-options))
@@ -330,7 +323,7 @@
 	   (intern (format nil "~A~A*" 'port- name))))
     (multiple-value-bind (unspread-argument-names spread-arguments
 			  spread-argument-names keyword-argument-names
-			  unspread-other-keyword-arguments
+			  unspread-other-keyword-arguments			  
 			  other-keyword-arguments keywords)
 	(decode-graphics-function-arguments arguments keywords-to-spread)
       `(progn
@@ -339,42 +332,50 @@
 	   (declare (ignore ,@drawing-options ,@keyword-argument-names)
 		    (dynamic-extent args))
 	   ,(if keywords-to-spread
-		  `(with-keywords-removed 
-		       (args args 
-			     ',(mapcar #'(lambda (x)
-					   (intern (car x) :keyword))
-				       keywords-to-spread))
-		     (apply #',spread-name 
-				medium
-				,@spread-arguments
-				,@(mapcan #'(lambda (x) 
-					      (destructuring-bind
-						  (name type . rest) x
-						  (ecase type
-						    (point (list 
-							    (kintern (first rest))
-							    `(and ,name (point-x ,name))
-							    (kintern (second rest))
-							    `(and ,name (point-y ,name)))))))
-					  keywords-to-spread)
-				args))
-		`(apply #',spread-name 
-				medium
-				,@spread-arguments
-				args)))
+		`(with-keywords-removed 
+		     (args args ',(mapcar #'(lambda (x)
+					      (intern (symbol-name (car x)) :keyword))
+					  keywords-to-spread))
+		   (apply #',spread-name 
+			  medium
+			  ,@spread-arguments
+			  ,@(mapcan 
+			      #'(lambda (x) 
+				  (destructuring-bind (name type . rest) x
+				    (ecase type
+				      (point 
+					(list (intern (symbol-name (first rest)) :keyword)
+					      `(and ,name (point-x ,name))
+					      (intern (symbol-name (second rest)) :keyword)
+					      `(and ,name (point-y ,name)))))))
+			      keywords-to-spread)
+			  args))
+ 		`(apply #',spread-name 
+			medium
+			,@spread-arguments
+			args)))
 	 (defun ,spread-name (medium ,@spread-argument-names &rest args 
 			      &key ,@drawing-options ,@other-keyword-arguments)
 	   (declare (ignore ,@drawing-options)
 		    (dynamic-extent args))
-	   (with-keywords-removed (args args ',keywords)
-	     (apply #'invoke-with-drawing-options
-		    medium
-		    #'(lambda ()
-			(,medium-graphics-function-name 
-			 medium
-			 ,@spread-argument-names
-			 ,@keyword-argument-names))
-		    args)))
+	   ,(if keywords
+		`(with-keywords-removed (args args ',keywords)
+		   (apply #'invoke-with-drawing-options
+			  medium
+			  #'(lambda ()
+			      (,medium-graphics-function-name 
+				 medium
+				 ,@spread-argument-names
+				 ,@keyword-argument-names))
+			  args))
+		`(apply #'invoke-with-drawing-options
+			medium
+			#'(lambda ()
+			    (,medium-graphics-function-name 
+			       medium
+			       ,@spread-argument-names
+			       ,@keyword-argument-names))
+			args)))
 	 (setf (get ',name 'args)
 	       '((,@spread-argument-names ,@keyword-argument-names)
 		 ,@args)) 
@@ -391,20 +392,17 @@
 	   (let* ((sheet (medium-sheet medium)))
 	     ;; want to tranform stuff, set up clipping region etc etc
 	     ,(and points-to-transform
-		    (do ((pts points-to-transform (cddr pts))
-			 (tf '#:transform)
-			 (r nil))
-			((null pts) 
-			 `(let ((,tf (medium-transformation medium)))
-			    ,@(nreverse r)))
-		      (let ((b 		       
-		       `(transform-positions
-			 (,tf)
-			 ,(car pts) ,(cadr pts))))
-			(if (member (car pts)
-				    optional-points-to-transform)
-			    (push `(when ,(car pts) ,b) r)
-			  (push b r)))))
+		   (do ((pts points-to-transform (cddr pts))
+			(tf '#:transform)
+			(r nil))
+		       ((null pts) 
+			`(let ((,tf (medium-transformation medium)))
+			   ,@(nreverse r)))
+		     (let ((b `(transform-positions (,tf)
+				,(first pts) ,(second pts))))
+		       (if (member (car pts) optional-points-to-transform)
+			   (push `(when ,(car pts) ,b) r)
+			   (push b r)))))
 	     ,@(and distances-to-transform
 		    `((transform-distances 
 			((medium-transformation medium))
@@ -429,7 +427,11 @@
 	     unspread-other-keyword-arguments
 	     other-keyword-arguments
 	     arguments
-	     keywords-to-spread))))))
+	     keywords-to-spread)))))
+
+(defun get-drawing-function-description (name)
+  (or (get name 'args)
+      (error "Cannot find description for: ~S" name)))
 
 
 (define-graphics-function draw-point ((point point x y))
@@ -543,11 +545,13 @@
 	(height (pattern-height pattern)))
     (if (or clipping-region transformation)
 	(with-drawing-options (medium :clipping-region clipping-region
-				      :transformation transformation)
+				      :transformation transformation
+				      :ink pattern)
+	  (draw-rectangle* medium x y (+ x width) (+ y height)
+			   :filled t))
+	(with-drawing-options (medium :ink pattern)
 	  (draw-rectangle* medium x y (+ x width) (+ y height)
-			   :filled t :ink pattern))
-	(draw-rectangle* medium x y (+ x width) (+ y height)
-			 :filled t :ink pattern))))
+			   :filled t)))))
 
 
 (define-graphics-function draw-polygon ((points point-sequence list-of-x-and-ys)
@@ -655,81 +659,23 @@
 
 
 (define-graphics-function draw-text (string-or-char (point point x y)
-						    &key (start 0) 
-						    (end nil)
-						    (align-x :left)
-						    (align-y :baseline)
-						    towards-point
-						    transform-glyphs)
+						    &key (start 0) (end nil)
+							 (align-x :left)
+							 (align-y :baseline)
+							 towards-point
+							 transform-glyphs)
   :points-to-transform (x y towards-x towards-y)
   :optional-points-to-transform (towards-x towards-y)
   :keywords-to-spread ((towards-point point towards-x towards-y))
   :drawing-options :text)
 
-(defmethod stream-glyph-for-character ((medium medium) character text-style
-				       &optional our-font)
-  (port-glyph-for-character (port medium) character text-style our-font))
-
-(defmethod stream-write-string-1 ((medium medium) glyph-buffer 
-				  start end x-font color x y)
-  (port-write-string-1 (port medium) medium
-		       glyph-buffer start end x-font color x y))
-
 (defmethod sheet-beep ((x t))
   x)
 
 (defmethod sheet-beep ((x sheet))
   (port-beep (port x) x))
 
-(defun get-drawing-function-description (name)
-  (or (get name 'args)
-      (error "Cannot find description for: ~S" name)))
-
-(defmacro define-port-graphics-method ((name port-class) &body body)
-  (destructuring-bind (args &rest ignore)
-      (get-drawing-function-description name)
-    (declare (ignore ignore))
-    `(defmethod ,(intern (format nil "~A~A*" 'port- name))
-		((port ,port-class) ,@args)
-       ,@body)))
-
 
-;;--- Remove this when the time comes...
-(defun clim-internals::draw-line-internal
-       (stream xoff yoff x1 y1 x2 y2 ink style)
-  (letf-globally (((medium-line-style stream)
-		   (or style (medium-line-style stream)))
-		  ((medium-transformation stream) +identity-transformation+))
-    (draw-line* stream
-		(+ x1 xoff) (+ y1 yoff)
-		(+ x2 xoff) (+ y2 yoff)
-		:ink ink)))
-
-;;--- Remove this when the time comes...
-(defun clim-internals::draw-rectangle-internal
-       (stream xoff yoff left top right bottom ink style)
-  (letf-globally (((medium-line-style stream)
-		   (or style (medium-line-style stream)))
-		  ((medium-transformation stream) +identity-transformation+))
-    (draw-rectangle* stream
-		     (+ left xoff) (+ top yoff)
-		     (+ right xoff) (+ bottom yoff)
-		     :filled (not style) :ink ink)))
-
-;;--- Remove this when the time comes...
-(defun clim-internals::draw-ellipse-internal
-       (stream xoff yoff center-x center-y
-	       radius-1-dx radius-1-dy radius-2-dx radius-2-dy
-	       start-angle end-angle ink style)
-  (letf-globally (((medium-line-style stream)
-		   (or style (medium-line-style stream)))
-		  ((medium-transformation stream) +identity-transformation+))
-    (draw-ellipse* stream
-		   (+ center-x xoff) (+ center-y yoff)
-		   radius-1-dx radius-1-dy radius-2-dx radius-2-dy
-		   :start-angle start-angle :end-angle end-angle
-		   :filled (not style) :ink ink)))
-
 (defmethod copy-area (sheet 
 		      from-left from-top from-right from-bottom
 		      to-left to-top)
diff --git a/silica/layout.lisp b/silica/layout.lisp
index ae6402ad..e1ef353d 100644
--- a/silica/layout.lisp
+++ b/silica/layout.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: layout.lisp,v 1.16 92/05/07 13:11:22 cer Exp Locker: cer $
+;; $fiHeader: layout.lisp,v 1.17 92/05/12 18:24:30 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -92,13 +92,13 @@
 ;(defmethod allocate-space (sheet width height)
 ;  (declare (ignore sheet width height)))
 
-
 (defun parse-box-contents (contents)
   (mapcar #'(lambda (x)
+	      ;; Handle top-down layout syntax
 	      (if (and (consp x)
-		       (typep (car x) '(or (member :fill) number)))
-		  `(list ,(car x) ,(second x))
-		x))
+		       (typep (first x) '(or (member :fill) number)))
+		  `(list ,(first x) ,(second x))
+		  x))
 	  contents))
 
 (defmacro vertically (options &body contents)
@@ -112,9 +112,10 @@
 	      :contents (list ,@(parse-box-contents contents))
 	      ,@options))
 
+
 (defmethod resize-sheet* ((sheet sheet) width height)
   (unless (and (> width 0) (> height 0))
-    (error "Trying to resize sheet to zero ~S,~S,~S"
+    (error "Trying to resize sheet ~S to be too small (~D x ~D)"
 	   sheet width height))
   (when (or width height)
     (with-bounding-rectangle* (minx miny maxx maxy) sheet
@@ -131,10 +132,6 @@
 	  ;;-- I guess we do not want to do this always but ...
 	  (allocate-space sheet owidth oheight))))))
 
-(defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height)
-  (resize-sheet* sheet width height)
-  (move-sheet* sheet minx miny))
-
 (defmethod move-sheet* ((sheet sheet) minx miny)
   (let ((trans (sheet-transformation sheet)))
     (multiple-value-bind (x y)
@@ -147,6 +144,10 @@
 		(if minx (- minx x) 0)
 		(if miny (- miny y) 0)))))))
 
+(defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height)
+  (resize-sheet* sheet width height)
+  (move-sheet* sheet minx miny))
+
 
 ;; Various
 
@@ -318,14 +319,14 @@
 
 (defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port)
   (if port
-      ;; We do this because if the wm has resized us then we want to
-      ;; do the complete layout-frame thing including clearing caches
+      ;; We do this because if the WM has resized us then we want to
+      ;; do the complete LAYOUT-FRAME thing including clearing caches
       ;; etc etc.
       (multiple-value-call #'layout-frame
 	(pane-frame pane) 
 	(bounding-rectangle-size pane))
-    ;; Otherwise just call allocate-space etc
-    (call-next-method)))
+      ;; Otherwise just call ALLOCATE-SPACE etc
+      (call-next-method)))
 
 #+++ignore
 (defmethod allocate-space ((sheet top-level-sheet) width height)
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 89e6c080..6a1fc9ef 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: medium.lisp,v 1.11 92/05/13 17:10:37 cer Exp Locker: cer $
+;; $fiHeader: medium.lisp,v 1.12 92/05/14 11:03:46 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -236,7 +236,8 @@
 	       merged-text-style merged-text-style-valid) medium
     (if merged-text-style-valid
 	merged-text-style
-	(prog1 (setf merged-text-style (merge-text-styles text-style default-text-style))
+	(prog1 
+	  (setf merged-text-style (merge-text-styles text-style default-text-style))
 	  (setf merged-text-style-valid t)))))
 
 (defmacro with-text-style ((stream style) &body body)
diff --git a/silica/mirror.lisp b/silica/mirror.lisp
index 1c685788..d24ed726 100644
--- a/silica/mirror.lisp
+++ b/silica/mirror.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: mirror.lisp,v 1.17 92/05/07 13:11:26 cer Exp Locker: cer $
+;; $fiHeader: mirror.lisp,v 1.18 92/05/12 18:24:33 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -44,9 +44,9 @@
 (defgeneric enable-mirror (port sheet))
 (defgeneric disable-mirror (port sheet))
 
-
 (defmethod sheet-direct-mirror ((sheet sheet)) nil)
 
+
 (defclass mirrored-sheet-mixin ()
     ((mirror :initform nil :accessor sheet-direct-mirror)
      (native-transformation :initform +identity-transformation+
@@ -68,9 +68,9 @@
 (defmethod sheet-device-transformation ((sheet sheet))
   (or (sheet-cached-device-transformation sheet)
       (setf (sheet-cached-device-transformation sheet)
-	(compose-transformations
-	 (sheet-transformation sheet)
-	 (sheet-device-transformation (sheet-parent sheet))))))
+	    (compose-transformations
+	      (sheet-transformation sheet)
+	      (sheet-device-transformation (sheet-parent sheet))))))
 
 (defmethod sheet-device-transformation :around ((sheet mirrored-sheet-mixin))
   (if (sheet-direct-mirror sheet)
@@ -97,16 +97,14 @@
   (sheet-native-region sheet))
 
 ;;--- This assumes that sheet siblings do not overlap...
-
 (defmethod sheet-device-region ((sheet sheet))
   (or (sheet-cached-device-region sheet)
       (setf (sheet-cached-device-region sheet)
-	(region-intersection
-	 (transform-region 
-	  (sheet-device-transformation sheet)
-	  (sheet-region sheet))
-	 (sheet-device-region (sheet-parent sheet))))))
-
+	    (region-intersection
+	      (transform-region 
+		(sheet-device-transformation sheet)
+		(sheet-region sheet))
+	      (sheet-device-region (sheet-parent sheet))))))
 
 ;;;; Mirror region stuff
 
@@ -162,14 +160,12 @@
 	      (setf (sheet-direct-mirror sheet)
 		    (call-next-method)))))
     (setf (gethash mirror (port-mirror->sheet-table port)) sheet)
-    ;;--- What is the right thing do here.
-    ;;--- In the motif port we note specify the width and height of
-    ;;--- widgets when we make them. We rely on the layout protocol -
-    ;;--- ???  to take care of all of that, ie. to go in and change
-    ;;--- the size
-    #+ignore
-    (update-mirror-transformation port sheet)
-    (setf (sheet-native-transformation sheet) +identity-transformation+)
+    ;;--- What is the right thing do here?
+    ;;--- In the Motif port we note specify the width and height of
+    ;;--- widgets when we make them.  We rely on the layout protocol
+    ;;--- to take care of all of that, ie. to go in and change the size
+    #+++ignore (update-mirror-transformation port sheet)
+    #---ignore (setf (sheet-native-transformation sheet) +identity-transformation+)
     mirror))
 
 (defmethod destroy-mirror :around ((port port) (sheet mirrored-sheet-mixin))
diff --git a/silica/port.lisp b/silica/port.lisp
index 44ef5c83..3e6e69e2 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: port.lisp,v 1.11 92/05/06 15:37:22 cer Exp Locker: cer $
+;; $fiHeader: port.lisp,v 1.12 92/05/07 13:11:29 cer Exp $
 
 (in-package :silica)
 
@@ -52,7 +52,6 @@
   (:method (x)
    (error "Cannot find port type: ~S" x)))
 
-(defmethod port ((x t)) nil)
 
 (defmethod initialize-instance :around ((port port) &key server-path)
   (setf (slot-value port 'server-path) (copy-list server-path))
@@ -62,13 +61,9 @@
 
 
 (defgeneric port (x)
-  ;;;-- Do we need this???
-  #+ignore
   (:method ((port port)) port)
-  #+ignore
   (:method ((object t)) nil))
 
-
 (defgeneric port-properties (port))
 
 (defgeneric (setf port-properties) (properties port))
diff --git a/silica/protocols.lisp b/silica/protocols.lisp
index 10ce206c..e8890bc3 100644
--- a/silica/protocols.lisp
+++ b/silica/protocols.lisp
@@ -21,9 +21,9 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
-;; $fiHeader$
+;; $fiHeader: protocols.lisp,v 1.2 92/01/02 15:09:22 cer Exp Locker: cer $
 
-(in-package "CLIM-UTILS")
+(in-package :clim-utils)
 
 ;;;
 ;;; Protocol Stuff (should be moved to a utils package)
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index c757c0c8..8a91f25e 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: sheet.lisp,v 1.13 92/05/12 18:24:36 cer Exp Locker: cer $
+;; $fiHeader: sheet.lisp,v 1.14 92/05/14 11:03:48 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -29,7 +29,7 @@
 (defgeneric sheet-child (sheet))
 (defgeneric sheet-enabled-children (sheet))
 (defgeneric sheet-siblings (sheet))
-(defgeneric sheet-ancestor-p (sheet))
+(defgeneric sheet-ancestor-p (sheet putative-ancestor))
 
 (defgeneric sheet-adopt-child (sheet child))
 (defgeneric sheet-disown-child (sheet child))
@@ -118,7 +118,7 @@
     (error "~S is not child of ~S" child parent))
   (setf (sheet-parent child) nil)
   (setf  (sheet-children parent)
-	 (delete child (sheet-children parent)))
+	 (remove child (sheet-children parent)))
   (note-sheet-disowned child)
   (when (port parent)
     (setf (port child) nil)))
@@ -265,28 +265,28 @@
    (declare (ignore port-did-it)) 
    nil))
 
-(defgeneric invalidate-cached-transformations (sheet)
-  (:method ((sheet sheet)) 
-	   (setf (sheet-cached-device-region sheet) nil)
-	   (setf (sheet-cached-device-transformation sheet) nil))
-  (:method :after ((sheet sheet-parent-mixin))
-    (mapc #'invalidate-cached-transformations (sheet-children sheet))))
-
 (defgeneric invalidate-cached-regions (sheet)
   (:method ((sheet sheet)) 
 	   (setf (sheet-cached-device-region sheet) nil))
   (:method :after ((sheet sheet-parent-mixin))
-	   (mapc #'invalidate-cached-regions (sheet-children sheet))))
+    (mapc #'invalidate-cached-regions (sheet-children sheet))))
 
 (defmethod note-sheet-region-changed :before ((sheet sheet) &key port-did-it)
   (declare (ignore port-did-it))
   (invalidate-cached-regions sheet))
 
+(defgeneric invalidate-cached-transformations (sheet)
+  (:method ((sheet sheet)) 
+   (setf (sheet-cached-device-region sheet) nil)
+   (setf (sheet-cached-device-transformation sheet) nil))
+  (:method :after ((sheet sheet-parent-mixin))
+    (mapc #'invalidate-cached-transformations (sheet-children sheet))))
+ 
 ;;--- Check to see if the call to invalidate-cached-regions is really necessary.
 ;;--- CER thinks we do because regions depend on transformations.
 
 (defmethod note-sheet-transformation-changed :before ((sheet sheet) &key port-did-it)
- (declare (ignore port-did-it))
+  (declare (ignore port-did-it))
   (invalidate-cached-transformations sheet)
   (invalidate-cached-regions sheet))
 
@@ -328,7 +328,12 @@
 
 (defclass permanent-medium-sheet-output-mixin (sheet-with-medium-mixin) ())
 
-(defmethod note-sheet-grafted :after ((sheet permanent-medium-sheet-output-mixin))
+
+(defmethod note-sheet-grafted :around ((sheet permanent-medium-sheet-output-mixin))
+  ;; By making this an around we make sure that the mirror has been
+  ;; realized at this point, if its a mirror sheet. This is pretty
+  ;; horrible but it makes sure that things happen in the right order.
+  (call-next-method)
   (when (sheet-medium-type sheet)
     (setf (sheet-medium sheet)
 	  (make-medium (port sheet) sheet))
diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp
index e857622e..faaaa88f 100644
--- a/sys/defsystem.lisp
+++ b/sys/defsystem.lisp
@@ -27,7 +27,7 @@
 ;;;
 ;;;-----------------------------------------------------------
 
-;; $fiHeader: defsystem.lisp,v 1.9 92/04/15 11:47:35 cer Exp $
+;; $fiHeader: defsystem.lisp,v 1.10 92/05/07 13:13:12 cer Exp $
 
 ;; Add a feature for ANSI-adhering Lisps.  So far, only Apple's
 ;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1.
@@ -46,9 +46,9 @@
       (pushnew :ansi-90 *features*))))
 
 #+ANSI-90
-(defpackage "CLIM-DEFSYSTEM"
-  (:use "COMMON-LISP")
-  (:nicknames "CLIM-DEFSYS" "CLIM-DS")
+(defpackage :clim-defsystem
+  (:use :common-lisp)
+  (:nicknames :clim-defsys :clim-ds)
   (:export
     *current-system*
     *defsystem-version*
@@ -70,16 +70,16 @@
 (in-package :clim-defsystem)
 
 #+(or Genera-Release-8-0 Genera-Release-8-1)
-(lisp:in-package "CLIM-DEFSYSTEM"
-		 :use '("LISP")
-		 :nicknames '("CLIM-DEFSYS"))
+(lisp:in-package :clim-defsystem
+		 :use '(:lisp)
+		 :nicknames '(:clim-defsys))
 
 #-(or ANSI-90 Genera-Release-8-0 Genera-Release-8-1)
-(lisp:in-package #-(or lispworks ANSI-90) "CLIM-DEFSYSTEM" 
-            #+lispworks "PDEFSYS"
-            #+ANSI-90 "CLIM-DEFSYSTEM"
-            #-ANSI-90 :use #-ANSI-90 '("LISP")
-            #-ANSI-90 :nicknames #-ANSI-90 '("CLIM-DEFSYS"))
+(lisp:in-package #-(or lispworks ANSI-90) :clim-defsystem 
+            #+lispworks :pdefsys
+            #+ANSI-90 :clim-defsystem
+            #-ANSI-90 :use #-ANSI-90 '(:lisp)
+            #-ANSI-90 :nicknames #-ANSI-90 '(:clim-defsys))
 
 #-ANSI-90
 (export '(*current-system*
@@ -97,7 +97,7 @@
 	  undefsystem
 	  with-compiler-options
 	  with-delayed-compiler-warnings)
-	"CLIM-DEFSYSTEM")
+	:clim-defsystem)
 
 ;;; *** A temporary workaround, easier than fixing all references to
 ;;; *** LISP:<foo>.  --RWK 20.Nov.90
@@ -109,13 +109,15 @@
 	     (assert (not (null pack)) ()
 		     "Attempting to add the name ~S to package ~S, which doesn't exist")
 	     (when (null (find-package add-name))
-	       (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"))
+	       (let (#+Allegro (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)))
 
 
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index f2c8ade4..fb43797a 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,8 +1,8 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.15 92/05/07 13:13:14 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.16 92/05/13 17:10:57 cer Exp Locker: cer $
 
-(in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user)
+(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
 "Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
 
@@ -10,7 +10,7 @@
 
 ;;; Tell the world that we're here
 ;;;--- These need to be in the CLIM.fasl also.
-;;;--- Currently they're in excl-verification  but that does not seem the best place.
+;;;--- Currently they're in EXCL-VERIFICATION but that does not seem the best place.
 (pushnew :clim *features*)
 (pushnew :clim-2 *features*)
 (pushnew :clim-2.0 *features*)
@@ -143,9 +143,10 @@
 
   ;; Establish a uniform stream model
   ("clim-streams")
-  ("cl-stream-classes" :features (not clim-uses-lisp-stream-classes))
+  (#-Cloe-Runtime "cl-stream-classes" #+Cloe-Runtime "clstrcla"
+   :features (not clim-uses-lisp-stream-classes))
   ("minima-stream-classes" :features Minima)
-  ("cl-stream-functions" 
+  (#-Cloe-Runtime "cl-stream-functions" #+Cloe-Runtime "clstrfun"
    :features (and (not clim-uses-lisp-stream-functions) (not Lucid)))
   ("lucid-stream-functions" :features Lucid)
   ("genera-streams" :features Genera)
@@ -240,8 +241,6 @@
   ("input-defs")
   ("input-protocol")
   ("output-protocol")
-  ("drawing-state-mixin" :features (not Silica))
-  ("window-protocol" :features (not Silica))
 
   ;; Output recording
   ("recording-defs"
@@ -251,25 +250,18 @@
   ("text-recording"
    :load-before-compile ("recording-protocol"))
   ("graphics-recording"
-   :load-before-compile ("recording-protocol") :features Silica)
+   :load-before-compile ("recording-protocol"))
 
   ;; Input editing
   (#-Cloe-Runtime "interactive-protocol" #+Cloe-Runtime "int-prot"
    :load-before-compile ("clim-defs"))
   ("input-editor-commands")
 
-  (#-Cloe-Runtime "protocol-intermediaries" #+Cloe-Runtime "prot-int"
-   :features (not Silica))
-
   ;; Formatted output definitions
   ("formatted-output-defs")
   ("incremental-redisplay"
    :load-before-compile ("clim-defs" "recording-protocol"))
 
-  ;; Graphics
-  ("defs-graphics-generics" :features (not Silica))
-  (#-Cloe-Runtime "graphics-generics" #+Cloe-Runtime "gph-gene" :features (not Silica))
-
   ;; Windows
   ("coordinate-sorted-set")
   ("window-stream")
@@ -277,7 +269,8 @@
   ;; Presentation types
   ("ptypes1"
    :load-before-compile ("clim-defs"))
-  ("completer")
+  ("completer"
+   :load-before-compile ("ptypes1"))
   ("presentations"
    :load-before-compile ("ptypes1"))
   ("translators"
@@ -302,47 +295,14 @@
   ("text-formatting"
    :load-before-compile ("clim-defs" "incremental-redisplay"))
 
-  (#-Cloe-Runtime "graphics-internals" #+Cloe-Runtime "gph-inte" :features (not Silica))
-
   ;; Pointer tracking
   ("tracking-pointer")
   ("dragging-output"
    :load-before-compile ("tracking-pointer"))
 
-  ("vertical-string" :features (not Silica))
-
-  ;; CLX
-  ("clx-implementation" :features (and (not Silica) Xlib))
-
-  ;; Genera
-  ("genera-implementation" :features (and (not Silica) Genera))
-
-  ;; MCL
-  ;("coral-scroll" :features (and (not Silica) CCL-2))
-  ;("coral-implementation" :features (and (not Silica) CCL-2))
-  ;("coral-fonts" :features  (and (not Silica) CCL-2))
-  ;("coral-font-stuff" :features  (and (not Silica) CCL-2))
-  ;("coral-events" :features (and (not Silica) CCL-2))
-  ;("coral-streams" :features (and (not Silica) CCL-2))
-
-  ;; CLOE
-  ;("wheader" :features (and (not Silica) Cloe-Runtime))
-  ;("windows" :features (and (not Silica) Cloe-Runtime)
-  ; :load-before-compile ("wheader"))
-  ;("cloe-implementation" :features (and (not Silica) Cloe-Runtime)
-  ; :load-before-compile ("windows"))
-  ;("cloe-events" :features (and (not Silica) Cloe-Runtime)
-  ; :load-before-compile ("windows" "cloe-implementation"))
-  ;("cloe-applications" :features (and (not Silica) Cloe-Runtime))
-
-  ;; Postscript
-  ;("postscript-implementation" :features (not Silica))
-  ;("laserwriter-metrics" :features (not Silica)
-  ; :load-before-compile ("postscript-implementation"))
-
   ;; Gadgets
-  ("db-stream" :features Silica)
-  ("gadget-output" :features Silica)
+  ("db-stream")
+  ("gadget-output")
 
   ;; Application building substrate
   ("accept"
@@ -355,19 +315,16 @@
    :load-before-compile ("clim-defs" "command"))
   ("basic-translators"
    :load-before-compile ("ptypes2" "command"))
-  ("define-application"
-   :load-before-compile ("clim-defs" "command-processor") :features (not Silica))
-  ("default-application"
-   :load-before-compile ("define-application") :features (not Silica))
   ("frames" 
-   :load-before-compile ("clim-defs" "command-processor") :features Silica)
+   :load-before-compile ("clim-defs" "command-processor"))
+  ("noting-progress"
+   :load-before-compile ("frames"))
   ("menus"
    :load-before-compile ("defresource" "clim-defs"))
-  ;("mac-menus"
-  ; :features (and (not Silica) CCL-2) :load-before-compile ("menus"))
   ("accept-values"
-   :load-before-compile ("clim-defs" "incremental-redisplay"
-			 #-Silica "define-application" #+Silica "frames"))
+   :load-before-compile ("clim-defs" "incremental-redisplay" "frames"))
+  ("drag-and-drop" 
+   :load-before-compile ("frames"))
   ("pixmap-streams"
    :load-before-compile ("clim-defs"))
   ("item-list-manager")
@@ -376,10 +333,10 @@
   ("stream-trampolines"
    :load-before-compile ("defprotocol" "stream-defprotocols"))
   ("lucid-after" :features lucid)
-  ("prefill" :features (and (not Silica) (or Genera Cloe-Runtime))))
+  ("prefill" :features (or Genera Cloe-Runtime)))
 
 
-#+(and Silica Genera)
+#+Genera
 (clim-defsys:defsystem genera-clim
     (:default-pathname "SYS:CLIM;REL-2;GENERA;"
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;GENERA;"
@@ -393,7 +350,7 @@
   ("genera-gadgets")  
   ("genera-activities"))
 
-#+(and Silica CLX use-CLX)
+#+(and CLX use-CLX)
 (clim-defsys:defsystem clx-clim
     (:default-pathname "SYS:CLIM;REL-2;CLX;"
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLX;"
@@ -407,7 +364,7 @@
   ("clx-gadgets"))
 
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem xlib
     (:default-pathname (frob-pathname "xlib")
      :default-binary-pathname (frob-pathname "xlib")
@@ -423,7 +380,7 @@
   ("x11-keysyms" :load-before-compile ("ffi"))
   ("last" :load-before-compile ("load-xlib" "xlib-funs")))
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem xt-tk
     (:default-pathname (frob-pathname "tk")
      :default-binary-pathname (frob-pathname "tk")
@@ -451,17 +408,17 @@
   ("xt-classes")
   ("xt-init"))
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem xm-tk
     (:default-pathname (frob-pathname "tk")
      :default-binary-pathname (frob-pathname "tk")
      :needed-systems (xt-tk)
      :load-before-compile (xt-tk))
   ;; Motif specific stuff
+  ("load-xm")
   ("xm-defs")
   ("xm-classes")
   ("xm-callbacks")
-  ("load-xm")
   ("xt-funs") ;;--- This is really in tk but because of the loading
   ("xm-funs")
   ("xm-classes")
@@ -470,12 +427,9 @@
   ("xm-font-list")
   ("xm-protocols")
   ("convenience")
-  #+ignore ("examples")
-
-  ;; More General stuff
   ("make-widget"))
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem ol-tk
     (:default-pathname (frob-pathname "tk")
      :default-binary-pathname (frob-pathname "tk")
@@ -483,16 +437,16 @@
      :load-before-compile (xt-tk))
   ;; OpenLook specific stuff
   ("ol-defs")
-  ("ol-classes")
   ("load-ol")
   ("xt-funs") ;;--- This is really in tk but because of the loading
   ("ol-funs")
+  ("ol-classes")
   ("ol-init")
+  ("ol-widgets")
   ("ol-callbacks")
-  #+ignore("ol-examples")
   ("make-widget"))
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem motif-clim
     (:default-pathname (frob-pathname "tk-silica")
      :default-binary-pathname (frob-pathname "tk-silica")
@@ -512,7 +466,7 @@
   ("xt-cursor")
   ("xt-pixmaps"))
 
-#+(and Silica Allegro)
+#+Allegro
 (clim-defsys:defsystem openlook-clim
     (:default-pathname (frob-pathname "tk-silica")
      :default-binary-pathname (frob-pathname "tk-silica")
@@ -531,7 +485,7 @@
   ("xt-pixmaps"))
 
 
-#+(and Silica CCL-2)
+#+CCL-2
 (clim-defsys:defsystem ccl-clim
     (:default-pathname "SYS:CLIM;REL-2;CCL;"
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CCL;"
@@ -546,7 +500,7 @@
   ("ccl-menus"))
 
 
-#+(and Silica Cloe-Runtime)
+#+Cloe-Runtime
 (clim-defsys:defsystem cloe-clim
     (:default-pathname "SYS:CLIM;REL-2;CLOE;"
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLOE;"
@@ -563,7 +517,7 @@
   ("cloe-menus"))
 
 
-#+(and Silica use-PostScript)
+#+use-PostScript
 (clim-defsys:defsystem postscript-clim
     (:default-pathname "SYS:CLIM;REL-2;POSTSCRIPT;"
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;"
@@ -592,12 +546,10 @@
 			     :pretty-name "CLIM Standalone"
 			     :default-pathname "SYS:CLIM;REL-2;CLIM;")
 
-#+Silica
 (clim-defsys:import-into-sct 'genera-clim :subsystem t
 			     :pretty-name "Genera CLIM"
 			     :default-pathname "SYS:CLIM;REL-2;GENERA;")
 
-#+Silica
 (clim-defsys:import-into-sct 'clx-clim :subsystem t
 			     :pretty-name "CLX CLIM"
 			     :default-pathname "SYS:CLIM;REL-2;CLX;")
@@ -614,20 +566,20 @@
   (:serial "clim-utils"
 	   "clim-silica"
 	   "clim-standalone"
-	   #+Silica "genera-clim"
-	   #+Silica "clx-clim"))
+	   "genera-clim"
+	   "clx-clim"))
 
-#+(and Silica ignore)
+#+++ignore
 (clim-defsys:import-into-sct 'motif-clim :subsystem t
 			     :pretty-name "Motif CLIM"
 			     :default-pathname "SYS:CLIM;REL-2;TK-SILICA;")
 
-#+(and Silica ignore)
+#+++ignore
 (clim-defsys:import-into-sct 'openlook-clim :subsystem t
 			     :pretty-name "OpenLook CLIM"
 			     :default-pathname "SYS:CLIM;REL-2;TK-SILICA;")
 
-#+(and Silica ignore)
+#+++ignore
 (sct:defsystem clim-tags-table
     (:pretty-name "CLIM Tags Table"
      :default-pathname "SYS:CLIM;REL-2;CLIM;"
@@ -655,7 +607,6 @@
 			     :sct-name :minima-clim-standalone :pretty-name "Minima CLIM Standalone"
 			     :default-pathname "SYS:CLIM;REL-2;CLIM;")
 
-#+Silica
 (clim-defsys:import-into-sct 'clx-clim :subsystem t
 			     :sct-name :minima-clx-clim :pretty-name "CLX CLIM"
 			     :default-pathname "SYS:CLIM;REL-2;CLX;")
@@ -673,7 +624,7 @@
   (:serial "minima-clim-utils"
 	   "minima-clim-silica"
 	   "minima-clim-standalone"
-	   #+Silica "minima-clx-clim"))
+	   "minima-clx-clim"))
 
 )
 
diff --git a/test/chess.lisp b/test/chess.lisp
index c0d4b278..e710483c 100644
--- a/test/chess.lisp
+++ b/test/chess.lisp
@@ -1,4 +1,4 @@
-;; -*- mode: common-lisp; package: clim -*-
+;; -*- mode: common-lisp; package: clim-user -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,10 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: chess.lisp,v 1.4 92/04/10 14:27:15 cer Exp $
+;; $fiHeader: chess.lisp,v 1.5 92/05/07 13:13:16 cer Exp Locker: cer $
 
 
-(in-package :clim)
+(in-package :clim-user)
 
 (define-application-frame chess-board ()
   ((board :initform (make-array '(8 8)
@@ -32,26 +32,44 @@
    (bitmaps :initform nil :allocation :class)
    (subprocess :initform (create-chess-subprocess)))
   (:command-table chess-commands)
-  (:pane
-   (scrolling ()
-     (make-pane 'application-pane
-       :incremental-redisplay t
-       :display-function 'draw-chess-board))))
+  (:panes
+   (board :application
+	  :incremental-redisplay t
+	  :scroll-bars :dynamic
+	  :width :compute :height :compute
+	  :max-width :compute :max-height :compute
+	  :display-function 'draw-chess-board))
+  (:layouts
+   (:default board)))
 
 (define-presentation-type chess-square ())
 
-(define-command (com-do-nothing :command-table chess-commands :menu t) ()
+(define-presentation-method highlight-presentation ((type chess-square) record stream state)
+  state
+  (multiple-value-bind (xoff yoff)
+      (convert-from-relative-to-absolute-coordinates 
+	stream (output-record-parent record))
+    (with-bounding-rectangle* (left top right bottom) record
+      (draw-rectangle* stream
+		       (- (+ left xoff) 2) (- (+ top yoff) 2)
+		       (+ right xoff 2) (+ bottom yoff 2)
+		       :line-thickness 2
+		       :filled nil
+		       :ink +flipping-ink+))))
+
+(define-chess-board-command (com-do-nothing :menu t) ()
   nil)
 
-(define-command (com-reset :command-table chess-commands :menu t) ()
+(define-chess-board-command (com-reset :menu t) ()
   (with-slots (board subprocess) *application-frame*
     (send-command subprocess "new")
     (setf board
       (make-array '(8 8)
 		  :initial-contents
-		  (make-chess-board-initial-state)))))
+		  (make-chess-board-initial-state)))
+    (window-clear *standard-output*)))
 
-(define-command com-move-piece
+(define-chess-board-command com-move-piece
     ((from 'chess-square)
      (to 'chess-square))
   (with-slots (subprocess board) *application-frame*
@@ -93,7 +111,7 @@
   (destructuring-bind
       (row col) x
     (coerce (list 
-	     (int-char (+ (char-int #\a) col))
+	     (cltl1::int-char (+ (char-int #\a) col))
 	     (digit-char (- 8 row)))
 	    'cltl1::string)))
 
@@ -106,36 +124,26 @@
      com-move-piece
      chess-commands)
   (object)
-  (list object *unsupplied-argument*))
+  (list object *unsupplied-argument-marker*))
 
-(defmethod draw-chess-board (frame stream)
-  (stream-set-cursor-position* stream 0 0)
-  (updating-output 
-	 (stream)
-	 (formatting-table 
-	  (stream)
-	  (dotimes (row 8)
-	    (formatting-row 
-	     (stream)
-	     (dotimes (column 8)
-	       (formatting-cell 
-		(stream)
-		(let ((x (aref (slot-value frame 'board) row column)))
-		  (updating-output 
-		   (stream
-		    :unique-id (list row column)
-		    :id-test #'equal
-		    :cache-value x
-		    :cache-test #'equal)
-		   (with-output-as-presentation (
-						 :object (list row column)
-						 :type 'chess-square
-						 :stream stream)
-		     (draw-piece frame
-				 stream 
-				 (second x) 
-				 (car x)
-				 (oddp (+ row column)))))))))))))
+(defmethod draw-chess-board (frame stream &key &allow-other-keys)
+  (formatting-table (stream)
+      (dotimes (row 8)
+	(formatting-row (stream)
+	    (dotimes (column 8)
+	      (formatting-cell (stream)
+		  (let ((x (aref (slot-value frame 'board) row column)))
+		    (updating-output (stream
+				      :unique-id (list row column)
+				      :id-test #'equal
+				      :cache-value x
+				      :cache-test #'equal)
+			(with-output-as-presentation (stream (list row column) 'chess-square)
+			  (draw-piece frame
+				      stream 
+				      (second x) 
+				      (car x)
+				      (oddp (+ row column))))))))))))
 
 (defmethod draw-piece (frame stream (which (eql nil)) color square)
   (draw-rectangle* stream 0 0 80 80 
@@ -161,11 +169,6 @@
     (draw-rectangle* stream 0 0 80 80 
 		     :ink ink)))
 
-
-#+ignore
-(draw-rectangle* stream 0 0 80 80 :ink pattern)
-
-
 (defun make-chess-board-initial-state ()
   (labels ((define-pieces (color)
 	       (ecase color
@@ -187,7 +190,6 @@
 	    (make-list 4 :initial-element (make-list 8))
 	    (define-pieces :white))))
 
-
 (defun create-chess-subprocess ()
   (multiple-value-bind
       (stream something pid)
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 341af84d..ed6bbfdc 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.19 92/05/07 13:13:18 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.20 92/05/13 17:10:59 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -1247,7 +1247,6 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(decf bottom yoff))
       (draw-rectangle* stream left top right bottom :filled nil :ink +cyan+))))
 
-
 (define-table-cell-test set-cursor-position "move the cursor, output some text"
   (stream-set-cursor-position stream 50 50)
   (write-string ">Wally<" stream))
@@ -2696,17 +2695,17 @@ Luke Luck licks the lakes Luke's duck likes."))
 			  ("Exit" :command (exit-clim-tests)))))
   (:command-definer nil)
   (:panes 
-   (caption-pane
-    (outlining ()
-      (scrolling ()
-	(make-pane 'application-pane :height 50))))
-   (display-pane 
-     (outlining ()
-       (scrolling ()
-	 (make-pane 'application-pane)))))
-  (:layout
-   (:default
-     (vertically () caption-pane display-pane))))
+    (caption-pane
+      (outlining ()
+	(scrolling ()
+	  (make-pane 'application-pane :height 50))))
+    (display-pane 
+      (outlining ()
+	(scrolling ()
+	  (make-pane 'application-pane)))))
+  (:layouts
+    (:default
+      (vertically () caption-pane display-pane))))
 
 (defmethod frame-standard-output ((frame clim-tests))
   (get-frame-pane frame 'display-pane))
diff --git a/test/test.lisp b/test/test.lisp
index 31e54da3..c490c13e 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: test.lisp,v 1.25 92/05/07 13:13:22 cer Exp Locker: cer $
+;; $fiHeader: test.lisp,v 1.26 92/05/12 18:25:07 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -52,12 +52,12 @@
       (make-pane 'interactor-pane)))
   (:icon :name "foo" 
 	 :pixmap (make-pattern 
-		  (let ((x (make-array '(48 48))))
-		    (dotimes (i 48)
-		      (dotimes (j 48)
-			(setf (aref x i j) (random 2))))
-		    x)
-		  (list +red+ +green+)))
+		   (let ((x (make-array '(48 48))))
+		     (dotimes (i 48)
+		       (dotimes (j 48)
+			 (setf (aref x i j) (random 2))))
+		     x)
+		   (list +red+ +green+)))
   (:geometry :width 300 :height 300))
 
 
@@ -113,8 +113,7 @@
     ()
   (window-clear *query-io*))
 
-(define-test-frame-command (com-quit :name t 
-				     :menu ("Quit" :documentation "foo"))
+(define-test-frame-command (com-quit :name t :menu ("Quit" :documentation "Word"))
     ()
   (frame-exit *application-frame*))
 
@@ -162,7 +161,7 @@
     (e :interactor
        :width 300 :max-width +fill+
        :height 300 :max-height +fill+))
-  (:layout
+  (:layouts
     (:default 
       (vertically ()
 	a b c e))
@@ -227,28 +226,47 @@
   (write-string "gadget" stream))
 
 (define-test-frame-command (com-make-one :name t :menu t)
-    ()
+    ((what '(subset :slider :push-button :interactor :radio-box)))
   (let* ((stream *query-io*))
-    (let ((weird (cons nil nil)))
-      (setf (car weird)
-	    (with-output-as-presentation (stream weird 'some-kinda-gadget)
-	      (surrounding-output-with-border (stream)
-		(with-output-as-gadget (stream)
-		  (make-pane 'slider))))))
-    (let ((weird (cons nil nil)))
-      (setf (car weird)
-	    (with-output-as-presentation (stream weird 'some-kinda-gadget)
-	      (surrounding-output-with-border (stream)
-		(with-output-as-gadget (stream)
-		  (make-pane 'push-button
-		    :label "Amazing"))))))
-    (let ((weird (cons nil nil)))
-      (setf (car weird)
-	    (with-output-as-presentation (stream weird 'some-kinda-gadget)
-	      (surrounding-output-with-border (stream)
-		(with-output-as-gadget (stream)
-		  (scrolling ()
-		    (make-pane 'interactor-pane)))))))))
+    (when (member :slider what)
+      (let ((weird (cons nil nil)))
+	(setf (car weird)
+	  (with-output-as-presentation (stream weird 'some-kinda-gadget)
+	    (surrounding-output-with-border (stream)
+					    (with-output-as-gadget (stream)
+					      (make-pane 'slider)))))))
+    
+    (when (member :push-button what)
+      (let ((weird (cons nil nil)))
+	(setf (car weird)
+	  (with-output-as-presentation (stream weird 'some-kinda-gadget)
+	    (surrounding-output-with-border (stream)
+					    (with-output-as-gadget (stream)
+					      (make-pane 'push-button
+							 :label "Amazing")))))))
+    (when (member :interactor what)
+      (let ((weird (cons nil nil)))
+	(setf (car weird)
+	  (with-output-as-presentation (stream weird 'some-kinda-gadget)
+	    (surrounding-output-with-border (stream)
+					    (with-output-as-gadget (stream)
+					      (scrolling ()
+							 (make-pane
+							  'interactor-pane))))))))
+    (when (member :radio-box what)
+      (let ((weird (cons nil nil)))
+	(setf (car weird)
+	  (with-output-as-presentation (stream weird 'some-kinda-gadget)
+	    (surrounding-output-with-border (stream)
+					    (with-output-as-gadget
+						(stream)
+					      (let ((gadget (make-pane 'radio-box)))
+						(dolist (x '(a b c) gadget)
+						  (make-pane
+						   'toggle-button
+						   :parent gadget
+						   :label (string x))))))))))
+    ))
 
 (define-test-frame-command (com-move-gadget :name t :menu t)
     ((weird 'some-kinda-gadget))
@@ -353,15 +371,15 @@
 (defun slider-dragged-callback (slider value)
   (format t "~&Slider ~A dragged to ~S" (gadget-label slider) value))
 
-
-(defun text-field-changed (tf value)
-  (format t "~&Text field ~A changed to ~S" tf value))
-
 (defun option-pane-changed-callback (tf value)
-  (format t "~&option menu ~A changed to ~S"  tf value))
+  (format t "~&Option menu ~A changed to ~S"  tf value))
 
 (defun list-pane-changed-callback (tf value)
-  (format t "~&list pane ~A changed to ~S"  tf value))
+  (format t "~&List pane ~A changed to ~S"  tf value))
+
+
+(defun text-field-changed (tf value)
+  (format t "~&Text field ~A changed to ~S" tf value))
 
 (defclass insect () ())
 
@@ -478,190 +496,166 @@
 	    :value-changed-callback 'slider-changed-callback
 	    :drag-callback 'slider-dragged-callback))))))
  
-
 (define-application-frame tf988 () ()
-			  (:command-table test-frame)
-			  (:pane 
-			   (outlining ()
-				      (horizontally ()
-						    (scrolling ()
-						     (make-pane 'text-editor 
-								:value "lucid "
-								:value-changed-callback 'text-field-changed
-								:ncolumns 30
-								:nlines 10))
-						    (scrolling ()
-							       (make-pane 'text-editor 
-									  :value "harlqn  more"
-									  :value-changed-callback 'text-field-changed
-									  :ncolumns 30
-									  :nlines 10))))))
-
-
-(define-application-frame tf97 
-    () ()
-    (:command-table test-frame)
-    (:pane 
-     (vertically ()
-		 (horizontally ()
-			       (scrolling ()
-					  (make-pane
-					   'list-pane
-					   :value "Franz"
-					   :test 'string=
-					   :value-changed-callback 
-					   'list-pane-changed-callback
-					   :items '("Franz" "Lucid"
-						    "Harlqn"
-						    "Symbolics")))
-			       :fill
-			       (scrolling ()
-					  (make-pane
-					   'list-pane
-					   :value '("Lisp" "C")
-					   :test 'string=
-					   :mode :nonexclusive
-					   :value-changed-callback 
-					   'list-pane-changed-callback
-					   :items '("C" "Cobol" "Lisp" "Ada"))))
-		 (make-pane 'option-pane
-			    :items '("eenie" "meanie" "minie")
-			    :value "minie"
-			    :value-changed-callback 
-			    'option-pane-changed-callback
-			    :test 'string=
-			    :label "moo")
-		 (outlining ()
-			    (scrolling ()
-			     (make-pane 'text-editor 
-					:value
-					"lucid are nice guys "
-					:value-changed-callback 'text-field-changed
-					:ncolumns 30
-					:nlines 10))))))
-
-(define-application-frame tf96
-    () ()
-    (:command-table test-frame)
-    (:panes
-     (a :application :width '(80 :character))
-     (b :application :width '(50 :mm))
-     (c :application :height '(10 :line))
-     (d :application :height '(5 :line))
-     (e :application :height '( 50 :mm)))
-    (:layout
-     (:default (vertically ()
-			   (horizontally () a b)
-			   (vertically () c d e)))))
-
-
-
-(define-test-frame-command (com-frob-sizes :name t :menu t)
-    ()
+  (:command-table test-frame)
+  (:pane 
+    (outlining ()
+      (horizontally ()
+	(scrolling ()
+	  (make-pane 'text-editor 
+		     :value "lucid "
+		     :value-changed-callback 'text-field-changed
+		     :ncolumns 30
+		     :nlines 10))
+	(scrolling ()
+	  (make-pane 'text-editor 
+		     :value "harlqn  more"
+		     :value-changed-callback 'text-field-changed
+		     :ncolumns 30
+		     :nlines 10))))))
+
+(define-application-frame tf97 () ()
+  (:command-table test-frame)
+  (:pane 
+    (vertically ()
+      (horizontally ()
+	(scrolling ()
+	  (make-pane 'list-pane
+	    :value "Franz"
+	    :test 'string=
+	    :value-changed-callback 'list-pane-changed-callback
+	    :items '("Franz" "Lucid" "Harlqn" "Symbolics")))
+	:fill
+	(scrolling ()
+	  (make-pane 'list-pane
+	    :value '("Lisp" "C")
+	    :test 'string=
+	    :mode :nonexclusive
+	    :value-changed-callback 'list-pane-changed-callback
+	    :items '("C" "Cobol" "Lisp" "Ada"))))
+      (make-pane 'option-pane
+		 :items '("eenie" "meanie" "minie")
+		 :value "minie"
+		 :value-changed-callback 'option-pane-changed-callback
+		 :test 'string=
+		 :label "moo")
+      (outlining ()
+	(scrolling ()
+	  (make-pane 'text-editor 
+	    :value "lucid are nice guys "
+	    :value-changed-callback 'text-field-changed
+	    :ncolumns 30
+	    :nlines 10))))))
+
+(define-application-frame tf96 () ()
+  (:command-table test-frame)
+  (:panes
+    (a :application :width '(80 :character))
+    (b :application :width '(50 :mm))
+    (c :application :height '(10 :line))
+    (d :application :height '(5 :line))
+    (e :application :height '( 50 :mm)))
+  (:layouts
+    (:default 
+      (vertically ()
+	(horizontally () a b)
+	(vertically () c d e)))))
+
+(define-test-frame-command (com-frob-sizes :name t :menu t) ()
   (changing-space-requirements ()
-			       (change-space-requirements
-				(get-frame-pane *application-frame* 'a)
-				:resize-frame t
-				:width `(,(random 60) :character))
-			       (change-space-requirements
-				(get-frame-pane *application-frame* 'b)
-				:resize-frame t
-				:width `(,(random 60) :character))
-			       (change-space-requirements
-				(get-frame-pane *application-frame* 'd)
-				:resize-frame t
-				:height `(,(random 10) :line))))
-
-(define-application-frame tf95
-    () ()
-    (:command-table test-frame)
-    (:panes
-     (a :application :width '(80 :character))
-     (b :application :width '(50 :mm))
-     (c :application :height '(10 :line))
-     (d :application :height '(5 :line))
-     (e :application :height '( 50 :mm)))
-    (:layout
-     (:default (vertically 
-		()
-		(1/3 (horizontally () (1/10 a) (9/10 b)))
-		(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
-
-
-(define-application-frame tf94
-    () ()
-    (:command-table test-frame)
-    (:panes
-     (a :application :width '(80 :character))
-     (b :application)
-     (c :application :height '(10 :line))
-     (d :application)
-     (e :application :height '( 50 :mm)))
-    (:layout
-     (:default (vertically 
-		()
-		(1/3 (horizontally () (1/10 a) (:fill b)))
-		(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
-
-(define-application-frame tf93
-    () ()
-    (:command-table test-frame)
-    (:panes
-     (a :application)
-     (b :application)
-     (c :application)
-     (d :application)
-     (e :application))
-    (:layout
-     (:default (vertically 
-		()
-		(1/3 (horizontally () (1/10 a) (9/10 b)))
-		(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
-
-(define-application-frame tf91
-    () ()
-    (:command-table test-frame)
-    (:panes
-     (a :application)
-     (b :application)
-     (c :application)
-     (d :application)
-     (e :application))
-    (:layout
-     (:default (vertically 
-		()
-		(1/3 (horizontally () (1/10 a) (:fill b)))
-		(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
-
-(define-application-frame tf92 ()
-  ()
+    (change-space-requirements
+      (get-frame-pane *application-frame* 'a)
+      :resize-frame t
+      :width `(,(random 60) :character))
+    (change-space-requirements
+      (get-frame-pane *application-frame* 'b)
+      :resize-frame t
+      :width `(,(random 60) :character))
+    (change-space-requirements
+      (get-frame-pane *application-frame* 'd)
+      :resize-frame t
+      :height `(,(random 10) :line))))
+
+(define-application-frame tf95 () ()
+  (:command-table test-frame)
+  (:panes
+    (a :application :width '(80 :character))
+    (b :application :width '(50 :mm))
+    (c :application :height '(10 :line))
+    (d :application :height '(5 :line))
+    (e :application :height '( 50 :mm)))
+  (:layouts
+    (:default 
+      (vertically ()
+	(1/3 (horizontally () (1/10 a) (9/10 b)))
+	(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
+
+(define-application-frame tf94 () ()
+  (:command-table test-frame)
+  (:panes
+    (a :application :width '(80 :character))
+    (b :application)
+    (c :application :height '(10 :line))
+    (d :application)
+    (e :application :height '( 50 :mm)))
+  (:layouts
+    (:default 
+      (vertically ()
+	(1/3 (horizontally () (1/10 a) (:fill b)))
+	(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
+
+(define-application-frame tf93 () ()
+  (:command-table test-frame)
+  (:panes
+    (a :application)
+    (b :application)
+    (c :application)
+    (d :application)
+    (e :application))
+  (:layouts
+    (:default 
+      (vertically ()
+	(1/3 (horizontally () (1/10 a) (9/10 b)))
+	(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
+
+(define-application-frame tf91 () ()
+  (:command-table test-frame)
+  (:panes
+    (a :application)
+    (b :application)
+    (c :application)
+    (d :application)
+    (e :application))
+  (:layouts
+    (:default
+      (vertically ()
+	(1/3 (horizontally () (1/10 a) (:fill b)))
+	(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
+
+(define-application-frame tf92 () ()
   (:pane
-     (make-pane 'vbox-pane
-		:contents
-		(mapcar #'(lambda (x)
-			    (destructuring-bind
-				(min max &optional (decimal-places 0))
-				x
-				(make-pane 'slider
-				 :label (format nil "Slider ~D,~D,~D"
-					 min max decimal-places)
-				 :min-value min
-				 :max-value max
-				 :decimal-places decimal-places
-				 :show-value-p t
-				 :value-changed-callback 'slider-changed-callback
-				 :drag-callback
-				 'slider-dragged-callback)))
-			'((0 100)
-			  (50 60)
-			  (50 60 2)
-			  (0.0 1.0 2))))))
+    (make-pane 'vbox-pane
+      :contents 
+        (mapcar #'(lambda (x)
+		    (destructuring-bind (min max &optional (decimal-places 0)) x
+		      (make-pane 'slider
+			:label (format nil "Slider ~D,~D,~D"
+				 min max decimal-places)
+			:min-value min
+			:max-value max
+			:decimal-places decimal-places
+			:show-value-p t
+			:value-changed-callback 'slider-changed-callback
+			:drag-callback 'slider-dragged-callback)))
+		'((0 100)
+		  (50 60)
+		  (50 60 2)
+		  (0.0 1.0 2))))))
 
 (defun test-accepting-values (&optional (own-window t)
-					(gadget-dialog-view t))
+			      (gadget-dialog-view t))
   (let* ((stream *query-io*)
-	 (ptypes-and-prompts `(
-			       (boolean "Finished it yet")
+	 (ptypes-and-prompts `((boolean "Finished it yet")
 			       ((member a b c) "3 Member test")
 			       ((member a b c d e f g h) "8 Member test")
 			       ((member a b c d e f g h i
@@ -676,46 +670,38 @@
 			       ;; A big blob of text
 			       ;; token-or-type??.tim
 			       ;; Funny ones
-			       ((or integer (member :small :large))
-				"Size:")
+			       ((or integer (member :small :large)) "Size:")
 			       ))
 	 (n (length ptypes-and-prompts))
 	 (values (make-array n :initial-element :none)))
 	   
     (accepting-values (stream :own-window own-window :label "foo")
-		      ;; Test of the member stuff
-		      (clim-internals::letf-globally 
-		       (((stream-default-view stream)
-			 (if gadget-dialog-view 
-			     (stream-default-view stream)
-			   +textual-dialog-view+)))
-
-		       (dotimes (i n)
-			 (if (eq (svref values i) :none)
-			     (setf (svref values i)
-			       (accept (first (nth i
-						   ptypes-and-prompts)) 
-				       :stream stream
-				       :prompt (second (nth i
-							    ptypes-and-prompts))))
-			   (setf (svref values i)
-			     (accept (first (nth i ptypes-and-prompts))
-				     :default (svref values i) 
-				     :stream stream
-				     :prompt (second (nth i ptypes-and-prompts)))))
-			 (terpri stream))))
+      ;; Test of the member stuff
+      (clim-internals::letf-globally (((stream-default-view stream)
+				       (if gadget-dialog-view 
+					   (stream-default-view stream)
+					   +textual-dialog-view+)))
+	(dotimes (i n)
+	  (if (eq (svref values i) :none)
+	      (setf (svref values i)
+		    (accept (first (nth i ptypes-and-prompts)) 
+			    :stream stream
+			    :prompt (second (nth i ptypes-and-prompts))))
+	      (setf (svref values i)
+		    (accept (first (nth i ptypes-and-prompts))
+			    :default (svref values i) 
+			    :stream stream
+			    :prompt (second (nth i ptypes-and-prompts)))))
+	  (terpri stream))))
     values))
 
+
 ;; This was from a pkarp mail message
-
 (defun shift-output-record (stream record dx dy)
   (let ((parent (output-record-parent record)))
     (multiple-value-bind (x-offset y-offset)
-	(convert-from-relative-to-absolute-coordinates
-	 stream
-	 parent)
-      (multiple-value-bind
-	  (x y)
+	(convert-from-relative-to-absolute-coordinates stream parent)
+      (multiple-value-bind (x y)
 	  (bounding-rectangle-position record)
 	(erase-output-record record stream)
 	(output-record-set-position record (+ x dx) (+ y dy))
diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp
index b93a211d..cda54bb0 100644
--- a/tk-silica/ol-frames.lisp
+++ b/tk-silica/ol-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-frames.lisp,v 1.2 92/01/31 14:56:00 cer Exp $
+;; $fiHeader: ol-frames.lisp,v 1.3 92/02/24 13:06:06 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -30,3 +30,151 @@
 
 (defmethod make-frame-manager ((port openlook-port))
   (make-instance 'openlook-frame-manager :port port))
+
+
+(defmethod adopt-frame :after ((framem openlook-frame-manager) 
+			       (frame standard-application-frame))
+  (when (frame-panes frame)
+    (establish-wm-protocol-callbacks framem frame)))
+
+(defmethod establish-wm-protocol-callbacks ((framem openlook-frame-manager) frame)
+  (let ((shell (frame-shell frame)))
+    (tk::add-ol-callback
+      shell 
+      (ff::string-to-char* "wmProtocol")
+      :wm-protocol
+      'ol-frame-wm-protocol-callback
+      frame)))
+
+(defun ol-frame-wm-protocol-callback (shell value frame)
+  (when (eq value :wm-delete-window)
+    (frame-wm-protocol-callback shell frame)))
+
+
+(defmethod frame-manager-dialog-view ((framem openlook-frame-manager))
+  +gadget-dialog-view+)
+
+;;;; 
+
+(defmethod frame-manager-construct-menu 
+	   ((framem openlook-frame-manager) 
+	    items 
+	    printer 
+	    presentation-type 
+	    associated-window
+	    default-style
+	    label)
+  (declare (ignore default-style))
+  (let* (value-returned 
+	 return-value
+	 (simplep (and (null printer)
+		       (null presentation-type)))
+	 (port (port framem))
+	 (menu-shell (make-instance 'xt::menu-shell
+			      :parent (or (and associated-window
+					       (sheet-mirror associated-window))
+					  (port-application-shell port))
+			      :managed nil))
+	 (menu (tk::get-values menu-shell :menu-pane)))
+
+    (when label
+      (tk::set-values menu-shell :title label))
+    
+    (labels ((make-menu-button (item class parent &rest options)
+	       (let ((button
+		      (if simplep
+			  (apply #'make-instance
+				 class 
+				 :sensitive (clim-internals::menu-item-active item)
+				 :parent parent 
+				 :managed nil
+				 :label (string (menu-item-display item))
+				 options) 
+			(let* ((pixmap (pixmap-from-menu-item
+					associated-window 
+					item
+					printer
+					presentation-type))
+			       (image (tk::image-from-pixmap pixmap))
+			       (button
+				(apply #'make-instance
+				       class 
+				       :sensitive (clim-internals::menu-item-active item)
+				       :parent parent 
+				       :label-type :image
+				       :label-image image
+				       options)))
+			  (xt::add-widget-cleanup-function
+			   button
+			   #'tk::destroy-image image)
+			  button))))
+		 #+dunno
+		 (when (clim-internals::menu-item-documentation item)
+		   (tk::add-callback button 
+				 :help-callback 
+				 'display-motif-help
+				 port
+				 (clim-internals::menu-item-documentation item)))
+		 button))
+	     (construct-menu-from-items (menu items)
+	       (map nil #'(lambda (item)
+			    (ecase (clim-internals::menu-item-type item)
+			      (:separator
+			       #+dunno
+			       (make-instance 'tk::xm-separator
+					      :managed nil
+					      :parent menu))
+			      (:label
+				  (make-instance 'xt::static-text
+						 :parent menu
+						 :managed nil
+						 :string (string
+								(menu-item-display item))))
+			      (:item
+			       (if (clim-internals::menu-item-item-list item)
+				   (let* ((menu-button
+					   (make-menu-button item 
+							     'xt::menu-button
+							     menu))
+					  (submenu (tk::get-values menu-button :menu-pane)))
+				     (construct-menu-from-items 
+				      submenu 
+				      (clim-internals::menu-item-item-list item)))
+				 (let ((menu-button
+					(make-menu-button item 'xt::oblong-button menu))
+				       (value (menu-item-value item)))
+				   (tk::add-callback
+				    menu-button
+				    :select
+				    #'(lambda (&rest args)
+					(declare (ignore args))
+					(setq return-value (list value item)
+					      value-returned t))))))))
+		    items)
+	       ;;
+	       (tk::manage-children (tk::widget-children menu))))
+	
+      (construct-menu-from-items menu items))
+    (tk::add-callback menu-shell
+		      :popdown-callback
+		      #'(lambda (&rest ignore) 
+			  (declare (ignore ignore))
+			  (setq value-returned t)))
+    (values menu-shell
+	    #'(lambda (&optional init)
+		(if init
+		    (setf value-returned nil return-value nil)
+		  (values value-returned return-value))))))
+
+(defmethod framem-enable-menu ((framem openlook-frame-manager) menu)
+  (tk::ol_menu_post menu))
+
+(defmethod framem-destroy-menu ((framem openlook-frame-manager) menu)
+  (tk::destroy-widget menu))
+
+(defmethod framem-popdown-menu ((framem openlook-frame-manager) menu)
+  (tk::ol_menu_popdown menu))
+
+(defmethod framem-menu-active-p ((framem openlook-frame-manager) menu)
+  (declare (ignore t))
+  t)
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 82135e09..2a157c04 100644
--- a/tk-silica/ol-gadgets.lisp
+++ b/tk-silica/ol-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-gadgets.lisp,v 1.11 92/05/07 13:13:51 cer Exp Locker: cer $
+;; $fiHeader: ol-gadgets.lisp,v 1.12 92/05/13 17:11:12 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -32,24 +32,15 @@
 			 (push-button openlook-push-button)
 			 (label-pane openlook-label-pane)
 			 (text-field openlook-text-field)
+			 (text-editor openlook-text-editor)
 			 (toggle-button openlook-toggle-button)
 			 (menu-bar openlook-menu-bar)
 			 (viewport ol-viewport)
 			 (radio-box openlook-radio-box)
 			 (frame-pane openlook-frame-pane)
 			 (top-level-sheet openlook-top-level-sheet)
-			 ;; One day
-			 (line-editor-pane)
-			 (label-button-pane)
-			 (radio-button-pane)
-			 (horizontal-divider-pane)
-			 (vertical-divider-pane)
-			 (label-pane)
-			 ;;
-			 (list-pane)
-			 (caption-pane)
-			 (cascade-button)
-			 ))))
+			 (list-pane openlook-list-pane)
+			 (option-pane openlook-option-pane)))))
 
 
 ;;;;;;;;;;;;;;;;;;;;
@@ -62,7 +53,7 @@
 						     (parent t)
 						     (sheet openlook-scroll-bar))
   (with-accessors ((orientation gadget-orientation)) sheet
-		  (values 'tk::scroll-bar
+		  (values 'tk::scrollbar
 			  (list :orientation orientation))))
 
 (defmethod (setf silica::scroll-bar-size) (nv (sb openlook-scroll-bar))
@@ -73,14 +64,17 @@
   (tk::set-values (sheet-direct-mirror sb) :slider-value nv)
   nv)
 
-(defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &rest args 
-				     &key slider-size value)
-  (declare (ignore args))
-  (tk::set-values
-   (sheet-direct-mirror sb)
-   :proportion-length slider-size
-   :slider-value value))
 
+(defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &key slider-size value)
+  (let ((mirror (sheet-direct-mirror sb)))
+    (multiple-value-bind
+	(mmin mmax) (tk::get-values mirror :slider-min :slider-max)
+      (multiple-value-bind
+	  (real-value real-size) (compute-new-scroll-bar-values sb mmin mmax value slider-size)
+	(tk::set-values
+	 mirror
+	 :proportion-length  real-size
+	 :slider-value real-value)))))
 
 (defmethod add-sheet-callbacks ((port openlook-port) (sheet openlook-scroll-bar) (widget t))
   (tk::add-callback widget
@@ -90,14 +84,18 @@
 
 (defmethod scroll-bar-changed-callback-1 ((widget t) (sheet openlook-scroll-bar))
   (multiple-value-bind
-      (value size)
-      (tk::get-values widget :slider-value :proportion-length)
-    (scroll-bar-value-changed-callback
-     sheet
-     (gadget-client sheet)
-     (gadget-id sheet)
-     value
-     size)))
+      (smin smax) (gadget-range* sheet)
+    (multiple-value-bind
+	(value size mmin mmax)
+	(tk::get-values widget :slider-value :proportion-length :slider-min :slider-max)
+      (scroll-bar-value-changed-callback
+       sheet
+       (gadget-client sheet)
+       (gadget-id sheet)
+       (compute-symmetric-value
+	mmin mmax value smin smax)
+       (compute-symmetric-value
+	mmin mmax size smin smax)))))
 
 (defmethod compose-space ((m openlook-scroll-bar) &key width height)
   (let ((x 16))
@@ -162,8 +160,8 @@
 ;; OpenLook viewport
 
 (defclass ol-viewport
-	  (viewport
-	   mirrored-sheet-mixin)
+	  (mirrored-sheet-mixin
+	   viewport)
     ())
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
@@ -291,9 +289,8 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-push-button))
-  (declare (ignore port))
   (with-accessors ((label gadget-label)) sheet
-    (values 'tk::menu-button 
+    (values 'tk::oblong-button 
 	    (and label (list :label label)))))
 
 ;;
@@ -307,7 +304,8 @@
 		    'queue-active-event-ol
 		    sheet))
 
-(defmethod queue-active-event-ol ((widget openlook-action-pane) sheet)
+(defmethod queue-active-event-ol (widget (sheet openlook-action-pane))
+  (declare (ignore widget))
   (distribute-event
    (port sheet)
    (make-instance 'activate-gadget-event
@@ -361,3 +359,324 @@
    (make-instance 'value-changed-gadget-event
 		  :gadget sheet
 		  :value (gadget-value sheet))))
+
+;;;
+
+(defclass openlook-labelled-gadget () ())
+
+(defmethod find-widget-class-and-initargs-for-sheet
+    :around ((port openlook-port)
+	     (parent t)
+	     (sheet openlook-labelled-gadget))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (with-accessors ((alignment gadget-alignment)
+		     (label gadget-label)) sheet
+      (when label
+	(unless (getf initargs :label)
+	  (setf (getf initargs :label) label)))
+      (unless (getf initargs :label-justify)
+	(setf (getf initargs :label-justify) 
+	  (ecase alignment
+	    (:center :left)
+	    ((:left :right)  alignment)))))
+    (values class initargs)))
+
+(defmethod (setf gadget-label) :after (nv (sheet openlook-labelled-gadget))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :label (or nv ""))))
+
+(defmethod (setf gadget-alignment) :after (nv (sheet openlook-labelled-gadget))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) 
+		    :label-justify (ecase nv
+				     (:center nv)
+				     ((:left :right) nv)))))
+
+;; Toggle button
+
+(defclass openlook-toggle-button (toggle-button
+				openlook-labelled-gadget
+				openlook-value-pane
+				xt-leaf-pane)
+	  ())
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet openlook-toggle-button))
+  (with-accessors ((set gadget-value)
+		   (indicator-type gadget-indicator-type)) sheet
+    (values (typecase (sheet-parent sheet)
+	      (openlook-radio-box 'xt::rect-button)
+	      (openlook-check-box 'xt::rect-button)
+	      (t 'xt::check-box))
+	    (append (list :set set)
+		    #+dunno
+		    (list :indicator-type 
+			  (ecase indicator-type
+			    (:one-of :one-of-many)
+			    (:some-of :n-of-many)))))))
+
+;; check-box, rect  select, unselect callback, :set resource
+
+(defmethod add-sheet-callbacks :after ((port openlook-port) 
+				       (sheet openlook-toggle-button) 
+				       (widget t))
+  (tk::add-callback widget
+		    :select
+		    'queue-value-changed-event
+		    sheet)
+  (tk::add-callback widget
+		    :unselect
+		    'queue-value-changed-event
+		    sheet))
+
+(defmethod gadget-value ((gadget openlook-toggle-button))
+  (if (sheet-direct-mirror gadget)
+      (tk::get-values (sheet-mirror gadget) :set)
+    (call-next-method)))
+
+(defmethod (setf gadget-value) (nv (gadget openlook-toggle-button) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (when (sheet-direct-mirror gadget)
+    (tk::set-values (sheet-mirror gadget) :set nv)))
+
+
+
+
+;;; 
+
+;; Openlook-orriented-gadget
+
+(defclass openlook-oriented-gadget () ())
+
+(defmethod find-widget-class-and-initargs-for-sheet :around ((port openlook-port)
+							     (parent t)
+							     (sheet openlook-oriented-gadget))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (with-accessors ((orientation gadget-orientation)) sheet
+      (unless (getf initargs :orientation)
+	(setf (getf initargs :orientation) orientation)))
+    (values class initargs)))
+
+(defmethod (setf gadget-orientation) :after (nv (gadget openlook-oriented-gadget))
+  (when (sheet-direct-mirror gadget)
+    (tk::set-values (sheet-direct-mirror gadget) :orientation nv)))
+
+
+;;
+
+(defclass openlook-radio-box (openlook-geometry-manager 
+			      mirrored-sheet-mixin
+			      #+ignore ;;-- Need to decide
+			      openlook-oriented-gadget
+			      sheet-multiple-child-mixin
+			      sheet-permanently-enabled-mixin
+			      radio-box
+			      ask-widget-for-size-mixin
+			      pane)
+	  ())
+
+(defmethod sheet-adopt-child :after ((gadget openlook-radio-box) child)
+  (setf (gadget-client child) gadget))
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet openlook-radio-box))
+  (values 'xt::exclusives nil))
+
+(defmethod value-changed-callback :around ((v gadget)
+					   (client openlook-radio-box)
+					   (id t)
+					   (value t))
+  (when (eq value t)
+    (setf (radio-box-current-selection client) v)
+    (value-changed-callback client 
+			    (gadget-client client)
+			    (gadget-id client) 
+			    v))
+  (call-next-method))
+
+(defmethod compose-space ((rb openlook-radio-box) &key width height)
+  (declare (ignore width height))
+  (let ((w 0)
+	(h 0))
+    (dolist (child (tk::widget-children (sheet-direct-mirror rb)))
+      (multiple-value-bind
+	  (ignore-x igore-y width height)
+	  (xt::widget-best-geometry child)
+	(maxf h height)
+	(incf w width)))
+    (make-space-requirement :width w :height h)))
+;;;
+
+
+(defclass openlook-check-box (openlook-geometry-manager
+			      mirrored-sheet-mixin
+			      #+Dunno ;;--- what do do about tihs
+			      openlook-oriented-gadget
+			      sheet-multiple-child-mixin
+			      sheet-permanently-enabled-mixin
+			      check-box
+			      ask-widget-for-size-mixin
+			      pane)
+	  ())
+
+(defmethod sheet-adopt-child :after ((gadget openlook-check-box) child)
+  (setf (gadget-client child) gadget))
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet openlook-check-box))
+  
+  (values 'xt::nonexclusives nil))
+
+(defmethod value-changed-callback :around ((v gadget)
+					   (client openlook-check-box)
+					   (id t)
+					   (value t))
+  (if (eq value t)
+      (push v (check-box-current-selection client))
+    (setf (check-box-current-selection client)
+      (delete v (check-box-current-selection client))))
+  (value-changed-callback client 
+			  (gadget-client client)
+			  (gadget-id client) 
+			  (check-box-current-selection client))
+  (call-next-method))
+
+;;
+
+;; Openlook-orriented-gadget
+
+
+(defclass openlook-slider (#+ignore openlook-range-pane
+			   #+ignore openlook-oriented-gadget
+			   xt-leaf-pane
+			   slider)
+	  ())
+
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet openlook-slider))
+  (with-accessors ((label gadget-label)
+		   (show-value-p gadget-show-value-p)
+		   (value gadget-value)
+		   (orientation gadget-orientation)) sheet
+    (multiple-value-bind
+	(smin smax) (gadget-range* sheet)
+      (let ((mmin 0) 
+	    (mmax 100))
+	(values 'tk::slider
+		(append
+		 (list :orientation orientation)
+		 #+dunno
+		 (and label (list :title-string label))
+		 (list :slider-min mmin
+		       :slider-max mmax)
+		 (and value 
+		      (list :slider-value 
+			    (fix-coordinate 
+				    (compute-symmetric-value
+				     smin smax value mmin
+				     mmax))))))))))
+
+(defmethod compose-space ((m openlook-slider) &key width height)
+  (declare (ignore width height))
+  (let ((sr (copy-space-requirement (call-next-method))))
+    (ecase (gadget-orientation m)
+      (:vertical
+       (setf (space-requirement-max-height sr) +fill+))
+      (:horizontal
+       (setf (space-requirement-max-width sr) +fill+)))
+    sr))
+
+#+dunno
+(defmethod (setf gadget-show-value-p) :after (nv (sheet openlook-slider)) 
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :show-value nv)))
+
+#+dunno 
+(defmethod (setf gadget-label) :after (nv (sheet openlook-slider))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv ""))))
+
+;;; 
+
+(defclass openlook-text-editor (openlook-value-pane 
+				openlook-action-pane
+				text-editor
+				xt-leaf-pane)
+	  ())
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet
+						      openlook-text-editor))
+  (with-accessors ((value gadget-value)
+		   (ncolumns silica::gadget-columns)
+		   (nlines silica::gadget-lines)) sheet
+    (values 'tk::text
+	    (append
+	     (list :edit-mode :multi-line)
+	     (and ncolumns (list :columns ncolumns))
+	     (and nlines (list :rows nlines))
+	     (and value `(:value ,value))))))
+
+(defmethod compose-space ((te openlook-text-editor) &key width height)
+  (declare (ignore width height))
+  (let ((sr (call-next-method)))
+    (setq sr (copy-space-requirement sr))
+    ;;-- What it the correct thing to do???
+    (setf (space-requirement-max-width sr) +fill+
+	  (space-requirement-max-height sr) +fill+)
+    sr))
+
+(defmethod silica::gadget-supplied-scrolling (frame-manager frame 
+					      (contents openlook-text-editor) 
+					      &rest ignore)
+  (declare (ignore ignore))
+  (with-look-and-feel-realization (frame-manager frame)
+    (make-pane 'openlook-scrolling-window :contents contents)))
+
+;;;
+;;;--- This code is so much like the motif one I think we could share
+;;;--- code.
+
+(defclass openlook-scrolling-window (openlook-geometry-manager
+				  ask-widget-for-size-mixin
+				  mirrored-sheet-mixin
+				  sheet-single-child-mixin
+				  sheet-permanently-enabled-mixin
+				  pane)
+	  ;;-- probably one of the options is whether to have vertical
+	  ;;-- and/or horizontal scrollbars
+	  ())
+
+(defmethod initialize-instance :after ((pane openlook-scrolling-window) &key contents)
+  (sheet-adopt-child pane contents))
+
+(defmethod compose-space ((fr openlook-scrolling-window) &key width height)
+  (declare (ignore width height))
+  ;;--- This is not quite right because I think scrollbars are a bit
+  ;;--- bigger than this. But atleast its a start
+  (let ((fudge-factor (+ 16
+			 #+ignore
+			 (tk::get-values (sheet-mirror fr)
+					 :spacing)))
+	(sr (copy-space-requirement (compose-space (sheet-child fr)))))
+    (incf (space-requirement-width sr) fudge-factor)
+    (incf (space-requirement-height sr) fudge-factor)
+    ;;--- Is this the correct thing to do???
+    (setf (space-requirement-min-width sr) fudge-factor
+	  (space-requirement-min-height sr) fudge-factor)
+    sr))
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
+						     (parent t)
+						     (sheet openlook-scrolling-window))
+  (values 'xt::scrolled-window nil))
diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp
index 5b4cf3af..c39da7bb 100644
--- a/tk-silica/ol-silica.lisp
+++ b/tk-silica/ol-silica.lisp
@@ -20,17 +20,18 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-silica.lisp,v 1.7 92/03/24 19:37:03 cer Exp Locker: cer $
+;; $fiHeader: ol-silica.lisp,v 1.8 92/04/03 12:04:50 cer Exp $
 
 (in-package :xm-silica)
 
-(defclass openlook-port (xt-port) 
-  ((type :allocation :class 
-	 :initform :openlook :reader port-type)))
+(defclass openlook-port (xt-port) ())
 
 (defmethod find-port-type ((type (eql :openlook)))
   'openlook-port)
 
+(defmethod port-type ((port openlook-port))
+  ':openlook)
+
 (warn "Changing the default server path to ~S"
       (setq *default-server-path* '(:openlook)))
 
@@ -41,3 +42,47 @@
 		 :height 11
 		 :managed t))
 
+(defmethod port-note-cursor-change :after ((port openlook-port)
+					   cursor stream type old new)
+  (declare (ignore old type cursor))
+  (when new 
+    (let ((mirror (sheet-mirror stream)))
+      (when mirror 
+	(let ((window (tk::widget-window mirror)))
+	  (when (eq  (tk::window-map-state window) :viewable)
+	    ;;--- There could very well be a race condition involving
+	    ;;--- a couple of processes.  Another process could have made
+	    ;;--- this window go away at this point
+	    (tk::ol_set_input_focus 
+	     mirror
+	     2				; RevertToParent
+	     0)))))))
+
+(defmethod change-widget-geometry ((parent tk::draw-area) child
+				   &rest args
+				   &key x y width height)
+  (declare (ignore x y width height))
+  (apply #'tk::configure-widget child args))
+
+;;;--- Why have this class
+
+(defclass openlook-geometry-manager (xt-geometry-manager) ())
+
+(defmethod find-shell-class-and-initargs ((port openlook-port) sheet)
+  (declare (ignore port))
+  (cond ( ;;--- hack alert
+	 (popup-frame-p sheet)
+	 (values 'tk::transient-shell
+		 (append
+		  (let ((x (find-shell-of-calling-frame sheet)))
+		    (and x `(:transient-for ,x)))
+		  '(:keyboard-focus-policy :pointer))))
+	(t
+	 (call-next-method))))
+
+(defmethod enable-xt-widget ((parent tk::transient-shell) (mirror t))
+  (manage-child mirror)
+  (popup parent))
+
+(defmethod disable-xt-mirror ((parent xt::transient-shell) (mirror t))
+  (tk::popdown parent))
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index b6f2b5a5..7a0e3007 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.16 92/05/06 15:37:53 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.17 92/05/13 17:11:14 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -44,95 +44,6 @@
       'frame-wm-protocol-callback
       frame)))
 
-;;; Definitions of the individual classes
-
-;; This looks like garbage??
-
-;(defclass motif-main-window (motif-composite-pane)
-;  (
-;   (contents :accessor main-window-contents :initform nil)
-;   (command-window :initform nil :accessor main-window-command-window)
-;   command-window-location
-;   menu-bar
-;   message-window
-;   ))
-;
-;(defmethod initialize-instance :after ((mw motif-main-window)
-;				       &key
-;				       command-window
-;				       command-window-location
-;				       menu-bar
-;				       message-window
-;				       contents)
-;  (when contents
-;    (setf (main-window-contents mw) contents))
-;  (when command-window
-;    (setf (main-window-command-window mw) command-window))
-;  (when message-window
-;    (setf (main-window-message-window mw) message-window)))
-;
-;(defmethod (setf main-window-contents) :after (nv (mw motif-main-window))
-;  (unless (sheet-parent nv)
-;    (sheet-adopt-child mw nv)))
-;
-;(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window))
-;  (unless (sheet-parent nv)
-;    (sheet-adopt-child mw nv)))
-;
-;#+ignore
-;(defmethod realize-mirror :around (port (motif-main-window))
-;  (let ((m (call-next-method)))
-;    (tk::xm_set_main_window_areas
-;     m
-;     .. 
-;     (and command-window (realize-mirror port command-window))
-;     ..
-;     (and message-window (realize-mirror port message-window))
-;     ...)))
-
-;;;; Drawing area
-;
-;#+ignore
-;(defclass motif-drawing-area (motif-composite-pane) ())
-;
-;;;; Row colum
-;
-;(defclass motif-row-colum (motif-composite-pane) ())
-;
-;;;; Push button
-
-;#+ignore
-;(defclass motif-push-button (motif-leaf-pane) ())
-
-;;; Menu bar
-
-;(defclass motif-menu-bar (motif-composite-pane) ())
-;(defclass motif-pulldown-menu (motif-composite-pane) ())
-;
-;(defclass motif-cascade-button (motif-composite-pane)
-;  ((submenu :accessor cascade-button-submenu :initform nil))
-;  )
-;
-;(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button))
-;  (let ((m (call-next-method)))
-;    (when (cascade-button-submenu sheet)
-;      (tk::set-values m :sub-menu-id 
-;		      (realize-mirror port (cascade-button-submenu sheet))))
-;    m))
-
-(defmethod handle-event (sheet (event window-manager-delete-event))
-  (frame-exit *application-frame*))
-
-(defun frame-wm-protocol-callback (widget frame)
-  ;; Invoked when the Wm close function has been selected
-  ;; We want to queue an "event" somewhere so that we can
-  ;; synchronously quit from the frame
-  (distribute-event
-   (port frame)
-   (make-instance 'window-manager-delete-event
-		  :sheet (frame-top-level-sheet frame))))
-
-
 (defclass motif-menu-bar (xt-leaf-pane) 
 	  ((command-table :initarg :command-table)))
 
@@ -279,18 +190,18 @@
     mirror))
 
 (defun display-motif-help (widget port documentation)
-  (port-notify-user 
-   port
+  (frame-manager-notify-user 
+   (find-frame-manager :port port)		;--- frame manager should be passed in
    documentation
    :associated-window widget))
 	     
-(defmethod port-dialog-view ((port motif-port))
+(defmethod frame-manager-dialog-view ((framem motif-frame-manager))
   +gadget-dialog-view+)
   
-;;--- Should "ungray" the command button, if there is one
 ;;--- If the command button is visible, right now since everything is
 ;;--- in a menu we do not have a problem with this.
 
+;;--- Should "ungray" the command button, if there is one
 (defmethod note-command-enabled ((framem motif-frame-manager) frame command)
   (declare (ignore frame command)))
 
@@ -338,3 +249,136 @@
 	    (tk::set-values shell :clip-mask (decode-pixmap clipping-mask))))))))
 
 
+;;;
+
+(defmethod frame-manager-construct-menu 
+	   ((framem motif-frame-manager) 
+	    items 
+	    printer 
+	    presentation-type 
+	    associated-window
+	    default-style
+	    label)
+  (declare (ignore default-style))
+  (let* (value-returned 
+	 return-value
+	 (simplep (and (null printer)
+		       (null presentation-type)))
+	 (port (port framem))
+	 (menu (make-instance 'tk::xm-popup-menu 
+			      :parent (or (and associated-window
+					       (sheet-mirror associated-window))
+					  (port-application-shell port))
+			      :managed nil)))
+    (when label
+      (make-instance 'tk::xm-label
+		     :parent menu
+		     :managed nil
+		     :label-string label)
+      (make-instance 'tk::xm-separator
+		     :managed nil
+		     :separator-type :double-line
+		     :parent menu))
+    (labels ((make-menu-button (item class parent &rest options)
+	       (let ((button
+		      (if simplep
+			  (apply #'make-instance
+				 class 
+				 :sensitive (clim-internals::menu-item-active item)
+				 :parent parent 
+				 :managed nil
+				 :label-string (string (menu-item-display item))
+				 options) 
+			(let* ((pixmap (pixmap-from-menu-item
+					associated-window 
+					item
+					printer
+					presentation-type))
+			       (button
+				(apply #'make-instance
+				       class 
+				       :sensitive (clim-internals::menu-item-active item)
+				       :parent parent 
+				       :label-type :pixmap
+				       :label-pixmap pixmap
+				       options)))
+			  (xt::add-widget-cleanup-function
+			   button
+			   #'tk::destroy-pixmap pixmap)
+			  button))))
+		 (when (clim-internals::menu-item-documentation item)
+		   (tk::add-callback button 
+				 :help-callback 
+				 'display-motif-help
+				 port
+				 (clim-internals::menu-item-documentation item)))
+		 button))
+	     (construct-menu-from-items (menu items)
+	       (map nil #'(lambda (item)
+			    (ecase (clim-internals::menu-item-type item)
+			      (:separator
+			       (make-instance 'tk::xm-separator
+					      :managed nil
+					      :parent menu))
+			      (:label
+				  (make-instance 'tk::xm-label
+						 :parent menu
+						 :managed nil
+						 :label-string (string
+								(menu-item-display item))))
+			      (:item
+			       (if (clim-internals::menu-item-item-list item)
+				   (let* ((submenu (make-instance
+						    'tk::xm-pulldown-menu
+						    :managed nil
+						    :parent menu))
+					  (menu-button
+					   (make-menu-button item 
+							     'tk::xm-cascade-button
+							     menu
+							     :sub-menu-id submenu)))
+				     (declare (ignore menu-button))
+				     (construct-menu-from-items 
+				      submenu 
+				      (clim-internals::menu-item-item-list item)))
+				 (let ((menu-button
+					(make-menu-button item 
+							  'tk::xm-push-button
+							  menu))
+				       (value (menu-item-value item)))
+				   (tk::add-callback
+				    menu-button
+				    :activate-callback
+				    #'(lambda (&rest args)
+					(declare (ignore args))
+					(setq return-value (list value item)
+					      value-returned t))))))))
+		    items)
+	       ;;
+	       (tk::manage-children (tk::widget-children menu))))
+	
+      (construct-menu-from-items menu items))
+    (tk::add-callback (widget-parent menu)
+		      :popdown-callback
+		      #'(lambda (&rest ignore) 
+			  (declare (ignore ignore))
+			  (setq value-returned t)))
+    (values menu
+	    #'(lambda (&optional init)
+		(if init
+		    (setf value-returned nil return-value nil)
+		  (values value-returned return-value))))))
+
+(defmethod framem-enable-menu ((framem motif-frame-manager) menu)
+  (tk::manage-child menu))
+
+(defmethod framem-destroy-menu ((framem motif-frame-manager) menu)
+  (tk::destroy-widget (tk::widget-parent menu)))
+
+(defmethod framem-popdown-menu ((framem motif-frame-manager) menu)
+  ;; Should be already popped down
+  nil)
+
+
+(defmethod framem-menu-active-p ((framem motif-frame-manager) menu)
+  (not (tk::is-managed-p menu)))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 120fc766..5b201a03 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.29 92/05/12 18:25:22 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.30 92/05/13 17:11:16 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -38,7 +38,7 @@
 			 (menu-bar motif-menu-bar)
 			 (viewport xm-viewport)
 			 (radio-box motif-radio-box)
-			 (clim-internals::check-box motif-check-box)
+			 (check-box motif-check-box)
 			 (frame-pane motif-frame-pane)
 			 (top-level-sheet motif-top-level-sheet)
 			 (list-pane motif-list-pane)
@@ -65,7 +65,7 @@
 
 (defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key invoke-callback)
   (declare (ignore invoke-callback))
-  (when (sheet-mirror gadget)
+  (when (sheet-direct-mirror gadget)
     (tk::set-values (sheet-mirror gadget) :value nv)))
 
 (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet)))
@@ -159,7 +159,6 @@
 						     (sheet motif-label-pane))
   (values 'tk::xm-label nil))
 
-
 ;;; Push button
 
 (defclass motif-push-button (push-button
@@ -268,7 +267,6 @@
 		   (value gadget-value)) sheet
     (multiple-value-bind
 	(smin smax) (gadget-range* sheet)
-
       (let ((mmin 0) 
 	    (mmax 100)
 	    (decimal-points 0)
@@ -308,6 +306,7 @@
   (when (sheet-direct-mirror sheet)
     (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv ""))))
 
+
 (defmethod compose-space ((m motif-slider) &key width height)
   (declare (ignore width height))
   (multiple-value-bind
@@ -355,20 +354,16 @@
 (defmethod change-scroll-bar-values ((sb motif-scroll-bar) &key slider-size value)
   (let ((mirror (sheet-direct-mirror sb)))
     (multiple-value-bind
-	(smin smax) (gadget-range* sb)
+	(mmin mmax) (tk::get-values mirror :minimum :maximum)
       (multiple-value-bind
-	  (mmin mmax) (tk::get-values mirror :minimum :maximum)
+	  (real-value real-size) (compute-new-scroll-bar-values sb mmin mmax value slider-size)
 	(tk::set-values
 	 mirror
-	 :slider-size 
-	 (fix-coordinate
-	  (compute-symmetric-value
-		       smin smax slider-size mmin mmax))
-	 :value (fix-coordinate
-		 (compute-symmetric-value
-		  smin smax value mmin mmax)))))))
+	 :slider-size real-size
+	 :value real-value)))))
 
 
+   
 (defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scroll-bar) (widget t))
   (tk::add-callback widget
 		    :value-changed-callback
@@ -376,9 +371,9 @@
 		    sheet))
 
 
-(defun scroll-bar-changed-callback-1 (widget sheet)
+(defmethod scroll-bar-changed-callback-1 ((widget t) (sheet motif-scroll-bar))
   (multiple-value-bind
-      (smin smax) (silica::gadget-range* sheet)
+      (smin smax) (gadget-range* sheet)
     (multiple-value-bind
 	(value size mmin mmax)
 	(tk::get-values widget :value :slider-size :minimum :maximum)
@@ -386,9 +381,9 @@
        sheet
        (gadget-client sheet)
        (gadget-id sheet)
-       (silica::compute-symmetric-value
+       (compute-symmetric-value
 	mmin mmax value smin smax)
-       (silica::compute-symmetric-value
+       (compute-symmetric-value
 	mmin mmax size smin smax)))))
 
 
@@ -635,8 +630,8 @@
 		    sheet))
 
 (defclass motif-radio-box (motif-geometry-manager
-			   motif-oriented-gadget
 			   mirrored-sheet-mixin
+			   motif-oriented-gadget
 			   sheet-multiple-child-mixin
 			   sheet-permanently-enabled-mixin
 			   radio-box
@@ -650,26 +645,28 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-radio-box))
-  
   (values 'tk::xm-radio-box nil))
 
-(defmethod value-changed-callback :after ((v gadget)
-					  (client motif-radio-box)
-					  (id t)
-					  (value t))
+(defmethod value-changed-callback :around ((v gadget)
+					   (client motif-radio-box)
+					   (id t)
+					   (value t))
+  ;; This and the one below have to be around because of the user has
+  ;; specified a callback function only arounds ever get executed.
   (when (eq value t)
     (setf (radio-box-current-selection client) v)
     (value-changed-callback client 
 			    (gadget-client client)
 			    (gadget-id client) 
-			    v)))
+			    v))
+  (call-next-method))
 
 (defclass motif-check-box (motif-geometry-manager
-			   motif-oriented-gadget
 			   mirrored-sheet-mixin
+			   motif-oriented-gadget
 			   sheet-multiple-child-mixin
 			   sheet-permanently-enabled-mixin
-			   silica::check-box
+			   check-box
 			   ask-widget-for-size-mixin
 			   pane)
     ())
@@ -683,18 +680,21 @@
   
   (values 'tk::xm-row-column nil))
 
-(defmethod value-changed-callback :after ((v gadget)
-					  (client motif-check-box)
-					  (id t)
-					  (value t))
+(defmethod value-changed-callback :around ((v gadget)
+					   (client motif-check-box)
+					   (id t)
+					   (value t))
+  ;; This and the one below have to be around because of the user has
+  ;; specified a callback function only arounds ever get executed.
   (if (eq value t)
-      (push v (silica::check-box-current-selection client))
-    (setf (silica::check-box-current-selection client)
-      (delete v (silica::check-box-current-selection client))))
+      (push v (check-box-current-selection client))
+    (setf (check-box-current-selection client)
+      (delete v (check-box-current-selection client))))
   (value-changed-callback client 
 			  (gadget-client client)
 			  (gadget-id client) 
-			  (silica::check-box-current-selection client)))
+			  (check-box-current-selection client))
+  (call-next-method))
 
 ;; Frame-viewport that we need because a sheet can have
 
@@ -784,8 +784,7 @@
   (let ((fudge-factor (+ 16
 			 (tk::get-values (sheet-mirror fr)
 					 :spacing)))
-	(sr (copy-space-requirement (compose-space
-					     (sheet-child fr)))))
+	(sr (copy-space-requirement (compose-space (sheet-child fr)))))
     (incf (space-requirement-width sr) fudge-factor)
     (incf (space-requirement-height sr) fudge-factor)
     ;;--- Is this the correct thing to do???
@@ -922,7 +921,6 @@
   (declare (ignore count))
   (queue-value-changed-event widget sheet value))
 
-
 (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback)
   (declare (ignore invoke-callback)) 
   (set-option-menu-value gadget nv))
@@ -944,22 +942,22 @@
 	  (tk::set-values (tk::intern-widget (tk::xm_option_button_gadget widget))
 			  :label-string (funcall name-key (nth x items))))))))
 
-(defmethod port-notify-user ((port motif-port)
-			     message-string 
-			     &key 
-			     (style :inform)
-			     (frame nil frame-p)
-			     (associated-window
-			      (if frame-p
-				  (frame-top-level-sheet frame)
-				(find-graft :port port)))
-			     (title "Notify user")
-			     documentation
-			     (exit-boxes
-			      '(:exit
-				:abort
-				:help))
-			     (name title))
+(defmethod frame-manager-notify-user ((framem motif-frame-manager)
+				      message-string 
+				      &key 
+				      (style :inform)
+				      (frame nil frame-p)
+				      (associated-window
+					(if frame-p
+					    (frame-top-level-sheet frame)
+					    (graft framem)))
+				      (title "Notify user")
+				      documentation
+				      (exit-boxes
+					'(:exit
+					   :abort
+					   :help))
+				      (name title))
   (let ((dialog (make-instance (ecase style
 				 (:inform 'tk::xm-information-dialog)
 				 (:error 'tk::xm-error-dialog)
@@ -983,8 +981,8 @@
 	       (setq result (list r)))
 	     (display-help (widget ignore)
 	       (declare (ignore widget ignore))
-	       (port-notify-user 
-		port
+	       (frame-manager-notify-user 
+		framem
 		documentation
 		:associated-window associated-window)))
 	(tk::add-callback dialog :ok-callback #'set-it t)
@@ -1010,21 +1008,12 @@
 	    (progn
 	      (tk::manage-child dialog)
 	      (wait-for-callback-invocation
-	       port
+	       (port framem)
 	       #'(lambda () (or result (not (tk::is-managed-p dialog))))
 	       "Waiting for dialog"))
 	  (tk::destroy-widget dialog))
 	(car result)))))
 
-
-(defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback"))
-  (if (eq mp:*current-process* (port-process port))
-      (progn
-	(loop 
-	  (when (funcall predicate) (return nil))
-	  (process-next-event port)))
-    (mp:process-wait whostate predicate)))
-
 (defun get-message-box-child (widget &rest children)
   (values-list
    (mapcar #'(lambda (child)
@@ -1073,23 +1062,20 @@
 
 ;;; File Selection
 
-(defmethod port-select-file ((port motif-port) &rest options 
-			     &key 
-			     (frame nil frame-p)
-			     (associated-window
-			      (if frame-p
-				  (frame-top-level-sheet frame)
-				(find-graft :port port)))
-			     (title "Select File")
-			     documentation
-			     file-search-proc
-			     directory-list-label
-			     file-list-label
-			     (exit-boxes
-			      '(:exit
-				:abort
-				:help))
-			     (name title))
+(defmethod frame-manager-select-file 
+	   ((framem motif-frame-manager) &rest options 
+	    &key (frame nil frame-p)
+		 (associated-window
+		   (if frame-p
+		       (frame-top-level-sheet frame)
+		       (graft framem)))
+		 (title "Select File")
+		 documentation
+		 file-search-proc
+		 directory-list-label
+		 file-list-label
+		 (exit-boxes '(:exit :abort :help))
+		 (name title))
 				  
   (let ((dialog (make-instance 
 		 'tk::xm-file-selection-dialog
@@ -1171,3 +1157,5 @@
   (push (cons :file-search-proc file-search-proc)
 	(tk::widget-callback-data dialog))
   *file-search-proc-callback-address*)
+
+;;;
diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp
index 45a6606e..ddffd18b 100644
--- a/tk-silica/xm-menus.lisp
+++ b/tk-silica/xm-menus.lisp
@@ -18,221 +18,14 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-menus.lisp,v 1.11 92/05/06 15:37:58 cer Exp Locker: cer $
+;; $fiHeader: xm-menus.lisp,v 1.12 92/05/07 13:13:54 cer Exp $
 
 
 (in-package :xm-silica)
 
 
-;;-- This is generic and should be specialized on xt-port
+;;-- This is generic and should be specialized on xt-frame-manager
+
 
-(defmethod port-menu-choose ((port motif-port) items &rest keys
-			     &key printer 
-				  presentation-type 
-				  associated-window
-				  default-style label
-				  cache
-				  (unique-id items)
-				  (id-test 'equal)
-				  (cache-value items)
-				  (cache-test #'equal))
-  (declare (ignore keys))      
-  (declare (values value chosen-item gesture))
-  (let (menu closure)
-    (when cache
-      (let ((x (assoc unique-id
-		      (port-menu-cache port)
-		      :test id-test)))
-	(when x
-	  (destructuring-bind
-	      (menu-cache-value amenu aclosure) x
-	    (if (funcall cache-test cache-value menu-cache-value)
-		(setq menu amenu closure aclosure)
-	      (progn
-		(setf (port-menu-cache port)
-		  (delete x (port-menu-cache port)))
-		(tk::destroy-widget (tk::widget-parent amenu))))))))
-      
-    (unless menu
-      (multiple-value-setq
-	  (menu closure)
-	(port-construct-menu port 
-			     items 
-			     printer 
-			     presentation-type 
-			     associated-window
-			     default-style
-			     label))
-      (when cache
-	(push (list unique-id menu closure) 
-	      (port-menu-cache port))))
-	  
-    ;; initialize the closure
-    (funcall closure t)
-    ;;
-    (multiple-value-bind
-	(ignore win1 win2 x y root-x root-y)
-	(tk::query-pointer (tk::display-root-window
-			    (port-display port)))
-      (declare (ignore ignore win1 win2 x y))
-      (tk::set-values menu :x root-x :y root-y)
-      (loop
-	(when (funcall closure) (return nil))
-	(tk::manage-child menu)
-	;; Now we have to wait
-	(port-force-output port)
-	(wait-for-callback-invocation
-	 port
-	 #'(lambda () 
-	     ;;-- This is to deal
-	     ;;-- with the race
-	     ;;-- condition where
-	     ;;-- the menu go down
-	     ;;-- to quick
-	     (or (funcall closure)
-		 (not (tk::is-managed-p menu)))) 
-	 "Returned value"))
-      (unless cache
-	(tk::destroy-widget (tk::widget-parent menu)))
-      
-      (values-list (nth-value 1 (funcall closure))))))
 
-(defmethod port-construct-menu ((port motif-port) 
-				items 
-				printer 
-				presentation-type 
-				associated-window
-				default-style
-				label)
-  (declare (ignore default-style))
-  (let (value-returned 
-	return-value
-	(simplep (and (null printer)
-		      (null presentation-type)))
-	(menu (make-instance 'tk::xm-popup-menu 
-			     :parent (or (and associated-window
-					      (sheet-mirror associated-window))
-					 (port-application-shell
-					  port))
-			     :managed nil)))
-    (when label
-      (make-instance 'tk::xm-label
-		     :parent menu
-		     :managed nil
-		     :label-string label)
-      (make-instance 'tk::xm-separator
-		     :managed nil
-		     :separator-type :double-line
-		     :parent menu))
-    (labels ((make-menu-button (item class parent &rest options)
-	       (let ((button
-		      (if simplep
-			  (apply #'make-instance
-				 class 
-				 :sensitive (clim-internals::menu-item-active item)
-				 :parent parent 
-				 :managed nil
-				 :label-string (string (menu-item-display item))
-				 options) 
-			(let* ((pixmap (pixmap-from-menu-item
-					associated-window 
-					item
-					printer
-					presentation-type))
-			       (button
-				(apply #'make-instance
-				       class 
-				       :sensitive (clim-internals::menu-item-active item)
-				       :parent parent 
-				       :label-type :pixmap
-				       :label-pixmap pixmap
-				       options)))
-			  (xt::add-widget-cleanup-function
-			   button
-			   #'tk::destroy-pixmap pixmap)
-			  button))))
-		 (when (clim-internals::menu-item-documentation item)
-		   (tk::add-callback button 
-				 :help-callback 
-				 'display-motif-help
-				 port
-				 (clim-internals::menu-item-documentation item)))
-		 button))
-	     (construct-menu-from-items (menu items)
-	       (map nil #'(lambda (item)
-			    (ecase (clim-internals::menu-item-type item)
-			      (:separator
-			       (make-instance 'tk::xm-separator
-					      :managed nil
-					      :parent menu))
-			      (:label
-				  (make-instance 'tk::xm-label
-						 :parent menu
-						 :managed nil
-						 :label-string (string
-								(menu-item-display item))))
-			      (:item
-			       (if (clim-internals::menu-item-item-list item)
-				   (let* ((submenu (make-instance
-						    'tk::xm-pulldown-menu
-						    :managed nil
-						    :parent menu))
-					  (menu-button
-					   (make-menu-button item 
-							     'tk::xm-cascade-button
-							     menu
-							     :sub-menu-id submenu)))
-				     (declare (ignore menu-button))
-				     (construct-menu-from-items 
-				      submenu 
-				      (clim-internals::menu-item-item-list item)))
-				 (let ((menu-button
-					(make-menu-button item 
-							  'tk::xm-push-button
-							  menu))
-				       (value (menu-item-value item)))
-				   (tk::add-callback
-				    menu-button
-				    :activate-callback
-				    #'(lambda (&rest args)
-					(declare (ignore args))
-					(setq return-value (list value item)
-					      value-returned t))))))))
-		    items)
-	       ;;
-	       (tk::manage-children (tk::widget-children menu))))
-	
-      (construct-menu-from-items menu items))
-    (tk::add-callback (widget-parent menu)
-		      :popdown-callback
-		      #'(lambda (&rest ignore) 
-			  (declare (ignore ignore))
-			  (setq value-returned t)))
-    (values menu
-	    #'(lambda (&optional init)
-		(if init
-		    (setf value-returned nil return-value nil)
-		  (values value-returned return-value))))))
-		
-(defun pixmap-from-menu-item (associated-window menu-item printer presentation-type)
-  (with-menu (menu associated-window)
-    (setf (stream-text-margin menu) 1000)
-    (let ((rec (with-output-recording-options (menu :draw nil :record t)
-		 (with-output-to-output-record (menu)
-		   (handler-case
-		       (if presentation-type
-			   (present menu-item presentation-type :stream menu)
-			 (funcall printer menu-item menu))
-		     (error (c)
-		       (write-string "Error in printer" menu)))))))
-      (multiple-value-bind
-	  (width height)
-	  (bounding-rectangle-size rec)
-	(with-output-to-pixmap (s associated-window :width width :height height)
-	  (multiple-value-call #'draw-rectangle* 
-	    s 0 0 (bounding-rectangle-size s) :ink +background-ink+)
-	  (replay-output-record 
-	    rec s +everywhere+
-	    (- (bounding-rectangle-min-x rec))
-	    (- (bounding-rectangle-min-y rec))))))))
   
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index a6bba1a2..7892c0f6 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,19 +18,19 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.17 92/04/30 09:09:53 cer Exp Locker: cer $
+;; $fiHeader: xm-silica.lisp,v 1.18 92/05/13 17:11:20 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
 ;; Motif specific stuff
 
-(defclass motif-port (xt-port) 
-  ((type :allocation :class 
-	 :initform :motif :reader port-type)))
+(defclass motif-port (xt-port) ())
 
 (defmethod find-port-type ((type (eql ':motif)))
   'motif-port)
 
+(defmethod port-type ((port motif-port))
+  ':motif)
 
 (defmethod change-widget-geometry ((parent tk::xm-my-drawing-area) child
 				   &rest args
@@ -51,40 +51,9 @@
   ;;-- shells decide where windows are positioned!
   (tk::set-values child :width width :height height))
 
-(defclass motif-geometry-manager ()
-	  ;; --- This is probably all
-	  ;; composites excepts drawing-area and shell
-	  ()
-  (:documentation "These are all parents that have strong feelings
-about their children"))
+(defclass motif-geometry-manager (xt-geometry-manager) ())
 
 
-(defmethod update-mirror-transformation-1 ((port port) sheet 
-					   (parent motif-geometry-manager))
-  nil)
-
-(defmethod update-mirror-region-1 ((port port) sheet 
-				   (parent motif-geometry-manager))
-  nil)
-	    
-
-(defmethod update-mirror-transformation-1 :after ((port port)
-						  (sheet motif-geometry-manager)
-						  (parent t))
-  (update-geo-manager-sheet-children sheet))
-
-
-(defmethod update-mirror-region-1 :after ((port port)
-					  (sheet motif-geometry-manager)
-					  (parent t))
-  (update-geo-manager-sheet-children sheet))
-
-(defmethod update-geo-manager-sheet-children (geo-manager)
-  (dolist (child (sheet-children geo-manager))
-    ;;--- Yuck!
-    (when (typep child 'mirrored-sheet-mixin)
-      (mirror-region-updated (port geo-manager) child))))
-
 (defmethod find-shell-class-and-initargs ((port motif-port) sheet)
   (declare (ignore port))
   (cond ( ;;--- hack alert
@@ -112,3 +81,10 @@ about their children"))
 ;  (declare (ignore old type cursor))
 ;  (when new
 ;    (xmprocesstraversal (sheet-mirror stream) 0)))
+
+(defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t))
+  ;; this is a nasty hack just to make sure that the child is managed.
+  ;; top-level-sheets are created unmanaged because they are
+  ;; disabled to we have to do not!
+  (manage-child mirror)
+  (popup (widget-parent mirror)))
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 4ee2af97..990cef2c 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.9 92/04/21 16:13:34 cer Exp Locker: cer $
+;; $fiHeader: xt-frames.lisp,v 1.10 92/05/07 13:13:56 cer Exp $
 
 
 (in-package :xm-silica)
@@ -28,7 +28,10 @@
 ;; Basic intrinsics frame-manager
 
 (defclass xt-frame-manager (standard-frame-manager) 
-    ())
+    ((menu-cache
+       :initform nil
+       :accessor frame-manager-menu-cache)
+     ))
 
 (defmethod frame-wrapper ((framem xt-frame-manager) 
 			  (frame standard-application-frame) pane)
@@ -88,3 +91,126 @@
 		   :value (second item))))
 
 
+(defun frame-wm-protocol-callback (widget frame)
+  ;; Invoked when the Wm close function has been selected
+  ;; We want to queue an "event" somewhere so that we can
+  ;; synchronously quit from the frame
+  (distribute-event
+   (port frame)
+   (make-instance 'window-manager-delete-event
+		  :sheet (frame-top-level-sheet frame))))
+
+(defmethod handle-event (sheet (event window-manager-delete-event))
+  (frame-exit *application-frame*))
+
+;;; Menu code
+
+(defmethod frame-manager-menu-choose
+	   ((framem xt-frame-manager) items &rest keys
+	    &key printer 
+		 presentation-type 
+		 (associated-window (frame-top-level-sheet *application-frame*))
+		 default-style label
+		 cache
+		 (unique-id items)
+		 (id-test 'equal)
+		 (cache-value items)
+		 (cache-test #'equal))
+  (declare (ignore keys))      
+  (declare (values value chosen-item gesture))
+  (let ((port (port framem))
+	menu closure)
+    (when cache
+      (let ((x (assoc unique-id
+		      (frame-manager-menu-cache framem)
+		      :test id-test)))
+	(when x
+	  (destructuring-bind
+	      (menu-cache-value amenu aclosure) x
+	    (if (funcall cache-test cache-value menu-cache-value)
+		(setq menu amenu closure aclosure)
+	      (progn
+		(setf (frame-manager-menu-cache framem)
+		  (delete x (frame-manager-menu-cache framem)))
+		(tk::destroy-widget (tk::widget-parent amenu))))))))
+      
+    (unless menu
+      (multiple-value-setq
+	  (menu closure)
+	(frame-manager-construct-menu framem 
+				      items 
+				      printer 
+				      presentation-type 
+				      associated-window
+				      default-style
+				      label))
+      (when cache
+	(push (list unique-id menu closure) 
+	      (frame-manager-menu-cache framem))))
+	  
+    ;; initialize the closure
+    (funcall closure t)
+    ;;
+    (multiple-value-bind
+	(ignore win1 win2 x y root-x root-y)
+	(tk::query-pointer (tk::display-root-window
+			    (port-display port)))
+      (declare (ignore ignore win1 win2 x y))
+      (tk::set-values menu :x root-x :y root-y)
+      (loop
+	(when (funcall closure) (return nil))
+	(framem-enable-menu framem menu)
+	;; Now we have to wait
+	(port-force-output port)
+	(wait-for-callback-invocation
+	 port
+	 #'(lambda () 
+	     ;;-- This is to deal
+	     ;;-- with the race
+	     ;;-- condition where
+	     ;;-- the menu go down
+	     ;;-- to quick
+	     (or (funcall closure)
+		 (not (framem-menu-active-p framem menu)))) 
+	 "Returned value"))
+
+      (framem-popdown-menu framem menu)
+      
+      (unless cache
+	(framem-destroy-menu framem menu))
+      
+      (values-list (nth-value 1 (funcall closure))))))
+
+
+(defun pixmap-from-menu-item (associated-window menu-item printer presentation-type)
+  (with-menu (menu associated-window)
+    (setf (stream-text-margin menu) 1000)
+    (let ((rec (with-output-recording-options (menu :draw nil :record t)
+		 (with-output-to-output-record (menu)
+		   (handler-case
+		       (if presentation-type
+			   (present menu-item presentation-type :stream menu)
+			 (funcall printer menu-item menu))
+		     (error (c)
+		       (write-string "Error in printer" menu)))))))
+      (multiple-value-bind
+	  (width height)
+	  (bounding-rectangle-size rec)
+	(with-output-to-pixmap (s associated-window :width width :height height)
+	  (multiple-value-call #'draw-rectangle* 
+	    s 0 0 (bounding-rectangle-size s) :ink +background-ink+)
+	  (replay-output-record 
+	    rec s +everywhere+
+	    (- (bounding-rectangle-min-x rec))
+	    (- (bounding-rectangle-min-y rec))))))))
+
+
+;;;
+
+(defmethod clim-internals::frame-manager-exit-box-labels ((frame t) (framem xt-frame-manager))
+  '(
+    (:exit  "Ok")
+    (:abort  "Cancel")))
+
+(defmethod clim-internals::frame-manager-default-exit-boxes ((framem xt-frame-manager))
+  '((:exit) (:abort)))
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index bf362ccf..13cc880a 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-gadgets.lisp,v 1.12 92/05/07 13:13:57 cer Exp Locker: cer $
+;; $fiHeader: xt-gadgets.lisp,v 1.13 92/05/12 18:25:28 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -136,7 +136,27 @@
 
 ;;--- This isn't really right.  Genera and CLX ports have kludges
 ;;--- for the time being, too.
+
 (defmethod sheet-shell (sheet)
   (do ((w (sheet-mirror sheet) (tk::widget-parent w)))
       ((typep w '(or tk::shell null))
        w)))
+
+(defun compute-new-scroll-bar-values (scroll-bar mmin mmax value slider-size)
+  (multiple-value-bind
+      (smin smax) (gadget-range* scroll-bar)
+    (values 
+     (fix-coordinate
+      (compute-symmetric-value
+       smin smax value mmin mmax))
+     (fix-coordinate
+      (compute-symmetric-value
+       smin smax slider-size mmin mmax)))))
+
+(defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback"))
+  (if (eq mp:*current-process* (port-process port))
+      (progn
+	(loop 
+	  (when (funcall predicate) (return nil))
+	  (process-next-event port)))
+    (mp:process-wait whostate predicate)))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 67169a47..fda8cdff 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.21 92/05/13 17:11:23 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.22 92/05/14 11:04:02 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -260,7 +260,7 @@
 
 (defmethod decode-ink ((ink color) (medium xt-medium))
   (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable
-			 color-p ink-table)
+			 color-p)
       medium
     (or (gethash ink ink-table)
 	(let ((drawable (or drawable
@@ -271,7 +271,6 @@
 		   (decode-color medium ink)))
 		(t
 		 (multiple-value-bind (r g b) (color-rgb ink)
-		   ;; The luminance formula isn't really right.  XXX
 		   (let* ((luminance (color-luminosity r g b))
 			  (color (decode-luminance luminance t)))
 		     (cond ((eq color 1)
@@ -317,7 +316,7 @@ and on color servers, unless using white or black")
 		  (tk::gcontext-fill-style new-gc) :stippled)
 	    (setf (gethash key ink-table) new-gc))))))
   
-
+ 
 (defmethod decode-ink ((ink contrasting-ink) stream)
   (decode-ink (make-color-for-contrasting-ink ink) stream))
 
@@ -957,34 +956,6 @@ and on color servers, unless using white or black")
 		 to-left to-top))
 
 
-
-;;--- Is this used any more?
-(defmethod port-write-string-1 ((port xt-port) medium
-				glyph-buffer start end 
-				x-font color x y)
-  (break "is this used anymore")
-  (unless (= start end)
-    (let* ((sheet (medium-sheet medium))
-	   (transform (sheet-device-transformation sheet))
-	   (window (medium-drawable medium))
-	   (font x-font))
-      ;; At one point we checked to see whether the widget is unrealized
-      ;; or not.  Can we draw on disabled sheets?
-      (convert-to-device-coordinates transform x y)
-      (incf y (tk::font-ascent font))
-      (when (medium-drawable medium)
-	(let ((gc (decode-ink (medium-ink medium) medium)))
-	  (setf (tk::gcontext-font gc) font)
-	  (etypecase glyph-buffer
-	    ((simple-array (unsigned-byte 16))
-	     (x11::xdrawstring16
-	       (tk::object-display window)
-	       window
-	       gc
-	       x y
-	       glyph-buffer (- end start)))))))))
-
-
 (defmethod port-beep ((port xt-port) (sheet t))
   (x11:xbell (port-display port) 100))
 
@@ -1042,4 +1013,4 @@ and on color servers, unless using white or black")
 				    to-drawable seq-no '(:graphics-expose) 
 				    :block nil))
 		       (unless event
-			 (return))))))))))))))
+ 			 (return))))))))))))))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index b80bc42a..faeee8bc 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.26 92/05/12 18:25:31 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.27 92/05/13 17:11:24 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -30,17 +30,15 @@
      (context :reader port-context)     
      (copy-gc :initform nil)
      (opacities :initform nil)
-     (type :allocation :class 
-	   :initform :xt :reader port-type)
      (event-lock :initform (clim-sys:make-lock "port event lock")
 		 :reader port-event-lock)
-     (menu-cache
-      :initform nil
-      :accessor port-menu-cache)
      (rotated-font-cache :initform nil :accessor port-rotated-font-cache))
   (:default-initargs :allow-loose-text-style-size-mapping t)
   (:documentation "The port for X intrinsics based ports"))
 
+(defmethod port-type ((port xt-port))
+  ':xt)
+
 (defmethod port-copy-gc ((port xt-port))
   (with-slots (copy-gc display) port
     (or copy-gc
@@ -49,7 +47,7 @@
 	    :display display
 	    :graphics-exposures :on
 	    :foreign-address (x11:screen-default-gc
-			      (x11:xdefaultscreenofdisplay display)))))))
+ 			      (x11:xdefaultscreenofdisplay display)))))))
 
 
 
@@ -78,14 +76,21 @@
        ,@body)))
        
 (defmethod initialize-instance :after ((port xt-port) &key server-path)
-  (destructure-x-server-path (:display display) server-path
-    (declare (ignore ignore))
-    (multiple-value-bind (context display application-shell)
-	(initialize-motif-toolkit display)
-      (setf (slot-value port 'application-shell) application-shell
-	    (slot-value port 'context) context
-	    (slot-value port 'display) display)
-      (initialize-xlib-port port display))))
+  (destructuring-bind
+      (&key (display nil display-p)
+	    (application-name nil application-name-p)
+	    (application-class nil application-class-p))
+      (cdr server-path)
+    (let ((args nil))
+      (when display-p (setf (getf args :host) display))
+      (when application-name-p (setf (getf args :application-name) application-name))
+      (when application-class-p (setf (getf args :application-class) application-class))
+      (multiple-value-bind (context display application-shell)
+	  (apply #'tk::initialize-toolkit args)
+	(setf (slot-value port 'application-shell) application-shell
+	      (slot-value port 'context) context
+	      (slot-value port 'display) display)
+	(initialize-xlib-port port display)))))
 
 (defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
 			     (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*")
@@ -565,29 +570,27 @@
 				  ,@initargs))))
 
 (defmethod enable-mirror ((port xt-port) sheet)
-  (declare (ignore port))
   (let ((mirror (sheet-mirror sheet)))
-    (typecase (widget-parent mirror)
-      (null)
-      ((or top-level-shell tk::xm-dialog-shell)
-	;; this is a nasty hack just to make sure that the child is managed.
-	;; top-level-sheets are created unmanaged because they are
-	;; disabled to we have to do not!
-	(manage-child mirror)
-	(popup (widget-parent mirror)))
-      (t
-	(manage-child mirror)))))
+    (enable-xt-widget (widget-parent mirror) mirror)))
+
+(defmethod enable-xt-widget ((parent t) (mirror t))
+  (manage-child mirror))
+
+(defmethod enable-xt-widget ((parent top-level-shell) (mirror t))
+  (manage-child mirror)
+  (popup (widget-parent mirror)))
 
 (defmethod disable-mirror ((port xt-port) sheet)
   (declare (ignore port))
   (let ((mirror (sheet-mirror sheet)))
     (when mirror
-      (typecase (widget-parent mirror)
-	(null)
-	(top-level-shell
-	  (tk::popdown (widget-parent mirror)))
-	(t
-	  (tk::unmanage-child mirror))))))
+      (disable-xt-mirror (widget-parent mirror) mirror))))
+
+(defmethod disable-xt-mirror ((parent t) (mirror t))
+  (tk::unmanage-child mirror))
+
+(defmethod disable-xt-mirror ((parent top-level-shell) (mirror t))
+  (tk::popdown parent))
 
 (defmethod realize-graft ((port xt-port) graft)
   ;; Set the width etc etc
@@ -606,14 +609,13 @@
 	    silica::pixels-per-point (float (/ silica::pixel-width
 					       (* 72 (/ silica::mm-width 25.4)))))
       ;;--- Mess with the region
-      (warn "Do something about the graft")
       (setf (sheet-region graft)
 	(ecase (graft-units graft)
 	  ((:device :pixel)
 	   (make-bounding-rectangle 0 0
 				    silica::pixel-width silica::pixel-height))))
       ;;-- what about the transformation
-      )))
+      (setf (sheet-native-transformation graft) +identity-transformation+))))
 
 (defmethod mirror-region* ((port xt-port) sheet)
   (when (sheet-mirror sheet)
@@ -699,9 +701,7 @@
 				:timeout timeout))
 	  (tk::process-one-event context mask reason))))))
 
-(defmethod port-force-output ((port xt-port))
-  ;;--- move to tk
-  (x11::xflush (port-display port)))
+
 
 (defmethod port-glyph-for-character ((port xt-port)
 				     character text-style 
@@ -994,6 +994,10 @@
 				   (pane clim-internals::output-protocol-mixin))
   (default-from-mirror-resources port pane))
 
+(defmethod engraft-medium :before ((medium t) (port xt-port) (pane viewport))
+  (default-from-mirror-resources port pane))
+
+
 ;;-- What do we do about pixmap streams. I guess they should inherit
 ;;-- properties from the parent.
 
@@ -1007,29 +1011,30 @@
   (unless (and (medium-foreground pane)
 	       (medium-background pane))
     (let* ((w (sheet-mirror pane))
-	   (dap (typep w 'tk::xm-drawing-area)))
-
-      ;;-- What about the case when there is a pixmap
-      (multiple-value-bind
-	  (foreground background)
-	  (if dap
-	      (tk::get-values w :foreground :background)
-	    (values nil (tk::get-values w :background)))
-	;; Now we have to convert into CLIM colors.
-	(flet ((ccm (x)
-		 (multiple-value-bind
-		     (r g b)
-		     (tk::query-color (tk::default-colormap (port-display port)) x)
-		   (let ((x #.(1- (ash 1 16))))
-		     (make-rgb-color 
-		      (/ r x)
-		      (/ g x)
-		      (/ b x))))))
-	  (when foreground
-	    (unless (medium-foreground pane)
-	      (setf (medium-foreground pane) (ccm foreground))))
-	  (unless (medium-background pane)
-	    (setf (medium-background pane) (ccm background))))))))
+	   (shellp (typep w 'tk::shell)))
+      ;;; Make sure we dont have a pixmp
+      (when (typep w 'xt::xt-root-class)
+	;;-- What about the case when there is a pixmap
+	(multiple-value-bind
+	    (foreground background)
+	    (if shellp
+		(values nil (tk::get-values w :background))
+	      (tk::get-values w :foreground :background))
+	  ;; Now we have to convert into CLIM colors.
+	  (flet ((ccm (x)
+		   (multiple-value-bind
+		       (r g b)
+		       (tk::query-color (tk::default-colormap (port-display port)) x)
+		     (let ((x #.(1- (ash 1 16))))
+		       (make-rgb-color 
+			(/ r x)
+			(/ g x)
+			(/ b x))))))
+	    (when foreground
+	      (unless (medium-foreground pane)
+		(setf (medium-foreground pane) (ccm foreground))))
+	    (unless (medium-background pane)
+	      (setf (medium-background pane) (ccm background)))))))))
 
 ;;;--- Gadget activation deactivate
 
@@ -1040,5 +1045,44 @@
     widget))
 
 
+(defmethod port-force-output ((port xt-port))
+  (x11:xflush (port-display port)))
+
+
+
+;;;
+
+
+(defclass xt-geometry-manager ()
+	  ;; --- This is probably all
+	  ;; composites excepts drawing-area and shell
+	  ()
+  (:documentation "These are all parents that have strong feelings
+about their children"))
+
+
+(defmethod update-mirror-transformation-1 ((port port) sheet 
+					   (parent xt-geometry-manager))
+  nil)
+
+(defmethod update-mirror-region-1 ((port port) sheet 
+				   (parent xt-geometry-manager))
+  nil)
+	    
+
+(defmethod update-mirror-transformation-1 :after ((port port)
+						  (sheet xt-geometry-manager)
+						  (parent t))
+  (update-geo-manager-sheet-children sheet))
+
 
+(defmethod update-mirror-region-1 :after ((port port)
+					  (sheet xt-geometry-manager)
+					  (parent t))
+  (update-geo-manager-sheet-children sheet))
 
+(defmethod update-geo-manager-sheet-children (geo-manager)
+  (dolist (child (sheet-children geo-manager))
+    ;;--- Yuck!
+    (when (typep child 'mirrored-sheet-mixin)
+      (mirror-region-updated (port geo-manager) child))))
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index 72ca6a18..80c14fde 100644
--- a/tk/callbacks.lisp
+++ b/tk/callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: callbacks.lisp,v 1.12 92/05/07 13:10:47 cer Exp Locker: cer $
+;; $fiHeader: callbacks.lisp,v 1.13 92/05/13 17:10:11 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -122,6 +122,7 @@
 	    ;; OpenLook Callbacks
 	    ("sliderMoved" slider-moved)
 	    ("select")
+	    ("unselect")
 	    )))
 
 (defun convert-callback-name (x)
diff --git a/tk/event.lisp b/tk/event.lisp
index a66e382a..0c13a2c3 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -1,4 +1,4 @@
-;; -*- mode: common-lisp; package: tk -*-
+ ;; -*- mode: common-lisp; package: tk -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.8 92/04/15 11:44:40 cer Exp Locker: cer $
+;; $fiHeader: event.lisp,v 1.9 92/04/21 20:27:28 cer Exp $
 
 (in-package :tk)
 
@@ -84,7 +84,6 @@
 	1
       0)))
 
-
 (defparameter *match-event-sequence-and-types-address*
     (register-function 'match-event-sequence-and-types))
 
diff --git a/tk/font.lisp b/tk/font.lisp
index 4b830eb9..5d92d415 100644
--- a/tk/font.lisp
+++ b/tk/font.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: font.lisp,v 1.10 92/04/21 20:27:29 cer Exp Locker: cer $
+;; $fiHeader: font.lisp,v 1.11 92/04/28 09:25:00 cer Exp $
 
 (in-package :tk)
 
@@ -50,12 +50,11 @@
 
 (defmethod font-width (font)
   (x11::xfontstruct-max-bounds-width font))
-
+ 
 (defmethod font-height (font)
   (+ (font-ascent font)
      (font-descent font)))
 
- 
 (defmethod font-ascent (font)
   (x11:xfontstruct-ascent font))
 
diff --git a/tk/foreign.lisp b/tk/foreign.lisp
index f8e0a867..92d77173 100644
--- a/tk/foreign.lisp
+++ b/tk/foreign.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign.lisp,v 1.10 92/04/21 20:27:30 cer Exp $
+;; $fiHeader: foreign.lisp,v 1.11 92/05/13 17:10:13 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -54,23 +54,21 @@
 
 (defun open-display (&key (context (create-application-context))
 			  (host nil)
-			  (name "clim")
-			  (class "Clim")
+			  (application-name "clim")
+			  (application-class "Clim")
 			  (options 0)
 			  (num-options 0)
 			  (argc 0)
 			  (argv 0))
   (let ((d (with-ref-par ((argc argc))
 	     (xt_open_display context
-			   (if host 
-			       host
-			     0)
-			   name
-			   class
-			   options 
-			   num-options
-			   argc
-			   argv))))
+			      (or host 0)
+			      application-name
+			      application-class
+			      options 
+			      num-options
+			      argc
+			      argv))))
     (if (zerop d)
 	(error "cannot open the display: ~A" host)
       d)))
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 11e1ad82..0d9d30c3 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.14 92/05/12 18:24:17 cer Exp Locker: cer $
+;; $fiHeader: gcontext.lisp,v 1.15 92/05/13 17:10:17 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -51,7 +51,6 @@
 	(dash-offset :int)
 	(dashes :char)))
 
-
   (defconstant *gcontext-bit-mask*
       '(function plane-mask foreground background
 	line-width line-style cap-style join-style fill-style
@@ -60,6 +59,7 @@
 	arc-mode)))
 
 
+
 (eval-when (compile eval)
   #+ignore
   (defun gcontext-component-to-slot-definition (x)
@@ -177,7 +177,6 @@
   (intern (substitute #\_ #\- (symbol-name (lispify-tk-name name)))))
 
 
-
 ;;; Accessors for the gc
 
 (define-gc-accessor function (encode-function decode-function))
@@ -262,11 +261,11 @@
 
 (define-gc-accessor subwindow-mode (encode-enum decode-enum)
 		  '(:clip-by-children :include-inferiors))
-
 (define-gc-accessor graphics-exposures (encode-enum decode-enum) '(:off :on))
 (define-gc-accessor clip-x-origin (encode-int16 decode-int16))
 (define-gc-accessor clip-y-origin (encode-int16 decode-int16))
 
+
 (define-gc-accessor dash-offset (encode-card16 decode-card16))
 (define-gc-accessor arc-mode (encode-enum decode-enum)  '(:chord :pie-slice))
 
@@ -314,7 +313,6 @@
    gc
    nv))
 
-
 (defmethod (setf gcontext-clip-mask) ((nv cons) (gc gcontext))
   (let ((r (x11:make-xrectangle)))
     (setf (x11:xrectangle-x r) (first nv)
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index 89c12f44..5973ba89 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -20,12 +20,12 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-ol.lisp,v 1.8 92/04/03 12:03:58 cer Exp $
+;; $fiHeader: load-ol.lisp,v 1.9 92/05/07 13:10:50 cer Exp Locker: cer $
 
 (in-package :tk)
 
-(defvar *libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a")
-(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
+(defvar sys::*libxol-pathname* "/vapor/usr/tech/cer/stuff/clim-2.0/tk/lib2/libXol.a")
+(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
 
 (defun load-from-ol ()
   (x11::load-undefined-symbols-from-library
@@ -45,9 +45,9 @@
      "_class_extended"
      "__unpack_integer"
      )
-   (list *libxol-pathname*
-	 *libxt-pathname*
-	 x11::*libx11-pathname*)))
+   (list sys::*libxol-pathname*
+	 sys::*libxt-pathname*
+	 sys::*libx11-pathname*)))
 
 (load-from-ol)
 
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index bdab8e7d..b77b098c 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -20,22 +20,23 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.11 92/05/07 13:10:51 cer Exp Locker: cer $
+;; $fiHeader: load-xm.lisp,v 1.12 92/05/13 17:10:19 cer Exp Locker: cer $
 
 (in-package :tk)
 
 
 
 ;;;; 
-(defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
-(defvar *libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a")
-(defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
+
+(defvar sys::*libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
+(defvar sys::*libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a")
 
 (defun load-from-xm ()
   (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea"))
     (load "MyDrawingA.o"
-	  :system-libraries (list *libxm-pathname* *libxt-pathname*
-				  x11::*libx11-pathname*)
+	  :system-libraries (list sys::*libxm-pathname* 
+				  sys::*libxt-pathname*
+				  sys::*libx11-pathname*)
 	  :print t))
   (x11::load-undefined-symbols-from-library
    "stub-motif.o"
@@ -53,9 +54,9 @@
       "_class_extended"
       "__unpack_integer"
       )
-    (list *libxm-pathname*
-	  *libxt-pathname*
-	  x11::*libx11-pathname*)))
+    (list sys::*libxm-pathname*
+	  sys::*libxt-pathname*
+	  sys::*libx11-pathname*)))
 
 (load-from-xm)
 
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index d9660d49..840730d4 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.16 92/05/07 13:10:52 cer Exp Locker: cer $
+;; $fiHeader: make-classes.lisp,v 1.17 92/05/13 17:10:22 cer Exp Locker: cer $
 
 (in-package :tk)
 
diff --git a/tk/ol-callbacks.lisp b/tk/ol-callbacks.lisp
index 05e867dc..ad73f4ab 100644
--- a/tk/ol-callbacks.lisp
+++ b/tk/ol-callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-callbacks.lisp,v 1.5 92/03/09 17:40:50 cer Exp $
+;; $fiHeader: ol-callbacks.lisp,v 1.6 92/04/21 20:27:35 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -57,3 +57,18 @@
 (defmethod spread-callback-data (widget data (type (eql 'slider-moved)))
   (values))
 
+
+(defun add-ol-callback (widget name type function &rest args)
+  (ol_add_callback widget name *callback-handler-address*
+		   (caar (push
+			  (list (new-callback-id) (cons function args) type)
+			  (widget-callback-data widget)))))
+
+
+(defmethod spread-callback-data ((widget shell) data (type (eql :wm-protocol)))
+  ;;; I dunno why this works but it does
+  (ecase (logand 15 (ol-wm-protocol-verify-message-type data))
+	    (1 :wm-delete-window)	; 80000001
+	    (2 :wm-save-yourself)	; 80000002
+	    (4 :wm-take-focus)		; 80000004
+	    ))
diff --git a/tk/ol-defs.lisp b/tk/ol-defs.lisp
index edbd5247..12ca3bf4 100644
--- a/tk/ol-defs.lisp
+++ b/tk/ol-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-defs.lisp,v 1.1 92/04/21 16:40:05 cer Exp Locker: cer $
+;; $fiHeader: ol-defs.lisp,v 1.2 92/04/21 20:27:36 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -43,3 +43,6 @@
 	    (width xt-dimension)
 	    (height xt-dimension))
 
+(def-c-type (ol-wm-protocol-verify :no-defuns) :struct
+	    (message-type :int)
+	    (event * x11:xevent))
diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp
index 038ae3dd..8a279ce8 100644
--- a/tk/ol-funs.lisp
+++ b/tk/ol-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-funs.lisp,v 1.1 92/04/21 16:40:06 cer Exp Locker: cer $
+;; $fiHeader: ol-funs.lisp,v 1.2 92/04/21 20:27:37 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -42,3 +42,9 @@
 (defforeign 'ol_set_va_display_warning_msg_handler
     :entry-point "_OlSetVaDisplayWarningMsgHandler")
 
+(defforeign 'ol_add_callback :entry-point "_OlAddCallback")
+
+(defforeign 'ol_set_input_focus :entry-point "_OlSetInputFocus")
+
+(defforeign 'ol_menu_post :entry-point "_OlMenuPost")
+(defforeign 'ol_menu_popdown :entry-point "_OlMenuPopdown")
diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp
index 0730f80f..04648db7 100644
--- a/tk/ol-init.lisp
+++ b/tk/ol-init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-init.lisp,v 1.11 92/04/21 20:27:38 cer Exp Locker: cer $
+;; $fiHeader: ol-init.lisp,v 1.12 92/05/07 13:10:58 cer Exp Locker: cer $
 
 
 (in-package :tk)
@@ -69,6 +69,7 @@
 (defvar *ol-done* nil)
 
 (unless *ol-done*
+  (compile-file "test/test")
   (ol-initialize)
   (xt-initialize)
   (define-toolkit-classes 
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 259acd0d..c4d89de4 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.20 92/05/07 13:10:59 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.21 92/05/13 17:10:25 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -606,3 +606,11 @@
     ;;-- Should check to see if its registered
     (integer value)))
 
+
+;;;--- Dont ask this is what OLIT sez the label-image of a oblong
+;;;--- button is. I know why! its because its a f*cking image (rather
+;;;--- than a pixmap
+
+(defmethod convert-resource-out ((parent t) (typep (eql 'pointer)) value)
+  value)
+				 
diff --git a/tk/widget.lisp b/tk/widget.lisp
index f7a26e83..4f264103 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: widget.lisp,v 1.18 92/04/21 20:27:42 cer Exp $
+;; $fiHeader: widget.lisp,v 1.19 92/05/13 17:10:27 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -89,9 +89,7 @@
   (xt_destroy_widget widget))
 
 (defun popup (shell)
-       (xt_popup shell
-	       0))
-
+       (xt_popup shell 0))
 
 (defun popdown (shell)
        (xt_popdown shell))
@@ -248,15 +246,12 @@
 
 ;; Could not think of anywhere better!
 
-(defun setup (&optional (hostspec "localhost:0"))
+(defun initialize-toolkit (&rest args)
   (let* ((context (create-application-context))
-	 (display (make-instance 'display 
-		    :host hostspec
-		    :context context))
+	 (display (apply #'make-instance 'display 
+			 :context context
+			 args))
 	 (app (app-create-shell :display display
 				:widget-class 'application-shell)))
     (values context display app)))
 
-(defun initialize-motif-toolkit (hostspec)
-  (setup hostspec))
-
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 9cb872e6..18047c8a 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.16 92/04/21 20:27:43 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.17 92/05/13 17:10:28 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -121,6 +121,18 @@
 			      attrs)
     (x11:xwindowattributes-depth attrs)))
 
+
+(defmethod window-map-state ((window window))
+  (let ((attrs (x11:make-xwindowattributes)))
+    (x11:xgetwindowattributes (object-display window)
+			      window
+			      attrs)
+    (ecase (x11:xwindowattributes-map-state attrs)
+      (0 :unmapped)
+      (1 :unviewable)
+      (2 :viewable))))
+
+
 (defmethod drawable-width ((window window))
   (window-width window))
 (defmethod drawable-height ((window window))
@@ -488,3 +500,17 @@
      dest-y
      (image-width image)
      (image-height image))))
+
+(defun image-from-pixmap (pixmap)
+  (x11:xgetimage
+   (object-display pixmap)
+   pixmap
+   0 
+   0 
+   (pixmap-width pixmap)
+   (pixmap-height pixmap)
+   #xff					; plane-mask
+   x11:xypixmap))
+
+(defun destroy-image (image)
+  (x11:xdestroyimage image))
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index d4ecf1a1..e6a1c95b 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-funs.lisp,v 1.3 92/04/21 20:27:51 cer Exp Locker: cer $
+;; $fiHeader: xt-funs.lisp,v 1.4 92/05/07 13:11:03 cer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp
index 534b33d6..b55e7219 100644
--- a/tk/xt-init.lisp
+++ b/tk/xt-init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-init.lisp,v 1.5 92/04/21 20:27:52 cer Exp Locker: cer $
+;; $fiHeader: xt-init.lisp,v 1.6 92/05/07 13:11:04 cer Exp Locker: cer $
 
 
 (in-package :tk)
@@ -30,6 +30,5 @@
 (defun xt-initialize ()
   (unless *xt-done*
     (xt_toolkit_initialize)
-    (define-toolkit-classes *intrinsic-classes*)
     (setq *xt-done* t)))
 
diff --git a/utils/autoconstructor.lisp b/utils/autoconstructor.lisp
index ea6f60fd..f7d87e25 100644
--- a/utils/autoconstructor.lisp
+++ b/utils/autoconstructor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: autoconstructor.lisp,v 1.2 92/01/31 14:52:23 cer Exp $
+;; $fiHeader: autoconstructor.lisp,v 1.3 92/02/24 13:05:05 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1990 by Xerox Corporation.  All rights reserved.
@@ -96,7 +96,7 @@
        (eval-when (compile load eval)
 	 (proclaim '(notinline ,name))
 	 (proclaim '(function ,name)))
-       #+Ignore ;; See if FUNCTION proclamation is sufficient.
+       #+++ignore ;; See if FUNCTION proclamation is sufficient.
        (defun ,name (&rest args)
 	 (declare (dynamic-extent args)
 		  (ignore args))
@@ -196,7 +196,7 @@
 	      ;; Can't use PCL's iterate tool
 	      (dorest (sublist supplied-initargs cddr)
 		(collect (first sublist)))
-	      #+ignore
+	      #+++ignore
 	      (iterate ((name (pcl::*list-elements supplied-initargs
 						   :by #'cddr)))
 		       (collect name))))))
diff --git a/utils/cl-stream-classes.lisp b/utils/cl-stream-classes.lisp
index 60ae5d1a..583ab9e6 100644
--- a/utils/cl-stream-classes.lisp
+++ b/utils/cl-stream-classes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cl-stream-classes.lisp,v 1.2 92/01/31 15:07:17 cer Exp $
+;; $fiHeader: cl-stream-classes.lisp,v 1.3 92/02/24 13:05:09 cer Exp $
 
 (in-package :clim-utils)
 
@@ -74,6 +74,7 @@
 (define-class-and-predicate fundamental-binary-output-stream nil
   (fundamental-output-stream fundamental-binary-stream))
 
+#-Cloe-Runtime					;not there yet
 (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/clos.lisp b/utils/clos.lisp
index efc8389e..23a5e2b9 100644
--- a/utils/clos.lisp
+++ b/utils/clos.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clos.lisp,v 1.4 92/03/04 16:20:08 cer Exp $
+;; $fiHeader: clos.lisp,v 1.5 92/04/15 11:45:25 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -147,7 +147,7 @@
 ;;; DEFGENERIC ... because it isn't there.
 ;;;
 
-#+ignore
+#+++ignore
 (defmacro defgeneric (function-specifier lambda-list &rest options)
   (declare (ignore lambda-list))
   (let ((expansion nil)
@@ -201,7 +201,7 @@
 (defun collect-root-classes (&optional package)
   (w::with-collection
     (let ((classes (mapcar #'find-class (classes-in-package 
-					  (or package 'silica) t))))
+					  (or package :silica) t))))
       (dolist (class classes)
 	(if (not (intersection (pcl::class-local-supers class)
 			       classes))
diff --git a/utils/defpackage.lisp b/utils/defpackage.lisp
index 6109d31b..748053a5 100644
--- a/utils/defpackage.lisp
+++ b/utils/defpackage.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: (CLIM-LISP :USE LISP :COLON-MODE :EXTERNAL); Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: defpackage.lisp,v 1.4 92/03/04 16:20:11 cer Exp $
+;; $fiHeader: defpackage.lisp,v 1.5 92/03/10 10:11:49 cer Exp $
 
 "Copyright (c) 1989, 1990, 1991 by International Lisp Associates.  All Rights Reserved."
 
@@ -83,7 +83,7 @@
 	       :export
 	       #'(lambda (option-arg)
 		   `(export-1 ',option-arg ,package-var)
-		   #+ignore
+		   #+++ignore
 		   `(progn ,@(mapcar #'(lambda (x)
 					 `(export (list (intern ',x ,package-var))
 						  ,package-var))
diff --git a/utils/defun.lisp b/utils/defun.lisp
index 8e84284b..1168d47b 100644
--- a/utils/defun.lisp
+++ b/utils/defun.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: defun.lisp,v 1.3 92/02/24 13:05:32 cer Exp $
+;; $fiHeader: defun.lisp,v 1.4 92/03/04 16:20:14 cer Exp $
 
 (in-package :clim-utils)
 
@@ -273,8 +273,8 @@
 	,@documentation ,@new-body))))
 
 (lisp:defun generate-dynamic-function-declarations (functions)
-  #-Ignore (declare (ignore functions))
-  #+Ignore `((declare (dynamic-extent ,@(mapcar #'(lambda (fn) `#',fn) functions)))))
+  #---ignore (declare (ignore functions))
+  #+++ignore `((declare (dynamic-extent ,@(mapcar #'(lambda (fn) `#',fn) functions)))))
 
 (defmacro flet (functions &body body &environment env)
   (construct-local-function-body 'lisp:flet functions body env))
diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp
index 4dc186d8..5751f826 100644
--- a/utils/excl-verification.lisp
+++ b/utils/excl-verification.lisp
@@ -20,11 +20,12 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: excl-verification.lisp,v 1.8 92/04/03 12:04:19 cer Exp Locker: cer $
+;; $fiHeader: excl-verification.lisp,v 1.9 92/04/10 14:26:41 cer Exp Locker: cer $
 
 (in-package :sys)
 
-(assert (eq excl::*current-case-mode* :case-insensitive-lower))
+(eval-when (compile)
+  (assert (member excl::*current-case-mode* '(:case-insensitive-lower :case-insensitive-upper))))
 
 (eval-when (compile load eval)
   (pushnew :clim *features*)
@@ -58,4 +59,4 @@ You do not have patches ~{~S ~}"
 
 (si::rcsnote
  "CLIM 2.0.alpha.0"
- "$fiHeader: $")
+ "$fiHeader: excl-verification.lisp,v 1.9 92/04/10 14:26:41 cer Exp Locker: cer $")
diff --git a/utils/lisp-package-fixups.lisp b/utils/lisp-package-fixups.lisp
index c07444ba..0c074422 100644
--- a/utils/lisp-package-fixups.lisp
+++ b/utils/lisp-package-fixups.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10 -*-
 
-;; $fiHeader: lisp-package-fixups.lisp,v 1.3 92/02/16 20:55:12 cer Exp $
+;; $fiHeader: lisp-package-fixups.lisp,v 1.4 92/02/24 13:05:39 cer Exp $
 
 #+ANSI-90 (in-package :cl-user)
 
@@ -63,12 +63,11 @@
 		  (old-name (package-name package))
 		  (old-nicknames (package-nicknames package)))
 	     (let (#+Allegro (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))))))
+	       (rename-package
+		 package old-name
+		 (union (list* primary-name old-nicknames)
+			required-nicknames
+			: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/lucid-stream-functions.lisp b/utils/lucid-stream-functions.lisp
index 400df62f..4e7273e8 100644
--- a/utils/lucid-stream-functions.lisp
+++ b/utils/lucid-stream-functions.lisp
@@ -5,7 +5,7 @@
 "Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
  Portions copyright (c) 1989, 1990 International Lisp Associates."
 
-;;; $fiHeader: lucid-stream-functions.lisp,v 1.3 92/02/24 13:34:13 cer Exp $
+;;; $fiHeader: lucid-stream-functions.lisp,v 1.4 92/03/04 16:20:18 cer Exp $
 ;;; 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
@@ -238,8 +238,8 @@
 
 (defmacro %string-stream (stream &body body)
   `(let (result
-	 (new-stream (cond ((typep ,stream 'clim-internals::accept-values-stream)
-			    (slot-value ,stream 'clim-internals::stream))
+	 (new-stream (cond ((encapsulating-stream-p ,stream)
+			    (encapsulating-stream-stream ,stream))
 			   ((typep ,stream 'fundamental-stream)
 			    ,stream)
 			   (t
@@ -263,8 +263,8 @@
 (redefine-lucid-io-function lcl:underlying-stream (stream &optional direction
 							  (recurse t)
 							  exact-same)
-			    (if (typep stream 'clim-internals::accept-values-stream)
-				(slot-value stream 'clim-internals::stream)
+			    (if (encapsulating-stream-p stream)
+				(encapsulating-stream-stream stream)
 				stream))
 
 (redefine-lucid-io-function lisp:prin1 (object &optional (stream *standard-output*))
@@ -359,8 +359,8 @@
 
 (lcl:defadvice (lisp:y-or-n-p stream-wrapper) (&optional format-string &rest args)
   (declare (dynamic-extent args))
-  (if (and (system:standard-object-p *QUERY-IO*)
-	   (typep *QUERY-IO* 'fundamental-stream))
+  (if (and (system:standard-object-p *query-io*)
+	   (typep *query-io* 'fundamental-stream))
       (clim:accept 'clim:boolean :prompt (apply #'lisp::format nil format-string
 					   args))
       (lcl:apply-advice-continue format-string args)))
@@ -381,6 +381,6 @@
   (let ((stream (if (eq stream t) *standard-output* stream)))
     (if (and (system:standard-object-p stream)
 	     (typep stream 'fundamental-stream))
-	(apply #'clim:format   stream control-string args)
+	(apply #'clim:format stream control-string args)
 	(lcl:apply-advice-continue stream control-string args))))
 
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 14b42b31..9a0ca744 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.15 92/05/07 13:11:40 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.16 92/05/13 17:10:42 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -1485,12 +1485,6 @@
     area
     areap
     coordinate
-
-    check-box
-    check-box-current-selection
-    check-box-pane
-    check-box-selections
-
     ellipse
     ellipse-center-point
     ellipse-center-point*
@@ -1743,7 +1737,6 @@
     note-sheet-grafted
     note-sheet-region-changed
     note-sheet-transformation-changed
-    note-viewport-position-changed
     permanent-medium-sheet-output-mixin
     pointer-button-event
     pointer-button-hold-event
@@ -1765,8 +1758,6 @@
     poll-pointer
     port
     port-keyboard-input-focus
-    port-notify-user
-    port-select-file
     port-properties
     port-server-path
     port-type
@@ -2268,7 +2259,6 @@
     form
     frame-document-highlighted-presentation
     funcall-presentation-generic-function
-    gadget-active-p
     gadget-dialog-view
     gadget-menu-view
     gadget-view
@@ -2290,7 +2280,6 @@
     or
     pathname
     pointer-documentation-view
-    port-dialog-view
     present
     present-method
     present-to-string
@@ -2399,13 +2388,13 @@
     
     ;; Menus
     draw-standard-menu
+    frame-manager-menu-choose
     menu-choose
     menu-choose-from-drawer
     menu-item
     menu-item-display
     menu-item-options
     menu-item-value
-    port-menu-choose
     print-menu-item
     with-menu
     
@@ -2415,6 +2404,7 @@
     accept-values-resynchronize
     accepting-values
     display-exit-boxes
+    frame-manager-dialog-view
     invoke-accept-values-command-button
     
     ;; Command processor
@@ -2487,7 +2477,7 @@
     user-command-table
     with-command-table-keystrokes
     
-    ;; Application frames
+    ;; Application frames and frame managers
     *application-frame*
     *default-frame-manager*
     *pointer-documentation-output*
@@ -2521,6 +2511,8 @@
     frame-maintain-presentation-histories
     frame-manager
     frame-manager-frames
+    frame-manager-notify-user
+    frame-manager-select-file
     frame-name
     frame-named-panes
     frame-pane
@@ -2567,6 +2559,15 @@
     with-application-frame
     with-frame-manager
     
+    ;; Progress notes
+    *current-progress-note*
+    dolist-noting-progress
+    dotimes-noting-progress
+    note-progress
+    note-progress-in-phases
+    noting-progress
+    progress-note-name
+
     ;; Panes
     +fill+
     allocate-space
@@ -2585,11 +2586,12 @@
     label-pane
     labelled
     lowering
-    make-clim-pane
+    make-clim-stream-pane
     make-pane
     make-pane-1
     make-space-requirement
     note-space-requirements-changed
+    note-viewport-position-changed
     outlined-pane
     outlining
     pane
@@ -2632,11 +2634,16 @@
     activate-callback
     activate-gadget
     armed-callback
+    check-box
+    check-box-current-selection
+    check-box-pane
+    check-box-selections
     deactivate-gadget
     disarmed-callback
     drag-callback
     gadget
     gadget-activate-callback
+    gadget-active-p
     gadget-armed-callback
     gadget-client
     gadget-disarmed-callback
@@ -2655,27 +2662,17 @@
     gadget-show-value-p
     gadget-value
     gadget-value-changed-callback
-    gadget-show-value-p
-    
-    ;; this should go somewhere 
-    
-    slider-decimal-places
-    set-gadget-items
-    set-gadget-name-key
-    set-gadget-value-key
-    set-gadget-test
+    label-pane
+    labelled-gadget-mixin
     list-pane
     list-pane-mode
-    option-pane
-
-    label-pane
-    labelled-gadget
     menu-bar
     menu-button
     menu-button-pane
     note-gadget-activated
     note-gadget-deactivated
-    oriented-gadget
+    option-pane
+    oriented-gadget-mixin
     push-button
     push-button-pane
     push-button-show-as-default-p
@@ -2684,9 +2681,16 @@
     radio-box-pane
     radio-box-selections
     scroll-bar
+    scroll-bar-current-size
+    scroll-bar-current-value
     scroll-bar-drag-callback
     scroll-bar-pane
+    set-gadget-items
+    set-gadget-name-key
+    set-gadget-test
+    set-gadget-value-key
     slider
+    slider-decimal-places
     slider-pane
     text-editor
     text-editor-pane
@@ -3320,9 +3324,6 @@
     frame-shell
     frame-wrapper
     gadget-alignment
-    gadget-range
-    gadget-range*
-    gadget-show-value-p
     get-drawing-function-description
     get-port-canonical-gesture-spec
     grid-pane
@@ -3331,7 +3332,6 @@
     label-button-pane
     layout-mixin
     line-editor-pane
-    list-pane
     make-frame-manager
     make-medium
     medium-+y-upward-p
@@ -3350,6 +3350,7 @@
     mute-repainting-mixin
     non-drawing-option-keywords
     one-of-pane
+    option-pane
     parse-gesture-spec
     permanent-medium-sheet-output-mixin
     pointer-press-event
@@ -3374,8 +3375,6 @@
     port-pointer
     port-process
     port-undefined-text-style
-    port-write-char-1
-    port-write-string-1
     process-event-locally
     radio-button-pane
     raise-mirror
@@ -3398,9 +3397,8 @@
     standard-sheet-input-mixin
     standardize-text-style 
     standardize-text-style-1
-    stream-glyph-for-character
+    stream-scan-character-for-writing
     stream-scan-string-for-writing
-    stream-write-string-1
     string-height 
     string-width 
     text-style-scale 
diff --git a/utils/reader.lisp b/utils/reader.lisp
index 64fead9d..c505f157 100644
--- a/utils/reader.lisp
+++ b/utils/reader.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: reader.lisp,v 1.5 92/02/24 13:05:53 cer Exp $
+;; $fiHeader: reader.lisp,v 1.6 92/03/10 10:11:58 cer Exp $
 
 (in-package :clim-utils)
 
@@ -44,7 +44,7 @@
       (catch 'stop
 	;; here's where we install #\} as the terminating character
 	;; for #{
-	(with-macro-character (#\} '|READ-}|)
+	(with-macro-character (#\} #'|READ-}|)
 	  (loop
 	    (let ((feature (read stream t nil t)))
 	      (when found-otherwise
diff --git a/utils/regions.lisp b/utils/regions.lisp
index 13998c10..5ca23e3b 100644
--- a/utils/regions.lisp
+++ b/utils/regions.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: regions.lisp,v 1.7 92/04/21 16:12:47 cer Exp Locker: cer $
+;; $fiHeader: regions.lisp,v 1.8 92/05/07 13:11:44 cer Exp $
 
 (in-package :clim-utils)
 
@@ -584,8 +584,8 @@
 (defmethod bounding-rectangle-set-edges ((rectangle standard-bounding-rectangle)
 					 left top right bottom)
   (declare (type real left top right bottom))
-  #+ignore (assert (<= left right))
-  #+ignore (assert (<= top bottom))
+  #+++ignore (assert (<= left right))
+  #+++ignore (assert (<= top bottom))
   (with-slots ((bl left) (bt top) (br right) (bb bottom)) rectangle
     (setq bl (coordinate left)
 	  bt (coordinate top)
diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp
index 0adf11d1..179e9078 100644
--- a/xlib/ffi.lisp
+++ b/xlib/ffi.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ffi.lisp,v 1.10 92/04/15 11:45:43 cer Exp Locker: cer $
+;; $fiHeader: ffi.lisp,v 1.11 92/04/21 20:28:01 cer Exp $
 
 (in-package :x11)
 
@@ -89,6 +89,7 @@
 						 (foo-slot slot))
 					     slots))
 		(error ":overlays used in a way we cannot handle"))))))))
+
 	  
 
 (defun trans-slot-type (type)
diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp
index fdc7b073..5fc87e99 100644
--- a/xlib/load-xlib.lisp
+++ b/xlib/load-xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xlib.lisp,v 1.2 92/03/30 17:52:17 cer Exp $
+;; $fiHeader: load-xlib.lisp,v 1.3 92/05/13 17:10:47 cer Exp Locker: cer $
 
 (in-package :x11)
 
@@ -48,10 +48,11 @@
 	    :system-libraries libraries
 	    :print t))))
 
-(defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
+(defvar sys::*libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
 
 (unless (ff:get-entry-point (ff:convert-to-lang "lisp_XDrawString"))
-  (load "xlibsupport.o" :system-libraries (list *libx11-pathname*) :print t))
+  (load "xlibsupport.o" :system-libraries (list sys::*libx11-pathname*) :print t))
+
 (x11::load-undefined-symbols-from-library
  "stub-x.o"
  (x11::symbols-from-file "misc/undefinedsymbols")
@@ -59,5 +60,5 @@
    "__prod_b10000" 
    "__carry_out_b10000" 
    "__prod_65536_b10000")
- (list x11::*libx11-pathname*))
+ (list sys::*libx11-pathname*))
 
diff --git a/xlib/pkg.lisp b/xlib/pkg.lisp
index e5550106..72c7412f 100644
--- a/xlib/pkg.lisp
+++ b/xlib/pkg.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.5 92/02/24 13:06:36 cer Exp Locker: cer $
+;; $fiHeader: pkg.lisp,v 1.6 92/03/09 17:41:34 cer Exp Locker: cer $
 
 
 (defpackage :x11
diff --git a/xlib/x11-keysyms.lisp b/xlib/x11-keysyms.lisp
index 26a88e1a..c69c35fc 100644
--- a/xlib/x11-keysyms.lisp
+++ b/xlib/x11-keysyms.lisp
@@ -18,11 +18,11 @@
 ;; Commercial Software developed at private expense as specified in FAR
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
+;;
 
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
 ;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
 ;;      registered trademark of USL. Used by written permission of the owners.
-;;
 ;;      (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered
 ;;      trademark of Bigelow & Holmes. Permission to use the Lucida
 ;;      trademark is hereby granted only in association with the images
@@ -44,8 +44,10 @@
 ;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
 ;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
 
+;;; $fiHeader: x11-keysyms.lisp,v 1.7 92/04/21 20:34:41 cer Exp $
+
 ;;;@(#)x11-keysym.lisp	1.3 11/29/90
-;;; $fiHeader$
+
 
 (in-package :x11)
 
-- 
GitLab