From d5d5323ad2c7187a5f1c03d53eaf5fc8fbf35c1d Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 8 Sep 1992 10:35:40 +0000
Subject: [PATCH] fixes

---
 Makefile                       |   4 +-
 clim/accept-values.lisp        | 100 +++++++-----
 clim/command.lisp              |   4 +-
 clim/db-stream.lisp            |  32 ++--
 clim/frames.lisp               | 136 ++++++++++------
 clim/gadget-output.lisp        | 288 ++++++++++++++++++++++++++-------
 clim/interactive-defs.lisp     |  23 ++-
 clim/interactive-protocol.lisp |  14 +-
 clim/output-protocol.lisp      |   5 +-
 clim/recording-protocol.lisp   |   6 +-
 clim/view-defs.lisp            |   8 +-
 demo/cad-demo.lisp             |   2 +-
 demo/graphics-editor.lisp      | 229 +++++++++++++++++++-------
 demo/plot.lisp                 |  15 +-
 demo/sysdcl.lisp               |   8 +-
 misc/compile-1.lisp            |  10 +-
 misc/dev-load-1.lisp           |  19 ++-
 postscript/sysdcl.lisp         |   4 +-
 silica/db-border.lisp          |   6 +-
 silica/db-box.lisp             |  82 +++++-----
 silica/db-layout.lisp          |  15 +-
 silica/db-scroll.lisp          |   6 +-
 silica/db-table.lisp           |  48 +++---
 silica/gadgets.lisp            |  26 +--
 silica/pixmaps.lisp            |   7 +-
 sys/sysdcl.lisp                |   4 +-
 test/chess.lisp                |  38 +++--
 test/test-suite.lisp           | 173 +++++++++++---------
 test/test.lisp                 |  51 +++++-
 tk-silica/xm-frames.lisp       |  74 +++++----
 tk-silica/xm-gadgets.lisp      | 114 +++++++++----
 tk-silica/xt-frames.lisp       |  12 +-
 tk-silica/xt-gadgets.lisp      |  37 ++++-
 tk-silica/xt-graphics.lisp     |   3 +-
 tk-silica/xt-silica.lisp       |  59 ++++---
 tk/callbacks.lisp              |  27 +++-
 tk/load-ol.lisp                |   4 +-
 tk/load-xm.lisp                |   4 +-
 tk/resources.lisp              |  18 ++-
 tk/widget.lisp                 |  18 ++-
 tk/xlib.lisp                   |  13 +-
 tk/xm-widgets.lisp             |  18 ++-
 utils/packages.lisp            |  20 ++-
 utils/processes.lisp           |   7 +-
 44 files changed, 1253 insertions(+), 538 deletions(-)

diff --git a/Makefile b/Makefile
index fba9075e..579b8d2f 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.43 92/08/19 10:24:17 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.44 92/08/21 16:34:13 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
@@ -143,6 +143,7 @@ CLIM-UTILS-OBJS = utils/excl-verification.fasl \
                    utils/lisp-utilities.fasl \
                    utils/processes.fasl \
                    utils/queue.fasl \
+		   utils/timers.fasl \
                    utils/protocols.fasl \
                    utils/autoconstructor.fasl \
                    utils/clim-streams.fasl \
@@ -275,6 +276,7 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \
                    tk-silica/image.fasl \
                    tk-silica/xt-frames.fasl \
                    tk-silica/xm-frames.fasl \
+                   tk-silica/xm-dialogs.fasl \
                    tk-silica/xt-gadgets.fasl \
                    tk-silica/xm-gadgets.fasl \
                    tk-silica/xm-menus.fasl \
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index e9a565c5..c5d11269 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.30 92/08/19 18:04:40 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.31 92/08/21 16:33:42 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -244,6 +244,9 @@
 ;; So the continuation can run with the proper value of *APPLICATION-FRAME*
 (defvar *avv-calling-frame*)
 
+(defmethod frame-manager-accepting-values-frame-class ((framem standard-frame-manager))
+  'accept-values-own-window)
+
 (defun invoke-accepting-values (stream continuation
 				 &key frame-class command-table own-window 
 				      (exit-boxes 
@@ -260,7 +263,9 @@
 	 (right-margin 10)
 	 (bottom-margin 10))
      (if own-window
-	 (let ((frame (make-application-frame (or frame-class 'accept-values-own-window)
+	 (let ((frame (make-application-frame (or frame-class 
+						  (frame-manager-accepting-values-frame-class
+						   (frame-manager *application-frame*)))
 			:calling-frame *application-frame*
 			:parent *application-frame*
 			:pretty-name label
@@ -344,15 +349,15 @@
 		     (redisplay avv stream :check-overlapping check-overlapping))
 		   (loop
 		     (let ((command
-			     (let ((command-stream (slot-value stream 'stream)))
-			       ;; While we're reading commands, restore the view
-			       ;; to what it was before we started.
-			       (letf-globally (((stream-default-view command-stream)
-						original-view))
-				 (read-frame-command frame :stream command-stream)))))
-		       (if (and command (not (keyboard-event-p command)))
-			   (execute-frame-command frame command)
-		       (beep stream)))
+			      (let ((command-stream (slot-value stream 'stream)))
+				;; While we're reading commands, restore the view
+				;; to what it was before we started.
+				(letf-globally (((stream-default-view command-stream)
+						 original-view))
+				  (read-frame-command frame :stream command-stream)))))
+			 (if (and command (not (keyboard-event-p command)))
+			     (execute-frame-command frame command)
+			   (beep stream)))
 		     (with-deferred-gadget-updates
 		       (when (or resynchronize-every-pass
 				 (slot-value avv-record 'resynchronize))
@@ -380,20 +385,24 @@
 		       (size-panes-appropriately)))))
 	       (size-panes-appropriately ()
 		 (changing-space-requirements ()
-		   ;; We really want to specify the min/max sizes of
-		   ;; the exit-button pane also
-		   (size-frame-from-contents exit-button-stream
- 		     :size-setter
- 		       #'(lambda (pane w h)
-			   (change-space-requirements pane 
-			     :width w :min-width w :max-width w
-			     :height h :min-height h :max-height h)))
+		     ;; We really want to specify the min/max sizes of
+		     ;; the exit-button pane
+		     ;; also
+		     (when exit-button-stream
+
+		       (size-frame-from-contents exit-button-stream
+						 :size-setter
+						 #'(lambda (pane w h)
+						     (change-space-requirements 
+						      pane 
+						      :width w :min-width w :max-width w
+						      :height h :min-height h :max-height h))))
 		   (when own-window
 		     (size-frame-from-contents own-window
-		       :width own-window-width
-		       :height own-window-height
-		       :right-margin own-window-right-margin
-		       :bottom-margin own-window-bottom-margin)))))
+					       :width own-window-width
+					       :height own-window-height
+					       :right-margin own-window-right-margin
+					       :bottom-margin own-window-bottom-margin)))))
 	  (declare (dynamic-extent #'run-continuation #'run-avv
 				   #'size-panes-appropriately))
 	  (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog")
@@ -406,7 +415,7 @@
 				  (stream 'accept-values-output-record avv-record)
 				(run-continuation stream avv-record)))))))
 	    ;; In own window dialogs the buttons are displayed separately
-	    (when own-window
+	    (when (and own-window exit-button-stream)
 	      (setq exit-button-record
 		    (updating-output (exit-button-stream)
 		      (with-end-of-line-action (exit-button-stream :allow)
@@ -426,7 +435,8 @@
 			   (frame-top-level-sheet (pane-frame own-window)) x y))
 		       (window-expose own-window)
 		       (with-input-focus (own-window)
-			 (replay exit-button-record exit-button-stream)
+			 (when exit-button-record
+			   (replay exit-button-record exit-button-stream))
 			 (replay avv stream)
 			 (run-avv)))
 		      (t
@@ -473,6 +483,22 @@
 	    (read-gesture :stream help-window))
 	(setf (window-visibility help-window) nil)))))
 
+(defmethod frame-manager-display-input-editor-error ((framem standard-frame-manager)
+						     (frame accept-values) stream error)
+  ;;--- Resignal the error so the user can handle it
+  ;;--- (in lieu of HANDLER-BIND-DEFAULT)
+  (notify-user frame (princ-to-string error) 
+	       :title "Input error"
+	       :style :error :exit-boxes '(:exit))
+  ;;  (beep stream)
+  (remove-activation-gesture stream)
+  ;;  (with-input-editor-typeout (stream :erase t)
+  ;;    (format stream "~A~%Please edit your input." error))
+  ;; Now wait until the user forces a rescan by typing
+  ;; an input editing command
+  (loop (read-gesture :stream stream)))
+
+
 (defmethod accept-values-top-level :around ((frame accept-values-own-window) &rest args)
   (declare (ignore args))
   (unwind-protect
@@ -1103,18 +1129,18 @@
     (with-slots (exit-boxes) frame
       (updating-output (stream :unique-id stream
 			       :cache-value 'exit-boxes)
-	(formatting-item-list (stream :n-columns (length exit-boxes)
-				      :initial-spacing nil)
-	  (dolist (exit-box exit-boxes)
-	    (let* ((value (if (consp exit-box) (car exit-box) exit-box))
-		   (label (or (if (consp exit-box) (second exit-box))
-			      (second (assoc value labels)))))
-	      (formatting-cell (stream)
-		(with-output-as-gadget (stream)
-		  (make-pane 'push-button
-		    :label label
-		    :client frame :id value
-		    :activate-callback #'handle-exit-box-callback))))))))))
+	  (formatting-table (stream :equalize-column-widths nil)
+	      (dolist (exit-box exit-boxes)
+		(formatting-column (stream)
+		    (let* ((value (if (consp exit-box) (car exit-box) exit-box))
+			   (label (or (if (consp exit-box) (second exit-box))
+				      (second (assoc value labels)))))
+		      (formatting-cell (stream)
+			  (with-output-as-gadget (stream)
+			    (make-pane 'push-button
+				       :label label
+				       :client frame :id value
+				       :activate-callback #'handle-exit-box-callback)))))))))))
 
 (defun handle-exit-box-callback (gadget)
   (let ((id (gadget-id gadget)))
diff --git a/clim/command.lisp b/clim/command.lisp
index 2970a427..d817a555 100644
--- a/clim/command.lisp
+++ b/clim/command.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: command.lisp,v 1.13 92/08/18 17:24:45 cer Exp Locker: cer $
+;; $fiHeader: command.lisp,v 1.14 92/08/19 10:23:54 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -408,6 +408,7 @@
 
 (defun add-menu-item-to-command-table (command-table string type value
 				       &key documentation (after ':end) keystroke
+					    mnemonic
 					    text-style (errorp t))
   (check-type string (or string null))
   (check-type type (member :command :function :menu :divider))
@@ -444,6 +445,7 @@
     (incf menu-tick)
     (setq keystrokes nil)
     (let* ((item `(,type ,value 
+		   ,@(and mnemonic `(:mnemonic ,mnemonic))
 		   ,@(and documentation `(:documentation ,documentation))
 		   ,@(and text-style `(:text-style ,text-style))))
 	   ;; Entries are of the form (MENU-NAME KEYSTROKE MENU-ITEM)
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 9f8cf13f..81287dcc 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.26 92/07/27 11:02:19 cer Exp $
+;; $fiHeader: db-stream.lisp,v 1.27 92/08/18 17:24:49 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -20,6 +20,7 @@
 	   sheet-permanently-enabled-mixin
 	   sheet-mute-input-mixin
 	   sheet-multiple-child-mixin
+	   silica::space-requirement-cache-mixin
 	   space-requirement-mixin
 	   permanent-medium-sheet-output-mixin
 	   pane)
@@ -128,14 +129,21 @@
 			 (eq sr-component :compute))
 		   (multiple-value-bind (width height)
 		       (let ((record
+			      ;;--- can we really do this
+			      (if (and (stream-output-history pane)
+				       (> (output-record-count (stream-output-history pane)) 0))
+				  (stream-output-history pane)
 			       (let ((*sizing-application-frame* t))
 				 (with-output-to-output-record (pane)
-				   (invoke-pane-display-function 
+				   (funcall 
+				    (if (slot-value pane 'incremental-redisplay-p)
+					#'invoke-pane-redisplay-function 
+					#'invoke-pane-display-function)
 				     (pane-frame pane) pane
 				     ;;--- Are all pane display functions prepared to
 				     ;;--- ignore these arguments?  I think not...
 				     :max-width width
-				     :max-height height)))))
+				     :max-height height))))))
 			 (bounding-rectangle-size record))
 		     (do-with-space-req-components progn
 		         sr-component (sr-width sr-min-width sr-max-width)
@@ -297,18 +305,22 @@
       (setf-unless :height 100)
       (setf-unless :min-height 0)
       (setf-unless :max-height +fill+))
-    (let ((pane `(make-pane ,type ,@options)))
+    (let* ((stream (gensym))
+	   (pane `(setq ,stream (make-pane ,type ,@options))))
       (when scroll-bars
 	(setq pane `(scrolling (:scroll-bars ,scroll-bars)
-		      ,pane)))
+			       ,pane)))
       (when label
 	(setq pane `(vertically ()
-		      ,pane
+			,pane
 		      (make-pane 'label-pane 
-			:label ,label
-			:max-width +fill+))))
-      `(outlining (:thickness 1)
-	 ,pane))))
+				 :label ,label
+				 :max-width +fill+))))
+      `(let (,stream)
+	 (values 
+	  (outlining (:thickness 1)
+		     ,pane)
+	  ,stream)))))
 
 (defmacro make-clim-interactor-pane (&rest options)
   `(make-clim-stream-pane :type 'interactor-pane ,@options))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 586204e8..25a1c2a2 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.37 92/08/18 17:54:10 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.38 92/08/19 10:23:59 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -271,6 +271,7 @@
 	       (value (second options) (second options)))
 	      ((null options))
 	   (case keyword
+	     (:inherit-menu)
 	     (:inherit-from
 	       (if (listp value)
 		   (dolist (item value)
@@ -516,7 +517,8 @@
 	    (resize-sheet top-sheet width height))))))
 
 (defmethod (setf frame-current-layout) (layout (frame standard-application-frame))
-  (unless (eq (frame-current-layout frame) layout)
+  (unless (or (eq (frame-current-layout frame) layout)
+	      (null (frame-top-level-sheet frame)))
     (setf (slot-value frame 'current-layout) layout)
     ;; First disown all the children
     (dolist (name-and-pane (slot-value frame 'all-panes))
@@ -531,17 +533,18 @@
     (multiple-value-call #'layout-frame
       frame (bounding-rectangle-size (frame-top-level-sheet frame)))
     (let ((layout-space-requirements 
-	    (cddr (assoc layout (frame-layouts frame)))))
+	   (cddr (assoc layout (frame-layouts frame)))))
       (changing-space-requirements (:layout nil)
-	(flet ((adjust-layout (sheet)
-		 (change-space-requirements-to-default sheet)
-		 (let ((x (and (panep sheet)
-			       (assoc (pane-name sheet) layout-space-requirements))))
-		   (when x (apply #'change-space-requirements sheet (cdr x))))))
-	  (declare (dynamic-extent #'adjust-layout))
-	  (map-over-sheets #'adjust-layout (frame-top-level-sheet frame)))))
+	  (flet ((adjust-layout (sheet)
+		   (change-space-requirements-to-default sheet)
+		   (let ((x (and (panep sheet)
+				 (assoc (pane-name sheet) layout-space-requirements))))
+		     (when x (apply #'change-space-requirements sheet (cdr x))))))
+	    (declare (dynamic-extent #'adjust-layout))
+	    (map-over-sheets #'adjust-layout (frame-top-level-sheet frame)))))
     ;;--- Don't throw, just recompute stream bindings in a principled way
-    (throw 'layout-changed nil)))
+    (handler-case (throw 'layout-changed nil)
+      (error () nil))))
 
 (defmethod frame-all-layouts ((frame standard-application-frame))
   (mapcar #'first (frame-layouts frame)))
@@ -628,19 +631,19 @@
 	 ;; then we should be using that
 	 ;; If the frame already exists then we probably should be using
 	 ;; the top level sheet size
-	 (multiple-value-call #'layout-frame 
-	   frame
-	   (ecase old
-	     (:disowned 
- 	       (if (and width height)
-		   (values width height)
-		   (values)))
-	     (:disabled
-	       (bounding-rectangle-size
-		 (frame-top-level-sheet frame)))))
-	 (when (and left top)
-	   (move-sheet (frame-top-level-sheet frame) left top))
-	 (note-frame-enabled (frame-manager frame) frame))))))
+	 (multiple-value-bind (w h)
+	     (ecase old
+	       (:disowned 
+		(if (and width height)
+		    (values width height)
+		  (values)))
+	       (:disabled
+		(bounding-rectangle-size
+		 (frame-top-level-sheet frame))))  
+	   (layout-frame frame w h)
+	   (when (and left top)
+	     (move-sheet (frame-top-level-sheet frame) left top))
+	   (note-frame-enabled (frame-manager frame) frame)))))))
 
 (defmethod destroy-frame ((frame standard-application-frame))
   (when (eq (frame-state frame) :enabled)
@@ -1042,12 +1045,15 @@
 			       (synchronous-command-event-command c)))))
 	  (call-next-method)))))
 	
-;; Actually this should be treated as a command event
+;;--- Actually this should be named command-event
+
 (defclass presentation-event (event)
-    ((value :initarg :value :reader presentation-event-value)
-     (sheet :initarg :sheet :reader event-sheet)
-     (frame :initarg :frame :reader event-frame)
-     (presentation-type :initarg :presentation-type :reader event-presentation-type)))
+	  ((value :initarg :value :reader presentation-event-value)
+	   (sheet :initarg :sheet :reader event-sheet)
+	   (frame :initarg :frame :reader event-frame)
+	   (queuep :initarg :queuep :initform nil)
+	   (presentation-type :initarg :presentation-type :reader event-presentation-type))
+  (:default-initargs :presentation-type 'command))
 
 (defmethod handle-event (sheet (event presentation-event))
   (process-command-event sheet event))
@@ -1057,35 +1063,58 @@
   (let ((command (presentation-event-value event)))
     (if (partial-command-p command)
 	(throw-highlighted-presentation
-	  (make-instance 'standard-presentation
-	    :object command
-	    :type (event-presentation-type event))
-	  *input-context*
-	  (allocate-event 'pointer-button-press-event
-	    :sheet sheet
-	    :x 0 :y 0
-	    :modifier-state 0
-	    :button +pointer-left-button+))
-	(progn
-	  (when (and *input-buffer-empty*
-		     (eq *application-frame* (event-frame event)))
-	    (signal 'synchronous-command-event
-		    :command command))
-	  ;; Perhaps if this results directly from a user action then either
-	  ;; we should do it right away, ie. loose the input buffer or beep if
-	  ;; it has to be deffered,
-	  (queue-frame-command (event-frame event) (presentation-event-value event))))))
+	 (make-instance 'standard-presentation
+			:object command
+			:type (event-presentation-type event))
+	 *input-context*
+	 (allocate-event 'pointer-button-press-event
+			 :sheet sheet
+			 :x 0 :y 0
+			 :modifier-state 0
+			 :button +pointer-left-button+))
+      (progn
+	(when (and *input-buffer-empty*
+		   (eq *application-frame* (event-frame event)))
+	  (signal 'synchronous-command-event
+		  :command command))
+	;; Perhaps if this results directly from a user action then either
+	;; we should do it right away, ie. loose the input buffer or beep if
+	;; it has to be deffered,
+	(if (slot-value event 'queuep)
+	    (queue-frame-command (event-frame event) (presentation-event-value event))
+	  (beep sheet))))))
 
 (defun queue-frame-command (frame command)
   (queue-push (frame-command-queue frame) command))
 
-(defmethod execute-command-in-frame ((frame standard-application-frame) command)
+(defmethod execute-command-in-frame ((frame standard-application-frame) 
+				     command &rest initargs)
   (distribute-event
     (port frame)
-    (allocate-event 'presentation-event
-      :frame frame
-      :sheet (frame-top-level-sheet frame)
-      :value command)))
+    (apply #'allocate-event 
+	   'presentation-event 
+	   :frame frame
+	   :sheet (frame-top-level-sheet frame) 
+	   :value command 
+	   initargs)))
+
+(defun make-command-timer (frame 
+			   command arguments delay 
+			   &key repeat
+				(command-table (frame-command-table frame)))
+  (flet ((queue-command-event (timer)
+	   (declare (ignore timer))
+	   (execute-command-in-frame
+	    frame
+	    (cons command arguments)
+	    :queuep t
+	    :presentation-type `(command :command-table ,command-table))))
+    (let ((timer 
+	   (make-instance 'clim-utils::timer 
+			  :function #'queue-command-event
+			  :delay delay :repeat repeat)))
+      (clim-utils::add-timer timer)
+      timer)))
 
 
 ;;; The contract of this is to find an "appropriate" presentation; i.e., one
@@ -1317,3 +1346,6 @@
     (values left   left-presentation   left-context
 	    middle middle-presentation middle-context
 	    right  right-presentation  right-context)))
+
+
+
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index 1db36a3e..f8cd3dbd 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.24 92/08/18 17:24:55 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.lisp,v 1.25 92/08/21 16:33:48 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -269,57 +269,70 @@
   ;;--- number of items, etc.
   +radio-box-view+)
 
-;;--- Gadget currently does not include prompt
+
+(define-presentation-method gadget-includes-prompt-p 
+			    ((type completion) (stream t) (view radio-box-view))
+  t)
+
 (define-presentation-method accept-present-default 
-			    ((type completion) stream (view radio-box-view)
-			     default default-supplied-p present-p query-identifier
-			     &key (prompt t))
+    ((type completion) stream (view radio-box-view)
+		       default default-supplied-p present-p query-identifier
+		       &key (prompt t))
   (declare (ignore present-p))
   (let ((current-selection nil))
     (flet ((update-gadget (record gadget radio-box)
 	     (declare (ignore gadget record))
 	     (map-over-sheets
-	       #'(lambda (sheet)
-		   (when (typep sheet 'toggle-button)
-		     (when (setf (gadget-value sheet)
-				 (and default-supplied-p
-				      (funcall test 
-					       (funcall value-key (gadget-id sheet))
-					       (funcall value-key default))))
-		       (setf (radio-box-current-selection radio-box) sheet))))
-	       radio-box)))
+	      #'(lambda (sheet)
+		  (when (typep sheet 'toggle-button)
+		    (when (setf (gadget-value sheet)
+			    (and default-supplied-p
+				 (funcall test 
+					  (funcall value-key (gadget-id sheet))
+					  (funcall value-key default))))
+		      (setf (radio-box-current-selection radio-box) sheet))))
+	      radio-box)))
       (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
-	(let* ((buttons
-		 (map 'list
-		      #'(lambda (element)
-			  (let ((button
-				  (make-pane 'toggle-button 
-					     :label (let ((name (funcall name-key element)))
-						      (if (eq printer #'write-token)
-							  name
-							(pixmap-from-menu-item stream name printer nil)))
-				    :indicator-type :one-of
-				    :value (and default-supplied-p
-						(funcall test 
-							 (funcall value-key element)
-							 (funcall value-key default)))
-				    :id element)))
-			    (when (and default-supplied-p
-				       (funcall test 
-						(funcall value-key element)
-						(funcall value-key default)))
-			      (setq current-selection button))
-			    button))
-		      sequence))
-	       (radio-box (make-pane-from-view 'radio-box view
-			    :label (and (stringp prompt) prompt)
-			    :choices buttons
-			    :selection current-selection
-			    :client stream :id query-identifier
-			    :value-changed-callback
-			      (make-accept-values-value-changed-callback
-				stream query-identifier))))
-	  (values (outlining () radio-box) radio-box))))))
+	(let* ((toggle-options (getf (view-gadget-initargs view) :toggle-button-options))
+	       (buttons
+		(map 'list
+		  #'(lambda (element)
+		      (let ((button
+			     (apply #'make-pane 'toggle-button 
+					:label (let ((name (funcall name-key element)))
+						 (if (eq printer #'write-token)
+						     name
+						   (pixmap-from-menu-item stream name printer nil)))
+					:indicator-type (getf toggle-options :indicator-type :one-of)
+					:value (and default-supplied-p
+						    (funcall test 
+							     (funcall value-key element)
+							     (funcall value-key default)))
+					:id element
+					toggle-options)))
+			(when (and default-supplied-p
+				   (funcall test 
+					    (funcall value-key element)
+					    (funcall value-key default)))
+			  (setq current-selection button))
+			button))
+		  sequence))
+	       (radio-box (apply #'make-pane 'radio-box
+				 (append (with-keywords-removed 
+					     (args (view-gadget-initargs view) '(:toggle-button-options))
+					   args)
+					   (list :label (and (stringp prompt) prompt)
+					       :choices buttons :selection
+					       current-selection 
+					       :client stream
+					       :id query-identifier 
+					       :value-changed-callback
+					       (make-accept-values-value-changed-callback stream query-identifier))
+					 ))))
+	  (values (vertically ()
+		      (make-pane 'label-pane :label prompt)
+		    (outlining () radio-box))
+		  radio-box))))))
 
 
 ;;; Subset completion gadget
@@ -328,6 +341,10 @@
 			    ((type subset-completion) (view gadget-dialog-view) (framem standard-frame-manager))
   +check-box-view+)
 
+(define-presentation-method gadget-includes-prompt-p 
+			    ((type subset-completion) (stream t) (view check-box-view))
+  t)
+
 (define-presentation-method accept-present-default 
 			    ((type subset-completion) stream (view check-box-view)
 			     default default-supplied-p present-p query-identifier
@@ -347,31 +364,39 @@
 			      t))))
 	     check-box)))
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
-      (let* ((buttons
+      (let* ((toggle-options (getf (view-gadget-initargs view) :toggle-button-options))
+	     (buttons
 	       (map 'list
 		    #'(lambda (element)
 			(let* ((value (funcall value-key element))
 			       (button
 				 (make-pane 'toggle-button 
 				   :label (funcall name-key element)
-				   :indicator-type :some-of
+				   :indicator-type (getf toggle-options :indicator-type :some-of)
 				   :value (and default-supplied-p
 					       (member value default
 						       :test test 
 						       ;;--- Should the value-key be used?
 						       :key value-key) 
 					       t)
-				   :id value)))
+				   :id value
+				   toggle-options)))
 			  button))
 		    sequence))
-	     (check-box (make-pane-from-view 'check-box view
-			  :label (and (stringp prompt) prompt)
-			  :choices buttons
-			  :client stream :id query-identifier
-			  :value-changed-callback
-			    (make-accept-values-value-changed-callback
-			      stream query-identifier))))
-	(values (outlining () check-box) check-box)))))
+	     (check-box (apply #'make-pane 'check-box
+			       (append (with-keywords-removed 
+					     (args (view-gadget-initargs view) '(:toggle-button-options))
+					   args)
+				       (list :label (and (stringp prompt) prompt)
+					     :choices buttons
+					     :client stream 
+					     :id query-identifier
+					     :value-changed-callback
+					     (make-accept-values-value-changed-callback stream query-identifier))))))
+	(values (vertically ()
+		      (make-pane 'label-pane :label prompt)
+		  (outlining () check-box)) 
+		check-box)))))
 
 
 ;;; Boolean gadget
@@ -462,6 +487,157 @@
 		    (make-accept-values-value-changed-callback
 		      stream query-identifier))))
 	  (values (outlining () slider) slider))))))
+
+
+(define-presentation-method accept-present-default 
+			    ((type t) stream (view text-field-view)
+			     default default-supplied-p present-p query-identifier
+			     &key (prompt t))
+  (declare (ignore default-supplied-p present-p))
+  (flet ((update-gadget (record gadget text-field)
+ 	   (declare (ignore record gadget))
+ 	   (setf (gadget-value text-field) (present-to-string default type))))
+    (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
+      (let ((text-field (make-pane-from-view 'text-field view
+			   :label (and (stringp prompt) prompt)
+			   :value (present-to-string default type)
+			   :client stream :id query-identifier
+			   :value-changed-callback
+			   `(accept-values-string-field-changed-callback ,stream ,query-identifier))))
+ 	(values text-field text-field)))))
+
+;;;--- This is mostly nonsense. If we enter something that is an error then
+;;;--- the field value is unchanged. What is the right thing to do?
+
+(defmethod accept-values-string-field-changed-callback ((gadget text-field) new-value stream query)
+  (when (accept-values-query-valid-p query (accept-values-query-presentation query))
+    ;; Only call the callback if the query is still valid
+    (handler-case (multiple-value-bind (object type index)
+		      (accept-from-string (accept-values-query-type query) new-value)
+		    (declare (ignore type))
+		    (assert (= index (length new-value)))
+		    object)
+      (error ())
+      (:no-error (object)
+	(do-avv-command object stream query)))))
+
+;;; The string case is straightforward
+
+
+(define-presentation-method decode-indirect-view
+			    ((type string) (view gadget-dialog-view) (framem standard-frame-manager))
+  +text-field-view+)
+
+(define-presentation-method accept-present-default 
+			    ((type string) stream (view text-field-view)
+			     default default-supplied-p present-p query-identifier
+			     &key (prompt t))
+  (declare (ignore default-supplied-p present-p))
+  (flet ((update-gadget (record gadget button)
+ 	   (declare (ignore record gadget))
+ 	   (setf (gadget-value button) default)))
+    (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
+      (let ((text-field (make-pane-from-view 'text-field view
+			   :label (and (stringp prompt) prompt)
+			   :value default
+			   :client stream :id query-identifier
+			   :value-changed-callback
+			   (make-accept-values-value-changed-callback
+			    stream query-identifier))))
+ 	(values text-field text-field)))))
+
+;;;; Text-editor
+
+(define-presentation-method accept-present-default 
+			    ((type string) stream (view text-editor-view)
+			     default default-supplied-p present-p query-identifier
+			     &key (prompt t))
+  (declare (ignore default-supplied-p present-p))
+  (flet ((update-gadget (record gadget button)
+ 	   (declare (ignore record gadget))
+ 	   (setf (gadget-value button) default)))
+    (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
+      (let ((text-field (make-pane-from-view 'text-editor view
+			   :label (and (stringp prompt) prompt)
+			   :value default
+			   :client stream :id query-identifier
+			   :value-changed-callback
+			   (make-accept-values-value-changed-callback
+			    stream query-identifier))))
+ 	(values (scrolling () text-field) text-field)))))
+
+;;;; List-pane
+
+(define-presentation-method accept-present-default 
+    ((type completion) stream (view list-pane-view)
+		       default default-supplied-p present-p query-identifier
+		       &key (prompt t))
+  (declare (ignore present-p default-supplied-p prompt))
+  (make-list/option-pane-for-ptype 'list-pane
+				   stream view sequence name-key value-key
+				   test default query-identifier type
+				   printer
+				   :exclusive))
+
+(define-presentation-method accept-present-default 
+    ((type subset-completion) stream (view list-pane-view)
+			      default default-supplied-p present-p query-identifier
+			      &key (prompt t))
+  (declare (ignore present-p default-supplied-p prompt))
+  (make-list/option-pane-for-ptype 'list-pane stream view sequence name-key value-key
+			    test default query-identifier type printer :nonexclusive))
+
+(defun make-list/option-pane-for-ptype (pane-type stream view sequence name-key
+				 value-key test default
+					query-identifier type printer mode)
+  (flet ((update-gadget (record gadget list-pane)
+	   (declare (ignore gadget record))
+	   (setf (gadget-value list-pane) default)
+	   list-pane))
+    (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
+      (let* ((pane (if (eq pane-type 'option-pane)
+		       (make-pane-from-view pane-type view
+					    :items sequence
+					     :name-key name-key
+					     :value-key value-key
+					     :test test
+					     :printer printer
+					     :value default
+					     :client stream :id query-identifier
+					     :mode mode
+					     :visible-items (min 10 (length sequence))
+					     :value-changed-callback
+					     (make-accept-values-value-changed-callback
+					      stream
+					      query-identifier))
+		     
+		       (make-pane-from-view pane-type view
+					     :items sequence
+					     :name-key name-key
+					     :value-key value-key
+					     :test test
+					     :value default
+					     :client stream :id query-identifier
+					     :mode mode
+					     :visible-items (min 10 (length sequence))
+					     :value-changed-callback
+					     (make-accept-values-value-changed-callback
+					      stream query-identifier)))))
+	(values (if (eq pane-type 'list-pane) (scrolling () pane) pane)
+		pane)))))
+
+(define-presentation-method accept-present-default 
+    ((type completion) stream (view option-pane-view)
+		       default default-supplied-p present-p query-identifier
+		       &key (prompt t))
+  (declare (ignore present-p default-supplied-p prompt))
+  (make-list/option-pane-for-ptype 'option-pane
+				   stream view sequence name-key value-key
+				   test default query-identifier type 
+				   printer
+				   :exclusive))
+
+;;;; Option-menu-view
 
 
 ;;--- These should be defined in the standard DEFOPERATION way...
diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp
index 3f8824f4..fd48ff4c 100644
--- a/clim/interactive-defs.lisp
+++ b/clim/interactive-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: interactive-defs.lisp,v 1.12 92/07/27 11:02:35 cer Exp $
+;; $fiHeader: interactive-defs.lisp,v 1.13 92/08/18 17:25:11 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -245,6 +245,27 @@
 	(when subhelp-clauses
 	  (display-help-clauses subhelp-clauses))))))
 
+(defun display-input-editor-error (stream error)
+  ;;-- The reason for using *application-frame* instead of (pane-frame
+  ;;stream) is because for own-window nil avv the pane-frame is the
+  ;;calling frame rather than the accept-values frame
+  (frame-manager-display-input-editor-error
+   (frame-manager *application-frame*) 
+   *application-frame* stream error))
+
+(defmethod frame-manager-display-input-editor-error ((framem standard-frame-manager)
+						     (frame t) stream error)
+  ;;--- Resignal the error so the user can handle it
+  ;;--- (in lieu of HANDLER-BIND-DEFAULT)
+  (beep stream)
+  (remove-activation-gesture stream)
+  (with-input-editor-typeout (stream :erase t)
+    (format stream "~A~%Please edit your input." error))
+  ;; Now wait until the user forces a rescan by typing
+  ;; an input editing command
+  (loop (read-gesture :stream stream)))
+
+
 ;; OPTIONS is a list of a help type followed by a help string (or a function
 ;; of two arguments, a stream and the help string so far) A "help type" is
 ;; either a single keyword (either :TOP-LEVEL-HELP or :SUBHELP), or a list
diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp
index 190b002b..19abb05e 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.14 92/08/18 17:25:13 cer Exp Locker: cer $
+;; $fiHeader: interactive-protocol.lisp,v 1.15 92/08/21 16:33:56 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -874,16 +874,8 @@
 		       (reset-scan-pointer stream)
 		       (handler-bind 
 			   ((parse-error
-			      #'(lambda (error)
-				  ;;--- Resignal the error so the user can handle it
-				  ;;--- (in lieu of HANDLER-BIND-DEFAULT)
-				  (beep stream)
-				  (remove-activation-gesture stream)
-				  (with-input-editor-typeout (stream :erase t)
-				    (format stream "~A~%Please edit your input." error))
-				  ;; Now wait until the user forces a rescan by typing
-				  ;; an input editing command
-				  (loop (read-gesture :stream stream)))))
+			     #'(lambda (error)
+				 (display-input-editor-error stream error))))
 			 (return
 			   (let #+Genera ((sys:rubout-handler :read)) #-Genera ()
 			     (with-input-context (context) ()
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 01925143..cd75c8bd 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: output-protocol.lisp,v 1.18 92/08/18 17:25:17 cer Exp Locker: cer $
+;; $fiHeader: output-protocol.lisp,v 1.19 92/08/19 18:04:58 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -373,7 +373,8 @@
 					(* 4 (stream-character-width stream #\0))))))))
 	;; If the cursor moves outside the current region, expand
 	;; it to include the new cursor position.
-	(when (> cy (bounding-rectangle-height stream))
+	(when (and viewport
+		   (> cy (bounding-rectangle-height stream)))
 	  (multiple-value-bind (sx sy) (bounding-rectangle-position stream)
 	    (update-region stream 
 			   sx sy cx cy
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index 679157cd..7f6853cb 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.18 92/07/27 11:02:54 cer Exp $
+;; $fiHeader: recording-protocol.lisp,v 1.19 92/08/18 17:25:32 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -1035,8 +1035,8 @@
 	(let* ((stream (output-record-stream record))
 	       (viewport (pane-viewport stream)))
 	  (when viewport
-	    (update-scroll-bars viewport))
-	  (update-region stream nleft ntop nright nbottom))))))
+	    (update-scroll-bars viewport)
+	    (update-region stream nleft ntop nright nbottom)))))))
 
 ;;; DEFCLASS of OUTPUT-RECORDING-MIXIN, etc. is in STREAM-CLASS-DEFS
 (defmethod initialize-instance :after ((stream output-recording-mixin) &rest args)
diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp
index 96469943..98e21673 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.8 92/07/27 11:03:04 cer Exp $
+;; $fiHeader: view-defs.lisp,v 1.9 92/08/18 17:25:47 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -62,11 +62,13 @@
        ',name)))
 
 (define-gadget-view toggle-button)
-
 (define-gadget-view radio-box)
 (define-gadget-view check-box)
-
 (define-gadget-view slider)
+(define-gadget-view text-field)
+(define-gadget-view list-pane)
+(define-gadget-view option-pane)
+(define-gadget-view text-editor)
 
 ;;--- These three methods are the result of not including the
 ;;--- gadget class as a superclass of view class...
diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp
index 7e57f7b0..f326db47 100644
--- a/demo/cad-demo.lisp
+++ b/demo/cad-demo.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cad-demo.lisp,v 1.14 92/07/24 10:54:44 cer Exp $
+;; $fiHeader: cad-demo.lisp,v 1.15 92/08/18 17:26:16 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp
index b93eef71..33023f76 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.4 92/08/19 10:24:14 cer Exp Locker: cer $
+;; $fiHeader: graphics-editor.lisp,v 1.5 92/08/21 16:34:09 cer Exp Locker: cer $
 
 (in-package :clim-graphics-editor)
 
@@ -220,31 +220,66 @@
 
 ;;; The application itself
 
+(define-command-table graphics-editor-file-commands)
+(define-command-table graphics-editor-edit-commands)
+(define-command-table graphics-editor-option-commands)
+
 (define-application-frame graphics-editor (selected-object-mixin) 
-    ((objects :initform nil)
-     (counter :initform 0)
-     (last-box :initform nil)
-     (style :initform (make-line-style :thickness 1 :dashes nil))
-     (shape :initform :rectangle))
+			  ((objects :initform nil)
+			   (counter :initform 0)
+			   (last-box :initform nil)
+			   (style :initform (make-line-style :thickness 1 :dashes nil))
+			   (shape :initform :rectangle))
   (:command-definer define-graphics-editor-command)
-  (:command-table (graphics-editor :inherit-from (accept-values-pane)))
+  (:command-table (graphics-editor :inherit-from (accept-values-pane
+						  graphics-editor-file-commands
+						  graphics-editor-edit-commands
+						  graphics-editor-option-commands
+						  			  )
+				   ;;-- Should be inherit-keystrokes.
+				   ;;	   :inherit-menu t
+	   :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F)
+		  ("Edit" :menu graphics-editor-edit-commands :mnemonic #\E )
+		  ("Options" :menu graphics-editor-option-commands  :mnemonic #\O))))
   (:pointer-documentation t)
   ;; Three panes: a display pane, and command menu, and a modeless 
   ;; dialog containing the line style options
   (:panes
-    (display :application
-	     :incremental-redisplay t
-	     :display-after-commands t
-	     :display-function 'display-objects
-	     :scroll-bars :both)
-    (options :accept-values
-	     :display-function '(accept-values-pane-displayer 
-				  :displayer accept-graphics-editor-options)))
+   (display :application
+	    :incremental-redisplay t
+	    :display-after-commands t
+	    :display-function 'display-objects
+	    :scroll-bars :both)
+   (horizontal-options :accept-values
+		       :width :compute
+	    :display-function '(accept-values-pane-displayer 
+				:displayer (lambda (frame stream)
+					     (accept-graphics-editor-options frame stream
+						       :direction :horizontal))))
+   (vertical-options :accept-values
+		     :display-function '(accept-values-pane-displayer 
+					 :displayer (lambda (frame stream)
+						      (accept-graphics-editor-options 
+						       frame stream
+						       :direction :vertical)))))
   (:layouts
-    (default 
-      (vertically () 
-	(1/5 options)
-	(:fill display)))))
+   (default 
+       (vertically () 
+	   (1/5 horizontal-options)
+	 (:fill display)))
+   (other
+    (horizontally () 
+	(1/5 vertical-options)
+      (:fill display)))))
+
+(defmethod read-frame-command ((frame graphics-editor) 
+			       &key (stream *query-io*)		;frame-query-io?
+			       ;; should the rest of the *command-parser*
+			       ;; etc. variables be passed as keywords or bound?
+			       )
+  (read-command (frame-command-table frame) :use-keystrokes t :stream stream))
+
+;;; Presentation types
 
 (define-presentation-type-abbreviation line-thickness ()
   '((member 1 2 3 4) :name-key identity
@@ -261,47 +296,101 @@
 		  :line-thickness object))))
 
 (defun highlight-line-thickness (continuation object stream)
+  (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))
+
+(defun present-line-style (object stream &key acceptably)
+  (declare (ignore acceptably))
+  (let ((y (stream-line-height stream)))
+    (with-room-for-graphics (stream)
+      (draw-rectangle* stream 0 2 16 (- y 2)
+		       :filled nil :ink +background-ink+)
+      (draw-line* stream 0 (floor y 2) 16 (floor y 2)
+		  :line-dashes (eq object :dashed)))))
+
+(defun highlight-line-style (continuation object stream)
+  (surrounding-output-with-border (stream)
+      (funcall continuation object stream)))
+
+
+
+(define-presentation-type-abbreviation object-shape ()
+  '((member :oval :rectangle) :name-key identity
+			      :printer present-object-shape
+			      :highlighter highlight-object-shape))
+
+(defun present-object-shape (object stream &key acceptably)
+  (declare (ignore acceptably))
+  (let ((y (stream-line-height stream)))
+    (multiple-value-bind (left top bottom right)
+	(values 0 2 16 (- y 2))
+      (with-room-for-graphics (stream)
+	(ecase object
+	  (:rectangle
+	   (draw-rectangle* stream left top (* 2 bottom) (* 2 right) :filled nil))
+	  (:oval
+	   (draw-oval* stream 
+		       (/ (+ left right) 2)
+		       (/ (+ top bottom) 2)
+		       (/ (abs (- right left)) 2)
+		       (/ (abs (- bottom top)) 2) :filled nil)))))))
+
+(defun highlight-object-shape (continuation object stream)
   (surrounding-output-with-border (stream)
     (funcall continuation object stream)))
 
-(defmethod accept-graphics-editor-options ((frame graphics-editor) stream)
+
+;;; 
+(defmethod accept-graphics-editor-options ((frame graphics-editor) stream &key (direction :horizontal))
   (with-slots (style shape) frame
     (flet ((accept (type default prompt query-id 
 		    &optional (view (stream-default-view stream)))
 	     (let (object ignore changed)
-	       (formatting-cell (stream :align-x :center)
-		 (multiple-value-setq (object ignore changed)
-		   (accept type
-			   :stream stream :default default
-			   :query-identifier query-id :prompt prompt
-			   :view view)))
+	       (formatting-cell (stream :align-x (ecase direction
+						   (:horizontal :center)
+						   (:vertical :left)))
+		   (multiple-value-setq (object ignore changed)
+		     (accept type
+			     :stream stream :default default
+			     :query-identifier query-id :prompt prompt
+			     :view view)))
 	       (values object changed))))
       (declare (dynamic-extent #'accept))
       (terpri stream)
       (terpri stream)
       (formatting-table (stream :x-spacing '(3 :character))
-	(formatting-row (stream)
-	  (let ((thickness (line-style-thickness style))
-		(dashes (line-style-dashes style)))
-	    (multiple-value-bind (thickness thickness-changed)
-		(accept 'line-thickness thickness "Thickness" 'thickness)
-	      (declare (ignore ignore))
-	      (multiple-value-bind (dashes dashes-changed)
-		  (accept 'boolean dashes "Dashed" 'dashes)
-		(declare (ignore ignore))
-		(multiple-value-bind (new-shape shape-changed)
-		    (accept '(member :oval :rectangle) shape "Shape" 'shape)
-		  (when (or thickness-changed dashes-changed shape-changed)
-		    (setq style (make-line-style :thickness thickness
-						 :dashes dashes))
-		    (setq shape new-shape)
-		    (when (frame-selected-object frame)
-		      (setf (object-style (frame-selected-object frame))
-			(slot-value frame 'style))
-		      (setf (box-shape (frame-selected-object frame))
-			(slot-value frame 'shape))
-		      (tick-object (frame-selected-object frame))
-		      (redisplay-frame-pane frame 'display))))))))))))
+	  (flet ((do-body (stream)
+		   (let ((thickness (line-style-thickness style))
+			 (dashes (line-style-dashes style)))
+		     (multiple-value-bind (thickness thickness-changed)
+			 (accept 'line-thickness thickness "Thickness" 'thickness)
+		       (declare (ignore ignore))
+		       (multiple-value-bind (dashes dashes-changed)
+			   (accept 'line-style-type (if dashes :dashed :solid) "Line Style" 'dashes)
+			 (declare (ignore ignore))
+			 (setq dashes (eq dashes :dashed))
+			 (multiple-value-bind (new-shape shape-changed)
+			     (accept 'object-shape shape "Shape" 'shape)
+			   (when (or thickness-changed dashes-changed shape-changed)
+			     (setq style (make-line-style :thickness thickness
+							  :dashes dashes))
+			     (setq shape new-shape)
+			     (when (frame-selected-object frame)
+			       (setf (object-style (frame-selected-object frame))
+				 (slot-value frame 'style))
+			       (setf (box-shape (frame-selected-object frame))
+				 (slot-value frame 'shape))
+			       (tick-object (frame-selected-object frame))
+			       (redisplay-frame-pane frame 'display)))))))))
+	    (ecase direction
+	      (:horizontal (formatting-row (stream) (do-body stream)))
+	      (:vertical (formatting-column (stream) (do-body stream)))))))))
 
 (defmethod display-objects ((frame graphics-editor) stream)
   (dolist (object (slot-value frame 'objects))
@@ -381,16 +470,17 @@
 
 ;; Select an object by clicking "select" (Mouse-Left) on it.
 (define-graphics-editor-command com-select-object
-    ((object 'basic-object :gesture :select))
+    ((object 'box :gesture :select))
   (select-object *application-frame* object)
   (setf (slot-value *application-frame* 'style) (object-style object)
 	(slot-value *application-frame* 'shape) (box-shape object)))
 
 ;; Deselect an object by clicking the Deselect menu button, or by
 ;; clicking over blank area without moving the mouse.
-(define-graphics-editor-command (com-deselect-object :menu "Deselect") ()
-  (when (frame-selected-object *application-frame*)
-    (deselect-object *application-frame* (frame-selected-object *application-frame*))))
+
+(define-command (com-deselect-object :command-table graphics-editor-edit-commands :menu "Deselect") nil
+                (when (frame-selected-object *application-frame*)
+                  (deselect-object *application-frame* (frame-selected-object *application-frame*))))
 
 ;; Move an object by clicking Mouse-Middle on it and dragging the mouse.
 (define-graphics-editor-command com-move-object
@@ -448,25 +538,42 @@
 	(move-handle handle (- x dx) (- y dy))))))
 
 ;; OK, I added a menu button to clear the window.
-(define-graphics-editor-command (com-clear :menu t) ()
-  (with-slots (objects selected-object last-box) *application-frame*
-    (setq objects nil
-	  selected-object nil
-	  last-box nil)
-    (window-clear (get-frame-pane *application-frame* 'display))))
+
+(define-command (com-clear :command-table graphics-editor-edit-commands :menu t) nil
+                (with-slots (objects selected-object last-box) *application-frame*
+                            (setq objects nil selected-object nil last-box nil)
+                            (window-clear (get-frame-pane
+					   *application-frame* 'display))))
+
 
 ;; OK, I added a menu button to redisplay the window, too, although
 ;; it's only here for debugging.
-(define-graphics-editor-command (com-redisplay :menu t) ()
+
+(define-command (com-redisplay :command-table
+			       graphics-editor-edit-commands 
+			       :keystroke (:r :meta)
+			       :menu t) 
+    nil
   (redisplay-frame-pane *application-frame* 'display :force-p t))
 
-(define-graphics-editor-command (com-quit :menu t) ()
+(define-command (com-quit :command-table graphics-editor-file-commands
+			  :keystroke (:x :meta)
+			  :menu t) ()
   (frame-exit *application-frame*))
 
+(define-command (com-change-layout :command-table
+				   graphics-editor-option-commands 
+				   :keystroke (:l :meta)
+				   :menu t) ()
+  (let ((layouts (frame-all-layouts *application-frame*)))
+    (setf (frame-current-layout *application-frame*)
+      (or (second (member (frame-current-layout *application-frame*) layouts))
+	  (car layouts)))))
+
 
 (defvar *graphics-editors* nil)
 
-(defun do-graphics-editor (&key (port (find-port)) (force nil))
+(defun do-graphics-editor (&key (port (find-port)) (force t))
   (let* ((framem (find-frame-manager :port port))
 	 (frame 
 	   (let* ((entry (assoc port *graphics-editors*))
diff --git a/demo/plot.lisp b/demo/plot.lisp
index 8f2f4ff5..65a5a072 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: plot.lisp,v 1.5 92/07/27 11:03:34 cer Exp $
+;; $fiHeader: plot.lisp,v 1.6 92/08/18 17:26:23 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -551,6 +551,19 @@
 	  (accept 'string
 		  :default (nth i (slot-value frame 'x-labels))))))
 
+
+#+allegro
+(define-plot-demo-command (com-print-graph :name t :menu t)
+    ((printer '(member :lw :lw2 :lw3)
+	      :display-default t
+	      :default :lw2))
+  (with-open-stream (pipe (excl:run-shell-command  (format nil "lpr -P~A" printer)
+						   :input :stream :wait nil))
+    (with-output-to-postscript-stream (stream pipe :multi-page t)
+      (display-graph *application-frame* stream))))
+
+
+
 (define-plot-demo-command (com-edit-y-label :name t :menu t)
     ((i 'y-label :gesture :select))
   (with-application-frame (frame)
diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp
index f6f40974..22bdcc3f 100644
--- a/demo/sysdcl.lisp
+++ b/demo/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.14 92/07/27 11:03:36 cer Exp $
+;; $fiHeader: sysdcl.lisp,v 1.15 92/08/18 17:26:25 cer Exp Locker: cer $
 
 (in-package #-ansi-90 :user #+ansi-90 :common-lisp-user)
 
@@ -33,7 +33,11 @@
   ("graphics-editor" :load-before-compile ("demo-driver" "packages"))
   ("ico"	     :load-before-compile ("demo-driver" "packages"))
   ("browser"	     :load-before-compile ("demo-driver" "packages"))
-  ("demo-prefill"    :features (or Genera Cloe-Runtime)))
+  #+Allegro
+  ("process-browser" :load-before-compile ("demo-driver" "packages"))
+  ("bitmap-editor"    :load-before-compile ("demo-driver" "packages"))
+ 
+ ("demo-prefill"    :features (or Genera Cloe-Runtime)))
 
 #+Genera
 (clim-defsys:import-into-sct 'clim-demo 
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index 5262f8b6..fffd789b 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.8 92/07/01 15:47:55 cer Exp Locker: cer $
+;; $fiHeader: compile-1.lisp,v 1.9 92/08/21 16:34:17 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -28,6 +28,13 @@
 ;;;; (setq *ignore-package-name-case* t)
 
 (set-case-mode :case-insensitive-lower)
+
+#+ignore
+(progn
+  (compile-file "~/stuff/misc/new-slot-opt.cl")
+  (load "~/stuff/misc/new-slot-opt.fasl")
+  )
+
 (setf (sys:gsgc-switch :print) t)
 (setf (sys:gsgc-switch :stats) t)
 
@@ -59,6 +66,7 @@
    (clim-defsys::load-system sys))
   (load "postscript/sysdcl")
   (clim-defsys::compile-system 'postscript-clim :propagate t)
+  (clim-defsys::load-system 'postscript-clim)
   (compile-file-if-needed "test/test-suite")
   (load "demo/sysdcl")
   (clim-defsys::compile-system 'clim-demo :propagate t))
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index 53d189d1..f5f8e974 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,13 +20,20 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.9 92/07/27 19:30:16 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.10 92/08/21 16:34:21 cer Exp Locker: cer $
 
 ;;;; This should not matter
 ;;;; (setq *ignore-package-name-case* t)
 
 (set-case-mode :case-insensitive-lower)
 
+
+#+ignore
+(progn
+(compile-file "~/stuff/misc/new-slot-opt.cl")
+(load "~/stuff/misc/new-slot-opt.fasl")
+)
+
 (tenuring
    (let ((*load-source-file-info* t)
 	 (*load-xref-info* nil))
@@ -56,8 +63,7 @@
   ;;-- been loaded
   
   (tenuring
-   (load "postscript/sysdcl")
-   (clim-defsys::load-system 'postscript-clim))
+   (load "climps.fasl"))
 
   (compile-file-if-needed "test/test-suite")
 
@@ -72,6 +78,7 @@
      #-ignore
      (clim-defsys::load-system 'clim-demo)))
   
+
   (when (probe-file "/scm/4.1/sparc/src/code/")
     (let ((sys::*require-search-list*
 	   (cons (make-pathname :directory "/scm/4.1/sparc/src/code/"
@@ -83,7 +90,7 @@
 	    sys::*load-search-list*)))
       (tenuring (require :composer)))
   
-    (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/")
+    (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/"))
 
-    (tenuring
-     (load "misc/clos-preload.fasl" :if-does-not-exist nil))))
+  (tenuring
+   (load "misc/clos-preload.fasl" :if-does-not-exist nil)))
diff --git a/postscript/sysdcl.lisp b/postscript/sysdcl.lisp
index 9eeecd04..1143acf4 100644
--- a/postscript/sysdcl.lisp
+++ b/postscript/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;;; $fiHeader$
+;;; $fiHeader: sysdcl.lisp,v 1.1 92/08/19 10:28:02 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -11,7 +11,7 @@
 		       #-Genera (frob-pathname "postscript")
      :default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;"
 			      #-Genera (frob-pathname "postscript")
-     :needed-systems (clim-standalone)
+     #+ignore :needed-systems #+ignore (clim-standalone)
      :load-before-compile (clim-standalone))
   ("pkgdcl")
   ("postscript-port")
diff --git a/silica/db-border.lisp b/silica/db-border.lisp
index 4862ee22..7ced7448 100644
--- a/silica/db-border.lisp
+++ b/silica/db-border.lisp
@@ -5,7 +5,7 @@
 
 (in-package :silica)
 
-;; $fiHeader: db-border.lisp,v 1.9 92/07/20 15:59:04 cer Exp $
+;; $fiHeader: db-border.lisp,v 1.10 92/08/18 17:23:25 cer Exp Locker: cer $
 
 ;;; Border Panes
 
@@ -77,7 +77,9 @@
 ;;; Label panes
 
 (defparameter *default-label-text-style* 
-	      (make-text-style :sans-serif :italic :small))
+    ;;--- This defeats the resource mechanism
+    #-ignore nil
+    #+ignore (make-text-style :sans-serif :italic :small))
 
 (defclass label-pane (foreground-background-and-text-style-mixin labelled-gadget-mixin)
     ()
diff --git a/silica/db-box.lisp b/silica/db-box.lisp
index d33ffd3f..821999d8 100644
--- a/silica/db-box.lisp
+++ b/silica/db-box.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-box.lisp,v 1.19 92/07/20 15:59:05 cer Exp $
+;; $fiHeader: db-box.lisp,v 1.20 92/08/18 17:23:26 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -102,16 +102,16 @@
 	       '(:width :max-width :min-width :height :max-height :min-height)))
 
 (defmethod allocate-space ((box-pane hbox-pane) width height)
-  (with-slots (contents space space-requirement) box-pane
-    (unless space-requirement 
-      (compose-space box-pane :width width :height height))
-    (flet ((compose (x)
-	     (cond ((atom x) (compose-space x :height height))
-		   ((eq (car x) :fill) :fill)
-		   (t (make-space-requirement :height 0 :width (* (car x) width))))))
-      (declare (dynamic-extent #'compose))
-      (let ((sizes 
-	      (allocate-space-to-items
+  (with-slots (contents space) box-pane
+    (let ((space-requirement
+	   (compose-space box-pane :width width :height height)))
+      (flet ((compose (x)
+	       (cond ((atom x) (compose-space x :height height))
+		     ((eq (car x) :fill) :fill)
+		     (t (make-space-requirement :height 0 :width (* (car x) width))))))
+	(declare (dynamic-extent #'compose))
+	(let ((sizes 
+	       (allocate-space-to-items
 		width
 		space-requirement
 		contents
@@ -119,16 +119,16 @@
 		#'space-requirement-width
 		#'space-requirement-max-width
 		#'compose))
-	    (x 0))
-	(mapc #'(lambda (sheet size)
-		  (when (or (panep sheet)
-			    (and (consp sheet)
-				 (panep (second sheet))
-				 (setq sheet (second sheet))))
-		    (move-and-resize-sheet 
-		      sheet x 0 (frob-size size width x) height))
-		  (incf x size))
-	      contents sizes)))))
+	      (x 0))
+	  (mapc #'(lambda (sheet size)
+		    (when (or (panep sheet)
+			      (and (consp sheet)
+				   (panep (second sheet))
+				   (setq sheet (second sheet))))
+		      (move-and-resize-sheet 
+		       sheet x 0 (frob-size size width x) height))
+		    (incf x size))
+		contents sizes))))))
 
 
 (defclass vbox-pane (box-pane) ())
@@ -146,16 +146,16 @@
 	       `(:height :max-height :min-height :width :max-width :min-width)))
 
 (defmethod allocate-space ((box-pane vbox-pane) width height)
-  (with-slots (contents space space-requirement) box-pane
-    (unless space-requirement 
-      (compose-space box-pane :width width :height height))
-    (flet ((compose (x)
-	     (cond ((atom x) (compose-space x :width width))
-		   ((eq (car x) :fill) :fill)
-		   (t (make-space-requirement :width 0 :height (* (car x) height))))))
-      (declare (dynamic-extent #'compose))
-      (let ((sizes 
-	      (allocate-space-to-items
+  (with-slots (contents space) box-pane
+    (let ((space-requirement
+	   (compose-space box-pane :width width :height height)))
+      (flet ((compose (x)
+	       (cond ((atom x) (compose-space x :width width))
+		     ((eq (car x) :fill) :fill)
+		     (t (make-space-requirement :width 0 :height (* (car x) height))))))
+	(declare (dynamic-extent #'compose))
+	(let ((sizes 
+	       (allocate-space-to-items
 		height
 		space-requirement
 		contents
@@ -163,16 +163,16 @@
 		#'space-requirement-height
 		#'space-requirement-max-height
 		#'compose))
-	    (y 0))
-	(mapc #'(lambda (sheet size)
-		  (when (or (panep sheet)
-			    (and (consp sheet)
-				 (panep (second sheet))
-				 (setq sheet (second sheet))))
-		    (move-and-resize-sheet
-		      sheet 0 y width (frob-size size height y)))
-		  (incf y size))
-	      contents sizes)))))
+	      (y 0))
+	  (mapc #'(lambda (sheet size)
+		    (when (or (panep sheet)
+			      (and (consp sheet)
+				   (panep (second sheet))
+				   (setq sheet (second sheet))))
+		      (move-and-resize-sheet
+		       sheet 0 y width (frob-size size height y)))
+		    (incf y size))
+		contents sizes))))))
 
 ;;--- In theory this should work OK.
 (defun frob-size (wanted-size available where-we-are-now)
diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp
index 6135d3f3..556f673d 100644
--- a/silica/db-layout.lisp
+++ b/silica/db-layout.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-layout.lisp,v 1.22 92/07/20 15:59:09 cer Exp $
+;; $fiHeader: db-layout.lisp,v 1.23 92/08/18 17:23:30 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -411,13 +411,13 @@
 ;;;
 
 (defclass space-requirement-cache-mixin (layout-mixin)
-    ((space-requirement :initform nil)))
+    ((space-requirement-cache :initform nil)))
 
 (defmethod compose-space :around ((pane space-requirement-cache-mixin) &key width height)
   (declare (ignore width height))
-  (with-slots (space-requirement) pane
-    (or space-requirement
-	(setf space-requirement (call-next-method)))))
+  (with-slots (space-requirement-cache) pane
+    (or space-requirement-cache
+	(setf space-requirement-cache (call-next-method)))))
 
 (defmethod clear-space-requirement-cache ((pane layout-mixin))
   nil)
@@ -426,8 +426,8 @@
   nil)
 
 (defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin))
-  (with-slots (space-requirement) pane
-    (setf space-requirement nil)))
+  (with-slots (space-requirement-cache) pane
+    (setf space-requirement-cache nil)))
 
 (defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key)
   (clear-space-requirement-cache pane))
@@ -651,6 +651,7 @@
 (defclass layout-pane (sheet-mute-input-mixin
 		       pane-background-mixin
 		       space-requirement-cache-mixin
+		       space-requirement-mixin
 		       sheet-permanently-enabled-mixin
 		       composite-pane)
     ())
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index fa4ff795..dc57c29c 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.28 92/08/18 17:23:31 cer Exp Locker: cer $
+;; $fiHeader: db-scroll.lisp,v 1.29 92/08/19 18:04:15 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -161,6 +161,10 @@
 ;;--- 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.
+
+(defmethod note-sheet-grafted :before ((sheet scroll-bar))
+  (setf (scroll-bar-current-size sheet) nil))
+
 (defun update-scroll-bar (scroll-bar min max vmin vmax)
   (declare (optimize (safety 0) (speed 3)))
   (let ((current-size (scroll-bar-current-size scroll-bar))
diff --git a/silica/db-table.lisp b/silica/db-table.lisp
index 2cbb5128..01931efe 100644
--- a/silica/db-table.lisp
+++ b/silica/db-table.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-table.lisp,v 1.13 92/07/20 15:59:14 cer Exp $
+;; $fiHeader: db-table.lisp,v 1.14 92/08/18 17:23:35 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -104,28 +104,28 @@
       :min-height omin-h :height oh :max-height omax-h)))
 
 (defmethod allocate-space ((table table-pane) width height)
-  (with-slots (space-requirement column-space-requirements row-space-requirements) table
-    (unless space-requirement 
-      (compose-space table :width width :height height))
-    (let* ((contents (slot-value table 'contents))
+  (with-slots (column-space-requirements row-space-requirements) table
+    (let* ((space-requirement 
+	    (compose-space table :width width :height height))
+	   (contents (slot-value table 'contents))
 	   (row-heights
-	     (allocate-space-to-items
-	       height
-	       space-requirement
-	       row-space-requirements
-	       #'space-requirement-min-height
-	       #'space-requirement-height
-	       #'space-requirement-max-height
-	       #'identity))
+	    (allocate-space-to-items
+	     height
+	     space-requirement
+	     row-space-requirements
+	     #'space-requirement-min-height
+	     #'space-requirement-height
+	     #'space-requirement-max-height
+	     #'identity))
 	   (column-widths
-	     (allocate-space-to-items
-	       width
-	       space-requirement
-	       column-space-requirements
-	       #'space-requirement-min-width
-	       #'space-requirement-width
-	       #'space-requirement-max-width
-	       #'identity))
+	    (allocate-space-to-items
+	     width
+	     space-requirement
+	     column-space-requirements
+	     #'space-requirement-min-width
+	     #'space-requirement-width
+	     #'space-requirement-max-width
+	     #'identity))
 	   (y 0))
       (dotimes (row (array-dimension contents 0))
 	(let ((row-height (pop row-heights))
@@ -137,8 +137,8 @@
 	      (when (and item
 			 (sheet-enabled-p item))
 		(move-and-resize-sheet
-		  item x y 
-		  (min column-width (1- (- width x)))
-		  (min row-height (1- (- height y)))))
+		 item x y 
+		 (min column-width (1- (- width x)))
+		 (min row-height (1- (- height y)))))
 	      (incf x column-width)))
 	  (incf y row-height))))))
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 531cf7df..5613a52e 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.31 92/08/18 17:23:42 cer Exp Locker: cer $
+;; $fiHeader: gadgets.lisp,v 1.32 92/08/19 18:04:24 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -21,6 +21,7 @@
   (with-slots (text-style) pane
     ;; Convert the text style if necesary
     (etypecase text-style
+      (null)
       (cons (setq text-style (parse-text-style text-style)))
       (text-style nil))))
 
@@ -227,6 +228,10 @@
 (defparameter *default-slider-range-label-text-style*
 	      (make-text-style :sans-serif :bold :very-small))
 
+;;; Separator
+
+(defclass separator (oriented-gadget-mixin) ())
+
 ;;; Slider
 (defclass slider
 	  (value-gadget oriented-gadget-mixin range-gadget-mixin labelled-gadget-mixin)
@@ -415,11 +420,12 @@
     ())
 
 (defclass text-editor (text-field) 
-    ((ncolumns :initarg :ncolumns
-	       :accessor gadget-columns)
-     (nlines :initarg :nlines
-	     :accessor gadget-lines))
-  (:default-initargs :ncolumns 1 :nlines 1))
+	  ((ncolumns :initarg :ncolumns
+		     :accessor gadget-columns)
+	   (nlines :initarg :nlines
+		   :accessor gadget-lines)
+	   (editable-p :initarg :editable-p :accessor silica::gadget-editable-p))
+  (:default-initargs :ncolumns 1 :nlines 1 :editable-p t))
 
 
 ;;; Viewport
@@ -588,8 +594,9 @@
 (defclass list-pane (set-gadget-mixin value-gadget)
     ;;--- Should this be :ONE-OF/:SOME-OF, as radio boxes are?
     ((mode :initarg :mode :type (member :exclusive :nonexclusive)
-	   :accessor list-pane-mode))
-  (:default-initargs :mode :exclusive))
+	   :accessor list-pane-mode)
+     (visible-items :initarg :visible-items :reader gadget-visible-items))
+  (:default-initargs :mode :exclusive :visible-items nil))
  
 (defun compute-list-pane-selected-items (sheet value)
   (with-accessors ((items set-gadget-items)
@@ -624,7 +631,8 @@
 (defclass option-pane (set-gadget-mixin 
 		       labelled-gadget-mixin
 		       value-gadget)
-    ())
+	  ((printer :initarg :printer :reader option-pane-printer))
+  (:default-initargs :printer nil))
 
 
 ;; Callbacks on widgets generate these events
diff --git a/silica/pixmaps.lisp b/silica/pixmaps.lisp
index f743d45b..caec018a 100644
--- a/silica/pixmaps.lisp
+++ b/silica/pixmaps.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: pixmaps.lisp,v 1.6 92/08/19 10:23:43 cer Exp Locker: cer $
+;; $fiHeader: pixmaps.lisp,v 1.7 92/08/21 16:33:34 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -118,8 +118,9 @@
 			 :port (port sheet)
 			 :medium pixmap-medium
 			 :width width :height height)))
-    (setf (medium-foreground pixmap-medium) (medium-foreground stream)
-	  (medium-background pixmap-medium) (medium-background stream))
+    (with-sheet-medium (medium sheet)
+      (setf (medium-foreground pixmap-medium) (medium-foreground medium)
+	    (medium-background pixmap-medium) (medium-background medium)))
     (funcall continuation pixmap-sheet)
     (slot-value pixmap-medium 'pixmap)))
 
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index bc4eb427..66d50bb6 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.22 92/08/18 17:54:12 cer Exp $
+;; $fiHeader: sysdcl.lisp,v 1.23 92/08/21 16:34:02 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -130,6 +130,7 @@
   ("lisp-utilities")
   ("processes")
   ("queue")
+  ("timers" :load-before-compile ("queue" "processes"))
   ("protocols")
   ("autoconstructor")
 
@@ -421,6 +422,7 @@
   ("image")
   ("xt-frames")
   ("xm-frames")
+  ("xm-dialogs")
   ("xt-gadgets")
   ("xm-gadgets")
   ("xm-menus")
diff --git a/test/chess.lisp b/test/chess.lisp
index be49c0ca..5e8fd0c2 100644
--- a/test/chess.lisp
+++ b/test/chess.lisp
@@ -20,27 +20,37 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: chess.lisp,v 1.6 92/05/22 19:28:47 cer Exp $
+;; $fiHeader: chess.lisp,v 1.7 92/07/01 15:47:18 cer Exp Locker: cer $
 
 
 (in-package :clim-user)
 
 (define-application-frame chess-board ()
-    ((board :initform (make-array '(8 8)
-				  :initial-contents
-				  (make-chess-board-initial-state)))
-     (bitmaps :initform nil :allocation :class)
-     (subprocess :initform (create-chess-subprocess)))
+			  ((board :initform (make-array '(8 8)
+							:initial-contents
+							(make-chess-board-initial-state)))
+			   (bitmaps :initform nil :allocation :class)
+			   (subprocess :initform (create-chess-subprocess)))
   (:command-table chess-commands)
   (:panes
-    (board :application
-	   :incremental-redisplay t
-	   :scroll-bars :dynamic
-	   :width :compute :height :compute
-	   :max-width :compute :max-height :compute
-	   :display-function 'draw-chess-board))
+   (board :application
+	  :incremental-redisplay '(t :check-overlapping nil)
+	  :scroll-bars :dynamic
+	  :width :compute :height :compute
+	  :max-width :compute :max-height :compute
+	  :display-function 'draw-chess-board)
+   (status :application :scroll-bars nil :height '(1 :line)))
   (:layouts
-    (:default board)))
+   (:default (vertically () status board))))
+
+(defmethod update-status (frame message)
+  (let ((pane (get-frame-pane frame 'status)))
+    (window-clear pane)
+    (with-text-face (pane :bold)
+      (write-string message pane))))
+
+(defmethod read-frame-command :before  ((frame chess-board) &key)
+  (update-status frame "Your move"))
 
 (define-presentation-type chess-square ())
 
@@ -84,6 +94,7 @@
 	(apply #'aref board from)
 	(apply #'aref board from) nil)
       (redisplay-frame-pane *application-frame* (frame-standard-output *application-frame*))
+      (update-status *application-frame* "My Move......")
       (let ((res (read-chess-move-from-subprocess subprocess)))
 	(multiple-value-bind
 	    (from to)
@@ -127,6 +138,7 @@
   (list object *unsupplied-argument-marker*))
 
 (defmethod draw-chess-board (frame stream &key &allow-other-keys)
+  (stream-set-cursor-position stream 0 0)
   (formatting-table (stream)
       (dotimes (row 8)
 	(formatting-row (stream)
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index e6f065bc..0b90e475 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.30 92/08/19 10:24:06 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.31 92/08/21 16:34:04 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -523,13 +523,17 @@ people, shall not perish from the earth.
 		  (stream `(region-intersects-region-p ,region1 ,region2) 'form
 		   :single-box t)
 		(formatting-cell (stream :align-x :center)
-		  (let ((res (lookup-result region1 region2))
+		    (handler-case 
+			(let ((res (lookup-result region1 region2))
 			(result (region-intersects-region-p (eval region1) (eval region2))))
 		    (if (eq res :none)
 			(write-char #\space stream)	;the presentation demands some ink
 		      (with-text-face (stream
 				       (if (eq res result) nil :bold))
-			(format stream "~A" result)))))))))))
+			(format stream "~A" result))))
+		      (error ()
+			(with-text-face (stream :bold)
+			  (write-string "Error signalled")))))))))))
     (region-test-comment stream)))
 
 
@@ -1645,62 +1649,72 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(line-thickness 1)
 	(line-thickness-units :normal))
     (accepting-values (stream :own-window own-window)
-      (setq square-dimension
-	    (accept 'number :stream stream
-		    :prompt "Size of square" :default square-dimension))
-      (terpri stream)
-      (setq draw-circle
-	    (accept 'boolean :stream stream
-		    :prompt "Draw the circle" :default draw-circle))
-      (terpri stream)
-      (setq draw-square
-	    (accept 'boolean :stream stream
-		    :prompt "Draw the square" :default draw-square))
-      (terpri stream)
-      (setq draw-point
-	    (accept 'boolean :stream stream
-		    :prompt "Draw point" :default draw-point))
-      (terpri stream)
-      (setq draw-/-diagonal
-	    (accept 'boolean :stream stream
-		    :prompt "Draw / diagonal" :default draw-/-diagonal))
-      (terpri stream)
-      (setq draw-\\-diagonal
-	    (accept 'boolean :stream stream
-		    :prompt "Draw \\ diagonal" :default draw-\\-diagonal))
-      (terpri stream)
-      (setq line-thickness
-	    (accept 'number :stream stream
-		    :prompt "Line thickness" :default line-thickness))
-      (terpri stream)
-      (setq line-thickness-units
-	    (accept '(member :normal :point) :stream stream
-		    :prompt "Line style units" :default line-thickness-units))
-      (terpri stream)
-      (with-room-for-graphics (stream)
-	(let ((radius (/ square-dimension 2)))
-	  (with-drawing-options (stream :line-unit line-thickness-units
-					:line-thickness line-thickness)
-	    (when draw-square
-	      (draw-polygon* stream (list 0 0
-					  0 square-dimension
-					  square-dimension square-dimension
-					  square-dimension 0)
-			     :line-joint-shape :miter
-			     :filled nil))
-	    (when draw-circle
-	      (draw-circle* stream radius radius radius
-			    :filled nil))
-	    (when draw-point
-	      (draw-point* stream 
-			   (/ square-dimension 4)
-			   (/ square-dimension 2)))
-	    (when draw-/-diagonal
-	      (draw-line* stream 0 square-dimension square-dimension 0
-			  :line-cap-shape :round))
-	    (when draw-\\-diagonal
-	      (draw-line* stream 0 0 square-dimension square-dimension
-			  :line-cap-shape :round))))))))
+	(formatting-item-list (stream :n-columns 2)
+	    (formatting-cell (stream)
+		(setq square-dimension
+		  (accept 'number :stream stream
+			  :prompt "Size of square" :default square-dimension))
+	      (terpri stream)
+	      (setq draw-circle
+		(accept 'boolean :stream stream
+			:prompt "Draw the circle" :default draw-circle))
+	      (terpri stream)
+	      (setq draw-square
+		(accept 'boolean :stream stream
+			:prompt "Draw the square" :default draw-square))
+	      (terpri stream)
+	      (setq draw-point
+		(accept 'boolean :stream stream
+			:prompt "Draw point" :default draw-point))
+	      (terpri stream)
+	      (setq draw-/-diagonal
+		(accept 'boolean :stream stream
+			:prompt "Draw / diagonal" :default draw-/-diagonal))
+	      (terpri stream)
+	      (setq draw-\\-diagonal
+		(accept 'boolean :stream stream
+			:prompt "Draw \\ diagonal" :default draw-\\-diagonal))
+	      (terpri stream)
+	      (setq line-thickness
+		(accept 'number :stream stream
+			:prompt "Line thickness" :default line-thickness))
+	      (terpri stream)
+	      (setq line-thickness-units
+		(accept '(member :normal :point) :stream stream
+			:prompt "Line style units" :default line-thickness-units))
+	      (terpri stream))
+	  (formatting-cell (stream)
+	      (let (s)
+		(with-output-as-gadget (stream)
+		  (multiple-value-bind (sheets stream)
+		      (make-clim-application-pane :scroll-bars :both :width 150 :height 150)
+		    (setq s stream)
+		    sheets))
+		(let ((stream s))
+		  (with-room-for-graphics (stream :move-cursor nil)
+		    (let ((radius (/ square-dimension 2)))
+		      (with-drawing-options (stream :line-unit line-thickness-units
+						    :line-thickness line-thickness)
+			(when draw-square
+			  (draw-polygon* stream (list 0 0
+						      0 square-dimension
+						      square-dimension square-dimension
+						      square-dimension 0)
+					 :line-joint-shape :miter
+					 :filled nil))
+			(when draw-circle
+			  (draw-circle* stream radius radius radius
+					:filled nil))
+			(when draw-point
+			  (draw-point* stream 
+				       (/ square-dimension 4)
+				       (/ square-dimension 2)))
+			(when draw-/-diagonal
+			  (draw-line* stream 0 square-dimension square-dimension 0
+				      :line-cap-shape :round))
+			(when draw-\\-diagonal
+			  (draw-line* stream 0 0 square-dimension square-dimension
+				      :line-cap-shape :round))))))))))))
 
 
 ;;;; Benchmarks
@@ -1845,11 +1859,13 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(let ((time (funcall function :careful t)))
 	  (push (list (first benchmark) time) data))))
     (setq data (reverse data))
-    (with-open-file (s pathname :direction :output)
-      (format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
-      (format s "~%;on ~A ~A.~%" (machine-type) (machine-instance))
-      (when comment (format s ";~A~%" comment))
-      (print data s))))
+    (let ((*package* (or (find-package :common-lisp-user)
+			 (error "Package COMMON-LISP-USER not found"))))
+      (with-open-file (s pathname :direction :output)
+	(format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
+	(format s "~%;on ~A ~A.~%" (machine-type) (machine-instance))
+	(when comment (format s ";~A~%" comment))
+	(print data s)))))
 
 (define-command (generate-report :command-table benchmarks :menu t)
     ()
@@ -1914,16 +1930,25 @@ Luke Luck licks the lakes Luke's duck likes."))
       (flet ((print-out (description results)
 	       (when results
 		 (format s "~2%~A" description)
-		 (do ((name-and-number results (cdr name-and-number))
-		      (column 0 (1+ column)))
-		     ((null name-and-number))
-		   (let ((short-name (first (car name-and-number)))
-			 (number (second (car name-and-number))))
-		     (when (zerop (mod column 4))
-		       (format s "~%  "))
-		     (if number
-			 (format s "~22@<~A ~2$ ~>" short-name number)
-		         (format s "~22@T")))))))
+		 (let ((min nil))
+		   (do ((name-and-number results (cdr name-and-number)))
+		       ((null name-and-number))
+		     (let ((number (second (car name-and-number))))
+		       (when number
+			 (setq min (if min (min number min) number)))))
+		   (do ((name-and-number results (cdr name-and-number))
+			(column 0 (1+ column)))
+		       ((null name-and-number))
+		     (let ((short-name (first (car name-and-number)))
+			   (number (second (car name-and-number))))
+		       (when (zerop (mod column 4))
+			 (format s "~%  "))
+		       (if number
+			   (format s "~22@<~A ~2$ (~2$)~>" 
+				   short-name
+				   number
+				   (float (/ number min)))
+		         (format s "~22@T"))))))))
 	;; Print out the summaries
 	(format s "~&~%Summary results (geometric means of a number of relevant tests):~%~%Category~28T")
 	(dolist (short-name data)
diff --git a/test/test.lisp b/test/test.lisp
index 2623746e..11fdb305 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: test.lisp,v 1.36 92/07/24 10:54:39 cer Exp $
+;; $fiHeader: test.lisp,v 1.37 92/08/18 17:25:55 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -823,9 +823,14 @@
   (:layouts
    (:default c)))
 
-
 (define-application-frame tf106 () 
-			  ((square-dimension :initform 100)
+			  (
+			   (s :initform "hello")
+			   (r :initform "hello")
+			   (w :initform :oval)
+			   (v :initform nil)
+			   (u :initform :xxx)
+			   (square-dimension :initform 100)
 			   (draw-circle :initform t)
 			   (draw-square :initform t)
 			   (draw-/-diagonal :initform t)
@@ -841,9 +846,13 @@
       :height :compute :width :compute
       :display-function `(accept-values-pane-displayer
 			  :resynchronize-every-pass t
-			  :displayer display-frame-c)))
+			  :displayer display-frame-c))
+   (e :accept-values
+      :height :compute :width :compute
+      :display-function `(accept-values-pane-displayer
+			  :displayer display-frame-e)))
   (:layouts
-   (:default (vertically () c d))))
+   (:default (vertically () c d e))))
 
 (defun display-frame-b (frame stream &key max-width max-height)
   (declare (ignore max-width max-height))
@@ -912,3 +921,35 @@
       (accept '(member :normal :point) :stream stream
 	      :prompt "Line style units" :default line-thickness-units))
     (terpri stream)))
+
+
+(defun display-frame-e (frame stream)
+  (with-slots (s r w v u) frame
+    (setq s (accept 'string :stream stream
+		    :prompt "bar"
+		    :default s))
+    (terpri stream)
+    (setq r  (accept 'string :stream stream
+		     :prompt "foo"
+		     :view '(clim-internals::text-editor-view 
+			     :ncolumns 30
+			     :nlines 5)
+		     :default r))
+    (terpri stream)
+    (setq u (accept '(member :xxx :yyy :zyy)
+		    :view clim-internals::+list-pane-view+
+		    :stream stream
+		    :prompt "baz"
+		    :default u))
+    (terpri stream)
+    (setq w (accept '(member :oval :rectangle)
+		    :view clim-internals::+option-pane-view+
+		    :stream stream
+		    :prompt "bazzy"
+		    :default w))
+    (terpri stream)
+    (setq v (accept '(subset :x :y :z)
+		    :view clim-internals::+list-pane-view+
+		    :stream stream
+		    :prompt "barf"
+		    :default v))))
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 7f186260..435e3e33 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.26 92/08/19 18:05:33 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.27 92/08/21 16:34:29 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -58,6 +58,9 @@
 	      (list :orientation :horizontal))
     (values 
      'tk::xm-menu-bar 
+     ;;---- This seems important but why
+     ;;---- At a guess I would say its because the query-geometry gets
+     ;;---- all stupid if these resources are NIL
      (list :resize-height t
 	   :resize-width t))))
 
@@ -101,35 +104,47 @@
 				     (pane-frame sheet)
 				     commands-and-buttons))))
 	     (make-submenu (parent menu item)
-	       (let* ((submenu (make-instance
-				'tk::xm-pulldown-menu
-				:managed nil
-				:parent parent))
+	       (let* ((shell (make-instance 'xt::xm-menu-shell 
+					    :width 5 ; This widget is
+						     ; realized when
+						     ; it is created
+						     ; so we have to
+						     ; specify a size!
+					    :height 5
+					    :allow-shell-resize t
+					    :override-redirect t
+					    :parent parent))
+
+		      (submenu (make-instance 'xt::xm-row-column
+					      :managed nil
+					      :parent shell
+					      :row-column-type :menu-pulldown))
 		      (cb (make-instance 'xt::xm-cascade-button-gadget
 					 :parent parent
 					 :label-string menu
 					 :sub-menu-id submenu)))
 		 (declare (ignore cb))
-		 ;;-- At this point should write the code to lazily
-		 ;;-- create menus and update them if the table has
-		 ;;-- changed.
+		 (let ((mnem (getf (command-menu-item-options item) :mnemonic)))
+		   (when mnem (tk::set-values cb :mnemonic mnem)))
 		 (let* ((ct (find-command-table (second item)))
 			(tick (slot-value ct 'clim-internals::menu-tick)))
-		   (tk::add-callback (tk::widget-parent submenu)
-				     :popup-callback
-				     #'(lambda (ignore)
-					 (declare (ignore ignore))
-					 (let ((children
-						(tk::widget-children submenu)))
-					   (when (or (null children)
-						     (/= tick
-							 (setq tick
-							   (slot-value ct 'clim-internals::menu-tick))))
-					     (mapc #'tk::destroy-widget children)
-					     (make-menu-for-command-table
-					      ct
-					      submenu
-					      nil))))))))
+		   (make-menu-for-command-table ct submenu nil)
+		   ;;-- This is what we wanted to do but looses
+		   ;;-- because of the shared shell
+		  (setf (tk::widget-create-popup-child-proc shell)
+		    #'(lambda (shell)
+			(declare (ignore shell))
+			(let ((children
+			       (tk::widget-children submenu)))
+			  (when (or (null children)
+				    (/= tick
+					(setq tick
+					  (slot-value ct 'clim-internals::menu-tick))))
+			    (mapc #'tk::destroy-widget children)
+			    (make-menu-for-command-table
+			     ct
+			     submenu
+			     nil))))))))
 	     (make-menu-for-command-table-1 (command-table parent top)
 	       ;; Unless we are at the top level we want to have a
 	       ;; map-before callback that sets the sensitivity of
@@ -171,10 +186,13 @@
 			       (push (list item button)
 				     commands-and-buttons)
 			       
-			       (set-button-accelerator-from-keystroke button keystroke)
-			       
-			       (when (getf (command-menu-item-options
-					    item) :documentation)
+			       (set-button-accelerator-from-keystroke 
+				button keystroke)
+			
+			       (let ((mnem (getf (command-menu-item-options item) :mnemonic)))
+				 (when mnem (tk::set-values button :mnemonic mnem)))
+
+			       (when (getf (command-menu-item-options item) :documentation)
 				 (tk::add-callback
 				  button
 				  :help-callback
@@ -380,3 +398,5 @@
 (defmethod framem-menu-active-p ((framem motif-frame-manager) menu)
   (tk::is-managed-p menu))
 
+;;;; 
+
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index fbdeac06..2bf5cee5 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.43 92/08/19 10:24:22 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.44 92/08/21 16:34:30 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -28,6 +28,7 @@
 			 ;; Another experiment
 			 ;; experiment
 			 (outlined-pane motif-frame-pane)
+			 (silica::separator motif-separator)
 			 ;;
 			 (scroll-bar motif-scroll-bar)
 			 (slider motif-slider)
@@ -68,7 +69,8 @@
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (tk::get-values m :value))))
-      (tk::set-values m :value nv))))
+      (let ((*dont-invoke-callbacks* t))
+	(tk::set-values m :value nv)))))
 
 ;; Gadgets that have a :label initarg
 
@@ -252,10 +254,23 @@
 	(multiple-value-bind
 	    (mmin mmax)
 	    (tk::get-values mirror :minimum :maximum)
-	  (tk::set-values mirror
-			  :value (fix-coordinate 
-				  (compute-symmetric-value
-				   smin smax nv mmin mmax))))))))
+	  (let ((*dont-invoke-callbacks* t))
+	    (tk::set-values mirror
+			    :value (fix-coordinate 
+				    (compute-symmetric-value
+				     smin smax nv mmin mmax)))))))))
+
+;;; 
+
+(defclass motif-separator (motif-oriented-gadget
+			   xt-leaf-pane
+			   silica::separator)
+	  ())
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (parent t)
+						     (sheet motif-separator))
+  (values 'tk::xm-separator nil))
 
 ;;; Slider
 
@@ -513,14 +528,20 @@
 						      motif-text-editor))
   (with-accessors ((value gadget-value)
 		   (ncolumns silica::gadget-columns)
+		   (editable silica::gadget-editable-p)
 		   (nlines silica::gadget-lines)) sheet
     (values 'tk::xm-text
 	    (append
+	     (list :editable editable)
 	     (list :edit-mode :multi-line)
 	     (and ncolumns (list :columns ncolumns))
 	     (and nlines (list :rows nlines))
 	     (and value `(:value ,value))))))
 
+(defmethod (setf gadget-editable-p) :after (nv (te motif-text-editor))
+  (let ((m (sheet-direct-mirror m)))
+    (tk::set-values m :editable nv)))
+
 ;(defmethod compute-initial-mirror-geometry (parent (sheet motif-text-editor) initargs)
 ;  (multiple-value-bind (left top right bottom)
 ;      (sheet-actual-native-edges* sheet)
@@ -535,6 +556,7 @@
 ;	    (getf initargs :y) (floor top))
 ;    initargs))
 
+#+ignore
 (defmethod compose-space ((te motif-text-editor) &key width height)
   (declare (ignore width height))
   (let ((sr (call-next-method)))
@@ -547,7 +569,20 @@
 	:width width :min-width min-width :max-width +fill+
 	:height height :min-height min-height :max-height +fill+))))
 
-
+(defmethod compose-space ((te motif-text-editor) &key width height)
+  (declare (ignore width height))
+  (multiple-value-bind (font-list margin-height margin-width)
+      (tk::get-values (sheet-direct-mirror te) :font-list
+		      :margin-height :margin-width)
+    (let* ((max-width most-negative-fixnum)
+	   (max-height most-negative-fixnum))
+      (assert font-list)
+      (dolist (font font-list)
+	(let ((font (second font)))
+	  (maxf max-height (tk::font-height font))
+	  (maxf max-width (tk::font-width font))))
+      (make-space-requirement :width (+ (* 2 margin-width) (* max-width (silica::gadget-columns te)))
+			      :height (+ (* 2 margin-height) (* max-height (silica::gadget-lines te)))))))
 ;;; Toggle button
 
 (defclass motif-toggle-button (motif-labelled-gadget
@@ -563,10 +598,11 @@
 		   (indicator-type gadget-indicator-type)) sheet
     (values 'xt::xm-toggle-button 
 	    (append (list :set set)
-		    (list :indicator-type 
-			  (ecase indicator-type
-			    (:one-of :one-of-many)
-			    (:some-of :n-of-many)))))))
+		    (ecase indicator-type
+		      ;;--- How can we deal with this portably
+		      ((nil) (list :indicator-on nil :shadow-thickness 2))
+		      (:one-of (list :indicator-type :one-of-many))
+		      (:some-of (list :indicator-type :n-of-many)))))))
 
 (defmethod gadget-value ((gadget motif-toggle-button))
   (if (sheet-direct-mirror gadget)
@@ -577,7 +613,8 @@
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (tk::get-values m :set))))
-      (tk::set-values m :set nv))))
+      (let ((*dont-invoke-callbacks* t))
+	(tk::set-values m :set nv)))))
 
 #+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
@@ -836,6 +873,7 @@
 		   (value-key set-gadget-value-key)
 		   (test set-gadget-test)
 		   (mode list-pane-mode)
+		   (visible-items silica::gadget-visible-items)
 		   (name-key set-gadget-name-key)) sheet
     (let ((selected-items
 	   (compute-list-pane-selected-items sheet value)))
@@ -848,6 +886,7 @@
 		,(ecase mode
 		   (:exclusive :single-select)
 		   (:nonexclusive :multiple-select))
+		,@(and visible-items `(:visible-item-count ,visible-items))
 		:items ,(mapcar name-key items) 
 		:item-count ,(length items))))))
 
@@ -885,9 +924,10 @@
   (when (sheet-direct-mirror l)
     (let ((selected-items
 	   (compute-list-pane-selected-items l nv)))
-      (tk::set-values (sheet-direct-mirror l)
-		      :selected-item-count (length selected-items)
-		      :selected-items selected-items))))
+      (let ((*dont-invoke-callbacks* t))
+	(tk::set-values (sheet-direct-mirror l)
+			:selected-item-count (length selected-items)
+			:selected-items selected-items)))))
 
 ;;; Option buttons
 
@@ -899,14 +939,24 @@
 						     (sheet motif-option-pane))
   (with-accessors ((items set-gadget-items)
 		   (name-key set-gadget-name-key)
+		   (printer silica::option-pane-printer)
 		   (value-key set-gadget-value-key)) sheet
     (let ((pdm (make-instance 'xt::xm-pulldown-menu :managed nil :parent parent)))
       (setf (motif-option-menu-buttons sheet)
 	(mapcar #'(lambda (item)
-		    (let ((button 
-			   (make-instance 'tk::xm-push-button 
-					  :label-string (funcall name-key item)
-					  :parent pdm)))
+		    (let* ((name (funcall name-key item))
+			   (pixmap (unless (or (null printer) (eq printer #'write-token))
+				     (clim-internals::pixmap-from-menu-item 
+				      sheet name printer nil)))
+			   (button 
+			    (if (null pixmap)
+				(make-instance 'tk::xm-push-button 
+					       :label-string name
+					       :parent pdm)
+			      (make-instance 'tk::xm-push-button 
+					     :label-pixmap pixmap
+					     :label-type :pixmap
+					     :parent pdm))))
 		      (tk::add-callback  
 		       button
 		       :activate-callback
@@ -924,7 +974,8 @@
 
 (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback)
   (declare (ignore invoke-callback)) 
-  (set-option-menu-value gadget nv))
+  (let ((*dont-invoke-callbacks* t))
+    (set-option-menu-value gadget nv)))
 
 (defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane))
   (prog1 (call-next-method)
@@ -934,14 +985,21 @@
   (with-accessors ((items set-gadget-items)
 		   (value-key set-gadget-value-key)
 		   (test set-gadget-test)
+		   (printer silica::option-pane-printer)
 		   (name-key set-gadget-name-key)) gadget
     (when (sheet-direct-mirror gadget)
       (let* ((x (position nv items :test test :key value-key))
 	     (widget (sheet-direct-mirror gadget)))
 	(when x
 	  (tk::set-values widget :menu-history (nth x (motif-option-menu-buttons gadget)))
-	  (tk::set-values (tk::intern-widget (tk::xm_option_button_gadget widget))
-			  :label-string (funcall name-key (nth x items))))))))
+	  (let* ((name (funcall name-key (nth x items)))
+		 (pixmap (unless (or (null printer) (eq printer #'write-token))
+			   (clim-internals::pixmap-from-menu-item 
+			    gadget name printer nil)))
+		 (widget (tk::intern-widget (tk::xm_option_button_gadget widget))))
+	    (if pixmap
+		(tk::set-values widget :label-pixmap pixmap :label-type :pixmap)
+	      (tk::set-values widget :label-string name))))))))
 
 (defmethod frame-manager-notify-user ((framem motif-frame-manager)
 				      message-string 
@@ -1227,15 +1285,14 @@
       (when m
 	(tk::set-values 
 	 m 
-	 :width width
-	 :height (fix-coordinate (space-requirement-height csr))
 	 :pane-minimum (fix-coordinate (space-requirement-min-height csr))
 	 :pane-maximum (fix-coordinate (space-requirement-max-height csr)))))))
 
 (defmethod allocate-space ((fr motif-paned-pane) width height)
   (declare (ignore height))
   (dolist (child (sheet-children fr))
-    (tk::set-values (sheet-direct-mirror child) :width (fix-coordinate width))))
+    (let ((m (sheet-direct-mirror child)))
+      (when m (tk::set-values m :width (fix-coordinate width))))))
 
 ;; If one of these gadgets tries to change its size the drawing area
 ;; might very well let it.
@@ -1283,7 +1340,8 @@
 			   sheet-permanently-enabled-mixin
 			   layout-mixin
 			   pane)
-	  ((attachments :initform nil :initarg :attachments)))
+	  ((attachments :initform nil :initarg :attachments)
+	   (fraction-base :initform nil :initarg :fraction-base)))
 
 (defmethod initialize-instance :after ((pane motif-form-pane) &key
 							       frame-manager frame
@@ -1302,7 +1360,9 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-form-pane))
-  (values 'xt::xm-form nil))
+  (with-slots (fraction-base) sheet
+    (values 'xt::xm-form 
+	    (and fraction-base (list :fraction-base fraction-base )))))
 
 
 (defmethod (setf port) :around ((port motif-port) (sheet motif-form-pane) &key graft)
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 4b3a729a..70002a05 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.15 92/07/24 10:55:01 cer Exp Locker: cer $
+;; $fiHeader: xt-frames.lisp,v 1.16 92/08/21 16:34:32 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -66,13 +66,9 @@
 ;;;
 
 (defun command-button-callback (button dunno frame command-table item)
-  (distribute-event
-    (port frame)
-    (allocate-event 'presentation-event
-      :frame frame
-      :sheet (frame-top-level-sheet frame)
-      :presentation-type `(command :command-table ,command-table)
-      :value (second item))))
+  (execute-command-in-frame
+   frame (second item)
+   :presentation-type `(command :command-table ,command-table)))
 
 
 (defun frame-wm-protocol-callback (widget frame)
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index 985b26de..c55c25ec 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-gadgets.lisp,v 1.17 92/07/24 10:55:03 cer Exp $
+;; $fiHeader: xt-gadgets.lisp,v 1.18 92/08/18 17:26:38 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -100,8 +100,20 @@
   (let ((pixel (decode-color medium ink)))
     (list :foreground pixel)))
 
-(defclass xt-pane (pane) ())
+(defclass xt-pane (pane) 
+	  ;;--- Is this useful a hack enabling things to be passed through
+	  ;;--- to the mirror
+	  ((silica::mirror-initargs  :initarg :mirror-initargs))
+  (:default-initargs :mirror-initargs nil))
 
+(defmethod find-widget-class-and-initargs-for-sheet :around ((port xt-port)
+							     (parent t)
+							     (sheet xt-pane))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (values class (append (slot-value sheet 'silica::mirror-initargs) initargs))))
+	    
 (defmethod note-gadget-activated :after ((client t) (gadget xt-pane))
   (let (m)
     (when (setq m (sheet-direct-mirror gadget))
@@ -121,6 +133,8 @@
 			xt-pane)
 	  ())
 
+
+
 ;;--- This isn't really right.  Genera and CLX ports have kludges
 ;;--- for the time being, too.
 (defmethod sheet-shell (sheet)
@@ -151,8 +165,19 @@
 
 
 (defun set-button-accelerator-from-keystroke (button keystroke)
-  ;;-- Somehow we have to convert the keystroke into some text and
-  ;;-- some character so that pressing it will have an effect
   (when keystroke 
-    (tk::set-values button 
-		    :accelerator-text (princ-to-string keystroke))))
+    (let ((accel (format nil "<Key>~A" (car keystroke)))
+	  (accel-text (format nil "~A" (car keystroke))))
+      (dolist (modifier (cdr keystroke))
+	(setq accel-text
+	  (concatenate 'string 
+	    (case modifier (:control "Ctrl+") (:meta "Alt+") (t ""))
+	    accel-text))
+	(setq accel
+	  (concatenate 'string 
+	    (case modifier (:control "Ctrl") (:meta "Mod1") (t ""))
+	    accel)))
+      (tk::set-values button 
+		      :accelerator accel
+		      :accelerator-text accel-text))))
+
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index c3bb57fb..2cad575a 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.34 92/08/18 17:54:32 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.35 92/08/19 10:24:25 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -173,6 +173,7 @@
 
 (defparameter *use-color* t)		; For debugging monochrome
 (defun color-medium-p (medium)
+  ;;-- This should just look at this port
   (and *use-color*
        (let ((display (port-display (port (medium-sheet medium)))))
 	 (> (x11:xdefaultdepth display (tk::display-screen-number display)) 2))))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index fdba30a1..34bdf55c 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.40 92/08/18 17:26:44 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.41 92/08/18 17:54:34 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -626,7 +626,11 @@
 	  (let ((frame (pane-frame sheet)))
 	    (when frame (setf (getf initargs :name) (string (frame-name frame)))))
 	  (apply #'make-instance class :parent (find-shell-parent port sheet) initargs))
-        (sheet-mirror ma))))
+        (sheet-mirror-for-parenting ma))))
+
+(defmethod sheet-mirror-for-parenting ((sheet sheet))
+  ;; There might be a situation where a sheet is mirrored by a whil
+  (sheet-mirror sheet))
 
 (defmethod find-shell-of-calling-frame ((sheet sheet))
   (find-shell-of-calling-frame (pane-frame sheet)))
@@ -1208,13 +1212,16 @@ the geometry of the children. Instead the parent has control. "))
 |#
 
 
+(defvar *dont-invoke-callbacks* nil)
+
 (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet)))
   (declare (ignore widget))
-  (distribute-event
-   (port sheet)
-   (allocate-event 'value-changed-gadget-event
-     :gadget sheet
-     :value value)))
+  (unless *dont-invoke-callbacks*
+    (distribute-event
+     (port sheet)
+     (allocate-event 'value-changed-gadget-event
+		     :gadget sheet
+		     :value value))))
 
 
 (defmethod queue-drag-event (widget sheet &optional (value (gadget-value sheet)))
@@ -1244,18 +1251,34 @@ the geometry of the children. Instead the parent has control. "))
 	   silica::*ports*))
 
 
-(defmethod port-canonicalize-gesture-spec ((port xt-port) keysym &optional shifts)
+;(defmethod port-canonicalize-gesture-spec ((port xt-port) keysym &optional shifts)
+;  (declare (optimize (speed 3) (safety 0)))
+;  ;; Here, we must take the gesture spec, turn it back into
+;  ;; a keycode, then see what the keysyms are for that keycode
+;  (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym))
+;		      (keysym->xt-keysym (xt-keysym->keysym (char-code keysym)))
+;		    (keysym->xt-keysym keysym)))
+;	(x-keycode nil))
+;    (unless x-keysym 
+;      (return-from port-canonicalize-gesture-spec nil))
+;    (cons keysym shifts)))
+
+(defmethod port-canonicalize-gesture-spec 
+	   ((port xt-port) gesture-spec &optional modifier-state)
   (declare (optimize (speed 3) (safety 0)))
-  ;; Here, we must take the gesture spec, turn it back into
-  ;; a keycode, then see what the keysyms are for that keycode
-  (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym))
-		      (keysym->xt-keysym (xt-keysym->keysym (char-code keysym)))
-		    (keysym->xt-keysym keysym)))
-	(x-keycode nil))
-    (unless x-keysym 
-      (return-from port-canonicalize-gesture-spec nil))
-    (cons keysym shifts)))
-
+  (multiple-value-bind (keysym shifts)
+      (if modifier-state
+	  (values gesture-spec modifier-state)
+	  (parse-gesture-spec gesture-spec))
+    ;; Here, we must take the gesture spec, turn it back into
+    ;; a keycode, then see what the keysyms are for that keycode
+    (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym))
+			(keysym->xt-keysym (xt-keysym->keysym (char-code keysym)))
+			(keysym->xt-keysym keysym)))
+	  (x-keycode nil))
+      (unless x-keysym 
+	(return-from port-canonicalize-gesture-spec nil))
+      (cons keysym shifts))))
 
 (defmethod port-set-pointer-position ((port xt-port) pointer x y)
   (let* ((sheet (pointer-sheet pointer))
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index ad05a653..92576c8d 100644
--- a/tk/callbacks.lisp
+++ b/tk/callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: callbacks.lisp,v 1.15 92/06/16 15:01:05 cer Exp Locker: cer $
+;; $fiHeader: callbacks.lisp,v 1.16 92/06/23 08:19:06 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -65,6 +65,27 @@
 	    (list (new-callback-id) (cons function args) type)
 	    (widget-callback-data widget))))))
 
+
+(defun-c-callable create-popup-child-proc-function  ((widget :unsigned-long))
+  (create-popup-child-proc-function-1 widget))
+
+(defun create-popup-child-proc-function-1 (widget)
+  (let* ((widget (find-object-from-address widget))
+	 (function (or (cdr (assoc :create-popup-child-proc (widget-callback-data widget)))
+		       (error "cannot find create-popup-childp-proc ~S" widget))))
+    (funcall function widget)))
+
+
+(defvar *create-popup-child-proc-function-address* 
+    (ff:register-function 'create-popup-child-proc-function))
+
+(defun (setf widget-create-popup-child-proc) (function widget)
+  (push
+   (cons :create-popup-child-proc function)
+   (widget-callback-data widget))
+  (set-values widget :create-popup-child-proc *create-popup-child-proc-function-address*)
+  function)
+  
 (defun remove-all-callbacks (widget callback-name)
   (xt_remove_all_callbacks widget (convert-callback-name callback-name)))
 
@@ -81,7 +102,7 @@
 
 (defparameter *callback-name-alist* 
     (mapcar #'process-callback-alist-component
-	  '(
+	    '(
 	    ("activateCallback" :activate)
 	    ("armCallback")           
 	    ("disarmCallback")        
@@ -144,3 +165,5 @@
   (values (x-drawing-area-callback-window call-data)
 	  (x-drawing-area-callback-event call-data)))
 
+
+  
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index 5b9c796f..d4298fa4 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-ol.lisp,v 1.15 92/08/19 10:23:33 cer Exp $
+;; $fiHeader: load-ol.lisp,v 1.16 92/08/21 16:33:32 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -40,7 +40,7 @@
 				sys::*libx11-pathname*)
 	:print t))
 
-(unless (ff:get-entry-point (ff:convert-to-lang "_XtAppIntervalNextTimer"))
+(unless (ff:get-entry-point (ff:convert-to-lang "XtAppIntervalNextTimer"))
     (load "xtsupport.o"
 	  :system-libraries (list sys::*libxt-pathname*
 				  sys::*libx11-pathname*)
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index c6aaee3c..38f5f322 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.18 92/08/18 17:53:36 cer Exp Locker: cer $
+;; $fiHeader: load-xm.lisp,v 1.19 92/08/19 10:23:34 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -41,7 +41,7 @@
 				sys::*libx11-pathname*)
 	:print t))
 
-(unless (ff:get-entry-point (ff:convert-to-lang "_XtAppIntervalNextTimer"))
+(unless (ff:get-entry-point (ff:convert-to-lang "XtAppIntervalNextTimer"))
     (load "xtsupport.o"
 	  :system-libraries (list sys::*libxt-pathname*
 				  sys::*libx11-pathname*)
diff --git a/tk/resources.lisp b/tk/resources.lisp
index dce12bb5..626f10c9 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.28 92/07/08 16:28:50 cer Exp $
+;; $fiHeader: resources.lisp,v 1.29 92/08/18 17:53:44 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -73,6 +73,13 @@
 				     :column
 				     :none))
 
+(define-enumerated-resource row-column-type (:work-area 
+					     :menu-bar 
+					     :menu-pulldown
+					     :menu-popup
+					     :menu-option))
+
+
 (define-enumerated-resource edit-mode (:multi-line :single-line))
 
 (define-enumerated-resource visual-policy (:variable :constant))
@@ -597,4 +604,11 @@
 
 (defmethod convert-resource-out ((parent t) (typep (eql 'pointer)) value)
   value)
-				 
+
+;;;			 
+
+(defmethod convert-resource-out ((parent t) (typep (eql 'key-sym)) value)
+  (char-int value))
+
+(defmethod convert-resource-in ((parent t) (typep (eql 'key-sym)) value)
+  (cltl1:int-char value))
diff --git a/tk/widget.lisp b/tk/widget.lisp
index b2af6fca..eb8a8a46 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: widget.lisp,v 1.23 92/07/27 19:29:18 cer Exp $
+;; $fiHeader: widget.lisp,v 1.24 92/08/18 17:53:46 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -240,12 +240,16 @@
 
 
 (defun describe-widget (w)
-  (dolist (r (class-resources (class-of w)))
-    (format t "~S : ~S~%"
-	    (resource-name r)
-	    (handler-case
-		(get-values w (intern (resource-name r) :keyword))
-	      (error (c) c "Get-values failed!")))))
+  (flet ((describe-resources (resources)
+	   (dolist (r resources)
+	     (format t "~S : ~S~%"
+		     (resource-name r)
+		     (handler-case
+			 (get-values w (intern (resource-name r) :keyword))
+		       (error (c) c "Get-values failed!"))))))
+    (describe-resources (class-resources (class-of w)))
+    (when (tk::widget-parent w)
+      (describe-resources (class-constraint-resources (class-of (tk::widget-parent w)))))))
 
 (defun set-sensitive (widget value)
   (xt_set_sensitive widget (if value 1 0)))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index a4967734..46b9bd0c 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.23 92/07/24 10:53:40 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.24 92/08/18 17:53:48 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -579,3 +579,14 @@
 	  (values-list (cdr result)))
        (x11:xungrabserver .display.)
        (x11:xflush .display.))))
+
+;;; Visuals
+
+(defun screen-root-visual-class (screen)
+  (ecase (x11::visual-class (x11::screen-root-visual screen))
+    (0 :static-gray)
+    (2 :static-color)
+    (4 :true-color)
+    (1 :gray-scale)
+    (3 :pseudo-color)
+    (5 :direct-color)))
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index 32293900..1885080d 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-widgets.lisp,v 1.7 92/07/27 19:29:20 cer Exp $
+;; $fiHeader: xm-widgets.lisp,v 1.8 92/08/18 17:53:51 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -52,6 +52,14 @@
 					  (string-to-char*
 					   "deleteResponse")))
 
+(tk::add-resource-to-class (find-class 'xm-text)
+			   (make-instance 'resource
+					  :name :font-list
+					  :type 'font-list
+					  :original-name 
+					  (string-to-char*
+					   "fontList")))
+
 
 (tk::add-resource-to-class (find-class 'vendor-shell)
 			   (make-instance 'resource
@@ -61,6 +69,14 @@
 					  (string-to-char*
 					   "keyboardFocusPolicy")))
 
+(tk::add-resource-to-class (find-class 'xm-cascade-button-gadget)
+			   (make-instance 'resource
+					  :name :label-type
+					  :type 'tk::label-type
+					  :original-name 
+					  (string-to-char*
+					   "labelType")))
+
 
 ;; Moved here as to be after loading xm-funs.
 
diff --git a/utils/packages.lisp b/utils/packages.lisp
index f7413a71..68606c88 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.24 92/07/27 11:01:52 cer Exp $
+;; $fiHeader: packages.lisp,v 1.25 92/08/18 17:24:11 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2287,13 +2287,21 @@
     ;; Presentation types
     *input-context*
     *null-presentation*
+    +check-box-view+
     +gadget-dialog-view+
     +gadget-menu-view+
     +gadget-view+
+    +list-pane-view+
+    +option-pane-view+
     +pointer-documentation-view+
+    +radio-box-view+
+    +slider-view+
+    +text-field-view+
+    +text-editor-view+
     +textual-dialog-view+
     +textual-menu-view+
     +textual-view+
+    +toggle-button-view+
     accept
     accept-from-string
     accept-1
@@ -2629,6 +2637,7 @@
     interactor-pane
     layout-frame
     make-application-frame
+    make-command-timer
     note-command-disabled
     note-command-enabled
     note-frame-disabled
@@ -2741,6 +2750,7 @@
     check-box-current-selection
     check-box-pane
     check-box-selections
+    check-box-view
     deactivate-gadget
     disarmed-callback
     drag-callback
@@ -2768,6 +2778,7 @@
     labelled-gadget-mixin
     list-pane
     list-pane-mode
+    list-pane-view
     menu-bar
     menu-bar-command-table
     menu-button
@@ -2775,6 +2786,7 @@
     note-gadget-activated
     note-gadget-deactivated
     option-pane
+    option-pane-view
     oriented-gadget-mixin
     push-button
     push-button-pane
@@ -2783,11 +2795,13 @@
     radio-box-current-selection
     radio-box-pane
     radio-box-selections
+    radio-box-view
     scroll-bar
     scroll-bar-current-size
     scroll-bar-current-value
     scroll-bar-drag-callback
     scroll-bar-pane
+    separator
     set-gadget-items
     set-gadget-name-key
     set-gadget-test
@@ -2795,13 +2809,17 @@
     slider
     slider-decimal-places
     slider-pane
+    slider-view
     text-editor
     text-editor-pane
+    text-editor-view
     text-field
     text-field-pane
+    text-field-view
     toggle-button
     toggle-button-indicator-type
     toggle-button-pane
+    toggle-button-view
     value-changed-callback
     value-gadget
     with-output-as-gadget
diff --git a/utils/processes.lisp b/utils/processes.lisp
index 3fef3f56..9b7d9bbd 100644
--- a/utils/processes.lisp
+++ b/utils/processes.lisp
@@ -1,11 +1,13 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: processes.lisp,v 1.7 92/07/24 10:54:08 cer Exp $
+;; $fiHeader: processes.lisp,v 1.8 92/08/18 17:24:14 cer Exp Locker: cer $
 
 (in-package :clim-utils)
 
 "Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
- Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates.
+ Portions copyright (c) 1992, Franz Inc"
+
 
 ;;; Locks
 
@@ -312,3 +314,4 @@
 		     'process-interrupt process closure))
   }
   )
+
-- 
GitLab