diff --git a/Makefile b/Makefile
index 579b8d2f2c94c72f17f5e3b4e090c16c779e10f0..b02c657c69702d35cd102d6b8bad9c343659ec93 100644
--- a/Makefile
+++ b/Makefile
@@ -1,8 +1,9 @@
-# $fiHeader: Makefile,v 1.44 92/08/21 16:34:13 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.45 92/09/08 10:35:20 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
-CL	= /usr/tech/cer/cl/src/dcl
+#CL	= /usr/tech/cer/cl/src/dcl
+CL	= /net/vapor/scm2/4.2.beta/src/dcl-stable
 PWD	= /usr/tech/cer/stuff/clim-2.0
 DUMP-CL	= $(CL)
 CLOPTS	= -qq
@@ -73,6 +74,7 @@ OPENWINHOME=/usr/openwin-3.0
 
 DEBUGLIB=
 MOTIFLIB=/x11/R4/sun4-lib/libXm$(DEBUGLIB).a
+MOTIFLIB_d=/x11/R4/sun4-lib/libXm_d.a
 XLIB= /x11/R4/sun4-lib/libX11$(DEBUGLIB).a 
 XTLIB=/x11/R4/sun4-lib/libXt$(DEBUGLIB).a
 XLIBS= $(XTLIB) $(XLIB)
@@ -80,6 +82,7 @@ XLIBS= $(XTLIB) $(XLIB)
 OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2
 OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a
 LIBXOL=$(OLCOPYLIB)/libXol.a
+LIBXOL_d=$(OLCOPYLIB)/libXol.a
 
 # This has to be kept consistent with xlib.lisp
 UNDEFS=misc/undefinedsymbols
@@ -94,11 +97,14 @@ XM_UNDEFS=misc/undefinedsymbols.motif
 OL_UNDEFS=misc/undefinedsymbols.olit
 
 CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl climps.fasl
-CLIMOBJS= clim-motif.o clim-olit.o stub-xt.o stub-x.o xlibsupport.o MyDrawingA.o \
+CLIMOBJS= clim-motif_d.o clim-olit_d.o  clim-motif.o clim-olit.o stub-xt.o stub-x.o \
+	  xlibsupport.o MyDrawingA.o \
 	  olsupport.o xtsupport.o
 
 # These are linked into the distribution
-FCLIMOBJS= `pwd`/clim-motif.o `pwd`/clim-olit.o `pwd`/stub-xt.o `pwd`/stub-x.o \
+FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-olit_d.o \
+	    `pwd`/clim-motif.o `pwd`/clim-olit.o \
+	    `pwd`/stub-xt.o `pwd`/stub-x.o \
 	   `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o `pwd`/xtsupport.o
 
 # These are built into xm-dcl and ol-dcl.
@@ -223,6 +229,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \
                         clim/basic-translators.fasl \
                         clim/frames.fasl \
 			clim/default-frame.fasl \
+                        clim/activities.fasl \
 			clim/noting-progress.fasl \
                         clim/menus.fasl \
                         clim/accept-values.fasl \
@@ -487,6 +494,9 @@ compile-xm:	$(CLIMOBJS) FORCE
 		(setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \
 		(setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
 		(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \
+		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
+		(setq sys::*libx11-pathname* \"$(XLIB)\") \
+		(setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
 		(load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch
 		echo CLIM-XM compiled!!!!
 
@@ -496,6 +506,9 @@ compile-ol:	$(CLIMOBJS) FORCE
 		(setf excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \
 		(setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \
 		(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) \
 		(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \
@@ -549,9 +562,12 @@ tk/xm-defs.fasl : tk/xm-defs.lisp
 
 # Building
 
-clim-xm:	FORCE
+clim-xm:	FORCE $(CLIMOBJS)
 #	-$(RM) $(CLIM)
 	$(ECHO) " \
+		(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/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
@@ -563,6 +579,9 @@ clim-xm:	FORCE
 clim-ol:	FORCE
 #	-$(RM) $(CLIM)
 	$(ECHO) " \
+		(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/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
@@ -585,15 +604,26 @@ clim-small:	FORCE
 train	:	FORCE
 	$(TRAIN_TEXT)
 
+BENCHMARK_FILE=nil
+
+benchmark:
+	$(ECHO) "\
+	(load \"tk-silica/test-clim.lisp\") \
+	(clim-user::benchmark-clim $(BENCHMARK_FILE)) \
+"  | $(CLIM) $(CLOPTS) -batch
+
 echo-train:
 	-$(ECHO) "$(TRAIN_LISP)"
 
 # Misc
 
 
+cleanobjs: 
+	rm -f $(CLIMOBJS) stub-motif.o stub-olit.o
+
 clean:
 	find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \
-	  $(CLIMOBJS) slim slim-small
+l	  $(CLIMOBJS) slim slim-small
 
 
 cheapclean:
@@ -663,6 +693,13 @@ clim-motif.o	: stub-motif.o
 clim-olit.o	: stub-olit.o
 	ld -r -o clim-olit.o stub-olit.o $(LIBXOL)
 
+clim-motif_d.o	: stub-motif.o
+	ld -r -o clim-motif_d.o stub-motif.o $(MOTIFLIB_d)
+
+clim-olit_d.o	: stub-olit.o
+	ld -r -o clim-olit_d.o stub-olit.o $(LIBXOL_d)
+
+
 stub-motif.c	:  $(XT_UNDEFS) $(XM_UNDEFS) misc/make-stub-file
 	misc/make-stub-file "void ___lisp_load_motif_stub ()"  $(XT_UNDEFS) $(XM_UNDEFS) > stub-motif.c 
 
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index 75134b52c3d7f1595d289e313d9887311cf8a75a..0fc07489b017b0f5c9716d201c12df31aa9ca852 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.32 92/09/08 10:34:36 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.33 92/09/08 15:17:23 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -1198,7 +1198,11 @@
 		     :documentation documentation
 		     :resynchronize resynchronize)))
        (make-pane 'push-button
-	 :label prompt
+	 :label (if (stringp prompt)
+		    stream
+		  ;;--- Perhaps we should create a pixmap
+		  (with-output-to-string (stream)
+		    (funcall prompt stream)))
 	 :id record :client client
 	 :activate-callback
 	   #'(lambda (button)
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index b76754beb286252342e7c3e1fa0d7c6fc94080be..f894964ecb37b7818181cabb1c5461b4e1ca42a5 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.28 92/09/08 10:34:41 cer Exp Locker: cer $
+;; $fiHeader: db-stream.lisp,v 1.29 92/09/08 15:17:39 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -321,10 +321,10 @@
 			       ,pane)))
       (when label
 	(setq pane `(vertically ()
-			,pane
-		      (make-pane 'label-pane 
+			(make-pane 'label-pane 
 				 :label ,label
-				 :max-width +fill+))))
+				 :max-width +fill+)
+		      ,pane)))
       `(let (,stream)
 	 (values 
 	  (outlining (:thickness 1)
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 188dbabb2e4f2c5ad894dbf61e0119cb44fb723b..b383764e90c4f1e7f129c1988532923df47f46c5 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.39 92/09/08 10:34:45 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -54,7 +54,9 @@
 		:reader frame-resizable)
      (layout :initarg :layouts :reader frame-layouts)
      (top-level-process :initform nil)
-     (command-queue :initform (make-locking-queue) :reader frame-command-queue))
+     (command-queue :initform (make-locking-queue) :reader
+		    frame-command-queue)
+     (input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer))
   (:default-initargs :pointer-documentation nil
 		     :layouts nil
 		     :resize-frame nil
@@ -625,6 +627,8 @@
   (destructuring-bind (&key left top width height &allow-other-keys)
       (frame-geometry frame)
     (ecase (frame-state frame)
+      (:shrunk 
+       (note-frame-deiconified (frame-manager frame) frame))
       (:enabled)
       ((:disabled :disowned)
        (let ((old (frame-state frame)))
@@ -647,6 +651,9 @@
 	     (move-sheet (frame-top-level-sheet frame) left top))
 	   (note-frame-enabled (frame-manager frame) frame)))))))
 
+(defmethod iconify-frame ((frame standard-application-frame))
+  (note-frame-iconified (frame-manager frame) frame))
+
 (defmethod destroy-frame ((frame standard-application-frame))
   (when (eq (frame-state frame) :enabled)
     (disable-frame frame))
@@ -1035,14 +1042,17 @@
 	       (synchronous-command-event-command condition)))))
 )	;eval-when
 
+(defvar *reading-frame-command* nil)
+
 (defmethod read-frame-command :around ((frame standard-application-frame) &key)
   (let* ((command (queue-pop (frame-command-queue frame))))
     (or command 
 	(handler-bind ((synchronous-command-event
-			 #'(lambda (c)
-			     (return-from read-frame-command
-			       (synchronous-command-event-command c)))))
-	  (call-next-method)))))
+			#'(lambda (c)
+			    (return-from read-frame-command
+			      (synchronous-command-event-command c)))))
+	  (let ((*reading-frame-command* t))
+	    (call-next-method))))))
 	
 ;;--- Actually this should be named command-event
 
@@ -1347,4 +1357,10 @@
 	    right  right-presentation  right-context)))
 
 
+(defmethod raise-frame ((frame standard-application-frame))
+  (raise-sheet (frame-top-level-sheet frame)))
+
+(defmethod bury-frame ((frame standard-application-frame))
+  (bury-sheet (frame-top-level-sheet frame)))
+
 
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index f7b6449aad53856d6e16db8fd291955e53ffeccb..53ce15f64b4ce8ee4180b6ccdf220cfc979c0724 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadget-output.lisp,v 1.26 92/09/08 10:34:47 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.lisp,v 1.27 92/09/08 15:17:46 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -371,23 +371,20 @@
 		    #'(lambda (element)
 			(let* ((value (funcall value-key element))
 			       (button
-				 (make-pane 'toggle-button 
-
-				   :label
-				   
-				   (let ((name (funcall name-key element)))
-				     (if (eq printer #'write-token)
-					 name
-					 (pixmap-from-menu-item stream name printer nil)))
-				   :indicator-type (getf toggle-options :indicator-type :some-of)
-				   :value (and default-supplied-p
-					       (member value default
-						       :test test 
-						       ;;--- Should the value-key be used?
-						       :key value-key) 
-					       t)
-				   :id value
-				   toggle-options)))
+				 (apply #'make-pane 'toggle-button 
+					:label (let ((name (funcall name-key element)))
+						 (if (eq printer #'write-token)
+						     name
+						   (pixmap-from-menu-item stream name printer nil)))
+					:indicator-type (getf toggle-options :indicator-type :some-of)
+					:value (and default-supplied-p
+						    (member value default
+							    :test test 
+							    ;;--- Should the value-key be used?
+							    :key value-key) 
+						    t)
+					:id value
+					toggle-options)))
 			  button))
 		    sequence))
 	     (check-box (apply #'make-pane 'check-box
diff --git a/clim/gestures.lisp b/clim/gestures.lisp
index 70490d9530980719b8b11cdf609bc3619cfda4b0..ff11a9287669ead9d17599b6d822b930c4583b40 100644
--- a/clim/gestures.lisp
+++ b/clim/gestures.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gestures.lisp,v 1.11 92/08/18 17:24:57 cer Exp $
+;; $fiHeader: gestures.lisp,v 1.12 92/09/08 15:17:48 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -265,15 +265,15 @@
   (multiple-value-bind (keysym modifier-state) 
       (if modifier-state
 	  (values gesture-spec modifier-state)
-	  (parse-gesture-spec gesture-spec))
+	(parse-gesture-spec gesture-spec))
     (with-stack-list (key keysym modifier-state)
       (let ((table (port-canonical-gesture-specs port)))
 	(when table
 	  (multiple-value-bind (value found-p) (gethash key table)
 	    (if found-p
 		value
-		(setf (gethash (evacuate-list key) table)
-		      (call-next-method port keysym modifier-state)))))))))
+	      (setf (gethash (evacuate-list key) table)
+		(call-next-method port keysym modifier-state)))))))))
 
 ;; Needed for (sigh) string streams.  Hardly ever used...
 (defmethod port-canonicalize-gesture-spec 
diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp
index c87933d55ac618616f1e8cb1d05f2b9ccb940aa8..94deacda38802bd9886a53aaf9ed85cc1e3621ac 100644
--- a/clim/input-defs.lisp
+++ b/clim/input-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-defs.lisp,v 1.12 92/07/27 11:02:30 cer Exp $
+;; $fiHeader: input-defs.lisp,v 1.13 92/08/18 17:25:05 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -27,6 +27,9 @@
      (button-state :accessor pointer-button-state
 		   :type fixnum :initform 0)
      (position-changed :accessor pointer-position-changed)
+     ;; In case the pointer's cursor needs to be managed more directly...
+     (cursor :initform nil :reader pointer-cursor)
+     ;;-- Dunno what all this are for.
      (cursor-pattern :accessor pointer-cursor-pattern)
      (cursor-width :accessor pointer-cursor-width)
      (cursor-height :accessor pointer-cursor-height)
@@ -40,6 +43,10 @@
 (progn
   (declaim (notinline pointer-sheet (setf pointer-sheet))))
 
+(defmethod (setf pointer-cursor) (cursor (pointer standard-pointer))
+  (port-set-pointer-cursor (port pointer) pointer cursor)
+  (setf (slot-value pointer 'cursor) cursor))
+
 (defmethod pointer-position ((pointer standard-pointer))
   (with-slots (x-position y-position) pointer
     (values x-position y-position)))
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 084b36d62dd0065e5b8f5e6c58c27dd59d88a0fc..d80e0ebf1ff6c434870e6eb5004dadbf7b91ddff 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.23 92/08/19 18:04:53 cer Exp $
+;; $fiHeader: input-protocol.lisp,v 1.24 92/09/08 15:17:57 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -369,9 +369,13 @@
 		 :numeric-argument (or *accelerator-numeric-argument* 1)))
 	((member gesture *abort-gestures*
 		 :test #'keyboard-event-matches-gesture-name-p)
-	 (let ((cursor (slot-value stream 'text-cursor)))
-	   (when (and cursor
-		      (cursor-active cursor))
+	 (let* ((frame (pane-frame stream))
+		(stream (if (typep stream 'interactor-pane)
+			    stream
+			  (and frame
+			       (find-frame-pane-of-type frame 'interactor-pane))))
+		(cursor (and stream (stream-text-cursor stream))))
+	   (when (and cursor (cursor-active cursor))
 	     (write-string "[Abort]" stream)
 	     (force-output stream)))
 	 (error 'abort-gesture :event gesture))))
@@ -407,6 +411,9 @@
 	(return-from stream-read-char gesture))
       ;;--- Probably wrong.  It prevents the input editor from ever seeing
       ;;--- mouse clicks, for example.
+      (when (and (typep gesture 'key-press-event)
+		 (characterp (keyboard-event-character gesture)))
+	(return-from stream-read-char (slot-value gesture 'character)))
       (beep stream))))
 
 (defmethod stream-unread-char ((stream input-protocol-mixin) character)
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 5909bbe7d74f14b2adba8117411c2b64f80eb22c..e00a00db0e8e18c7ad6c2d3a36795e9fea6cbb21 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: output-protocol.lisp,v 1.21 92/09/08 15:18:07 cer Exp Locker: cer $
+;; $fiHeader: output-protocol.lisp,v 1.22 92/09/09 11:44:44 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -289,25 +289,19 @@
 (defmethod stream-start-line-p ((output-stream output-protocol-mixin))
   (zerop (slot-value output-stream 'cursor-x)))
 
-#+Allegro
 (defmethod stream-line-column ((output-stream output-protocol-mixin))
   (multiple-value-bind (origin-x origin-y space-width)
-      (port-glyph-for-character (port output-stream) #\space
+      (port-glyph-for-character (port output-stream) #\Space
 				(medium-merged-text-style output-stream))
     (declare (ignore origin-x origin-y))
+    ;;--- This is pretty dubious stuff
+    #-Symbolics
     (multiple-value-bind (column remainder)
 	(floor (slot-value output-stream 'cursor-x) space-width)
       (and (= remainder 0)
-	   column))))
-
-;;--- This version returns non-integers and makes allegro unhappy.
-#-Allegro
-(defmethod stream-line-column ((output-stream output-protocol-mixin))
-  (multiple-value-bind (origin-x origin-y space-width)
-      (port-glyph-for-character (port output-stream) #\Space
-				(medium-merged-text-style output-stream))
-    (declare (ignore origin-x origin-y))
-    ;; Better to return a rational number than NIL
+	   column))
+    #+Symbolics
+    ;; Better to return a rational number than NIL. 
     (/ (slot-value output-stream 'cursor-x) space-width)))
 
 (defmethod stream-advance-to-column ((output-stream output-protocol-mixin) column)
diff --git a/clim/presentations.lisp b/clim/presentations.lisp
index c3d53d2f6b7707ef0797f172dce3d9f7ebfaa06b..82738e669ff129c53646ddbfce8bda889a88caa0 100644
--- a/clim/presentations.lisp
+++ b/clim/presentations.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: presentations.lisp,v 1.14 92/08/19 10:24:03 cer Exp $
+;; $fiHeader: presentations.lisp,v 1.15 92/09/08 15:18:19 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -140,6 +140,7 @@
 	(setf (presentation-object null-presentation) null-presentation)
 	null-presentation))
 
+
 (defun window-cohorts-p (window-one window-two)
   ;; The best test for whether or not two windows care about each
   ;; other's mouse motion (for now) is whether they share an IO buffer.
diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp
index 83abbc531d1b976e3743d0891b175a915bc45189..46b978a85a7323fadc6722cd590f2c2023d6ebd6 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.12 92/08/21 16:33:59 cer Exp $
+;; $fiHeader: standard-types.lisp,v 1.13 92/09/08 15:18:32 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -359,7 +359,7 @@
   :inherit-from t			;enforce CL definition
   :history t
   :options ((default-type nil)
-	    (default-version :newest)
+	    (default-version #+allegro :unspecific #-allegro :newest)
 	    (merge-default t)))
 
 ;;; PATHNAME is supposed to be a built-in-class, but since it's missing in Genera,
diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp
index b374d3325362ca2985fc004de39b24cbf6fb800b..6593f196e899004640da0b432810474bd048a041 100644
--- a/clim/table-formatting.lisp
+++ b/clim/table-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: table-formatting.lisp,v 1.9 92/08/18 17:25:39 cer Exp Locker: cer $
+;; $fiHeader: table-formatting.lisp,v 1.10 92/08/19 18:05:04 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp
index f555e38dbe134d69a65015b4681b8b75e89c0553..084a540b2a872f73d34fb31c8b9fd4b870434683 100644
--- a/clim/text-recording.lisp
+++ b/clim/text-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-recording.lisp,v 1.10 92/08/18 17:25:43 cer Exp $
+;; $fiHeader: text-recording.lisp,v 1.11 92/09/08 15:18:38 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -29,7 +29,7 @@
 
 (defclass standard-text-output-record
 	  (output-record-element-mixin text-displayed-output-record)
-    ((string :initarg :string)
+    ((string :initarg :string :reader text-displayed-output-record-string)
      (wrapped-p :initform nil :initarg :wrapped-p)
      (ink :initarg :ink)
      (clipping-region :initarg :clipping-region)))
@@ -55,6 +55,8 @@
   :ink ink :string string :clipping-region clipping-region :wrapped-p wrapped-p
   :initial-style style :current-style style :baseline baseline)
 
+
+
 (defmethod print-object ((object standard-text-output-record) stream)
   (print-unreadable-object (object stream :type t :identity t)
     (format stream "~S /x ~A:~A y ~A:~A/"
diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp
index f4e2af7779eab355fb5ff1b1069bab6e50232a27..3ec05552ee96f826b266a653734d1242081748c3 100644
--- a/clx/clx-mirror.lisp
+++ b/clx/clx-mirror.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-mirror.lisp,v 1.11 92/08/18 17:54:05 cer Exp $
+;; $fiHeader: clx-mirror.lisp,v 1.12 92/09/08 15:17:14 cer Exp Locker: cer $
 
 (in-package :clx-clim)
 
diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp
index 1b59199563340c037a00fd1cf7d54c8086eda515..f169a622ce24a412bddfc30fe7ff5b5a03c76d9e 100644
--- a/clx/clx-port.lisp
+++ b/clx/clx-port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clx-port.lisp,v 1.12 92/07/27 11:02:02 cer Exp $
+;; $fiHeader: clx-port.lisp,v 1.13 92/08/18 17:24:27 cer Exp Locker: cer $
 
 (in-package :clx-clim)
 
@@ -505,33 +505,35 @@
 
 
 (defvar *clx-cursor-type-alist*
-  '((:default 132)
-    (:vertical-scroll 116)
-    (:scroll-up 114)
-    (:scroll-down 106)
-    (:horizontal-scroll 108)
-    (:scroll-left 110)
-    (:scroll-right 112)
-    (:busy 150)
-    (:upper-left 134)
-    (:upper-right 136)
-    (:lower-left 12)
-    (:lower-right 14)
-    (:vertical-thumb 112)
-    (:horizontal-thumb 114)
-    (:button 132)
-    (:prompt 92)
-    (:move 52)
-    (:position 34)))
-
-(defmethod install-port-cursor ((port clx-port) sheet cursor)
-  (unless (eq cursor (port-cursor port))
+	'((:default 132)
+	  (:vertical-scroll 116)
+	  (:scroll-up 114)
+	  (:scroll-down 106)
+	  (:horizontal-scroll 108)
+	  (:scroll-left 110)
+	  (:scroll-right 112)
+	  (:busy 150)
+	  (:upper-left 134)
+	  (:upper-right 136)
+	  (:lower-left 12)
+	  (:lower-right 14)
+	  (:vertical-thumb 112)
+	  (:horizontal-thumb 114)
+	  (:button 132)
+	  (:prompt 92)
+	  (:move 52)
+	  (:position 34)))
+
+;; In X Windows, cursors are associated with a particular window, so
+;; we are depending on the fact that the CLX port is not deeply mirrored
+;; to get the behavior that we can "globally" change the pointer cursor.
+(defmethod port-set-pointer-cursor ((port clx-port) pointer cursor)
+  (unless (eq (pointer-cursor pointer) cursor)
     (with-slots (display) port
-      (setf (port-cursor port) cursor)
-      (setf (xlib:window-cursor (sheet-mirror sheet))
+      (setf (xlib:window-cursor (sheet-mirror (pointer-sheet pointer)))
 	    (realize-cursor port cursor))
-      (xlib:display-force-output display))
-    cursor))
+      (xlib:display-force-output display)))
+  cursor)
 
 (defmethod realize-cursor :around ((port clx-port) cursor)
   (with-slots (cursor-cache) port
@@ -555,6 +557,7 @@
       :foreground (xlib:make-color :red   0.0 :green 0.0 :blue  0.0)
       :background (xlib:make-color :red   1.0 :green 1.0 :blue  1.0))))
 
+
 ;;--- We need something like PORT-SET-POINTER-POSITION
 (defmethod set-cursor-location ((port clx-port) sheet x y)
   (xlib:warp-pointer (sheet-mirror sheet)
diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp
index ae3065612513cdbcf86b7614286491d756966dcc..3263b3b975c92e9e132b010321e75c9de8fdac98 100644
--- a/demo/bitmap-editor.lisp
+++ b/demo/bitmap-editor.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: bitmap-editor.lisp,v 1.1 92/09/08 10:39:09 cer Exp Locker: cer $
 
 
 (in-package :clim-demo)
@@ -46,32 +46,37 @@
     (flet ((display-color (object stream)
 	     (with-room-for-graphics (stream)
 	       (draw-rectangle* stream 0 0 30 10 :ink object))))
-      (setf current-color
-	(position
-	 (accept `((completion ,colors)
-		   :name-key ,#'identity
-		   :printer ,#'display-color)
-		 :view '(clim-internals::radio-box-view :orientation
-			 :vertical :toggle-button-options (:indicator-type nil))
-		 :stream stream
-		 :default (nth current-color colors)
-		 :prompt "Colors")
-	 colors))
-      (terpri stream)
-      (accept-values-command-button (stream)
-	"Add Color"
-	(add-color-to-palette frame))
-      (terpri stream)
-      (accept-values-command-button (stream)
-	"Edit Color"
-	(replace-current-color frame))
-            (terpri stream)
-      (accept-values-command-button (stream)
-	"Delete Color"
-	(delete-current-color frame)))))
+      (formatting-item-list (stream :n-columns 2)
+	  (formatting-cell (stream)
+	      (setf current-color
+		(position
+		 (accept `((completion ,colors)
+			   :name-key ,#'identity
+			   :printer ,#'display-color)
+			 :view '(clim-internals::radio-box-view 
+				 :orientation :vertical
+				 :toggle-button-options (:indicator-type nil))
+			 :stream stream
+			 :default (nth current-color colors)
+			 :prompt "Colors")
+		 colors)))
+	(formatting-cell (stream)
+	    (formatting-item-list (stream :n-columns 1)
+		(formatting-cell (stream)
+		    (accept-values-command-button (stream)
+		      "Add Color"
+		      (add-color-to-palette frame)))
+	      (formatting-cell (stream)
+		  (accept-values-command-button (stream)
+		    "Edit Color"
+		    (replace-current-color frame)))
+	      (formatting-cell (stream)
+		  (accept-values-command-button (stream)
+		    "Delete Color"
+		    (delete-current-color frame)))))))))
 
 (defun replace-current-color (frame)
-  ;;--- Exercise for the read
+  ;;--- Exercise for the reader
   )
 
 (defun delete-current-color (frame)
@@ -190,3 +195,28 @@
 	(erase-output-record presentation stream)
 	(display-cell frame stream i j)
 	(display-pattern frame)))))
+
+
+(defvar *bitmap-editors* nil)
+
+(defun do-bitmap-editor (&key (port (find-port)) (force nil))
+  (let* ((framem (find-frame-manager :port port))
+	 (frame 
+	   (let* ((entry (assoc port *bitmap-editors*))
+		  (frame (cdr entry)))
+	     (when (or force (null frame))
+	       (setq frame (make-application-frame 'bitmap-editor
+						   :frame-manager framem)))
+	     (if entry 
+		 (setf (cdr entry) frame)
+		 (push (cons port frame) *bitmap-editors*))
+	     frame)))
+    (run-frame-top-level frame)))
+
+(define-demo "Bitmap Editor" do-bitmap-editor)
+
+
+
+
+
+  
diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp
index f326db47e0847867f0f1eacb7c11e07021972604..9fb62a7ca1828caf1459df74b7cde5c94e3d777f 100644
--- a/demo/cad-demo.lisp
+++ b/demo/cad-demo.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cad-demo.lisp,v 1.15 92/08/18 17:26:16 cer Exp Locker: cer $
+;; $fiHeader: cad-demo.lisp,v 1.16 92/09/08 10:35:11 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -536,9 +536,7 @@
     (design-area :application))
   (:pointer-documentation t)
   (:layouts
-    (default design-area))
-  (:top-level
-    (default-frame-top-level :partial-command-parser cad-demo-partial-command-parser)))
+   (default design-area)))
 
 (defmethod initialize-instance :around ((cd cad-demo) &key)
   (call-next-method)
@@ -547,15 +545,6 @@
     (setf (stream-output-history dp) cd)
     (setf (stream-recording-p dp) nil)))
 
-(defun cad-demo-partial-command-parser (partial-command command-table stream start-location)
-  (let ((name (command-name partial-command)))
-    (if (eq name 'com-create-component)
-	(accept-values-command-parser
-	  name command-table (frame-top-level-sheet *application-frame*) partial-command
-	  :own-window t)
-        (menu-read-remaining-arguments-for-partial-command
-	  partial-command command-table stream start-location))))
-
 (defmethod bounding-rectangle* ((cd cad-demo))
   (let ((left 0)
 	(top 0)
@@ -797,32 +786,21 @@
 ;;; Commands
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-#+++ignore	;---why doesn't this work?
-(define-cad-demo-command (com-create-component :menu "Create")
-    ((type `(member-alist ,*component-types*)
-	   :prompt "Component type")
-     (position 'cad-position
-	       :prompt "Position"))
-  (let ((object (make-instance type :x (car position) :y (cdr position))))
-    (add-new-object *application-frame* object)
-    (draw-self object (get-frame-pane *application-frame* 'design-area))))
-
-#---ignore
+;;;--- A good exercise for the reader would be to use a partial
+;;;--- command parser to read the type and position as the arguments.
+;;; cos we currently have to do it in the command body.
+
 (define-cad-demo-command (com-create-component :menu "Create" :keystroke #\C)
-    ;; The substrate doesn't yet support popping up the menu for the first arg...
-    #+ignore ((type `((menu-alist ,*component-types*)))
-	      (position 'cad-position))
-    #-ignore ()
-    ;; ... so we do it in the command body.
-    (let* ((window (get-frame-pane *application-frame* 'design-area))
-	   (type (menu-choose *component-types*
-			      :associated-window (window-root window)
-			      :cache t :unique-id 'component-types)))
-      (when type
-	(let* ((position (accept 'cad-position :stream window :prompt nil))
-	       (object (make-instance type :x (car position) :y (cdr position))))
-	  (add-new-object *application-frame* object)
-	  (draw-self object window)))))
+    ()
+  (let* ((window (get-frame-pane *application-frame* 'design-area))
+	 (type (menu-choose *component-types*
+			    :associated-window (window-root window)
+			    :cache t :unique-id 'component-types)))
+    (when type
+      (let* ((position (accept 'cad-position :stream window :prompt nil))
+	     (object (make-instance type :x (car position) :y (cdr position))))
+	(add-new-object *application-frame* object)
+	(draw-self object window)))))
 
 ;;; Takes two operands, an input terminal and an output terminal
 ;;; --- This needs to propagate value changes down the line, or
diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp
index 0834c4affa9b725b38628dee5899a6c6bfa81984..efd3cca41cda8293a2c8ee5d3b39940e5cf6c308 100644
--- a/demo/graphics-editor.lisp
+++ b/demo/graphics-editor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-editor.lisp,v 1.6 92/09/08 10:35:15 cer Exp Locker: cer $
+;; $fiHeader: graphics-editor.lisp,v 1.7 92/09/08 15:19:01 cer Exp Locker: cer $
 
 (in-package :clim-graphics-editor)
 
@@ -554,6 +554,7 @@
 
 (define-command (com-quit :command-table graphics-editor-file-commands
 			  :keystroke (:x :meta)
+			  :name "Quit"
 			  :menu t) ()
   (frame-exit *application-frame*))
 
@@ -569,7 +570,7 @@
 
 (defvar *graphics-editors* nil)
 
-(defun do-graphics-editor (&key (port (find-port)) (force t))
+(defun do-graphics-editor (&key (port (find-port)) (force nil))
   (let* ((framem (find-frame-manager :port port))
 	 (frame 
 	   (let* ((entry (assoc port *graphics-editors*))
diff --git a/demo/ico.lisp b/demo/ico.lisp
index 69825e48cf069a0924a3d3a398c697468eb58733..75a813b8e2fe8659985c7a3b7f6fc5c799d4c773 100644
--- a/demo/ico.lisp
+++ b/demo/ico.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: ico.lisp,v 1.4 92/07/27 11:03:31 cer Exp Locker: cer $
+;; $fiHeader: ico.lisp,v 1.5 92/08/18 17:26:20 cer Exp Locker: cer $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -40,23 +40,25 @@
 
 (defmethod display-options-pane ((frame ico-frame) pane &key max-width max-height)
   (declare (ignore max-width max-height))
-  (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame
-    (setf ico-time-p (accept 'boolean 
-			     :default ico-time-p
-			     :stream pane
-			     :prompt "Time"))
-    (terpri pane)
-    (let ((x (append (and draw-faces '(:faces))
-		     (and draw-edges '(:edges)))))
-      (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
-      (terpri pane)
-      (setf draw-edges (and (member :edges x) t)
-	    draw-faces (and (member :faces x) t)))
-    (setf ico-line-style (accept '(member :thin :thick)
-				 :default ico-line-style
-				 :stream pane
-				 :prompt "Line Style"))
-    (terpri pane)))
+  (formatting-item-list (pane :n-rows 1)
+      (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame
+	(formatting-cell (pane)
+	    (setf ico-time-p (accept 'boolean 
+				     :default ico-time-p
+				     :stream pane
+				     :prompt "Time")))
+	(formatting-cell (pane)
+	    (let ((x (append (and draw-faces '(:faces))
+			     (and draw-edges '(:edges)))))
+	      (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
+	      (setf draw-edges (and (member :edges x) t)
+		    draw-faces (and (member :faces x) t))))
+	(formatting-cell (pane)
+	    (setf ico-line-style (accept '(member :thin :thick)
+					 :default ico-line-style
+					 :stream pane
+					 :prompt "Line Style"))))))
+
 
 (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) ()
   (with-application-frame (frame)
diff --git a/demo/plot.lisp b/demo/plot.lisp
index 65a5a072fdae53a4cd87d537f3e88f85815817dc..14245d2dc940f83624d5a439aa62e7c6774dc9d8 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+>;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
 ;;
 ;;				-[]-
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: plot.lisp,v 1.6 92/08/18 17:26:23 cer Exp Locker: cer $
+;; $fiHeader: plot.lisp,v 1.7 92/09/08 10:35:16 cer Exp $
 
 (in-package :clim-demo)
 
@@ -52,16 +52,35 @@
 ;; We should make presentations of these types
 
 (define-presentation-type graph-plot ())
+
 (define-presentation-type graph-region ())
 
+(define-presentation-method accept ((type graph-region) stream (view textual-view) &key)
+  (let ((ltrb (accept `((sequence-enumerated 
+			  ((sequence-enumerated real real) :echo-space nil)
+			  ((sequence-enumerated real real) :echo-space nil))
+			:separator #\: :echo-space nil) 
+		      :prompt nil :stream stream)))
+    (destructuring-bind ((left top) (right bottom)) ltrb
+      (make-rectangle* left top right bottom))))
+
+(define-presentation-method present (region (type graph-region) stream (view textual-view) &key)
+  (with-bounding-rectangle* (left top right bottom) region
+    (present `((,left ,top) (,right ,bottom))
+	     `((sequence-enumerated 
+		 ((sequence-enumerated real real) :echo-space nil)
+		 ((sequence-enumerated real real) :echo-space nil))
+	       :separator #\: :echo-space nil)
+	     :stream stream)))
+
 (define-presentation-method presentation-typep (object (type graph-region))
-  (typep object 'standard-rectangle))
+  (rectanglep object))
 
 (define-command-table plot-command-table)
 
 (define-presentation-translator select-graph-region
     (graph-plot graph-region plot-command-table :gesture :select)
-    (x y window)
+  (x y window)
   (let ((nx x)
 	(ny y)
 	(ox x)
@@ -72,22 +91,49 @@
 				:filled nil :ink +flipping-ink+)))
 	(declare (dynamic-extent #'draw-it))
 	(draw-it)
-	(tracking-pointer (window)
-	  (:pointer-motion (x y)
-	   (draw-it) 
-	   (setq nx x ny y)
-	   (draw-it))
-	  (:pointer-button-press (x y)
-	   (draw-it)
-	   (setq nx x ny y)
-	   (return (make-rectangle* ox oy nx ny))))))))
+	(clim-utils:letf-globally (((sheet-pointer-cursor window) (sheet-pointer-cursor window)))
+	  (tracking-pointer (window)
+	    (:pointer-motion (x y)
+			     (draw-it) 
+			     (setq nx x ny y)
+			     (draw-it)
+			     (setf (sheet-pointer-cursor window)
+			       (if (< nx ox)
+				   (if (< ny oy)
+				       :upper-left
+				     :lower-left)
+				 (if (< ny oy)
+				       :upper-right
+				     :lower-right))))
+	    (:pointer-button-press (x y)
+				   (draw-it)
+				   (setq nx x ny y)
+				   (return (make-rectangle* ox oy nx ny)))))))))
 
 ;; Define a presentation translator from a graph-plot to a graph-region.
 ;; In that way we trivially write a command that will zoom into a
 ;; particular region of the graph.
 
-(define-presentation-type graph-point ())
-(define-presentation-type graph-line ())
+(define-presentation-type plot-point ())
+
+(define-presentation-method accept ((type plot-point) stream (view textual-view) &key)
+  (values (accept `((sequence-enumerated real real) :echo-space nil) 
+		  :prompt nil :stream stream)))
+
+(define-presentation-method present (point (type plot-point) stream (view textual-view) &key)
+  (present point `((sequence-enumerated real real) :echo-space nil)
+	   :stream stream))
+
+(define-presentation-method presentation-typep (object (type plot-point))
+  (and (listp object)
+       (= (length object) 2)
+       (every #'realp object)))
+
+(define-presentation-type graph-point ()
+  :inherit-from 'plot-point)
+
+(define-presentation-type graph-line ()
+  :inherit-from 'integer)
 
 (define-presentation-type graph-axis ())
 
@@ -427,7 +473,8 @@
      (y-labels :initform  (copy-list '("Mexico City" "Tokyo" "New York"))))
   (:command-table (plot-demo :inherit-from (plot-command-table accept-values-pane)))
   (:panes 
-    (graph-window :application
+   (graph-window :application
+		 :label "Plot"
 		  :display-function 'display-graph
 		  :incremental-redisplay t
 		  :end-of-line-action :allow
@@ -435,6 +482,7 @@
 		  :scroll-bars :both
 		  :width :compute :height :compute)
     (data-window :application
+		 :label "Data"
 		 :display-function 'display-data
 		 :incremental-redisplay t
 		 :end-of-line-action :allow
@@ -442,6 +490,7 @@
 		 :scroll-bars :both
 		 :width :compute :height :compute)
     (options :accept-values
+	     :label "Options"
 	     :scroll-bars :both
 	     :display-function `(accept-values-pane-displayer
 				  :resynchronize-every-pass t
@@ -487,9 +536,13 @@
 (defmethod frame-standard-output ((fr plot-demo))
   (get-frame-pane fr 'command))
 
-(define-presentation-type data-point ())
-(define-presentation-type x-label ())
-(define-presentation-type y-label ())
+(define-presentation-type data-point ()
+  :inherit-from 'plot-point)
+
+(define-presentation-type x-label ()
+  :inherit-from 'integer)
+(define-presentation-type y-label ()
+  :inherit-from 'integer)
 
 (defmethod display-data ((frame plot-demo) stream &key &allow-other-keys)
   (updating-output (stream)
@@ -544,14 +597,6 @@
 			  (with-output-as-presentation (stream n 'number)
 			    (format stream "~2D" n)))))))))))))))
 
-(define-plot-demo-command (com-edit-x-label :name t :menu t)
-    ((i 'x-label :gesture :select))
-  (with-application-frame (frame)
-    (setf (nth i (slot-value frame 'x-labels))
-	  (accept 'string
-		  :default (nth i (slot-value frame 'x-labels))))))
-
-
 #+allegro
 (define-plot-demo-command (com-print-graph :name t :menu t)
     ((printer '(member :lw :lw2 :lw3)
@@ -562,8 +607,59 @@
     (with-output-to-postscript-stream (stream pipe :multi-page t)
       (display-graph *application-frame* stream))))
 
+(define-plot-demo-command (com-edit-x-label :name t :menu t)
+    ((i 'x-label :gesture :select))
+  (with-application-frame (frame)
+    (setf (nth i (slot-value frame 'x-labels))
+	  (accept 'string
+		  :default (nth i (slot-value frame 'x-labels))))))
 
 
+(define-presentation-action drag-it-translator
+    (blank-area command plot-command-table 
+		:documentation "Drag"
+		:gesture :describe)
+  (window)
+  (let (ox oy
+	;;--- We use this sheet because its a stable reference sheet.
+	;;--- We cannot use the window because its native transformation
+	;;--- changes as we go and than causes confusion
+	(sheet (frame-top-level-sheet (pane-frame window))))
+    (multiple-value-bind (minx miny maxx maxy) (viewport-range window)
+      (clim-utils:letf-globally (((sheet-pointer-cursor sheet) :move))
+	(tracking-pointer (sheet :multiple-window t)
+	  (:pointer-motion (x y)
+			   (multiple-value-bind (vx vy) (window-viewport-position window)
+			     (when ox
+			       (window-set-viewport-position
+				window
+				(min maxx (max minx (+ vx (- x ox)))) ; +/-
+				(min maxy (max miny (+ vy (- y oy))))))  ; +/-
+			     (setq ox x oy y)))
+	  (:pointer-button-press (x y)
+				 (when ox
+				   (multiple-value-bind (vx vy) (window-viewport-position window)
+				     (window-set-viewport-position
+				      window
+				      (min maxx (max minx (+ vx (- x ox))))
+				      (min maxy (max miny (+ vy (- y oy))))))
+				   (return nil))))))))
+
+(defun viewport-range (window)
+  (multiple-value-bind (vwidth vheight)
+      (bounding-rectangle-size (pane-viewport-region window))
+    (with-bounding-rectangle* (left top right bottom) 
+	(silica::viewport-contents-extent (pane-viewport window))
+      (let ((cwidth (- right left))
+	    (cheight (- bottom top)))
+	(values left 
+		top
+		(+ left (max 0 (- cwidth vwidth)))
+		(+ top (max 0 (- cheight vheight))))))))
+	      
+	      
+      
+
 (define-plot-demo-command (com-edit-y-label :name t :menu t)
     ((i 'y-label :gesture :select))
   (with-application-frame (frame)
@@ -672,3 +768,5 @@
     (run-frame-top-level frame)))
 
 (define-demo "Plotting Demo" do-plot-demo)
+
+
diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp
index 9af5425f606bc716b56c658c9922401c8ad89ef0..c6b7288ab613f675caee1fc3c104b16f857daf3d 100644
--- a/demo/puzzle.lisp
+++ b/demo/puzzle.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: puzzle.lisp,v 1.13 92/08/21 16:34:11 cer Exp $
+;; $fiHeader: puzzle.lisp,v 1.14 92/09/08 15:19:06 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp
index 22bdcc3f1505d6ee0c8b2287ee8f93f0bfb71892..2cb8e2b0e73ba301fb89ba747acdfe8de9e1d910 100644
--- a/demo/sysdcl.lisp
+++ b/demo/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.15 92/08/18 17:26:25 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.16 92/09/08 10:35:18 cer Exp Locker: cer $
 
 (in-package #-ansi-90 :user #+ansi-90 :common-lisp-user)
 
@@ -35,6 +35,7 @@
   ("browser"	     :load-before-compile ("demo-driver" "packages"))
   #+Allegro
   ("process-browser" :load-before-compile ("demo-driver" "packages"))
+  ("demo-activity" :load-before-compile ("demo-driver" "packages"))
   ("bitmap-editor"    :load-before-compile ("demo-driver" "packages"))
  
  ("demo-prefill"    :features (or Genera Cloe-Runtime)))
diff --git a/misc/compile-ol.lisp b/misc/compile-ol.lisp
deleted file mode 100644
index 4c31aedde561de5d4d70b9cde86f3ff27884b5be..0000000000000000000000000000000000000000
--- a/misc/compile-ol.lisp
+++ /dev/null
@@ -1,30 +0,0 @@
-;; -*- mode: common-lisp; package: user -*-
-;;
-;;				-[]-
-;; 
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
-;; copyright (c) 1986-1991 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: compile-ol.lisp,v 1.1 92/03/24 19:45:41 cer Exp $
-
-(in-package :user)
-
-(pushnew :clim-openlook *features*)
-
-(load "misc/compile-1")
-(compile-it 'openlook-clim)
diff --git a/misc/compile-xm.lisp b/misc/compile-xm.lisp
deleted file mode 100644
index bc7fe918fe006f99d81e17889743baf70684aedc..0000000000000000000000000000000000000000
--- a/misc/compile-xm.lisp
+++ /dev/null
@@ -1,30 +0,0 @@
-;; -*- mode: common-lisp; package: user -*-
-;;
-;;				-[]-
-;; 
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
-;; copyright (c) 1986-1991 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: compile-xm.lisp,v 1.7 92/03/24 19:38:31 cer Exp $
-
-(in-package :user)
-
-(pushnew :clim-motif *features*)
-
-(load "misc/compile-1")
-(compile-it 'motif-clim)
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index bf31aee6e346631c8cb2ae83b6dd458ddf53096b..8bc560d9d768d64fc77b269789bc5acbb7f02a2a 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.11 92/09/08 10:35:25 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.12 92/09/08 15:19:10 cer Exp Locker: cer $
 
 ;;;; This should not matter
 ;;;; (setq *ignore-package-name-case* t)
@@ -83,7 +83,7 @@
      #-ignore
      (clim-defsys::load-system 'clim-demo)))
   
-
+  #+:allegro-v4.1
   (when (probe-file "/scm/4.1/sparc/src/code/")
     (let ((sys::*require-search-list*
 	   (cons (make-pathname :directory "/scm/4.1/sparc/src/code/"
@@ -98,4 +98,5 @@
     (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/"))
 
   (tenuring
-   (load "misc/clos-preload.fasl" :if-does-not-exist nil)))
+	(ignore-errors
+	   (load "misc/clos-preload.fasl" :if-does-not-exist nil))))
diff --git a/misc/dev-load-ol.lisp b/misc/dev-load-ol.lisp
deleted file mode 100644
index 3876e0973be76e65cba07eca5ddd59b2dcd36321..0000000000000000000000000000000000000000
--- a/misc/dev-load-ol.lisp
+++ /dev/null
@@ -1,28 +0,0 @@
-;; -*- mode: common-lisp; package: user -*-
-;;
-;;				-[]-
-;; 
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
-;; copyright (c) 1986-1991 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: dev-load-ol.lisp,v 1.2 92/05/07 13:13:48 cer Exp $
-
-(pushnew :clim-openlook *features*)
-
-(load "misc/dev-load-1")
-(load-it 'openlook-clim)
diff --git a/misc/dev-load-xm.lisp b/misc/dev-load-xm.lisp
deleted file mode 100644
index 156ea7cabec8fcb701b1267f70cbf6e9645a33e4..0000000000000000000000000000000000000000
--- a/misc/dev-load-xm.lisp
+++ /dev/null
@@ -1,28 +0,0 @@
-;; -*- mode: common-lisp; package: user -*-
-;;
-;;				-[]-
-;; 
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
-;; copyright (c) 1986-1991 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: dev-load-xm.lisp,v 1.7 92/05/07 13:13:49 cer Exp $
-
-(pushnew :clim-motif *features*)
-
-(load "misc/dev-load-1")
-(load-it 'motif-clim)
diff --git a/silica/classes.lisp b/silica/classes.lisp
index bcddbd31e101aac6bcbc9b900754fd12b44d3bf7..fd39cfe7df23a5a923dbbcdec6483bb1ab08382c 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.16 92/08/19 18:04:12 cer Exp $
+;; $fiHeader: classes.lisp,v 1.17 92/09/08 15:16:29 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -32,7 +32,6 @@
      (medium-cache :initform nil :accessor port-medium-cache)
      (color-cache :initform (make-hash-table) :reader port-color-cache)
      (pointer :initform nil)
-     (cursor :initform nil :accessor port-cursor)
      (mapping-table :initform (make-hash-table :test #'equal))
      (mapping-cache :initform (cons nil nil))	;one entry cache
      (undefined-text-style :initform *undefined-text-style*
@@ -56,13 +55,15 @@
 
 ;;--- Make a SHEET protocol class, and call this BASIC-SHEET
 (defclass sheet ()
-    ((port :initform nil :reader port)
-     (graft :initform nil :reader graft)
-     (parent :initform nil 
-	     :accessor sheet-parent)
-     (region :initarg :region :initform (make-bounding-rectangle 0 0 100 100)
-	     :accessor sheet-region)
-     (enabledp :initform nil :accessor sheet-enabled-p)))
+	  ((port :initform nil :reader port)
+	   (graft :initform nil :reader graft)
+	   (parent :initform nil 
+		   :accessor sheet-parent)
+	   (region :initarg :region :initform (make-bounding-rectangle 0 0 100 100)
+		   :accessor sheet-region)
+	   (enabledp :initform nil :accessor sheet-enabled-p)
+	   ;;-- Is this the best place
+	   (cursor :initform nil :reader sheet-pointer-cursor)))
 
 
 (define-protocol-class medium ())
@@ -214,4 +215,4 @@
 (deftype lock-keysym    () '(member :caps-lock :shift-lock :mode-lock))
 
 (deftype modifier-keysym ()
-  '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym lock-keysym))
+  '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym))
diff --git a/silica/event.lisp b/silica/event.lisp
index c3f9318bd9ef854febd4319d6ac95ec11ceaf40a..ea0c40689d306c226e7d1b4ab0c91c61dbf8d68b 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: event.lisp,v 1.20 92/08/18 17:23:36 cer Exp $
+;; $fiHeader: event.lisp,v 1.21 92/09/08 15:16:38 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -156,6 +156,13 @@
 
 ;;; Crossing events
 
+
+;; Note that exit events on the parent are generated when the pointer goes
+;; from a parent to a child, and that enter events on the parent are generated
+;; when the pointer goes back from the child to the parent again.  If these
+;; events are not interesting, the user should ignore all pointer-enter and
+;; exit events that have a kind of :inferior.
+;;
 ;; We have fun here to generate enter/exit events for unmirrored sheets
 ;; Three cases:
 ;; 1. Mouse motion event:
@@ -187,6 +194,165 @@
 ;;    We should probably exit from intermediate descendents.
 ;;    Sheet- x,y,z --> Child
 ;; 4. Share a common ancestor: exit from all of the sheets.
+
+
+;;
+;; There is a lot of unnecessary hair in this code because a sheet's
+;; region is not always correct in the current implementation!
+;;
+
+
+#-jdi-version
+(defun generate-crossing-events (port event)
+  (declare (optimize (speed 3)))
+  (let* ((mirrored-sheet (event-sheet event))
+	 (toplevel-sheet mirrored-sheet)
+	 (x (pointer-event-native-x event))
+	 (y (pointer-event-native-y event))
+	 (modifiers (event-modifier-state event))
+	 (pointer (pointer-event-pointer event))
+	 (ancestors-of-mirrored-sheet
+	  (do ((sheets nil)
+	       (sheet (sheet-parent mirrored-sheet) (sheet-parent sheet)))
+	      ((graftp sheet) sheets)
+	    (push sheet sheets))))
+    (macrolet ((generate-enter-event (sheet kind)
+		 `(let ((sheet ,sheet))
+		    (dispatch-event
+		     sheet
+		     (allocate-event 'pointer-enter-event
+				     :sheet sheet
+				     :x x :y y
+				     :kind ,kind
+				     :modifier-state modifiers
+				     :pointer pointer))))
+	       (generate-exit-event (sheet kind)
+		 `(let ((sheet ,sheet))
+		    (dispatch-event
+		     sheet
+		     (allocate-event 'pointer-exit-event
+				     :sheet sheet
+				     :x x :y y
+				     :kind ,kind
+				     :modifier-state modifiers
+				     :pointer pointer)))))
+      
+      ;; If we got an event for some mirrored child, go back to the top level
+      ;; sheet.
+      (unless (graftp (sheet-parent mirrored-sheet))
+	(let ((new-x x)
+	      (new-y y))
+	  (dolist (sheet (cons mirrored-sheet (reverse ancestors-of-mirrored-sheet)))
+	    (when (graftp (sheet-parent sheet))
+	      (setq x new-x
+		    y new-y
+		    toplevel-sheet sheet)
+	      (return))
+	    (multiple-value-setq (new-x new-y)
+	      (map-sheet-position-to-parent sheet new-x new-y)))))
+      
+      (let* ((v (port-trace-thing port))
+	     (exitted-a-window 
+	      (and (typep event 'pointer-exit-event)
+		   (not (eq (pointer-boundary-event-kind event) :inferior))))
+	     (entered-from-child
+	      (and (typep event 'pointer-enter-event)
+		   (eq (pointer-boundary-event-kind event) :inferior)))
+	     (exitted-top-level-window
+	      (and exitted-a-window
+		   (eq toplevel-sheet mirrored-sheet))))
+#|
+	(format excl:*initial-terminal-io*
+		"Inside g-c-e, top-sheet: ~s, mir-sheet: ~s,~% port-trace: "
+		toplevel-sheet mirrored-sheet)
+	(dotimes (i (fill-pointer v))
+	  (format excl:*initial-terminal-io* "  ~s~%" (aref v i)))
+	(format excl:*initial-terminal-io* "~%event: ~s~%" event)
+|#
+	(when (or (not exitted-a-window)
+		  exitted-top-level-window)
+	  #+Genera (declare (sys:array-register v))
+	  ;; Pop up the stack of sheets
+	  (unless (zerop (fill-pointer v))
+	    (let ((m (if (and (not exitted-top-level-window)
+			      (eq (aref v 0) toplevel-sheet))
+			 (let ((new-x x)
+			       (new-y y)
+			       (mirrored-sheet-in-trace
+				(position mirrored-sheet v :test #'eq))
+			       sheet)
+			   (if (and mirrored-sheet-in-trace
+				    (> mirrored-sheet-in-trace 1))
+			       (do ((i 1 (1+ i)))
+				   ((> i mirrored-sheet-in-trace))
+				 (multiple-value-setq (new-x new-y)
+				   (map-sheet-position-to-child
+				    (aref v i) new-x new-y))))
+			   (do ((i (if mirrored-sheet-in-trace
+				       (1+ mirrored-sheet-in-trace) 0) (1+ i)))
+			       ((>= i (fill-pointer v)) (fill-pointer v))
+			     (setq sheet (aref v i))
+			     (unless (zerop i)
+			       (multiple-value-setq (new-x new-y)
+				 (map-sheet-position-to-child sheet new-x new-y)))
+			     (when (or (and (not mirrored-sheet-in-trace)
+					    (not (member sheet ancestors-of-mirrored-sheet)))
+				       (not (sheet-enabled-p sheet))
+				       (not (region-contains-position-p 
+					     (sheet-region sheet) new-x new-y)))
+			       (return i))))
+		       0)))
+	      (do ((i (1- (fill-pointer v)) (1- i)))
+		  ((< i m))
+		(generate-exit-event (aref v i) :ancestor)
+		(unless (zerop i)
+		  (generate-enter-event (aref v (1- i)) :inferior)))
+	      (setf (fill-pointer v) m))))
+	(when (and (not exitted-a-window)
+		   (not entered-from-child)
+		   (region-contains-position-p (sheet-region toplevel-sheet) x y))
+	  ;; If its empty initialize it with the toplevel sheet.
+	  (when (zerop (fill-pointer v))
+	    (vector-push-extend toplevel-sheet v)
+	    (generate-enter-event toplevel-sheet :ancestor))
+	  ;; Now add all sheets between the last sheet on the trace
+	  ;; and the mirrored sheet.
+	  (unless (find mirrored-sheet v :test #'eq)
+	    (let ((last-sheet (aref v (1- (fill-pointer v))))
+		  (sheets nil))
+	      (do ((sheet mirrored-sheet (sheet-parent sheet)))
+		  ((or (eq sheet last-sheet)
+		       (when (graftp sheet)
+			 (setq sheets nil)
+			 t)))
+		(push sheet sheets))
+	      (dolist (sheet sheets)
+		(generate-exit-event (aref v (1- (fill-pointer v))) :inferior)
+		(generate-enter-event sheet :ancestor)
+		(vector-push-extend sheet v))))
+	  ;; We have to get the sheets into the correct coordinate space
+	  (loop for i from 1 below (fill-pointer v)
+	      do (multiple-value-setq (x y)
+		   (map-sheet-position-to-child (aref v i) x y)))
+	  ;; Finally add progeny of mirrored-sheet.
+	  (let ((new-x x)
+		(new-y y)
+		(sheet (aref v (1- (fill-pointer v))))
+		child)
+	    (loop
+	      (unless (typep sheet 'sheet-parent-mixin) 
+		(return nil))
+	      (setq child (child-containing-position sheet new-x new-y))
+	      (unless child
+		(return nil))
+	      (generate-exit-event sheet :inferior)
+	      (generate-enter-event child :ancestor)
+	      (multiple-value-setq (new-x new-y)
+		(map-sheet-position-to-child child new-x new-y))
+	      (setq sheet child)
+	      (vector-push-extend child v))))))))
+
+#+pre-jdi-version
 (defun generate-crossing-events (port event)
   (declare (optimize (speed 3)))
   (let* ((mirrored-sheet (event-sheet event))
@@ -305,6 +471,7 @@
 		(map-sheet-position-to-child child new-x new-y))
 	      (setq sheet child)
 	      (vector-push-extend child v))))))))
+>>>>>>> 1.21
 
 
 ;;; Event distribution
@@ -343,7 +510,7 @@
 	(y (pointer-event-native-y event))
 	(modifiers (event-modifier-state event))
 	(pointer (pointer-event-pointer event)))
-    ;; Dispatch event to the innermost sheet
+    ;; dispatch event to the innermost sheet
     (let ((sheet (let ((v (port-trace-thing port)))
 		   (and (not (zerop (fill-pointer v)))
 			(aref v (1- (fill-pointer v)))))))
@@ -356,29 +523,29 @@
 		(pointer-y-position pointer) ty
 		(pointer-native-x-position pointer) x
 		(pointer-native-y-position pointer) y)
-	  (typecase event
-	    (pointer-button-event
+	   (typecase event
+	     (pointer-button-event
 	      (dispatch-event
-		sheet
-		(allocate-event event-type
-		  :sheet sheet
-		  :native-x x :native-y y
-		  :x tx :y ty
-		  :modifier-state modifiers
-		  :button (pointer-event-button event)
-		  :pointer pointer)))
-	    (pointer-motion-event
+	       sheet
+	       (allocate-event event-type
+			       :sheet sheet
+			       :native-x x :native-y y
+			       :x tx :y ty
+			       :modifier-state modifiers
+			       :button (pointer-event-button event)
+			       :pointer pointer)))
+	     (pointer-motion-event
 	      (dispatch-event
-		sheet
-		(allocate-event event-type
-		  :sheet sheet
-		  :native-x x :native-y y
-		  :x tx :y ty
-		  :modifier-state modifiers
-		  :pointer pointer)))
-	    ;; Pointer exit and enter events are handled
-	    ;; by GENERATE-CROSSING-EVENTS.
-	    )))))
+	       sheet
+	       (allocate-event event-type
+			       :sheet sheet
+			       :native-x x :native-y y
+			       :x tx :y ty
+			       :modifier-state modifiers
+			       :pointer pointer)))
+	     ;; Pointer exit and enter events are handled
+	     ;; by generate-crossing-events.
+	     )))))
   (deallocate-event event))
 	    
 
@@ -533,10 +700,13 @@
 	  (setf (slot-value copy name) (slot-value event name)))))
     copy))
 
-#||
+
+
+#|
 ;; Debugging help
+
 (defmethod print-object ((event pointer-boundary-event) stream)
-  (print-unreadable-object (event stream :type t :identity *print-escape*)
+  (print-unreadable-object (event stream :type t :identity nil)
     (let ((comma nil))
       (when (slot-boundp event 'sheet)
 	(let ((sheet (event-sheet event)))
@@ -547,4 +717,28 @@
 	(if comma
 	    (write-string ", " stream))
 	(format stream "kind ~s" (pointer-boundary-event-kind event))))))
-||#
+
+(defmethod print-object ((event pointer-motion-event) stream)
+  (print-unreadable-object (event stream :type t :identity nil)
+    (let ((comma nil))
+      (when (slot-boundp event 'sheet)
+	(let ((sheet (event-sheet event)))
+	  (format stream "~:[~;mirrored ~]sheet ~s"
+		  (sheet-direct-mirror sheet) sheet))
+	(setq comma t))
+      (when (slot-boundp event 'x)
+	(if comma
+	    (write-string ", " stream))
+	(format stream "x: ~d, y: ~d"
+		(pointer-event-x event) (pointer-event-y event))
+	(setq comma t))
+      (when (slot-boundp event 'native-x)
+	(if comma
+	    (write-string ", " stream))
+	(format stream "nx: ~d, ny: ~d"
+		(pointer-event-native-x event) (pointer-event-native-y event))
+	))))
+
+
+|#
+
diff --git a/silica/framem.lisp b/silica/framem.lisp
index cb1a7341420746f8b6d1e42cef54831fd3884bf6..38553560a438e596edcd908a728f083854c7e147 100644
--- a/silica/framem.lisp
+++ b/silica/framem.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: framem.lisp,v 1.13 92/08/18 17:23:38 cer Exp $
+;; $fiHeader: framem.lisp,v 1.14 92/09/08 15:16:40 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -76,7 +76,9 @@
     (let* ((top-pane (frame-panes frame))
 	   (sheet (with-look-and-feel-realization (framem frame)
 		    (make-pane 'top-level-sheet
+                      :event-queue (clim-internals::frame-input-buffer frame)
 		      :user-specified-position-p (frame-user-specified-position-p frame)
+
 		      :user-specified-size-p (frame-user-specified-size-p frame)
 		      :region (multiple-value-bind (width height)
 				  (bounding-rectangle-size top-pane)
@@ -86,6 +88,8 @@
 	    (frame-shell frame) (sheet-shell sheet))
       (sheet-adopt-child sheet (frame-panes frame)))))
 
+
+
 (defmethod adopt-frame :after ((framem standard-frame-manager) frame)
   (setf (frame-manager-frames framem)
 	(nconc (frame-manager-frames framem) (list frame))))
@@ -177,3 +181,9 @@
   (declare (ignore realizer type))
   (declare (non-dynamic-extent options))
   options)
+
+(defmethod note-frame-iconified ((framem standard-frame-manager) frame)
+  (setf (frame-state frame) :shrunk))
+
+(defmethod note-frame-deiconified ((framem standard-frame-manager) frame)
+  (setf (frame-state frame) :enabled))
diff --git a/silica/mirror.lisp b/silica/mirror.lisp
index 65d444d3620fd222dba864e18710dc8cc0e3f8e6..64a1a6d343538888a9627e0eb3406215fac55385 100644
--- a/silica/mirror.lisp
+++ b/silica/mirror.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: mirror.lisp,v 1.24 92/08/18 17:23:51 cer Exp $
+;; $fiHeader: mirror.lisp,v 1.25 92/09/08 15:16:47 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -149,8 +149,6 @@
 
 ;; Returns the regions mirror in the mirror coordinate space
 (defgeneric mirror-region (port sheet))
-(defgeneric mirror-region* (port sheet))
-(defgeneric mirror-inside-region* (port sheet))
 (defgeneric mirror-native-edges* (port sheet))
 (defgeneric mirror-inside-edges* (port sheet))
 (defgeneric set-sheet-mirror-edges* (port sheet left top right bottom))
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index 3b0bed89325f2067dc285a9320d5ea6fc8ffbbde..f6240f362504a66631f6db45a7f00fce4d78a7db 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sheet.lisp,v 1.24 92/08/18 17:23:55 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.25 92/09/08 15:16:51 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -141,16 +141,20 @@
   (let ((parent (sheet-parent sheet)))
     (when parent
       (setf (sheet-children parent)
-	    (nconc (delete sheet (sheet-children parent)) (list sheet)))))
+	(nconc (delete sheet (sheet-children parent) :test #'eq)
+	       (list sheet)))))
   (when (sheet-direct-mirror sheet)
     (bury-mirror (port sheet) sheet)))
 
+;; This could be optimized if we can guarantee that the ordering of
+;; sheet-children is always kept up to date wrt the actual stacking
+;; order.  Unfortunately this is quite hard under X11 for top level windows.
 (defmethod reorder-sheets ((parent sheet) new-ordering)
-  ;; Error check new ordering
+  ;; Errorcheck new-ordering.
   (assert (null (set-exclusive-or new-ordering (sheet-children parent)))
-  	  (new-ordering)
-	  "Specified ordering ~S does not contain children of sheet ~S"
-	  new-ordering parent)
+      (new-ordering)
+    "Specified ordering ~S does not contain children of sheet ~S"
+    new-ordering parent)
   (setf (sheet-children parent) new-ordering)
   (let ((port (port parent)))
     (dolist (child (reverse new-ordering))
@@ -449,3 +453,34 @@
 (defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) 
 				       &key enabled)
   (setf (sheet-enabled-p sheet) enabled))
+
+
+
+
+
+
+
+(defmethod (setf sheet-pointer-cursor) (cursor (sheet sheet))
+  (port-set-sheet-pointer-cursor (port sheet) sheet cursor)
+  (setf (slot-value sheet 'cursor) cursor))
+
+(defmacro with-pointer-grabbed ((sheet &rest options) &body body)
+  `(flet ((with-pointer-grabbed-body () ,@body))
+     (declare (dynamic-extent #'with-pointer-grabbed-body))
+     (invoke-with-pointer-grabbed ,sheet #'with-pointer-grabbed-body ,@options)))
+	    
+(defun invoke-with-pointer-grabbed (sheet continuation &rest options)
+  (apply #'port-invoke-with-pointer-grabbed (port sheet) sheet continuation options))
+
+(defmethod port-invoke-with-pointer-grabbed ((port port) (sheet sheet) continuation &key)
+  (declare (ignore options))
+  (funcall continuation))
+
+(defmethod (setf sheet-grabbed-pointer-cursor) (cursor (sheet sheet))
+  (port-set-sheet-grabbed-pointer-cursor (port sheet)
+					 sheet
+					 cursor))
+
+(defmethod port-set-sheet-grabbed-pointer-cursor ((port port) (sheet sheet) cursor)
+  (declare (ignore cursor))
+  nil)
diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp
index e04ec4aff1b799c9f734a3850bd3247baf140102..32252984b2b6e0544c2702c54aac2eb828b301ba 100644
--- a/sys/defsystem.lisp
+++ b/sys/defsystem.lisp
@@ -27,7 +27,7 @@
 ;;;
 ;;;-----------------------------------------------------------
 
-;; $fiHeader: defsystem.lisp,v 1.12 92/07/01 15:47:14 cer Exp $
+;; $fiHeader: defsystem.lisp,v 1.13 92/08/18 17:25:50 cer Exp Locker: cer $
 
 ;; Add a feature for ANSI-adhering Lisps.  So far, only Apple's
 ;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1.
@@ -1081,7 +1081,7 @@ pathname fields are evaluated."
   (proclaim '(special *loaded-systems* *loaded-modules* *compiled-systems*
 	      *compiled-modules* *tracep*)))
 
-#-(and ANSI-90 (not Allegro) (not Cloe))
+#+(or (not ANSI-90) (and Allegro (not (version>= 4 2))) Cloe)
 (#+Allegro excl::without-package-locks #-Allegro progn
 
 (defun translate-logical-pathname (path) path)
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 2ae020be5033c878bf6a5b8f32cf5a9f06e33d62..809a7c09d15e5ff25a06071c16de3ec92c39da7e 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.24 92/09/08 10:34:59 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.25 92/09/08 15:18:42 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -295,6 +295,8 @@
   ("frames" 
    :load-before-compile ("clim-defs" "command-processor"))
   ("default-frame" 
+      :load-before-compile ("frames"))
+  ("activities" 
    :load-before-compile ("frames"))
   ("db-menu"
    :load-before-compile ("frames"))
diff --git a/test/simple-test.lisp b/test/simple-test.lisp
index b813cad854faabc676b3c08bb59f2a3ca686f348..2f2ab59816a348e81f0c358663e6bf4def37c9d4 100644
--- a/test/simple-test.lisp
+++ b/test/simple-test.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: clim-user; Base: 10; Lowercase: Yes -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,12 +20,22 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: simple-test.lisp,v 1.6 92/03/04 16:22:37 cer Exp Locker: cer $
+;; $fiHeader: simple-test.lisp,v 1.7 92/07/20 16:00:48 cer Exp $
 
 
-(in-package :silica)
+(defpackage :clim-user (:use :clim-silica))
 
-(defclass even-simpler (simple-sheet) ())
+(in-package :clim-user)
+
+(defclass simple-test-sheet (silica::permanent-medium-sheet-output-mixin
+			     silica::sheet-multiple-child-mixin
+			     silica::sheet-transformation-mixin
+			     silica::standard-repainting-mixin
+			     silica::immediate-sheet-input-mixin
+			     sheet)
+  ())
+
+(defclass even-simpler (simple-test-sheet) ())
 
 (defun simple-test ()
   (let* ((port (find-port))
@@ -35,7 +45,7 @@
 			       :region (make-bounding-rectangle 0 0 300 300))))
     (dotimes (i 5)
       (dotimes (j 5)
-	(let ((s (make-instance 'simple-sheet
+	(let ((s (make-instance 'simple-test-sheet
 				:parent sheet
 				:region (make-bounding-rectangle 0 0 60 60)
 				:transformation
@@ -50,7 +60,7 @@
     (setf (sheet-enabled-p sheet) t)
     sheet))
 
-(defmethod handle-event ((sheet simple-sheet) (event pointer-enter-event))
+(defmethod handle-event ((sheet simple-test-sheet) (event pointer-enter-event))
   (outline-sheet sheet)
   (setf (port-keyboard-input-focus (port sheet)) sheet))
 
@@ -62,18 +72,18 @@
 			     :filled nil
 			     :ink +flipping-ink+)))
 
-(defmethod handle-event ((sheet simple-sheet) (event pointer-exit-event))
+(defmethod handle-event ((sheet simple-test-sheet) (event pointer-exit-event))
     (outline-sheet sheet))
 
 
-(defmethod handle-event ((sheet simple-sheet) (event pointer-button-event))
+(defmethod handle-event ((sheet simple-test-sheet) (event pointer-button-event))
   (multiple-value-call
       #'draw-rectangle*
     sheet
     (bounding-rectangle* sheet)
     :ink +flipping-ink+))
 
-(defmethod handle-event ((sheet simple-sheet) (event keyboard-event))
+(defmethod handle-event ((sheet simple-test-sheet) (event keyboard-event))
   (draw-line* sheet -200 -200 200 200 :ink +flipping-ink+
 	      :line-thickness 10))
 
@@ -85,3 +95,11 @@
     (bounding-rectangle* sheet)
     :filled t
     :ink +red+))
+
+(defmethod repaint-sheet ((sheet standard-sheet) (region t))
+  )
+
+(defmethod repaint-sheet ((sheet simple-test-sheet) (region t))
+  )
+
+
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 3229f55f18555129b67a1270f5ab9e1cd4a2ec36..d85cc816902fa0b05e31ba491d8ce536bf597541 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.33 92/09/08 15:18:44 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.34 92/09/09 11:44:49 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -668,14 +668,22 @@ people, shall not perish from the earth.
       (draw-text* stream "Some fox jumped over something" 200 200
 		  :towards-x 400 :towards-y 200))
     (with-output-as-presentation (stream 2 'form) 
-      (draw-text* stream "Some fox jumped over something" 200 200
-		  :towards-x 200 :towards-y 400))
+      (with-text-style (stream '(nil :italic :larger))
+	(draw-text* stream "Some fox jumped over something" 200 200
+		    :towards-x 200 :towards-y 400)))
     (with-output-as-presentation (stream 3 'form) 
-      (draw-text* stream "Some fox jumped over something" 200 200
-		  :towards-x 0 :towards-y 200))
+      (with-text-style (stream '(nil :bold :huge))
+	(draw-text* stream "Some fox jumped over something" 200 200
+		    :towards-x 0 :towards-y 200)))
     (with-output-as-presentation (stream 4 'form) 
-      (draw-text* stream "Some fox jumped over something" 200 200
-		  :towards-x 200 :towards-y 0))))
+      (with-text-style (stream '(nil :bold :small))
+	(draw-text* stream "Some fox jumped over something" 200 200
+		    :towards-x 200 :towards-y 0)))
+    (do ((x 300 (+ x 20)))
+	((> x 1000))
+      (with-output-as-presentation (stream 4 'form) 
+	(draw-text* stream "Dont be silly in the City." x 200
+		      :towards-x x :towards-y 0)))))
 
 (defparameter *named-colors*
  '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+
@@ -1100,7 +1108,12 @@ people, shall not perish from the earth.
   "Draw a graph showing part of the CLOS class hierarchy"
   (format-graph-from-roots 
     (mapcar #'find-class '(clos:metaobject clos:dependee-mixin))
-    #'(lambda (o s) (format s "~A" (clos::class-name o))) 
+    #'(lambda (o s)
+	(let ((text (format nil "~A" (clos::class-name o))))
+	  (multiple-value-bind (width height) (text-size s text)
+	    (with-new-output-record (s)
+	    (draw-rectangle* s 0 0 width height :filled t :ink +red+)
+	    (draw-text* s text 0 0 :align-x :left :align-y :top)))))
     #'clos::class-direct-subclasses
     :stream stream
     :merge-duplicates t))
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index f3dfdfd49a418ae227142ca61e36ab8dfa90126c..506c6e76c2a830f3316d72a3bbb2bfe3a5bf3d91 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.23 92/08/18 17:26:32 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.24 92/09/08 15:19:13 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -158,7 +158,7 @@
 
 ;;; top level sheet
 
-(defclass openlook-top-level-sheet (top-level-sheet) ())
+(defclass openlook-top-level-sheet (xt-top-level-sheet) ())
 
 (defmethod add-sheet-callbacks :after ((port openlook-port) 
 				       (sheet openlook-top-level-sheet)
@@ -275,45 +275,101 @@
   ;; submenus then it creates one with a menu of its own
   
   (let ((mirror (call-next-method)))
-    (labels ((make-menu-for-command-table (command-table parent top)
-	       (map-over-command-table-menu-items
-		#'(lambda (menu keystroke item)
-		    (declare (ignore keystroke))
-		    (let ((type (command-menu-item-type item)))
-		      (case type
-			(:divider
-			 (unless top
-			   (make-instance 'xt::static-text
-					  :parent parent
-					  :managed nil
-					  :string " ")))
-			(:function
-			 ;;--- Do this sometime
-			 )
-			(:menu
-			 (let* ((mb (make-instance 'tk::menu-button
-						  :parent parent
-						  :label menu)))
-			   (make-menu-for-command-table
-			    (find-command-table (second item))
-			    (tk::get-values mb :menu-pane)
-			    nil)))
-			(t
-			 (let ((button 
-				(make-instance 'tk::oblong-button
-					       :label menu
-					       :managed t
-					       :parent parent)))
-			   (set-button-accelerator-from-keystroke button keystroke)
+    (labels ((update-menu-item-sensitivity (widget frame commands)
+	       (declare (ignore widget))
+	       (dolist (cbs commands)
+		 (tk::set-sensitive (second cbs)
+				    (command-enabled
+				     (car (second (car cbs)))
+				     frame))))
+	     
+	     
+	     (make-command-for-command-table-1 (mb item)
+	       (let* ((menu-pane (tk::get-values mb :menu-pane))
+		      (ct (find-command-table (second item)))
+		      (tick (slot-value ct 'clim-internals::menu-tick))
+		      (commands-and-buttons
+		       (make-menu-for-command-table
+			ct
+			menu-pane
+			nil)))
+
+		 (when commands-and-buttons
+		   ;; We might have add-callbacks for a different set
+		   ;; of children which are now destroyed
+		   (let ((shell (do ((widget menu-pane (tk::widget-parent widget)))
+				    ((typep widget 'tk::shell)
+				     widget)
+				  (assert widget))))
+		     
+		     (setf (tk::widget-create-popup-child-proc shell)
+		       #'(lambda (shell)
+			   (declare (ignore shell))
+			   (let ((children
+				  (tk::widget-children menu-pane)))
+			     (when (or (null children)
+				       (/= tick
+					   (setq tick
+					     (slot-value ct 'clim-internals::menu-tick))))
+			       (mapc #'tk::destroy-widget children)
+			       (make-command-for-command-table-1 mb item)))))
+		     
+		     (tk::remove-all-callbacks shell :popup-callback)
+		     (tk::add-callback shell :popup-callback
+				       #'update-menu-item-sensitivity 
+				       (pane-frame sheet)
+				       commands-and-buttons)))
+			     
+		 (set-button-mnemonic 
+		  sheet mb (getf
+			    (command-menu-item-options item) :mnemonic))))
+  
+	     (make-menu-for-command-table (command-table parent top)
+	       (let ((commands-and-buttons nil))
+		 (map-over-command-table-menu-items
+		  #'(lambda (menu keystroke item)
+		      (let ((type (command-menu-item-type item)))
+			(case type
+			  (:divider
+			   (unless top
+			     (make-instance 'xt::static-text
+					    :parent parent
+					    :managed nil
+					    :string " ")))
+			  (:function
+			   ;;--- Do this sometime
+			   )
+			  (:menu
+			   (make-command-for-command-table-1
+			      (make-instance 'tk::menu-button
+						     :parent parent
+						     :label menu) 
+			      item))
+
+			  (t
+			   (let ((button 
+				  (make-instance 'tk::oblong-button
+						 :label menu
+						 :managed t
+						 :parent parent)))
+			     (set-button-accelerator-from-keystroke
+			      sheet button keystroke)
 			   
-			   (tk::add-callback
-			    button
-			    :select
-			    'command-button-callback-ol
-			    (slot-value sheet 'silica::frame)
-			    command-table
-			    item))))))
-		command-table)))
+			     (set-button-mnemonic
+			      sheet
+			      button (getf (command-menu-item-options item) :mnemonic))
+
+			     (push (list item button) commands-and-buttons)
+
+			     (tk::add-callback
+			      button
+			      :select
+			      'command-button-callback-ol
+			      (slot-value sheet 'silica::frame)
+			      command-table
+			      item))))))
+		  command-table)
+		 commands-and-buttons)))
       (make-menu-for-command-table
        (menu-bar-command-table sheet)
        mirror
@@ -412,7 +468,8 @@
 	   (nv (gadget openlook-text-field) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror gadget)
-    (setf (text-editor-text (openlook-text-field-edit-widget gadget)) nv)))
+    (with-no-value-changed-callbacks
+	(setf (text-editor-text (openlook-text-field-edit-widget gadget)) nv))))
 
 ;;--- We need to implement the activate callback stuff so that when
 ;;--- the user hits return we invoke the callback. I guess we need to
@@ -441,7 +498,8 @@
 	   (nv (gadget openlook-value-pane) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror gadget)
-    (tk::set-values (sheet-mirror gadget) :value nv)))
+    (with-no-value-changed-callbacks
+	(tk::set-values (sheet-mirror gadget) :value nv))))
 
 ;;;
 
@@ -456,14 +514,19 @@
       (call-next-method)
     (with-accessors ((alignment gadget-alignment)
 		     (label gadget-label)) sheet
-      (when label
-	(unless (getf initargs :label)
-	  (setf (getf initargs :label) label)))
-      (unless (getf initargs :label-justify)
-	(setf (getf initargs :label-justify) 
-	  (ecase alignment
-	    (:center :left)
-	    ((:left :right)  alignment)))))
+      (typecase label
+	(string
+	 (unless (getf initargs :label)
+	   (setf (getf initargs :label) label))
+	 (unless (getf initargs :label-justify)
+	   (setf (getf initargs :label-justify) 
+	     (ecase alignment
+	       (:center :left)
+	       ((:left :right)  alignment)))))
+	(xt::pixmap
+	 (unless (getf initargs :label-image)
+	   (setf (getf initargs :label-image) (tk::image-from-pixmap label)
+		 (getf initargs :label-type) :image)))))
     (values class initargs)))
 
 (defmethod (setf gadget-label) :after (nv (sheet openlook-labelled-gadget))
@@ -481,7 +544,6 @@
 
 (defclass openlook-toggle-button (toggle-button
 				openlook-labelled-gadget
-				openlook-value-pane
 				xt-leaf-pane)
 	  ())
 
@@ -524,7 +586,8 @@
 	   (nv (gadget openlook-toggle-button) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror gadget)
-    (tk::set-values (sheet-mirror gadget) :set nv)))
+    (with-no-value-changed-callbacks
+	(tk::set-values (sheet-mirror gadget) :set nv))))
 
 
 
@@ -555,8 +618,6 @@
 
 (defclass openlook-radio-box (openlook-geometry-manager 
 			      mirrored-sheet-mixin
-			      #+ignore ;;-- Need to decide
-			      openlook-oriented-gadget
 			      sheet-multiple-child-mixin
 			      sheet-permanently-enabled-mixin
 			      radio-box
@@ -570,7 +631,12 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-radio-box))
-  (values 'xt::exclusives nil))
+  (with-accessors ((orientation gadget-orientation)) sheet
+    (values 'xt::exclusives 
+	    (list :layout-type
+		  (ecase orientation
+		    (:horizontal :fixedrows)
+		    (:vertical :fixedcols))))))
 
 (defmethod value-changed-callback :around ((v gadget)
 					   (client openlook-radio-box)
@@ -586,22 +652,35 @@
 
 (defmethod compose-space ((rb openlook-radio-box) &key width height)
   (declare (ignore width height))
-  (let ((w 0)
-	(h 0))
-    (dolist (child (tk::widget-children (sheet-direct-mirror rb)))
+  (compose-space-for-radio/check-box rb))
+
+(defun compose-space-for-radio/check-box (rb &optional (spacing 0))
+  (let ((sum-w 0)
+	(max-w 0)
+	(max-h 0)
+	(sum-h 0)
+	(children (tk::widget-children (sheet-direct-mirror rb))))
+    (dolist (child children)
       (multiple-value-bind
 	  (ignore-x igore-y width height)
 	  (xt::widget-best-geometry child)
-	(maxf h height)
-	(incf w width)))
-    (make-space-requirement :width w :height h)))
+	(declare (ignore ignore-x igore-y))
+	(maxf max-h height)
+	(incf sum-w width)
+	(incf sum-h height)
+	(maxf max-w width)))
+    (case (gadget-orientation rb)
+      (:horizontal (make-space-requirement 
+		    :width (+ sum-w (* spacing (1- (length children))))
+		    :height max-h))
+      (:vertical (make-space-requirement 
+		  :width max-w 
+		  :height (+ sum-h (* spacing (1- (length children)))))))))
 ;;;
 
 
 (defclass openlook-check-box (openlook-geometry-manager
 			      mirrored-sheet-mixin
-			      #+Dunno ;;--- what do do about tihs
-			      openlook-oriented-gadget
 			      sheet-multiple-child-mixin
 			      sheet-permanently-enabled-mixin
 			      check-box
@@ -616,7 +695,12 @@
 						     (parent t)
 						     (sheet openlook-check-box))
   
-  (values 'xt::nonexclusives nil))
+  (with-accessors ((orientation gadget-orientation)) sheet
+    (values 'xt::nonexclusives 
+	    (list :layout-type
+		  (ecase orientation
+		    (:horizontal :fixedrows)
+		    (:vertical :fixedcols))))))
 
 (defmethod value-changed-callback :around ((v gadget)
 					   (client openlook-check-box)
@@ -634,22 +718,7 @@
 
 (defmethod compose-space ((cb openlook-check-box) &key width height)
   (declare (ignore width height))
-  ;;-- This is a dreadful hack that attempts to second guess that
-  ;;--- stupid tookit.
-  (let ((twidth 0)
-	(theight 0)
-	(children (tk::widget-children (sheet-direct-mirror cb))))
-    (dolist (child children)
-      (multiple-value-bind
-	  (x y width height borderwidth
-	   care-x care-y care-width care-height care-borderwidth)
-	  (tk::widget-best-geometry child)
-	(declare (ignore x y borderwidth care-x care-y 
-			 care-width care-height care-borderwidth))
-	(maxf theight height)
-	(incf twidth width)))
-    (make-space-requirement :width (+ twidth (* (1- (length children)) 15))
-			    :height theight)))
+  (compose-space-for-radio/check-box cb 15))
 
 
 ;;
@@ -663,13 +732,6 @@
 			   slider)
 	  ())
 
-(defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-slider) (widget t))
-  (break "fix me")
-  (tk::add-callback widget
-		    :drag-callback
-		    'queue-drag-event
-		    sheet))
-
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-slider))
@@ -703,7 +765,8 @@
 (defmethod (setf gadget-value) :after  (nv (slider openlook-slider) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror slider)
-    (set-slider-value slider nv)))
+    (with-no-value-changed-callbacks
+	(set-slider-value slider nv))))
 
 (defun compute-slider-value (sheet)
   (let ((widget (sheet-direct-mirror sheet)))
@@ -732,6 +795,9 @@
 (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))
 
 (defmethod slider-changed-callback-1 ((widget t) (sheet openlook-slider))
@@ -784,9 +850,6 @@
   (let ((widget (sheet-direct-mirror te)))
     (setf (text-editor-text widget) nv)))
 
-(defmethod (setf text-editor-text) (nv (widget tk::text-edit))
-    (setf (text-editor-text widget) nv))
-
 (defmethod (setf text-editor-text) (nv (widget tk::text-edit))
   (assert (not (zerop (tk::ol_text_edit_clear_buffer widget))))
   (assert (not (zerop (tk::ol_text_edit_insert widget nv (length nv))))))
@@ -834,7 +897,8 @@
 	   (nv (gadget openlook-text-editor) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror gadget)
-    (setf (text-editor-text gadget) nv)))
+    (with-no-value-changed-callbacks
+	(setf (text-editor-text gadget) nv))))
 
 
 (defmethod gadget-supplies-scrolling-p ((contents openlook-text-editor))
@@ -1230,4 +1294,29 @@
     (let ((item (find nv items :test test :key value-key)))
       (assert item)
       (let ((button (find item (option-menu-buttons sheet) :key #'second)))
-	(tk::set-values button :default t)))))
+	(with-no-value-changed-callbacks
+	    (tk::set-values button :default t))))))
+
+(defmethod set-button-accelerator-from-keystroke ((menubar openlook-menu-bar) button keystroke)
+  (when keystroke 
+    (record-accelerator menubar keystroke)
+    (let ((accel (format nil "<~A>" (car keystroke)))
+	  (accel-text (format nil "~A" (car keystroke))))
+      (dolist (modifier (cdr keystroke))
+	(setq accel-text
+	  (concatenate 'string 
+	    (case modifier (:control "Ctrl+") (:meta "Alt+") (t ""))
+	    accel-text))
+	(setq accel
+	  (concatenate 'string 
+	    (case modifier (:control "c") (:meta "a") (t ""))
+	    accel)))
+      (tk::set-values button 
+		      :accelerator accel
+		      :accelerator-text accel-text))))
+
+(defmethod discard-accelerator-event-p ((port openlook-port) event)
+  ;;-- 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
+  (call-next-method))
diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp
index a9a073256890a309e6bbfc11c94be251d1edc72a..6f93a3e0a2eeb18cdad8fdcdd6cdd3cf6623dda4 100644
--- a/tk-silica/ol-silica.lisp
+++ b/tk-silica/ol-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-silica.lisp,v 1.12 92/07/20 16:01:50 cer Exp $
+;; $fiHeader: ol-silica.lisp,v 1.13 92/08/18 17:54:24 cer Exp $
 
 (in-package :xm-silica)
 
@@ -72,6 +72,8 @@
 
 (defclass openlook-geometry-manager (xt-geometry-manager) ())
 
+;;--- This looks kinda like to motif-port method.
+
 (defmethod find-shell-class-and-initargs ((port openlook-port) sheet)
   (declare (ignore port))
   (cond ( ;;--- hack alert
@@ -89,7 +91,7 @@
   (popup parent))
 
 (defmethod disable-xt-mirror ((parent xt::transient-shell) (mirror t))
-  (tk::popdown parent))
+  (popdown parent))
 
 (defmethod destroy-mirror ((port openlook-port) (sheet mirrored-sheet-mixin))
   ;; Only do this if its the top most widget being destroyed or we are
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 611f2baf9f5a0afd9e5822979a77e560cb4eb1d0..9eaccdc009591a12ce1c9f976ac1b0510c056418 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.28 92/09/08 10:35:27 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.29 92/09/08 15:19:15 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -123,9 +123,10 @@
 					 :parent parent
 					 :label-string menu
 					 :sub-menu-id submenu)))
-		 (declare (ignore cb))
-		 (let ((mnem (getf (command-menu-item-options item) :mnemonic)))
-		   (when mnem (tk::set-values cb :mnemonic mnem)))
+		 
+		 (set-button-mnemonic sheet
+				      cb (getf (command-menu-item-options item) :mnemonic))
+		 
 		 (let* ((ct (find-command-table (second item)))
 			(tick (slot-value ct 'clim-internals::menu-tick)))
 		   (make-menu-for-command-table ct submenu nil)
@@ -187,10 +188,12 @@
 				     commands-and-buttons)
 			       
 			       (set-button-accelerator-from-keystroke 
+				sheet
 				button keystroke)
-			
-			       (let ((mnem (getf (command-menu-item-options item) :mnemonic)))
-				 (when mnem (tk::set-values button :mnemonic mnem)))
+
+			       (set-button-mnemonic
+				sheet
+				button (getf (command-menu-item-options item) :mnemonic))
 
 			       (when (getf (command-menu-item-options item) :documentation)
 				 (tk::add-callback
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 110013994bdf1620fc3618df00bba10d57bd406f..0602167248c448b04daf45038c1173ae29fbfef8 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.45 92/09/08 10:35:29 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.46 92/09/08 15:19:16 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -69,8 +69,8 @@
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (tk::get-values m :value))))
-      (let ((*dont-invoke-callbacks* t))
-	(tk::set-values m :value nv)))))
+      (with-no-value-changed-callbacks
+	  (tk::set-values m :value nv)))))
 
 ;; Gadgets that have a :label initarg
 
@@ -202,30 +202,6 @@
 			 'sheet-mirror-event-handler
 			 sheet))
 
-#|
-
-;; Drawing area
-;; Who uses this anyway??????????????
-
-;; Noone!
-
-(defclass motif-drawing-area (standard-sheet-input-mixin 
-			      permanent-medium-sheet-output-mixin
-			      xt-leaf-pane) 
-	  ())
-
-(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
-						     (parent t)
-						     (sheet motif-drawing-area))
-  (values 'tk::xm-my-drawing-area (list :margin-width 0 
-				     :resize-policy :none
-				     :margin-height 0)))
-
-(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget)
-  ;; Now does nothing
-  )
-|#
-
 ;;; range pane mixin
 
 (defclass motif-range-pane (motif-value-pane) ())
@@ -254,11 +230,11 @@
 	(multiple-value-bind
 	    (mmin mmax)
 	    (tk::get-values mirror :minimum :maximum)
-	  (let ((*dont-invoke-callbacks* t))
-	    (tk::set-values mirror
-			    :value (fix-coordinate 
-				    (compute-symmetric-value
-				     smin smax nv mmin mmax)))))))))
+	  (with-no-value-changed-callbacks
+	      (tk::set-values mirror
+			      :value (fix-coordinate 
+				      (compute-symmetric-value
+				       smin smax nv mmin mmax)))))))))
 
 ;;; 
 
@@ -438,8 +414,8 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
-(defclass motif-top-level-sheet (top-level-sheet) ())
+(defclass motif-top-level-sheet (xt-top-level-sheet)
+	  ())
 
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet motif-top-level-sheet)
@@ -612,8 +588,8 @@
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (tk::get-values m :set))))
-      (let ((*dont-invoke-callbacks* t))
-	(tk::set-values m :set nv)))))
+      (with-no-value-changed-callbacks
+	  (tk::set-values m :set nv)))))
 
 #+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
@@ -923,10 +899,10 @@
   (when (sheet-direct-mirror l)
     (let ((selected-items
 	   (compute-list-pane-selected-items l nv)))
-      (let ((*dont-invoke-callbacks* t))
-	(tk::set-values (sheet-direct-mirror l)
-			:selected-item-count (length selected-items)
-			:selected-items selected-items)))))
+      (with-no-value-changed-callbacks
+	    (tk::set-values (sheet-direct-mirror l)
+			    :selected-item-count (length selected-items)
+			    :selected-items selected-items)))))
 
 ;;; Option buttons
 
@@ -973,8 +949,8 @@
 
 (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback)
   (declare (ignore invoke-callback)) 
-  (let ((*dont-invoke-callbacks* t))
-    (set-option-menu-value gadget nv)))
+  (with-no-value-changed-callbacks
+      (set-option-menu-value gadget nv)))
 
 (defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane))
   (prog1 (call-next-method)
@@ -1465,3 +1441,29 @@
 			    'sheet-mirror-event-handler
 			    sheet))))
 
+(defmethod discard-accelerator-event-p ((port motif-port) event)
+  (or (call-next-method)
+      ;;-- There are a whole bunch of other keysyms that need to be
+      ;;-- ignored too but there does not appear to be an easy way
+      ;;-- of going from the osf name to the keysym that we need to ignore
+      ;;--  osfMenuBar
+      (member (keyboard-event-key-name event) '(:f10))))
+
+
+(defmethod set-button-accelerator-from-keystroke ((menubar motif-menu-bar) button keystroke)
+  (when keystroke 
+    (record-accelerator menubar keystroke)
+    (let ((accel (format nil "<Key>~A" (car keystroke)))
+	  (accel-text (format nil "~A" (car keystroke))))
+      (dolist (modifier (cdr keystroke))
+	(setq accel-text
+	  (concatenate 'string 
+	    (case modifier (:control "Ctrl+") (:meta "Alt+") (t ""))
+	    accel-text))
+	(setq accel
+	  (concatenate 'string 
+	    (case modifier (:control "Ctrl") (:meta "Mod1") (t ""))
+	    accel)))
+      (tk::set-values button 
+		      :accelerator accel
+		      :accelerator-text accel-text))))
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 70002a05d809c2141ff46488ad69b84b6c532d4c..44bdcfe130dbd4b12629620a9eb591faa5784e48 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.16 92/08/21 16:34:32 cer Exp Locker: cer $
+;; $fiHeader: xt-frames.lisp,v 1.17 92/09/08 10:35:32 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -81,7 +81,7 @@
      :sheet (frame-top-level-sheet frame))))
 
 (defmethod handle-event (sheet (event window-manager-delete-event))
-  (frame-exit *application-frame*))
+  (frame-exit (pane-frame sheet)))
 
 ;;; Menu code
 
@@ -173,3 +173,9 @@
 
 (defmethod frame-manager-default-exit-boxes ((framem xt-frame-manager))
   '((:exit) (:abort)))
+
+(defmethod note-frame-iconified ((framem xt-frame-manager) frame)
+  (tk::set-values (frame-shell frame) :iconic t))
+
+(defmethod note-frame-deiconified ((framem xt-frame-manager) frame)
+  (tk::set-values (frame-shell frame) :iconic nil))
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index c55c25ecff5338cc811f74f03483ff45fed8a04d..57570be30063dcb15fc11baf97ad28b64a8aaf94 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-gadgets.lisp,v 1.18 92/08/18 17:26:38 cer Exp Locker: cer $
+;; $fiHeader: xt-gadgets.lisp,v 1.19 92/09/08 10:35:33 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -133,6 +133,11 @@
 			xt-pane)
 	  ())
 
+(defclass xt-top-level-sheet (top-level-sheet) 
+	  ((accelerator-gestures :initform nil)))
+
+(defmethod sheet-disown-child :after ((sheet xt-top-level-sheet) (child sheet))
+  (setf (slot-value sheet 'accelerator-gestures) nil))
 
 
 ;;--- This isn't really right.  Genera and CLX ports have kludges
@@ -163,21 +168,29 @@
 	  (process-next-event port)))
     (mp:process-wait whostate predicate)))
 
+(defun set-button-mnemonic (menubar button mnem)
+  (when mnem 
+    (record-accelerator menubar (list mnem :meta))
+    (tk::set-values button :mnemonic mnem)))
+
+(defun record-accelerator (menubar gesture)
+  (let ((sheet (frame-top-level-sheet (pane-frame menubar))))
+    (push gesture (slot-value sheet 'accelerator-gestures))))
+
+(defmethod distribute-event ((port xt-port) (event keyboard-event))
+  (unless (discard-accelerator-event-p port event)
+    (call-next-method)))
+
+(defmethod discard-accelerator-event-p ((port xt-port) event)
+  (let ((frame (pane-frame (event-sheet event))))
+    (and frame
+	 (some #'(lambda (gesture)
+		   (clim-internals::keyboard-event-matches-gesture-name-p event gesture port))
+	       (slot-value (frame-top-level-sheet frame) 'accelerator-gestures)))))
+
+
+
+
+
 
-(defun set-button-accelerator-from-keystroke (button keystroke)
-  (when keystroke 
-    (let ((accel (format nil "<Key>~A" (car keystroke)))
-	  (accel-text (format nil "~A" (car keystroke))))
-      (dolist (modifier (cdr keystroke))
-	(setq accel-text
-	  (concatenate 'string 
-	    (case modifier (:control "Ctrl+") (:meta "Alt+") (t ""))
-	    accel-text))
-	(setq accel
-	  (concatenate 'string 
-	    (case modifier (:control "Ctrl") (:meta "Mod1") (t ""))
-	    accel)))
-      (tk::set-values button 
-		      :accelerator accel
-		      :accelerator-text accel-text))))
 
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index bf0b7877e8e63e65e5fe6bf995ed79f375d48a42..d4bbc53e0e12cc5c312721f43a035edfefeb2c61 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.37 92/09/08 15:19:18 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.38 92/09/09 11:45:00 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -117,9 +117,12 @@
   (tk::widget-window mirror nil))
 
 (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet)
-  (with-slots (foreground-gcontext background-gcontext flipping-gcontext color-p
+  (with-slots (foreground-gcontext background-gcontext
+				   flipping-gcontext color-p
+				   indirect-inks
 				   drawable tile-gcontext white-pixel black-pixel clip-mask)
       medium
+    (setf indirect-inks nil)
     (setf clip-mask nil)
     (setf (medium-sheet medium) sheet)
     (when (and drawable
@@ -155,7 +158,7 @@
   (declare (ignore sheet))
   (with-slots 
        (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext
-	drawable)
+			    ink-table drawable)
       medium
     (setf drawable nil
 	  (medium-sheet medium) nil)
@@ -163,9 +166,11 @@
 		 `(when ,gc
 		    (tk::free-gcontext ,gc)
 		    (setf ,gc nil))))
-      ;;-- Do we actually need to do this or cant we save them until
-      ;;-- the next time around. Also, what about all those gc's in
-      ;;-- the ink-table etc etc.
+      (maphash #'(lambda (ink gc) 
+		   (declare (ignore ink))
+		   (tk::free-gcontext gc))
+	       ink-table)
+      (clrhash ink-table)
       (loose-gc foreground-gcontext)
       (loose-gc background-gcontext)
       (loose-gc flipping-gcontext)
@@ -1174,6 +1179,7 @@ and on color servers, unless using white or black")
 					  :height n))
 		   (gc (make-instance 'fast-gcontext
 				      :drawable pixmap
+				      :font font
 				      :foreground 1
 				      :background 0)))
 	      ;; Draw all the characters
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 0459352a835d14dde1cfcc508e92b398d9d91107..0fba2ac32d3bac68b358a43f7f3cd3b8a723bea6 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.43 92/09/08 15:19:22 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.44 92/09/09 11:45:06 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -37,7 +37,9 @@
 		 :reader port-event-lock)
      (rotated-font-cache :initform nil :accessor port-rotated-font-cache)
      (depth :accessor port-depth)
-     (visual-class :accessor port-visual-class))
+     (visual-class :accessor port-visual-class)
+     (cursor-font :initform nil)
+     (cursor-cache :initform nil))
   (:default-initargs :allow-loose-text-style-size-mapping t)
   (:documentation "The port for X intrinsics based ports"))
 
@@ -389,25 +391,47 @@
 	  (:key-press
 	   (multiple-value-bind (character keysym)
 	       (lookup-character-and-keysym sheet widget event)
-	     (allocate-event 'key-press-event
-			     :sheet sheet
-			     :key-name keysym
-			     :character character
-			     :modifier-state 
-			     (setf (port-modifier-state port)
-			       (state->modifiers
-				(x11::xkeyevent-state event) nil)))))
+	     (let ((keysym-shift-mask
+		    (if (typep keysym 'silica::modifier-keysym)
+			(make-modifier-state
+			 (case keysym
+			   ((:left-shift :right-shift) :shift)
+			   ((:left-control :right-control) :control)
+			   ((:left-meta :right-meta) :meta)
+			   ((:left-super :right-super) :super)
+			   ((:left-hyper :right-hyper) :hyper)))
+		      0)))
+	       (allocate-event 'key-press-event
+			       :sheet sheet
+			       :key-name keysym
+			       :character character
+			       :modifier-state
+			       (setf (port-modifier-state port)
+				 (logior
+				  (state->modifiers (x11::xkeyevent-state event))
+				  keysym-shift-mask))))))
 	  (:key-release
 	   (multiple-value-bind (character keysym)
 	       (lookup-character-and-keysym sheet widget event)
-	     (allocate-event 'key-release-event
-			     :sheet sheet
-			     :key-name keysym
-			     :character character
-			     :modifier-state 
-			     (setf (port-modifier-state port)
-			       (state->modifiers
-				(x11::xkeyevent-state event) nil)))))
+	     (let ((keysym-shift-mask
+		    (if (typep keysym 'silica::modifier-keysym)
+			(make-modifier-state
+			 (case keysym
+			   ((:left-shift :right-shift) :shift)
+			   ((:left-control :right-control) :control)
+			   ((:left-meta :right-meta) :meta)
+			   ((:left-super :right-super) :super)
+			   ((:left-hyper :right-hyper) :hyper)))
+		      0)))
+	       (allocate-event 'key-release-event
+			       :sheet sheet
+			       :key-name keysym
+			       :character character
+			       :modifier-state 
+			       (setf (port-modifier-state port)
+				 (logandc2
+				  (state->modifiers (x11::xkeyevent-state event))
+				  keysym-shift-mask))))))
 	  (:button-press
 	   (let ((button (x-button->silica-button 
 			  (x11::xbuttonevent-button event)))
@@ -515,7 +539,9 @@
   ;; This isn't really the right place to do this, but it's better than
   ;; in ensure-blinker-for-cursor.
   (let ((window (tk::widget-window widget)))
-    (setf (xt::window-backing-store window) t))
+    (unless (getf (window-property-list window) 'backing-store-on)
+      (setf (getf (window-property-list window) 'backing-store-on) t
+	    (xt::window-backing-store window)                      t)))
   (let* ((minx (x11::xexposeevent-x event))
 	 (miny (x11::xexposeevent-y event))
 	 (width (x11::xexposeevent-width event))
@@ -536,32 +562,57 @@
 
 (defmethod sheet-mirror-input-callback (widget window event sheet)
   (declare (ignore window))
-  (let ((port (port sheet)))
-    (ecase (tk::event-type event)
-      (:key-press
-       (distribute-event 
-	port
-	(multiple-value-bind (character keysym)
-	    (lookup-character-and-keysym sheet widget event)
-	  (allocate-event 'key-press-event
-			  :sheet sheet
-			  :key-name keysym
-			  :character character
-			  :modifier-state (setf (port-modifier-state port)
-					    (state->modifiers
-					     (x11::xkeyevent-state event) nil))))))
-      (:key-release
+  (let ((port (port sheet))
+	(event-key (tk::event-type event)))
+    (ecase event-key
+      ((:key-press :key-release)
        (distribute-event
 	port
 	(multiple-value-bind (character keysym)
 	    (lookup-character-and-keysym sheet widget event)
-	  (allocate-event 'key-release-event
-			  :sheet sheet
-			  :key-name keysym
-			  :character character
-			  :modifier-state (setf (port-modifier-state port)
-					    (state->modifiers
-					     (x11::xkeyevent-state event) nil))))))
+	  (let* ((keysym-shift-mask
+		  (if (typep keysym 'silica::modifier-keysym)
+		      (make-modifier-state
+		       (case keysym
+			 ((:left-shift :right-shift) :shift)
+			 ((:left-control :right-control) :control)
+			 ((:left-meta :right-meta) :meta)
+			 ((:left-super :right-super) :super)
+			 ((:left-hyper :right-hyper) :hyper)))
+		    0))
+		 (modifier-state
+		  (if (eq event-key :key-press)
+		      (logior (state->modifiers (x11::xkeyevent-state event))
+			      keysym-shift-mask)
+		    (logandc2 (state->modifiers (x11::xkeyevent-state event))
+			      keysym-shift-mask)))
+		 ;;-- Canonicalize the only interesting key right here.
+		 ;;--  If we get a key labelled "Return", we canonicalize it
+		 ;;-- into #\Newline.
+		 ;;-- This may be misguided, but it'll almost certainly help us
+		 ;;-- in the short run.
+		 ;;-- This code copied from clx-mirror.
+		 ;;-- This seems to break stuff.
+		 ;;-- It fails because newline is a standard-character
+		 ;;-- and so the event is #\newline which
+		 ;;-- port-canonicalize-gesture does not know what to
+		 ;;-- do with. It returns NIL. In comparision #\return
+		 ;;-- is nonstandard so no one gets confused.
+		 (char (cond #+this-does-not-work
+			     ((and (eq keysym ':return)
+				   (or (zerop modifier-state)
+				       (= modifier-state
+					  (make-modifier-state :shift))))
+			      #\Newline)
+			     (t character))))
+	    (setf (port-modifier-state port) modifier-state)
+	    (allocate-event (if (eq event-key :key-press)
+				'key-press-event
+			      'key-release-event)
+			    :sheet sheet
+			    :key-name keysym
+			    :character char
+			    :modifier-state modifier-state)))))
       (:button-press
        (let ((button (x-button->silica-button 
 		      (x11::xbuttonevent-button event)))
@@ -675,25 +726,60 @@
 	    `(:allow-shell-resize ,(clim-internals::frame-resizable (pane-frame sheet))
 				  ,@initargs))))
 
-(defmethod enable-mirror ((port xt-port) sheet)
+(defmethod enable-mirror ((port xt-port) (sheet t))
   (let ((mirror (sheet-mirror sheet)))
     (enable-xt-widget (widget-parent mirror) mirror)))
 
-(defmethod enable-xt-widget ((parent t) (mirror t))
+(defmethod enable-xt-widget ((parent t) mirror)
   (unless (xt::is-managed-p mirror)
     (manage-child mirror)))
 
+;(defmethod enable-mirror ((port xt-port) (sheet top-level-sheet))
+;  (let* ((mirror (sheet-mirror sheet))
+; 	 (parent (widget-parent mirror)))
+;    (manage-child mirror)
+;    (xt:realize-widget parent)		; Make sure widget is realized.
+;    (let ((ussp (slot-value sheet 'silica::user-specified-size-p))
+; 	  (uspp (slot-value sheet 'silica::user-specified-position-p)))
+;      (unless (and (eq ussp :unspecified)
+; 		   (eq uspp :unspecified))
+; 	(let* ((window (tk::widget-window parent))
+; 	       (display (tk::widget-display parent))
+; 	       (size-hints (x11::xallocsizehints)))
+; 	  (tk::with-ref-par ((supplied 0))
+; 	    (when (zerop
+; 		   (x11::xgetwmnormalhints display window size-hints supplied))
+; 	      (warn "top-level-sheet had no size hints?!")
+; 	      (return-from enable-mirror))
+; 	    (let ((flags (x11::xsizehints-flags size-hints)))
+; 	      (if* (and uspp (not (eq uspp :unspecified)))
+; 		 then (setf flags (logior flags x11::uspositionhint))
+; 	       elseif (null uspp)
+; 		 then (setf flags (logandc2 flags x11::uspositionhint)))
+; 	      (if* (and ussp (not (eq ussp :unspecified)))
+; 		 then (setf flags (logior flags x11::ussizehint))
+; 	       elseif (null ussp)
+; 		 then (setf flags (logandc2 flags x11::ussizehint)))
+; 	      (setf (x11::xsizehints-flags size-hints) flags))
+; 	    (x11::xsetwmnormalhints display window size-hints)))))
+;    (popup parent)))
+ 
+;(defmethod enable-xt-widget ((parent top-level-shell) mirror)
+;  (manage-child mirror)
+;  (popup (widget-parent mirror)))
+
 (defmethod disable-mirror ((port xt-port) sheet)
   (declare (ignore port))
   (let ((mirror (sheet-mirror sheet)))
     (when mirror
       (disable-xt-mirror (widget-parent mirror) mirror))))
 
-(defmethod disable-xt-mirror ((parent t) (mirror t))
+(defmethod disable-xt-mirror ((parent t) mirror)
   (tk::unmanage-child mirror))
 
-(defmethod disable-xt-mirror ((parent top-level-shell) (mirror t))
-  (tk::popdown parent))
+(defmethod disable-xt-mirror ((parent top-level-shell) mirror)
+  (declare (ignore mirror))
+  (popdown parent))
 
 (defmethod realize-graft ((port xt-port) graft)
   ;; Set the width etc etc
@@ -797,7 +883,7 @@
 	  (multiple-value-setq (mask reason)
 	    (tk::wait-for-event context
 				:wait-function wait-function
-				:timeout timeout))
+				:timeout 0))
 	  (tk::process-one-event context mask reason))))))
 
 
@@ -978,6 +1064,8 @@
 (define-xt-keysym (keysym 255 008) :backspace)
 (define-xt-keysym (keysym 009 227) :page)
 (define-xt-keysym (keysym 255 010) :linefeed)
+;;;---
+(define-xt-keysym (keysym 255 010) :newline)
 (define-xt-keysym (keysym 255 027) :escape)
 
 ;; Other useful characters
@@ -989,6 +1077,23 @@
 (define-xt-keysym (keysym 255 097) :refresh)
 (define-xt-keysym (keysym 255 011) :clear-input)
 
+;;;
+
+
+;;; Some nonstandard keys
+
+(define-xt-keysym (keysym 255 #xb3) :f1)
+(define-xt-keysym (keysym 255 #xbf) :f2)
+(define-xt-keysym (keysym 255 #xc0) :f3)
+(define-xt-keysym (keysym 255 #xc1) :f4)
+(define-xt-keysym (keysym 255 #xc2) :f5)
+(define-xt-keysym (keysym 255 #xc3) :f6)
+(define-xt-keysym (keysym 255 #xc4) :f7)
+(define-xt-keysym (keysym 255 #xc5) :f8)
+(define-xt-keysym (keysym 255 #xc6) :f9)
+(define-xt-keysym (keysym 255 #xc7) :f10)
+
+
 ;; Finally, the shifts
 ;; snarfed from translate.cl
 
@@ -1020,6 +1125,7 @@
 (define-xt-keysym left-hyper-keysym    :left-hyper)
 (define-xt-keysym right-hyper-keysym   :right-hyper)
 
+;;;
 (defun lookup-character-and-keysym (sheet mirror event)
   (declare (ignore sheet mirror)
 	   (optimize (speed 3) (safety 0)))
@@ -1065,11 +1171,11 @@
     (values character (xt-keysym->keysym keysym))))
 
 
-(defun state->modifiers (x &optional (shift-it t))
+(defun state->modifiers (x)
   (declare (optimize (speed 3) (safety 0))
 	   (fixnum x))
   (logior
-    (if (and shift-it (logtest x x11:shiftmask)) +shift-key+ 0)
+    (if (logtest x x11:shiftmask) +shift-key+ 0)
     (if (logtest x x11:controlmask) +control-key+ 0)
     (if (logtest x x11:mod1mask) +meta-key+ 0)
     (if (logtest x x11:mod2mask) +super-key+ 0)
@@ -1178,7 +1284,16 @@ the geometry of the children. Instead the parent has control. "))
   ;;---  Surely if a sheet is mirrored then you do not need to
   ;;--- invalidate any caches below that point
   nil)
-	    
+
+#+ignore
+(defmethod initialize-mirror :after ((port xt-port)
+				     (parent xt-geometry-manager)
+				     (parent-widget t)
+				     (sheet t)
+				     (widget t))
+  ;; A bogus attempt to get the initial sheet-region right.
+  (sheet-mirror-resized-callback nil nil nil sheet))
+
 
 ;; Instead if the geometry of the parent has changed, I guess this
 ;; suggests that the children have changed shape and that we need to
@@ -1228,6 +1343,10 @@ the geometry of the children. Instead the parent has control. "))
 
 (defvar *dont-invoke-callbacks* nil)
 
+(defmacro with-no-value-changed-callbacks (&body body)
+  `(let ((*dont-invoke-callbacks* t))
+     ,@body))
+
 (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet)))
   (declare (ignore widget))
   (unless *dont-invoke-callbacks*
@@ -1266,21 +1385,28 @@ the geometry of the children. Instead the parent has control. "))
 
 
 (defmethod port-canonicalize-gesture-spec 
-	   ((port xt-port) gesture-spec &optional modifier-state)
+    ((port xt-port) gesture-spec &optional modifier-state)
   (declare (optimize (speed 3) (safety 0)))
   (multiple-value-bind (keysym shifts)
       (if modifier-state
 	  (values gesture-spec modifier-state)
-	  (parse-gesture-spec gesture-spec))
+	(parse-gesture-spec gesture-spec))
     ;; Here, we must take the gesture spec, turn it back into
     ;; a keycode, then see what the keysyms are for that keycode
-    (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym))
-			(keysym->xt-keysym (xt-keysym->keysym (char-code keysym)))
-			(keysym->xt-keysym keysym)))
+    (let ((x-keysym 
+	   (if (characterp keysym)
+	       (case keysym
+		 (#\newline (keysym->xt-keysym :newline))
+		 (#\tab (keysym->xt-keysym :tab))
+		 (#\rubout (keysym->xt-keysym :rubout))
+		 (#\return (keysym->xt-keysym :return))
+		 (t (and (standard-char-p keysym)
+			 (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))))))
+	     (keysym->xt-keysym keysym)))
 	  (x-keycode nil))
       (unless x-keysym 
 	(return-from port-canonicalize-gesture-spec nil))
-      (cons keysym shifts))))
+      (cons (xt-keysym->keysym x-keysym) shifts))))
 
 
 
@@ -1300,6 +1426,23 @@ the geometry of the children. Instead the parent has control. "))
        (fix-coordinate y)))))
 
 
+
+(defmethod raise-mirror ((port xt-port) sheet)
+  (x11:xraisewindow (port-display port) (tk::widget-window (sheet-mirror sheet))))
+
+(defmethod raise-mirror ((port xt-port) (sheet top-level-sheet))
+  ;; Compensate for the top-level-sheet's mirror not being the right window.
+  (x11:xraisewindow (port-display port)
+		    (tk::widget-window (tk::widget-parent (sheet-mirror sheet)))))
+
+(defmethod bury-mirror ((port xt-port) sheet)
+  (x11:xlowerwindow (port-display port) (tk::widget-window (sheet-mirror sheet))))
+
+(defmethod bury-mirror ((port xt-port) (sheet top-level-sheet))
+  ;; Compensate for the top-level-sheet's mirror not being the right window.
+  (x11:xlowerwindow (port-display port)
+		    (tk::widget-window (tk::widget-parent (sheet-mirror sheet)))))
+
 (defmethod enable-mirror ((port xt-port) (sheet top-level-sheet))
   (let* ((mirror (sheet-mirror sheet))
  	 (parent (widget-parent mirror)))
@@ -1333,3 +1476,138 @@ the geometry of the children. Instead the parent has control. "))
 (defmethod enable-xt-widget ((parent top-level-shell) (mirror t))
   (manage-child mirror)
   (popup (widget-parent mirror)))
+
+
+(defmethod mirror-visible-p ((port xt-port) sheet)
+  (let ((mirror (sheet-mirror sheet)))
+    ;;--- This costs a round trip to the display server.  A better
+    ;;--- scheme would be to have the map/unmap-notify set a flag
+    ;;--- that we could simply read here, as in CLIM 1.1
+    ;;--- What does unviewable mean?
+    (not (eq (tk::window-map-state (tk::widget-window mirror)) :unmapped))))
+
+;;;---- Cursor stuff
+
+(defvar *clx-cursor-type-alist*
+	'((:default 132)
+	  (:vertical-scroll 116)
+	  (:scroll-up 114)
+	  (:scroll-down 106)
+	  (:horizontal-scroll 108)
+	  (:scroll-left 110)
+	  (:scroll-right 112)
+	  (:busy 150)
+	  (:upper-left 134)
+	  (:upper-right 136)
+	  (:lower-left 12)
+	  (:lower-right 14)
+	  (:vertical-thumb 112)
+	  (:horizontal-thumb 114)
+	  (:button 132)
+	  (:prompt 92)
+	  (:move 52)
+	  (:position 34)))
+
+
+
+(defmethod port-set-pointer-cursor ((port xt-port) pointer cursor)
+  (unless (eq (pointer-cursor pointer) cursor)
+    (let* ((cursor (and cursor (realize-cursor port cursor)))
+	   (widget (sheet-direct-mirror (frame-top-level-sheet 
+					 (pane-frame (pointer-sheet pointer)))))
+	   (window (tk::widget-window widget nil)))
+      (when window
+	(if cursor
+	    (x11:xdefinecursor
+	     (port-display port) window cursor)
+	  (x11:xundefinecursor
+	   (port-display port) window))
+	(port-force-output port)))
+    cursor))
+
+
+(defmethod port-set-sheet-pointer-cursor ((port xt-port) sheet cursor)
+  (unless (eq (silica::sheet-pointer-cursor sheet)  cursor)
+    (let* ((cursor (and cursor (realize-cursor port cursor)))
+	   (widget (sheet-mirror sheet))
+	   (window (tk::widget-window widget nil)))
+      (when window
+	(if cursor
+	    (x11:xdefinecursor
+	     (port-display port) window cursor)
+	  (x11:xundefinecursor
+	   (port-display port) window))
+	(port-force-output port))))
+  cursor)
+
+(defmethod realize-cursor :around ((port xt-port) cursor)
+  (with-slots (cursor-cache) port
+    (or (getf cursor-cache cursor)
+	(setf (getf cursor-cache cursor)
+	      (call-next-method)))))
+
+(defmethod realize-cursor ((port xt-port) (cursor symbol))
+  (let ((cursor (or (second (assoc cursor *clx-cursor-type-alist*))
+		    132)))
+    (realize-cursor port cursor)))
+
+(defmethod realize-cursor ((port xt-port) (cursor number))
+  (x11:xcreatefontcursor
+   (port-display port)
+   cursor))
+
+
+(defvar *pointer-grabbed* nil)
+
+
+(defmethod port-invoke-with-pointer-grabbed ((port xt-port) (sheet sheet) continuation 
+								    &key
+								    confine-to cursor
+								    (ungrab-on-error t))
+  (let ((widget (sheet-mirror sheet)))
+    (unwind-protect
+	(progn
+	  (tk::xt_grab_pointer
+	   widget 
+	   ;;---- Are these parameters correct????
+	   0				; owner-events
+	   (xt-grabbed-event-mask)
+					; Event-mask
+	   x11:grabmodeasync		; pointer-grab-mode
+	   x11:grabmodeasync		; keyboard
+	   (if confine-to widget 0)	; confine to
+	   (if cursor (realize-cursor port cursor) 0)
+	   0				; current-time
+	   )
+	  (handler-bind ((error #'(lambda (condition)
+				    (declare (ignore condition))
+				    (when ungrab-on-error
+				      (tk::xt_ungrab_pointer
+				       widget 0)))))
+	    (let ((*pointer-grabbed* t))
+	      (funcall continuation))))
+      (tk::xt_ungrab_pointer widget 0))))
+
+(defun xt-grabbed-event-mask ()
+  (tk::encode-event-mask '(:enter-window 
+			   :leave-window
+			   :pointer-motion-hint
+			   :pointer-motion
+			   :button-motion
+			   :button-press
+			   :button-release
+			   )))
+
+(defmethod port-set-sheet-grabbed-pointer-cursor ((port xt-port)
+							  sheet
+							  cursor)
+  (when *pointer-grabbed*
+    (x11::xchangeactivepointergrab
+     (port-display port)
+     (xt-grabbed-event-mask)					; event-mask
+     (if cursor (realize-cursor port cursor) 0)
+     0					; time
+     )))
+
+
+
diff --git a/tk/event.lisp b/tk/event.lisp
index c9c3562e55072c4078003ffc37a339f0eecc0276..469c5b0a5de7290feaa06294760ffb64b12bf5fd 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.11 92/08/19 10:23:32 cer Exp $
+;; $fiHeader: event.lisp,v 1.12 92/09/08 15:16:21 cer Exp Locker: cer $
 
 (in-package :tk)
 
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index d4298fa49cae7544d3bde51830f8d536ecf40666..411d9b952722c388430665a22c5cbd0db458f568 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-ol.lisp,v 1.16 92/08/21 16:33:32 cer Exp Locker: cer $
+;; $fiHeader: load-ol.lisp,v 1.17 92/09/08 10:34:03 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -28,9 +28,10 @@
 (require :climg)
 
 (defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a")
+(defvar sys::*clim-olit-pathname* "clim-olit.o")
 
 (x11::load-undefined-symbols-from-library
- "clim-olit.o"
+ sys::*clim-olit-pathname*
  (x11::symbols-from-file "misc/undefinedsymbols.olit")
  (list sys::*libxt-pathname* sys::*libx11-pathname*))
 
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index 38f5f3223cda52edb8db0f0c9a92a8419633a30d..48cc9f7bac5565c0da48f49bba22b249eda84e61 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.19 92/08/19 10:23:34 cer Exp Locker: cer $
+;; $fiHeader: load-xm.lisp,v 1.20 92/09/08 10:34:04 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -28,10 +28,12 @@
 (require :climg)
 
 ;;;; 
+
 (defvar sys::*libxt-pathname* "/x11/R4/sun4-lib/libXt.a")
+(defvar sys::*clim-motif-pathname* "clim-motif.o")
 
 (x11::load-undefined-symbols-from-library
- "clim-motif.o"
+ sys::*clim-motif-pathname*
  (x11::symbols-from-file "misc/undefinedsymbols.motif")
  (list sys::*libxt-pathname* sys::*libx11-pathname*))
 
diff --git a/tk/pkg.lisp b/tk/pkg.lisp
index 5ddd12c3b72b7acf8534f16c4c80e5216e0f81dc..d5681995981b89c0cebfb9d06ad138452d62e0bb 100644
--- a/tk/pkg.lisp
+++ b/tk/pkg.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.11 92/07/27 19:29:16 cer Exp $
+;; $fiHeader: pkg.lisp,v 1.12 92/08/18 17:53:43 cer Exp $
 
 (defpackage :tk
   ;;-- No we really need
@@ -35,6 +35,7 @@
    #:get-values
    #:top-level-shell
    #:popup
+   #:popdown
    #:manage-child
    #:realize-widget
    #:card32
@@ -46,5 +47,6 @@
    #:int16
    #:int8
    #:with-server-grabbed
+   #:window-property-list
    ))
 
diff --git a/tk/resources.lisp b/tk/resources.lisp
index ebb399392cff7c69e89de9ffe38b0377b6e7bcee..ce7ad7825f4bf30dfbafeb7a05b1b756eaa82984 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.30 92/09/08 10:34:05 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.31 92/09/08 15:16:25 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -611,3 +611,12 @@
 
 (defmethod convert-resource-in ((parent t) (typep (eql 'key-sym)) value)
   (cltl1:int-char value))
+
+
+;; Openlook 
+
+(defmethod convert-resource-out ((parent t) (typep (eql 'char)) value)
+  (char-int value))
+
+(defmethod convert-resource-in ((parent t) (typep (eql 'char)) value)
+  (cltl1:int-char value))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index c905fac4ef48517ec23d156326ac414c28623370..23c87f1c7a57d25722bfe3525459b938b8ca49c8 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.25 92/09/08 10:34:08 cer Exp Locker: cer $
+;; $fiHeader: xlib.lisp,v 1.26 92/09/09 11:44:28 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -48,7 +48,8 @@
 
 (defclass drawable (display-object) ())
 	  
-(defclass window (drawable) ())
+(defclass window (drawable)
+  ((plist :accessor window-property-list :initform nil)))
 
 (eval-when (compile load eval)
   (defconstant *window-set-attributes-bit-mask*
@@ -131,6 +132,8 @@
 (define-window-reader depth)
 (define-window-reader map-state decode-window-map-state)
 
+(define-window-accessor cursor nil)
+
 (defun decode-window-map-state (x)
   (declare (optimize (speed 3) (safety 0)))
   (ecase x
@@ -310,6 +313,9 @@
 	      (object-display colormap)
 	      colormap
 	      y)))
+      ;;-- This needs to be handled intelligently
+      ;;-- Perhaps the colormap code should enable the user to
+      ;;-- intercept this or we should just resort to some kind of stippling
       (when (zerop z)
 	(error "Could not allocate color: ~S" x))
       (values (x11:xcolor-pixel y)
@@ -446,6 +452,7 @@
 
 
 (defun event-type (event)
+  (declare (optimize (speed 3) (safety 0)))
   (elt *event-types* (x11::xevent-type event)))
 
 (defun encode-event-mask (mask)
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index 349849639ccbfdbb8e7cf1a54f5b1373a73d1ece..0144c62168962a25ea973547cb5ec6535688105e 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-funs.lisp,v 1.10 92/08/19 10:23:37 cer Exp $
+;; $fiHeader: xt-funs.lisp,v 1.11 92/09/08 15:16:27 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -290,6 +290,28 @@
     :arguments '(foreign-address fixnum)
     :arg-checking nil
     :return-type :void)
-    
 
+(defforeign 'xt_grab_pointer
+    :entry-point "_XtGrabPointer"
+    :call-direct t
+    :arguments '(foreign-address	; display
+		 foreign-address	; widget
+		 fixnum			; owner
+		 fixnum			; pgrabmode
+		 fixnum			; kgrabmode
+		 foreign-address	; confine to
+		 foreign-address	; cursor
+		 fixnum			; time
+		 )
+    :arg-checking nil
+    :return-type :fixnum)
+
+(defforeign 'xt_ungrab_pointer
+    :entry-point "_XtUngrabPointer"
+    :call-direct t
+    :arguments '(foreign-address	; display
+		 fixnum			; time
+		 )
+    :arg-checking nil
+    :return-type :fixnum)
 
diff --git a/utils/packages.lisp b/utils/packages.lisp
index cbcbcb46e9b0702e247e15a4923f71c5cf10147b..23aeb5dec4588d1be1a30d6b025b006e6bb9b2b7 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.26 92/09/08 10:34:27 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.27 92/09/08 15:17:07 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -1853,6 +1853,7 @@
     sheet-ancestor-p
     sheet-child
     sheet-children
+    sheet-cursor
     sheet-delta-transformation
     sheet-device-region
     sheet-device-transformation
@@ -1861,6 +1862,7 @@
     sheet-enabled-children
     sheet-enabled-p
     sheet-event-queue
+    sheet-grabbed-pointer-cursor
     sheet-grafted-p
     sheet-identity-transformation-mixin
     sheet-leaf-mixin
@@ -1873,6 +1875,7 @@
     sheet-native-transformation
     sheet-occluding-sheets
     sheet-parent
+    sheet-pointer-cursor
     sheet-region
     sheet-siblings
     sheet-single-child-mixin
@@ -1925,6 +1928,7 @@
     with-drawing-options
     with-first-quadrant-coordinates
     with-local-coordinates
+    with-pointer-grabbed
     with-rotation
     with-scaling
     with-translation
@@ -2587,6 +2591,7 @@
     application-frame
     application-frame-p
     application-pane
+    bury-frame
     client-setting
     command-enabled
     command-menu-pane
@@ -2642,7 +2647,9 @@
     note-command-disabled
     note-command-enabled
     note-frame-disabled
+    note-frame-deiconified
     note-frame-enabled
+    note-frame-iconified
     notify-user
     pane-frame
     pane-name
@@ -2651,6 +2658,7 @@
     pointer-documentation-pane
     position-sheet-carefully
     position-sheet-near-pointer
+    raise-frame
     read-frame-command
     reconfigure-frame
     redisplay-frame-pane
@@ -3499,12 +3507,16 @@
     port-graft-class
     port-grafts
     port-invalidate-gesture-specs
+    port-invoke-with-pointer-grabbed
     port-mirror->sheet-table
     port-note-cursor-change
     port-note-gadget-activated
     port-note-gadget-deactivated
     port-process
+    port-set-pointer-cursor
     port-set-pointer-position
+    port-set-sheet-pointer-cursor
+    port-set-sheet-grabbed-pointer-cursor
     port-trace-thing
     port-undefined-text-style
     process-event-locally