From e9bcb2192aea572c55d2f62f4bb5dac669095412 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Wed, 6 May 1992 15:38:00 +0000
Subject: [PATCH] fixes

---
 Makefile                     |  23 +-
 clim/accept-values.lisp      |  38 +++-
 clim/db-stream.lisp          | 164 +++++++++++---
 clim/frames.lisp             |  47 ++--
 clim/gadget-output.lisp      |  77 ++++---
 clim/menus.lisp              |  23 +-
 clim/recording-protocol.lisp |  11 +-
 silica/db-box.lisp           |  87 +++++---
 silica/db-layout.lisp        | 200 ++++++++++++++----
 silica/db-scroll.lisp        |   5 +-
 silica/framem.lisp           |  18 +-
 silica/gadgets.lisp          |  38 +++-
 silica/layout.lisp           |  43 ++--
 silica/port.lisp             |   5 +-
 test/test.lisp               | 195 +++++++++++++++--
 tk-silica/xm-frames.lisp     |  22 +-
 tk-silica/xm-gadgets.lisp    | 400 +++++++++++++++++++++--------------
 tk-silica/xm-menus.lisp      |  60 +++---
 tk-silica/xt-gadgets.lisp    |  16 +-
 tk-silica/xt-silica.lisp     |  22 +-
 tk/callbacks.lisp            |  17 +-
 tk/resources.lisp            |   4 +-
 tk/xm-defs.lisp              |  16 +-
 tk/xm-funs.lisp              |   8 +-
 utils/packages.lisp          |  14 +-
 25 files changed, 1140 insertions(+), 413 deletions(-)

diff --git a/Makefile b/Makefile
index 3e1978ed..b4661cbb 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.24 92/04/28 09:26:11 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.25 92/04/30 09:09:48 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
@@ -6,6 +6,17 @@ CL	= /vapor/usr/tech/cer/cl/src/dcl
 DUMP-CL	= $(CL)
 CLOPTS	= -qq
 
+# Training
+TRAIN_LISP= (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \
+		(clim-user::train-clim-2) \
+		(exit 0) 
+
+TRAIN_TEXT = \
+	$(ECHO) "\
+	$(TRAIN_LISP) \
+" | $(CLIM) $(CLOPTS) -batch \
+	; echo CLIM trained!!!!	
+
 # Info
 LOAD_SOURCE_FILE_INFO=t
 RECORD_SOURCE_FILE_INFO=t
@@ -258,6 +269,9 @@ OPENLOOK-OBJS = $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS)
 
 default: all-xm
 
+train-clim-xm:	
+	(make all-xm train ; make clim-xm) |& mail cer
+
 all-xm:	compile-xm cat-xm clim-xm
 all-ol:	compile-ol cat-ol clim-ol
 
@@ -355,11 +369,8 @@ clim-small:	FORCE
 # Training
 
 train	:	FORCE
-	$(ECHO) "\
-		(load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \
-		(clim-user::train-clim-2) \
-		(exit 0) " | $(CLIM) $(CLOPTS) -batch
-	echo CLIM trained!!!!	
+	$(TRAIN_TEXT)
+
 # Misc
 
 
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index 654d1be2..5b5c6ef5 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.17 92/04/28 09:25:37 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.18 92/04/30 09:09:26 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -267,7 +267,8 @@
 
 #+Silica
 (defun invoke-accepting-values (stream continuation
-				 &key frame-class own-window exit-boxes
+				 &key frame-class own-window
+				      exit-boxes (resize-frame nil)
 				      (initially-select-query-identifier nil)
 				      (resynchronize-every-pass nil) (check-overlapping t)
 				      label x-position y-position width height)
@@ -292,7 +293,8 @@
 					      :initially-select-query-identifier
 					        initially-select-query-identifier
 					      :resynchronize-every-pass
-					        resynchronize-every-pass
+					      resynchronize-every-pass
+					      :resize-frame resize-frame 
 					      :check-overlapping
 					      check-overlapping)))
 	   ;; What do we do about sizing?????
@@ -340,7 +342,7 @@
 	  avv avv-record)
       (letf-globally (((stream-default-view stream) 
 		       (port-dialog-view (port stream))))
-	(flet ((run-continuation (stream avv-record)
+	(labels ((run-continuation (stream avv-record)
 		 (setf (slot-value stream 'avv-record) avv-record)
 		 (setf (slot-value stream 'avv-frame) frame)
 		 (with-output-recording-options (stream :draw nil :record t)
@@ -357,6 +359,8 @@
 		   (com-edit-avv-choice initial-query)
 		   (redisplay avv stream :check-overlapping check-overlapping))
 		 (loop
+		   (when (frame-resizable frame)
+		     (size-panes-appropriately))
 		   (let ((command
 			   (let ((command-stream (slot-value stream 'stream)))
 			     ;; While we're reading commands, restore the view
@@ -380,7 +384,24 @@
 		     (setf (slot-value avv-record 'resynchronize) nil)
 		     (when exit-button-record
 		       (redisplay exit-button-record exit-button-stream))
-		     (redisplay avv stream :check-overlapping check-overlapping)))))
+		     (redisplay avv stream :check-overlapping
+				check-overlapping))))
+	       (size-panes-appropriately ()
+		 (changing-space-requirements ()
+                    ;; We really want to specify the min/max sizes of
+                    ;; the exit-button pane also
+                    (size-menu-appropriately
+		     exit-button-stream
+		     :size-fn
+		     #'(lambda (pane w h)
+			 (change-space-requirement pane 
+			  :width w :min-width w :max-width w
+			  :height h :min-height h :max-height h)))
+		    (size-menu-appropriately own-window
+					     :width own-window-width
+					     :height own-window-height
+					     :right-margin own-window-right-margin
+					     :bottom-margin own-window-bottom-margin))))
 	  (declare (dynamic-extent #'run-continuation #'run-avv))
 	  (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog")
 	    (setq avv
@@ -401,12 +422,7 @@
 					      (stream-default-view stream)))))))
 	    (unwind-protect
 		(cond (own-window
-		       (size-menu-appropriately exit-button-stream)
-		       (size-menu-appropriately own-window
-						:width own-window-width
-						:height own-window-height
-						:right-margin own-window-right-margin
-						:bottom-margin own-window-bottom-margin)
+		       (size-panes-appropriately)
 		       (multiple-value-bind (x y)
 			   #-Silica
 			   (stream-pointer-position-in-window-coordinates
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 0447e8b4..893146a2 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1990 by Xerox Corporations.  All rights reserved.
 ;;;
-;; $fiHeader: db-stream.lisp,v 1.13 92/04/21 16:12:58 cer Exp Locker: cer $
+;; $fiHeader: db-stream.lisp,v 1.14 92/04/30 09:09:28 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -116,32 +116,133 @@
 	   ((pane clim-stream-pane) &key &allow-other-keys)
   (setf (sheet-transformation pane) +identity-transformation+))
 
+;;-- Althought the unit options are mostly applicable here I guess
+;;-- other classes might want to use it also
+;;-- Perhaps we add a compose-space method on pane which does this.
+;;-- Perhaps the class hierarchy needs a big sort out
+
+(defmacro with-space-requirement ((sr &rest vars) &body body)
+  ;; A handy macro that makes it slightly easy to manipulate space requirements
+  (unless vars
+    (setq vars '(sr-width sr-min-width sr-max-width sr-height sr-min-height sr-max-height)))
+  `(multiple-value-bind
+       ,vars
+       (space-requirement-components ,sr) 
+     (macrolet ((do-with-space-req-components (operator var vars &body body)
+		 `(,operator
+		   ,@(mapcar #'(lambda (a-var)
+				 `(symbol-macrolet ((,var ,a-var))
+				    ,@body))
+			     vars)))
+		(make-sr ()
+		  `,'(make-space-requirement
+		    ,@(mapcan #'list '(:width :min-width :max-width
+				       :height :min-height :max-height)
+			      vars))))
+       ,@body)))
+
 (defmethod compose-space ((pane clim-stream-pane) &key width height)
   (let ((sr (call-next-method)))
-    (let ((sr-components
-	    (multiple-value-list (space-requirement-components sr))))
-      (when (member :compute sr-components)
-	(multiple-value-bind (width height)
-	    (let ((record
-		    (with-output-to-output-record (pane)
-		      (invoke-pane-redisplay-function 
-			(pane-frame pane) pane
-			;;--- Are all pane display functions prepared to
-			;;--- ignore these arguments?  I think not...
-			:max-width width
-			:max-height height))))
-	      (bounding-rectangle-size record))
-	  ;;--- Yabba dabba doo!
-	  (setq sr-components (nsubstitute width :compute sr-components :end 3))
-	  (setq sr-components (nsubstitute height :compute sr-components :start 3)))
-	(setq sr (make-space-requirement 
-		   :width      (pop sr-components)
-		   :min-width  (pop sr-components)
-		   :max-width  (pop sr-components)
-		   :height     (pop sr-components)
-		   :min-height (pop sr-components)
-		   :max-height (pop sr-components)))))
-    sr))
+    (labels ((process-compute-space-requirements ()
+	       (with-space-requirement (sr)
+		 (when (do-with-space-req-components 
+			or sr-component 
+			(sr-width sr-min-width
+				  sr-max-width sr-height
+				  sr-min-height sr-max-height) 
+			(eq sr-component :compute))
+		   (multiple-value-bind (width height)
+		       (let ((record
+			      (with-output-to-output-record (pane)
+				(invoke-pane-redisplay-function 
+				 (pane-frame pane) pane
+				 ;;--- Are all pane display functions prepared to
+				 ;;--- ignore these arguments?  I think not...
+				 :max-width width
+				 :max-height height))))
+			 (bounding-rectangle-size record))
+		     (do-with-space-req-components
+		      progn sr-component (sr-width sr-min-width sr-max-width)
+		      (when (eq sr-component :compute) (setq sr-component width)))
+		     (do-with-space-req-components
+		      progn sr-component (sr-height sr-min-height sr-max-height)
+		      (when (eq sr-component :compute) (setq sr-component height))))
+		   (setq sr (make-sr)))))
+	     (process-unit-space-requirements ()
+	       (with-space-requirement (sr)
+		 (let ((changed nil))
+		   (do-with-space-req-components 
+		    progn sr-component 
+		    (sr-width sr-min-width
+			      sr-max-width sr-height
+			      sr-min-height sr-max-height) 
+		    (when (unit-space-requirement-p sr-component)
+		      (setq sr-component
+			(process-unit-space-requirement pane sr-component)
+			changed t)))
+		   (when changed
+		     (setq sr (make-sr))))))
+	     (process-relative-space-requirements ()
+	       (with-space-requirement (sr)
+		 (unless (and (numberp sr-width)
+			      (numberp sr-height)
+			      (do-with-space-req-components 
+			       and sr-component 
+			       ( sr-min-width
+				 sr-max-width
+				 sr-min-height 
+				 sr-max-height) 
+			       (or (numberp sr-component)
+				   (relative-space-requirement-p
+				    sr-component))))
+		   (error "Illegal space requirement ~S" sr))
+		 (let ((changed nil))
+		   (when (relative-space-requirement-p sr-min-width)
+		     (setq sr-min-width (- sr-width
+					   (process-unit-space-requirement pane (car sr-min-width)))
+			   changed t))
+		   (when (relative-space-requirement-p sr-max-width)
+		     (setq sr-max-width (+ sr-width
+					   (process-unit-space-requirement pane (car sr-max-width)))
+			   changed t))
+		   (when (relative-space-requirement-p sr-min-height)
+		     (setq sr-min-height (- sr-height
+					    (process-unit-space-requirement pane (car sr-min-height)))
+			   changed t))
+		   (when (relative-space-requirement-p sr-max-height)
+		     (setq sr-max-height (+ sr-height
+					    (process-unit-space-requirement pane (car sr-max-height)))
+			   changed t))
+		   (when changed
+		     (setq sr (make-sr)))))))
+      (process-compute-space-requirements)
+      (process-unit-space-requirements)
+      (process-relative-space-requirements)
+      sr)))
+
+(defun relative-space-requirement-p (sr)
+  (and (consp sr)
+       (= (length sr) 2)
+       (or (numberp (second sr))
+	   (unit-space-requirement-p (second sr)))))
+
+
+(defun unit-space-requirement-p (sr)
+  (and (consp sr)
+       (= (length sr) 2)
+       (member (second sr) '(:line :character :mm :point :pixel))))
+
+(defun process-unit-space-requirement (pane sr)
+  (destructuring-bind
+      (number unit) sr
+    (let ((graft (graft pane)))
+      (ecase unit
+	(:pixel number)
+	(:mm (* number (/ (silica::graft-pixel-width graft) (silica::graft-mm-width graft))))
+	(:point (* number (silica::graft-pixels-per-point graft)))
+	(:character (* number (stream-string-width pane "M")))
+	(:line (+ (* number (stream-line-height pane))
+		  (* (1- number) (stream-vertical-spacing pane))))))))
 
 #+ignore
 (defmethod note-sheet-grafted :after ((pane clim-stream-pane))
@@ -195,10 +296,13 @@
   (multiple-value-bind (history-width history-height)
       (if (stream-current-output-record pane)
 	  (bounding-rectangle-size (stream-current-output-record pane))
-	  (values width height))
+	(values width height))
     ;; Don't ever shrink down smaller than our contents.
-    (apply #'call-next-method pane :width (max width history-width)
-				   :height (max height history-height) keys)))
+    (if (and (numberp width)
+	     (numberp height))
+	(apply #'call-next-method pane :width (max width history-width)
+	       :height (max height history-height) keys)
+      (call-next-method))))
 
 
 (defclass interactor-pane (clim-stream-pane) ())
@@ -310,9 +414,7 @@
   (bounding-rectangle-size (pane-viewport-region stream)))
 
 (defmethod window-set-inside-size ((stream clim-stream-sheet) width height)
-  (change-space-requirement stream :width width :height height)
-  (clear-space-requirement-caching-in-ancestors stream)
-  (layout-frame (pane-frame stream)))
+  (change-space-requirement stream :width width :height height :resize-frame t))
 
 (defun-inline window-parent (window)
   (sheet-parent window))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 1e0f0572..24a17704 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.16 92/04/28 09:25:40 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.17 92/04/30 09:09:29 cer Exp Locker: cer $
 
 
 (in-package :clim-internals)
@@ -46,9 +46,12 @@
 			      :reader frame-pointer-documentation-p)
      (pointer-documentation-pane :initform nil)
      (properties :initform nil :initarg :properties
-		 :accessor frame-properties))
-  (:default-initargs :pointer-documentation nil
-		     :top-level 'default-frame-top-level))
+		 :accessor frame-properties)
+     (resizable :initarg :resize-frame
+		:reader frame-resizable))
+     (:default-initargs :pointer-documentation nil
+       :resize-frame nil
+       :top-level 'default-frame-top-level))
 
 (defmethod port ((frame standard-application-frame))
   (port (frame-manager frame)))
@@ -72,7 +75,7 @@
   (destructuring-bind (&key x y width height) geometry
     (declare (ignore x y width height)))
   (destructuring-bind (&key name pixmap clipping-mask) icon
-    (declare (ignore name pixmap clip-mask)))
+    (declare (ignore name pixmap clipping-mask)))
   
   (let ((frame-manager
 	  (etypecase parent
@@ -406,15 +409,26 @@
       (unless (and width height)
 	(let ((sr (compose-space panes)))
 	  (setq width  (space-requirement-width sr)
-		height (space-requirement-height sr))))
+		height (space-requirement-height sr))
+	  (multiple-value-bind
+	      (gw gh) (bounding-rectangle-size (graft frame))
+	    (minf width (* 0.9 gw))
+	    (minf height (* 0.9 gh)))))
       ;;--- Don't bother with this if the size didn't change?
-      (resize-sheet* 
-	(or (frame-top-level-sheet frame) panes)
-	width height
-	;; We need to do this because if the WM has changed the sheet
-	;; then this will not change its size but we need it to start
-	;; the layout stuff
-	:force t))))
+      (let ((top (or (frame-top-level-sheet frame) panes)))
+	(if (and (sheet-enabled-p top)
+		 (not (frame-resizable frame)))
+	    (multiple-value-call 
+		#'allocate-space 
+	      top
+	      (bounding-rectangle-size top))
+	  (resize-sheet* 
+	   top
+	   width height
+	   ;; We need to do this because if the WM has changed the sheet
+	   ;; then this will not change its size but we need it to start
+	   ;; the layout stuff
+	   :force t))))))
 
 (defmethod (setf frame-current-layout) (nv (frame standard-application-frame))
   (unless (eq (frame-current-layout frame) nv)
@@ -478,6 +492,8 @@ the same time " options))
     (nstring-capitalize new-string)))
 
 (defmethod enable-frame ((frame standard-application-frame))
+  (unless (frame-manager frame)
+    (error "Cannot enabled :disowned frame ~S" frame))
   (destructuring-bind
       (&key width height &allow-other-keys) (frame-geometry frame)
     (ecase (frame-state frame)
@@ -501,6 +517,11 @@ the same time " options))
 		 (frame-top-level-sheet frame)))))
 	 (note-frame-enabled (frame-manager frame) frame))))))
 
+(defmethod destroy-frame ((frame standard-application-frame))
+  (when (eq (frame-state frame) :enabled)
+    (disable-frame frame))
+  (disown-frame (frame-manager frame) frame))
+
 (defmethod disable-frame ((frame standard-application-frame))
   (ecase (frame-state frame)
     ((:disowned :disabled))
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index 97b72aed..9a88de12 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -19,13 +19,15 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gadget-output.lisp,v 1.12 92/04/28 09:25:44 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.lisp,v 1.13 92/04/30 09:09:31 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
 
 ;;; Implementation of output-records that are tied to gadgets.
 
+;;--- Need to use the commented out version of this code.
+
 (defclass gadget-output-record 
     	  (output-record-mixin output-record-element-mixin output-record)
     ((gadget :initform nil
@@ -45,9 +47,23 @@
 	 (stream-output-history-position stream))
       (decf x abs-x)
       (decf y abs-y)
+
+      #-ignore
+      (multiple-value-bind (cx cy)
+	  (stream-cursor-position stream)
+	(declare (type coordinate cx cy))
+	(with-slots (start-x start-y) rec
+	  (setq start-x (- cx abs-x) start-y (- cy abs-y))))
+      
       (bounding-rectangle-set-edges
        rec
-       x y (+ x (space-requirement-width sr)) (+ y (space-requirement-height sr))))
+       x y (+ x (space-requirement-width sr)) 
+       (+ y (space-requirement-height sr)))
+      
+      #-ignore
+      (when (output-record-parent rec)
+	(tree-recompute-extent rec)))
+    
     (when (output-record-stream rec)
       (update-gadget-position rec)
       (setf (sheet-enabled-p gadget) t))))
@@ -66,23 +82,28 @@
   (declare (ignore  a b))
   (update-gadget-position rec))
 
+(defmethod bounding-rectangle-set-size :after ((rec gadget-output-record) a b)
+  (declare (ignore  a b))
+  (update-gadget-position rec))
+
+#+ignore
 (defmethod update-gadget-position (record) 
   (let ((gadget (output-record-gadget record)))
     (when gadget
-      (with-bounding-rectangle* (left top right bottom) record
-        (let ((xoff 0)
-	      (yoff 0))
-	  (do ((parent record (output-record-parent parent)))
-	      ((null parent))
-	    (multiple-value-bind (x y)
-		(output-record-position parent)
-	      (incf xoff x)
-	      (incf yoff y)))
-	  (move-and-resize-sheet* gadget
-				  (+ left xoff) (+ top yoff)
-				  (- right left) (- bottom top)))))))
-
-#+This-almost-works-with-the-other-definition
+      (with-bounding-rectangle* 
+	  (left top right bottom) record
+	  (let ((xoff 0)
+		(yoff 0))
+	    (multiple-value-setq
+		(xoff yoff)
+	      (convert-from-relative-to-absolute-coordinates 
+	       (sheet-parent gadget) 
+	       record))
+	    (move-and-resize-sheet* gadget
+				    (+ left xoff) (+ top yoff)
+				    (- right left) (- bottom top)))))))
+
+#-ignore
 (defmethod update-gadget-position (record) 
   (let ((gadget (output-record-gadget record)))
     (when gadget
@@ -119,6 +140,7 @@
 	     (with-look-and-feel-realization (,fm ,f) ,@body)) 
 	 ,@args))))
 
+#+ignore
 (defmethod invoke-with-output-as-gadget (stream continuation &key)
   ;;--- (PANE-FRAME STREAM) or *APPLICATION-FRAME*?
   (let* ((frame (pane-frame stream))
@@ -141,7 +163,7 @@
 	(move-cursor-beyond-output-record stream record)
 	(values gadget record)))))
 	    
-#+This-almost-works-with-the-other-definition
+#-ignore
 (defmethod invoke-with-output-as-gadget (stream continuation &key)
   (let* ((frame (pane-frame stream))
 	 (framem (frame-manager frame)))
@@ -149,15 +171,18 @@
     (assert framem)
     (multiple-value-bind (x y)
 	(stream-cursor-position stream)
-      (let* (gadget
+      (let* (new
+	     gadget
 	     (record
 	      (with-new-output-record (stream 'gadget-output-record record)
 		(unless (setq gadget (output-record-gadget record))
-		  (setq gadget (funcall continuation framem frame))))))
-	(associate-record-and-gadget
-		   record
-		   gadget
-		   stream x y)
+		  (setq new t 
+			gadget (funcall continuation framem frame))))))
+	(when new
+	  (associate-record-and-gadget
+	   record
+	   gadget
+	   stream x y))
 	(move-cursor-beyond-output-record stream record)
 	(values gadget record)))))
 
@@ -334,11 +359,15 @@
     #+ignore
     (setf (gadget-value gadget) default)))
 
-;;; Integer gadget
+;;;;-------------- Integer gadget
+;;;; I general there should be a way of using a slider to input a real
+;;;; number but I do not think it should be the default
 
+#+ignore
 (define-presentation-method gadget-includes-prompt-p ((type integer) (stream t) (view gadget-view) &key)
   t)
 
+#+ignore
 (define-presentation-method accept-present-default ((type integer)
 						    stream
 						    (view gadget-dialog-view)
diff --git a/clim/menus.lisp b/clim/menus.lisp
index a8482702..d0affed7 100644
--- a/clim/menus.lisp
+++ b/clim/menus.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: menus.lisp,v 1.19 92/04/15 11:46:54 cer Exp Locker: cer $
+;; $fiHeader: menus.lisp,v 1.20 92/04/21 16:13:11 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -113,16 +113,21 @@
       (clear-input menu))))
 
 #+Silica
-(defun size-menu-appropriately (menu &key width height (right-margin 10) (bottom-margin 10))
+(defun size-menu-appropriately (menu &key 
+				     width height
+				     (right-margin 10) 
+				     (bottom-margin 10)
+				     (size-fn 
+				      #'window-set-inside-size))
   (with-slots (output-record) menu
     (with-bounding-rectangle* (minx miny maxx maxy) output-record
-      (let* ((graft (graft menu))
-	     (gw (bounding-rectangle-width (sheet-region graft)))
-	     (gh (bounding-rectangle-height (sheet-region graft)))
-	     (width (min gw (+ (- maxx minx) right-margin)))
-	     (height (min gh (+ (- maxy miny) bottom-margin))))
-	(window-set-inside-size menu width height)
-	(window-set-viewport-position menu minx miny)))))
+	(let* ((graft (graft menu))
+	       (gw (bounding-rectangle-width (sheet-region graft)))
+	       (gh (bounding-rectangle-height (sheet-region graft)))
+	       (width (min gw (+ (- maxx minx) right-margin)))
+	       (height (min gh (+ (- maxy miny) bottom-margin))))
+	  (funcall size-fn menu width height)
+	  (window-set-viewport-position menu minx miny)))))
 
 #-Silica
 (defun position-window-near-carefully (window x y)
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index e802bf57..11cdb462 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.8 92/04/15 11:47:13 cer Exp Locker: cer $
+;; $fiHeader: recording-protocol.lisp,v 1.9 92/04/21 16:13:14 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -1219,10 +1219,11 @@
 		    (bounding-rectangle stream)))))
     (unless (eq clear +nowhere+)
       (with-sheet-medium (medium stream)
-	(multiple-value-call #'draw-rectangle*
-	  medium
-	  (bounding-rectangle* clear)
-	  :ink +background-ink+))
+	(with-bounding-rectangle* (a b c d) clear
+				  (draw-rectangle*
+				   medium
+				   a b c d
+				   :ink +background-ink+)))
       (stream-replay stream region))))
 
 
diff --git a/silica/db-box.lisp b/silica/db-box.lisp
index aeb57686..04fe13f5 100644
--- a/silica/db-box.lisp
+++ b/silica/db-box.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
-;; $fiHeader: db-box.lisp,v 1.12 92/04/21 16:12:34 cer Exp Locker: cer $
+;; $fiHeader: db-box.lisp,v 1.13 92/04/30 09:09:11 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -43,7 +43,12 @@
     (etypecase child
       (number)
       ((member :fill))
-      (pane (sheet-adopt-child pane child))))
+      (pane (sheet-adopt-child pane child))
+      (cons
+       (unless (and (typep (first child) '(or  (member :fill) (real 0 1)))
+		    (panep (second child)))
+	 (error "Invalid box child: ~S" contents))
+       (sheet-adopt-child pane (second child)))))
   (with-slots ((c contents)) pane
     (setf c contents)))
 
@@ -60,20 +65,33 @@
 	    minor+ minor-
 	    (minor-min 0)
 	    ;;--- is this safe?
-	    (minor-max most-positive-fixnum))
+	    (minor-max most-positive-fixnum)
+	    scale)
 	(dolist (entry contents)
 	  (cond ((eq entry :fill) (incf major+ +fill+))
 		((numberp entry) (incf major entry))
-		(t 
+		(t
+		 (if (consp entry)
+		     (psetf entry (second entry) 
+			    scale (let ((n (first entry)))
+				    (if (numberp n)
+					(float n) n)))
+		   (setf scale 1.0))
 		 (let ((space-req (apply #'compose-space entry width-or-height)))
-		   (incf major (+ (funcall fn-major space-req) space))
-		   (incf major+ (funcall fn-major+ space-req))
-		   (incf major- (funcall fn-major- space-req))
-		   (setq minor (max minor (funcall fn-minor space-req))) 
-		   (setq minor-min
-		     (max minor-min (funcall fn-minor- space-req)))
-		   (setq minor-max
-		     (min minor-max (funcall fn-minor+ space-req)))))))
+		   (flet ((scale (x) (if (and (numberp scale) (< x +fill+)) (/ x scale) x)))
+		     (if (eq scale :fill)
+			 (incf major+ +fill+)
+		       (progn
+			 (incf major (+ (scale (funcall fn-major space-req)) space))
+			 (incf major+ (if (eq scale :fill)
+					  +fill+
+					(scale (funcall fn-major+ space-req))))))
+		     (incf major- (scale (funcall fn-major- space-req)))
+		     (setq minor (max minor (funcall fn-minor space-req))) 
+		     (setq minor-min
+		       (max minor-min (funcall fn-minor- space-req)))
+		     (setq minor-max
+		       (min minor-max (funcall fn-minor+ space-req))))))))
 	(decf major space)
 	;; ?? These calcs lead to weirdness when fills are involved.
 	;;--- This looks like a leftover from the time when +/- were relative
@@ -86,7 +104,6 @@
 		       keys 
 		       (list major major+ major- minor minor+ minor-)))))))
 
-
 (defclass hbox-pane (box-pane) ())
 
 (defmethod compose-space ((box-pane hbox-pane) &key width height)
@@ -105,6 +122,10 @@
   (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))))))
     (let ((sizes 
 	    (allocate-space-to-items
 	      width
@@ -113,15 +134,18 @@
 	      #'space-requirement-min-width
 	      #'space-requirement-width
 	      #'space-requirement-max-width
-	      #'(lambda (x) (compose-space x :height height))))
+	      #'compose))
 	  (x 0))
       (mapc #'(lambda (sheet size)
-		(when (panep sheet)
+		(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))))
+	    contents sizes)))))
 
 
 (defclass vbox-pane (box-pane) ())
@@ -142,23 +166,32 @@
   (with-slots (contents space space-requirement) box-pane
     (unless space-requirement 
       (compose-space box-pane :width width :height height))
-    (let ((sizes 
-	    (allocate-space-to-items
+    (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))))))
+      (let ((sizes 
+	     (allocate-space-to-items
 	      height
 	      space-requirement
 	      contents
 	      #'space-requirement-min-height
 	      #'space-requirement-height
 	      #'space-requirement-max-height
-	      #'(lambda (x) (compose-space x :width width))))
-	  (y 0))
-      (mapc #'(lambda (sheet size)
-		(when (panep sheet)
-		  (move-and-resize-sheet* sheet 
-					  0 y
-					  width (frob-size size height y)))
-		(incf y size))
-	    contents sizes))))
+	      #'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)))))
 
 ;;--- Yow
 (defun frob-size (wanted-size available where-we-are-now)
diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp
index 71d61547..f1ef68e1 100644
--- a/silica/db-layout.lisp
+++ b/silica/db-layout.lisp
@@ -22,7 +22,7 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
-;; $fiHeader: db-layout.lisp,v 1.13 92/04/21 16:12:36 cer Exp Locker: cer $
+;; $fiHeader: db-layout.lisp,v 1.14 92/04/28 09:25:14 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -72,12 +72,78 @@
 (defmethod change-space-requirement ((pane layout-mixin) &key &allow-other-keys)
   nil)
 
-(defmethod change-space-requirement :after
-	   ((pane layout-mixin) &key resize-frame &allow-other-keys)
+
+;;#|
+
+(defmacro changing-space-requirements ((&rest options &key resize-frame) &body body)
+  `(flet ((changing-space-requirements-body ()
+	    ,@body))
+     (declare (dynamic-extent #'changing-space-requirements-body))
+     (invoke-with-changing-space-requirements 
+      #'changing-space-requirements-body 
+      ,@options)))
+
+(defvar *inside-changing-space-requirements* nil)
+
+(defun invoke-with-changing-space-requirements (continuation &key resize-frame)
+  (let ((old-inside-changing-space-requirements 
+	 *inside-changing-space-requirements*)
+	(*inside-changing-space-requirements* 
+	 (cons nil *inside-changing-space-requirements*)))
+    (multiple-value-prog1
+	(funcall continuation)
+      (unless old-inside-changing-space-requirements
+	;; Layout that frames that need to be laid out
+	;; and relayout the minimal subtrees that need to be laid out
+	(let* ((frames (remove-duplicates
+			(remove-if-not 
+			#'(lambda (x) (typep x 'application-frame))
+			*inside-changing-space-requirements*)))
+	       (panes (remove-if #'(lambda (x)
+				     (or (not (panep x))
+					 (member (pane-frame x) frames)))
+				 *inside-changing-space-requirements*)))
+	  (mapc #'layout-frame frames)
+	  (dolist (pane panes)
+	    (unless (some #'(lambda (p) 
+			      (and (not (eq p pane))
+				   (sheet-ancestor-p pane p)))
+			  panes)
+	      ;; do this because the change has occurred somewhere in
+	      ;; the tree
+	      (clear-space-requirement-caches-in-tree pane) 
+	      (multiple-value-call #'allocate-space 
+		pane (bounding-rectangle-size pane)))))))))
+
+(defmethod note-space-requirement-changed (parent child)
+  (multiple-value-call #'allocate-space 
+    parent (bounding-rectangle-size parent)))
+
+(defmethod change-space-requirement :before ((pane space-requirement-cache-mixin) &key)
+  (clear-space-requirement-cache pane))
+
+(defmethod change-space-requirement :around ((pane layout-mixin) &key
+								 resize-frame 
+								 &allow-other-keys)
+  (call-next-method)
+  (if *inside-changing-space-requirements*
+      (push (if resize-frame (pane-frame pane) (sheet-parent pane))
+	    (cdr *inside-changing-space-requirements*))
+    (if resize-frame
+	(layout-frame (pane-frame pane))
+      (note-space-requirement-changed (sheet-parent pane) pane))))
+
+;;|#
+
+
+
+#+ignore
+(defmethod change-space-requirement :after ((pane layout-mixin) &key resize-frame &allow-other-keys)
   (if resize-frame
       (layout-frame (pane-frame pane))
       (note-space-requirement-changed (sheet-parent pane) pane)))
 
+#+ignore
 (defmethod note-space-requirement-changed (parent child)
   nil)
 
@@ -89,18 +155,6 @@
   (multiple-value-bind (width height) (bounding-rectangle-size pane)
     (allocate-space pane width height)))
 
-
-#||
-
-(defmacro changing-space-requirements ((pane &key resize-frame) &body body)
- `(progn
-    ,@body {translate "change-space-req" to %set-space-req}
-    (if resize-frame
-        (layout-frame frame)
-        (note-space-requirement-changed (sheet-parent pane) pane))))
-
-||#
-
 (defun map-space-requirement (fn req)
   (setf (space-requirement-width req) (funcall fn (space-requirement-width req))
 	(space-requirement-height req) (funcall fn (space-requirement-height req))
@@ -467,6 +521,7 @@ provided elsewhere"))
 ;;---- along the way, calling fix-coor on alloc helps a little but we
 ;;---- still end up with a gap along the bottom-right edges.
 
+#+ignore
 (defun allocate-space-to-items (given wanted items min-size
 				desired-size max-size item-size)
   (flet ((desired-size (x) (funcall desired-size x))
@@ -493,29 +548,100 @@ provided elsewhere"))
 	       (setq alloc 0)))
 	    (t
 	     (let* ((item-size (item-size item)))
-	       (setq alloc (desired-size item-size))
-	       (when (> give 0)
-		 (if stretch-p
-		     (progn
-		       (setq used (/ (* (- (max-size item-size)
-					   (desired-size item-size))
-					extra)
-				     give))
-		       (incf alloc used)
-		       (fix-coordinates alloc)
-		       (decf give (- (max-size item-size)
-				     (desired-size item-size))))
-		   (progn
-		     (setq used (/ (* (- (desired-size item-size)
-					 (min-size item-size))
-				      extra)
-				   give))
-		     (decf alloc used)
-		     (fix-coordinates alloc)
-		     (decf give (- (desired-size item-size)
-				   (min-size item-size)))))
-		 (decf extra used)))))
+	       (if (eq item-size :fill)
+		   (if stretch-p
+		       (progn
+			 (setq alloc (/ (* +fill+ extra) give))
+			 (setq alloc (ceiling alloc))
+			 (fix-coordinates alloc)
+			 (decf give +fill+))
+		     (setq alloc 0))
+		 (progn
+		   (setq alloc (desired-size item-size))
+		   (when (> give 0)
+		     (if stretch-p
+			 (progn
+			   (setq used (/ (* (- (max-size item-size)
+					       (desired-size item-size))
+					    extra)
+					 give))
+			   (incf alloc used)
+			   (fix-coordinates alloc)
+			   (decf give (- (max-size item-size)
+					 (desired-size item-size))))
+		       (progn
+			 (setq used (/ (* (- (desired-size item-size)
+					     (min-size item-size))
+					  extra)
+				       give))
+			 (decf alloc used)
+			 (fix-coordinates alloc)
+			 (decf give (- (desired-size item-size)
+				       (min-size item-size)))))
+		     (decf extra used)))))))
+	  (push alloc sizes)))
+      (nreverse sizes))))
+
+;;-- This new supa dupa version saves up all the fills to the end and
+;;-- then divides up any leftover space equally amongst them and it
+;;-- seems to work!
+
+(defun allocate-space-to-items (given wanted items min-size
+				desired-size max-size item-size)
+  (flet ((desired-size (x) (funcall desired-size x))
+	 (min-size (x) (funcall min-size x))
+	 (max-size (x) (funcall max-size x))
+	 (item-size (x) (funcall item-size x)))
+    (let ((stretch-p (>= given (desired-size wanted)))
+	  (allocated 0)
+	  extra give used sizes)
+      (if stretch-p
+	  (setq give (- (max-size wanted) (desired-size wanted))
+		extra (min (- given (desired-size wanted)) give))
+	(setq give (- (desired-size wanted) (min-size wanted))
+	      extra (min (- (desired-size wanted) given) give)))
+      (dolist (item items)
+	(let (alloc)
+	  (typecase item
+	    ((member :fill)
+	     (setq alloc :fill))
+	    (t
+	     (let* ((item-size (item-size item)))
+	       (if (eq item-size :fill)
+		   (setq alloc :fill)
+		 (progn
+		   (setq alloc (desired-size item-size))
+		   (when (> give 0)
+		     (if stretch-p
+			 (progn
+			   (setq used (/ (* (- (max-size item-size)
+					       (desired-size item-size))
+					    extra)
+					 give))
+			   (incf alloc used)
+			   (fix-coordinates alloc)
+			   (decf give (- (max-size item-size)
+					 (desired-size item-size))))
+		       (progn
+			 (setq used (/ (* (- (desired-size item-size)
+					     (min-size item-size))
+					  extra)
+				       give))
+			 (decf alloc used)
+			 (fix-coordinates alloc)
+			 (decf give (- (desired-size item-size)
+				       (min-size item-size)))))
+		     (decf extra used)))))))
+	  (when (numberp alloc)
+	    (incf allocated alloc))
 	  (push alloc sizes)))
+      (let ((fills (count :fill sizes))
+	    (leftover (- given allocated)))
+	(when (> fills 0)
+	  (let ((x (if (> leftover 0) 
+		       (fix-coordinate (/ leftover fills)) 
+		     0)))
+	    (setf sizes (nsubstitute x :fill sizes)))))
       (nreverse sizes))))
 	
 ;;; Most of the layout panes should inherit from this
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index 897dc64a..be382508 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.17 92/04/28 09:25:17 cer Exp Locker: cer $
+;; $fiHeader: db-scroll.lisp,v 1.18 92/04/30 09:09:13 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -554,7 +554,8 @@
   (declare (values value2))
   (let* ((distance1 (- max1 min1))
 	 (fraction1 (if (zerop distance1) 0 (/ (- value1 min1) distance1))))
-    (+ min2 (* (- max2 min2) fraction1))))
+    (let ((x (+ min2 (* (- max2 min2) fraction1))))
+      (if (integerp x) x (float x)))))
 
 (defmethod handle-event :around ((pane scroll-bar-target-pane) 
 				 (event pointer-button-press-event))
diff --git a/silica/framem.lisp b/silica/framem.lisp
index 6f44ada9..5e7649a0 100644
--- a/silica/framem.lisp
+++ b/silica/framem.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: framem.lisp,v 1.5 92/04/15 11:45:09 cer Exp Locker: cer $
+;; $fiHeader: framem.lisp,v 1.6 92/04/21 16:12:39 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -29,6 +29,11 @@
     ((port :reader port :initarg :port)
      (frames :accessor frame-manager-frames :initform nil)))
 
+;;-- This is most likely wrong.
+
+(defmethod graft ((framem standard-frame-manager))
+  (car (port-grafts (port framem))))
+
 (defvar *frame-managers* nil)
 
 (defun find-frame-manager (&rest options 
@@ -70,9 +75,18 @@
 (defmethod adopt-frame :after ((framem standard-frame-manager) frame)
   (pushnew frame (frame-manager-frames framem)))
 
+
+(defmethod disown-frame ((framem standard-frame-manager) frame)
+  (let ((top (frame-top-level-sheet frame)))
+    (when top
+      (sheet-disown-child (sheet-parent top) top)
+      (setf (frame-top-level-sheet frame) nil
+	    (frame-state frame) :disowned))))
+
 (defmethod disown-frame :after ((framem standard-frame-manager) frame)
   (setf (frame-manager-frames framem)
-	(delete frame (frame-manager-frames framem))))
+    (delete frame (frame-manager-frames framem))
+    (slot-value frame 'frame-manager) nil))
 
 (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame)
   (update-frame-settings framem frame)
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 7533b8d8..11a202d0 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.18 92/04/21 16:12:40 cer Exp Locker: cer $
+;; $fiHeader: gadgets.lisp,v 1.19 92/04/30 09:09:14 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -94,7 +94,7 @@
 
 (defclass oriented-gadget ()
     ((orientation :initarg :orientation
-		  :reader gadget-orientation))
+		  :accessor gadget-orientation))
   (:default-initargs :orientation :horizontal))
 
 
@@ -136,13 +136,18 @@
 ;;; The intent is that the real implementations inherit from these
 
 ;;; Slider
+
 (defclass slider
 	  (value-gadget oriented-gadget range-gadget-mixin labelled-gadget)
     ((drag-callback :initarg :drag-callback :initform nil
 		    :reader slider-drag-callback)
+     (decimal-places :initarg :decimal-places
+		     :reader slider-decimal-places)
      (show-value-p :initarg :show-value-p 
 		   :accessor gadget-show-value-p))
-  (:default-initargs :show-value-p nil))
+  (:default-initargs
+      :decimal-places 0
+      :show-value-p nil))
 
 
 (defmethod drag-callback ((gadget slider) (client t) (id t) value)
@@ -413,7 +418,7 @@ l
     (note-gadget-activated (gadget-client gadget) gadget)))
 
 (defmethod note-gadget-activated ((client t) (gadget gadget))
-  (port-note-gadget-activated (port gadget) gadget))
+  nil)
 
 (defmethod deactivate-gadget ((gadget gadget))
   (when (gadget-active-p gadget)
@@ -421,4 +426,27 @@ l
     (note-gadget-deactivated (gadget-client gadget) gadget)))
 
 (defmethod note-gadget-deactivated ((client t) (gadget gadget))
-  (port-note-gadget-deactivated (port gadget) gadget))
+  nil)
+
+;;; List panes and option menus
+
+(defclass set-gadget-mixin ()
+	  ((items :initarg :items :accessor set-gadget-items)
+	   (name-key :initarg :name-key :accessor set-gadget-name-key)
+	   (value-key :initarg :value-key :accessor set-gadget-value-key)
+	   (test :initarg :test :accessor set-gadget-test))
+  (:default-initargs 
+    :items nil
+    :test #'eql
+    :value-key #'identity
+    :name-key #'princ-to-string))
+
+(defclass list-pane (set-gadget-mixin value-gadget)
+	  ((mode :initarg :mode :type (member :exclusive :nonexclusive)
+		 :accessor list-pane-mode))
+  (:default-initargs :mode :exclusive))
+
+(defclass option-pane (set-gadget-mixin 
+			     value-gadget 
+			     labelled-gadget)
+	  ())
diff --git a/silica/layout.lisp b/silica/layout.lisp
index d7401902..4d4e8541 100644
--- a/silica/layout.lisp
+++ b/silica/layout.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: layout.lisp,v 1.13 92/04/21 16:12:42 cer Exp Locker: cer $
+;; $fiHeader: layout.lisp,v 1.14 92/04/30 09:09:16 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -92,22 +92,32 @@
 ;(defmethod allocate-space (sheet width height)
 ;  (declare (ignore sheet width height)))
 
+
+(defun parse-box-contents (contents)
+  (mapcar #'(lambda (x)
+	      (if (and (consp x)
+		       (typep (car x) '(or (member :fill) number)))
+		  `(list ,(car x) ,(second x))
+		x))
+	  contents))
+
 (defmacro vertically (options &body contents)
   `(make-pane 'vbox-pane
-	      :contents (list ,@contents)
+	      :contents (list ,@(parse-box-contents contents))
 	      ,@options))
 
-
-
 (defmacro horizontally (options &body contents)
   `(make-pane 'hbox-pane
-	      :contents (list ,@contents)
+	      :contents (list ,@(parse-box-contents contents))
 	      ,@options))
 
 
 ;;;---- Should force be T
 
-(defmethod resize-sheet* ((sheet sheet) width height &key (force t))
+(defmethod resize-sheet* ((sheet sheet) width height &key (force nil))
+  (unless (and (> width 0) (> height 0))
+    (error "Trying to resize sheet to zero ~S,~S,~S"
+	   sheet width height))
   (when (or width height)
     (with-bounding-rectangle* (minx miny maxx maxy) sheet
       (when (or force
@@ -121,6 +131,9 @@
 
 (defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height)
   (resize-sheet* sheet width height)
+  (move-sheet* sheet minx miny))
+
+(defmethod move-sheet* ((sheet sheet) minx miny)
   (let ((trans (sheet-transformation sheet)))
     (multiple-value-bind (x y)
 	(transform-position trans 0 0)
@@ -132,18 +145,6 @@
 		(if minx (- minx x) 0)
 		(if miny (- miny y) 0)))))))
 
-(defmethod move-sheet* ((sheet sheet) minx miny)
-  (let ((trans (sheet-transformation sheet)))
-    (multiple-value-bind (x y)
-	(transform-position trans 0 0)
-      (when (or (/= x minx)
-		(/= y miny))
-	(setf (sheet-transformation sheet)
-	      (compose-translation-with-transformation
-		trans
-		(- minx x)
-		(- miny y)))))))
-
 
 ;; Various
 
@@ -315,10 +316,14 @@
 
 (defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port)
   (if port
+      ;; We do this because if the wm has resized us then we want to
+      ;; do the complete layout-frame thing including clearing caches
+      ;; etc etc.
       (multiple-value-call #'layout-frame
 	(pane-frame pane) 
 	(bounding-rectangle-size pane))
-      (call-next-method)))
+    ;; Otherwise just call allocate-space etc
+    (call-next-method)))
 
 #+++ignore
 (defmethod allocate-space ((sheet top-level-sheet) width height)
diff --git a/silica/port.lisp b/silica/port.lisp
index a055a86b..9632dfae 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: port.lisp,v 1.9 92/03/24 19:36:49 cer Exp $
+;; $fiHeader: port.lisp,v 1.10 92/04/15 11:45:18 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -61,7 +61,10 @@
 
 
 (defgeneric port (x)
+  ;;;-- Do we need this???
+  #+ignore
   (:method ((port port)) port)
+  #+ignore
   (:method ((x t)) nil))
 
 (defgeneric port-properties (port))
diff --git a/test/test.lisp b/test/test.lisp
index 01c9b695..faae505b 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.22 92/04/28 09:26:05 cer Exp Locker: cer $
+;; $fiHeader: test.lisp,v 1.23 92/04/30 09:09:43 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -114,7 +114,8 @@
     ()
   (window-clear *query-io*))
 
-(define-test-frame-command (com-quit :name t :menu t)
+(define-test-frame-command (com-quit :name t 
+				     :menu ("Quit" :documentation "foo"))
     ()
   (frame-exit *application-frame*))
 
@@ -358,6 +359,12 @@
 (defun text-field-changed (tf value)
   (format t "~&Text field ~A changed to ~S"  tf value))
 
+(defun option-pane-changed-callback (tf value)
+  (format t "~&option menu ~A changed to ~S"  tf value))
+
+(defun list-pane-changed-callback (tf value)
+  (format t "~&list pane ~A changed to ~S"  tf value))
+
 (defclass insect () ())
 
 (define-test-frame-command (com-make-insect :name t :menu t)
@@ -451,17 +458,14 @@
 			  (:pane 
 			   (outlining ()
 				      (horizontally ()
-						    (make-pane
-						     'xm-silica::motif-scrolling-window
-						     :contents
+						    (scrolling ()
 						     (make-pane 'text-editor 
 								:value "lucid "
 								:value-changed-callback 'text-field-changed
 								:ncolumns 30
 								:nlines 10))
-						    (make-pane
-						     'xm-silica::motif-scrolling-window
-						     :contents (make-pane 'text-editor 
+						    (scrolling ()
+							       (make-pane 'text-editor 
 									  :value "harlqn  more"
 									  :value-changed-callback 'text-field-changed
 									  :ncolumns 30
@@ -473,24 +477,158 @@
     (:command-table test-frame)
     (:pane 
      (vertically ()
-		 (scrolling ()
-			    (make-pane
-			     'xm-silica::motif-list-pane
-			     :items '("Franz" "Lucid"
-				      "Harlqn" "Symbolics")))
-		 (make-pane 'xm-silica::motif-option-pane
+		 (horizontally ()
+			       (scrolling ()
+					  (make-pane
+					   'list-pane
+					   :value "Franz"
+					   :test 'string=
+					   :value-changed-callback 
+					   'list-pane-changed-callback
+					   :items '("Franz" "Lucid"
+						    "Harlqn" "Symbolics")))
+			       (scrolling ()
+					  (make-pane
+					   'list-pane
+					   :value '("Lisp" "C")
+					   :test 'string=
+					   :mode :nonexclusive
+					   :value-changed-callback 
+					   'list-pane-changed-callback
+					   :items '("C" "Cobol" "Lisp" "Ada"))))
+		 (make-pane 'option-pane
 			    :items '("eenie" "meanie" "minie")
+			    :value "minie"
+			    :value-changed-callback 
+			    'option-pane-changed-callback
+			    :test 'string=
 			    :label "moo")
 		 (outlining ()
-			    (make-pane
-			     'xm-silica::motif-scrolling-window
-			     :contents
+			    (scrolling ()
 			     (make-pane 'text-editor 
 					:value
 					"lucid are nice guys "
 					:value-changed-callback 'text-field-changed
 					:ncolumns 30
 					:nlines 10))))))
+
+(define-application-frame tf96
+    () ()
+    (:command-table test-frame)
+    (:panes
+     (a :application :width '(80 :character))
+     (b :application :width '(50 :mm))
+     (c :application :height '(10 :line))
+     (d :application :height '(5 :line))
+     (e :application :height '( 50 :mm)))
+    (:layout
+     (:default (vertically ()
+			   (horizontally () a b)
+			   (vertically () c d e)))))
+
+
+
+(define-test-frame-command (com-frob-sizes :name t :menu t)
+    ()
+  (changing-space-requirements ()
+			       (change-space-requirement 
+				(get-frame-pane *application-frame* 'a)
+				:resize-frame t
+				:width `(,(random 60) :character))
+			       (change-space-requirement 
+				(get-frame-pane *application-frame* 'b)
+				:resize-frame t
+				:width `(,(random 60) :character))
+			       (change-space-requirement 
+				(get-frame-pane *application-frame* 'd)
+				:resize-frame t
+				:height `(,(random 10) :line))))
+
+(define-application-frame tf95
+    () ()
+    (:command-table test-frame)
+    (:panes
+     (a :application :width '(80 :character))
+     (b :application :width '(50 :mm))
+     (c :application :height '(10 :line))
+     (d :application :height '(5 :line))
+     (e :application :height '( 50 :mm)))
+    (:layout
+     (:default (vertically 
+		()
+		(1/3 (horizontally () (1/10 a) (9/10 b)))
+		(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
+
+
+(define-application-frame tf94
+    () ()
+    (:command-table test-frame)
+    (:panes
+     (a :application :width '(80 :character))
+     (b :application)
+     (c :application :height '(10 :line))
+     (d :application)
+     (e :application :height '( 50 :mm)))
+    (:layout
+     (:default (vertically 
+		()
+		(1/3 (horizontally () (1/10 a) (:fill b)))
+		(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
+
+(define-application-frame tf93
+    () ()
+    (:command-table test-frame)
+    (:panes
+     (a :application)
+     (b :application)
+     (c :application)
+     (d :application)
+     (e :application))
+    (:layout
+     (:default (vertically 
+		()
+		(1/3 (horizontally () (1/10 a) (9/10 b)))
+		(2/3 (vertically () (1/4 c) (1/2 d) (1/4 e)))))))
+
+(define-application-frame tf91
+    () ()
+    (:command-table test-frame)
+    (:panes
+     (a :application)
+     (b :application)
+     (c :application)
+     (d :application)
+     (e :application))
+    (:layout
+     (:default (vertically 
+		()
+		(1/3 (horizontally () (1/10 a) (:fill b)))
+		(2/3 (vertically () (1/4 c) (:fill d) (1/4 e)))))))
+
+(define-application-frame tf92 ()
+  ()
+  (:pane
+     (make-pane 'vbox-pane
+		:contents
+		(mapcar #'(lambda (x)
+			    (destructuring-bind
+				(min max &optional (decimal-places 0))
+				x
+				(make-pane 'slider
+				 :label (format nil "Slider ~D,~D,~D"
+					 min max decimal-places)
+				 :min-value min
+				 :max-value max
+				 :decimal-places decimal-places
+				 :show-value-p t
+				 :value-changed-callback 'slider-changed-callback
+				 :drag-callback
+				 'slider-dragged-callback)))
+			'((0 100)
+			  (50 60)
+			  (50 60 2)
+			  (0.0 1.0 2))))))
+
 (defun test-accepting-values (&optional (own-window t)
 					(gadget-dialog-view t))
   (let* ((stream *query-io*)
@@ -539,3 +677,26 @@
 				     :prompt (second (nth i ptypes-and-prompts)))))
 			 (terpri stream))))
     values))
+
+;; This was from a pkarp mail message
+
+(defun shift-output-record (stream record dx dy)
+  (let ((parent (output-record-parent record)))
+    (multiple-value-bind (x-offset y-offset)
+	(convert-from-relative-to-absolute-coordinates
+	 stream
+	 parent)
+      (multiple-value-bind
+	  (x y)
+	  (bounding-rectangle-position record)
+	(erase-output-record record stream)
+	(output-record-set-position record (+ x dx) (+ y dy))
+	(replay-output-record record stream nil x-offset y-offset)
+	(add-output-record record parent)))))
+
+(define-test-frame-command (com-shift-gadget :name t :menu t)
+    ((weird 'some-kinda-gadget)
+     (dx 'integer)
+     (dy 'integer))
+  (shift-output-record *query-io* (car weird) dx dy))
+  
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 1335ee83..44a6a90a 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.14 92/04/21 20:28:30 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.15 92/04/28 09:26:24 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -254,7 +254,19 @@
 						   :label-string menu
 						   :managed t
 						   :parent parent)))
-			       (push (list item button) commands-and-buttons)
+			       (push (list item button)
+				     commands-and-buttons)
+			       
+			       (when (getf (command-menu-item-options
+					    item) :documentation)
+				 (tk::add-callback
+				  button
+				  :help-callback
+				  'display-motif-help
+				  port
+				  (getf (command-menu-item-options
+					 item) :documentation)))
+			       
 			       (tk::add-callback
 				button
 				:activate-callback
@@ -269,6 +281,12 @@
 	 ct mirror (not (flat-command-table-menu-p ct)))))
     mirror))
 
+(defun display-motif-help (widget port documentation)
+  (port-notify-user 
+   port
+   documentation
+   :associated-window widget))
+	     
 (defmethod port-dialog-view ((port motif-port))
   +gadget-dialog-view+)
   
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 5768ae32..5983c87e 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.25 92/04/28 09:26:27 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.26 92/04/30 09:09:51 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -41,17 +41,8 @@
 			 (clim-internals::check-box motif-check-box)
 			 (frame-pane motif-frame-pane)
 			 (top-level-sheet motif-top-level-sheet)
-			 ;; One day
-			 (line-editor-pane)
-			 (label-button-pane)
-			 (radio-button-pane)
-			 (horizontal-divider-pane)
-			 (vertical-divider-pane)
-			 (label-pane)
-			 ;;
-			 (list-pane)
-			 (caption-pane)
-			 (cascade-button)
+			 (list-pane motif-list-pane)
+			 (option-pane motif-option-pane)
 			 ))))
 
 ;;; We now need a lot of classes that mirror the xm classes.
@@ -76,13 +67,69 @@
   (when (sheet-mirror gadget)
     (tk::set-values (sheet-mirror gadget) :value nv)))
 
-(defmethod queue-value-changed-event (widget sheet)
+(defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet)))
   (declare (ignore widget))
   (distribute-event
    (port sheet)
    (make-instance 'value-changed-gadget-event
 		  :gadget sheet
-		  :value (gadget-value sheet))))
+		  :value value)))
+
+;; Gadgets that have a :label initarg
+
+(defclass motif-labelled-gadget () ())
+
+(defmethod find-widget-class-and-initargs-for-sheet
+    :around ((port motif-port)
+	     (parent t)
+	     (sheet motif-labelled-gadget))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (with-accessors ((alignment silica::gadget-alignment)
+		     (label gadget-label)) sheet
+      (when label
+	(unless (getf initargs :label-string)
+	  (setf (getf initargs :label-string) label)))
+      (unless (getf initargs :alignment)
+	(setf (getf initargs :alignment) 
+	  (ecase alignment
+	    ((:left nil) :beginning)
+	    (:center :center)
+	    (:right :end)))))
+    (values class initargs)))
+
+(defmethod (setf gadget-label) :after (nv (sheet motif-labelled-gadget))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :label-string (or nv
+								  ""))))
+
+(defmethod (setf silica::gadget-alignment) :after (nv (sheet motif-labelled-gadget))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) 
+		    :alignment (ecase nv
+				 ((:left nil) :beginning)
+				 (:center :center)
+				 (:right :end)))))
+
+;; Motif-orriented-gadget
+
+(defclass motif-oriented-gadget () ())
+
+(defmethod find-widget-class-and-initargs-for-sheet :around ((port motif-port)
+							     (parent t)
+							     (sheet motif-oriented-gadget))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (with-accessors ((orientation gadget-orientation)) sheet
+      (unless (getf initargs :orientation)
+	(setf (getf initargs :orientation) orientation)))
+    (values class initargs)))
+
+(defmethod (setf gadget-orientation) :after (nv (gadget motif-oriented-gadget))
+  (when (sheet-direct-mirror gadget)
+    (tk::set-values (sheet-direct-mirror gadget) :orientation nv)))
 
 ;;; Motif widgets that support the activate callback
 
@@ -103,27 +150,19 @@
 
 ;;; Label
 
-(defclass motif-label-pane (xt-leaf-pane label-pane) 
+(defclass motif-label-pane (xt-leaf-pane motif-labelled-gadget label-pane) 
 	  ())
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-label-pane))
-  (with-accessors ((label gadget-label)
-		   (alignment silica::gadget-alignment)) sheet
-    (values 'tk::xm-label
-	    (append
-	     (list :alignment 
-		   (ecase alignment
-		     ((:left nil) :beginning)
-		     (:center :center)
-		     (:right :end)))
-	     (and label (list :label-string label))))))
+  (values 'tk::xm-label nil))
 
 
 ;;; Push button
 
 (defclass motif-push-button (xt-leaf-pane
+			     motif-labelled-gadget
 			     push-button
 			     motif-action-pane) 
 	  ())
@@ -133,10 +172,7 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-push-button))
-  (declare (ignore port))
-  (with-accessors ((label gadget-label)) sheet
-    (values 'tk::xm-push-button 
-	    (and label (list :label-string label)))))
+  (values 'tk::xm-push-button nil))
 
 (defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area))
   (tk::add-callback widget 
@@ -219,55 +255,56 @@
 
 (defclass motif-slider (xt-leaf-pane
 			motif-range-pane
+			motif-oriented-gadget
 			slider)
 	  ())
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-slider))
-  (with-accessors ((orientation gadget-orientation)
-		   (label gadget-label)
+  (with-accessors ((label gadget-label)
 		   (show-value-p silica::gadget-show-value-p)
 		   (value gadget-value)) sheet
-    (values 'tk::xm-scale 
-	    (append
-	     (and show-value-p (list :show-value show-value-p ))
-	     (and label (list :title-string label))
-	     (list :orientation orientation)
-	     (and value (list :value value))))))
-
-
-;;;--- It seems that motif-sliders will actually tell you how big they
-;;;--- want to be. Mostly
-
-;(defmethod compose-space ((m motif-slider) &key width height)
-;  (declare (ignore width height))
-;  (destructuring-bind
-;      (label scroll-bar) (tk::widget-children (sheet-direct-mirror m))
-;    (declare (ignore scroll-bar))
-;    (multiple-value-bind
-;	(label-x label-y label-width label-height)
-;	(if (gadget-label m)
-;	    (tk::widget-best-geometry label)
-;	  (values nil nil 0 0))
-;      (declare (ignore label-x label-y))
-;      ;;-- We need to estimate the space requirements for the value if
-;      ;;-- that is shown.
-;      ;;-- Life sucks and then you die.  We need to determine the
-;      ;;-- text-extent of the biggest value we can show and incf that
-;      ;;-- Plus some scale margin.
-;      (let ((fudge 16))
-;	(ecase (gadget-orientation m)
-;	  (:vertical
-;	   (make-space-requirement :width (+ fudge label-width)
-;				   :min-height fudge
-;				   :height (max (* 2 fudge) label-height)
-;				   :max-height +fill+))
-;	  (:horizontal
-;	   (make-space-requirement :height (+ fudge label-height)
-;				   :min-width fudge
-;				   :width (max (* 2 fudge) label-width)
-;				   :max-width +fill+)))))))
+    (multiple-value-bind
+	(smin smax) (silica::gadget-range* sheet)
+
+      (let ((mmin 0) 
+	    (mmax 100)
+	    (decimal-points 0)
+	    (decimal-places (silica::slider-decimal-places sheet)))
+	(cond ((and (zerop decimal-places)
+		    (typep smin '(signed-byte 32))
+		    (typep smax '(signed-byte 32)))
+	       (setq mmin smin mmax smax decimal-points 0))
+	      ;; Real case
+	      (t
+	       (setq smin (float smin) smax (float smax))
+	       (let ((scaling (expt 10 decimal-places)))
+		 (setq mmin (round (* scaling smin))
+		       mmax (round (* scaling smax))
+		       decimal-points decimal-places))))
+
+	(assert (and (typep mmin '(signed-byte 32))
+		     (typep mmax '(signed-byte 32))))
+	
+	(values 'tk::xm-scale 
+		(append
+		 (and show-value-p (list :show-value show-value-p ))
+		 (and label (list :title-string label))
+		 (list :minimum mmin
+		       :maximum mmax
+		       :decimal-points decimal-points)
+		 (and value 
+		      (list :value (silica::compute-symmetric-value
+				    smin smax value mmin mmax)))))))))
+
+(defmethod (setf gadget-show-value-p) :after (nv (sheet motif-slider)) 
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :show-value nv)))
+
+(defmethod (setf gadget-label) :after (nv (sheet motif-slider))
+  (when (sheet-direct-mirror sheet)
+    (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv ""))))
 
 (defmethod compose-space ((m motif-slider) &key width height)
   (declare (ignore width height))
@@ -292,16 +329,14 @@
 
 
 (defclass motif-scroll-bar (xt-leaf-pane
-			   scroll-bar)
+			    motif-oriented-gadget
+			    scroll-bar)
 	  ())
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-scroll-bar))
-  (with-accessors ((orientation gadget-orientation)) sheet
-    ;;-- we should really decide what the min and max resources should be
-    (values 'tk::xm-scroll-bar 
-	    (list :orientation orientation))))
+  (values 'tk::xm-scroll-bar nil))
 
 (defmethod (setf silica::scroll-bar-size) (nv (sb motif-scroll-bar))
   (tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv))
@@ -501,6 +536,7 @@
 ;;; Toggle button
 
 (defclass motif-toggle-button (xt-leaf-pane 
+			       motif-labelled-gadget
 			       motif-value-pane
 			       toggle-button)
 	  ())
@@ -509,11 +545,9 @@
 						     (parent t)
 						     (sheet motif-toggle-button))
   (with-accessors ((set gadget-value)
-		   (label gadget-label)
 		   (indicator-type gadget-indicator-type)) sheet
     (values 'tk::xm-toggle-button 
 	    (append (list :set set)
-		    (and label (list :label-string label))
 		    (list :indicator-type 
 			  (ecase indicator-type
 			    (:one-of :one-of-many)
@@ -528,6 +562,7 @@
   (when (sheet-direct-mirror gadget)
     (tk::set-values (sheet-mirror gadget) :set nv)))
 
+#+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet clim-stream-sheet)
 				       (widget tk::xm-drawing-area))
@@ -583,6 +618,7 @@
 	    :resize-policy :none
 	    :scroll-bar-display-policy :static)))
 
+#+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet xm-viewport)
 				       (widget tk::xm-drawing-area))
@@ -595,6 +631,7 @@
 		    sheet))
 
 (defclass motif-radio-box (motif-geometry-manager
+			   motif-oriented-gadget
 			   mirrored-sheet-mixin
 			   sheet-multiple-child-mixin
 			   sheet-permanently-enabled-mixin
@@ -610,9 +647,7 @@
 						     (parent t)
 						     (sheet motif-radio-box))
   
-  (with-accessors ((orientation gadget-orientation)) sheet
-    (values 'tk::xm-radio-box
-	    (list :orientation orientation))))
+  (values 'tk::xm-radio-box nil))
 
 (defmethod value-changed-callback :after ((v gadget)
 					  (client motif-radio-box)
@@ -626,6 +661,7 @@
 			    v)))
 
 (defclass motif-check-box (motif-geometry-manager
+			   motif-oriented-gadget
 			   mirrored-sheet-mixin
 			   sheet-multiple-child-mixin
 			   sheet-permanently-enabled-mixin
@@ -641,9 +677,7 @@
 						     (parent t)
 						     (sheet motif-check-box))
   
-  (with-accessors ((orientation gadget-orientation)) sheet
-    (values 'tk::xm-row-column
-	    (list :orientation orientation))))
+  (values 'tk::xm-row-column nil))
 
 (defmethod value-changed-callback :after ((v gadget)
 					  (client motif-check-box)
@@ -681,6 +715,7 @@
 ;  ;;-- Is this what wrapping space mixin should do???
 ;  (move-and-resize-sheet* (sheet-child fr) 0 0 width height))
 
+
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet xm-frame-viewport)
 				       (widget tk::xm-drawing-area))
@@ -760,89 +795,148 @@
 						     (sheet motif-scrolling-window))
   (values 'xt::xm-scrolled-window nil))
 
-;;-- This needs work but we are getting there
-;;-- We should make it abstract and define the interface
-;;-- List of items and a unique string to appear.
+;; List-pane
+
+(defclass motif-list-pane (list-pane xt-leaf-pane)
+	  ())
 
-(defclass motif-list-pane (xt-leaf-pane)
-	  ((items :initarg :items :accessor list-pane-items))
-  (:default-initargs :items nil))
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet
 						      motif-list-pane))
-  (with-accessors ((items list-pane-items)) sheet
-    (values 'xt::xm-list 
-	    `(
-	      :items ,items :item-count ,(length items)))))
-
-(defmethod silica::gadget-supplied-scrolling (frame-manager frame (contents motif-list-pane) &rest ignore)
+  (with-accessors ((items set-gadget-items)
+		   (value gadget-value)
+		   (value-key set-gadget-value-key)
+		   (test set-gadget-test)
+		   (mode list-pane-mode)
+		   (name-key set-gadget-name-key)) sheet
+    (let ((selected-items
+	   (compute-list-pane-selected-items sheet value)))
+      (values 'xt::xm-list 
+	      `(
+		,@(and selected-items
+		       `(:selected-item-count ,(length selected-items)
+			 :selected-items ,selected-items))
+		:selection-policy 
+		,(ecase mode
+		   (:exclusive :single-select)
+		   (:nonexclusive :multiple-select))
+		:items ,(mapcar name-key items) 
+		:item-count ,(length items))))))
+
+(defun list-pane-single-selection-callback (widget item-position sheet)
+  (declare (ignore item-count))
+  (let ((item (funcall (set-gadget-value-key sheet) 
+		       (nth (1- item-position) (set-gadget-items sheet)))))
+    (queue-value-changed-event 
+     widget sheet
+     (and (not (funcall (set-gadget-test sheet) item (gadget-value sheet)))
+	  item))))
+
+(defun list-pane-multiple-selection-callback (widget item-positions sheet)
+  (declare (ignore item-count))
+  (let ((items (mapcar #'(lambda (item-position)
+			   (funcall (set-gadget-value-key sheet) 
+				    (nth (1- item-position)
+					 (set-gadget-items sheet))))
+		       item-positions)))
+    (queue-value-changed-event 
+     widget sheet items)))
+
+
+(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-list-pane) (widget xt::xm-list))
+  (ecase (list-pane-mode sheet)
+      (:exclusive
+       (tk::add-callback widget :single-selection-callback
+			 'list-pane-single-selection-callback sheet))
+      (:nonexclusive
+       (tk::add-callback widget :multiple-selection-callback 
+			 'list-pane-multiple-selection-callback sheet))))
+
+(defun compute-list-pane-selected-items (sheet value)
+  (with-accessors ((items set-gadget-items)
+		   (value-key set-gadget-value-key)
+		   (test set-gadget-test)
+		   (mode list-pane-mode)
+		   (name-key set-gadget-name-key)) sheet
+    (ecase mode
+      (:exclusive
+       (let ((x (find value items :test test :key value-key)))
+	 (and x (list (funcall name-key x)))))
+      (:nonexclusive
+       (mapcar name-key 
+	       (remove-if-not #'(lambda (item)
+				  (member (funcall value-key item) value :test test))
+			      items))))))
+
+(defmethod silica::gadget-supplied-scrolling (frame-manager frame
+					      (contents motif-list-pane)
+					      &rest ignore)
   (declare (ignore ignore))
   (with-look-and-feel-realization (frame-manager frame)
     (make-pane 'motif-scrolling-window :contents contents)))
 
-(defmethod gadget-value ((l motif-list-pane))
-  )
-
-(defmethod (setf gadget-value) (nv (l motif-list-pane) &key)
-  )
+(defmethod (setf gadget-value) :after (nv (l motif-list-pane) &key)
+  (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))))
 
 ;;; Option buttons
 
-(defclass motif-option-pane (xt-leaf-pane silica::labelled-gadget)
-	  ((items :initarg :items :accessor option-pane-items))
-  (:default-initargs :items nil))
+(defclass motif-option-pane (option-pane motif-labelled-gadget xt-leaf-pane)
+	  ((buttons :accessor motif-option-menu-buttons)))
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-option-pane))
-  (with-accessors ((label gadget-label)
-		   (items option-pane-items)) sheet
+  (with-accessors ((items set-gadget-items)
+		   (name-key set-gadget-name-key)
+		   (value-key set-gadget-value-key)) sheet
     (let ((pdm (make-instance 'xt::xm-pulldown-menu :managed nil :parent parent)))
-      (dolist (item items)
-	(make-instance 'tk::xm-push-button :label-string item :parent pdm))
+      (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)))
+		      (tk::add-callback  
+		       button
+		       :activate-callback
+		       'option-menu-callback-function
+		       (funcall value-key item)
+		       sheet)
+		      button))
+		items))
       (values 'xt::xm-option-menu
-	      (append
-	       (and label `(:label-string ,label))
-	       `(:sub-menu-id ,pdm))))))
-
-;;--- What is the interface to this? It seems to represent one of a
-;; set of N items. Does that set have a key and test and (setf)
-;; gadget-value changes/returns which is the current one?
-
-;; There seems to be a need for various types of dialog boxes.
-
-;;;; Inform-user
-;
-;(defmethod port-inform-user ((port motif-port) message 
-;			     &rest args
-;			     &key (title "Not some information")
-;			     &allow-other-keys)
-;  (apply #'question-user-1 ' message :title title  args))
-;
-;
-;(defmethod port-error-user ((port motif-port) message 
-;			    &rest args
-;			    &key (title "Not an error")
-;			     &allow-other-keys)
-;  (apply #'question-user-1  message :title
-;	 title  args))
-;
-;(defmethod port-question-user ((port motif-port) message 
-;			       &rest args
-;			       &key (title "Not A Question")
-;			     &allow-other-keys)
-;  (apply #'question-user-1 ' message :title title  args))
-;
-;(defmethod port-warn-user ((port motif-port) message 
-;			   &rest args
-;			   &key (title "Not A Warning")
-;			   &allow-other-keys)
-;  (apply #'question-user-1  message  :title title args))
-
-;;-- Guess we want to specify text of ok,cancel and help buttons
-;;-- and whether there is any help for the help-button
+	      `(:sub-menu-id ,pdm)))))
+
+(defun option-menu-callback-function (widget count value sheet)
+  (declare (ignore count))
+  (queue-value-changed-event widget sheet value))
+
+(defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key)
+  (set-option-menu-value gadget nv))
+
+(defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane))
+  (prog1 (call-next-method)
+    (set-option-menu-value pane (gadget-value pane))))
+
+(defun set-option-menu-value (gadget nv)
+  (with-accessors ((items set-gadget-items)
+		   (value-key set-gadget-value-key)
+		   (test set-gadget-test)
+		   (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))))))))
 
 (defmethod port-notify-user ((port motif-port)
 			     message-string 
@@ -867,7 +961,9 @@
 				 (:warning 'tk::xm-warning-dialog))
 			       :dialog-style :primary-application-modal
 			       :managed nil
-			       :parent (sheet-mirror associated-window)
+			       :parent (if (typep associated-window 'xt::xt-root-class)
+					   associated-window
+					   (sheet-mirror associated-window))
 			       :name name
 			       :dialog-title title
 			       :message-string message-string
@@ -908,7 +1004,7 @@
 	    (progn
 	      (tk::manage-child dialog)
 	      (wait-for-callback-invocation
-	       (port associated-window)
+	       port
 	       #'(lambda () (or result (not (tk::is-managed-p dialog))))
 	       "Waiting for dialog"))
 	  (tk::destroy-widget dialog))
@@ -916,16 +1012,12 @@
 
 
 (defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback"))
-  ;;-- Funnily enough if we are in the mouse process then we
-  ;;-- are hosed. We should process events until the
-  ;;-- predicate is true
-  ;;-- and exit sometime
   (if (eq mp:*current-process* (silica::port-process port))
       (progn
 	(loop 
 	  (when (funcall predicate) (return nil))
 	  (process-next-event port)))
-      (mp:process-wait whostate predicate)))
+    (mp:process-wait whostate predicate)))
 
 (defun get-message-box-child (widget &rest children)
   (values-list
diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp
index 5be5e84d..873df9fd 100644
--- a/tk-silica/xm-menus.lisp
+++ b/tk-silica/xm-menus.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-menus.lisp,v 1.9 92/04/10 14:27:51 cer Exp Locker: cer $
+;; $fiHeader: xm-menus.lisp,v 1.10 92/04/21 16:13:29 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -125,31 +125,39 @@
 		     :separator-type :double-line
 		     :parent menu))
     (labels ((make-menu-button (item class parent &rest options)
-	       (if simplep
-		   (apply #'make-instance
-			  class 
-			  :sensitive (clim-internals::menu-item-active item)
-			  :parent parent 
-			  :managed nil
-			  :label-string (string (menu-item-display item))
-			  options) 
-		 (let* ((pixmap (pixmap-from-menu-item
-				 associated-window 
-				 item
-				 printer
-				 presentation-type))
-			(button
-			 (apply #'make-instance
-				class 
-				:sensitive (clim-internals::menu-item-active item)
-				:parent parent 
-				:label-type :pixmap
-				:label-pixmap pixmap
-				options)))
-		   (xt::add-widget-cleanup-function
-		    button
-		    #'tk::destroy-pixmap pixmap)
-		   button)))
+	       (let ((button
+		      (if simplep
+			  (apply #'make-instance
+				 class 
+				 :sensitive (clim-internals::menu-item-active item)
+				 :parent parent 
+				 :managed nil
+				 :label-string (string (menu-item-display item))
+				 options) 
+			(let* ((pixmap (pixmap-from-menu-item
+					associated-window 
+					item
+					printer
+					presentation-type))
+			       (button
+				(apply #'make-instance
+				       class 
+				       :sensitive (clim-internals::menu-item-active item)
+				       :parent parent 
+				       :label-type :pixmap
+				       :label-pixmap pixmap
+				       options)))
+			  (xt::add-widget-cleanup-function
+			   button
+			   #'tk::destroy-pixmap pixmap)
+			  button))))
+		 (when (clim-internals::menu-item-documentation item)
+		   (tk::add-callback button 
+				 :help-callback 
+				 'display-motif-help
+				 port
+				 (clim-internals::menu-item-documentation item)))
+		 button))
 	     (construct-menu-from-items (menu items)
 	       (map nil #'(lambda (item)
 			    (ecase (clim-internals::menu-item-type item)
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index 91b84420..e9ffcb29 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.9 92/04/10 14:27:57 cer Exp Locker: cer $
+;; $fiHeader: xt-gadgets.lisp,v 1.10 92/04/15 11:48:52 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -115,11 +115,15 @@
 
 (defclass xt-pane (pane) ())
 
-(defmethod allocate-space ((p xt-pane) width height)
-  (when (sheet-mirror p)
-    (tk::set-values (sheet-mirror p) 
-		    :width (floor width)
-		    :height (floor height))))
+(defmethod port-note-gadget-activated :after ((client t) (gadget xt-pane))
+  (let (m)
+    (when (setq m (sheet-direct-mirror gadget))
+      (xt::set-sensitive m t))))
+
+(defmethod note-gadget-deactivated :after ((client t) (gadget xt-pane))
+  (let (m)
+    (when (setq m (sheet-direct-mirror gadget))
+      (xt::set-sensitive m nil))))
 
 ;(defclass xt-composite-pane () ())
 
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 879e583a..81e4b7c3 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.22 92/04/28 09:26:38 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.23 92/04/30 09:09:55 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -547,11 +547,19 @@
        (find-shell-of-calling-frame sheet))
       (port-application-shell port)))
 
-(defmethod find-shell-class-and-initargs ((port xt-port) sheet)
+(defmethod find-shell-class-and-initargs ((port xt-port) (sheet t))
   (values 'top-level-shell 
 	  ;; Need this so that an interactive pane can have children
 	  ;; but still accept the focus
-	  '(:keyboard-focus-policy :pointer)))
+	  `(:keyboard-focus-policy :pointer)))
+
+(defmethod find-shell-class-and-initargs :around ((port xt-port) (sheet pane))
+  (multiple-value-bind
+      (class initargs)
+      (call-next-method)
+    (values class
+	    `(:allow-shell-resize ,(clim-internals::frame-resizable (pane-frame sheet))
+				  ,@initargs))))
 
 (defmethod enable-mirror ((port xt-port) sheet)
   (declare (ignore port))
@@ -1016,10 +1024,6 @@
       (xt::set-sensitive widget nil))
     widget))
 
-(defmethod port-note-gadget-activated ((port xt-port) gadget)
-  (when (sheet-mirror gadget)
-    (xt::set-sensitive (sheet-mirror gadget) t)))
 
-(defmethod port-note-gadget-deactivated ((port xt-port) gadget)
-  (when (sheet-mirror gadget)
-    (xt::set-sensitive (sheet-mirror gadget) nil)))
+
+
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index 541ca7e0..bf1e9909 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.9 92/03/30 17:51:25 cer Exp $
+;; $fiHeader: callbacks.lisp,v 1.10 92/04/21 20:27:24 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -102,10 +102,10 @@
 	    ("applyCallback")         
 	    ("okCallback")            
 	    ("browseSelectionCallback") 
-	    ("singleSelectionCallback") 
+	    ("singleSelectionCallback" :single-selection) 
 	    ("defaultActionCallback")   
 	    ("extendedSelectionCallback")
-	    ("multipleSelectionCallback")
+	    ("multipleSelectionCallback" :multiple-selection)
 	    ("entryCallback")           
 	    ("mapCallback")             
 	    ("unmapCallback")           
@@ -137,3 +137,14 @@
 (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area)))
   (values (x-drawing-area-callback-window call-data)
 	  (x-drawing-area-callback-event call-data)))
+
+(defmethod spread-callback-data (widget call-data (type (eql :single-selection)))
+  (declare (ignore widget))
+  (xm-list-callback-struct-item-position call-data))
+
+(defmethod spread-callback-data (widget call-data (type (eql :multiple-selection)))
+  (declare (ignore widget))
+  (let ((si (xm-list-callback-struct-selected-item-positions call-data))
+	(r nil))
+    (dotimes (i (xm-list-callback-struct-selected-item-count call-data) (nreverse r))
+      (push (xm-selected-position-array si i) r))))
diff --git a/tk/resources.lisp b/tk/resources.lisp
index a18bff3c..d52f8be5 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.17 92/04/21 20:27:41 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.18 92/04/28 09:25:04 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -126,6 +126,7 @@
 	(x-arglist (aref arglist i) 0))
        values))))
 
+
 (defmethod convert-resource-in (class type value)
   (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value)
   (convert-resource-in class type value))
@@ -560,6 +561,7 @@
 
 (define-enumerated-resource visual-policy (:variable :constant))
 (define-enumerated-resource scroll-bar-display-policy (:static :as-needed))
+(define-enumerated-resource selection-policy (:single-select :multiple-select :extended-select :browse-select))
 
 (defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value)
   (if value
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index 9838e9c2..51e04542 100644
--- a/tk/xm-defs.lisp
+++ b/tk/xm-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-defs.lisp,v 1.2 92/04/21 20:27:45 cer Exp Locker: cer $
+;; $fiHeader: xm-defs.lisp,v 1.3 92/04/28 09:25:07 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -50,3 +50,17 @@
 	    (dir-length :int)
 	    (pattern xm-string)
 	    (pattern-length xm-string))
+
+(def-c-type (xm-list-callback-struct :no-defuns) :struct
+	    (reason :int)
+	    (event * x11:xevent)
+	    (item xm-string)
+	    (item-length :int)
+	    (item-position :int)
+	    (selection-items * xm-string)
+	    (selected-item-count :int)
+	    (selected-item-positions * :int)
+	    (selection-type :int))
+	    
+(def-c-type (xm-selected-position-array :no-defuns) 1 :int)
+
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index cecf1a2e..0378df27 100644
--- a/tk/xm-funs.lisp
+++ b/tk/xm-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-funs.lisp,v 1.3 92/04/21 20:27:47 cer Exp Locker: cer $
+;; $fiHeader: xm-funs.lisp,v 1.4 92/04/28 09:25:09 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -69,3 +69,9 @@
 
 (defforeign 'xm_file_selection_do_search
     :entry-point "_XmFileSelectionDoSearch")
+
+(defforeign 'xm_option_label_gadget
+    :entry-point "_XmOptionLabelGadget")
+
+(defforeign 'xm_option_button_gadget
+    :entry-point "_XmOptionButtonGadget")
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 7ddf94f7..4a98b7d1 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.12 92/04/28 09:25:23 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.13 92/04/30 09:09:18 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2651,6 +2651,18 @@
     gadget-value
     gadget-value-changed-callback
     gadget-show-value-p
+    
+    ;; this should go somewhere 
+    
+    slider-decimal-places
+    set-gadget-items
+    set-gadget-name-key
+    set-gadget-value-key
+    set-gadget-test
+    list-pane
+    list-pane-mode
+    option-pane
+    
     label-pane
     labelled-gadget
     menu-bar
-- 
GitLab