From c2878abc4a8fbe4de3d4529f94d03abca294e019 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 25 May 1993 20:42:58 +0000
Subject: [PATCH] clim/accept-values.lisp		Clearing the
 accept-values-query-error-p when the value changes 			
 Moving the focus to a specific query either 				when
 specified by 				initially-select-query-identifier or
 when an 				invalid value is entered in a text
 field. 				Help pops up in avv dialogs 	
 		Exit boxes support documentation option 		
 	Protocol for handling erroneous text fields 			
 accept-values-command-buttons now use push-button-view clim/activities.lisp
 	activity stores frame-actual-pointer-documentation-pane
 clim/db-stream.lisp		make-clim-stream-pane is now function 	
 		Fixed open-window-stream to create an 			
 ordinary frame clim/frames.lisp		default-frame-top-level now
 records 				actual-pointer-documentation-pane for
 use by 				gadget help. 			
 command-enabled-p now makes sure the command 				is
 defined clim/gadget-output.lisp		dialogs now define help
 callback that 				displays the accept help by default
 clim/input-defs.lisp		fixed typo in sheets-nearest-common-ancestor
 clim/interactive-protocol.lisp	popup help on accept-values-stream also
 clim/menus.lisp			open-window-stream frame added and
 open-window-stream clim/recording-protocol.lisp	erase-output-records
 now takes a list clim/standard-types.lisp	describe-presentation-type for
 completion 				now invokes printer
 clim/view-defs.lisp		push-button-view defined
 climtoys/draw-sheets.lisp	Added graph-mirror-hierarchy climtoys/ib.lisp
 	Changed interface climtoys/pi.lisp		Added display mirror
 hierarchy command climtoys/record.lisp		record button-press-events
 demo/cload-demos.lisp		made package clim-user
 demo/graphics-editor.lisp	Sample documentation. Rewrote presentation 
 			types to support describe methods misc/climgccursor.c
 	Removed diagnostics misc/compile-1.lisp		load test-suite.fasl
 after compiling it 				since test-suite uses it.
 misc/dev-load-1.lisp		Make sure composer is loaded
 misc/undefinedsymbols.motif	Fixed typo misc/undefinedsymbols.xt	Added
 parse-table symbol silica/db-scroll.lisp		Moved
 line-scroll-amount into update scrollbar silica/gadgets.lisp		Added
 help callback, 				move-focus-to-gadget,
 port-move-focus-to-gadget silica/macros.lisp		Added
 make-clim-stream-pane flet and macro silica/sheet.lisp test/test-clim.lisp
 	Fixed up tests. Support for profiling test/test-driver.lisp	
 Added *execute-one-command-hook* to support profiling 			
 with-test-success-expected macro 			
 do-frame-test-with-profiling test/test-suite.lisp		Added now
 square bitmap, erase-output-record 				with list of
 records, list-pane test tk/event.lisp			commented out
 diagnostic tk/ol-widgets.lisp		Added some missing resources
 tk/resources.lisp		Made :ignore be -1 and 65535 		
 	conversion for accelerator and translation tables tk/xt-funs.lisp
 		Added parse accelerator and translation 		
 	tables and peek-event tk-silica/ol-frames.lisp	Documentation
 callbacks tk-silica/ol-gadgets.lisp	Documentation callback 		
 	Fix listpane tk-silica/xm-frames.lisp	added documentation callbacks
 tk-silica/xm-gadgets.lisp	added added documentation callbacks
 tk-silica/xm-silica.lisp	port-move-focus-to-gadget
 tk-silica/xt-frames.lisp	"Ok" -> "OK" 				added
 documentation callbacks tk-silica/xt-graphics.lisp	dummy
 with-medium-state-cached tk-silica/xt-silica.lisp utils/packages.lisp	
 exported various

---
 clim/accept-values.lisp        | 369 ++++++++++++++++++++++-----------
 clim/activities.lisp           |  15 +-
 clim/db-stream.lisp            | 185 ++++++-----------
 clim/frames.lisp               |  91 ++++----
 clim/gadget-output.lisp        |  42 ++--
 clim/input-defs.lisp           |   4 +-
 clim/interactive-protocol.lisp |   4 +-
 clim/menus.lisp                |  85 +++++++-
 clim/recording-protocol.lisp   |  59 ++++--
 clim/standard-types.lisp       |   4 +-
 clim/view-defs.lisp            |   4 +-
 demo/cload-demos.lisp          |   4 +-
 demo/graphics-editor.lisp      |  61 ++++--
 misc/climgccursor.c            |   5 -
 misc/compile-1.lisp            |   4 +-
 misc/dev-load-1.lisp           |  15 +-
 misc/undefinedsymbols.motif    |   2 +-
 misc/undefinedsymbols.xt       |   2 +
 notes/profiles/.cvsignore      |   1 +
 silica/db-scroll.lisp          |  46 ++--
 silica/gadgets.lisp            |  13 +-
 silica/macros.lisp             |  17 +-
 silica/sheet.lisp              |   3 +-
 test/test-clim.lisp            |  98 +++++++--
 test/test-driver.lisp          |  51 ++++-
 test/test-suite.lisp           |  34 ++-
 tk-silica/ol-frames.lisp       |  17 +-
 tk-silica/ol-gadgets.lisp      |  86 ++++----
 tk-silica/xm-frames.lisp       |  72 ++++---
 tk-silica/xm-gadgets.lisp      |  46 +++-
 tk-silica/xm-silica.lisp       |   8 +-
 tk-silica/xt-frames.lisp       |  20 +-
 tk-silica/xt-graphics.lisp     |   5 +-
 tk-silica/xt-silica.lisp       |   5 +-
 tk/event.lisp                  |   8 +-
 tk/ol-widgets.lisp             |  20 +-
 tk/resources.lisp              | 316 ++++++++++++++--------------
 tk/xt-funs.lisp                |  27 ++-
 utils/packages.lisp            |   6 +-
 39 files changed, 1194 insertions(+), 660 deletions(-)
 create mode 100755 notes/profiles/.cvsignore

diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index 3a0b6549..a72de6c7 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.61 1993/05/05 01:38:12 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.62 1993/05/13 16:22:58 cer Exp $
 
 (in-package :clim-internals)
 
@@ -138,6 +138,8 @@
 		   (setf (accept-values-query-changed-p query) nil)))))
 
 ;; Probably should be keyword arguments...
+
+
 (defmethod find-or-add-query ((stream accept-values-stream) query-identifier ptype prompt
 			      default default-supplied-p view active-p)
   (let ((avv-record (slot-value stream 'avv-record)))
@@ -180,7 +182,8 @@
 				 ;; can change values without changing the query itself.
 				 :default (if (accept-values-query-changed-p query)
 					      (accept-values-query-value query)
-					      (setf (accept-values-query-value query) default))
+					      (setf (accept-values-query-error-p query) nil
+						  (accept-values-query-value query) default))
 				 :history ptype
 				 :present-p `(accept-values-choice ,query)
 				 :query-identifier query
@@ -449,9 +452,9 @@
 			      (setq initial-query
 				    (find-query avv-record 
 						(car initially-select-query-identifier))))
-		     (if (cdr initially-select-query-identifier)
-			 (com-modify-avv-choice initial-query)
-			 (com-edit-avv-choice initial-query))
+		     (move-focus-to-query stream 
+					  initial-query
+					  (not (cdr initially-select-query-identifier)))
 		     (redisplay avv stream :check-overlapping check-overlapping))
 		   (loop
 		     (let ((command
@@ -561,6 +564,32 @@
 		(move-cursor-beyond-output-record 
 		  (encapsulating-stream-stream stream) avv)))))))))
 
+(defun find-query-gadget (query)
+  (let ((record (accept-values-query-presentation query)))
+    (when record
+      (labels ((find-gadget-output-record (record)
+		 (typecase record
+		   (gadget-output-record 
+		    (return-from find-query-gadget (output-record-gadget record)))
+		   (output-record
+		    (map-over-output-records #'find-gadget-output-record record)))))
+	(declare (dynamic-extent #'find-gadget-output-record))
+	(find-gadget-output-record record)))))
+
+(defun move-focus-to-query (stream query &optional (editp t))
+  (declare (ignore stream))
+  ;;-- If there is a gadget then we should move the focus to that
+  ;;-- otherwise edit the field
+  (let ((gadget (find-query-gadget query)))
+    (cond (gadget
+	   (move-focus-to-gadget gadget))
+	  ;;-- This stuff will still loose on old style CLIM
+	  ;;-- member fields
+	  (editp
+	   (com-edit-avv-choice query))
+	  (t
+	   (com-modify-avv-choice query)))))
+
 (defmethod display-view-background (stream (view view))
   nil)
 
@@ -593,36 +622,16 @@
   (loop (read-gesture :stream stream)))
 
 (defmethod frame-manager-display-help 
-	   ((framem standard-frame-manager) (frame accept-values-own-window) stream continuation)
+    (framem (frame accept-values-own-window) (stream standard-input-editing-stream) continuation)
   (declare (dynamic-extent continuation))
-  (when (null (slot-value frame 'help-window))
-    (setf (slot-value frame 'help-window)
-	  (allocate-resource 'menu stream (window-root stream))))
-  (let ((help-window (slot-value frame 'help-window))
-	(own-window (slot-value frame 'own-window)))
-    (setf (window-visibility help-window) nil)
-    ;; You might think that we should bind *INPUT-CONTEXT* to NIL, but
-    ;; by not doing the translators from the ACCEPT-VALUES dialog apply
-    ;; to any items presented in the help window.  Cool, huh?
-    (let ((*original-stream* nil))
-      (window-clear help-window)
-      (with-output-recording-options (help-window :draw t :record t)
-	(with-end-of-line-action (help-window :allow)
-	  (with-end-of-page-action (help-window :allow)
-	    (funcall continuation help-window)
-	    (fresh-line help-window)
-	    (with-text-face (help-window :italic)
-	      (write-line "Press any key to remove this window" help-window)))))
-      (size-frame-from-contents help-window)
-      (multiple-value-bind (x y) (bounding-rectangle-position own-window)
-	(position-sheet-carefully 
-	  (frame-top-level-sheet (pane-frame help-window)) x y))
-      (setf (window-visibility help-window) t)
-      (clear-input help-window)
-      (unwind-protect
-	  (with-input-focus (help-window)
-	    (read-gesture :stream help-window))
-	(setf (window-visibility help-window) nil)))))
+  ;;-- Yuck but think of a better way
+  (let ((old-help *accept-help*))
+    (accepting-values (stream :exit-boxes '(:exit)
+			      :label "Input editor help"
+			      :own-window t)
+      (let ((*accept-help* old-help))
+	(funcall continuation stream)))))
+
 
 (defmethod accept-values-top-level :around ((frame accept-values-own-window) &rest args)
   (declare (ignore args))
@@ -667,14 +676,17 @@
 
 (define-presentation-type accept-values-exit-box ())
 
-(defmacro with-exit-box-decoded ((value label text-style) exit-box labels &body body)
+(defmacro with-exit-box-decoded ((value label text-style documentation) exit-box labels &body body)
   `(let* ((,value (if (consp ,exit-box) (first ,exit-box) ,exit-box))
 	  (,label (or (and (consp ,exit-box)
 			   (second ,exit-box))
 		      (second (assoc ,value ,labels))))
 	  (,text-style (or (and (consp ,exit-box)
 				(getf (cddr ,exit-box) :text-style))
-			   (getf (cddr (assoc ,value ,labels)) :text-style))))
+			   (getf (cddr (assoc ,value ,labels)) :text-style)))
+	  (,documentation (or (and (consp ,exit-box)
+				   (getf (cddr ,exit-box) :documentation))
+			      (getf (cddr (assoc ,value ,labels)) :documentation))))
      ,@body))
 
 ;;; Applications can create their own AVV class and specialize this method in
@@ -689,7 +701,8 @@
     (updating-output (stream :unique-id stream :cache-value 'exit-boxes)
       (with-slots (exit-boxes) frame
 	(dolist (exit-box exit-boxes)
-	  (with-exit-box-decoded (value label text-style) exit-box labels
+	  (with-exit-box-decoded (value label text-style documentation) exit-box labels
+	    (declare (ignore documentation))
 	    (when label
 	      (with-text-style (stream text-style)
 		(with-output-as-presentation (stream value 'accept-values-exit-box)
@@ -884,21 +897,88 @@
 (define-gesture-name :abort-dialog :keyboard (:abort))
 
 (define-accept-values-command (com-exit-avv :keystroke :exit-dialog) ()
-  (with-slots (stream) *application-frame*
-    (let ((avv-record (slot-value stream 'avv-record))
-	  (query-ids nil))
-      (map-over-accept-values-queries avv-record
-	#'(lambda (record unique-id)
-	    (declare (ignore record))
-	    (when (accept-values-query-error-p (find-query avv-record unique-id))
-	      (push unique-id query-ids))))
-      (if query-ids
-	  (notify-user *application-frame*
-		       (format nil "The following fields are not valid:~{ ~A~}"
-			 (mapcar #'cadr (nreverse query-ids)))
-		       :title "Invalid Fields"
-		       :style :error :exit-boxes '(:exit))
-	  (frame-exit *application-frame*)))))
+  (let ((frame *application-frame*))
+    (with-slots (stream) frame
+      (when (verify-queries frame stream (slot-value stream 'avv-record))
+	(frame-exit *application-frame*)))))
+
+
+(defun verify-queries (frame stream avv-record)
+  (let ((queries nil))
+    (maphash
+     #'(lambda (query-identifier query)
+	 (declare (ignore query-identifier))
+	 (when (and (accept-values-query-active-p query)
+		    (output-record-stream (accept-values-query-presentation query))
+		    (accept-values-query-error-p query))
+	   (push query queries)))
+     (slot-value avv-record 'query-table))
+    (if queries
+	(progn
+	  (verify-queries-1 frame stream queries)
+	  nil)
+      t)))
+
+(defun verify-queries-1 (frame stream queries)
+  (display-invalid-queries 
+   frame 
+   stream
+   (mapcar #'(lambda (query)
+	       (list
+		query
+		(slot-value query 'query-identifier)
+		(let ((condition (accept-values-query-error-p query)))
+		  (and (not (eq condition t)) condition))))
+	   queries))
+  (move-focus-to-query stream (car queries)))
+	
+
+
+(defmethod display-invalid-queries ((frame standard-application-frame) stream query-info)
+  (declare (ignore stream))
+  (notify-user frame
+	       (format nil "The following fields are not valid:~{ ~{~A~:[~;~:* : ~A~]~}~}"
+		       (mapcar #'(lambda (query-stuff)
+				   (destructuring-bind (query id condition) query-stuff
+				     (declare (ignore query))
+				     (list
+				      (if (and (consp id)
+					       (eq (car id) :query-identifier)
+					       (consp (cdr id))
+					       (stringp (second id)))
+					  (second id)
+					id)
+				      (and (not (eq condition t)) condition))))
+			       query-info))
+	       :title "Invalid Fields"
+	       :style :error :
+	       exit-boxes '(:exit)))
+
+(defmethod display-invalid-queries ((frame accept-values-own-window) stream queries)
+  (display-invalid-queries (frame-calling-frame frame) stream queries))
+
+#+ignore
+(defmethod (setf accept-values-query-error-p query) :around (value (query accept-values-query))
+  (let ((old-value (accept-values-query-error-p query)))
+    (call-next-method)
+    (unless (eq value old-value)
+      (note-query-validity-changed query value))))
+
+#+ignore
+(defmethod note-query-validity-changed (query errorp)
+  (let ((gadget (find-query-gadget query)))
+    (when (and gadget (typep gadget '(or text-field text-editor)))
+      (if errorp
+	  (setf (gadget-original-background gadget) (gadget-background gadget)
+		(gadget-background gadget) +red+)
+	(setf (gadget-background gadget) (gadget-original-background gadget))))))
+
+;; Focus-in callback/ value changed - establish normal 
+;; Focus-out callback - establish error condition
+;; Need to save away contents, cursor position, colors.
+;; What about the case when we are changing it back to ok cos some one
+;; has changed the value?
+;; Perhaps the old value come from present-to-string the query value.
 
 (define-accept-values-command (com-abort-avv :keystroke :abort-dialog) ()
   (abort))
@@ -926,33 +1006,34 @@
 
 (define-presentation-type accept-values-command-button ())
 
-(defmacro accept-values-command-button ((&optional stream &rest options) prompt 
-					&body body &environment env)
+(defmacro accept-values-command-button ((&optional stream &rest options &key (view nil viewp) &allow-other-keys) prompt 
+														 &body body &environment env)
   #+Genera (declare (zwei:indentation 1 3 2 1))
   #-(or Genera Minima) (declare (ignore env))
   (declare (arglist ((&optional stream 
-		      &key documentation query-identifier
-			   (cache-value t) (cache-test #'eql)
-			   view resynchronize)
+				&key documentation query-identifier
+				(cache-value t) (cache-test #'eql)
+				view resynchronize)
 		     prompt &body body)))
   (default-input-stream stream accept-values-command-button)
-  (let ((constant-prompt-p
-	  (and (constantp prompt #+(or Genera Minima) env)
-	       (stringp (eval prompt #+(or Genera Minima-Developer) env)))))
-    `(flet ((avv-command-button-body () ,@body)
-	    ,@(unless constant-prompt-p
-		`((avv-command-button-prompt (,stream) ,prompt))))
-       ,@(unless constant-prompt-p
-	   `((declare (dynamic-extent #'avv-command-button-prompt))))
-       (invoke-accept-values-command-button
-	 ,stream
-	 #'avv-command-button-body ,(getf options :view `(stream-default-view ,stream))
-	 ,(if constant-prompt-p
-	      (eval prompt #+(or Genera Minima-Developer) env)
-	      '#'avv-command-button-prompt)
-	 ,@options))))
-
-(defmethod invoke-accept-values-command-button
+  (with-keywords-removed (options options '(:view))
+    (let ((constant-prompt-p
+	   (and (constantp prompt #+(or Genera Minima) env)
+		(stringp (eval prompt #+(or Genera Minima-Developer) env)))))
+      `(flet ((avv-command-button-body () ,@body)
+	      ,@(unless constant-prompt-p
+		  `((avv-command-button-prompt (,stream) ,prompt))))
+	 ,@(unless constant-prompt-p
+	     `((declare (dynamic-extent #'avv-command-button-prompt))))
+	 (invoke-accept-values-command-button
+	  ,stream
+	  #'avv-command-button-body ,(if viewp view `(stream-default-view ,stream))
+	  ,(if constant-prompt-p
+	       (eval prompt #+(or Genera Minima-Developer) env)
+	     '#'avv-command-button-prompt)
+	  ,@options)))))
+
+(defmethod invoke-accept-values-command-button-1
 	   (stream continuation (view t) prompt
 	    &key (documentation (if (stringp prompt)
 				    prompt
@@ -960,8 +1041,10 @@
 				      (funcall prompt stream))))
 		 (query-identifier (list ':button documentation))
 		 (cache-value t) (cache-test #'eql)
-		 resynchronize)
-  (declare (dynamic-extent prompt))
+		 resynchronize
+		 active-p)
+  (declare (dynamic-extent prompt)
+	   (ignore active-p))
   (updating-output (stream :unique-id query-identifier :id-test #'equal
 			   :cache-value cache-value :cache-test cache-test)
     (with-output-as-presentation (stream
@@ -1301,8 +1384,8 @@
 			       :cache-value 'exit-boxes)
 	(formatting-table (stream :equalize-column-widths nil)
 	  (dolist (exit-box exit-boxes)
-	    (with-exit-box-decoded (value label text-style) exit-box labels
-	      (when label
+	    (with-exit-box-decoded (value label text-style documentation) exit-box labels
+		(when label
 		(when text-style
 		  (setq text-style `(:text-style ,text-style)))
 		(formatting-column (stream)
@@ -1310,6 +1393,7 @@
 		    (with-output-as-gadget (stream)
 		      (apply #'make-pane 'push-button
 			:label label
+			:help-callback documentation
 			:client frame :id value
 			:activate-callback #'handle-exit-box-callback
 			text-style))))))))))))
@@ -1357,8 +1441,42 @@
   `(,#'accept-values-value-changed-callback ,stream ,query))
 
 ;; This is how we associate an output-record with the button
-(defmethod invoke-accept-values-command-button
-    (stream continuation (view gadget-dialog-view) prompt
+
+(defun invoke-accept-values-command-button (stream continuation view prompt
+					    &rest options
+					    &key (documentation (if (stringp prompt)
+								    prompt
+								  ;;-- What is the right thing to do?
+								  (ignore-errors
+								   (with-output-to-string (stream)
+								     (funcall prompt stream)))))
+						 (query-identifier (list ':button documentation))
+					    &allow-other-keys)
+  (typecase view
+    (null)
+    (symbol (setq view (make-instance view)))
+    (cons   (setq view (apply #'make-instance view))))
+  (apply #'invoke-accept-values-command-button-1
+	 stream
+	 continuation
+	 (decode-indirect-view
+	  'accept-values-command-button
+	  view
+	  (frame-manager stream)
+	  :query-identifier query-identifier)
+	 prompt
+	 :documentation documentation
+	 :query-identifier query-identifier
+	 options))
+
+(define-presentation-method decode-indirect-view
+    ((type accept-values-command-button) (view gadget-dialog-view)
+					  (framem standard-frame-manager) &key read-only)
+  (declare (ignore read-only))
+  +push-button-view+)
+
+(defmethod invoke-accept-values-command-button-1
+    (stream continuation (view push-button-view) prompt
      &key (documentation (if (stringp prompt)
 			     prompt
 			   ;;-- What is the right thing to do?
@@ -1367,44 +1485,59 @@
 			      (funcall prompt stream)))))
 	  (query-identifier (list ':button documentation))
 	  (cache-value t) (cache-test #'eql)
-	  resynchronize)
+	  resynchronize
+	  (active-p t))
   (declare (dynamic-extent prompt))
+  (move-cursor-to-view-position stream view)
   (updating-output (stream :unique-id query-identifier :id-test #'equal
-			   :cache-value cache-value :cache-test cache-test)
-    (flet ((doit (stream)
-	     (with-output-as-gadget (stream)
-	       (let ((record (stream-current-output-record (encapsulating-stream-stream stream)))
-		     (client (make-instance 'accept-values-command-button
-					    :continuation continuation
-					    :documentation documentation
-					    :resynchronize resynchronize)))
-		 (make-pane 'push-button
-			    :id record :client client
-			    :activate-callback
-			    #'(lambda (button)
-				(when (accept-values-query-valid-p nil record) ;---can't be right
-				  (let ((sheet (sheet-parent button)))
-				    (process-command-event
-				     sheet
-				     (allocate-event 'presentation-event
-						     :sheet sheet
-						     :echo nil
-						     :presentation-type 'command
-						     :value `(com-avv-command-button ,client ,record)
-						     :frame *application-frame*)))))
-		   
-			    :label (if (stringp prompt)
-				       prompt
-				     ;;-- Does this suck or what???
-				     ;;-- If you do a
-				     ;;surrounding-output-with-border without
-				     ;;this write-string output does not get bordered.
-				     (let ((*original-stream* nil))
-				       (pixmap-from-menu-item stream 
-							      prompt
-							      #'funcall
-							      nil))))))))
-      (let ((align-prompts (slot-value stream 'align-prompts)) query)
+			   :cache-value (cons active-p cache-value) 
+			   :cache-test #'(lambda (x y)
+					   (and (eq (car x) (car y))
+						(funcall cache-test (cdr x) (cdr y)))))
+    (labels ((update-gadget (record gadget)
+			(declare (ignore record))	     ;;-- This sucks
+			(setf (gadget-label gadget) (compute-prompt))
+			(if active-p
+			    (activate-gadget gadget)
+			  (deactivate-gadget gadget)))
+	     (compute-prompt ()
+	       (if (stringp prompt)
+		   prompt
+		 ;;-- Does this suck or what???
+		 ;;-- If you do a
+		 ;;surrounding-output-with-border without
+		 ;;this write-string output does not get bordered.
+		 (let ((*original-stream* nil))
+		   (pixmap-from-menu-item stream 
+					  prompt
+					  #'funcall
+					  nil))))
+	     (doit (stream)
+	       (with-output-as-gadget (stream  :update-gadget #'update-gadget)
+		   (let ((record (stream-current-output-record (encapsulating-stream-stream stream)))
+			 (client (make-instance 'accept-values-command-button
+						:continuation continuation
+						:documentation documentation
+						:resynchronize resynchronize)))
+		     (make-pane-from-view 
+		      'push-button
+		      view
+		      :id record :client client
+		      :activate-callback #'(lambda (button)
+					     (when (accept-values-query-valid-p nil record) ;---can't be right
+					       (let ((sheet (sheet-parent button)))
+						 (process-command-event
+						  sheet
+						  (allocate-event 'presentation-event
+								  :sheet sheet
+								  :echo nil
+								  :presentation-type 'command
+								  :value `(com-avv-command-button ,client ,record)
+								  :frame *application-frame*)))))
+		      :label (compute-prompt)
+		      :help-callback documentation
+		      :active active-p)))))
+      (let ((align-prompts (slot-value stream 'align-prompts)))
 	(if align-prompts
 	    (formatting-row (stream)
 	      (formatting-cell (stream) stream)
@@ -1412,3 +1545,7 @@
 	  (doit stream))))))
 
 
+
+
+
+
diff --git a/clim/activities.lisp b/clim/activities.lisp
index 5b56eea6..c934c5c0 100644
--- a/clim/activities.lisp
+++ b/clim/activities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: activities.lisp,v 1.11 93/03/19 09:43:12 cer Exp $
+;; $fiHeader: activities.lisp,v 1.12 1993/05/05 01:38:17 cer Exp $
 
 (in-package :clim-internals)
 
@@ -21,7 +21,8 @@
      (input-buffer :initform (make-locking-queue) :accessor frame-input-buffer)
      (auto-select :initform nil :initarg :auto-select :accessor activity-auto-select)
      (frame-manager :initform nil :initarg :frame-manager
-		    :accessor frame-manager)))
+		    :accessor frame-manager)
+     (actual-pointer-documentation-pane :initform nil :accessor frame-actual-pointer-documentation-pane)))
 
 (defmethod initialize-instance :after ((activity activity) &key pretty-name)
   (setf (frame-pretty-name activity)
@@ -29,6 +30,7 @@
   (unless (frame-manager activity)
     (setf (frame-manager activity) (find-frame-manager))))
 
+
 (defmethod frame-name ((activity activity))
   (type-of activity))
 
@@ -147,6 +149,15 @@
 (defclass activity-frame (standard-application-frame)
     ((activity :initform nil :accessor frame-activity :initarg :activity)))
 
+(defmethod frame-actual-pointer-documentation-pane ((frame activity-frame))
+  (let ((act (frame-activity frame)))
+    (and act (frame-actual-pointer-documentation-pane act))))
+
+(defmethod (setf frame-actual-pointer-documentation-pane) (value (frame activity-frame))
+  (let ((act (frame-activity frame)))
+    (when act (setf (frame-actual-pointer-documentation-pane act) value)))
+  value)
+
 (defmethod frame-top-level-process ((frame activity-frame))
   (let ((act (frame-activity frame)))
     (and act (slot-value act 'top-level-process))))
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 638a841c..3a1a1b4c 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.51 93/05/13 16:23:01 cer Exp $
+;; $fiHeader: db-stream.lisp,v 1.52 1993/05/13 16:28:41 colin Exp $
 
 (in-package :clim-internals)
 
@@ -347,79 +347,65 @@
 
 (defclass command-menu-pane (clim-stream-pane) ())
 
-(defmethod compose-space :before ((pane command-menu-pane) &key width height)
-  (declare (ignore width height))
-  ;;------ !!!!!!!!!!!!!!!!!!!!!!
-  ;;
-  #+ignore
-  (window-clear pane))
-
-
-;; This is a macro because it counts on being expanded inside of a call
-;; to WITH-LOOK-AND-FEEL-REALIZATION
-(defmacro make-clim-stream-pane (&rest options
-				 &key (type ''clim-stream-pane) 
-				      label 
-				      (label-alignment #+Genera :bottom #-Genera :top)
-				      (scroll-bars ':vertical)
-				      (borders t)
-				      (display-after-commands nil dac-p)
-				      (background nil background-p)
-				      name
-				 &allow-other-keys)
-  (setq options (remove-keywords options '(:type :scroll-bars :borders
-					   :label :background
-					   :label-alignment :display-after-commands)))
-  (let* ((stream '#:clim-stream)
-	 (display-time
-	   (and dac-p
-		`(:display-time ,(cond ((eq display-after-commands t) :command-loop)
-				       ((eq display-after-commands :no-clear) :no-clear)
-				       (t nil)))))
-	 (background-var (and background (gensym)))
-	 (pane
-	   `(setq ,stream (make-pane ,type 
-				     ,@display-time
-				     ,@(and background-p `(:background ,background-var))
-				     ,@options))))
-    (when scroll-bars
-      (setq pane `(scrolling
-		      (:scroll-bars ,scroll-bars
-		       :name ,name
-		       ,@(and background-p `(:background ,background-var)))
-		    ,pane)))
-    (when label
-      (let ((label (if (stringp label)
-		       `(make-pane 'label-pane 
-			  :label ,label
-			  :max-width +fill+
-			   ,@(and background-p `(:background ,background-var)))
-		       `(make-pane 'label-pane 
-			  :label ,(first label)
-			  :max-width +fill+ ,@(rest label)
-			   ,@(and background-p `(:background ,background-var))))))
-	(ecase label-alignment
-	  (:bottom
-	   (setq pane `(vertically 
-			   (,@(and background-p `(:background ,background-var)))
-			 ,pane
-			 ,label)))
-	  (:top
-	   (setq pane `(vertically 
-			   (,@(and background-p `(:background ,background-var)))
-			 ,label
-			 ,pane))))))
-    (when borders 
-      (setq pane `(outlining 
-		      (:thickness 1 
-		       :name ,name
-		       ,@(and background-p `(:background ,background-var)))
-		    (spacing (:thickness 1
-			      ,@(and background-p `(:background ,background-var)))
-		      ,pane))))
-    `(let ((,stream)
-	   ,@(and background-p `((,background-var ,background))))
-       (values ,pane ,stream))))
+(defun make-clim-stream-pane-1 (framem frame
+				&rest options
+				&key (type 'clim-stream-pane)
+				     label 
+				     (label-alignment #+Genera :bottom #-Genera :top)
+				     (scroll-bars ':vertical)
+				     (borders t)
+				     (display-after-commands nil dac-p)
+				     (background nil background-p)
+				     name
+				&allow-other-keys)
+  (with-look-and-feel-realization (framem frame)
+    (setq options (remove-keywords options '(:type :scroll-bars :borders
+					     :label :background
+					     :label-alignment :display-after-commands)))
+    (when dac-p
+      (setf (getf options :display-time)
+	(cond ((eq display-after-commands t) :command-loop)
+	      ((eq display-after-commands :no-clear) :no-clear)
+	      (t nil))))
+    
+    (let* ((stream (apply #'make-pane type options))
+	   (pane stream))
+
+      (when scroll-bars
+	(setq pane (apply #'make-pane 'scroller-pane
+			  :contents pane
+			  :name name
+			  (and background-p `(:background ,background)))))
+
+      (when label
+	(let ((label (if (stringp label)
+			 (apply #'make-pane 'label-pane 
+				:label label
+				:max-width +fill+
+				(and background-p `(:background ,background)))
+		       (apply #'make-pane 'label-pane 
+			      :label (first label)
+			      :max-width +fill+ 
+			      (append (rest label)
+				      (and background-p `(:background ,background)))))))
+	  (setq pane (apply #'make-pane 'vbox-pane
+			    :contents 	  
+			    (ecase label-alignment
+			      (:bottom (list pane label))
+			      (:top (list label pane)))
+			    (and background-p `(:background ,background))))))
+      (when borders 
+	(setq pane
+	  (apply #'make-pane 'outlined-pane
+		 :name name
+		 :thickness 1
+		 :contents (apply #'make-pane 'spacing-pane
+				  :name name
+				  :thickness 1
+				  :contents pane
+				  (and background-p `(:background ,background)))
+		 (and background-p `(:background ,background)))))
+      (values pane stream))))
 
 (defmacro make-clim-interactor-pane (&rest options)
   `(make-clim-stream-pane :type 'interactor-pane ,@options))
@@ -680,54 +666,3 @@
       (values (floor (- right left) char-width)
 	      (floor (- bottom top) line-height)))))
 
-
-;;; This is too useful to simply omit
-(defun open-window-stream (&key left top right bottom width height
-				(foreground +black+) (background +white+)
-				text-style default-text-style
-				(vertical-spacing 2)
-				(end-of-line-action :allow)
-				(end-of-page-action :allow)
-				output-record (draw t) (record t)
-				(initial-cursor-visibility :off)
-				text-margin default-text-margin
-				save-under input-buffer
-				(scroll-bars :vertical) borders label)
-  (declare (ignore borders input-buffer))
-  (when (or width height)
-    (assert (and (null right) (null bottom))))
-  (when (null left) (setq left 0))
-  (when (null top)  (setq top 0))
-  (when (or (null width) (null height))
-    (if (or (null right) (null bottom))
-	(setq width 100
-	      height 100)
-	(setq width (- right left)
-	      height (- bottom top))))
-  (let* ((stream
-	  ;;-- This should call frame-manager-get-menu to get
-	  ;;-- the right kind of menu-frame
-	  (frame-manager-get-menu (find-frame-manager)
-					       ;;-- what about :save-under
-					       :label label
-					       :scroll-bars scroll-bars))
-	 (port (port stream)))
-    (setf (medium-foreground stream) foreground
-	  (medium-background stream) background
-	  (medium-default-text-style stream) (or default-text-style *default-text-style*)
-	  (medium-text-style stream) (or text-style *default-text-style*)
-	  (stream-vertical-spacing stream) vertical-spacing
-	  (stream-end-of-line-action stream) end-of-line-action
-	  (stream-end-of-page-action stream) end-of-page-action
-	  (stream-recording-p stream) record
-	  (stream-drawing-p stream) draw
-	  (cursor-visibility (stream-text-cursor stream)) initial-cursor-visibility
-	  (stream-text-margin stream) text-margin
-	  (stream-default-text-margin stream) default-text-margin)
-    (when output-record
-      (stream-output-history stream) (make-instance output-record))
-    (window-set-inside-size stream width height)
-    (window-set-viewport-position stream 0 0)
-    (position-sheet-carefully
-      (frame-top-level-sheet (pane-frame stream)) width height)
-    stream))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index f6b52a55..0f5569db 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.66 1993/05/05 01:38:23 cer Exp $
+;; $fiHeader: frames.lisp,v 1.67 1993/05/13 16:23:04 cer Exp $
 
 (in-package :clim-internals)
 
@@ -55,7 +55,8 @@
      (top-level-process :initform nil :reader frame-top-level-process)
      (command-queue :initform (make-locking-queue) :reader frame-command-queue)
      (input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer)
-     (pane-to-avv-stream-table :initform nil :accessor frame-pane-to-avv-stream-table))
+     (pane-to-avv-stream-table :initform nil :accessor frame-pane-to-avv-stream-table)
+     (actual-pointer-documentation-pane :initform nil :accessor frame-actual-pointer-documentation-pane))
   (:default-initargs :pointer-documentation nil
 		     :layouts nil
 		     :resize-frame nil
@@ -886,61 +887,62 @@
 
 (defmethod default-frame-top-level ((frame standard-application-frame)
 				    &key command-parser command-unparser
-					 partial-command-parser
-					 (prompt "Command: "))
+				    partial-command-parser
+				    (prompt "Command: "))
   ;; Enable the frame now
   (unless (eq (frame-state frame) :enabled)
     (enable-frame frame))
   (loop
     (let* ((*standard-output*
-	     (or (frame-standard-output frame) *standard-output*))
+	    (or (frame-standard-output frame) *standard-output*))
 	   (*standard-input* 
-	     (or (frame-standard-input frame) *standard-output*))
+	    (or (frame-standard-input frame) *standard-output*))
 	   (*query-io* 
-	     (or (frame-query-io frame) *standard-input*))
+	    (or (frame-query-io frame) *standard-input*))
 	   (*error-output* 
-	     (or (frame-error-output frame) *standard-output*))
+	    (or (frame-error-output frame) *standard-output*))
 	   (*pointer-documentation-output*
-	     (frame-pointer-documentation-output frame))
+	    (frame-pointer-documentation-output frame))
 	   (interactor
-	     (not (null (find-frame-pane-of-type frame 'interactor-pane))))
+	    (not (null (find-frame-pane-of-type frame 'interactor-pane))))
 	   (*command-parser*
-	     (or command-parser
-		 (if interactor
-		     #'command-line-command-parser
-		     #'menu-command-parser)))
+	    (or command-parser
+		(if interactor
+		    #'command-line-command-parser
+		  #'menu-command-parser)))
 	   (*command-unparser*
-	     (or command-unparser 
-		 #'command-line-command-unparser))
+	    (or command-unparser 
+		#'command-line-command-unparser))
 	   (*partial-command-parser* 
-	     (or partial-command-parser
-		 (if interactor
-		     #'command-line-read-remaining-arguments-for-partial-command
-		     #'menu-read-remaining-arguments-for-partial-command)))
+	    (or partial-command-parser
+		(if interactor
+		    #'command-line-read-remaining-arguments-for-partial-command
+		  #'menu-read-remaining-arguments-for-partial-command)))
 	   (command-stream
-	     ;;--- We have to ask the frame since we do not want to
-	     ;;--- just pick up a stream from the dynamic environment
-	     (let ((si (or (frame-standard-input frame)
-			   (frame-standard-output frame))))
-	       (typecase si
-		 (output-protocol-mixin si)
-		 (t (frame-top-level-sheet frame))))))
+	    ;;--- We have to ask the frame since we do not want to
+	    ;;--- just pick up a stream from the dynamic environment
+	    (let ((si (or (frame-standard-input frame)
+			  (frame-standard-output frame))))
+	      (typecase si
+		(output-protocol-mixin si)
+		(t (frame-top-level-sheet frame))))))
       ;; The read-eval-print loop for applications...
-      (loop
-	;; Redisplay all the panes
-	(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
-	  (redisplay-frame-panes frame)
-	  (when interactor
-	    (fresh-line *standard-input*)
-	    (if (stringp prompt)
-		(write-string prompt *standard-input*)
-		(funcall prompt *standard-input* frame)))
-	  (let ((command (read-frame-command frame :stream command-stream)))
+      (letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*))
+	(loop
+	  ;; Redisplay all the panes
+	  (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
+	    (redisplay-frame-panes frame)
 	    (when interactor
-	      (terpri *standard-input*))
-	    ;; Need this check in case the user aborted out of a command menu
-	    (when command
-	      (execute-frame-command frame command))))))))
+	      (fresh-line *standard-input*)
+	      (if (stringp prompt)
+		  (write-string prompt *standard-input*)
+		(funcall prompt *standard-input* frame)))
+	    (let ((command (read-frame-command frame :stream command-stream)))
+	      (when interactor
+		(terpri *standard-input*))
+	      ;; Need this check in case the user aborted out of a command menu
+	      (when command
+		(execute-frame-command frame command)))))))))
 
 ;; Generic because someone might want :BEFORE or :AFTER
 (defmethod frame-exit ((frame standard-application-frame))
@@ -1207,10 +1209,15 @@
 (defmethod execute-frame-command ((frame standard-application-frame) command)
   (apply (command-name command) (command-arguments command)))
 
+(defmethod command-defined-p ((frame standard-application-frame) command)
+  (or (not (symbolp command))
+      (fboundp command)))
+
 (defmethod command-enabled (command-name (frame standard-application-frame))
   (with-slots (disabled-commands) frame
     (or *assume-all-commands-enabled*
-	(and (not (member command-name disabled-commands))
+	(and (command-defined-p frame command-name)
+	     (not (member command-name disabled-commands))
 	     (command-accessible-in-command-table-p
 	       command-name (frame-command-table frame))))))
 
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index b69d40fe..c9c491b5 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.49 93/05/13 16:23:07 cer Exp $
+;; $fiHeader: gadget-output.lisp,v 1.50 1993/05/13 16:28:50 colin Exp $
 
 (in-package :clim-internals)
 
@@ -356,7 +356,8 @@
 				:value-changed-callback
 				  (make-accept-values-value-changed-callback
 				    stream query-identifier)
-				:active active-p)))))
+				:active active-p
+				:help-callback (make-gadget-help type))))))
 	  (values (if radio-box-label
 		      (outlining ()
 			(vertically ()
@@ -445,7 +446,8 @@
 				       :value-changed-callback
 				         (make-accept-values-value-changed-callback
 					   stream query-identifier)
-				       :active active-p)))))
+				       :active active-p
+				       :help-callback (make-gadget-help type))))))
 	(values (if check-box-label
 		    (outlining ()
 		      (vertically ()
@@ -489,7 +491,8 @@
 		      :value-changed-callback
 		        (make-accept-values-value-changed-callback
 			 stream query-identifier)
-		      :active active-p)))
+		      :active active-p
+		      :help-callback (make-gadget-help type))))
  	(values (outlining () button) button)))))
 
 
@@ -547,7 +550,8 @@
 			 (make-accept-values-value-changed-callback
 			   stream query-identifier))
 		  :active active-p
-		  :editable-p editable-p)))
+		  :editable-p editable-p
+		  :help-callback (make-gadget-help type))))
 	  (values (outlining () slider) slider))))))
 
 (define-presentation-method accept-present-default 
@@ -599,7 +603,8 @@
 			 (make-accept-values-value-changed-callback
 			   stream query-identifier))
 		  :active active-p
-		  :editable-p editable-p)))
+		  :editable-p editable-p
+		  :help-callback (make-gadget-help type))))
 	  (values (outlining () slider) slider))))))
 
 
@@ -663,7 +668,8 @@
 			    (and editable-p
 				 `(accept-values-string-field-changed-callback
 				    ,stream ,query-identifier))
-			  :active active-p)))
+			    :active active-p
+			    :help-callback (make-gadget-help type))))
  	(values text-field text-field)))))
 
 (defmethod accept-values-note-text-field-changed-callback
@@ -687,8 +693,12 @@
 	  ;; correctly (see tk-silica/ol-gadgets)
 	  (assert (= index (length new-value)))
 	  object)
-	(error () 
-	 (setf (accept-values-query-error-p query) t))
+	(error (c) 
+	  (setf (accept-values-query-error-p query) c)
+	  (let ((frame (pane-frame stream)))
+	    (unless (typep *application-frame* 'accept-values)
+	      (verify-queries-1 frame stream (list query))
+	      (setf (accept-values-query-changed-p query) nil))))
 	(:no-error (object)
 	 (setf (accept-values-query-error-p query) nil)
 	 (do-avv-command object stream query))))))
@@ -734,7 +744,8 @@
 				 (make-accept-values-value-changed-callback
 				   stream query-identifier))
 			  :active active-p
-			  :editable-p editable-p)))
+			  :editable-p editable-p
+			  :help-callback (make-gadget-help type))))
  	(values (scrolling () text-field) text-field)))))
 
 
@@ -786,7 +797,8 @@
 			 :value-changed-callback
 			   (make-accept-values-value-changed-callback
 			    stream query-identifier)
-			 :active active-p)
+			 :active active-p
+			 :help-callback (make-gadget-help type))
 		       (make-pane-from-view pane-type view
 			 :items sequence
 			 :name-key name-key
@@ -799,7 +811,8 @@
 			 :value-changed-callback
 			   (make-accept-values-value-changed-callback
 			     stream query-identifier)
-			 :active active-p))))
+			 :active active-p
+			 :help-callback (make-gadget-help type)))))
 	(values (if (eq pane-type 'list-pane) (scrolling () pane) pane)
 		pane)))))
 
@@ -842,3 +855,8 @@
 
 (defmethod sheet-disown-child ((stream standard-encapsulating-stream) child)
   (sheet-disown-child (encapsulating-stream-stream stream) child))
+
+;;
+
+(defun make-gadget-help (ptype)
+  `(make-help-from-presentation-type ,ptype))
diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp
index a525ff46..43427a1c 100644
--- a/clim/input-defs.lisp
+++ b/clim/input-defs.lisp
@@ -1,6 +1,6 @@
 M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-defs.lisp,v 1.17 93/03/19 09:43:36 cer Exp $
+;; $fiHeader: input-defs.lisp,v 1.18 1993/05/05 01:38:30 cer Exp $
 
 (in-package :clim-internals)
 
@@ -80,7 +80,7 @@ M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10
 (defun sheets-nearest-common-ancestor (sheet1 sheet2)
   (if (eq sheet1 sheet2) 
       sheet1
-    (do ((sheet sheet1 (sheet-parent sheet1)))
+    (do ((sheet sheet1 (sheet-parent sheet)))
 	((null sheet))
       (when (sheet-ancestor-p sheet2 sheet)
 	(return sheet)))))
diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp
index de0ae8c9..8b727509 100644
--- a/clim/interactive-protocol.lisp
+++ b/clim/interactive-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: interactive-protocol.lisp,v 1.26 93/05/13 16:23:19 cer Exp $
+;; $fiHeader: interactive-protocol.lisp,v 1.27 1993/05/13 16:29:07 colin Exp $
 
 (in-package :clim-internals)
 
@@ -1025,7 +1025,7 @@
   (declare (ignore framem frame))
   ;;-- Yuck but think of a better way
   (let ((old-help *accept-help*))
-    (if (typep (encapsulating-stream-stream stream) 'accept-values-pane)
+    (if (typep (encapsulating-stream-stream stream) '(or accept-values-pane accept-values-stream))
 	(accepting-values (stream :exit-boxes '(:exit)
 				  :label "Input editor help"
 				  :own-window t)
diff --git a/clim/menus.lisp b/clim/menus.lisp
index 1f526375..96dd7512 100644
--- a/clim/menus.lisp
+++ b/clim/menus.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: menus.lisp,v 1.43 93/04/16 09:44:55 cer Exp $
+;; $fiHeader: menus.lisp,v 1.44 1993/05/05 01:38:44 cer Exp $
 
 (in-package :clim-internals)
 
@@ -619,3 +619,86 @@
 		 (return-from menu-choose
 		   (values (menu-item-value item) item gesture)))))))))
 
+
+
+;;; This is too useful to simply omit
+
+(define-application-frame open-window-stream-frame ()
+  ((type :initarg :type)
+   (scroll-bars :initarg :scroll-bars) 
+   (borders :initarg :borders)
+   stream
+   pane)
+  (:command-definer nil)
+  (:menu-bar nil)
+  (:pane
+   (with-slots (pane stream type scroll-bars borders) *application-frame*
+     (multiple-value-setq (pane stream)
+       (make-clim-stream-pane
+	:type type
+	:scroll-bars scroll-bars
+	:borders borders))
+     pane)))
+
+(defun open-window-stream (&key (left nil leftp)
+				(top nil topp)
+				(right nil rightp)
+				(bottom nil bottomp) 
+				width height
+				(foreground +black+) (background +white+)
+				text-style default-text-style
+				(vertical-spacing 2)
+				(end-of-line-action :allow)
+				(end-of-page-action :allow)
+				output-record (draw t) (record t)
+				(initial-cursor-visibility :off)
+				text-margin default-text-margin
+				save-under input-buffer
+				(scroll-bars :vertical) borders label
+				(type 'application-pane)
+				parent)
+  (declare (ignore save-under))
+  (when (or width height)
+    (assert (and (null right) (null bottom))))
+  (when (null left) (setq left 0))
+  (when (null top)  (setq top 0))
+  (when (or (null width) (null height))
+    (if (or (null right) (null bottom))
+	(setq width 100
+	      height 100)
+	(setq width (- right left)
+	      height (- bottom top))))
+  (let* ((frame (make-application-frame 'open-window-stream-frame
+					:resize-frame t
+					:pretty-name label
+					:type  type
+					:scroll-bars scroll-bars
+					:borders  borders
+					:input-buffer input-buffer
+					:frame-manager
+					(etypecase parent
+					  ((or pane standard-application-frame) 
+					   (frame-manager parent))
+					  (frame-manager parent)
+					  (null (find-frame-manager)))))
+	 (stream (slot-value frame 'stream)))
+    (setf (medium-foreground stream) foreground
+	  (medium-background stream) background
+	  (medium-default-text-style stream) (or default-text-style *default-text-style*)
+	  (medium-text-style stream) (or text-style *default-text-style*)
+	  (stream-vertical-spacing stream) vertical-spacing
+	  (stream-end-of-line-action stream) end-of-line-action
+	  (stream-end-of-page-action stream) end-of-page-action
+	  (stream-recording-p stream) record
+	  (stream-drawing-p stream) draw
+	  (cursor-visibility (stream-text-cursor stream)) initial-cursor-visibility
+	  (stream-text-margin stream) text-margin
+	  (stream-default-text-margin stream) default-text-margin)
+    (when output-record
+      (stream-output-history stream) (make-instance output-record))
+    (window-set-inside-size stream width height)
+    (window-set-viewport-position stream 0 0)
+    (when (or leftp topp rightp bottomp)
+      (position-sheet-carefully
+       (frame-top-level-sheet (pane-frame stream)) left top))
+    stream))
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index ab598402..2c09c54a 100644
--- a/clim/recording-protocol.lisp
+++ b/clim/recording-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: recording-protocol.lisp,v 1.32 93/04/07 09:06:50 cer Exp $
+;; $fiHeader: recording-protocol.lisp,v 1.33 1993/05/05 01:38:56 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1150,25 +1150,44 @@
 	    (replay text-output-record stream region)))))))
 
 (defmethod erase-output-record (record (stream output-recording-mixin) &optional (errorp t))
-  (let ((parent (output-record-parent record)))
-    (multiple-value-bind (xoff yoff)
-	(convert-from-relative-to-absolute-coordinates stream parent)
-      (with-bounding-rectangle* (left top right bottom) record
-	(with-output-recording-options (stream :record nil)
-	  (if (or (= left right) (= top bottom))
-	      ;; Handle specially, since a thin line is wider than a
-	      ;; rectangle of zero width or height
-	      (draw-line-internal stream xoff yoff
-				  left top right bottom
-				  +background-ink+ nil)
-	      (draw-rectangle-internal stream xoff yoff
-				       left top right bottom
-				       +background-ink+ nil)))))
-    (when parent
-      (delete-output-record record parent errorp))
-    ;; Use the output record itself as the replay region, and replay
-    ;; the stuff that might have been obscured by the erased output
-    (frame-replay *application-frame* stream record)))
+  (macrolet ((draw-it ()
+	       `(if (or (= left right) (= top bottom))
+		    ;; Handle specially, since a thin line is wider than a
+		    ;; rectangle of zero width or height
+		    (draw-line-internal stream xoff yoff
+					left top right bottom
+					+background-ink+ nil)
+		  (draw-rectangle-internal stream xoff yoff
+					   left top right bottom
+					   +background-ink+ nil))))
+    (if (listp record)
+	(let ((replay-region +nowhere+))
+	  (with-output-recording-options (stream :record nil)
+	    (dolist (record record)
+	      (let ((parent (output-record-parent record)))
+		(multiple-value-bind (xoff yoff)
+		    (convert-from-relative-to-absolute-coordinates stream parent)
+		  (with-bounding-rectangle* (left top right bottom) record
+		    (draw-it)
+		    (when parent
+		      (delete-output-record record parent errorp))
+		    (translate-coordinates xoff yoff left top right bottom)
+		    (setq replay-region
+		      (region-union
+		       replay-region
+		       (make-bounding-rectangle left top right bottom))))))))
+	  (frame-replay *application-frame* stream replay-region))
+      (let ((parent (output-record-parent record)))
+	(multiple-value-bind (xoff yoff)
+	    (convert-from-relative-to-absolute-coordinates stream parent)
+	  (with-bounding-rectangle* (left top right bottom) record
+	    (with-output-recording-options (stream :record nil)
+	      (draw-it))))
+	(when parent
+	  (delete-output-record record parent errorp))
+	;; Use the output record itself as the replay region, and replay
+	;; the stuff that might have been obscured by the erased output
+	(frame-replay *application-frame* stream record)))))
 
 (defmethod invoke-with-output-recording-options ((stream output-recording-mixin)
 						 continuation record draw)
diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp
index 3bfb6df8..9c0e2fbe 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.27 93/03/19 09:43:48 cer Exp $
+;; $fiHeader: standard-types.lisp,v 1.28 1993/05/13 16:23:22 cer Exp $
 
 (in-package :clim-internals)
 
@@ -614,7 +614,7 @@
   (let ((position 0)
 	(last (1- (length sequence))))
     (map nil #'(lambda (item)
-		 (write-string (funcall name-key item) stream)
+		 (funcall printer (funcall name-key item) stream)
 		 (unless (= position last)
 		   (write-string (if (= last 1) " " ", ") stream)
 		   (when (= (incf position) last)
diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp
index 0bf65ea1..4dc14cea 100644
--- a/clim/view-defs.lisp
+++ b/clim/view-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: view-defs.lisp,v 1.11 92/09/24 09:39:33 cer Exp Locker: cer $
+;; $fiHeader: view-defs.lisp,v 1.12 92/10/28 08:19:42 cer Exp $
 
 (in-package :clim-internals)
 
@@ -64,6 +64,8 @@
 
 (define-gadget-view toggle-button)
 
+(define-gadget-view push-button)
+
 (define-gadget-view radio-box)
 (define-gadget-view check-box)
 
diff --git a/demo/cload-demos.lisp b/demo/cload-demos.lisp
index edb23ca3..a86487e6 100644
--- a/demo/cload-demos.lisp
+++ b/demo/cload-demos.lisp
@@ -20,9 +20,9 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: cload-demos.lisp,v 1.4 92/10/07 14:43:20 cer Exp Locker: cer $
+;; $fiHeader: cload-demos.lisp,v 1.5 92/10/12 17:54:30 cer Exp $
 
-(in-package :user)
+(in-package :clim-user)
 
 (defvar *demo-files* 
     '(
diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp
index 6aa5e9a2..5c93659a 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.18 93/04/27 14:35:44 cer Exp $
+;; $fiHeader: graphics-editor.lisp,v 1.19 93/04/27 15:49:36 cer Exp $
 
 (in-package :clim-graphics-editor)
 
@@ -262,7 +262,7 @@
 				   graphics-editor-edit-commands
 				   graphics-editor-option-commands)
 		    :inherit-menu :keystrokes
-		    :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F)
+		    :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F :documentation "File commands")
 			   ("Edit" :menu graphics-editor-edit-commands :mnemonic #\E )
 			   ("Options" :menu graphics-editor-option-commands :mnemonic #\O))))
   (:pointer-documentation t)
@@ -305,10 +305,15 @@
 
 ;;; Presentation types
 
-(define-presentation-type-abbreviation line-thickness ()
-  '((member 1 2 3 4) :name-key identity
-		     :printer present-line-thickness
-		     :highlighter highlight-line-thickness))
+(define-presentation-type line-thickness ()
+    :inherit-from `((completion (1 2 3 4))
+		    :name-key identity
+		    :printer present-line-thickness
+		    :highlighter highlight-line-thickness))
+
+(define-presentation-method describe-presentation-type ((type line-thickness) stream plural-count)
+  (declare (ignore plural-count))
+  (write-string  "Specify one of four line thicknesses" stream))
 
 (defun present-line-thickness (object stream &key acceptably)
   (declare (ignore acceptably))
@@ -323,10 +328,15 @@
   (surrounding-output-with-border (stream)
     (funcall continuation object stream)))
 
-(define-presentation-type-abbreviation line-style-type ()
-  '((member :solid :dashed) :name-key identity
-			    :printer present-line-style
-			    :highlighter highlight-line-style))
+(define-presentation-type line-style-type ()
+    :inherit-from `((completion (:solid :dashed))
+		    :name-key identity
+		    :printer present-line-style
+		    :highlighter highlight-line-style))
+
+(define-presentation-method describe-presentation-type ((type line-style-type) stream plural-count)
+  (declare (ignore plural-count))
+  (write-string  "Specify solid or dashed line style" stream))
 
 (defun present-line-style (object stream &key acceptably)
   (declare (ignore acceptably))
@@ -347,6 +357,16 @@
 			      :printer present-object-shape
 			      :highlighter highlight-object-shape))
 
+(define-presentation-type object-shape ()
+    :inherit-from `((completion (:oval :rectangle))
+		    :name-key identity
+		    :printer present-object-shape
+		    :highlighter highlight-object-shape))
+
+(define-presentation-method describe-presentation-type ((type object-shape) stream plural-count)
+  (declare (ignore plural-count))
+  (write-string  "Specify rectangle or oval shape" stream))
+
 (defun present-object-shape (object stream &key acceptably)
   (declare (ignore acceptably))
   (let ((y (stream-line-height stream)))
@@ -505,7 +525,9 @@
 ;; Deselect an object by clicking the Deselect menu button, or by
 ;; clicking over blank area without moving the mouse.
 (define-command (com-deselect-object :command-table graphics-editor-edit-commands
-				     :menu "Deselect") ()
+				     :menu ("Deselect"
+					    :documentation "Deselect all objects")) 
+    ()
   (when (frame-selected-object *application-frame*)
     (deselect-object *application-frame* (frame-selected-object *application-frame*))))
 
@@ -565,7 +587,10 @@
 	(move-handle handle (- x dx) (- y dy))))))
 
 ;; OK, I added a menu button to clear the window.
-(define-command (com-clear :command-table graphics-editor-edit-commands :menu t) nil
+(define-command (com-clear :command-table
+			   graphics-editor-edit-commands 
+			   :menu ("Clear" :documentation "Clear all graphics"))
+    ()
   (with-slots (objects selected-object last-box) *application-frame*
     (setq objects nil
 	  selected-object nil
@@ -575,15 +600,21 @@
 ;; OK, I added a menu button to redisplay the window, too, although
 ;; it's only here for debugging.
 (define-command (com-redisplay :command-table graphics-editor-edit-commands 
-			       :keystroke (:r :meta) :menu t) ()
+			       :keystroke (:r :meta) 
+			       :menu  ("Redisplay" :documentation "Redisplay windows"))
+    ()
   (redisplay-frame-pane *application-frame* 'display :force-p t))
 
 (define-command (com-quit :command-table graphics-editor-file-commands
-			  :keystroke (:x :meta) :menu t) ()
+			  :keystroke (:x :meta) 
+			  :menu ("Quit" :documentation "Quit application")) ()
   (frame-exit *application-frame*))
 
 (define-command (com-change-layout :command-table graphics-editor-option-commands 
-				   :keystroke (:l :meta) :menu t) ()
+				   :keystroke (:l :meta) 
+				   :menu ("Change application layout"
+					  :documentation "Change layout"))
+    ()
   (let ((layouts (frame-all-layouts *application-frame*)))
     (setf (frame-current-layout *application-frame*)
 	  (or (second (member (frame-current-layout *application-frame*) layouts))
diff --git a/misc/climgccursor.c b/misc/climgccursor.c
index 479feaf1..0e6e2095 100644
--- a/misc/climgccursor.c
+++ b/misc/climgccursor.c
@@ -1,7 +1,6 @@
 #include <X11/Intrinsic.h>
 #include <X11/StringDefs.h>
 #include <signal.h>
-#include <stdio.h>
 
 
 static Widget gc_widget = (Widget)NULL;
@@ -26,8 +25,6 @@ int cursor;
 
 	    if (XFindContext(display, root, context, &font_cursor)) {
 		font_cursor = XCreateFontCursor(display, cursor);
-		fprintf(stderr, "Making cursor\n");
-		fflush(stderr);
 		XSaveContext(display, root, context, font_cursor);
 	    }
 	    return (font_cursor);
@@ -73,8 +70,6 @@ Widget client_data;
 int *call_data;
 {
     if (gc_widget == client_data) {
-	fprintf(stderr, "Removing gc cursor\n");
-	fflush(stderr);
 	gc_widget = 0;
     }
 }
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index a0bdfabb..ff5c7d70 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.21 93/04/02 13:36:29 cer Exp $
+;; $fiHeader: compile-1.lisp,v 1.22 93/04/23 09:18:00 cer Exp $
 
 (in-package :user)
 
@@ -71,6 +71,8 @@
 
   (compile-file-if-needed "test/test-suite")
 
+  (load "test/test-suite")
+  
   (load "demo/sysdcl")
   (clim-defsys::compile-system 'clim-demo :propagate t)
   (clim-defsys::load-system 'clim-demo)
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index d3b2d21f..8fb1be95 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.26 93/04/23 09:18:01 cer Exp $
+;; $fiHeader: dev-load-1.lisp,v 1.27 1993/05/05 01:39:30 cer Exp $
 
 ;;;; This should not matter
 ;;;; (setq *ignore-package-name-case* t)
@@ -70,7 +70,12 @@
 
      (clim-defsys::load-system 'clim-demo)
 
-     (ignore-errors (tenuring (require :composer)))
+     (ignore-errors 
+      (tenuring 
+       (let ((*default-pathname-defaults* #P"/hyper/qa/4.2.beta2.0/solaris1/lib/code/"))
+	 (require :composer)
+	 (set (intern '#:*clm-binary-directory* :xtk)
+	      #P"/hyper/qa/4.2.beta2.0/solaris1/lib/"))))
 
      (dolist (file '("test/test-driver"
 		     "test/test-clim"
@@ -86,7 +91,11 @@
      (clim-defsys::fake-load-system (cons sys '(postscript-clim 
 				 clim-toys
 				 clim-demo)) :recurse t)
-				 
+     
+;     (warn "Loading patch file")
+;     (load "/net/vapor/usr/tech/cer/patches/clos-precache.fasl"
+;	   :if-does-not-exist nil)
+
      (ignore-errors
       (load (case sys
 	      (motif-clim "misc/clos-preloadxm.fasl")
diff --git a/misc/undefinedsymbols.motif b/misc/undefinedsymbols.motif
index 67d0199b..84f33249 100644
--- a/misc/undefinedsymbols.motif
+++ b/misc/undefinedsymbols.motif
@@ -8,7 +8,7 @@ XmFontListGetNextFont
 XmFontListCreate
 XmAddProtocolCallback
 XmInternAtom
-XmIsTraverable
+XmIsTraversable
 XmMainWindowSetAreas
 XmProcessTraversal
 XmMessageBoxGetChild
diff --git a/misc/undefinedsymbols.xt b/misc/undefinedsymbols.xt
index b65c48f7..a02db064 100644
--- a/misc/undefinedsymbols.xt
+++ b/misc/undefinedsymbols.xt
@@ -38,3 +38,5 @@ XtUngrabPointer
 XtUnmanageChild
 XtUnmanageChildren
 XtWindow
+XtParseTranslationTable
+XtParseAcceleratorTable
diff --git a/notes/profiles/.cvsignore b/notes/profiles/.cvsignore
new file mode 100755
index 00000000..7dd20dfb
--- /dev/null
+++ b/notes/profiles/.cvsignore
@@ -0,0 +1 @@
+*.*-profile.lisp
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index b7f8e2ab..132d5563 100644
--- a/silica/db-scroll.lisp
+++ b/silica/db-scroll.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-scroll.lisp,v 1.43 93/03/19 09:44:39 cer Exp $
+;; $fiHeader: db-scroll.lisp,v 1.44 1993/05/05 01:39:41 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -97,12 +97,12 @@
 	      (update-scroll-bar vertical-scroll-bar
 				 top bottom 
 				 vtop vbottom
-				 (line-scroll-amount scroller :vertical nil)))
+				 :vertical))
 	    (when horizontal-scroll-bar
 	      (update-scroll-bar horizontal-scroll-bar
 				 left right 
 				 vleft vright
-				 (line-scroll-amount scroller :horizontal  nil)))))))))
+				 :horizontal))))))))
 
 (defmethod note-sheet-grafted :before ((sheet scroll-bar))
   (setf (scroll-bar-current-size sheet) nil))
@@ -110,7 +110,7 @@
 ;;--- In the case where the viewport is bigger than the window this
 ;;--- code gets things wrong.  Check out the thinkadot demo.  It's
 ;;--- because (- (--) (- vmin)) is negative.
-(defun update-scroll-bar (scroll-bar min max vmin vmax line-scroll)
+(defun update-scroll-bar (scroll-bar min max vmin vmax orientation)
   (declare (optimize (safety 0) (speed 3)))
   ;;-- Is this really the right thing to do?
   ;;-- If in an interactor some draws at -ve coordinates but the
@@ -137,28 +137,19 @@
 			(the single-float
 			  (if (= max min)
 			      1.0
-			      (min 1.0 (the single-float
-					 (/ viewport-range contents-range))))))))
+			    (min 1.0 (the single-float
+				       (/ viewport-range contents-range))))))))
 	     ;;-- This does not scale by the range
 	     (pos (the single-float
 		    (min 1.0s0 (max 0.0s0
 				    (if (<= contents-range viewport-range)
 					0.0
-					(/ (float (- vmin min) 0.0s0) 
-					   ;;--- Uh-oh, the home-grown scroll bars
-					   ;;--- seem to have a different contract
-					   ;;--- from Motif/OpenLook.  Fix them!
-					   #+Allegro (- contents-range viewport-range)
-					   #-Allegro contents-range))))))
-	     (line-scroll #+ignore
-			  (* range (/ line-scroll viewport-range))
-			  (if (zerop contents-range)
-			      0 ;-- Who knows
-			    (* range (/ line-scroll contents-range)))
-			  #+ignore
-			  (if (< contents-range viewport-range)
-			      0 ;-- Who knows
-			    (* range (/ line-scroll (- contents-range viewport-range))))))
+				      (/ (float (- vmin min) 0.0s0) 
+					 ;;--- Uh-oh, the home-grown scroll bars
+					 ;;--- seem to have a different contract
+					 ;;--- from Motif/OpenLook.  Fix them!
+					 #+Allegro (- contents-range viewport-range)
+					 #-Allegro contents-range)))))))
 	(declare (type single-float pos size))
 	(unless (and current-size
 		     current-value
@@ -166,10 +157,15 @@
 		     (= current-value pos))
 	  (setf (scroll-bar-current-value scroll-bar) pos)
 	  (setf (scroll-bar-current-size scroll-bar) size)
-	  (change-scroll-bar-values scroll-bar 
-				    :slider-size size
-				    :value pos
-				    :line-increment line-scroll))))))
+	  ;;-- It would be nice if we could do this at the point of scrolling
+	  (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client) orientation nil))
+		 (line-scroll (if (zerop contents-range)
+				  0 ;-- Who knows
+				(* range (/ line-scroll contents-range)))))
+	    (change-scroll-bar-values scroll-bar 
+				      :slider-size size
+				      :value pos
+				      :line-increment line-scroll)))))))
 
 (defmethod scroll-bar-value-changed-callback
 	   (sheet (client scroller-pane) id value size)
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 39703116..93f37da5 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.51 1993/05/05 01:39:49 cer Exp $
+;; $fiHeader: gadgets.lisp,v 1.52 1993/05/13 16:24:04 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -17,7 +17,10 @@
 		     :reader gadget-armed-callback)
      (disarmed-callback :initarg :disarmed-callback :initform nil
 			:reader gadget-disarmed-callback)
-     (active :initarg :active :accessor gadget-active-p))
+     (active :initarg :active :accessor gadget-active-p)
+     (help-callback :initform nil 
+		    :initarg :help-callback 
+		    :accessor gadget-help-callback))
   (:default-initargs :active t))
 
 ;;; Arming and disarming
@@ -733,3 +736,9 @@
 
 (defmethod handle-event ((gadget focus-gadget) (event focus-in-gadget-event))
   (focus-in-callback gadget (gadget-client gadget) (gadget-id gadget)))
+
+(defun move-focus-to-gadget (gadget)
+  (port-move-focus-to-gadget (port gadget) gadget))
+
+(defmethod port-move-focus-to-gadget ((port t) (gadget t))
+  nil)
diff --git a/silica/macros.lisp b/silica/macros.lisp
index ec32d092..3d79bceb 100644
--- a/silica/macros.lisp
+++ b/silica/macros.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: macros.lisp,v 1.13 92/08/18 17:23:48 cer Exp $
+;; $fiHeader: macros.lisp,v 1.14 92/09/24 09:37:45 cer Exp $
 
 (in-package :silica)
 
@@ -43,10 +43,13 @@
     (setq frame `*application-frame*))
   `(flet ((make-pane (pane-class &rest pane-options)
 	    (declare (dynamic-extent pane-options))
-	    (apply #'make-pane-1 
-		   ,frame-manager ,frame pane-class pane-options)))
-     (declare (dynamic-extent #'make-pane))
-     #'make-pane			;prevent spurious compiler warnings
+	    (apply #'make-pane-1 ,frame-manager ,frame pane-class pane-options))
+	  (make-clim-stream-pane (&rest pane-options)
+	    (declare (dynamic-extent pane-options))
+	    (apply #'clim-internals::make-clim-stream-pane-1 ,frame-manager ,frame pane-options)))
+     (declare (dynamic-extent #'make-pane #'make-clim-stream-pane))
+     #'make-pane		;prevent spurious compiler warnings
+     #'make-clim-stream-pane
      ,@forms))
 
 #+Genera (zwei:defindentation (make-pane 1 1))
@@ -55,3 +58,7 @@
   (warn "~S not inside a call to ~S"
 	'make-pane 'with-look-and-feel-realization))
 
+(defun make-clim-stream-pane (&rest pane-options)
+  (declare (ignore pane-options))
+  (warn "~S not inside a call to ~S"
+	'make-clim-stream-pane 'with-look-and-feel-realization))
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index 902fc3cb..93173631 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.35 93/02/08 15:57:40 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.36 93/03/18 14:38:23 colin Exp $
 
 (in-package :silica)
 
@@ -498,3 +498,4 @@
 	   ((port basic-port) (sheet basic-sheet) cursor)
   (declare (ignore cursor))
   nil)
+
diff --git a/test/test-clim.lisp b/test/test-clim.lisp
index afd9037e..a150ed4d 100644
--- a/test/test-clim.lisp
+++ b/test/test-clim.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: test-clim.lisp,v 1.5 1993/05/05 01:40:05 cer Exp $
+;; $fiHeader: test-clim.lisp,v 1.6 1993/05/13 16:24:16 cer Exp $
 
 
 (in-package :clim-user)
@@ -57,7 +57,7 @@
 
 (define-command-sequence clim-tests-commands
     (com-draw-some-bezier-curves)
-    (:commands do-avv-test)
+  (:commands do-avv-test)
   (com-input-editor-tests)
   "This is (sexp) and a string"
   :ie-backward-character
@@ -97,18 +97,20 @@
   (:presentation-click display-pane integer)
   (:presentation-click display-pane integer)
   :abort
-  
-  (com-read-image-test)
+  )
+
+
+(define-frame-test more-clim-tests (clim-tests 
+				    :width 600 :height 600)
+  ((com-read-image-test)
    
   (com-filled-output)
+  (:presentation-click display-pane string)
    
   ;; This would be nice but moving to the top right of the
   ;; presentation does not work when they are circular!
   ;; (com-ordering-test-1)
   ;; (:presentation-click display-pane integer)
-
-
-  (:presentation-click display-pane string)
    
   (com-ordering-test-2a)
   (:presentation-click display-pane integer)
@@ -196,6 +198,9 @@
   (com-rotated-scaled-rectangles)
   (com-draw-some-rectangles))
 
+  (exit-clim-tests)
+  )
+
 (define-frame-test test-drag-and-drop (clim-tests 
 					       :width 600 :height 600  
 					       :history-class r-tree-output-history
@@ -508,15 +513,70 @@
 (push 'find-frame-manager-test *frame-tests*)
 
 (defun find-frame-manager-test ()
-  (handler-case (let ((fm (find-frame-manager)))
-		  (with-frame-manager (fm)
-		    (let ((*default-server-path* 
-			   `(,(if (excl::featurep :clim-motif)
-				  :motif :openlook)
-				:display "mysparc10:0")))
-		      (assert (eq fm (find-frame-manager))))))
-    (error (c)
-      (note-test-failed 'find-frame-manager-test c))
-    (:no-error (&rest ignore)
-      (declare (ignore ignore))
-      (note-test-succeeded 'find-frame-manager-test))))
+  (with-test-success-expected ('find-frame-manager-test)
+    (let ((fm (find-frame-manager)))
+      (with-frame-manager (fm)
+	(let ((*default-server-path* 
+	       `(,(if (excl::featurep :clim-motif)
+		      :motif :openlook)
+		    :display "mysparc10:0")))
+	  (assert (eq fm (find-frame-manager))))))))
+
+;;
+
+(push 'open-window-stream-test *frame-tests*)
+
+;; Stewart introduced bugs here......................
+
+(defun open-window-stream-test ()
+  (with-test-success-expected ('open-window-stream-test)
+    (let* (stream1 stream2 stream3)
+      (setq stream1 (open-window-stream :label "Fred" :scroll-bars :vertical))
+      (window-expose stream1)
+      (setq stream2 (open-window-stream :label "Joh" :scroll-bars :vertical :parent stream1))
+      (window-expose stream2)
+      (setq stream3 (open-window-stream :label "Joh" :scroll-bars :vertical :left 500 :top 500))
+      (window-expose stream3)
+      (sleep 10)
+      (setf (window-visibility stream1) nil
+	    (window-visibility stream2) nil
+	    (window-visibility stream3) nil))))
+
+
+;;
+
+(push 'multiple-value-setf-test *frame-tests*)
+
+(defun multiple-value-setf-test ()
+  (with-test-success-expected ('multiple-value-setf-test)
+    (let ((x (make-bounding-rectangle 0 0 10 10)))
+      (setf (bounding-rectangle* x)
+	(values 12 12 13 14)))))
+
+(push 'filling-output-on-plain-stream-test *frame-tests*)
+
+(defun filling-output-on-plain-stream-test ()
+  (with-test-success-expected ('filling-output-on-plain-stream-test)
+    (filling-output (*standard-output* :fill-width '(20 :character))
+      (write-string *gettysburg-address* *standard-output*))))
+
+
+
+(macrolet ((define-profile-clim-tests ()
+	       `(define-frame-test profile-clim-tests (clim-tests :width 600 :height 600)
+		  ,(mapcan #'(lambda (benchmark-group)
+			       (mapcar #'list (cdr benchmark-group)))
+			   *summary-contributions*)
+		  (exit-clim-tests))))
+  (define-profile-clim-tests))
+
+(push 'run-profile-clim-tests *frame-tests*)
+
+(defun run-profile-clim-tests ()
+  (let ((prof::*hidden-packages* nil)
+	(prof::*significance-threshold* 0.001)
+	(prof::*fractional-significance-threshold* .002))
+    (with-test-success-expected ('run-profile-clim-tests-time)
+      (do-frame-test-with-profiling 'profile-clim-tests  :type :time))
+    (with-test-success-expected ('run-profile-clim-tests-space)
+      (do-frame-test-with-profiling 'profile-clim-tests :type :space))))
diff --git a/test/test-driver.lisp b/test/test-driver.lisp
index 56a74013..73ae6ee6 100644
--- a/test/test-driver.lisp
+++ b/test/test-driver.lisp
@@ -122,13 +122,19 @@
      #'(lambda () (setq done (not (mp::process-stack-group process)))))
     done))
 
+(defvar *execute-one-command-hook* nil)
 
 (defun execute-commands-in-invocation (invocation commands)
   (do ((commands commands (cdr commands)))
       ((or (not (invocation-active-p invocation))
 	   (null commands)))
-    (execute-one-command invocation (car commands))
-    (wait-for-clim-input-state invocation)))
+    (let ((command (car commands)))
+      (flet ((do-it ()
+	       (execute-one-command invocation command)
+	       (wait-for-clim-input-state invocation)))
+	(if *execute-one-command-hook*
+	    (funcall *execute-one-command-hook* invocation command #'do-it)
+	  (do-it))))))
 
 (defvar *command-sequence-table* (make-hash-table))
 
@@ -190,6 +196,17 @@
 		    (wait-for-clim-input-state invocation timeout)))
 	      (execute-command-in-frame (or avv-frame (invocation-frame invocation)) command)))))))))
 
+(defmacro with-test-success-expected ((test-name) &body body)
+  (let ((tname (gensym)))
+    `(let ((,tname ,test-name))
+       (handler-case (progn ,@body)
+	 (error (c)
+	   (note-test-failed ,tname c))
+	 (:no-error (&rest ignore)
+	   (declare (ignore ignore))
+	   (note-test-succeeded ,tname))))))
+
+
 (defun exercise-frame (test-name class initargs commands exit-command 
 		       &key (error *catch-errors-in-tests*)
 			    (invocation-class 'frame-invocation))
@@ -205,12 +222,8 @@
 		 (warn "Process would not die when killed"))
 	       (destroy-invocation invocation)))))
     (if error
-	(handler-case (doit)
-	  (error (condition)
-	    (note-test-failed test-name condition))
-	  (:no-error (&rest ignore)
-	    (declare (ignore ignore))
-	    (note-test-succeeded test-name)))
+	(with-test-success-expected (test-name)
+	  (doit))
       (doit))))
 
 
@@ -665,6 +678,27 @@
 ;; How can we wait for a frame to be created. Grab hold of it and then
 ;; run some commands on it.
 
+(eval-when (compile load eval)
+  (require :prof))
+
+(defun do-frame-test-with-profiling (test &key (type :time))
+  (flet ((profiling-hook (invocation command continuation)
+	   ;;-- it would be nice to restrict it to the invocation process
+	   (if (or (atom command)
+		   (equal command '(exit-clim-tests)))
+	       (funcall continuation)
+	     (progn
+	       (unwind-protect
+		   (progn 
+		     (prof::start-profiler :type type :verbose nil)
+		     (funcall continuation))
+		 (profiler:stop-profiler))
+	       (with-open-file (*standard-output* (format nil "notes/profiles/~A.~A-profile.lisp" (car command) type)
+				:direction :output :if-exists :supersede)
+		 (prof:show-call-graph)
+		 (prof:show-flat-profile))))))
+    (let ((*execute-one-command-hook* #'profiling-hook))
+      (funcall test))))
 
 ;;; This should be at the end:
 ;;; make the training selective.
@@ -677,3 +711,4 @@
 ;; This stops warnings happening asynchronously and causing confusion.
 
 (setq excl:*global-gc-behavior* nil)
+
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index d6c15b39..b1feb392 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.63 93/05/13 16:24:24 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.63 1993/05/13 16:24:24 cer Exp $
 
 (in-package :clim-user)
 
@@ -776,7 +776,7 @@ people, shall not perish from the earth.
 (define-test (read-image-test graphics) (stream)
   "Test image reading code"
   (formatting-table (stream)
-    (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus"))
+    (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus" "calculator"))
       (formatting-row (stream)
 	(formatting-cell (stream)
 	  (write-string name stream))
@@ -1050,6 +1050,20 @@ people, shall not perish from the earth.
     (sleep 2)
     (window-refresh stream)))
 
+(define-test (multiple-erases output-recording) (stream)
+  "The four overlapping circles and a line and erase three of them"
+  (flet ((circle (x y r n)
+	   (with-output-as-presentation (stream  n 'integer)
+	     (draw-circle* stream x y r :ink (make-contrasting-inks 4 n)))))
+    (circle 100  50 40 1)
+    (let ((records (list 
+		    (circle  75 100 40 2)
+		    (circle 125 100 40 3)
+		    (circle 200 200 40 3))))
+      (draw-line* stream 100 50  200 200 :ink +white+)
+      (sleep 2)
+      (erase-output-record records stream))))
+
 
 ;;; Formatted output
 
@@ -1796,8 +1810,10 @@ Luke Luck licks the lakes Luke's duck likes."))
 (define-test (simple-menu menus-and-dialogs) (stream)
   "A simple test of MENU-CHOOSE."
   (write-string
-    (menu-choose '("Whistle"
-		   ("Pat head" :items
+    (menu-choose '(("Whistle" :documentation "Select whistle")
+		   ("Pat head" 
+		    :documentation "Pat head in various ways"
+		    :items
 		    (("with right hand" . "Pat head with right hand")
 		     ("with left hand" . "Pat head with left hand")))
 		   ("Rub Tummy" :items
@@ -2074,6 +2090,16 @@ Luke Luck licks the lakes Luke's duck likes."))
 	 (g (integer 0 10) :view '(slider-view :orientation :vertical)))
 	(terpri stream)))))
 
+(define-test (list-pane-dialog menus-and-dialogs) (stream)
+  "Various list panes"
+  (let ((x :a-one))
+    (accepting-values (stream)
+      (setf x (accept '(member :a-one :b-two :c-three :d-four)
+		      :stream stream
+		      :view +list-pane-view+
+		      :default x
+		      :prompt "Value for X")))))
+
 (define-test (readonly-gadget-dialog menus-and-dialogs) (stream)
   "Create a bunch of readonly gadgets"
   (accepting-values (stream :own-window nil :label "Gadgets dialog"
diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp
index cea90d8d..300f903c 100644
--- a/tk-silica/ol-frames.lisp
+++ b/tk-silica/ol-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-frames.lisp,v 1.23 93/04/08 13:18:52 colin Exp $
+;; $fiHeader: ol-frames.lisp,v 1.24 1993/05/13 16:31:25 colin Exp $
 
 
 (in-package :xm-silica)
@@ -77,7 +77,8 @@
 			      :managed nil))
 	 (menu (tk::get-values menu-shell :menu-pane))
 	 (font (and text-style (text-style-mapping (port framem) text-style)))
-	 (font-args (and font (list :font font))))
+	 (font-args (and font (list :font font)))
+	 (frame (pane-frame associated-window)))
 
     (let ((title (cond ((null label) "Choose")
 		       ((atom label) label)
@@ -121,13 +122,9 @@
 			   button
 			   #'tk::destroy-image image)
 			  button))))
-		 #+dunno
-		 (when (clim-internals::menu-item-documentation item)
-		   (tk::add-callback button 
-				 :help-callback 
-				 'display-motif-help
-				 port
-				 (clim-internals::menu-item-documentation item)))
+		 (add-documentation-callbacks
+		  frame button
+		  (clim-internals::menu-item-documentation item))
 		 button))
 	     (construct-menu-from-items (menu items)
 	       (map nil #'(lambda (item)
@@ -181,6 +178,8 @@
 		    (setf value-returned nil return-value nil)
 		  (values value-returned return-value))))))
 
+
+
 (defmethod framem-enable-menu ((framem openlook-frame-manager) menu)
   (tk::ol_menu_post menu))
 
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 6a413ac6..417d5d71 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.49 93/05/13 16:24:53 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.50 1993/05/13 16:31:32 colin Exp $
 
 
 (in-package :xm-silica)
@@ -325,8 +325,9 @@
   ;; submenus then it creates one with a menu of its own
   
   (let* ((mirror (call-next-method))
-	(text-style (pane-text-style sheet))
-	(font-list (list :font (text-style-mapping port text-style))))
+	 (text-style (pane-text-style sheet))
+	 (font-list (list :font (text-style-mapping port text-style)))
+	 (frame (pane-frame sheet)))
     (labels ((compute-options (item)
 	       (let ((text-style (getf (command-menu-item-options item) :text-style)))
 		 (if text-style
@@ -373,21 +374,6 @@
 			       (mapc #'tk::destroy-widget children)
 			       (make-command-for-command-table-1 mb item)))))
 		     
-		     ;;--- This does not get called.
-		     #+ignore
-		     (xt::add-callback 
-		      shell :popup-callback
-		      #'(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 
@@ -417,11 +403,15 @@
 			   )
 			  (:menu
 			   (make-command-for-command-table-1
-			      (apply #'make-instance 'tk::menu-button
-						     :parent parent
-						     :label menu
-						     (compute-options item))
-			      item))
+			    (let ((button
+				   (apply #'make-instance 'tk::menu-button
+					  :parent parent
+					  :label menu
+					  (compute-options item))))
+			      (add-documentation-callbacks 
+			       frame button (getf (command-menu-item-options item) :documentation))
+			      button) 
+			    item))
 
 			  (t
 			   (let ((button 
@@ -434,6 +424,10 @@
 							     (slot-value sheet 'silica::frame))
 						 (compute-options item))))
 			     
+			     (add-documentation-callbacks 
+			      frame button 
+			      (getf (command-menu-item-options item) :documentation))
+
 			     (when top
 			       (push (cons (car (command-menu-item-value item)) button)
 				     (menu-bar-command-name-to-button-table sheet)))
@@ -1488,11 +1482,11 @@
 
 
 
+
 ;;; 
 
 (defclass openlook-list-pane (list-pane xt-leaf-pane)
-	  ((item-list :accessor list-pane-item-list)
-	   (token-list :accessor list-pane-token-list)
+	  ((token-list :accessor list-pane-token-list)
 	   (current-tokens :initform nil :accessor list-pane-current-tokens)))
 
 
@@ -1502,8 +1496,10 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-list-pane))
-  (with-accessors () sheet
-    (values 'xt::ol-list nil)))
+  (with-accessors ((visible-items gadget-visible-items)
+		   (items set-gadget-items)) sheet
+    (values 'xt::ol-list 
+	    `(:view-height ,(max 1 (or visible-items (length items)))))))
 
 (defmethod realize-mirror :around ((port openlook-port) (sheet openlook-list-pane))
   (let ((widget (call-next-method)))
@@ -1512,7 +1508,7 @@
 
 
 (defun add-items-to-list-pane-widget (sheet widget)
-  (let ((item-list nil)
+  (let (
 	(token-list nil)
 	selected-tokens
 	(count 0)
@@ -1541,11 +1537,9 @@
 		  0
 		  x)))
 	    (push (list token count) token-list)
-	    (when selected-p (push token selected-tokens))
-	    (push x item-list))
+	    (when selected-p (push token selected-tokens)))
 	  (incf count)))
-      (setf (list-pane-item-list sheet) (nreverse item-list)
-	    (list-pane-token-list sheet) token-list
+      (setf (list-pane-token-list sheet) token-list
 	    (list-pane-current-tokens sheet) selected-tokens))))
 
 (defmethod (setf gadget-value) :after (new-value (gadget openlook-list-pane) &key invoke-callback)
@@ -1562,11 +1556,11 @@
 	    (setf (tk::ol-list-item-attr toolkit-item)
 	      (dpb (if selectedp 1 0)
 		   '#.tk::ol_b_list_attr_current
-		   (dpb position '#.tk::ol_b_list_attr_appl 0)))
+		   (dpb position '#.tk::ol_b_list_attr_appl (tk::ol-list-item-attr toolkit-item))))
 	    (touch-list-pane-item widget token)
-	    (when selectedp (push token-and-position selected-tokens))
-	    (setf (list-pane-current-tokens gadget)
-	      selected-tokens)))))))
+	    (when selectedp (push token selected-tokens)))))
+      (setf (list-pane-current-tokens gadget)
+	selected-tokens))))
 
 (defmethod (setf set-gadget-items) :after (items (gadget openlook-list-pane))
   (declare (ignore items))
@@ -1656,22 +1650,30 @@
 	       (vertical-margins (ceiling (* 2 4 (/ 90 72))))
 	       (horizontal-margins (ceiling (* (+ 6 8) (/ 90 72))))
 	       (vertical-spacing (ceiling (* 6 (/ 90 72))))
-	       (fudge 5)	; This seems to be necessary to make
+	       (fudge 6)	; This seems to be necessary to make
 				; the right number of items visible
-	       (item-max-length
+	       (item-max-width
 		(let ((max 0))
 		  (dolist (item items max)
-		    (maxf max (length (funcall name-key item))))))
+		    (maxf max (let ((string (funcall name-key item)))
+				(x11:xtextwidth
+				 font string (length string)))))))
 	       (height (+ (* (or visible-items (length items))
 			     (+ vertical-spacing (tk::font-height font)))
 			  vertical-margins
 		       fudge))
-	       (width (+ horizontal-margins
-			(* (tk::font-width font)
-			   item-max-length)
+	       (width (+ -5
+			 horizontal-margins
+			item-max-width
 			scroll-bar-width)))
 	  (make-space-requirement :width width :height height))))))
 
+(defmethod change-widget-geometry :after (parent (child tk::ol-list) &key width)
+  (declare (ignore parent))
+  (tk::set-values (tk::get-values child :list-pane) 
+		  :pref-max-width width
+		  :pref-min-width width))
+
 ;;;
 
 (defclass openlook-option-pane (option-pane xt-leaf-pane)
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index a9b286e3..e53c5cf6 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.55 93/04/23 09:18:45 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.56 93/04/27 14:36:09 cer Exp $
 
 (in-package :xm-silica)
 
@@ -125,7 +125,8 @@
 	 (text-style (pane-text-style sheet))
 	 (font-list (list :font-list (text-style-mapping port text-style)))
 	 (ct (menu-bar-command-table sheet))
-	 (flatp (flat-command-table-menu-p ct)))
+	 (flatp (flat-command-table-menu-p ct))
+	 (frame (pane-frame sheet)))
     (labels ((compute-options (item)
 	       (let ((text-style (getf (command-menu-item-options item) :text-style)))
 		 (if text-style
@@ -149,7 +150,7 @@
 		   (tk::remove-all-callbacks parent :map-callback)
 		   (tk::add-callback parent :map-callback
 				     #'update-menu-item-sensitivity 
-				     (pane-frame sheet)
+				     frame
 				     commands-and-buttons))))
 	     (make-submenu (parent menu item)
 	       (let* ((shell (make-instance 'xt::xm-menu-shell 
@@ -167,14 +168,19 @@
 					      :managed nil
 					      :parent shell
 					      :row-column-type :menu-pulldown))
-		      (cb (apply #'make-instance 'xt::xm-cascade-button-gadget
+		      (cb (apply #'make-instance 'xt::xm-cascade-button
 					 :parent parent
 					 :label-string menu
 					 :sub-menu-id submenu
 					 (compute-options item))))
 		 (unless flatp
 		   (set-button-mnemonic sheet
-					cb (getf (command-menu-item-options item) :mnemonic)))
+					cb (getf
+					    (command-menu-item-options
+					     item) :mnemonic)))
+
+		 (add-documentation-callbacks 
+		  frame cb (getf (command-menu-item-options item) :documentation))
 		 
 		 (let* ((ct (find-command-table (second item)))
 			(tick (slot-value ct 'clim-internals::menu-tick)))
@@ -244,6 +250,9 @@
 			       (push (list item button)
 				     commands-and-buttons)
 			       
+			       (add-documentation-callbacks 
+				frame button (getf (command-menu-item-options item) :documentation))
+
 			       (when flatp 
 				 (push (cons (car (command-menu-item-value item))
 					     button)
@@ -256,16 +265,9 @@
 			
 				 (set-button-mnemonic
 				  sheet
-				  button (getf (command-menu-item-options item) :mnemonic)))
-
-			       (when (getf (command-menu-item-options item) :documentation)
-				 (tk::add-callback
-				  button
-				  :help-callback
-				  'display-motif-help
-				  port
-				  (getf (command-menu-item-options
-					 item) :documentation)))
+				  button (getf
+					  (command-menu-item-options
+					   item) :mnemonic)))
 			       
 			       (tk::add-callback
 				button
@@ -281,10 +283,11 @@
 	 ct mirror (not flatp)))
     mirror))
 
-(defun display-motif-help (widget port documentation)
+(defun display-motif-help (widget framem documentation)
   (frame-manager-notify-user 
-   (find-frame-manager :port port)		;--- frame manager should be passed in
+   framem
    documentation
+   ;;-- Gross
    :associated-window widget))
 	     
 
@@ -335,7 +338,8 @@
 				    1))
 			      :managed nil))
 	 (font (and text-style (text-style-mapping port text-style)))
-	 (font-list (and (or label simplep) font (list :font-list (list font)))))
+	 (font-list (and (or label simplep) font (list :font-list (list font))))
+	 (frame (pane-frame associated-window)))
     (when label
       (let ((title (if (atom label) label (car label))))
 	(check-type title string)
@@ -383,13 +387,10 @@
 			  (xt::add-widget-cleanup-function
 			     button
 			     #'tk::destroy-pixmap pixmap)
-			  button))))
-		 (when (clim-internals::menu-item-documentation item)
-		   (tk::add-callback button 
-				 :help-callback 
-				 'display-motif-help
-				 port
-				 (clim-internals::menu-item-documentation item)))
+			  button))))	
+		 (add-documentation-callbacks
+		  frame button
+		  (clim-internals::menu-item-documentation item))
 		 button))
 	     (construct-menu-from-items (menu items)
 	       (map nil #'(lambda (item)
@@ -446,6 +447,8 @@
 		    (setf value-returned nil return-value nil)
 		  (values value-returned return-value))))))
 
+
+
 (defmethod frame-manager-allows-menu-caching ((framem motif-frame-manager))
   ;; Deal with the problem of motif installing passive grabs
   nil)
@@ -555,3 +558,22 @@
     ;; menu frames, such as implemented "click off menu to abort".
     (setf (getf (frame-properties frame) :menu-frame) t)
     (values (slot-value frame 'clim-internals::menu) frame)))
+
+(defmethod add-documentation-callbacks (frame (button tk::xm-push-button) documentation)
+  (when documentation
+    (tk::add-callback
+     button :arm-callback 
+     'pointer-documentation-callback-function
+     frame documentation t)
+    (tk::add-callback
+     button :disarm-callback 
+     'pointer-documentation-callback-function
+     frame documentation nil)))
+
+(defmethod add-documentation-callbacks :after (frame (button t) documentation)
+  (when documentation
+    (tk::add-callback button 
+		      :help-callback 
+		      'display-motif-help
+		      (frame-manager frame)
+		      documentation)))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 93442e5e..31f8dbcf 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.74 93/05/13 16:25:00 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.74 1993/05/13 16:25:00 cer Exp $
 
 (in-package :xm-silica)
 
@@ -1747,3 +1747,47 @@
                       :accelerator-text accel-text))))
 
 
+
+;; Support for help
+
+(defmethod add-sheet-callbacks :after 
+           ((port motif-port) (sheet gadget) (widget xt::xm-primitive))
+  (add-help-callback sheet widget))
+
+(defmethod add-sheet-callbacks :after 
+           ((port motif-port) (sheet gadget) (widget xt::xm-manager))
+  (add-help-callback sheet widget))
+
+(defun add-help-callback (sheet widget)
+  (when (silica::gadget-help-callback sheet)
+    (tk::add-callback widget 
+		      :help-callback 
+		      'help-callback-function
+		      sheet)))
+
+(defun help-callback-function (widget sheet)
+  (declare (ignore widget))
+  (distribute-event
+   (port sheet)
+   (allocate-event 'gadget-help-event
+		   :gadget sheet)))
+
+(defclass gadget-help-event (gadget-event) 
+  ())
+
+(defmethod handle-event ((sheet basic-gadget) (event gadget-help-event))
+  (let ((help (silica::gadget-help-callback sheet)))
+    (etypecase help
+      (string (display-motif-help sheet (frame-manager sheet) help))
+      (cons (apply (car help) sheet (cdr help))))))
+
+
+(defun clim-internals::make-help-from-presentation-type (stream presentation-type)
+  ;;-- We have to do it this way because describe methods might invoke
+  ;;-- presentations etc etc
+  (accepting-values (stream :exit-boxes '(:exit)
+			    :label "Help"
+			    :own-window t)
+    (describe-presentation-type presentation-type stream)))
+
+
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 1a693b20..1c923180 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.35 93/04/16 09:46:02 cer Exp $
+;; $fiHeader: xm-silica.lisp,v 1.36 1993/05/13 16:32:02 colin Exp $
 
 (in-package :xm-silica)
 
@@ -179,4 +179,10 @@
 (defun xm-get-focus-widget (widget)
   (tk::intern-widget (tk::xm_get_focus_widget widget)))
 
+(defmethod port-move-focus-to-gadget ((port xm-silica::motif-port) gadget)
+  ;;-- If this is composite then it should find the first child
+  ;;-- that can take the focus
+  (let ((m (sheet-direct-mirror gadget)))
+    (when m (tk::xm_process_traversal m 0))))
+
 
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 9f03397f..a672a23f 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.33 93/04/16 09:46:04 cer Exp $
+;; $fiHeader: xt-frames.lisp,v 1.34 93/04/23 09:18:48 cer Exp $
 
 
 (in-package :xm-silica)
@@ -190,8 +190,8 @@
 
 (defmethod frame-manager-exit-box-labels ((framem xt-frame-manager) frame view)
   (declare (ignore frame view))
-  '((:exit  "Ok")
-    (:abort  "Cancel")))
+  '((:exit  "OK" :documentation "Exit from dialog")
+    (:abort  "Cancel" :documentation "Cancel dialog")))
 
 (defmethod frame-manager-default-exit-boxes ((framem xt-frame-manager))
   '((:exit) (:abort)))
@@ -291,3 +291,17 @@
       (destructuring-bind (&key name &allow-other-keys) (clim-internals::frame-icon frame)
 	;;-- Dialog shells do not have :icon-name resource
 	(tk::set-values shell :icon-name (or name (frame-pretty-name frame)))))))
+
+(defmethod add-documentation-callbacks (frame button documentation)
+  (declare (ignore frame button documentation)))
+
+(defun pointer-documentation-callback-function (widget frame documentation showp)
+  (declare (ignore widget))
+  (let ((pointer-documentation-pane
+	 (clim-internals::frame-actual-pointer-documentation-pane frame)))
+    (when pointer-documentation-pane
+      (frame-manager-display-pointer-documentation-string
+       (frame-manager frame)
+       frame
+       pointer-documentation-pane
+       (and showp documentation)))))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index b7bf7309..e3f556d2 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.72 93/05/13 16:25:03 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.73 1993/05/13 16:32:11 colin Exp $
 
 (in-package :tk-silica)
 
@@ -1748,3 +1748,6 @@
 (defmethod medium-finish-output ((medium xt-medium))
   (x11:xsync (port-display (port medium)) 0))
 
+
+(defmacro with-medium-state-cached ((medium) &body body)
+  `(prog ,medium ,@body))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index f2e87b0a..1bda4f90 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.82 93/05/13 16:25:07 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.83 1993/05/13 16:32:28 colin Exp $
 
 (in-package :xm-silica)
 
@@ -1696,9 +1696,6 @@ the geometry of the children. Instead the parent has control. "))
 	    (tk::destroy-pixmap pixmap)
 	    (when mask (tk::destroy-pixmap mask))))))))
 
-
-      
-
 (defvar *pointer-grabbed* nil)
 
 
diff --git a/tk/event.lisp b/tk/event.lisp
index 7862ff06..86150c42 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.16 93/02/08 15:57:53 cer Exp $
+;; $fiHeader: event.lisp,v 1.17 1993/05/13 16:24:34 cer Exp $
 
 (in-package :tk)
 
@@ -85,6 +85,12 @@
 
 (defun process-one-event (context mask reason)
   (cond ((plusp mask)
+	 #+debug
+	 (when (logtest mask *xt-im-xevent*)
+	   (let ((event (x11:make-xevent)))
+	     (unless (zerop (xt_app_peek_event context event))
+	       (when (eq (event-type event) :key-press)
+		 (break)))))
 	 (xt_app_process_event
 	  context
 	  ;; Because of a feature in the OLIT toolkit we need to
diff --git a/tk/ol-widgets.lisp b/tk/ol-widgets.lisp
index bad4b698..672ce71c 100644
--- a/tk/ol-widgets.lisp
+++ b/tk/ol-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-widgets.lisp,v 1.2 92/06/23 08:19:15 cer Exp $
+;; $fiHeader: ol-widgets.lisp,v 1.3 92/07/27 19:29:14 cer Exp $
 
 (in-package :xt)
 
@@ -74,4 +74,20 @@
 					  :name :appl-delete-item
 					  :type 'function
 					  :original-name 
-					  (string-to-char* "applDeleteItem")))
+					  (string-to-char*
+					   "applDeleteItem")))
+
+(tk::add-resource-to-class (find-class 'ol-list)
+			   (make-instance 'resource
+					  :name :view-height
+					  :type 'dimension
+					  :original-name 
+					  (string-to-char*
+					   "viewHeight")))
+
+(tk::add-resource-to-class (find-class 'ol-list)
+			   (make-instance 'resource
+					  :name :recompute-width
+					  :type 'boolean
+					  :original-name 
+					  (string-to-char* "recomputeWidth")))
diff --git a/tk/resources.lisp b/tk/resources.lisp
index b2cc0b67..0476784c 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,8 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.45 93/05/13 16:24:38 cer Exp $
+;; $fiHeader: resources.lisp,v 1.45 1993/05/13 16:24:38 cer Exp $
+
 
 (in-package :tk)
 
@@ -105,156 +106,157 @@
 ;; from OpenLook.h
 
 (defparameter *ol-defines* '(
-		       (:ignore -1)
-		       (:absent-pair		0)
-		       (:all			1)
-		       (:always		2)
-		       (:atom-help		3)
-		       (:both			4)
-		       (:bottom		5)
-		       (:buttonstack		6)
-		       (:center		7)
-		       (:class-help		8)
-		       (:columns		9)
-		       (:copy-mask-value	10)
-		       (:copy-size		11)
-		       (:copy-source-value	12)
-		       (:current		13)
-		       (:default-pair		14)
-		       (:disk-source		15)
-		       (:display-form		16)
-		       (:down			17)
-		       (:existing-source	18)
-		       (:fixedcols		19)
-		       (:fixedheight		20)
-		       (:fixedrows		21)
-		       (:fixedwidth		22)
-		       (:flat-button		23)
-		       (:flat-checkbox	24)
-		       (:flat-container	25)
-		       (:flat-exclusives	26)
-		       (:flat-help		27)
-		       (:flat-nonexclusives	28)
-		       (:halfstack		29)
-		       (:horizontal		30)
-		       (:image		31)
-		       (:in			32)
-		       (:indirect-source	33)
-		       (:label		34)
-		       (:left			35)
-		       (:mask-pair		36)
-		       (:maximize		37)
-		       (:millimeters		38)
-		       (:minimize		39)
-		       (:never		40)
-		       (:next			41)
-		       (:none			42)
-		       (:nonebottom		43)
-		       (:noneleft		44)
-		       (:noneright		45)
-		       (:nonetop		46)
-		       (:notices		47)
-		       (:no-virtual-mapping	48)
-		       (:oblong		49)
-		       (:out			50)
-		       (:override-pair	51)
-		       (:pixels		52)
-		       (:points		53)
-		       (:popup		54)
-		       (:previous		55)
-		       (:prog-defined-source	56)
-		       (:rectbutton		57)
-		       (:right		58)
-		       (:rows			59)
-		       (:source-form		60)
-		       (:source-pair		61)
-		       (:stayup		62)
-		       (:string		63)
-		       (:string-source	64)
-		       (:text-append		65)
-		       (:text-edit		66)
-		       (:text-read		67)
-		       (:top			68)
-		       (:transparent-source	69)
-		       (:vertical		70)
-		       (:virtual-button	71)
-		       (:virtual-key		72)
-		       (:widget-help		73)
-		       (:window-help		74)
-		       (:wrap-any		75)
-		       (:wrap-white-space	76)
-		       (:continuous		77)
-		       (:granularity		78)
-		       (:release		79)
-		       (:tickmark		80)
-		       (:percent		81)
-		       (:slidervalue		82)
-		       (:wt-base		83)
-		       (:wt-cmd		84)
-		       (:wt-notice		85)
-		       (:wt-help		86)
-		       (:wt-other		87)
-		       (:success		88)
-		       (:duplicate-key	89)
-		       (:duplicatekey		89)
-		       (:bad-key		90)
-		       (:menu-full		91)
-		       (:menu-limited		92)
-		       (:menu-cancel		93)
-		       (:selectkey		94)
-		       (:menukey		95)
-		       (:menudefault		96)
-		       (:menudefaultkey	97)
-		       (:hsbmenu		98)
-		       (:vsbmenu		99)
-		       (:adjustkey		100)
-		       (:nextapp		101)
-		       (:nextwindow		102)
-		       (:prevapp		103)
-		       (:prevwindow		104)
-		       (:windowmenu		105)
-		       (:workspacemenu	106)
-		       (:defaultaction	108)
-		       (:drag			109)
-		       (:drop			110)
-		       (:togglepushpin	111)
-		       (:pageleft		112)
-		       (:pageright		113)
-		       (:scrollbottom		114)
-		       (:scrolltop		115)
-		       (:multiright		116)
-		       (:multileft		117)
-		       (:multidown		118)
-		       (:multiup		119)
-		       (:immediate		120)
-		       (:moveup		121)
-		       (:movedown		122)
-		       (:moveright		123)
-		       (:moveleft		124)
-		       (:click-to-type	125)
-		       (:realestate		126)
-		       (:underline		127)
-		       (:highlight		128)
-		       (:inactive		129)
-		       (:display		130)
-		       (:proc			131)
-		       (:size-proc		132)
-		       (:draw-proc		133)
-		       (:pinned-menu		134)
-		       (:press-drag-menu	135)
-		       (:stayup-menu		136)
-		       (:pointer		137)
-		       (:inputfocus		138)
-		       (:quit			142)
-		       (:destroy		143)
-		       (:dismiss		144)
-		       (:pre			145)
-		       (:post			146)
-		       (:grow-off     	147)
-		       (:grow-horizontal      148)
-		       (:grow-vertical        149)
-		       (:grow-both    	150)
-		       ))
+			     (:ignore -1)
+			     (:ignore 65535)
+			     (:absent-pair		0)
+			     (:all			1)
+			     (:always		2)
+			     (:atom-help		3)
+			     (:both			4)
+			     (:bottom		5)
+			     (:buttonstack		6)
+			     (:center		7)
+			     (:class-help		8)
+			     (:columns		9)
+			     (:copy-mask-value	10)
+			     (:copy-size		11)
+			     (:copy-source-value	12)
+			     (:current		13)
+			     (:default-pair		14)
+			     (:disk-source		15)
+			     (:display-form		16)
+			     (:down			17)
+			     (:existing-source	18)
+			     (:fixedcols		19)
+			     (:fixedheight		20)
+			     (:fixedrows		21)
+			     (:fixedwidth		22)
+			     (:flat-button		23)
+			     (:flat-checkbox	24)
+			     (:flat-container	25)
+			     (:flat-exclusives	26)
+			     (:flat-help		27)
+			     (:flat-nonexclusives	28)
+			     (:halfstack		29)
+			     (:horizontal		30)
+			     (:image		31)
+			     (:in			32)
+			     (:indirect-source	33)
+			     (:label		34)
+			     (:left			35)
+			     (:mask-pair		36)
+			     (:maximize		37)
+			     (:millimeters		38)
+			     (:minimize		39)
+			     (:never		40)
+			     (:next			41)
+			     (:none			42)
+			     (:nonebottom		43)
+			     (:noneleft		44)
+			     (:noneright		45)
+			     (:nonetop		46)
+			     (:notices		47)
+			     (:no-virtual-mapping	48)
+			     (:oblong		49)
+			     (:out			50)
+			     (:override-pair	51)
+			     (:pixels		52)
+			     (:points		53)
+			     (:popup		54)
+			     (:previous		55)
+			     (:prog-defined-source	56)
+			     (:rectbutton		57)
+			     (:right		58)
+			     (:rows			59)
+			     (:source-form		60)
+			     (:source-pair		61)
+			     (:stayup		62)
+			     (:string		63)
+			     (:string-source	64)
+			     (:text-append		65)
+			     (:text-edit		66)
+			     (:text-read		67)
+			     (:top			68)
+			     (:transparent-source	69)
+			     (:vertical		70)
+			     (:virtual-button	71)
+			     (:virtual-key		72)
+			     (:widget-help		73)
+			     (:window-help		74)
+			     (:wrap-any		75)
+			     (:wrap-white-space	76)
+			     (:continuous		77)
+			     (:granularity		78)
+			     (:release		79)
+			     (:tickmark		80)
+			     (:percent		81)
+			     (:slidervalue		82)
+			     (:wt-base		83)
+			     (:wt-cmd		84)
+			     (:wt-notice		85)
+			     (:wt-help		86)
+			     (:wt-other		87)
+			     (:success		88)
+			     (:duplicate-key	89)
+			     (:duplicatekey		89)
+			     (:bad-key		90)
+			     (:menu-full		91)
+			     (:menu-limited		92)
+			     (:menu-cancel		93)
+			     (:selectkey		94)
+			     (:menukey		95)
+			     (:menudefault		96)
+			     (:menudefaultkey	97)
+			     (:hsbmenu		98)
+			     (:vsbmenu		99)
+			     (:adjustkey		100)
+			     (:nextapp		101)
+			     (:nextwindow		102)
+			     (:prevapp		103)
+			     (:prevwindow		104)
+			     (:windowmenu		105)
+			     (:workspacemenu	106)
+			     (:defaultaction	108)
+			     (:drag			109)
+			     (:drop			110)
+			     (:togglepushpin	111)
+			     (:pageleft		112)
+			     (:pageright		113)
+			     (:scrollbottom		114)
+			     (:scrolltop		115)
+			     (:multiright		116)
+			     (:multileft		117)
+			     (:multidown		118)
+			     (:multiup		119)
+			     (:immediate		120)
+			     (:moveup		121)
+			     (:movedown		122)
+			     (:moveright		123)
+			     (:moveleft		124)
+			     (:click-to-type	125)
+			     (:realestate		126)
+			     (:underline		127)
+			     (:highlight		128)
+			     (:inactive		129)
+			     (:display		130)
+			     (:proc			131)
+			     (:size-proc		132)
+			     (:draw-proc		133)
+			     (:pinned-menu		134)
+			     (:press-drag-menu	135)
+			     (:stayup-menu		136)
+			     (:pointer		137)
+			     (:inputfocus		138)
+			     (:quit			142)
+			     (:destroy		143)
+			     (:dismiss		144)
+			     (:pre			145)
+			     (:post			146)
+			     (:grow-off     	147)
+			     (:grow-horizontal      148)
+			     (:grow-vertical        149)
+			     (:grow-both    	150)
+			     ))
 
 (defmethod convert-resource-in (parent (type (eql 'ol-define)) value)
   (declare (ignore parent))
@@ -594,9 +596,9 @@
 ;;; Accelerator table stuff
 
 (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table))
-				(value (eql nil)))
+				 (value (eql nil)))
   (declare (ignore parent))
-  0)
+  (xt_parse_accelerator_table ""))
 
 
 
@@ -701,3 +703,11 @@
 (define-enumerated-resource ol-wrap-mode  ((:wrap-off 74) 
 					   (:wrap-any 75)
 					   (:wrap-white-space 76)))
+
+
+(defmethod convert-resource-out (parent (type (eql 'xt::translation-table)) value)
+  (declare (ignore parent))
+  (xt_parse_translation_table 
+   (etypecase value
+     (string value)
+     (null ""))))
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index c755e0a7..615d6cf9 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -20,7 +20,8 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-funs.lisp,v 1.17 93/05/13 16:24:42 cer Exp $
+;; $fiHeader: xt-funs.lisp,v 1.17 1993/05/13 16:24:42 cer Exp $
+
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -277,6 +278,15 @@
     :arg-checking nil
     :return-type :fixnum
     :entry-point (ff:convert-to-lang "XtAppPending"))
+
+
+(defforeign 'xt_app_peek_event
+    :arguments '(foreign-address foreign-address)
+    :call-direct t
+    :arg-checking nil
+    :return-type :fixnum
+    :entry-point (ff:convert-to-lang "XtAppPeekEvent"))
+
 (defforeign 'xt_app_process_event
     :arguments '(foreign-address fixnum)
     :call-direct t
@@ -396,3 +406,18 @@
 ;    :arg-checking nil
 ;    :entry-point (ff:convert-to-lang "XtGetMultiClickTime")
 ;    :return-type :unsigned-integer)
+
+(ff:defforeign 'xt_parse_translation_table
+    :call-direct t
+    :arguments '(string)
+    :arg-checking nil
+    :entry-point (ff:convert-to-lang "XtParseTranslationTable")
+    :return-type :unsigned-integer)
+
+(ff:defforeign 'xt_parse_accelerator_table
+    :call-direct t
+    :arguments '(string)
+    :arg-checking nil
+    :entry-point (ff:convert-to-lang "XtParseAcceleratorTable")
+    :return-type :unsigned-integer)
+
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 9b943c57..14db14b0 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.53 93/04/27 14:36:16 cer Exp $
+;; $fiHeader: packages.lisp,v 1.54 1993/05/13 16:33:01 colin Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2032,6 +2032,7 @@
     pixmap-height
     pixmap-width
     with-output-to-pixmap
+    with-medium-state-cached
     
     ;; Colors
     +background-ink+
@@ -2666,6 +2667,7 @@
     disable-frame
     disown-frame
     display-command-menu
+    display-invalid-queries
     enable-frame
     execute-frame-command
     execute-command-in-frame
@@ -3470,6 +3472,8 @@
     mirror-region-updated
     mirror-visible-p
     modifier-keysym
+    move-focus-to-gadget
+    port-move-focus-to-gadget
     non-drawing-option-keywords
     note-layout-mixin-region-changed
     note-sheet-tree-grafted
-- 
GitLab