diff --git a/Makefile b/Makefile
index 16195c02a649f188260b284c3dd5cb3eeee311ce..a5ddcd346ca74e062aad9a22ab3de74a6df39228 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.68 92/11/20 08:44:11 cer Exp $
+# $fiHeader: Makefile,v 1.69 92/12/01 09:44:55 cer Exp $
 #
 #  Makefile for CLIM 2.0
 #
@@ -14,9 +14,11 @@ TRAIN_TIMES=2
 # view, file, print
 PSVIEW=file
 
+FRAME_TESTS=t
+
 TRAIN_LISP= \
 	(load \"misc/train.lisp\") \
-	(train-clim :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \
+	(train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \
 	(exit 0)
 
 TRAIN_TEXT = \
@@ -37,12 +39,19 @@ SAFETY	= 1
 # This next should be set to 1 for distribution
 DEBUG   = 2
 
+COMPILE_PRINT=nil 
+# Name of dumped lisp
+CLIM	= ./slim
+CLIMOL= $(CLIM)
+CLIMXM= $(CLIM)
+
 make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \
 	LOAD_SOURCE_FILE_INFO=${LOAD_SOURCE_FILE_INFO} \
 	RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \
 	LOAD_XREF_INFO=${LOAD_XREF_INFO} \
-	RECORD_XREF_INFO=${RECORD_XREF_INFO}
-
+	RECORD_XREF_INFO=${RECORD_XREF_INFO} \
+	CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} \
+	COMPILE_PRINT=${COMPILE_PRINT}
 
 CFLAGS	= -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD -I/x11/motif-1.1/lib
 
@@ -50,11 +59,6 @@ OLDSPACE = 15000000
 NEWSPACE = 5000000
 PREMALLOCS = '-m 401408'
 
-# Name of dumped lisp
-CLIM	= ./slim
-CLIMOL= $(CLIM)
-CLIMXM= $(CLIM)
-
 CLIM-SMALL	= ./slim-small
 
 PUBDIRS	= sys utils silica clim demo test genera clx pre-silica postscript compatibility
@@ -174,7 +178,6 @@ CLIM-UTILS-OBJS = utils/excl-verification.fasl \
                    utils/queue.fasl \
 		   utils/timers.fasl \
                    utils/protocols.fasl \
-                   utils/autoconstructor.fasl \
                    utils/clim-streams.fasl \
                    utils/excl-streams.fasl \
                    utils/clim-macros.fasl \
@@ -265,7 +268,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \
                         clim/stream-trampolines.fasl
 
 GENERIC-GADGETS = clim/db-menu.fasl clim/db-list.fasl clim/db-text.fasl silica/db-button.fasl \
-	    silica/db-slider.fasl	   
+	    silica/db-slider.fasl silica/scroll-pane.fasl
 
 XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl
 
@@ -354,7 +357,6 @@ ALL_SRC =	   utils/excl-verification.lisp \
                    utils/processes.lisp \
                    utils/queue.lisp \
                    utils/protocols.lisp \
-                   utils/autoconstructor.lisp \
                    utils/clim-streams.lisp \
                    utils/excl-streams.lisp \
                    utils/clim-macros.lisp \
@@ -521,10 +523,12 @@ compile-xm:	$(CLIMOBJS) FORCE
 	(si::system-compile-wrapper \
 	 (function \
 	  (lambda () \
+	    (setq *compile-print* $(COMPILE_PRINT)) \
 	    (setq sys::*libxt-pathname* \"$(XTLIB)\") \
 	    (setq sys::*libx11-pathname* \"$(XLIB)\") \
 	    (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
-	    (load \"misc/compile-xm.lisp\"))) \
+	    (load \"misc/compile-1.lisp\") \
+	    (compile-it 'motif-clim))) \
 	 :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \
 	 :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \
 	 :record-xref-info $(RECORD_XREF_INFO) \
@@ -536,13 +540,15 @@ compile-ol:	$(CLIMOBJS) FORCE
 	(si::system-compile-wrapper \
 	 (function \
 	  (lambda () \
+	    (setq *compile-print* $(COMPILE_PRINT)) \
 	    (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
 	    (setq sys::*libxt-pathname* \"$(XTLIB)\") \
 	    (setq sys::*libx11-pathname* \"$(XLIB)\") \
 	    (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
 	    (setq *ignore-package-name-case* t) \
 	    (set-case-mode :case-insensitive-lower) \
-	    (load \"misc/compile-ol.lisp\"))) \
+	    (load \"misc/compile-1.lisp\") \
+	    (compile-it 'openlook-clim))) \
 	 :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \
 	 :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \
 	 :record-xref-info $(RECORD_XREF_INFO) \
@@ -629,7 +635,8 @@ clim-xm:	FORCE $(CLIMOBJS)
 		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
 		(setq sys::*libx11-pathname* \"$(XLIB)\") \
 	        (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
-		(load \"misc/dev-load-xm.lisp\") \
+		(load \"misc/dev-load-1.lisp\") \
+		(load-it 'motif-clim) \
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMXM)
 	ls -lLt $(CLIMXM) >> Clim-sizes.n
@@ -643,7 +650,8 @@ clim-ol:	FORCE $(CLIMOBJS)
 		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
 		(setq sys::*libx11-pathname* \"$(XLIB)\") \
 	        (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
-		(load \"misc/dev-load-ol.lisp\") \
+		(load \"misc/dev-load-1.lisp\") \
+		(load-it 'openlook-clim) \
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMOL)
 	ls -lLt $(CLIMOL) >> Clim-sizes.n
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index e9d6deb6450257c6b3a8d894eefc6c032c09a13c..f5ac303761bafcfe85e26c08705b57d75bd5b19e 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.47 92/11/20 08:44:18 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.48 92/12/03 10:25:53 cer Exp $
 
 (in-package :clim-internals)
 
@@ -539,6 +539,19 @@
 		(move-cursor-beyond-output-record 
 		  (encapsulating-stream-stream stream) avv)))))))))
 
+(defmethod invoke-with-aligned-prompts ((stream accept-values-stream) continuation &key (align-prompts t))
+  (setq align-prompts (ecase align-prompts
+			((t :right) :right)
+			((:left) :left)
+			((nil) nil)))
+  (letf-globally (((slot-value stream 'align-prompts) align-prompts)) 
+    (formatting-table (stream)
+	(funcall continuation stream))))
+
+(defmethod invoke-with-aligned-prompts ((stream t) continuation &key align-prompts)
+  (declare (ignore align-prompts))
+  (funcall continuation stream))
+
 (defmethod frame-manager-display-input-editor-error
 	   ((framem standard-frame-manager) (frame accept-values) stream error)
   ;;--- Resignal the error so the user can handle it
diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp
index a23d3869dc5f4c96491a59761ce3c1190b32ec87..f57b12da73ab1549496742739994bbbeb9634109 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.11 92/11/19 14:17:04 cer Exp $
+;; $fiHeader: basic-translators.lisp,v 1.12 92/12/03 10:26:03 cer Exp $
 
 (in-package :clim-internals)
 
@@ -22,13 +22,15 @@
     (object presentation)
   (values object (presentation-type presentation)))
 
+
 (defun identity-translator-applicable-p (presentation context-type)
   (let* ((type (presentation-type presentation))
 	 (type-name (presentation-type-name type))
 	 (object (presentation-object presentation)))
     (with-presentation-type-decoded (context-name context-parameters) context-type
       (if (eq type-name 'blank-area)
-	  (orD,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (NIL :BOLD NIL) "CPTFONTCB") 0(eq context-name 'blank-area)
+	  (or ;;  D,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (NIL :BOLD NIL) "CPTFONTCB") 0
+	   (eq context-name 'blank-area)
 	      (presentation-subtypep-1 type context-type))
 	;; Let MENU-ITEM-IDENTITY take care of pure menu items
 	(unless (and (eq type-name 'menu-item)
diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp
index 69e3b7c2e6682c719d41d7e1433c7341a685aeb9..d66db0607451e3b3856f9725149b2af72df5dbbb 100644
--- a/clim/clim-defs.lisp
+++ b/clim/clim-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clim-defs.lisp,v 1.19 92/12/01 09:45:05 cer Exp $
+;; $fiHeader: clim-defs.lisp,v 1.20 92/12/03 10:26:06 cer Exp $
 
 (in-package :clim-internals)
 
@@ -309,6 +309,11 @@
      (declare (dynamic-extent #'accepting-values-body))
      (invoke-accepting-values ,stream #'accepting-values-body ,@args)))
 
+(defmacro with-aligned-prompts ((stream &rest args) &body body)
+  (default-input-stream stream accepting-values)
+  `(flet ((with-aligned-prompts-body (,stream) ,@body))
+     (declare (dynamic-extent #'accepting-values-body))
+     (invoke-with-aligned-prompts ,stream #'with-aligned-prompts-body ,@args)))
 
 ;; Establish a first quadrant coordinate system, execute the body, and then
 ;; place the output in such a way that the upper left corner of it is where
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 0bd754c359a5ac5f9875f8031f4c10e69066b17c..f47ae11466abfa056f1749f83fdf1decfd82174f 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-stream.lisp,v 1.38 92/12/01 09:45:08 cer Exp $
+;; $fiHeader: db-stream.lisp,v 1.39 92/12/03 10:26:23 cer Exp $
 
 (in-package :clim-internals)
 
@@ -355,7 +355,7 @@
 	  (:top
 	    (setq pane `(vertically () ,label ,pane))))))
     (when borders 
-      (setq pane (outlining (:thickness 1)
+      (setq pane `(outlining (:thickness 1)
 		   #+allegro
 		   ,pane
 		   #-allegro
diff --git a/clim/frames.lisp b/clim/frames.lisp
index db8309758a0a9a9b1dcc8f29c260f51b7e48fbcb..41d3433478a9e2ad328112b2033d701fb7e9e280 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.52 92/12/01 09:45:11 cer Exp $
+;; $fiHeader: frames.lisp,v 1.53 92/12/03 10:26:35 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1500,3 +1500,11 @@
     (values left   left-presentation   left-context
 	    middle middle-presentation middle-context
 	    right  right-presentation  right-context)))
+
+(defmethod handle-event ((stream input-protocol-mixin) (event port-terminated))
+  (if (pane-frame stream)
+      (frame-terminated (pane-frame stream) event)
+    (error "Port has died ~A" event)))
+
+(defmethod frame-terminated ((frame standard-application-frame) event)
+  (error "Port for frame ~A has died ~A" frame event))
diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp
index 2c58ad9e1566cc74f5931b891418a3487b62c64e..c2cb7c9d52de0be307db6b4c83e16e75ef52a2d2 100644
--- a/clim/graph-formatting.lisp
+++ b/clim/graph-formatting.lisp
@@ -1,79 +1,12 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
-;; Allegro Common Lisp
-;;				-[Thu Nov 19 18:52:10 1992 by smh]-
-;;
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
-;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
-;;
-;; The software, data and information contained herein are proprietary
-;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
-;; given in confidence by Franz, Inc. pursuant to a written license
-;; agreement, and may be stored and used only in accordance with the terms
-;; of such license.
-;;
-;; Restricted Rights Legend
-;; ------------------------
-;; Use, duplication, and disclosure of the software, data and information
-;; contained herein by any agency, department or entity of the U.S.
-;; Government are subject to restrictions of Restricted Rights for
-;; Commercial Software developed at private expense as specified in FAR
-;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
-;; applicable.
-;;
-;; $fiHeader: graph-formatting.lisp,v 1.18 92/11/06 18:59:45 cer Exp $
-
-
-"Copyright (c) 1990, 1991, 1992 Symbolics Inc.  All rights reserved."
-
-
-(In-package :clim-internals)
 
-#|
-
-This file is smh's quick hacked version for improved digraph layout.
-
-The basic strategy is that each node appearing more than once in the
-graph is reliably assigned the maximum generation (ply) to which it
-belongs, instead of depending on which occurence was encountered
-first.  Then `filler' output records are inserted to fill in missing
-generations in any link.  These fillers then participate in regular
-node layout.  This results in some unnecessarily squiggley lines, but
-generally the behavior is reasonable.
-
-In graphs where a node with large "depth" is adjacent to a small depth
-node with large fanout connections there is still the possibly that a
-connector will overwrite a node.  This could be fixed with one of
-several strategies: Pad the short node's depth somehow, which moves a
-lot of complexity onto the arc-drawing functions; or add a whole
-generation of additional filler nodes, which would be laid out to
-constrain the set of children of each parent to lie within that
-parents breadth.  I'd draw a picture of it weren't so tedious...
-
-The unnecessary squiggles could be fixed without too much work by
-postprocessing the links, successively moving filler nodes when there
-is room to line them up with one of it's connections in the adjacent
-generation.
-
-Useful rfe: Enforce some limit on the maximum absolute value slope on
-a connection.  Extra inter-generation spacing would be adde to limit
-the slope, since high-slope lines are the most visually confusion,
-especially when many occur together.
+;; $fiHeader: graph-formatting.lisp,v 1.20 92/12/01 17:49:59 cer Exp $
 
-As an additional hack, the digraph grapher handles circularities by
-creating a pair of `offpage' connectors.  This isn't as elegant as
-plotting circular paths backwards, but the current hack results in a
-clear visual diagram with little effort.  The new
-offpage-connector-out-printer and offpage-connector-in-printer args to
-format-graph-from-roots are something of a crock -- perhaps we can
-avoid documenting them until better treatment of cyclic graphs is
-devised.  BTW, before this hack, a circular graph with no roots (i.e.
-all nodes have at least one parent) would blow the stack, so don't
-undertake a more ambitious fix for circular graphs without accounting
-for this case.
+(in-package :clim-internals)
 
-|#
+"Copyright (c) 1990, 1991, 1992 Symbolics Inc.  All rights reserved.
+ Portions copyright (c) 1992 Franz, Inc.  All rights reserved."
 
-
 (defvar *graph-type-record-type-alist* nil)
 
 (defmacro define-graph-type (graph-type class)
@@ -157,15 +90,12 @@ for this case.
 ;; The basic graph output record class
 (defclass basic-graph-output-record 
 	  (standard-sequence-output-record graph-output-record)
-    ((orientation :initarg :orientation)
-     (center-nodes :initarg :center-nodes)
-     (cutoff-depth :initarg :cutoff-depth)
-     (merge-duplicates :initarg :merge-duplicates)
-     (generation-separation :initarg :generation-separation)
-     (within-generation-separation :initarg :within-generation-separation)
+    ((graph-type :initarg :graph-type)
      ;; The output records corresponding to the root nodes
      (root-nodes :initform nil :accessor graph-root-nodes)
-     (hash-table :initform nil :initarg :hash-table))
+     (hash-table :initform nil :initarg :hash-table)
+     ;; Stores things like :ORIENTATION, :MERGE-DUPLICATES, etc.
+     (properties :initarg :properties))
   (:default-initargs :size 30))
 
 ;;--- Not correct, since edges can overlap nodes. 
@@ -187,12 +117,13 @@ for this case.
     ((generation :accessor graph-node-generation :initform 0)
      ;; The output records corresponding to this node's parents and children
      (node-children :accessor graph-node-children :initform nil)
-     (node-parents :accessor graph-node-parents :initform nil))
+     (node-parents :accessor graph-node-parents :initform nil)
+     (object :accessor graph-node-object :initarg :object))
   (:default-initargs :size 5))
 
 (define-output-record-constructor standard-graph-node-output-record
-				  (&key x-position y-position (size 25))
-  :x-position x-position :y-position y-position :size size)
+				  (&key object x-position y-position (size 25))
+  :object object :x-position x-position :y-position y-position :size size)
 
 (defmethod tree-recompute-extent-1 ((record standard-graph-node-output-record))
   (bounding-rectangle* record))
@@ -221,9 +152,9 @@ for this case.
 				      *default-generation-separation*)
 				    (within-generation-separation
 				      *default-within-generation-separation*)
-				    (move-cursor t))
+				    (store-objects nil) (move-cursor t))
   (declare (dynamic-extent keys object-printer inferior-producer)
-	   (ignore stream key orientation cutoff-depth 
+	   (ignore stream key orientation cutoff-depth store-objects
 		   generation-separation within-generation-separation move-cursor))
   (with-keywords-removed (keys keys '(:key))
     (apply #'format-graph-from-roots
@@ -243,15 +174,16 @@ for this case.
 				       *default-generation-separation*)
 				     (within-generation-separation
 				       *default-within-generation-separation*)
-				     (move-cursor t)
+				     (maximize-generations #+Allegro t #-Allegro nil)
+				     (store-objects nil) (move-cursor t)
 				     ;; These `offpage' connector print functions
 				     ;; should receive more useful id in addition
 				     ;; to an identification number, such as the
 				     ;; from and to nodes.
 				     (offpage-connector-out-printer
-				      #'(lambda (s n) (format s ">~d" n)))
+				       #'(lambda (s n) (format s ">~D" n)))
 				     (offpage-connector-in-printer
-				      #'(lambda (s n) (format s "~d>" n))))
+				       #'(lambda (s n) (format s "~D>" n))))
   (declare (dynamic-extent object-printer inferior-producer))
   (check-type cutoff-depth (or null integer))
   (check-type generation-separation real)
@@ -272,22 +204,25 @@ for this case.
 		 (with-end-of-line-action (stream :allow)
 		   (with-new-output-record 
 		       (stream record-type graph-record
-			:orientation orientation
-			:center-nodes center-nodes
-			:cutoff-depth cutoff-depth
-			:merge-duplicates merge-duplicates
-			:generation-separation
-			  (coordinate generation-separation)
-			:within-generation-separation 
-			  (coordinate within-generation-separation)
+			:graph-type graph-type
+			:properties `(:orientation ,orientation
+				      :center-nodes ,center-nodes
+				      :cutoff-depth ,cutoff-depth
+				      :merge-duplicates ,merge-duplicates
+				      :maximize-generations ,maximize-generations
+				      :generation-separation
+				        ,(coordinate generation-separation)
+				      :within-generation-separation 
+				        ,(coordinate within-generation-separation))
 			:hash-table hash-table)
 		     (generate-graph-nodes
-		      graph-record stream
-		      root-objects object-printer inferior-producer
-		      :duplicate-key duplicate-key 
-		      :duplicate-test duplicate-test
-		      :offpage-connector-out-printer offpage-connector-out-printer
-		      :offpage-connector-in-printer  offpage-connector-in-printer)
+		       graph-record stream
+		       root-objects object-printer inferior-producer
+		       :duplicate-key  duplicate-key 
+		       :duplicate-test duplicate-test
+		       :store-objects store-objects
+		       :offpage-connector-out-printer offpage-connector-out-printer
+		       :offpage-connector-in-printer  offpage-connector-in-printer)
 		     graph-record))))))
       (unwind-protect
 	  (progn
@@ -302,31 +237,31 @@ for this case.
 	(move-cursor-beyond-output-record stream graph-record))
       graph-record)))
 
-(defun draw-linear-arc (stream from-node to-node x1 y1 x2 y2 &rest drawing-options)
+(defun draw-linear-arc (stream from-object to-object x1 y1 x2 y2 &rest drawing-options)
   (declare (dynamic-extent drawing-options))
-  (declare (ignore from-node to-node))
+  (declare (ignore from-object to-object))
   (apply #'draw-line* stream x1 y1 x2 y2 drawing-options))
 
-(defun-inline call-arc-drawer (stream arc-drawer from-node to-node
+(defun-inline call-arc-drawer (stream arc-drawer parent-object child-object
 			       parent parent-x parent-y child child-x child-y
 			       arc-drawing-options)
   (declare (dynamic-extent arc-drawer))
   (if (or (stream-redisplaying-p stream)
 	  (stream-current-redisplay-record stream))
-      (call-arc-drawer-1 stream arc-drawer from-node to-node
+      (call-arc-drawer-1 stream arc-drawer parent-object child-object
 			 parent parent-x parent-y child child-x child-y
 			 arc-drawing-options)
-      (apply arc-drawer stream from-node to-node
+      (apply arc-drawer stream parent-object child-object
 	     parent-x parent-y child-x child-y
 	     arc-drawing-options)))
 
 ;; Split out to avoid consing a closure environment
-(defun call-arc-drawer-1 (stream arc-drawer from-node to-node
+(defun call-arc-drawer-1 (stream arc-drawer parent-object child-object
 			  parent parent-x parent-y child child-x child-y
 			  arc-drawing-options)
   (declare (dynamic-extent arc-drawer))
   #---ignore	;--- this is the wrong thing...
-  (apply arc-drawer stream from-node to-node
+  (apply arc-drawer stream parent-object child-object
 	 parent-x parent-y child-x child-y
 	 arc-drawing-options)
   #+++ignore	;--- ...but the right thing doesn't work either
@@ -335,7 +270,7 @@ for this case.
 			   :cache-value (list parent-x parent-y
 					      child-x child-y)
 			   :cache-test #'equal)
-    (apply arc-drawer stream from-node to-node
+    (apply arc-drawer stream parent-object child-object
 	   parent-x parent-y child-x child-y
 	   arc-drawing-options)))
 
@@ -348,13 +283,13 @@ for this case.
 
 (defmethod generate-graph-nodes ((graph tree-graph-output-record) stream
 				 root-objects object-printer inferior-producer
-				 &key duplicate-key duplicate-test
-				 offpage-connector-out-printer
-				 offpage-connector-in-printer)
+				 &key duplicate-key duplicate-test store-objects
+				      offpage-connector-out-printer
+				      offpage-connector-in-printer)
   (declare (ignore duplicate-key duplicate-test
-		   offpage-connector-out-printer
-		   offpage-connector-in-printer))
-  (let ((cutoff-depth (slot-value graph 'cutoff-depth)))
+		   offpage-connector-out-printer offpage-connector-in-printer))
+  (let* ((properties (slot-value graph 'properties))
+	 (cutoff-depth (getf properties :cutoff-depth)))
     (labels ((format-node (object &optional (depth 1))
 	       (when (and cutoff-depth (> depth cutoff-depth))
 		 (return-from format-node nil))
@@ -367,7 +302,9 @@ for this case.
 		       (setq children (nconc children (list node))))))
 		 (let ((this-node 
 			 (with-stream-cursor-position-saved (stream)
-			   (with-new-output-record (stream 'standard-graph-node-output-record)
+			   (with-new-output-record
+			       (stream 'standard-graph-node-output-record nil
+				:object (and store-objects object))
 			     (funcall object-printer object stream)))))
 		   (setf (graph-node-children this-node) children)
 		   (dolist (child (graph-node-children this-node))
@@ -377,13 +314,16 @@ for this case.
 	    (map 'list #'format-node root-objects))))
   graph)
 
-(defmethod layout-graph-nodes ((graph tree-graph-output-record)
-			       stream arc-drawer arc-drawing-options)
+(defmethod layout-graph-nodes ((graph tree-graph-output-record) stream
+			       arc-drawer arc-drawing-options)
   (declare (ignore stream arc-drawer arc-drawing-options))
-  (with-slots (root-nodes orientation center-nodes
-	       generation-separation within-generation-separation) graph
-    (let ((start-x (coordinate 0))
-	  (start-y (coordinate 0)))
+  (with-slots (root-nodes) graph
+    (let* ((properties (slot-value graph 'properties))
+	   (orientation (getf properties :orientation))
+	   (generation-separation (getf properties :generation-separation))
+	   (within-generation-separation (getf properties :within-generation-separation))
+	   (start-x (coordinate 0))
+	   (start-y (coordinate 0)))
       (dolist (root-node root-nodes)
 	(macrolet
 	  ((layout-body (driver-function-name 
@@ -446,191 +386,254 @@ for this case.
 		       (layout-graph root-node start-x start-y
 				     (node-depth root-node))))))))))))
 
-(defmethod layout-graph-edges ((graph tree-graph-output-record) 
-			       stream arc-drawer arc-drawing-options)
-  (with-slots (orientation root-nodes) graph
-    (dolist (root-node root-nodes)
-      (flet ((parent-attachment-position (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (case orientation
-		   ((:horizontal :right)
-		    (values (1+ right) (+ top (floor (- bottom top) 2))))
-		   ((:vertical :down)
-		    (values (+ left (floor (- right left) 2)) (1+ bottom))))))
-	     (child-attachment-position (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (case orientation
-		   ((:horizontal :right)
-		    (values (1- left) (+ top (floor (- bottom top) 2))))
-		   ((:vertical :down)
-		    (values (+ left (floor (- right left) 2)) (1- top)))))))
-	(declare (dynamic-extent #'parent-attachment-position #'child-attachment-position))
-	(multiple-value-bind (xoff yoff)
-	    (convert-from-relative-to-absolute-coordinates
-	      stream (output-record-parent graph))
-	  (with-identity-transformation (stream)
-	    (with-output-recording-options (stream :draw nil :record t)
-	      (with-new-output-record (stream 'standard-sequence-output-record nil
-				       :parent graph)
-		(labels ((draw-edges (parent)
-			   (dolist (child (graph-node-children parent))
-			     (when (graph-node-children child)
-			       (draw-edges child))
-			     (multiple-value-bind (parent-x parent-y)
-				 (parent-attachment-position parent)
-			       (multiple-value-bind (child-x child-y)
-				   (child-attachment-position child)
-				 (translate-coordinates xoff yoff
-				   parent-x parent-y child-x child-y)
-				 (call-arc-drawer stream arc-drawer
-						  ;;--- Should be from- and to-node
-						  nil nil
-						  parent parent-x parent-y
-						  child child-x child-y
-						  arc-drawing-options))))))
-		  (declare (dynamic-extent #'draw-edges))
-		  (draw-edges root-node))))))))))
+(defmethod layout-graph-edges ((graph tree-graph-output-record) stream
+			       arc-drawer arc-drawing-options)
+  (with-slots (root-nodes properties) graph
+    (let ((orientation (getf properties :orientation)))
+      (dolist (root-node root-nodes)
+	(flet ((parent-attachment-position (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (case orientation
+		     ((:horizontal :right)
+		      (values (1+ right) (+ top (floor (- bottom top) 2))))
+		     ((:vertical :down)
+		      (values (+ left (floor (- right left) 2)) (1+ bottom))))))
+	       (child-attachment-position (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (case orientation
+		     ((:horizontal :right)
+		      (values (1- left) (+ top (floor (- bottom top) 2))))
+		     ((:vertical :down)
+		      (values (+ left (floor (- right left) 2)) (1- top)))))))
+	  (declare (dynamic-extent #'parent-attachment-position #'child-attachment-position))
+	  (multiple-value-bind (xoff yoff)
+	      (convert-from-relative-to-absolute-coordinates
+		stream (output-record-parent graph))
+	    (with-identity-transformation (stream)
+	      (with-output-recording-options (stream :draw nil :record t)
+		(with-new-output-record (stream 'standard-sequence-output-record nil
+					 :parent graph)
+		  (labels ((draw-edges (parent)
+			     (dolist (child (graph-node-children parent))
+			       (when (graph-node-children child)
+				 (draw-edges child))
+			       (multiple-value-bind (parent-x parent-y)
+				   (parent-attachment-position parent)
+				 (multiple-value-bind (child-x child-y)
+				     (child-attachment-position child)
+				   (translate-coordinates xoff yoff
+				     parent-x parent-y child-x child-y)
+				   (call-arc-drawer stream arc-drawer
+						    (graph-node-object parent) 
+						    (graph-node-object child)
+						    parent parent-x parent-y
+						    child child-x child-y
+						    arc-drawing-options))))))
+		    (declare (dynamic-extent #'draw-edges))
+		    (draw-edges root-node)))))))))))
 
 
 ;;; Directed graphs, both acyclic and cyclic
 
+#|
+
+The basic strategy is that each node appearing more than once in the
+graph is reliably assigned the maximum generation (ply) to which it
+belongs, instead of depending on which occurence was encountered
+first.  Then `filler' output records are inserted to fill in missing
+generations in any link.  These fillers then participate in regular
+node layout.  This results in some unnecessarily squiggley lines, but
+generally the behavior is reasonable.
+
+In graphs where a node with large "depth" is adjacent to a small depth
+node with large fanout connections there is still the possibly that a
+connector will overwrite a node.  This could be fixed with one of
+several strategies: Pad the short node's depth somehow, which moves a
+lot of complexity onto the arc-drawing functions; or add a whole
+generation of additional filler nodes, which would be laid out to
+constrain the set of children of each parent to lie within that
+parents breadth.  I'd draw a picture of it weren't so tedious...
+
+The unnecessary squiggles could be fixed without too much work by
+postprocessing the links, successively moving filler nodes when there
+is room to line them up with one of it's connections in the adjacent
+generation.
+
+Useful rfe: Enforce some limit on the maximum absolute value slope on
+a connection.  Extra inter-generation spacing would be added to limit
+the slope, since high-slope lines are the most visually confusing,
+especially when many occur together.
+
+As an additional hack, the digraph grapher handles circularities by
+creating a pair of `offpage' connectors.  This isn't as elegant as
+plotting circular paths backwards, but the current hack results in a
+clear visual diagram with little effort.  The offpage-connector-out-printer
+and offpage-connector-in-printer args to format-graph-from-roots are
+something of a crock -- perhaps we can avoid documenting them until
+better treatment of cyclic graphs is devised.  BTW, before this hack,
+a circular graph with no roots (i.e. all nodes have at least one parent)
+would blow the stack, so don't undertake a more ambitious fix for
+circular graphs without accounting for this case.
+
+|#
+
 (defclass directed-graph-output-record (basic-graph-output-record)
     ((n-generations :initform 0)))
 
 ;; For now, treat digraphs and DAGs the same way...
-;;
-;; With smh's hacks, cyclic digraphs get converted to dags automatically
-;; with the insertion of `offpage' connectors.
-;; This should be conditionalized, with options for also trying to thread
-;; the cycle path neatly backwards -- but it's too tricky for right now.
-;; Contact me for my thoughts on the matter. 19Nov92 -smh
-
 (define-graph-type :directed-graph directed-graph-output-record)
 (define-graph-type :digraph directed-graph-output-record)
 (define-graph-type :directed-acyclic-graph directed-graph-output-record)
 (define-graph-type :dag directed-graph-output-record)
 
-;; These implement the dummy nodes inserted when an arc must span
-;; more than one generation.
-(defclass graph-node-filler-output-record (standard-graph-node-output-record) ())
+;; These implement the dummy nodes inserted when an arc must span more
+;; than one generation.
+(defclass graph-node-filler-output-record   (standard-graph-node-output-record) ())
 (defclass graph-node-filler-output-record-1 (standard-graph-node-output-record) ())
 
 ;; These implement the `offpage' connectors for cyclic graphs.
 (defclass graph-node-connector-output-record
-    (standard-graph-node-output-record)
+	  (standard-graph-node-output-record)
     ((id :accessor connector-id :initarg :connector-id)))
-(defclass graph-node-connector-in-output-record  (graph-node-connector-output-record) ())
-(defclass graph-node-connector-out-output-record (graph-node-connector-output-record) ())
-
-(defmethod generate-graph-nodes ((graph directed-graph-output-record)
-				 stream
+(defclass graph-node-connector-in-output-record (graph-node-connector-output-record) 
+    () 
+  (:default-initargs :object nil))
+(defclass graph-node-connector-out-output-record (graph-node-connector-output-record)
+	  ()
+  (:default-initargs :object nil))
+
+(defmethod generate-graph-nodes ((graph directed-graph-output-record) stream
 				 root-objects object-printer inferior-producer
-				 &key duplicate-key duplicate-test
-				 offpage-connector-out-printer
-				 offpage-connector-in-printer)
+				 &key duplicate-key duplicate-test store-objects
+				      offpage-connector-out-printer
+				      offpage-connector-in-printer)
   (declare (dynamic-extent object-printer inferior-producer))
   (declare (ignore duplicate-test))
-  (let ((hash-table (slot-value graph 'hash-table))
-	(cutoff-depth (slot-value graph 'cutoff-depth))
-	(root-nodes '())
-	(connectors-in '()))
-    (labels ((inferior-mapper (function node)
-	       (map nil function (funcall inferior-producer node)))
-	     (new-node-function (parent-object parent-record child-object)
-	       (let ((child-record
-		      (with-stream-cursor-position-saved (stream)
-		      (with-new-output-record
-			  (stream 'standard-graph-node-output-record)
-			(funcall object-printer child-object stream)))))
-		 ;; This guarantees that the next phase will have at least one node
-		 ;; from which to start.  Otherwise the entire graph gets lost.
-		 ;; If the first node isn't really a root, it will be deleted from
-		 ;; the set of roots when the cycle is detected.
-		 (when (null root-nodes)
-		   (push child-record root-nodes))
-		 (old-node-function parent-object parent-record child-object child-record)))
-	     (old-node-function (parent-object parent-record child-object child-record)
-	       (declare (ignore parent-object child-object))
-	       ;; Preserve the ordering of the nodes
-	       ;; Generation numbers are now computed later -smh.
-	       (when parent-record
-		 (unless (member parent-record (graph-node-parents child-record))
-		   (setf (graph-node-parents child-record)
-		     (nconc (graph-node-parents child-record)
-			    (list parent-record))))
-		 (unless (member child-record (graph-node-children parent-record))
-		   (setf (graph-node-children parent-record)
-		     (nconc (graph-node-children parent-record)
-			    (list child-record)))))
-	       child-record))
-      (declare (dynamic-extent #'inferior-mapper #'new-node-function #'old-node-function))
-      (traverse-graph root-objects #'inferior-mapper
-		      hash-table duplicate-key
-		      #'new-node-function #'old-node-function
-		      cutoff-depth))
-    (map-node-table #'(lambda (key node)
-			(declare (ignore key))
-			(when (and (typep node 'graph-node-output-record)
-				   (null (graph-node-parents node)))
-			  (pushnew node root-nodes)))
-		    hash-table)
-    (labels ((break-cycles (node &optional path)
-	       (do ((c (graph-node-children node) (cdr c)))
-		   ((null c))
-		 (let ((child (car c)))
-		   (if (member child path)
-		       (let* ((id (connector-id
-				   (or (find child connectors-in
-					     :key #'(lambda (x)
-						      (car (graph-node-children x))))
-				       (let* ((id (1+ (length connectors-in)))
-					      (rec (with-new-output-record
-						       (stream
-							'graph-node-connector-in-output-record
-							nil :connector-id id)
-						     (funcall offpage-connector-in-printer
-							      stream id))))
-					 (push rec connectors-in)
-					 (setf (graph-node-children rec) (list child))
-					 ;; What about ordering?
-					 (push rec (graph-node-parents child))
-					 (setf root-nodes (delete child root-nodes))
-					 rec)))))
-			 (setf (car c)
+  (with-slots (n-generations) graph
+    (let* ((hash-table (slot-value graph 'hash-table))
+	   (graph-type (slot-value graph 'graph-type))
+	   (properties (slot-value graph 'properties))
+	   (cutoff-depth (getf properties :cutoff-depth))
+	   (maximize-generations (getf properties :maximize-generations))
+	   (root-nodes nil)
+	   (connectors-in nil))
+      (labels ((inferior-mapper (function node)
+		 (map nil function (funcall inferior-producer node)))
+	       (new-node-function (parent-object parent-record child-object)
+		 (let ((child-record
+			 (with-stream-cursor-position-saved (stream)
 			   (with-new-output-record
-			       (stream 'graph-node-connector-out-output-record nil
-				:connector-id id)
-			     (funcall offpage-connector-out-printer stream id))))
+			       (stream 'standard-graph-node-output-record nil
+				:object (and store-objects child-object))
+			     (funcall object-printer child-object stream)))))
+		   ;; This guarantees that the next phase will have at least one
+		   ;; node from which to start.  Otherwise the entire graph gets
+		   ;; lost.  If the first node isn't really a root, it will be
+		   ;; deleted from the set of roots when the cycle is detected.
+		   (when (null root-nodes)
+		     (push child-record root-nodes))
+		   (old-node-function parent-object parent-record child-object child-record)))
+	       (old-node-function (parent-object parent-record child-object child-record)
+		 (declare (ignore parent-object child-object))
+		 (unless maximize-generations
+		   (let ((old-generation (graph-node-generation child-record)))
+		     ;; Set the generation of this node to 1 greater than the parent,
+		     ;; and keep track of the highest generation encountered.
+		     (maxf n-generations
+			   (maxf (graph-node-generation child-record)
+				 (if parent-record
+				     (1+ (graph-node-generation parent-record))
+				     0)))
+		     ;; If the child-record got its generation adjusted, then we must
+		     ;; adjust the generation-number of already-processed children,
+		     ;; and their children, etc.
+		     (unless (eql (graph-node-generation child-record) old-generation)
+		       (increment-generation child-record))))
+		 ;; Preserve the ordering of the nodes.  Generation numbers are
+		 ;; computed later in the case when MAXIMIZE-GENERATIONS is T.
+		 (when parent-record
+		   (unless (member parent-record (graph-node-parents child-record))
+		     (setf (graph-node-parents child-record)
+			   (nconc (graph-node-parents child-record)
+				  (list parent-record))))
+		   (unless (member child-record (graph-node-children parent-record))
+		     (setf (graph-node-children parent-record)
+			   (nconc (graph-node-children parent-record)
+				  (list child-record)))))
+		 child-record)
+	       (increment-generation (record)
+		 (let ((new-generation (1+ (graph-node-generation record))))
+		   (dolist (child (graph-node-children record))
+		     ;; Remember which generation the child belonged to.
+		     (let ((old-generation (graph-node-generation child)))
+		       (maxf n-generations
+			     (maxf (graph-node-generation child) new-generation))
+		       ;; If it has changed, fix up the next generation recursively.
+		       (unless (eql (graph-node-generation child) old-generation)
+			 (increment-generation child)))))))
+	(declare (dynamic-extent #'inferior-mapper #'increment-generation
+				 #'new-node-function #'old-node-function))
+	(traverse-graph root-objects #'inferior-mapper
+			hash-table duplicate-key
+			#'new-node-function #'old-node-function
+			cutoff-depth))
+      (map-node-table #'(lambda (key node)
+			  (declare (ignore key))
+			  (when (and (typep node 'graph-node-output-record)
+				     (null (graph-node-parents node)))
+			    (pushnew node root-nodes)))
+		      hash-table)
+      (when (and (member graph-type '(:directed-graph :digraph))
+		 offpage-connector-in-printer offpage-connector-out-printer)
+	(labels 
+	  ((break-cycles (node &optional path)
+	     (do ((c (graph-node-children node) (cdr c)))
+		 ((null c))
+	       (let ((child (car c)))
+		 (if (member child path)
+		     (let* ((id (connector-id
+				  (or (find child connectors-in
+					    :key #'(lambda (x)
+						     (car (graph-node-children x))))
+				      (let* ((id (1+ (length connectors-in)))
+					     (rec (with-new-output-record
+						      (stream 'graph-node-connector-in-output-record nil
+						       :connector-id id)
+						    (funcall offpage-connector-in-printer
+							     stream id))))
+					(push rec connectors-in)
+					(setf (graph-node-children rec) (list child))
+					;;--- What about ordering?
+					(push rec (graph-node-parents child))
+					(setf root-nodes (delete child root-nodes))
+					rec)))))
+		       (setf (car c)
+			     (with-new-output-record
+				 (stream 'graph-node-connector-out-output-record nil
+				  :connector-id id)
+			       (funcall offpage-connector-out-printer stream id))))
 		     (break-cycles child (cons node path)))))))
-      (declare (dynamic-extent #'break-cycles))
-      (map nil #'break-cycles (copy-list root-nodes)))
-    (setf (slot-value graph 'root-nodes) (nconc (nreverse connectors-in)
-						(nreverse root-nodes)))
-    #+never
-    (let ((root-nodes nil))
-      (flet ((find-roots (key node)
-	       (declare (ignore key))
-	       (when (and (graph-node-output-record-p node)
-			  (null (graph-node-parents node)))
-		 (push node root-nodes))))
-	(declare (dynamic-extent #'find-roots))
-	(map-node-table #'find-roots hash-table))
-      (setf (graph-root-nodes graph) (nreverse root-nodes))))
-  (compute-graph-effective-generations graph)
-  (add-graph-filler-output-records graph stream)
+	  (declare (dynamic-extent #'break-cycles))
+	  (map nil #'break-cycles (copy-list root-nodes))))
+      (setf (slot-value graph 'root-nodes) 
+	    (nconc (nreverse connectors-in) (nreverse root-nodes)))
+      (when maximize-generations
+	(compute-graph-effective-generations graph)
+	(add-graph-filler-output-records graph stream))))
   graph)
 
 (defmethod compute-graph-effective-generations ((graph directed-graph-output-record))
-  (with-slots (n-generations root-nodes) graph
+  (with-slots (root-nodes n-generations) graph
     (labels ((traverse (node ply)
 	       (with-slots (generation) node
 		 (maxf generation ply)
 		 (let ((children (graph-node-children node))
 		       (gen1 (1+ generation)))
-		   (if children		;Save time -- do one or the other.
+		   (if children			;save time -- do one or the other
 		       (dolist (child children)
 			 (traverse child gen1))
-		     (maxf n-generations generation))))))
+		       (maxf n-generations generation))))))
+      (declare (dynamic-extent #'traverse))
       (dolist (root root-nodes)
 	(traverse root 0)))))
 
@@ -644,16 +647,17 @@ for this case.
 		     ((null c))
 		   (let ((child (car c)))
 		     (if (> (graph-node-generation child) gen1)
-			 (progn
-			   (let ((filler (with-new-output-record
-					     (stream 'graph-node-filler-output-record)
-					   nil)))
-			     (setf (graph-node-children filler) (list child)
-				   (graph-node-parents filler) (list node)
-				   (car c) filler
-				   (graph-node-generation filler) gen1)
-			     (traverse filler)))
-		       (traverse child)))))))
+			 (let ((filler (with-new-output-record
+					   (stream 'graph-node-filler-output-record)
+					 nil)))
+			   (setf (graph-node-children filler) (list child)
+				 (graph-node-parents filler)  (list node)
+				 (graph-node-object filler) (graph-node-object node)
+				 (car c) filler
+				 (graph-node-generation filler) gen1)
+			   (traverse filler))
+			 (traverse child)))))))
+      (declare (dynamic-extent #'traverse))
       (dolist (root root-nodes)
 	(traverse root)))))
 
@@ -669,14 +673,18 @@ for this case.
   (edge-breadth-separation nil)		;margin whitespace
   (touched nil))			;if T, use inner breadth separation
 
-(defmethod layout-graph-nodes ((graph directed-graph-output-record)
-			       stream arc-drawer arc-drawing-options)
-  (with-slots (orientation center-nodes
-	       generation-separation within-generation-separation n-generations
-	       root-nodes hash-table) graph
+(defmethod layout-graph-nodes ((graph directed-graph-output-record) stream
+			       arc-drawer arc-drawing-options)
+  (with-slots (root-nodes hash-table n-generations) graph
     (when root-nodes
-      (let ((start-x (coordinate 0))
-	    (start-y (coordinate 0)))
+      (let* ((properties (slot-value graph 'properties))
+	     (orientation (getf properties :orientation))
+	     (center-nodes (getf properties :center-nodes))
+	     (generation-separation (getf properties :generation-separation))
+	     (within-generation-separation (getf properties :within-generation-separation))
+	     (maximize-generations (getf properties :maximize-generations))
+	     (start-x (coordinate 0))
+	     (start-y (coordinate 0)))
 	(flet ((inferior-mapper (function node)
 		 (map nil function (graph-node-children node)))
 	       (yx-output-record-set-position (record y x)
@@ -717,38 +725,38 @@ for this case.
 			   (maxf (generation-depth descr) (depth child-node)))))
 		  (declare (dynamic-extent #'collect-node-size))
 		  (traverse #'collect-node-size))
-
-	      ;; Replace all filler nodes, giving them the max depth in their generation.
-	      (labels
-		  ((replace-filler-nodes (parent)
-		     (let ((children (graph-node-children parent)))
-		       (do ((c children (cdr c)))
-			   ((null c))
-			 (let ((node (car c)))
-			   (when (typep node 'graph-node-filler-output-record)
-			     (delete-output-record node graph)
-			     (let* ((depth (generation-depth
-					    (assoc (graph-node-generation node)
-						   generation-descriptors)))
-				    (new (with-output-to-output-record
-					     (stream 'graph-node-filler-output-record-1)
-					   (call-arc-drawer stream arc-drawer
-						    ;;--- Should be from- and to-node
-						    nil nil
-						    parent 0 0
-						    node depth 0
-						    arc-drawing-options)))
-				    (child (car (graph-node-children node))))
-			       (setf (graph-node-generation new) (graph-node-generation node)
-				     (graph-node-children new) (graph-node-children node)
-				     (graph-node-parents new) (graph-node-parents node)
-				     (graph-node-parents child) (list new)
-				     (car c) new)
-			       (add-output-record new graph)))))
-		       (map nil #'replace-filler-nodes children))))
-		(declare (dynamic-extent #'replace-filler-nodes))
-		(map nil #'replace-filler-nodes root-nodes))
-
+		;; Replace all filler nodes, giving them the max depth in their generation.
+		(when maximize-generations
+		  (labels
+		    ((replace-filler-nodes (parent)
+		       (let ((children (graph-node-children parent)))
+			 (do ((c children (cdr c)))
+			     ((null c))
+			   (let ((node (car c)))
+			     (when (typep node 'graph-node-filler-output-record)
+			       (delete-output-record node graph)
+			       (let* ((depth (generation-depth
+					       (assoc (graph-node-generation node)
+						      generation-descriptors)))
+				      (new (with-new-output-record
+					       (stream 'graph-node-filler-output-record-1 nil
+						:parent graph)
+					     (call-arc-drawer stream arc-drawer
+							      (graph-node-object parent)
+							      (graph-node-object node)
+							      parent 0 0
+							      node depth 0
+							      arc-drawing-options)))
+				      (child (car (graph-node-children node))))
+				 (setf (graph-node-generation new) (graph-node-generation node)
+				       (graph-node-children new) (graph-node-children node)
+				       (graph-node-parents new) (graph-node-parents node)
+				       (graph-node-parents child) (list new)
+				       (graph-node-object new) (graph-node-object node)
+				       (car c) new)))))
+			 (map nil #'replace-filler-nodes children))))
+		    (declare (dynamic-extent #'replace-filler-nodes))
+		    (map nil #'replace-filler-nodes root-nodes)))
 		;; Determine max-breadth and starting-depth
 		(loop with depth-so-far = start-depth
 		      for descr in generation-descriptors do
@@ -788,61 +796,62 @@ for this case.
 		  (declare (dynamic-extent #'place-node))
 		  (traverse #'place-node))))))))))
 
-(defmethod layout-graph-edges ((graph directed-graph-output-record) 
-			       stream arc-drawer arc-drawing-options)
-  (with-slots (orientation root-nodes hash-table) graph
-    (when root-nodes
-      (flet ((inferior-mapper (function node)
-	       (map nil function (graph-node-children node)))
-	     (north (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (declare (ignore bottom))
-		 (values (floor (+ right left) 2) (1- top))))
-	     (south (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (declare (ignore top))
-		 (values (floor (+ right left) 2) (1+ bottom))))
-	     (west (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (declare (ignore right))
-		 (values (1- left) (floor (+ top bottom) 2))))
-	     (east (node)
-	       (with-bounding-rectangle* (left top right bottom) node
-		 (declare (ignore left))
-		 (values (1+ right) (floor (+ top bottom) 2)))))
-	(declare (dynamic-extent #'inferior-mapper #'north #'south #'west #'east))
-	(multiple-value-bind (parent-attach child-attach)
-	    (ecase orientation
-	      ((:vertical :down) (values #'south #'north))
-	      ((:up) (values #'north #'south))
-	      ((:horizontal :right) (values #'east #'west))
-	      ((:left) (values #'west #'east)))
-	  (multiple-value-bind (xoff yoff)
-	      (convert-from-relative-to-absolute-coordinates
-		stream (output-record-parent graph))
-	    (with-identity-transformation (stream)
-	      (with-output-recording-options (stream :draw nil :record t)
-		(with-new-output-record (stream 'standard-sequence-output-record nil
-					 :parent graph)
-		  (labels ((draw-edge (parent ph child &optional ch)
-			     (declare (ignore ph ch))
-			     (when parent
-			       (multiple-value-bind (parent-x parent-y)
-				   (funcall parent-attach parent)
-				 (multiple-value-bind (child-x child-y)
-				     (funcall child-attach child)
-				   (translate-coordinates xoff yoff
-				     parent-x parent-y child-x child-y)
-				   (call-arc-drawer stream arc-drawer
-						    ;;--- Should be from- and to-node
-						    nil nil
-						    parent parent-x parent-y
-						    child child-x child-y
-						    arc-drawing-options))))))
-		    (declare (dynamic-extent #'draw-edge)) 
-		    (traverse-graph root-nodes #'inferior-mapper
-				    hash-table #'identity
-				    #'draw-edge #'draw-edge)))))))))))
+(defmethod layout-graph-edges ((graph directed-graph-output-record) stream
+			       arc-drawer arc-drawing-options)
+  (with-slots (root-nodes hash-table properties) graph
+    (let ((orientation (getf properties :orientation)))
+      (when root-nodes
+	(flet ((inferior-mapper (function node)
+		 (map nil function (graph-node-children node)))
+	       (north (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (declare (ignore bottom))
+		   (values (floor (+ right left) 2) (1- top))))
+	       (south (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (declare (ignore top))
+		   (values (floor (+ right left) 2) (1+ bottom))))
+	       (west (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (declare (ignore right))
+		   (values (1- left) (floor (+ top bottom) 2))))
+	       (east (node)
+		 (with-bounding-rectangle* (left top right bottom) node
+		   (declare (ignore left))
+		   (values (1+ right) (floor (+ top bottom) 2)))))
+	  (declare (dynamic-extent #'inferior-mapper #'north #'south #'west #'east))
+	  (multiple-value-bind (parent-attach child-attach)
+	      (ecase orientation
+		((:vertical :down) (values #'south #'north))
+		((:up) (values #'north #'south))
+		((:horizontal :right) (values #'east #'west))
+		((:left) (values #'west #'east)))
+	    (multiple-value-bind (xoff yoff)
+		(convert-from-relative-to-absolute-coordinates
+		  stream (output-record-parent graph))
+	      (with-identity-transformation (stream)
+		(with-output-recording-options (stream :draw nil :record t)
+		  (with-new-output-record (stream 'standard-sequence-output-record nil
+					   :parent graph)
+		    (labels ((draw-edge (parent ph child &optional ch)
+			       (declare (ignore ph ch))
+			       (when parent
+				 (multiple-value-bind (parent-x parent-y)
+				     (funcall parent-attach parent)
+				   (multiple-value-bind (child-x child-y)
+				       (funcall child-attach child)
+				     (translate-coordinates xoff yoff
+				       parent-x parent-y child-x child-y)
+				     (call-arc-drawer stream arc-drawer
+						      (graph-node-object parent) 
+						      (graph-node-object child)
+						      parent parent-x parent-y
+						      child child-x child-y
+						      arc-drawing-options))))))
+		      (declare (dynamic-extent #'draw-edge)) 
+		      (traverse-graph root-nodes #'inferior-mapper
+				      hash-table #'identity
+				      #'draw-edge #'draw-edge))))))))))))
 
 ;; ROOT-OBJECTS is a sequence of the roots of the graph.  
 ;; INFERIOR-MAPPER is a function of two arguments, a function and an object
@@ -874,7 +883,7 @@ for this case.
 	       (funcall new-node-function parent-object parent-hashval object)))
 	 (setf (get-node-table (funcall key object) hash-table) object-hashval)
 	 (when max-depth (decf max-depth))
-	 (unless (eql max-depth 0)
+	 (unless (eq max-depth 0)
 	   (flet ((traverse1 (child-object)
 		    (let ((child-key (funcall key child-object)))
 		      (multiple-value-bind (child-hashval found)
@@ -889,3 +898,4 @@ for this case.
     (map nil #'(lambda (root)
 		 (traverse nil nil root max-depth))
 	 root-objects)))
+
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index d6a9b5417c1ec486c3b13ac1856a9cdd0dc01018..dcaba5b617e12b73e262aeb58f77f92f8903dc04 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.34 92/12/01 09:45:20 cer Exp $
+;; $fiHeader: input-protocol.lisp,v 1.35 92/12/03 10:26:58 cer Exp $
 
 (in-package :clim-internals)
 
@@ -379,6 +379,7 @@
   (process-abort-or-accelerator-gesture stream gesture)
   gesture)
 
+
 (defun process-abort-or-accelerator-gesture (stream gesture)
   (cond ((member gesture *accelerator-gestures*
 		 :test #'keyboard-event-matches-gesture-name-p)
@@ -416,6 +417,8 @@
 		     (force-output stream))))))
 	 (error 'abort-gesture :event gesture))))
 
+
+
 ;;; This function is just a convenience for the programmer, defaulting the
 ;;; keyword :STREAM argument to *standard-input*.  The application can call
 ;;; stream-read-gesture directly.
diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp
index 06fc4ff528879576baf287aac5220b88197550f5..f8df0b69330faec3eed7cd6923da87bb3343b116 100644
--- a/clim/standard-types.lisp
+++ b/clim/standard-types.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: standard-types.lisp,v 1.21 92/11/20 08:44:58 cer Exp $
+;; $fiHeader: standard-types.lisp,v 1.22 92/12/03 10:27:49 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1468,7 +1468,7 @@
 				(subseq string index))))
 	expression))))
 
-r(define-presentation-method present (object (type expression) stream (view textual-view)
+(define-presentation-method present (object (type expression) stream (view textual-view)
 				     &key (acceptably *print-readably*))
   (print-recursive object stream :make-presentation nil :readably acceptably))
 
@@ -1481,18 +1481,23 @@ r(define-presentation-method present (object (type expression) stream (view text
 ;;--- Maybe this should have WRITE options
 (define-presentation-type form ()
   :options ((auto-activate nil boolean))
-  :inherit-from `((expression) :auto-activate ,auto-activate))
+  ;; Handling of AUTO-ACTIVATE is done below...
+  :inherit-from `expression)
 
 (define-presentation-method presentation-type-history ((type form))
   ;; Share history with EXPRESSION
   (presentation-type-history-for-frame 'expression *application-frame*))
 
 (define-presentation-method map-over-presentation-type-supertypes ((type form) function)
-  (map-over-presentation-type-supertypes-augmented type function
-    ;; Include COMMAND-OR-FORM in the supertypes
-    (with-stack-list (new-type 'command-or-form
+  (with-presentation-type-decoded (name) type
+    (funcall function name type)
+    (with-stack-list (new-name 'command-or-form 
 			       :command-table (frame-command-table *application-frame*))
-      (funcall function 'command-or-form new-type))))
+      (with-stack-list (new-type new-name :auto-activate auto-activate)
+	(funcall function 'command-or-form new-type))
+      (with-stack-list (new-name 'expression)
+	(with-stack-list (new-type new-name :auto-activate auto-activate)
+	  (map-over-presentation-type-supertypes new-type function))))))
 
 (defvar *char-associations* '((#\( . #\))
 			      (#\" . #\")
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index 469ff4505524d5165ebf5c32ebb94d39209dd8dd..14da7dc2db626ab059fdc9005a9f7df74dc7edc8 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.15 92/11/06 19:03:27 cer Exp $
+;; $fiHeader: compile-1.lisp,v 1.16 92/11/09 10:55:28 cer Exp $
 
 (in-package :user)
 
@@ -40,8 +40,6 @@
   (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)
diff --git a/misc/train.lisp b/misc/train.lisp
index 895da43c8a1410811330d76afc6901b1f6dd3bbb..ddafff5ac70869f7543e14007ec2e6d20cf18c9b 100644
--- a/misc/train.lisp
+++ b/misc/train.lisp
@@ -20,12 +20,13 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: train.lisp,v 1.1 92/12/01 09:46:08 cer Exp $
 
-(defun train-clim (&key (train-times 2) (psview nil))
+(defun train-clim (&key (train-times 2) (psview nil) (frame-tests t))
   (load "test/test.lisp") 
-  (clim-user::train-clim-2 train-times) 
-  (clim-user::do-frame-tests) 
+  (when frame-tests
+    (clim-user::train-clim-2 train-times) 
+    (clim-user::do-frame-tests))
   (when psview
     (load "test/postscript-tests.lisp")
     (clim-user::run-postscript-tests :output psview))
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 8e556380b541893ebef5a785833c5116afb10511..592f7a4ffd6985e713cca1b75db3cb9d6286f4e8 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: classes.lisp,v 1.25 92/12/01 09:46:13 cer Exp $
+;; $fiHeader: classes.lisp,v 1.26 92/12/03 10:29:12 cer Exp $
 
 (in-package :silica)
 
@@ -129,7 +129,6 @@
   ((timestamp :reader event-timestamp
 	      :initform (atomic-incf *event-timestamp*) :initarg :timestamp)))
 
-
 (define-event-class device-event (event) 
   ((sheet :reader event-sheet :initarg :sheet)
    (modifier-state :reader event-modifier-state
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index d479933c7abe561b1c07bc61556acd0ffd5107cf..77fb5d5c234b358509d258686a90f332fb5a5b55 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.36 92/12/01 09:46:20 cer Exp $
+;; $fiHeader: db-scroll.lisp,v 1.37 92/12/03 10:29:18 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -24,17 +24,6 @@
 				   :accessor scroller-pane-gadget-supplies-scrolling-p))
   (:default-initargs :scroll-bars :both))
 
-;; An implementation of a scroller pane
-(defclass generic-scroller-pane (scroller-pane 
-				 client-space-requirement-mixin
-				 wrapping-space-mixin
-				 permanent-medium-sheet-output-mixin
-				 pane-repaint-background-mixin
-				 layout-pane)
-    ())
-
-(defmethod handle-event :after ((pane generic-scroller-pane) (event pointer-motion-event))
-  (deallocate-event event))
 
 ;; Returns the viewport of the pane, if there is one
 (defmethod pane-viewport ((sheet sheet))
@@ -69,97 +58,6 @@
   (declare (ignore frame-manager frame ignore contents))
   nil)
 
-(defmethod allocate-space :before ((scroller generic-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 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 generic-scroller-pane) &key width height)
-  (declare (ignore width height))
-  (let ((sr (call-next-method)))
-    (multiple-value-bind (width min-width max-width
-			  height min-height max-height)
-	(space-requirement-components sr)
-      (if (or (< width 50) (< height 50))
-	  ;; Make sure the scroller pane is big enough to hold something
-	  (make-space-requirement
-	    :width (max width 50)
-	    :min-width (max min-width 50)
-	    :max-width (max max-width 50)
-	    :height (max height 50)
-	    :min-height (max min-height 50)
-	    :max-height (max max-height 50))
-	  sr))))
-
-;;--- 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 generic-scroller-pane) 
-				       &key contents frame-manager frame
-					    scroll-bars)
-  (let ((scroller (gadget-supplied-scrolling frame-manager frame contents
-					     :scroll-bars scroll-bars)))
-    (if scroller
-	(progn
-	  (sheet-adopt-child pane scroller)
-	  (setf (slot-value pane 'scrolling-supplied-by-gadget) t)
-	  scroller)
-	(progn
-	  (check-type scroll-bars
-		      (member t :both :dynamic :vertical :horizontal))
-	  (with-slots (vertical-scroll-bar horizontal-scroll-bar
-		       (c contents) viewport foreground background) pane
-	    (with-look-and-feel-realization (frame-manager frame)
-	      (let ((verticalp
-		      (member scroll-bars '(t :both :dynamic :vertical)))
-		    (horizontalp
-		      (member scroll-bars '(t :both :dynamic :horizontal))))
-		(setf vertical-scroll-bar 
-		      (and verticalp
-			   (make-pane 'scroll-bar 
-			     :orientation :vertical
-			     :id :vertical
-			     :client pane
-			     :background background
- 			     :foreground foreground
-			     :shared-medium-sheet pane))
-		      horizontal-scroll-bar 	    
-		      (and horizontalp
-			   (make-pane 'scroll-bar 
-			     :orientation :horizontal
-			     :id :horizontal
-			     :background background
- 			     :foreground foreground
-			     :client pane
-			     :shared-medium-sheet pane))
-		      c contents
-		      viewport (make-pane 'viewport :scroller-pane pane))
-		(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
-		)))))))
-
 (defvar *inhibit-updating-scroll-bars* nil)
 (defmacro inhibit-updating-scroll-bars ((stream) &body body)
   `(unwind-protect
@@ -359,440 +257,9 @@
 	      (note-viewport-position-changed frame sheet))))))))
 
 (defmethod note-viewport-position-changed (frame pane)
+  (declare (ignore frame pane))
   nil)
 
-
-;;; Home-grown scroll bars
-
-(defparameter *scroll-shaft-thickness-ink* 12)
-
-;;--- unit-increment, page-increment.
-(defclass scroll-bar-pane
-	  (scroll-bar
-	   sheet-permanently-enabled-mixin
-	   wrapping-space-mixin
-	   immediate-sheet-input-mixin
-	   sheet-multiple-child-mixin
-	   space-requirement-mixin
-	   shared-medium-sheet-output-mixin
-	   basic-pane)
-    ((shaft-thickness :initarg :shaft-thickness)
-     (min-target-pane :initform nil)
-     (max-target-pane :initform nil)
-     (shaft-pane :initform nil))
-  (:default-initargs :value 0
-		     :shaft-thickness *scroll-shaft-thickness-ink*))
-
-(defmethod initialize-instance :after ((pane scroll-bar-pane)
-				       &key orientation shaft-thickness
-					    frame-manager frame)
-  (with-slots (min-target-pane max-target-pane shaft-pane
-	       shared-medium-sheet foreground background) pane
-    (with-look-and-feel-realization (frame-manager frame)
-      (let ((inferiors
-	      (ecase orientation
-		(:vertical
-		  (spacing (:thickness 1)
-		    (vertically ()
-		      (setq min-target-pane
-			    (make-pane 'scroll-bar-target-pane
-			      :scroll-bar pane
-			      :end :less-than
-			      :width shaft-thickness
-			      :height shaft-thickness
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet))
-		      (setq shaft-pane 
-			    (make-pane 'scroll-bar-shaft-pane 
-			      :scroll-bar pane
-			      :width shaft-thickness
-			      :height 0
-			      :max-height +fill+
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet))
-		      (setq max-target-pane
-			    (make-pane 'scroll-bar-target-pane
-			      :scroll-bar pane
-			      :end :greater-than
-			      :width shaft-thickness
-			      :height shaft-thickness
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet)))))
-		(:horizontal
-		  (spacing (:thickness 1)
-		    (horizontally ()
-		      (setq min-target-pane
-			    (make-pane 'scroll-bar-target-pane
-			      :scroll-bar pane
-			      :end :less-than
-			      :width shaft-thickness
-			      :height shaft-thickness
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet))
-		      (setq shaft-pane 
-			    (make-pane 'scroll-bar-shaft-pane
-			      :scroll-bar pane
-			      :width 0
-			      :max-width +fill+
-			      :height shaft-thickness
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet))
-		      (setq max-target-pane
-			    (make-pane 'scroll-bar-target-pane
-			      :scroll-bar pane
-			      :end :greater-than
-			      :width shaft-thickness
-			      :height shaft-thickness
-			      :background background
-			      :foreground foreground
-			      :shared-medium-sheet shared-medium-sheet))))))))
-	(sheet-adopt-child pane inferiors)))))
-
-(defmethod handle-event :after ((pane scroll-bar-pane) (event pointer-event))
-  (deallocate-event event))
-
-
-(defmethod contents-range ((scroller scroller-pane) orientation)
-  (with-slots (viewport) scroller
-    (with-bounding-rectangle* (left top right bottom) 
-	(viewport-contents-extent viewport)
-      (ecase orientation
-	(:horizontal (- right left))
-	(:vertical (- bottom top))))))
-
-(defmethod viewport-range ((scroller scroller-pane) orientation)
-  (with-slots (viewport) scroller
-    (with-bounding-rectangle* (left top right bottom) 
-	(viewport-viewport-region viewport)
-      (ecase orientation
-	(:horizontal (- right left))
-	(:vertical (- bottom top))))))
-
-(defmethod line-scroll-amount ((pane scroller-pane) orientation direction)
-  (declare (ignore direction))
-  (with-slots (contents) pane
-    (let ((style (medium-text-style contents)))
-      ;; --- These are the stubs for user specified line scroll amounts
-      ;; req by graphic panes. I haven't enabled them because I want to
-      ;; check with SWM for the MAKE-PANE protocol for these. Davo 6/30/92
-      (ecase orientation
-	(:horizontal (or #+++ignore horizontal-line-scroll-amount
-			 (text-style-width style contents)))
-	(:vertical (or #+++ignore vertical-line-scroll-amount
-		       ;; --- This should check the top or bottom line
-		       ;; of the viewport for its line height to
-		       ;; determine the scroll amount - this is the
-		       ;; reason for the direction arg. Davo 6/30/92
-		       (+ (text-style-height style contents)
-			  (if (extended-output-stream-p contents)
-			      (stream-vertical-spacing contents) 
-			      0))))))))
-
-(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
-  (with-slots (current-size current-value port) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      (let* ((contents-range (contents-range scroller-pane orientation))
-	     (line-value (if (= contents-range 0)
-			     0
-			     (the single-float
-			       (/ (line-scroll-amount scroller-pane orientation :up)
-				  (float contents-range  0.0s0)))))
-	     (new-value (max 0.0 (- current-value line-value))))	
-	(scroll-bar-value-changed-callback
-	  scroll-bar scroller-pane orientation new-value current-size)))))
-
-(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
-  (with-slots (current-size current-value port) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      (let* ((contents-range (contents-range scroller-pane orientation))
-	     (line-value (if (= contents-range 0)
-			     0
-			     (the single-float
-			       (/ (line-scroll-amount scroller-pane orientation :down)
-				  (float contents-range  0.0s0)))))
-	     (new-value (min (- 1.0 current-size) (+ current-value line-value))))
-	(scroll-bar-value-changed-callback
-	  scroll-bar scroller-pane orientation new-value current-size)))))
-
-(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
-  (with-slots (current-size current-value) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      (let* ((contents-range (contents-range scroller-pane orientation))
-	     (viewport-range (bounding-rectangle-max-y viewport))
-	     new-value)
-	(if (zerop contents-range)
-	    (setq new-value current-value)
-	    (let ((page-value (the single-float 
-				(/ viewport-range (float contents-range 0.0s0)))))
-	      (setq new-value (max 0.0 (- current-value page-value)))))
-	(scroll-bar-value-changed-callback
-	  scroll-bar scroller-pane orientation new-value current-size)))))
-
-(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
-  (with-slots (current-size current-value) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      (let* ((contents-range (contents-range scroller-pane orientation))
-	     (viewport-range (bounding-rectangle-max-y viewport))
-	     new-value)
-      (if (zerop contents-range)
-	  (setq new-value current-value)
-	  (let ((page-value (the single-float 
-			      (/ viewport-range (float contents-range 0.0s0)))))
-	    (setq new-value (min (- 1.0 current-size) (+ current-value page-value)))))
-      (scroll-bar-value-changed-callback
-	scroll-bar scroller-pane orientation new-value current-size)))))
-
-(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id)
-  (with-slots (current-size current-value) scroll-bar
-    (scroll-bar-value-changed-callback scroll-bar client id 0 current-size)))
-
-(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id)
-  (with-slots (current-size current-value) scroll-bar
-    (scroll-bar-value-changed-callback
-      scroll-bar client id (- 1.0 current-size) current-size)))
-
-(defmethod scroll-line-to-top-callback ((scroll-bar scroll-bar-pane)
-					scroller-pane id orientation x y)
-  (with-slots (current-size current-value) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      ;; --- scroll-bar may not be the right thing if it's not the same
-      ;; size as the contents pane - Davo 6/30/92.
-      (with-bounding-rectangle* (left top right bottom)
-	  (sheet-region scroll-bar)
-	(with-bounding-rectangle* (vleft vtop vright vbottom)
-	    (viewport-viewport-region viewport) 
-	  (declare (ignore vright vbottom))
-	  (with-bounding-rectangle* (cleft ctop cright cbottom)
-	      (viewport-contents-extent viewport) 
-	    (declare (ignore cright cbottom))
-	    (let ((contents-range (contents-range scroller-pane orientation)))
-	      (unless (zerop contents-range)
-		(let* ((viewport-range (viewport-range scroller-pane orientation))
-		       (contents-min
-			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
-		       (viewport-min
-			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
-		       (mouse-offset
-			 (ecase orientation
-			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
-			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
-		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
-				  contents-min)
-			       contents-range)))
-		  (scroll-bar-value-changed-callback
-		    scroll-bar scroller-pane id
-		    (min (- 1.0 current-size) pos) current-size))))))))))
-
-(defmethod scroll-line-to-bottom-callback ((scroll-bar scroll-bar-pane)
-					   scroller-pane id orientation x y)
-  (with-slots (current-size current-value) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      ;; --- scroll-bar may not be the right thing if its not the same
-      ;; size as the contents pane - Davo 6/30/92.
-      (with-bounding-rectangle* (left top right bottom)
-	  (sheet-region scroll-bar)
-	(with-bounding-rectangle* (vleft vtop vright vbottom)
-	    (viewport-viewport-region viewport) 
-	  (declare (ignore vright vbottom))
-	  (with-bounding-rectangle* (cleft ctop cright cbottom)
-	      (viewport-contents-extent viewport) 
-	    (declare (ignore cright cbottom))
-	    (let ((contents-range (contents-range scroller-pane orientation)))
-	      (unless (zerop contents-range)
-		(let* ((viewport-range (viewport-range scroller-pane orientation))
-		       (contents-min
-			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
-		       (viewport-min
-			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
-		       (mouse-offset
-			 (ecase orientation
-			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
-			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
-		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
-				  viewport-range contents-min)
-			       contents-range)))
-		  (scroll-bar-value-changed-callback
-		    scroll-bar scroller-pane id (max 0 pos) current-size))))))))))
-
-(defmethod scroll-elevator-callback ((scroll-bar scroll-bar-pane)
-				     scroller-pane id orientation x y)
-  (with-slots (current-size current-value) scroll-bar
-    (with-slots (viewport contents) scroller-pane
-      ;; --- scroll-bar may not be the right thing if its not the same
-      ;; size as the contents pane - Davo 6/30/92.
-      (with-bounding-rectangle* (left top right bottom)
-	  (sheet-region scroll-bar)
-	(let* ((mouse-offset
-		 (- (ecase orientation
-		      (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
-		      (:horizontal (/ (- x left) (float (- right left) 0.0s0))))
-		    (/ current-size 2.0s0))))
-	  (scroll-bar-value-changed-callback
-	    scroll-bar scroller-pane id (min 1.0s0 (max 0.0s0 mouse-offset)) current-size))))))
-
-;;; Set the indicator to the proper size and location (size and value are between 0 and 1)
-(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane)
-				     &key slider-size value)
-  (setf (gadget-value scroll-bar) value)
-  (setf (scroll-bar-current-size scroll-bar) slider-size))
-
-
-(defclass scroll-bar-target-pane 
-	  (immediate-sheet-input-mixin
-	   space-requirement-mixin
-	   sheet-single-child-mixin
-	   shared-medium-sheet-output-mixin
-	   foreground-background-and-text-style-mixin
-	   pane-repaint-background-mixin
-	   leaf-pane)
-    ((end :initarg :end)
-     (scroll-bar :initarg :scroll-bar)
-     (coord-cache :initform nil)))
-
-(defmethod initialize-instance :after ((pane scroll-bar-target-pane) &key end)
-  (let* ((scroll-bar (slot-value pane 'scroll-bar))
-	 (orientation (gadget-orientation scroll-bar)))
-    (setf (slot-value pane 'pointer-cursor)
-	  (ecase end
-	    (:less-than 
-	      (ecase orientation
-		(:horizontal :scroll-left)
-		(:vertical :scroll-up)))
-	    (:greater-than
-	      (ecase orientation
-		(:horizontal :scroll-right)
-		(:vertical :scroll-down)))))))
-
-(defmethod note-sheet-region-changed :after ((pane scroll-bar-target-pane)
-					     &key &allow-other-keys)
-  (setf (slot-value pane 'coord-cache) nil))
-
-(defmethod handle-repaint ((pane scroll-bar-target-pane) region)
-  (declare (ignore region))
-  (with-sheet-medium (medium pane)
-    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
-      (draw-rectangle* medium left top (1- right) (1- bottom)
-		       :filled nil :ink (medium-foreground medium)))
-    (draw-target pane medium)))
-
-;;; You can pass :FILLED T to this in order to highlight the target when clicked on...
-(defmethod draw-target ((pane scroll-bar-target-pane) medium
-			&key filled (ink +foreground-ink+))
-  (let ((coord-cache (slot-value pane 'coord-cache)))
-    (unless coord-cache
-      (let ((identity (sheet-pointer-cursor pane)))
-	(setq coord-cache
-	      (setf (slot-value pane 'coord-cache)
-		    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
-		      ;; This seems to be a kludge to deal with roundoff?
-		      (decf right) (decf bottom)
-		      ;; Indent the target arrows a little for aesthetic purposes
-		      (incf left 2) (decf right 2)
-		      (incf top 2)  (decf bottom 2)
-		      (ecase identity
-			(:scroll-up
-			  (list left bottom
-				(+ left (/ (- right left) 2)) top
-				right bottom))
-			(:scroll-down
-			  (list left top
-				(+ left (/ (- right left) 2)) bottom
-				right top))
-			(:scroll-left
-			  (list right top
-				left (/ (+ top bottom) 2)
-				right bottom))
-			(:scroll-right
-			  (list left top
-				right (/ (+ top bottom) 2)
-				left bottom))))))))
-    (draw-polygon* medium coord-cache :filled filled :ink ink)))
-
-(defclass scroll-bar-shaft-pane
-	  (immediate-sheet-input-mixin
-	   space-requirement-mixin
-	   sheet-single-child-mixin
-	   shared-medium-sheet-output-mixin
-	   foreground-background-and-text-style-mixin
-	   pane-repaint-background-mixin
-	   leaf-pane)
-    ((scroll-bar :initarg :scroll-bar)
-     (needs-erase :initform nil)))
-
-(defmethod initialize-instance :after ((pane scroll-bar-shaft-pane) &key)
-  (let* ((scroll-bar (slot-value pane 'scroll-bar))
-	 (orientation (gadget-orientation scroll-bar)))
-    (setf (slot-value pane 'pointer-cursor)
-	  (ecase orientation
-	    (:horizontal :horizontal-scroll)
-	    (:vertical :vertical-scroll)))))
-
-(defmethod handle-repaint ((pane scroll-bar-shaft-pane) region)
-  (declare (ignore region))
-  (with-sheet-medium (medium pane)
-    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
-      (draw-rectangle* medium left top (1- right) (1- bottom)
-		       :filled nil :ink (medium-foreground medium)))
-    (draw-thumb pane medium)))
-
-(defparameter *scroll-bar-thumb-ink* (make-gray-color 2/3))
-
-(defmethod draw-thumb ((pane scroll-bar-shaft-pane) medium
-		       &key (ink +foreground-ink+))
-  (let ((needs-erase (slot-value pane 'needs-erase)))
-    (setf (slot-value pane 'needs-erase) (not (eq ink +background-ink+)))
-    (when (and (not needs-erase)
-	       (eq ink +background-ink+))
-      (return-from draw-thumb (values))))
-  (let* ((scroll-bar (slot-value pane 'scroll-bar))
-	 (scroll-value (gadget-value scroll-bar))
-	 (min-value (gadget-min-value scroll-bar))
-	 (max-value (gadget-max-value scroll-bar))
-	 (gadget-size (or (scroll-bar-current-size scroll-bar) 0))
-	 (gadget-range (abs (- max-value min-value)))
-	 (identity (sheet-pointer-cursor pane)))
-    (flet ((draw-car (medium left top right bottom which)
-	     (decf right) (decf bottom)
-	     (draw-rectangle* medium left top right bottom
-			      :filled t
-			      :ink (if (eq ink +foreground-ink+) *scroll-bar-thumb-ink* ink))
-	     (case which
-	       (:vertical-scroll
-		 (draw-line* medium left top right top :ink ink)
-		 (draw-line* medium left bottom right bottom :ink ink))
-	       (:horizontal-scroll
-		 (draw-line* medium left bottom left top :ink ink)
-		 (draw-line* medium right bottom right top :ink ink)))))
-      (declare (dynamic-extent #'draw-car))
-      (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
-	(let* ((height (- y2 y1))
-	       (width (- x2 x1))
-	       (scroll-range (ecase identity
-			       (:vertical-scroll height)
-			       (:horizontal-scroll width)))
-	       (car-size (max 10 (* scroll-range (/ gadget-size gadget-range))))
-	       (elevator-top (compute-symmetric-value 
-			       min-value max-value scroll-value 0
-			       scroll-range))
-	       (elevator-bottom (+ elevator-top car-size)))
-	  (ecase identity
-	    (:vertical-scroll
-	      (draw-car medium
-			(+ x1 1)           (+ y1 elevator-top)
-			(+ x1 width -1) (+ y1 elevator-bottom)
-			identity))
-	    (:horizontal-scroll
-	      (draw-car medium
-			elevator-top      (+ y1 1)
-			elevator-bottom   (+ y1 height -1)
-			identity))))))))
-
-
 ;;; Given min1, max1 and value1 which is between them it will return
 ;;; value2 which would be proportionally between min2 and max2.
 (defun compute-symmetric-value (min1 max1 value1 min2 max2)
@@ -801,122 +268,3 @@
 	 (fraction1 (if (zerop distance1) 0 (/ (- value1 min1) distance1))))
     (let ((x (+ min2 (* (- max2 min2) fraction1))))
       (if (integerp x) x (float x)))))
-
-(defmethod handle-event :around ((pane scroll-bar-target-pane) 
-				 (event pointer-button-press-event))
-  (with-sheet-medium (medium pane)
-    (draw-target pane medium :filled t :ink +foreground-ink+)
-    (call-next-method)
-    (draw-target pane medium :filled t :ink +background-ink+)
-    (draw-target pane medium :filled nil)))
-
-
-;;; This implements genera style scroll bars.
-;;; Vertical Scroll bars
-;;;    Top Target
-;;;       Left: Next Line   Middle: First Page   Right: Previous Line
-;;;    Bottom Target
-;;;       Left: Next Page   Middle: Last Page    Right: Previous Page
-(defmethod handle-event ((pane scroll-bar-target-pane) 
-			 (event pointer-button-press-event))
-  (let* ((scroll-bar (slot-value pane 'scroll-bar))
-	 (client (gadget-client scroll-bar))
-	 (id (gadget-id scroll-bar)))
-    (case (pointer-event-button event)
-      (#.+pointer-left-button+
-       (ecase (slot-value pane 'end)
-	 (:greater-than
-	   (scroll-down-page-callback scroll-bar client id))
-	 (:less-than
-	   (scroll-down-line-callback scroll-bar client id))))
-      (#.+pointer-middle-button+
-       (ecase (slot-value pane 'end)
-	 (:greater-than
-	   (scroll-to-bottom-callback scroll-bar client id))
-	 (:less-than
-	   (scroll-to-top-callback scroll-bar client id))))
-      (#.+pointer-right-button+
-       (ecase (slot-value pane 'end)
-	 (:greater-than
-	   (scroll-up-page-callback scroll-bar client id))
-	 (:less-than
-	   (scroll-up-line-callback scroll-bar client id)))))))
-
-(defmethod handle-event ((pane scroll-bar-shaft-pane) 
-			 (event pointer-button-press-event))
-  (let* ((x (pointer-event-x event))
-	 (y (pointer-event-y event))
-	 (scroll-bar (slot-value pane 'scroll-bar))
-	 (client (gadget-client scroll-bar))
-	 (id (gadget-id scroll-bar))
-	 (orientation (gadget-orientation scroll-bar)))
-    (case (pointer-event-button event)
-      (#.+pointer-left-button+
-       (scroll-line-to-top-callback
-	 scroll-bar client id orientation x y))
-      (#.+pointer-right-button+
-       (scroll-line-to-bottom-callback
-	 scroll-bar client id orientation x (- (bounding-rectangle-height scroll-bar) y)))
-      (#.+pointer-middle-button+
-       (scroll-elevator-callback
-	 scroll-bar client id orientation x y)))))
-
-(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-enter-event))
-  (frame-manager-display-pointer-documentation-string
-    (frame-manager pane) *pointer-documentation-output*
-    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
-      (:vertical
-	"L: This line to top; M: Proportional scrolling; R: Top line to here.")
-      (:horizontal
-	"L: This column to left edge; M: Proportional scrolling; R: Left edge to here."))))
-
-(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-enter-event))
-  (frame-manager-display-pointer-documentation-string
-    (frame-manager pane) *pointer-documentation-output*
-    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
-      (:vertical
-	(ecase (slot-value pane 'end)
-	  (:greater-than
-	    "L: Next screenful; M: Last screenful; R: previous screenful.")
-	  (:less-than
-	    "L: Next line; M: First screenful; R: Previous line.")))
-      (:horizontal
-	(ecase (slot-value pane 'end)
-	  (:greater-than
-	    "L: Next screenful; M: Last screenful; R: previous screenful.")
-	  (:less-than
-	    "L: Next column; M: First screenful; R: Previous column."))))))
-
-(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-exit-event))
-  (frame-manager-display-pointer-documentation-string 
-    (frame-manager pane) *pointer-documentation-output* nil))
-
-(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-exit-event))
-  (frame-manager-display-pointer-documentation-string 
-    (frame-manager pane) *pointer-documentation-output* nil))
-
-(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-event))
-  (deallocate-event event))
-
-(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-event))
-  (deallocate-event event))
-
-(defmethod update-scroll-bar-value ((pane scroll-bar-shaft-pane) scroll-bar coord min max)
-  (let* ((min-value (gadget-min-value scroll-bar))
-	 (max-value (gadget-max-value scroll-bar))
-	 (value (compute-symmetric-value min max coord min-value max-value)))
-    (setf (gadget-value scroll-bar) value)))
-
-(defmethod (setf gadget-value) (value (pane scroll-bar-pane) &key invoke-callback)
-  (declare (ignore invoke-callback))
-  (setf (slot-value pane 'value) value))
-
-(defmethod (setf gadget-value) :around (value (pane scroll-bar-pane) &key invoke-callback)
-  (declare (ignore value invoke-callback))
-  (if (port pane)
-      (let ((shaft-pane (slot-value pane 'shaft-pane)))
-	(with-sheet-medium (medium shaft-pane)
-	  (draw-thumb shaft-pane medium :ink +background-ink+)
-	  (call-next-method)
-	  (draw-thumb shaft-pane medium :ink +foreground-ink+)))
-      (call-next-method)))
diff --git a/silica/port.lisp b/silica/port.lisp
index a288041dcd103de5000f7c99a2b4fdee8e2b2218..743856ab23d4bd8f37258acfa78b403c60baa67d 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.25 92/11/19 14:25:03 cer Exp $
+;; $fiHeader: port.lisp,v 1.26 92/12/01 09:46:29 cer Exp $
 
 (in-package :silica)
 
@@ -136,6 +136,17 @@
 (defgeneric remove-watcher (port watcher))
 (defgeneric reset-watcher (watcher how))
 
+(define-event-class port-terminated (window-manager-event) 
+  ((condition :initarg :condition :reader port-terminated-condition)))
+
+(defmethod port-terminated ((port basic-port) condition)
+  ;;--- Should mark it as dead 
+  (setq *ports* (delete port *ports*))
+  (dolist (graft (port-grafts port))
+    (dolist (sheet (sheet-children graft))
+      (queue-event sheet (make-instance 'port-terminated 
+					:condition condition
+					:sheet sheet)))))
 
 
 ;;;;;;;;;;;;;;;;
diff --git a/silica/scroll-pane.lisp b/silica/scroll-pane.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..83f9c71092cb308f08d73fbc733fd3a6cf9372c7
--- /dev/null
+++ b/silica/scroll-pane.lisp
@@ -0,0 +1,666 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-scroll.lisp,v 1.36 92/12/01 09:46:20 cer Exp $
+
+"Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
+ Portions copyright(c) 1991, 1992 International Lisp Associates.
+ Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :silica)
+
+;; An implementation of a scroller pane
+(defclass generic-scroller-pane (scroller-pane 
+				 client-space-requirement-mixin
+				 wrapping-space-mixin
+				 permanent-medium-sheet-output-mixin
+				 pane-repaint-background-mixin
+				 layout-pane)
+    ())
+
+(defmethod handle-event :after ((pane generic-scroller-pane) (event pointer-motion-event))
+  (deallocate-event event))
+
+(defmethod allocate-space :before ((scroller generic-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 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 generic-scroller-pane) &key width height)
+  (declare (ignore width height))
+  (let ((sr (call-next-method)))
+    (multiple-value-bind (width min-width max-width
+			  height min-height max-height)
+	(space-requirement-components sr)
+      (if (or (< width 50) (< height 50))
+	  ;; Make sure the scroller pane is big enough to hold something
+	  (make-space-requirement
+	    :width (max width 50)
+	    :min-width (max min-width 50)
+	    :max-width (max max-width 50)
+	    :height (max height 50)
+	    :min-height (max min-height 50)
+	    :max-height (max max-height 50))
+	  sr))))
+
+;;--- 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 generic-scroller-pane) 
+				       &key contents frame-manager frame
+					    scroll-bars)
+  (let ((scroller (gadget-supplied-scrolling frame-manager frame contents
+					     :scroll-bars scroll-bars)))
+    (if scroller
+	(progn
+	  (sheet-adopt-child pane scroller)
+	  (setf (slot-value pane 'scrolling-supplied-by-gadget) t)
+	  scroller)
+	(progn
+	  (check-type scroll-bars
+		      (member t :both :dynamic :vertical :horizontal))
+	  (with-slots (vertical-scroll-bar horizontal-scroll-bar
+		       (c contents) viewport foreground background) pane
+	    (with-look-and-feel-realization (frame-manager frame)
+	      (let ((verticalp
+		      (member scroll-bars '(t :both :dynamic :vertical)))
+		    (horizontalp
+		      (member scroll-bars '(t :both :dynamic :horizontal))))
+		(setf vertical-scroll-bar 
+		      (and verticalp
+			   (make-pane 'scroll-bar 
+			     :orientation :vertical
+			     :id :vertical
+			     :client pane
+			     :background background
+ 			     :foreground foreground
+			     :shared-medium-sheet pane))
+		      horizontal-scroll-bar 	    
+		      (and horizontalp
+			   (make-pane 'scroll-bar 
+			     :orientation :horizontal
+			     :id :horizontal
+			     :background background
+ 			     :foreground foreground
+			     :client pane
+			     :shared-medium-sheet pane))
+		      c contents
+		      viewport (make-pane 'viewport :scroller-pane pane))
+		(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
+		)))))))
+
+;;; Home-grown scroll bars
+
+(defparameter *scroll-shaft-thickness-ink* 12)
+
+;;--- unit-increment, page-increment.
+(defclass scroll-bar-pane
+	  (scroll-bar
+	   sheet-permanently-enabled-mixin
+	   wrapping-space-mixin
+	   immediate-sheet-input-mixin
+	   sheet-multiple-child-mixin
+	   space-requirement-mixin
+	   shared-medium-sheet-output-mixin
+	   basic-pane)
+    ((shaft-thickness :initarg :shaft-thickness)
+     (min-target-pane :initform nil)
+     (max-target-pane :initform nil)
+     (shaft-pane :initform nil))
+  (:default-initargs :value 0
+		     :shaft-thickness *scroll-shaft-thickness-ink*))
+
+(defmethod initialize-instance :after ((pane scroll-bar-pane)
+				       &key orientation shaft-thickness
+					    frame-manager frame)
+  (with-slots (min-target-pane max-target-pane shaft-pane
+	       shared-medium-sheet foreground background) pane
+    (with-look-and-feel-realization (frame-manager frame)
+      (let ((inferiors
+	      (ecase orientation
+		(:vertical
+		  (spacing (:thickness 1)
+		    (vertically ()
+		      (setq min-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :less-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq shaft-pane 
+			    (make-pane 'scroll-bar-shaft-pane 
+			      :scroll-bar pane
+			      :width shaft-thickness
+			      :height 0
+			      :max-height +fill+
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq max-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :greater-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet)))))
+		(:horizontal
+		  (spacing (:thickness 1)
+		    (horizontally ()
+		      (setq min-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :less-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq shaft-pane 
+			    (make-pane 'scroll-bar-shaft-pane
+			      :scroll-bar pane
+			      :width 0
+			      :max-width +fill+
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq max-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :greater-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))))))))
+	(sheet-adopt-child pane inferiors)))))
+
+(defmethod handle-event :after ((pane scroll-bar-pane) (event pointer-event))
+  (deallocate-event event))
+
+
+(defmethod contents-range ((scroller generic-scroller-pane) orientation)
+  (with-slots (viewport) scroller
+    (with-bounding-rectangle* (left top right bottom) 
+	(viewport-contents-extent viewport)
+      (ecase orientation
+	(:horizontal (- right left))
+	(:vertical (- bottom top))))))
+
+(defmethod viewport-range ((scroller generic-scroller-pane) orientation)
+  (with-slots (viewport) scroller
+    (with-bounding-rectangle* (left top right bottom) 
+	(viewport-viewport-region viewport)
+      (ecase orientation
+	(:horizontal (- right left))
+	(:vertical (- bottom top))))))
+
+(defmethod line-scroll-amount ((pane scroller-pane) orientation direction)
+  (declare (ignore direction))
+  (with-slots (contents) pane
+    (let ((style (medium-text-style contents)))
+      ;; --- These are the stubs for user specified line scroll amounts
+      ;; req by graphic panes. I haven't enabled them because I want to
+      ;; check with SWM for the MAKE-PANE protocol for these. Davo 6/30/92
+      (ecase orientation
+	(:horizontal (or #+++ignore horizontal-line-scroll-amount
+			 (text-style-width style contents)))
+	(:vertical (or #+++ignore vertical-line-scroll-amount
+		       ;; --- This should check the top or bottom line
+		       ;; of the viewport for its line height to
+		       ;; determine the scroll amount - this is the
+		       ;; reason for the direction arg. Davo 6/30/92
+		       (+ (text-style-height style contents)
+			  (if (extended-output-stream-p contents)
+			      (stream-vertical-spacing contents) 
+			      0))))))))
+
+(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value port) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (line-value (if (= contents-range 0)
+			     0
+			     (the single-float
+			       (/ (line-scroll-amount scroller-pane orientation :up)
+				  (float contents-range  0.0s0)))))
+	     (new-value (max 0.0 (- current-value line-value))))	
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value port) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (line-value (if (= contents-range 0)
+			     0
+			     (the single-float
+			       (/ (line-scroll-amount scroller-pane orientation :down)
+				  (float contents-range  0.0s0)))))
+	     (new-value (min (- 1.0 current-size) (+ current-value line-value))))
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (viewport-range (bounding-rectangle-max-y viewport))
+	     new-value)
+	(if (zerop contents-range)
+	    (setq new-value current-value)
+	    (let ((page-value (the single-float 
+				(/ viewport-range (float contents-range 0.0s0)))))
+	      (setq new-value (max 0.0 (- current-value page-value)))))
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (viewport-range (bounding-rectangle-max-y viewport))
+	     new-value)
+      (if (zerop contents-range)
+	  (setq new-value current-value)
+	  (let ((page-value (the single-float 
+			      (/ viewport-range (float contents-range 0.0s0)))))
+	    (setq new-value (min (- 1.0 current-size) (+ current-value page-value)))))
+      (scroll-bar-value-changed-callback
+	scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id)
+  (with-slots (current-size current-value) scroll-bar
+    (scroll-bar-value-changed-callback scroll-bar client id 0 current-size)))
+
+(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id)
+  (with-slots (current-size current-value) scroll-bar
+    (scroll-bar-value-changed-callback
+      scroll-bar client id (- 1.0 current-size) current-size)))
+
+(defmethod scroll-line-to-top-callback ((scroll-bar scroll-bar-pane)
+					scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if it's not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(with-bounding-rectangle* (vleft vtop vright vbottom)
+	    (viewport-viewport-region viewport) 
+	  (declare (ignore vright vbottom))
+	  (with-bounding-rectangle* (cleft ctop cright cbottom)
+	      (viewport-contents-extent viewport) 
+	    (declare (ignore cright cbottom))
+	    (let ((contents-range (contents-range scroller-pane orientation)))
+	      (unless (zerop contents-range)
+		(let* ((viewport-range (viewport-range scroller-pane orientation))
+		       (contents-min
+			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
+		       (viewport-min
+			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
+		       (mouse-offset
+			 (ecase orientation
+			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
+		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
+				  contents-min)
+			       contents-range)))
+		  (scroll-bar-value-changed-callback
+		    scroll-bar scroller-pane id
+		    (min (- 1.0 current-size) pos) current-size))))))))))
+
+(defmethod scroll-line-to-bottom-callback ((scroll-bar scroll-bar-pane)
+					   scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if its not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(with-bounding-rectangle* (vleft vtop vright vbottom)
+	    (viewport-viewport-region viewport) 
+	  (declare (ignore vright vbottom))
+	  (with-bounding-rectangle* (cleft ctop cright cbottom)
+	      (viewport-contents-extent viewport) 
+	    (declare (ignore cright cbottom))
+	    (let ((contents-range (contents-range scroller-pane orientation)))
+	      (unless (zerop contents-range)
+		(let* ((viewport-range (viewport-range scroller-pane orientation))
+		       (contents-min
+			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
+		       (viewport-min
+			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
+		       (mouse-offset
+			 (ecase orientation
+			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
+		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
+				  viewport-range contents-min)
+			       contents-range)))
+		  (scroll-bar-value-changed-callback
+		    scroll-bar scroller-pane id (max 0 pos) current-size))))))))))
+
+(defmethod scroll-elevator-callback ((scroll-bar scroll-bar-pane)
+				     scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if its not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(let* ((mouse-offset
+		 (- (ecase orientation
+		      (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+		      (:horizontal (/ (- x left) (float (- right left) 0.0s0))))
+		    (/ current-size 2.0s0))))
+	  (scroll-bar-value-changed-callback
+	    scroll-bar scroller-pane id (min 1.0s0 (max 0.0s0 mouse-offset)) current-size))))))
+
+
+;;; Set the indicator to the proper size and location (size and value are between 0 and 1)
+(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane)
+				     &key slider-size value)
+  (setf (gadget-value scroll-bar) value)
+  (setf (scroll-bar-current-size scroll-bar) slider-size))
+
+
+
+(defclass scroll-bar-target-pane 
+	  (immediate-sheet-input-mixin
+	   space-requirement-mixin
+	   sheet-single-child-mixin
+	   shared-medium-sheet-output-mixin
+	   foreground-background-and-text-style-mixin
+	   pane-repaint-background-mixin
+	   leaf-pane)
+    ((end :initarg :end)
+     (scroll-bar :initarg :scroll-bar)
+     (coord-cache :initform nil)))
+
+(defmethod initialize-instance :after ((pane scroll-bar-target-pane) &key end)
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (setf (slot-value pane 'pointer-cursor)
+	  (ecase end
+	    (:less-than 
+	      (ecase orientation
+		(:horizontal :scroll-left)
+		(:vertical :scroll-up)))
+	    (:greater-than
+	      (ecase orientation
+		(:horizontal :scroll-right)
+		(:vertical :scroll-down)))))))
+
+(defmethod note-sheet-region-changed :after ((pane scroll-bar-target-pane)
+					     &key &allow-other-keys)
+  (setf (slot-value pane 'coord-cache) nil))
+
+(defmethod handle-repaint ((pane scroll-bar-target-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (draw-rectangle* medium left top (1- right) (1- bottom)
+		       :filled nil :ink (medium-foreground medium)))
+    (draw-target pane medium)))
+
+;;; You can pass :FILLED T to this in order to highlight the target when clicked on...
+(defmethod draw-target ((pane scroll-bar-target-pane) medium
+			&key filled (ink +foreground-ink+))
+  (let ((coord-cache (slot-value pane 'coord-cache)))
+    (unless coord-cache
+      (let ((identity (sheet-pointer-cursor pane)))
+	(setq coord-cache
+	      (setf (slot-value pane 'coord-cache)
+		    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+		      ;; This seems to be a kludge to deal with roundoff?
+		      (decf right) (decf bottom)
+		      ;; Indent the target arrows a little for aesthetic purposes
+		      (incf left 2) (decf right 2)
+		      (incf top 2)  (decf bottom 2)
+		      (ecase identity
+			(:scroll-up
+			  (list left bottom
+				(+ left (/ (- right left) 2)) top
+				right bottom))
+			(:scroll-down
+			  (list left top
+				(+ left (/ (- right left) 2)) bottom
+				right top))
+			(:scroll-left
+			  (list right top
+				left (/ (+ top bottom) 2)
+				right bottom))
+			(:scroll-right
+			  (list left top
+				right (/ (+ top bottom) 2)
+				left bottom))))))))
+    (draw-polygon* medium coord-cache :filled filled :ink ink)))
+
+(defclass scroll-bar-shaft-pane
+	  (immediate-sheet-input-mixin
+	   space-requirement-mixin
+	   sheet-single-child-mixin
+	   shared-medium-sheet-output-mixin
+	   foreground-background-and-text-style-mixin
+	   pane-repaint-background-mixin
+	   leaf-pane)
+    ((scroll-bar :initarg :scroll-bar)
+     (needs-erase :initform nil)))
+
+(defmethod initialize-instance :after ((pane scroll-bar-shaft-pane) &key)
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (setf (slot-value pane 'pointer-cursor)
+	  (ecase orientation
+	    (:horizontal :horizontal-scroll)
+	    (:vertical :vertical-scroll)))))
+
+(defmethod handle-repaint ((pane scroll-bar-shaft-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (draw-rectangle* medium left top (1- right) (1- bottom)
+		       :filled nil :ink (medium-foreground medium)))
+    (draw-thumb pane medium)))
+
+(defparameter *scroll-bar-thumb-ink* (make-gray-color 2/3))
+
+(defmethod draw-thumb ((pane scroll-bar-shaft-pane) medium
+		       &key (ink +foreground-ink+))
+  (let ((needs-erase (slot-value pane 'needs-erase)))
+    (setf (slot-value pane 'needs-erase) (not (eq ink +background-ink+)))
+    (when (and (not needs-erase)
+	       (eq ink +background-ink+))
+      (return-from draw-thumb (values))))
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (scroll-value (gadget-value scroll-bar))
+	 (min-value (gadget-min-value scroll-bar))
+	 (max-value (gadget-max-value scroll-bar))
+	 (gadget-size (or (scroll-bar-current-size scroll-bar) 0))
+	 (gadget-range (abs (- max-value min-value)))
+	 (identity (sheet-pointer-cursor pane)))
+    (flet ((draw-car (medium left top right bottom which)
+	     (decf right) (decf bottom)
+	     (draw-rectangle* medium left top right bottom
+			      :filled t
+			      :ink (if (eq ink +foreground-ink+) *scroll-bar-thumb-ink* ink))
+	     (case which
+	       (:vertical-scroll
+		 (draw-line* medium left top right top :ink ink)
+		 (draw-line* medium left bottom right bottom :ink ink))
+	       (:horizontal-scroll
+		 (draw-line* medium left bottom left top :ink ink)
+		 (draw-line* medium right bottom right top :ink ink)))))
+      (declare (dynamic-extent #'draw-car))
+      (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
+	(let* ((height (- y2 y1))
+	       (width (- x2 x1))
+	       (scroll-range (ecase identity
+			       (:vertical-scroll height)
+			       (:horizontal-scroll width)))
+	       (car-size (max 10 (* scroll-range (/ gadget-size gadget-range))))
+	       (elevator-top (compute-symmetric-value 
+			       min-value max-value scroll-value 0
+			       scroll-range))
+	       (elevator-bottom (+ elevator-top car-size)))
+	  (ecase identity
+	    (:vertical-scroll
+	      (draw-car medium
+			(+ x1 1)           (+ y1 elevator-top)
+			(+ x1 width -1) (+ y1 elevator-bottom)
+			identity))
+	    (:horizontal-scroll
+	      (draw-car medium
+			elevator-top      (+ y1 1)
+			elevator-bottom   (+ y1 height -1)
+			identity))))))))
+
+
+
+(defmethod handle-event :around ((pane scroll-bar-target-pane) 
+				 (event pointer-button-press-event))
+  (with-sheet-medium (medium pane)
+    (draw-target pane medium :filled t :ink +foreground-ink+)
+    (call-next-method)
+    (draw-target pane medium :filled t :ink +background-ink+)
+    (draw-target pane medium :filled nil)))
+
+
+;;; This implements genera style scroll bars.
+;;; Vertical Scroll bars
+;;;    Top Target
+;;;       Left: Next Line   Middle: First Page   Right: Previous Line
+;;;    Bottom Target
+;;;       Left: Next Page   Middle: Last Page    Right: Previous Page
+(defmethod handle-event ((pane scroll-bar-target-pane) 
+			 (event pointer-button-press-event))
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (client (gadget-client scroll-bar))
+	 (id (gadget-id scroll-bar)))
+    (case (pointer-event-button event)
+      (#.+pointer-left-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-down-page-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-down-line-callback scroll-bar client id))))
+      (#.+pointer-middle-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-to-bottom-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-to-top-callback scroll-bar client id))))
+      (#.+pointer-right-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-up-page-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-up-line-callback scroll-bar client id)))))))
+
+(defmethod handle-event ((pane scroll-bar-shaft-pane) 
+			 (event pointer-button-press-event))
+  (let* ((x (pointer-event-x event))
+	 (y (pointer-event-y event))
+	 (scroll-bar (slot-value pane 'scroll-bar))
+	 (client (gadget-client scroll-bar))
+	 (id (gadget-id scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (case (pointer-event-button event)
+      (#.+pointer-left-button+
+       (scroll-line-to-top-callback
+	 scroll-bar client id orientation x y))
+      (#.+pointer-right-button+
+       (scroll-line-to-bottom-callback
+	 scroll-bar client id orientation x (- (bounding-rectangle-height scroll-bar) y)))
+      (#.+pointer-middle-button+
+       (scroll-elevator-callback
+	 scroll-bar client id orientation x y)))))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-enter-event))
+  (frame-manager-display-pointer-documentation-string
+    (frame-manager pane) *pointer-documentation-output*
+    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
+      (:vertical
+	"L: This line to top; M: Proportional scrolling; R: Top line to here.")
+      (:horizontal
+	"L: This column to left edge; M: Proportional scrolling; R: Left edge to here."))))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-enter-event))
+  (frame-manager-display-pointer-documentation-string
+    (frame-manager pane) *pointer-documentation-output*
+    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
+      (:vertical
+	(ecase (slot-value pane 'end)
+	  (:greater-than
+	    "L: Next screenful; M: Last screenful; R: previous screenful.")
+	  (:less-than
+	    "L: Next line; M: First screenful; R: Previous line.")))
+      (:horizontal
+	(ecase (slot-value pane 'end)
+	  (:greater-than
+	    "L: Next screenful; M: Last screenful; R: previous screenful.")
+	  (:less-than
+	    "L: Next column; M: First screenful; R: Previous column."))))))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-exit-event))
+  (frame-manager-display-pointer-documentation-string 
+    (frame-manager pane) *pointer-documentation-output* nil))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-exit-event))
+  (frame-manager-display-pointer-documentation-string 
+    (frame-manager pane) *pointer-documentation-output* nil))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-event))
+  (deallocate-event event))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-event))
+  (deallocate-event event))
+
+(defmethod update-scroll-bar-value ((pane scroll-bar-shaft-pane) scroll-bar coord min max)
+  (let* ((min-value (gadget-min-value scroll-bar))
+	 (max-value (gadget-max-value scroll-bar))
+	 (value (compute-symmetric-value min max coord min-value max-value)))
+    (setf (gadget-value scroll-bar) value)))
+
+(defmethod (setf gadget-value) (value (pane scroll-bar-pane) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (setf (slot-value pane 'value) value))
+
+(defmethod (setf gadget-value) :around (value (pane scroll-bar-pane) &key invoke-callback)
+  (declare (ignore value invoke-callback))
+  (if (port pane)
+      (let ((shaft-pane (slot-value pane 'shaft-pane)))
+	(with-sheet-medium (medium shaft-pane)
+	  (draw-thumb shaft-pane medium :ink +background-ink+)
+	  (call-next-method)
+	  (draw-thumb shaft-pane medium :ink +foreground-ink+)))
+      (call-next-method)))
+
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index 7f1a22aa11067c27132fe850e41e5494e6233fa2..241b6d8c324abcbdf705667d2fb8d2f3f650a263 100644
--- a/silica/text-style.lisp
+++ b/silica/text-style.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-style.lisp,v 1.15 92/11/06 19:04:02 cer Exp $
+;; $fiHeader: text-style.lisp,v 1.16 92/11/19 14:25:06 cer Exp $
 
 (in-package :silica)
 
@@ -659,7 +659,7 @@
       (let ((tuples (gethash key mapping-table))
 	    (last-tuple nil)
 	    (last-size nil))
-	(dolist (tuple tuples (if tuples (cadr (last tuples))))
+	(dolist (tuple tuples (if (and tuples (not exact-size-required)) (cadar (last tuples))))
 	  (let ((font-size (text-style-size (car tuple))))
 	    (if exact-size-required
 		(when (= size font-size)
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 5818a1748f81dba8084255bdca4d89d966f7fb9b..f5d5c2d5a9fcb7ac0b614c245881eecebb72d169 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.31 92/11/19 14:25:12 cer Exp $
+;; $fiHeader: sysdcl.lisp,v 1.32 92/12/03 10:29:40 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -137,8 +137,6 @@
   ("queue")
   ("timers" :load-before-compile ("queue" "processes"))
   ("protocols")
-  ("autoconstructor")
-
   ;; Establish a uniform stream model
   ("clim-streams")
   ("cl-stream-classes" :features (not clim-uses-lisp-stream-classes))
@@ -190,6 +188,7 @@
   ("gadgets")
   ("db-border")
   ("db-scroll")
+  ("scroll-pane")
   ("db-button")
   ("db-slider"))
 
@@ -344,77 +343,59 @@
   ("x11-keysyms" :load-before-compile ("ffi"))
   ("last" :load-before-compile ("load-xlib" "xlib-funs")))
 
-#+Allegro
-(clim-defsys:defsystem xt-tk
-    (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-		       #-Genera (frob-pathname "tk")
-     :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-			      #-Genera (frob-pathname "tk")
-     :needed-systems (xlib)
-     :load-before-compile (xlib))
-  ;; Motif and Openlook specific foreign loading.
-  ;; Must be done early so defforeigns can be opencoded.
-  ("load-xm" :features clim-motif)
-  ("load-ol" :features clim-openlook)
-  ;; General stuff
-  ("pkg")
-  ("macros")
-  ("xt-defs")				; Used to be 'xtk'.
-  ("xt-funs")
-  ("foreign-obj")
-  ;; Xlib stuff
-  ("xlib")
-  ("font")
-  ("gcontext")
-  ("graphics")
+(macrolet ((define-xt-system (name file &rest modules)
+	       `(clim-defsys:defsystem ,name
+		    (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;"
+		      #-Genera (frob-pathname "tk")
+		      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;"
+		      #-Genera (frob-pathname "tk")
+		      :needed-systems (xlib)
+		      :load-before-compile (xlib))
+		  (,file)
+		  ("pkg")
+		  ("macros")
+		  ("xt-defs")		; Used to be 'xtk'.
+		  ("xt-funs")
+		  ("foreign-obj")
+		  ;; Xlib stuff
+		  ("xlib")
+		  ("font")
+		  ("gcontext")
+		  ("graphics")
   
-  ;; Toolkit stuff
-  ("meta-tk")
-  ("make-classes")
-  ("foreign")
-  ("widget")
-  ("resources")
-  ("event")
-  ("callbacks")
-  ("xt-classes")
-  ("xt-init"))
-
-#+Allegro
-(clim-defsys:defsystem xm-tk
-    (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-		       #-Genera (frob-pathname "tk")
-     :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-			      #-Genera (frob-pathname "tk")
-     :needed-systems (xt-tk)
-     :load-before-compile (xt-tk))
-  ;; Motif specific stuff
-  ("xm-defs")
-  ("xm-funs")
-  ("xm-classes")
-  ("xm-callbacks")
-  ("xm-init")
-  ("xm-widgets")
-  ("xm-font-list")
-  ("xm-protocols")
-  ("convenience")
-  ("make-widget"))
+		  ;; Toolkit stuff
+		  ("meta-tk")
+		  ("make-classes")
+		  ("foreign")
+		  ("widget")
+		  ("resources")
+		  ("event")
+		  ("callbacks")
+		  ("xt-classes")
+		  ("xt-init")
+		  ,@modules)))
+  
+  (define-xt-system xm-tk "load-xm"
+    ("xm-defs")
+    ("xm-funs")
+    ("xm-classes")
+    ("xm-callbacks")
+    ("xm-init")
+    ("xm-widgets")
+    ("xm-font-list")
+    ("xm-protocols")
+    ("convenience")
+    ("make-widget"))
+  
+  (define-xt-system ol-tk "load-ol"
+    ("ol-defs")
+    ("ol-funs")
+    ("ol-classes")
+    ("ol-init")
+    ("ol-widgets")
+    ("ol-callbacks")
+    ("make-widget")))
 
-#+Allegro
-(clim-defsys:defsystem ol-tk
-    (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-		       #-Genera (frob-pathname "tk")
-     :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;"
-			      #-Genera (frob-pathname "tk")
-     :needed-systems (xt-tk)
-     :load-before-compile (xt-tk))
-  ;; OpenLook specific stuff
-  ("ol-defs")
-  ("ol-funs")
-  ("ol-classes")
-  ("ol-init")
-  ("ol-widgets")
-  ("ol-callbacks")
-  ("make-widget"))
 
 #+Allegro
 (clim-defsys:defsystem motif-clim
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 55524db9a8a2e9d5ef5ab7fcba3989596fb31a33..839bd5205d7854dc5ecab59ea13dc4724075280c 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.47 92/12/01 09:46:42 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.48 92/12/03 10:29:48 cer Exp $
 
 (in-package :clim-user)
 
@@ -767,7 +767,7 @@ people, shall not perish from the earth.
 		      (draw-rectangle* stream 0 0 (pattern-width pattern) (pattern-height pattern) :ink pattern))
 		  (write-string "not found" stream))))))))
 
-#+Allegro
+
 (define-test (draw-some-bezier-curves graphics) (stream)
   "Draw bezier curve"
   (let ((points (list 0 0 100 300 300 300 400 0 200 200 150 30 0 0)))
@@ -775,7 +775,7 @@ people, shall not perish from the earth.
 	(dolist (filled '(nil t))
 	  (formatting-cell (stream)
 	      (with-scaling (stream 0.5)
-		(draw-bezier-polygon* stream points :filled filled)
+		(draw-bezier-curve* stream points :filled filled)
 		(do ((points points (cddr points)))
 		    ((null points))
 		  (draw-point* stream (car points) (cadr points) :line-thickness 2
@@ -1251,6 +1251,37 @@ people, shall not perish from the earth.
     (sleep 2)
     (window-refresh stream)))
 
+(define-test (hairy-graph-formatting formatted-output) (stream)
+  "Some hairy re-entrant and circular graphs"
+  (formatting-item-list (stream)
+      (dolist (test '((nil (a (bbbb (ccc (dd eee) (fff ggg (hh (ii jj) kkk))) (lll (mmm nnn) (ooo ppp qqq))) r (s t)))
+		      (t (a #1=(b (c #2= (d e #3=(f g)) (hhhhhhhhhh (i j k) l (m n o)))))
+		       (p (q (r (s t #3# u))))
+		       (w (x #2# #1#)))
+		      (t (a #11=(bbb (ccc (dd eee) (ffff g hhhhhhhh)))
+			  (mm (nnn ooo #11#) (p #12=(q r (s t))))
+			  (u (v (w (x #12#))))))
+		      (t (a #21= (b (c (d #21# e)) (f #22= (g (h i) j) k) #22#) (m n)))
+		      (t #34=(a #31= (b (c (d #31# e)) (f #32= (g (h i #31#) j) k) #32#) (m #34# n)))
+		      (t #51=(a #51#))
+		      (t #41=(aaa (bbb (ccc #41#))))
+		      ))
+	(formatting-cell (stream)
+	    (destructuring-bind (merge . data) test
+	      (flet ((printer-function (node stream)
+		       (format stream "~A" (if (consp node) (car node) node)))
+		     (child-function (node)
+		       (and (consp node) (cdr node))))
+		(format-graph-from-roots
+		 data
+		 #'printer-function
+		 #'child-function
+		 :stream stream
+		 :cutoff-depth 8
+		 :merge-duplicates merge
+		 )))))))
+    
+
 (define-test (filled-output formatted-output) (stream)
   "Some simple tests of filled output.  The thing labelled <Click Here> should be sensitive."
   (filling-output (stream :fill-width '(30 :character))
@@ -1742,7 +1773,11 @@ Luke Luck licks the lakes Luke's duck likes."))
 		   :label "Select an activity"))
     (doit
       (menu-choose '("akjdfkjdf" "bdfkj" "cdfkj")
-		   :label "foo" :text-style '(:fix :roman :huge)))))
+		   :label "foo" :text-style '(:fix :roman :huge)))
+    (doit
+     (menu-choose '("akjdfkjdf" "bdfkj" "cdfkj")
+		  :label '("Foo" :text-style (:serif :bold :huge)) 
+		  :text-style '(:fix :roman :huge)))))
 
 (define-test (graphical-menu menus-and-dialogs) (stream)
   "A menu that contains graphics."
@@ -1950,44 +1985,53 @@ Luke Luck licks the lakes Luke's duck likes."))
 (define-test (readonly-gadget-dialog menus-and-dialogs) (stream)
   "Create a bunch of readonly gadgets"
   (accepting-values (stream :own-window nil :label "Gadgets dialog"
-			    :align-prompts t)
-    (macrolet ((do-presents (view &rest p)
-		 `(progn
-		    ,@(mapcar #'(lambda (x)
-				  `(progn
-				     (present ',(car x) ',(cadr x)
-				       ,@(and view `(:view ,view))
-				       :prompt (format nil "~A,~A"
-						 ',(cadr x)
-						 ,(if (constantp view)
-						      (if (eval view) `',(type-of (eval view)) :default)
-						      `(if ,view (type-of ,view) :default)))
-				       :stream stream)
-				     (terpri stream)))
-			      p))))
-      (do-presents
-	nil
-	(5.0 real)
-	("xxx" string)
-	(#P"/tmp/foo" pathname)
-	(:a (member :a :b))
-	((:a :b) (subset :a :b))
-	(( 3 4) (sequence integer))
-	;; sequence-enumerated
-	(t boolean))
-      (do-presents
-	+text-field-view+
-	(5.0 real)
-	("xxx" string)
-	(#P"/tmp/foo" pathname)
-	(:a (member :a :b))
-	((:a :b) (subset :a :b))
-	(( 3 4) (sequence integer))
-	;; sequence-enumerated
-	(t boolean))
-      (do-presents
-	'(text-editor-view :nlines 5 :ncolumns 30)
-	("      (do-presents
+			    :align-prompts nil)
+      (macrolet ((do-presents (view &rest p)
+		   `(progn
+		      ,@(mapcar #'(lambda (x)
+				    `(progn
+				       (present ',(car x) ',(cadr x)
+						,@(and view `(:view ,view))
+						:prompt (format nil "~A,~A"
+								',(cadr x)
+								,(if (constantp view)
+								     (if (eval view) `',(type-of (eval view)) :default)
+								   `(if ,view (type-of ,view) :default)))
+						:stream stream)
+				       (terpri stream)))
+				p))))
+	
+	(formatting-item-list (stream :n-columns 2)
+	    (formatting-cell (stream)
+		(with-aligned-prompts (stream)
+		  (do-presents
+		      nil
+		    (5.0 real)
+		    ("xxx" string)
+		    (#P"/tmp/fooo" pathname)
+		    (:a (member :a :b))
+		    ((:a :b) (subset :a :b))
+		    (( 3 4) (sequence integer))
+		    ;; sequence-enumerated
+		    (t boolean))))
+	  (formatting-cell (stream)
+	      (with-aligned-prompts (stream)
+		(do-presents
+		    +text-field-view+
+		  (5.0 real)
+		  ("xxx" string)
+		  (#P"/tmp/fooo" pathname)
+		  (:a (member :a :b))
+		  ((:a :b) (subset :a :b))
+		  (( 3 4) (sequence integer))
+		  ;; sequence-enumerated
+		  (t boolean))))
+	  
+	  (formatting-cell (stream)
+	      (with-aligned-prompts (stream)
+		(do-presents
+		    '(text-editor-view :nlines 5 :ncolumns 30)
+		  ("      (do-presents
 	  +text-field-view+
 	  (5.0 real)
 	(xxx string)
@@ -1997,11 +2041,15 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(( 3 4) (sequence integer))
 	;; sequence-enumerated
 	(t boolean)) "
-	 string))
-      (do-presents
-	+slider-view+
-	(5.0 float)
-	(1 integer)))))
+		      string))))
+	  
+	  (formatting-cell (stream)
+	      (with-aligned-prompts (stream)
+		(do-presents
+		    +slider-view+
+		  (5.0 float)
+		  (1 integer))))))))
+
 
 (defun gadgets-dialog-internal (stream &optional own-window)
   (macrolet ((accepts (&rest accepts)
@@ -2078,29 +2126,35 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 (defun time-continuation (name iterations continuation &key (careful t))
   (with-display-pane (stream)
-		     (let ((results nil)
-		       (vresults nil))
+    (let ((results nil)
+	  (vresults nil))
       (when careful
 	(funcall continuation stream))
-      (repeat (* *multiply-factor* (if (not careful) 1 5))
-	(window-clear stream)
-	#+Genera (si:%gc-scavenge)
-	#+Cloe-Runtime (gc-immediately)
-	#+Lucid (lucid-common-lisp:ephemeral-gc)
-	#+excl (excl::gc)
-	#+ccl (ccl:gc)
-	(let ((start-time (get-internal-real-time))
-	      (vstart-time (get-internal-run-time)))
-	  (repeat iterations
-	    (#+Genera mi:with-metering-enabled #-Genera progn
-	      (funcall continuation stream))
-	    (force-output stream))
-	  (push (/ (float (- (get-internal-real-time) start-time))
-		   internal-time-units-per-second)
-		results)
-	  (push (/ (float (- (get-internal-run-time) vstart-time))
-		   internal-time-units-per-second)
-		vresults)))
+      (let ((initial-scale-iterations 1))
+        (repeat (* *multiply-factor* (if (not careful) 1 5))
+		(window-clear stream)
+		#+Genera (si:%gc-scavenge)
+		#+Cloe-Runtime (gc-immediately)
+		#+Lucid (lucid-common-lisp:ephemeral-gc)
+		#+excl (excl::gc)
+		#+ccl (ccl:gc)
+		(do ((scale-iterations initial-scale-iterations (* scale-iterations 2)))
+		    (nil)
+		  (let ((start-time (get-internal-real-time))
+			(vstart-time (get-internal-run-time)))
+		    (repeat (* iterations scale-iterations)
+			    (#+Genera mi:with-metering-enabled #-Genera progn
+				      (funcall continuation stream))
+			    (force-output stream))
+		    (let ((vtime (/ (float (- (get-internal-run-time) vstart-time))
+				    internal-time-units-per-second))
+			  (rtime (/ (float (- (get-internal-real-time) start-time))
+				    internal-time-units-per-second)))
+		      (when (or (> vtime 1) (> rtime 1))
+			(setq initial-scale-iterations scale-iterations)
+			(push (/ rtime scale-iterations) results)
+			(push (/ vtime scale-iterations) vresults)
+			(return nil)))))))
       (let ((time
 	     (if (not careful)
 		 (first results)
@@ -2112,11 +2166,11 @@ Luke Luck licks the lakes Luke's duck likes."))
 	       (let ((results (rest (butlast (sort vresults #'<)))))
 		 (/ (apply #'+ results) (length results))))))
 	(format (get-frame-pane *application-frame* 'caption-pane)
-	    "~%Each run of ~A took about ~3$ real, ~3$ virtual, ~3$ v/r seconds"
-	    name 
-	    time
-	    vtime
-	    (float (/ vtime time)))
+		"~%Each run of ~A took about ~3$ real, ~3$ virtual, ~3$ v/r seconds"
+		name 
+		time
+		vtime
+		(float (/ vtime time)))
 	time))))
 
 ;;; To distill the results down to something more easily interpretable by the
@@ -2953,7 +3007,7 @@ Luke Luck licks the lakes Luke's duck likes."))
   (without-clim-input
     (if #+allegro (typep (port stream) 'xm-silica::xt-port)
 	#-allegro nil
-	(sleep 1) ;; Avoid division by zero!
+	(sleep 0.1) ;; Avoid division by zero!
 	(menu-choose '(("Red" :value +red+)
 		       ("Green" :value +green+)
 		       ("Blue" :value +blue+)
@@ -2971,7 +3025,7 @@ Luke Luck licks the lakes Luke's duck likes."))
   (without-clim-input
     (if #+allegro (typep (port stream) 'xm-silica::xt-port)
 	#-allegro nil
-	(sleep 1) ;; Avoid division by zero!
+	(sleep 0.1) ;; Avoid division by zero!
 	(menu-choose '(("Red" :value +red+)
 		       ("Green" :value +green+)
 		       ("Blue" :value +blue+)
diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp
index e123da7ac0dbe197e8cb38d474b4531943730277..a9342609f1438a17c57368fa412327c1424a582d 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.18 92/11/10 08:56:55 cer Exp $
+;; $fiHeader: ol-frames.lisp,v 1.19 92/12/03 10:30:10 cer Exp $
 
 
 (in-package :xm-silica)
@@ -74,8 +74,11 @@
 	 (font (and text-style (text-style-mapping (port framem) text-style)))
 	 (font-args (and font (list :font font))))
 
-    (tk::set-values menu-shell :title (or label "Choose"))
-
+    (let ((title (cond ((null label) "Choose")
+		       ((atom label) label)
+		       (t (car label)))))
+      (check-type title string)
+      (tk::set-values menu-shell :title title))
     ;;-- Does not have a font resource
     ;;    (when font (tk::set-values menu-shell :font font))
     
@@ -184,6 +187,6 @@
   (tk::ol_menu_popdown menu 1))
 
 (defmethod framem-menu-active-p ((framem openlook-frame-manager) menu)
-  (declare (ignore t))
+  (declare (ignore menu))
   t)
 
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index fc8403e13ac16ec6a78d65b1325abd31b2bee395..e8f5cf24ee7cc6fab65deb5aea7a1c0854370c3e 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.32 92/11/20 08:46:35 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.33 92/12/03 10:30:13 cer Exp $
 
 
 (in-package :xm-silica)
@@ -101,6 +101,7 @@
 	mmin mmax size smin smax)))))
 
 (defmethod compose-space ((m openlook-scroll-bar) &key width height)
+  (declare (ignore width height))
   (let ((x 16))
     (ecase (gadget-orientation m)
       (:vertical
@@ -260,9 +261,9 @@
 	(declare (ignore ignore-x igore-y))
 	(maxf height h)
 	(incf width w)))
-    (multiple-value-bind (h-pad v-pad h-space v-space)
+    (multiple-value-bind (h-pad v-pad h-space)
 	(tk::get-values (sheet-direct-mirror mb)
-			:h-pad :v-pad :h-space :v-space)
+			:h-pad :v-pad :h-space)
       (incf width (+ (* 2 h-pad) (* (1- (length children)) h-space)))
       (incf height (* 2 v-pad)))
     (make-space-requirement :width width :height height)))
@@ -273,7 +274,7 @@
   ;; This code fills the menu-bar. If top level items do not have
   ;; submenus then it creates one with a menu of its own
   
-  (let ((mirror (call-next-method))
+  (let* ((mirror (call-next-method))
 	(text-style (menu-bar-text-style sheet))
 	(font-list (and text-style
 			(list :font (text-style-mapping port text-style))))
@@ -611,8 +612,12 @@
 	   (nv (gadget openlook-toggle-button) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror gadget)
-    (with-no-value-changed-callbacks
-	(tk::set-values (sheet-mirror gadget) :set nv))))
+    (handler-bind
+	;;-- Nasty hack alert for 
+	((simple-warning #'(lambda (condition)
+			     (muffle-warning condition))))
+      (with-no-value-changed-callbacks
+	  (tk::set-values (sheet-mirror gadget) :set nv)))))
 
 ;;
 
@@ -738,7 +743,7 @@
   (with-accessors ((label gadget-label)
 		   (show-value-p gadget-show-value-p)
 		   (value gadget-value)
-		   (editable gadget-editable-p)) sheet
+		   (editablep gadget-editable-p)) sheet
     (multiple-value-bind
 	(smin smax) (gadget-range* sheet)
       (let ((mmin 0) 
@@ -794,10 +799,11 @@
 (defmethod add-sheet-callbacks :after ((port openlook-port) 
 				       (sheet openlook-slider)
 				       (widget t))
-  ;;--- Do we need to do this?
-  #+ignore
-  (tk::add-callback widget :drag-callback 'queue-drag-event sheet)
-  (tk::add-callback widget :slider-moved 'slider-changed-callback-1 sheet))
+  (when (gadget-editable-p sheet)
+    ;;--- Do we need to do this?
+    #+ignore
+    (tk::add-callback widget :drag-callback 'queue-drag-event sheet)
+    (tk::add-callback widget :slider-moved 'slider-changed-callback-1 sheet)))
 
 (defmethod slider-changed-callback-1 ((widget t) (sheet openlook-slider))
   (queue-value-changed-event widget sheet))
@@ -949,6 +955,7 @@
 
 (defmethod initialize-instance :after ((sp openlook-scrolling-window)
 				       &key scroll-bars contents frame-manager frame)
+  #-bad-hack (declare (ignore scroll-bars))
   (if (setf (scroller-pane-gadget-supplies-scrolling-p sp)
 	(gadget-supplies-scrolling-p contents))
       (sheet-adopt-child sp contents)
@@ -1261,6 +1268,7 @@
 				   :string "xxxxxxxxxxxxxxxxxxxxxxxx"
 				   :parent control))
 	   (menu-pane (tk::get-values widget :menu-pane)))
+      (declare (ignore label))
       (setf (option-menu-buttons sheet)
 	(mapcar #'(lambda (item)
 		    (let* ((currentp (funcall
@@ -1316,7 +1324,7 @@
 		      :accelerator accel
 		      :accelerator-text accel-text))))
 
-(defmethod discard-accelerator-event-p ((port openlook-port) event)
+(defmethod discard-accelerator-event-p ((port openlook-port) (event t))
   ;;-- There are a whole bunch of other keysyms that need to be ignored.
   ;;-- Perhaps in OLIT there is a way of getting the actual keysym.
   ;;-- Perhaps we need a way of representing them in the clim world
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index f1460e7ddb707647bc98a5318ba3b9de9096145a..8d6b1bab597ab1f1a58f75e6db86b7eb903dae34 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.41 92/11/20 08:46:41 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.42 92/12/03 10:30:17 cer Exp $
 
 (in-package :xm-silica)
 
@@ -321,11 +321,16 @@
 	 (font (and text-style (text-style-mapping (port framem) text-style)))
 	 (font-list (and (or label simplep) font (list :font-list (list font)))))
     (when label
-      (apply #'make-instance 'xt::xm-label
-		     :parent menu
-		     :managed nil
-		     :label-string label
-		     font-list)
+      (let ((title (if (atom label) label (car label))))
+	(check-type title string)
+	(destructuring-bind (&key text-style) (and (listp label) (cdr label))
+	  (apply #'make-instance 'xt::xm-label
+		 :parent menu
+		 :managed nil
+		 :label-string title
+		 (if text-style
+		     (list :font-list (list (text-style-mapping (port framem) text-style)))
+		   font-list))))
       (make-instance 'xt::xm-separator
 		     :managed nil
 		     :separator-type :double-line
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 7c59bfa135545f7f9fbc6a94ba31811b5bdeaf91..e0efab0c211ce0f8dd04bf58b6b2295947353a22 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.61 92/12/01 09:47:21 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.62 92/12/02 13:31:36 colin Exp $
 
 (in-package :xm-silica)
 
@@ -91,50 +91,50 @@
       (setf (getf (mp:process-property-list process) ':survive-dumplisp) #'cleanup-port-after-dumplisp)
       (setf (port-process port) process))))
 
-(defmacro destructure-x-server-path ((&key display) path &body body)
-  ;;-- Of course the port ends up with an unspecified server-path.
-  ;;-- Perhaps this is OK or perhaps we have to default the components before
-  ;;-- putting it in the port???
-  (let ((ignore (gensym)))
-    `(destructuring-bind
-	 (,ignore &key ((:display ,display)
-			(or (sys::getenv "DISPLAY")
-			    "localhost:0")))
-	 ,path
-	 (declare (ignore ,ignore))
-       ,@body)))
-       
+(defmethod port-event-loop :around ((port xt-port))
+  (handler-case (call-next-method)
+    (tk::x-connection-lost (condition)
+      (port-terminated port condition)
+      (mp:process-kill mp:*current-process*))))
+
 (defparameter *use-color* t)		; For debugging monochrome
 
+(defvar *unreliable-server-vendors*
+    '("Solbourne Computer, Inc" "Network Computing Devices"
+      "Tektronix"))
+
 (defmethod initialize-instance :after ((port xt-port) &key server-path)
-  (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
-	      (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
-	      (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
-	      (slot-value port 'silica::default-palette) 
-	       (make-xt-palette port (tk::default-colormap (port-display port))))
-	(let* ((screen (x11:xdefaultscreenofdisplay display))
-	       (bs-p (not (zerop (x11::screen-backing-store screen))))
-	       (su-p (not (zerop (x11::screen-save-unders screen))))
-	       (vendor (ff:char*-to-string (x11::display-vendor display))))
-	  (if (and bs-p su-p
-		   ;; An amazing crock.  XXX
-		   (not (search "Network Computing Devices" vendor))
-		   (not (search "Tektronix" vendor)))
-	      (setf (slot-value port 'safe-backing-store) t)))
-	(initialize-xlib-port port display)))))
+  (handler-case
+      (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
+		  (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
+		  (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
+		  (slot-value port 'silica::default-palette) 
+		  (make-xt-palette port (tk::default-colormap (port-display port))))
+	    (let* ((screen (x11:xdefaultscreenofdisplay display))
+		   (bs-p (not (zerop (x11::screen-backing-store screen))))
+		   (su-p (not (zerop (x11::screen-save-unders screen))))
+		   (vendor (ff:char*-to-string (x11::display-vendor display))))
+	      (if (and bs-p su-p
+		       ;; An amazing crock.  XXX
+		       (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*))
+		  (setf (slot-value port 'safe-backing-store) t)))
+	    (initialize-xlib-port port display))))
+    (tk::x-connection-lost (condition)
+      (port-terminated port condition))))
+
 
 (defmethod port-color-p ((port xt-port))
   (and *use-color*
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index c72075b02e8d9126ff2250cc312dab27978be3f1..8884a2490f659c22bf3dbe0e07d26ed0a2bb111a 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.34 92/11/18 15:54:57 colin Exp $
+;; $fiHeader: xlib.lisp,v 1.35 92/12/02 13:31:21 colin Exp $
 
 (in-package :tk)
 
@@ -194,6 +194,15 @@
    (asynchronous :reader x-error-asynchronous :initarg :asynchronous))
   (:report report-x-error))
 
+(define-condition x-connection-lost (error)
+  ((display :reader x-error-display :initarg :display))
+  (:report report-x-connection-lost))
+
+(defun report-x-connection-lost (condition stream)
+  (let ((display (x-error-display condition)))
+    (format stream "Xlib: Connection to X11 server '~a' lost"
+	    (ff:char*-to-string (x11:display-display-name display)))))
+
 (defun report-x-error (condition stream)
   (let ((display (x-error-display condition))
 	(error-code (x-error-error-code condition))
@@ -229,8 +238,8 @@
 
 (defun-c-callable x-io-error-handler ((display :unsigned-long))
   (let ((*error-output* excl:*initial-terminal-io*))
-    (error "Xlib: Connection to X11 server '~a' lost"
-	   (ff:char*-to-string (x11:display-display-name display)))))
+    (error 'x-connection-lost :display display)))
+
 
 
 (defun get-error-text (code display-handle)
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 307cff0ed49af6b7a89d10fc94d338e75fb824ef..bffe654243d6180260d6bb2b66c07c73ea6893ab 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.41 92/12/01 09:47:32 cer Exp $
+;; $fiHeader: packages.lisp,v 1.42 92/12/03 10:30:45 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2557,6 +2557,7 @@
     display-exit-boxes
     frame-manager-dialog-view
     invoke-accept-values-command-button
+    with-aligned-prompts
     
     ;; Command processor
     *command-argument-delimiters*
@@ -3497,6 +3498,7 @@
     port-set-pointer-position
     port-set-sheet-pointer-cursor
     port-set-sheet-grabbed-pointer-cursor
+    port-terminated
     port-trace-thing
     port-undefined-text-style
     process-event-locally