From cf492b0accd8e4da71993d638f4a70239226a6e6 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 21 Apr 1992 16:13:39 +0000
Subject: [PATCH] cerfixes

---
 clim/accept-values.lisp      |   4 +-
 clim/db-stream.lisp          |  13 +-
 clim/frames.lisp             |  56 ++++--
 clim/gadget-output.lisp      |  43 ++--
 clim/input-protocol.lisp     |  11 +-
 clim/menus.lisp              |   2 +-
 clim/pixmap-streams.lisp     |  12 +-
 clim/recording-protocol.lisp |  11 +-
 silica/db-box.lisp           |  18 +-
 silica/db-layout.lisp        |  65 +++---
 silica/db-scroll.lisp        | 176 +++++++++-------
 silica/framem.lisp           |   8 +-
 silica/gadgets.lisp          |  66 +++---
 silica/layout.lisp           |   5 +-
 silica/mirror.lisp           |  30 ++-
 silica/sheet.lisp            |  12 +-
 test/test-suite.lisp         |  30 +--
 test/test.lisp               | 103 ++++++----
 tk-silica/xm-frames.lisp     | 100 +++++++---
 tk-silica/xm-gadgets.lisp    | 375 ++++++++++++++++++++++++++++++-----
 tk-silica/xm-menus.lisp      |  33 +--
 tk-silica/xm-silica.lisp     |   6 +-
 tk-silica/xt-frames.lisp     |   9 +-
 tk-silica/xt-graphics.lisp   |  31 ++-
 tk-silica/xt-silica.lisp     |  48 ++++-
 tk/convenience.lisp          |  50 +----
 tk/foreign-obj.lisp          |   6 +-
 tk/gcontext.lisp             |  18 +-
 tk/make-classes.lisp         |   9 +-
 tk/resources.lisp            |  38 +++-
 tk/widget.lisp               |  35 ++--
 tk/xlib.lisp                 |  18 +-
 tk/xm-funs.lisp              |   5 +-
 utils/regions.lisp           |  13 +-
 34 files changed, 999 insertions(+), 460 deletions(-)

diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index af35ea63..43dbb3ee 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.14 92/04/14 15:29:50 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.15 92/04/15 11:46:02 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -187,7 +187,7 @@
     (with-slots (stream own-window  exit-button-stream) *application-frame*
       (vertically ()
 	  (outlining ()
-	(scrolling (:scroll-bars :dynamic)
+	(scrolling  (:scroll-bars :dynamic)
 	  (progn
 	    (setq stream
 		  (make-instance 'accept-values-stream
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 64b8a432..d7db2919 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.11 92/04/10 14:26:58 cer Exp Locker: cer $
+;; $fiHeader: db-stream.lisp,v 1.12 92/04/15 11:46:23 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -102,7 +102,16 @@
        :reader pane-display-time
        :initarg :display-time :initform :command-loop		
        :type (member nil :command-loop t))))
-	   
+
+(defmethod pane-needs-redisplay ((pane clim-stream-pane))
+  (with-slots (display-time) pane
+    (ecase display-time
+      ((t) (setq display-time nil) t)
+      ((nil) nil)
+      (:command-loop t))))
+
+(defmethod pane-needs-redisplay ((pane pane)) nil)
+
 (defmethod initialize-instance :after 
 	   ((pane clim-stream-pane) &key &allow-other-keys)
   (setf (sheet-transformation pane) +identity-transformation+))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index c2643c77..173a38bf 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.11 92/03/24 19:37:49 cer Exp $
+;; $fiHeader: frames.lisp,v 1.14 92/04/15 11:46:30 cer Exp Locker: cer $
 
 
 (in-package :clim-internals)
@@ -39,7 +39,8 @@
      (top-level :initarg :top-level  :accessor frame-top-level)
      (current-layout :initarg :default-layout :initform nil
 		     :reader frame-current-layout)
-     (default-size :initform nil :initarg :default-size)
+     (geometry :initform nil :initarg :geometry :reader frame-geometry)
+     (icon :initform nil :initarg :icon :reader frame-icon)
      (shell :accessor frame-shell)
      (pointer-documentation-p :initarg :pointer-documentation
 			      :reader frame-pointer-documentation-p)
@@ -63,8 +64,16 @@
 (defmethod initialize-instance :after ((frame standard-application-frame) 
 				       &rest args
 				       &key frame-manager
+					    geometry
+					    icon
 					    (parent frame-manager))
   (declare (ignore args))
+  
+  (destructuring-bind (&key x y width height) geometry
+    (declare (ignore x y width height)))
+  (destructuring-bind (&key name pixmap clip-mask) icon
+    (declare (ignore name pixmap clip-mask)))
+  
   (let ((frame-manager
 	  (etypecase parent
 	    (null (find-frame-manager))
@@ -97,7 +106,8 @@
   #+Genera (declare (zwei:indentation 1 25 2 3 3 1))
   (with-warnings-for-definition name define-application-frame
     (let (pane panes layout top-level menu-bar pointer-documentation
-	  command-definer command-table disabled-commands)
+	  command-definer command-table disabled-commands
+	  icon geometry default-initargs)
       (macrolet ((extract (name keyword default &optional (pair t))
 		   `(let ((entry (assoc ',keyword options)))
 		      (cond ((null entry)
@@ -120,7 +130,10 @@
 	(extract pointer-documentation :pointer-documentation nil)
 	(extract command-definer :command-definer t)
 	(extract command-table :command-table t)
-	(extract disabled-commands :disabled-commands nil))
+	(extract disabled-commands :disabled-commands nil)
+	(extract default-initargs :default-initargs nil nil)
+	(extract icon :icon nil nil)
+	(extract geometry :geometry nil nil))
       (check-type name symbol)
       (check-type superclasses list)
       (check-type slots list)
@@ -171,7 +184,10 @@
 	       ,@(and command-table `(:command-table ',(car command-table)))
 	       ,@(and top-level `(:top-level ',top-level))
 	       ,@(and panes `(:pane-constructors ,pane-constructors))
-	       ,@(and layout `(:default-layout ',(caar layout)))))
+	       ,@(and layout `(:default-layout ',(caar layout)))
+	       ,@(and icon `(:icon (list ,@icon)))
+	       ,@(and geometry `(:geometry (list ,@geometry)))
+	       ,@default-initargs))
 	   ,@(when command-definer
 	       `((defmacro ,command-definer (command-name arguments &body body)
 		   #+Genera (declare (zwei:indentation 1 3 2 1))
@@ -402,22 +418,30 @@
 (defun make-application-frame (frame-name &rest options 
 			       &key frame-class
 				    enable pretty-name
-			            width height
+			            x y width height
 				    save-under
 			       &allow-other-keys)
   (declare (dynamic-extent options))
   (check-type pretty-name (or null string))
   (when (null frame-class)
     (setq frame-class frame-name))
+  (when (or x y width height)
+    (when (getf options :geometry)
+      (error "Cannot specify :geometry and :x,:y,:width or :height at ~
+the same time " options))
+    (setf (getf options :geometry)
+      (append (and x `(:x ,x))
+	      (and y `(:y ,y))
+	      (and width `(:width ,width))
+	      (and height `(:height ,height)))))
   (with-keywords-removed (options options 
 			  '(:frame-class :pretty-name
-			    :enable :width :height :save-under))
+			    :enable :x :y :width :height :save-under))
       (let ((frame (apply #'make-instance frame-class
 			  :name frame-name
+			  ;;-- Perhaps this should be a default-initarg?
 			  :pretty-name (or pretty-name
 					   (title-capitalize (string frame-name)))
-			  :default-size (when (or width height)
-					  (list width height))
 			  :properties `(:save-under ,save-under)
 			  options)))
 	(when enable 
@@ -431,7 +455,8 @@
     (nstring-capitalize new-string)))
 
 (defmethod enable-frame ((frame standard-application-frame))
-  (with-slots (default-size) frame
+  (destructuring-bind
+      (&key width height &allow-other-keys) (frame-geometry frame)
     (ecase (frame-state frame)
       (:enabled)
       ((:disabled :disowned)
@@ -445,8 +470,8 @@
 	   frame
 	   (ecase old
 	     (:disowned 
-	       (if default-size 
-		   (values (first default-size) (second default-size))
+	       (if (and width height)
+		   (values width height)
 		   (values)))
 	     (:disabled
 	       (bounding-rectangle-size
@@ -644,6 +669,7 @@
 
 ;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc?
 ;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR?
+
 (defun redisplay-frame-pane (frame pane &key force-p)
   (when (symbolp pane)
     (setq pane (get-frame-pane frame pane)))
@@ -675,7 +701,7 @@
 			   (redisplay-p
 			    (redisplay redisplay-record pane 
 				       :check-overlapping check-overlapping))
-			   (t
+			   ((pane-needs-redisplay pane)
 			    (invoke-pane-display-function frame pane))))))))))
 	(force-p
 	 ;;-- Is there anything else we need to do?
@@ -822,9 +848,9 @@
 (defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
   (not (null (find-frame-pane-of-type frame 'interactor-pane))))
 
-(defmethod notify-user (frame format-string &rest format-arguments) 
+(defmethod notify-user (frame message &rest options) 
   (declare (dynamic-extent format-arguments))
-  (apply #'port-notify-user (port frame) frame format-string format-arguments))
+  (apply #'port-notify-user (port frame) message :frame frame options))
 
 
 ;;; Pointer documentation
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index f8818839..1e238471 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gadget-output.lisp,v 1.9 92/04/10 14:27:02 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.lisp,v 1.10 92/04/15 11:46:32 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -226,13 +226,16 @@
   (declare (ignore present-p))
   ;; value-key, test, sequence
   (with-output-as-gadget (stream)
-    (let* ((gadget
-	     (make-pane 'radio-box 
-			:label (and (stringp prompt) prompt)
-			:client stream :id query-identifier
-			:value-changed-callback
-			  (make-accept-values-value-changed-callback
-			    stream query-identifier))))
+    (let* (gadget frame-pane)
+      (setq frame-pane
+	(outlining ()
+		   (setq gadget
+		     (make-pane 'radio-box 
+				:label (and (stringp prompt) prompt)
+				:client stream :id query-identifier
+				:value-changed-callback
+				(make-accept-values-value-changed-callback
+				 stream query-identifier)))))
       (dolist (element sequence)
 	(make-pane 'toggle-button 
 		   :label (princ-to-string element)
@@ -242,7 +245,7 @@
 					(funcall value-key default)))
 		   :id element
 		   :parent gadget))
-      gadget)))
+      frame-pane)))
 
 
 ;;; Boolean gadget
@@ -257,8 +260,10 @@
 						    present-p query-identifier
 						    &key (prompt t))
   (declare (ignore default-supplied-p present-p))
-  (let ((gadget
-	  (with-output-as-gadget (stream)
+  (let (gadget)
+    (with-output-as-gadget (stream)
+      (outlining ()
+	  (setq gadget
 	    (make-pane 'toggle-button
 		       :label (and (stringp prompt) prompt)
 		       :value default
@@ -269,6 +274,9 @@
     ;;--- We end up not making a new gadget sometimes, I think because
     ;;--- we find a gadget already in the record so we need to modify
     ;;--- the value!
+    ;;--- I am no longer sure that this is true cos the graphics
+    ;;--- dialog seems to work fine.
+    #+ignore
     (setf (gadget-value gadget) default)))
 
 ;;; Integer gadget
@@ -284,13 +292,14 @@
 						    &key (prompt t))
   (declare (ignore present-p))
   (with-output-as-gadget (stream)
-    (make-pane 'slider
-	       :label (and (stringp prompt) prompt)
-	       :value (if default-supplied-p default 0)
-	       :client stream :id query-identifier
-	       :value-changed-callback
+    (outlining ()
+      (make-pane 'slider
+		 :label (and (stringp prompt) prompt)
+		 :value (if default-supplied-p default 0)
+		 :client stream :id query-identifier
+		 :value-changed-callback
 	         (make-accept-values-value-changed-callback
-		   stream query-identifier))))
+		  stream query-identifier)))))
 
 
 
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 094fd504..4a329553 100644
--- a/clim/input-protocol.lisp
+++ b/clim/input-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-protocol.lisp,v 1.10 92/03/30 17:52:30 cer Exp $
+;; $fiHeader: input-protocol.lisp,v 1.11 92/04/15 11:46:49 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -425,7 +425,14 @@
 (defmethod receive-gesture ((stream input-protocol-mixin) (gesture event))
   (process-event-locally stream gesture)
   nil)
-  
+
+;;;--- This is horrible
+
+(defmethod receive-gesture
+	   ((stream input-protocol-mixin) (gesture pointer-button-release-event))
+  ;; don't translate it
+  gesture)
+
 (defmethod receive-gesture
 	   ((stream input-protocol-mixin) gesture)
   ;; don't translate it
diff --git a/clim/menus.lisp b/clim/menus.lisp
index b294d6b3..a8482702 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.18 92/04/10 14:27:04 cer Exp Locker: cer $
+;; $fiHeader: menus.lisp,v 1.19 92/04/15 11:46:54 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp
index bbaa0b3a..814eb669 100644
--- a/clim/pixmap-streams.lisp
+++ b/clim/pixmap-streams.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pixmap-streams.lisp,v 1.2 92/02/24 13:08:10 cer Exp $
+;; $fiHeader: pixmap-streams.lisp,v 1.3 92/03/04 16:22:06 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -46,12 +46,17 @@
 (defmethod initialize-instance :after ((stream pixmap-stream) &key 
 							      port
 							      pixmap
-							      width height)
+							      width
+							      height
+							      sheet)
   (setf (sheet-direct-mirror stream) pixmap
 	(port stream) port
 	(sheet-transformation stream) +identity-transformation+
 	(sheet-region stream) (make-bounding-rectangle 0 0 width
-						       height)))
+						       height))
+  ;;-- What about text style
+  (setf (medium-foreground stream) (medium-foreground sheet)
+	(medium-background stream) (medium-background sheet)))
 
 ;; Interface to this stuff
 
@@ -75,6 +80,7 @@
 
 (defmethod allocate-pixmap-stream (sheet pixmap width height)
   (make-instance 'pixmap-stream 
+		 :sheet sheet
 		 :default-text-margin width
 		 :pixmap pixmap 
 		 :width width
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index 6adb3eff..e802bf57 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.7 92/04/14 15:29:55 cer Exp Locker: cer $
+;; $fiHeader: recording-protocol.lisp,v 1.8 92/04/15 11:47:13 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -665,11 +665,18 @@
 		   (map-over-output-records-overlapping-region 
 		     #'replay-1 record region 
 		     (- x-offset) (- y-offset)
-		     (+ x-offset xoff) (+ y-offset yoff)))
+		     (+ x-offset xoff) (+ y-offset yoff))
+		   ;;--- Nasty hack to get around nasty bug
+		   (note-output-record-replayed record stream region x-offset y-offset))
 		 (replay-output-record record stream region x-offset y-offset))))
     (declare (dynamic-extent #'replay-1))
     (replay-1 record x-offset y-offset)))
 
+(defmethod note-output-record-replayed ((record output-record-mixin) stream
+					&optional region x-offset y-offset)
+  (declare (ignore stream region x-offset y-offset))
+  nil)
+
 (defun move-cursor-beyond-output-record (stream record)
   (multiple-value-bind (x-offset y-offset)
       (convert-from-relative-to-absolute-coordinates
diff --git a/silica/db-box.lisp b/silica/db-box.lisp
index 839978ab..7f1b1e61 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.10 92/04/10 14:26:25 cer Exp Locker: cer $
+;; $fiHeader: db-box.lisp,v 1.11 92/04/15 11:44:59 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -81,7 +81,7 @@
 	(setq minor- (max 0 (- minor minor-min)))
 	(setq minor+ (max 0 (- minor-max minor)))
 	(apply #'make-space-requirement
-	       (mapcan #'(lambda (key val) (list key val))
+	       (mapcan #'list
 		       keys 
 		       (list major major+ major- minor minor+ minor-)))))))
 
@@ -115,9 +115,10 @@
 	      #'(lambda (x) (compose-space x :height height))))
 	  (x 0))
       (mapc #'(lambda (sheet size)
-		(move-and-resize-sheet* sheet 
-					x 0
-					(frob-size size width x) height)
+		(when (panep sheet)
+		  (move-and-resize-sheet* sheet 
+					  x 0
+					  (frob-size size width x) height))
 		(incf x size))
 	    contents sizes))))
 
@@ -151,9 +152,10 @@
 	      #'(lambda (x) (compose-space x :width width))))
 	  (y 0))
       (mapc #'(lambda (sheet size)
-		(move-and-resize-sheet* sheet 
-					0 y
-					width (frob-size size height y))
+		(when (panep sheet)
+		  (move-and-resize-sheet* sheet 
+					  0 y
+					  width (frob-size size height y)))
 		(incf y size))
 	    contents sizes))))
 
diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp
index b6b76ce9..7e816855 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.11 92/03/30 17:52:01 cer Exp $
+;; $fiHeader: db-layout.lisp,v 1.12 92/04/15 11:45:02 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -463,6 +463,9 @@ provided elsewhere"))
 
 ;;; Generally useful layout function
 ;;; Used all over to satisfy constraints
+;;--- I think that since coordinates are ultimately integers we loose
+;;---- along the way, calling fix-coor on alloc helps a little but we
+;;---- still end up with a gap along the bottom-right edges.
 
 (defun allocate-space-to-items (given wanted items min-size
 				desired-size max-size item-size)
@@ -475,30 +478,43 @@ provided elsewhere"))
       (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)))
+	(setq give (- (desired-size wanted) (min-size wanted))
+	      extra (min (- (desired-size wanted) given) give)))
       (dolist (item items)
-	(let* ((item-size (item-size item))
-	       (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)
-		  (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)
-		  (decf give (- (desired-size item-size)
-				(min-size item-size)))))
-	    (decf extra used))
+	(let (alloc)
+	  (typecase item
+	    ((member :fill)
+	     (if stretch-p
+		 (progn
+		   (setq alloc (/ (* +fill+ extra) give))
+		   (setq alloc (ceiling alloc))
+		   (fix-coordinates alloc)
+		   (decf give +fill+))
+	       (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)))))
 	  (push alloc sizes)))
       (nreverse sizes))))
 	
@@ -524,3 +540,4 @@ provided elsewhere"))
       (resize-sheet* child 
 		     (space-requirement-width space-req)
 		     (space-requirement-height space-req)))))
+
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index e92bf898..e0128018 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.13 92/04/14 15:29:31 cer Exp Locker: cer $
+;; $fiHeader: db-scroll.lisp,v 1.14 92/04/15 11:45:04 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -15,9 +15,12 @@
 (defclass scroller-pane (client-space-requirement-mixin
 			 wrapping-space-mixin
 			 layout-pane)
-	  ((scroll-bars :initarg :scroll-bars)
-	   vertical-scroll-bar
-	   horizontal-scroll-bar
+	  ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy)
+	   (vertical-scroll-bar :initform nil :accessor scroller-pane-vertical-scroll-bar)
+	   (horizontal-scroll-bar :accessor 
+				  scroller-pane-horizontal-scroll-bar
+				  :initform nil)
+	   (scrolling-supplied-by-gadget :initform nil)
 	   contents
 	   viewport)
   (:default-initargs :scroll-bars :both))
@@ -38,93 +41,128 @@
 	      'scroller-pane)
        (sheet-parent (sheet-parent (sheet-parent x)))))
 
-(defmethod gadget-supplies-scroll-bars-p ((gadget t))
+(defmethod gadget-supplied-scrolling (frame-manager frame contents &rest ignore)
+  (declare (ignore frame-manager frame ignore contents))
   nil)
 
+(defmethod allocate-space :before ((sp scroller-pane) width height)
+  (declare (ignore width height))
+  ;; Adjust the status of the scrollbars
+  (multiple-value-bind
+      (changedp 
+       hscroll-bar hscroll-bar-enabled-p
+       vscroll-bar vscroll-bar-enabled-p)
+      (compute-dynamic-scroll-bar-values sp)
+    (if changedp
+	(update-dynamic-scroll-bars 
+	 sp
+	 changedp
+	 hscroll-bar hscroll-bar-enabled-p
+	 vscroll-bar vscroll-bar-enabled-p))))
+
+(defmethod compose-space ((sp scroller-pane) &key width height)
+  (declare (ignore width height))
+  (let ((sr (copy-space-requirement (call-next-method))))
+    (maxf (space-requirement-width sr) 50)
+    (maxf (space-requirement-height sr) 50)
+    sr))
+
 ;;--- Ideally we should use a toolkit scrolling window. This will look
 ;;--- exactly right and will deal with user specified placement of scroll-bars.
 ;;--- However the geometry management problems are quite huge.
 
+
 (defmethod initialize-instance :after ((pane scroller-pane) 
 				       &key contents frame-manager frame
 					    scroll-bars)
-  (if (gadget-supplies-scroll-bars-p contents)
-      (sheet-adopt-child pane contents)
-    (progn
-      (check-type scroll-bars
-	  (member :both :dynamic :vertical :horizontal))
-      (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane
-	(with-look-and-feel-realization (frame-manager frame)
-	  (let ((verticalp
-		 (member scroll-bars '(:both :dynamic :vertical)))
-		(horizontalp
-		 (member scroll-bars '(:both :dynamic :horizontal))))
-	    (setf vertical-scroll-bar 
-	      (and verticalp
-		   (make-pane 'scroll-bar 
-			      :orientation :vertical
-			      :client pane
-			      :id :vertical))
-	      horizontal-scroll-bar 	    
-	      (and horizontalp
-		   (make-pane 'scroll-bar 
-			      :id :horizontal
-			      :client pane
-			      :orientation :horizontal))
-	      c contents
-	      viewport (make-pane 'viewport))
-	    (sheet-adopt-child pane
-			       (cond ((and horizontalp verticalp)
-				      (tabling ()
-					       (viewport vertical-scroll-bar)
-					       (horizontal-scroll-bar
-						nil)))
-				     (verticalp
-				      (horizontally ()
+  (let ((x (gadget-supplied-scrolling frame-manager frame contents :scroll-bars scroll-bars)))
+    (if x
+	(progn
+	  (sheet-adopt-child pane x)
+	  (setf (slot-value pane 'scrolling-supplied-by-gadget) t)
+	  x)
+      (progn
+	(check-type scroll-bars
+	    (member :both :dynamic :vertical :horizontal))
+	(with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane
+	  (with-look-and-feel-realization (frame-manager frame)
+	    (let ((verticalp
+		   (member scroll-bars '(:both :dynamic :vertical)))
+		  (horizontalp
+		   (member scroll-bars '(:both :dynamic :horizontal))))
+	      (setf vertical-scroll-bar 
+		(and verticalp
+		     (make-pane 'scroll-bar 
+				:orientation :vertical
+				:client pane
+				:id :vertical))
+		horizontal-scroll-bar 	    
+		(and horizontalp
+		     (make-pane 'scroll-bar 
+				:id :horizontal
+				:client pane
+				:orientation :horizontal))
+		c contents
+		viewport (make-pane 'viewport))
+	      (sheet-adopt-child pane
+				 (cond ((and horizontalp verticalp)
+					(tabling ()
+						 (viewport vertical-scroll-bar)
+						 (horizontal-scroll-bar
+						  nil)))
+				       (verticalp
+					(horizontally ()
+						      viewport
+						      vertical-scroll-bar))
+				       (horizontalp
+					(vertically ()
 						    viewport
-						    vertical-scroll-bar))
-				     (horizontalp
-				      (vertically ()
-						  viewport
-						  horizontal-scroll-bar))
-				     (t
-				      (error "Should not have got here"))))
-
-	    (sheet-adopt-child viewport c)
-	    ;;-- Add callbacks
-	    ))))))
+						    horizontal-scroll-bar))
+				       (t
+					(error "Should not have got here"))))
+
+	      (sheet-adopt-child viewport c)
+	      ;;-- Add callbacks
+	      )))))))
 
 (defun update-scroll-bars (vp)
   ;;-- This is not the most efficient thing in the world
-  (multiple-value-call
-      #'update-dynamic-scroll-bars
-    vp (compute-dynamic-scroll-bar-values vp))
+  (multiple-value-bind
+      (changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar
+       vscroll-bar-enabled-p)
+      (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent vp)))
+    (update-dynamic-scroll-bars
+     (sheet-parent (sheet-parent vp))
+     changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar
+     vscroll-bar-enabled-p t))
+    ;;;
   (with-bounding-rectangle* (minx miny maxx maxy)
-      (let ((c (sheet-child vp)))
-	;;--- This is a major kludge
-	(if (typep c 'clim-internals::output-recording-mixin)
-	    (stream-output-history c)
-	    c))
+    (viewport-contents-extent vp)
     (with-bounding-rectangle* (vminx vminy vmaxx vmaxy)
-	(viewport-viewport-region vp)
-      (with-slots (horizontal-scroll-bar vertical-scroll-bar)
-		  (sheet-parent (sheet-parent vp))
+      (viewport-viewport-region vp)
+      (with-accessors ((horizontal-scroll-bar scroller-pane-horizontal-scroll-bar)
+		       (vertical-scroll-bar scroller-pane-vertical-scroll-bar))
+	  (sheet-parent (sheet-parent vp))
 	(update-scroll-bar vertical-scroll-bar
-			  miny maxy vminy vmaxy)
+			   miny maxy vminy vmaxy)
 	(update-scroll-bar horizontal-scroll-bar
-			  minx maxx vminx vmaxx)))))
+			   minx maxx vminx vmaxx)))))
 
 ;;--- In the case where the viewport is bigger than the window this
 ;;--- code gets things wrong. Check out the thinkadot demo.  It's
 ;;--- because (- (--) (- vmin)) is negative.
+
 (defun update-scroll-bar (scroll-bar min max vmin vmax)
   (declare (optimize (safety 0) (speed 3)))
-  (with-slots (current-size current-value) scroll-bar
+    (let ((current-size (scroll-bar-current-size scroll-bar))
+	  (current-value (scroll-bar-current-value scroll-bar)))
     ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size
     ;; before, and the viewport is bigger than the extent, don't bother with
     ;; the fancy math.
-    (let ((range (float (gadget-range scroll-bar) 0.0s0)))
-      (declare (type single-float range))
+      (let* ((gmin (float (gadget-min-value scroll-bar) 0s0))
+	     (gmax (float (gadget-max-value scroll-bar) 0s0))
+	     (range (- gmax gmin)))
+      (declare (type single-float range gmin gmax))
       (if (and (and current-size (= (the single-float current-size) range))
 	       (> (- vmax vmin) (- max min)))
 	  (return-from update-scroll-bar))
@@ -153,8 +191,8 @@
 		     current-value
 		     (= current-size size)
 		     (= current-value value))
-	  (setf current-size size
-		current-value value)
+	  (setf (scroll-bar-current-size scroll-bar) size
+		(scroll-bar-current-value scroll-bar) value)
 	  (change-scroll-bar-values scroll-bar 
 				   :slider-size size
 				   :value value))))))
@@ -176,9 +214,7 @@
 					      size)
   (with-slots (viewport contents) client
     ;;--- This TYPEP stuff is a major kludge
-    (let* ((extent (if (typep contents 'clim-internals::output-recording-mixin)
- 		       (stream-output-history contents)
- 		       contents))
+    (let* ((extent (viewport-contents-extent viewport))
 	   (vp viewport)
 	   (viewport (viewport-viewport-region vp)))
       (case id
diff --git a/silica/framem.lisp b/silica/framem.lisp
index 4a623792..6f44ada9 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.4 92/04/10 14:26:31 cer Exp Locker: cer $
+;; $fiHeader: framem.lisp,v 1.5 92/04/15 11:45:09 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -75,10 +75,14 @@
 	(delete frame (frame-manager-frames framem))))
 
 (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame)
-  ;; Perhaps we want to resize the top level sheet if there is one
+  (update-frame-settings framem frame)
+  ;;--- Perhaps we want to resize the top level sheet if there is one
   (when (frame-top-level-sheet frame)
     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)))
 
+(defmethod update-frame-settings ((framem standard-frame-manager) (frame t))
+  nil)
+
 (defmethod note-frame-disabled :after ((framem standard-frame-manager) frame)
   (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil))
 
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 70db1fdd..26f792b1 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.16 92/04/14 15:29:37 cer Exp Locker: cer $
+;; $fiHeader: gadgets.lisp,v 1.17 92/04/15 11:45:10 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -148,10 +148,11 @@
 
 
 ;; Scroll bar
+
 (defclass scroll-bar
 	  (value-gadget range-gadget-mixin oriented-gadget)
-    ((current-value :initform nil)
-     (current-size :initform nil)
+    ((current-value :initform nil :accessor scroll-bar-current-value)
+     (current-size :initform nil :accessor scroll-bar-current-size)
      (drag-callback :initarg :drag-callback :initform nil
 		    :reader scroll-bar-drag-callback)))
 
@@ -278,51 +279,34 @@
 
 ;;--- Work on this
 
-
-(defmethod note-sheet-region-changed :around ((viewport viewport) &key port-did-it)
-  (declare (ignore port-did-it))
-  (multiple-value-bind
-      (changedp 
-       hscroll-bar hscroll-bar-enabled-p
-       vscroll-bar vscroll-bar-enabled-p)
-      (compute-dynamic-scroll-bar-values viewport)
-    (if changedp
-	(update-dynamic-scroll-bars 
-	 viewport
-	 changedp
-	 hscroll-bar hscroll-bar-enabled-p
-	 vscroll-bar vscroll-bar-enabled-p)
-      (call-next-method))))
-
-
-(defun update-dynamic-scroll-bars (viewport
-				  changedp
-				  hscroll-bar hscroll-bar-enabled-p
-				  vscroll-bar vscroll-bar-enabled-p)
+(defun update-dynamic-scroll-bars (sp 
+				   changedp
+				   hscroll-bar hscroll-bar-enabled-p
+				   vscroll-bar vscroll-bar-enabled-p
+				   &optional relayout)
   (when changedp
     (when hscroll-bar
       (setf (sheet-enabled-p hscroll-bar) hscroll-bar-enabled-p))
     (when vscroll-bar
       (setf (sheet-enabled-p vscroll-bar) vscroll-bar-enabled-p))
-    (let ((table (sheet-parent viewport)))
-      (clear-space-requirement-caches-in-tree table)
-      (multiple-value-call
-	  #'allocate-space
-	table
-	(bounding-rectangle-size table)))))
-
-(defun compute-dynamic-scroll-bar-values (viewport)
-  (with-slots ((hscroll-bar horizontal-scroll-bar )
-	       (vscroll-bar vertical-scroll-bar)
-	       (scroll-bar-policy scroll-bars))
-      (sheet-parent (sheet-parent viewport))
+    (clear-space-requirement-caches-in-tree sp)
+    (when relayout
+      (multiple-value-bind
+	  (w h)
+	  (bounding-rectangle-size sp)
+	  (allocate-space sp w h)))))
+
+(defun compute-dynamic-scroll-bar-values (sp)
+  (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar sp))
+	 (vscroll-bar (scroller-pane-vertical-scroll-bar sp))
+	 (scroll-bar-policy (scroller-pane-scroll-bar-policy sp)))
     (if (eq scroll-bar-policy :dynamic)
 	(multiple-value-bind
-	    (vwidth vheight) (bounding-rectangle-size viewport)
+	    (vwidth vheight) (bounding-rectangle-size sp)
 	  (multiple-value-bind
 	      (cwidth cheight) 
 	      (bounding-rectangle-size 
-	       (viewport-contents-extent viewport))
+	       (viewport-contents-extent (slot-value sp 'viewport)))
 	    (let ((ohenp (sheet-enabled-p hscroll-bar))
 		  (ovenp (sheet-enabled-p vscroll-bar))
 		  (nhenp (> cwidth vwidth))
@@ -338,12 +322,10 @@
 
 (defun viewport-contents-extent (viewport)
   (let ((c (sheet-child viewport)))
-    (if (typep c 'clim-internals::output-recording-mixin)
-	(stream-output-history c)
-      c)))
+    (stream-output-history c)))
 
 ;;--- Need something in update-scroll-bars also.
-	    
+l	    
 ;;; Then there is the layout stuff and scrolling macros
 
 (defmacro scrolling (options &body contents)
diff --git a/silica/layout.lisp b/silica/layout.lisp
index 4fa0521d..6e7edc9d 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.11 92/04/10 14:26:34 cer Exp Locker: cer $
+;; $fiHeader: layout.lisp,v 1.12 92/04/15 11:45:13 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -105,8 +105,9 @@
 	      ,@options))
 
 
+;;;---- Should force be T
 
-(defmethod resize-sheet* ((sheet sheet) width height &key force)
+(defmethod resize-sheet* ((sheet sheet) width height &key (force t))
   (when (or width height)
     (with-bounding-rectangle* (minx miny maxx maxy) sheet
       (when (or force
diff --git a/silica/mirror.lisp b/silica/mirror.lisp
index bc51723c..92b1fcd9 100644
--- a/silica/mirror.lisp
+++ b/silica/mirror.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: mirror.lisp,v 1.14 92/03/30 17:52:06 cer Exp $
+;; $fiHeader: mirror.lisp,v 1.15 92/04/15 11:45:16 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -66,9 +66,11 @@
 (defgeneric sheet-device-transformation (sheet))
 
 (defmethod sheet-device-transformation ((sheet sheet))
-  (compose-transformations
-    (sheet-transformation sheet)
-    (sheet-device-transformation (sheet-parent sheet))))
+  (or (sheet-cached-device-transformation sheet)
+      (setf (sheet-cached-device-transformation sheet)
+	(compose-transformations
+	 (sheet-transformation sheet)
+	 (sheet-device-transformation (sheet-parent sheet))))))
 
 (defmethod sheet-device-transformation :around ((sheet mirrored-sheet-mixin))
   (if (sheet-direct-mirror sheet)
@@ -95,12 +97,15 @@
   (sheet-native-region sheet))
 
 ;;--- This assumes that sheet siblings do not overlap...
+
 (defmethod sheet-device-region (sheet)
-  (region-intersection
-    (transform-region 
-      (sheet-device-transformation sheet)
-      (sheet-region sheet))
-    (sheet-device-region (sheet-parent sheet))))
+  (or (sheet-cached-device-region sheet)
+      (setf (sheet-cached-device-region sheet)
+	(region-intersection
+	 (transform-region 
+	  (sheet-device-transformation sheet)
+	  (sheet-region sheet))
+	 (sheet-device-region (sheet-parent sheet))))))
 
 ;;;; Mirror region stuff
 
@@ -157,7 +162,14 @@
 	      (setf (sheet-direct-mirror sheet)
 		    (call-next-method)))))
     (setf (gethash mirror (port-mirror->sheet-table port)) sheet)
+    ;;--- What is the right thing do here.
+    ;;--- In the motif port we note specify the width and height of
+    ;;--- widgets when we make them. We rely on the layout protocol -
+    ;;--- ???  to take care of all of that, ie. to go in and change
+    ;;--- the size
+    #+ignore
     (update-mirror-transformation port sheet)
+    (setf (sheet-native-transformation sheet) +identity-transformation+)
     mirror))
 
 (defmethod destroy-mirror :around ((port port) (sheet mirrored-sheet-mixin))
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index b8bbd381..31592d59 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: sheet.lisp,v 1.9 92/03/30 17:52:08 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.10 92/04/15 11:45:19 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -264,14 +264,18 @@
    nil))
 
 (defgeneric invalidate-cached-transformations (sheet)
-  (:method ((sheet t)) nil)
+  (:method ((sheet t)) 
+	   (setf (sheet-cached-device-region sheet) nil)
+	   (setf (sheet-cached-device-transformation sheet) nil))
   (:method :after ((sheet sheet-parent-mixin))
     (mapc #'invalidate-cached-transformations (sheet-children sheet))))
 	     
 (defgeneric invalidate-cached-regions (sheet)
-  (:method ((sheet t)) nil)
+  (:method ((sheet t)) 
+	   (setf (sheet-cached-device-region sheet) nil)
+	   (setf (sheet-cached-device-transformation sheet) nil))
   (:method :after ((sheet sheet-parent-mixin))
-    (mapc #'invalidate-cached-regions (sheet-children sheet))))
+	   (mapc #'invalidate-cached-regions (sheet-children sheet))))
 
 (defmethod note-sheet-region-changed :before (sheet &key port-did-it)
   (declare (ignore port-did-it))
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 6ad6dd10..dd1e4ffc 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.15 92/04/10 14:27:18 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.16 92/04/15 11:47:40 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -780,7 +780,7 @@ people, shall not perish from the earth.
     (circle 100  50 40 1)
     (circle  75 100 40 2)
     (circle 125 100 40 3))
-  (stream-set-cursor-position* stream 0 150)
+  (stream-set-cursor-position stream 0 150)
   (format stream "~S" (accept 'integer :stream stream)))
 
 (define-test (ordering-test-2a output-recording) (stream)
@@ -791,7 +791,7 @@ people, shall not perish from the earth.
     (rect  50  50 150 150 1)
     (rect   0   0 100 100 2)
     (rect  25  25 125 125 3))
-  (stream-set-cursor-position* stream 0 160)
+  (stream-set-cursor-position stream 0 160)
   (format stream "~S" (accept 'integer :stream stream)))
 
 (define-test (ordering-test-2b output-recording) (stream)
@@ -802,7 +802,7 @@ people, shall not perish from the earth.
     (rect 125 125 225 225 1)
     (rect   0   0 100 100 2)
     (rect  50  50 150 150 3))
-  (stream-set-cursor-position* stream 0 240)
+  (stream-set-cursor-position stream 0 240)
   (format stream "~S" (accept 'integer :stream stream)))
 
 (define-test (cursorpos-table output-recording) (stream)
@@ -814,7 +814,7 @@ people, shall not perish from the earth.
     (multiple-value-bind (x y)
 	(stream-cursor-position stream)
       (dotimes (i 11)
-	(stream-set-cursor-position* stream x y)
+	(stream-set-cursor-position stream x y)
 	(write-string (format nil "~1$" (float (/ i 10))) stream)
 	(incf x (+ rect-width spacing))))
     (terpri stream)
@@ -941,7 +941,7 @@ people, shall not perish from the earth.
 
 (define-test (checkerboard formatted-output) (stream)
   "This should produce a checkerboard pattern."
-  (stream-set-cursor-position* stream 10 10)
+  (stream-set-cursor-position stream 10 10)
   (surrounding-output-with-border (stream)
     (formatting-table (stream :y-spacing 0 :x-spacing 0)
       (dotimes (i 8)
@@ -965,13 +965,13 @@ people, shall not perish from the earth.
 
 (define-test (simple-borders formatted-output) (stream)
   "Show the three types of canned borders."
-  (stream-set-cursor-position* stream 10 10)
+  (stream-set-cursor-position stream 10 10)
   (surrounding-output-with-border (stream :shape :rectangle)
     (write-string "a rectangle" stream))
-  (stream-set-cursor-position* stream 10 30)
+  (stream-set-cursor-position stream 10 30)
   (surrounding-output-with-border (stream :shape :drop-shadow)
     (write-string "a dropshadow" stream))
-  (stream-set-cursor-position* stream 10 50)
+  (stream-set-cursor-position stream 10 50)
   (surrounding-output-with-border (stream :shape :underline)
     (write-string "an underline" stream)))
 
@@ -1018,7 +1018,7 @@ people, shall not perish from the earth.
 
 (define-test (offset-table formatted-output) (stream)
   "Draw a table offset in the window.  After refreshing, it should look the same."
-  (stream-set-cursor-position* stream 20 20)
+  (stream-set-cursor-position stream 20 20)
   (formatting-table (stream)
     (dotimes (i 10)
       (formatting-row (stream)
@@ -1034,7 +1034,7 @@ people, shall not perish from the earth.
 (define-test (offset-graph formatted-output) (stream)
   "Draw a graph offset in the window.  After refreshing, it should look the same."
   (let ((orientation :horizontal))
-    (stream-set-cursor-position* stream 20 20)
+    (stream-set-cursor-position stream 20 20)
     (macrolet ((make-node (&key name children)
 		 `(list* ,name ,children)))
       (flet ((node-name (node)
@@ -1128,7 +1128,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(write-string doc-string documentation)
 	(write-string caption documentation)
 	(force-output documentation))
-      (stream-set-cursor-position* stream 30 30)
+      (stream-set-cursor-position stream 30 30)
       (funcall continuation stream)
       (draw-line* stream 30 15 30 45 :ink +green+)
       (draw-line* stream 15 30 45 30 :ink +green+)
@@ -1248,7 +1248,7 @@ Luke Luck licks the lakes Luke's duck likes."))
       (draw-rectangle* stream left top right bottom :filled nil :ink +cyan+))))
 
 (define-table-cell-test set-cursor-position* "move the cursor, output some text"
-  (stream-set-cursor-position* stream 50 50)
+  (stream-set-cursor-position stream 50 50)
   (write-string ">Wally<" stream))
 
 (define-test (comprehensive-table-tests formatted-output) (stream)
@@ -1366,7 +1366,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 	   (updating-output (stream)
 	     (updating-output (stream :unique-id 'test
 				      :cache-value tick)
-	       (stream-set-cursor-position* stream 10 10)
+	       (stream-set-cursor-position stream 10 10)
 	       (surrounding-output-with-border (stream)
 		 (format stream "Tick ~A" value))))))
     (repeat 5
@@ -1474,7 +1474,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 		      (draw-line* stream 0 0 20 20 :line-thickness 0)
 		      (draw-circle* stream 50 10 10)))
 	(incf delta-y 30))
-      (stream-set-cursor-position* stream 0 delta-y)))
+      (stream-set-cursor-position stream 0 delta-y)))
   (loop
     (accept 'integer :stream stream)
     (fresh-line stream)))
diff --git a/test/test.lisp b/test/test.lisp
index 44f236db..057ba633 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.19 92/04/10 14:27:21 cer Exp Locker: cer $
+;; $fiHeader: test.lisp,v 1.20 92/04/15 11:47:45 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -49,7 +49,17 @@
   (:command-table test-frame)
   (:pane 
     (scrolling ()
-	       (make-pane 'interactor-pane))))
+	       (make-pane 'interactor-pane)))
+  
+  (:icon :name "foo" 
+	 :pixmap (make-pattern 
+		  (let ((x (make-array '(48 48))))
+		    (dotimes (i 48)
+		      (dotimes (j 48)
+			(setf (aref x i j) (random 2))))
+		    x)
+		  (list +red+ +green+)))
+  (:geometry :width 100 :height 200))
 
 
 (define-application-frame test-frame01 () ()
@@ -401,12 +411,14 @@
 			:activate-callback 'push-button-callback)
 	  (make-pane 'push-button 
 			:label "B2"
-			:activate-callback 'push-button-callback)))
+			:activate-callback 'push-button-callback)
+	  :fill))
       (outlining ()
 	(horizontally ()
 	  (make-pane 'toggle-button
 			:label "T1" 
 			:value-changed-callback 'toggle-button-callback)
+	  :fill
 	  (make-pane 'toggle-button 
 			:label "T2"
 			:value-changed-callback
@@ -435,47 +447,50 @@
 
 
 (define-application-frame tf98 () ()
-  (:command-table test-frame)
-  (:pane 
-   (vertically ()
-      (outlining ()
-	(horizontally ()
-	  (make-pane 'push-button 
-			:label "B1"
-			:activate-callback 'push-button-callback)
-	  (make-pane 'push-button 
-			:label "B2"
-			:activate-callback 'push-button-callback)))
-      (outlining ()
-	(horizontally ()
-	  (make-pane 'toggle-button
-			:label "T1" 
-			:value-changed-callback 'toggle-button-callback)
-	  (make-pane 'toggle-button 
-			:label "T2"
-			:value-changed-callback
-			'toggle-button-callback)))
-      (outlining ()
-       (horizontally ()
-		     (scrolling ()
-				(make-pane 'text-editor 
-					   :value "lucid sucks"
-					   :value-changed-callback 'text-field-changed
-					   :ncolumns 30
-					   :nlines 10))
-		     (scrolling ()
-				(make-pane 'text-editor 
-					   :value "harlqn sucks more"
-					   :value-changed-callback 'text-field-changed
-					   :ncolumns 30
-					   :nlines 10))))
-      (outlining ()
-	(spacing ()
-	  (make-pane 'slider
-		     :label "Slider"
-		     :show-value-p t
-		     :value-changed-callback 'slider-changed-callback
-		     :drag-callback 'slider-dragged-callback))))))
+			  (:command-table test-frame)
+			  (:pane 
+			   (outlining ()
+				      (horizontally ()
+						    (make-pane
+						     'xm-silica::motif-scrolling-window
+						     :contents
+						     (make-pane 'text-editor 
+								:value "lucid sucks"
+								:value-changed-callback 'text-field-changed
+								:ncolumns 30
+								:nlines 10))
+						    (make-pane
+						     'xm-silica::motif-scrolling-window
+						     :contents (make-pane 'text-editor 
+									  :value "harlqn sucks more"
+									  :value-changed-callback 'text-field-changed
+									  :ncolumns 30
+									  :nlines 10))))))
+
+
+(define-application-frame tf97 
+    () ()
+    (: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
+			    :items '("eenie" "meanie" "minie")
+			    :label "moo")
+		 (outlining ()
+			    (make-pane
+			     'xm-silica::motif-scrolling-window
+			     :contents
+			     (make-pane 'text-editor 
+					:value
+					"lucid are nice guys "
+					:value-changed-callback 'text-field-changed
+					:ncolumns 30
+					:nlines 10))))))
 
 
 
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index d54a1ee4..8392f14a 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.11 92/03/09 17:41:25 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.12 92/04/10 14:27:49 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -140,10 +140,26 @@
 	  ((command-table :initarg :command-table)))
 
 (defmethod find-widget-class-and-initargs-for-sheet 
-	   ((port motif-port) (parent t) (sheet motif-menu-bar))
-  (values 'tk::xm-menu-bar 
-	  (list :resize-height t
-		:resize-width t)))
+    ((port motif-port) (parent t) (sheet motif-menu-bar))
+  (if (flat-command-table-menu-p (slot-value sheet 'command-table))
+      (values 'xt::xm-row-column 
+	      ;;--- It makes sense to be able to specify the orientation
+	      ;;--- of the command menu
+	      (list :orientation :horizontal))
+    (values 
+     'tk::xm-menu-bar 
+     (list :resize-height t
+	   :resize-width t))))
+
+(defun flat-command-table-menu-p (ct)
+  (map-over-command-table-menu-items
+   #'(lambda (menu keystroke item)
+       (declare (ignore keystroke menu))
+       (let ((type (command-menu-item-type item)))
+	 (when (eq type :menu) (return-from flat-command-table-menu-p nil))))
+   ct)
+  t)
+		      
 
 ;;; If would be nice if we could abstract this and use it for the OLIT
 ;;; port
@@ -188,20 +204,20 @@
 		 (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))))))))
+				     :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-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
@@ -248,19 +264,57 @@
 			  
 		  command-table)
 		 commands-and-buttons)))
-      (make-menu-for-command-table
-       (slot-value sheet 'command-table)
-       mirror
-       t))
+      (let ((ct (slot-value sheet 'command-table)))
+	(make-menu-for-command-table
+	 ct mirror (not (flat-command-table-menu-p ct)))))
     mirror))
 
 (defmethod port-dialog-view ((port motif-port))
   +gadget-dialog-view+)
   
 ;;--- Should "ungray" the command button, if there is one
+;;--- If the command button is visible, right now since everything is
+;;--- in a menu we do not have a problem with this.
+
 (defmethod note-command-enabled ((framem motif-frame-manager) frame command)
   (declare (ignore frame command)))
 
 ;;--- Should "gray" the command button, if there is one
 (defmethod note-command-disabled ((framem motif-frame-manager) frame command)
   (declare (ignore frame command)))
+
+(defmethod silica::update-frame-settings ((framem motif-frame-manager) (frame t))
+  ;;--- Lets see how this works out
+  (let ((shell (sheet-shell (frame-top-level-sheet frame))))
+    (let ((sr (compose-space (frame-top-level-sheet frame))))
+      (tk::set-values shell
+		      :min-width (fix-coordinate (space-requirement-min-width sr))
+		      :min-height
+		      (fix-coordinate (space-requirement-min-height sr))))
+    (let ((geo (clim-internals::frame-geometry frame)))
+      (destructuring-bind
+	  (&key x y width height &allow-other-keys) geo
+	;;-- what about width and height
+	(when (and width height)
+	  (tk::set-values shell :width width :height height))
+	(when (and x y)
+	  (tk::set-values shell 
+			  :x (fix-coordinate x)
+			  :y (fix-coordinate y)))))
+    (let ((icon (clim-internals::frame-icon frame)))
+      (flet ((decode-pixmap (x)
+	       (etypecase x
+		 (string x)
+		 (pattern 
+		  (let ((sheet (frame-top-level-sheet frame)))
+		    (with-sheet-medium (medium sheet)
+		      (second 
+		       (decode-gadget-background medium sheet x))))))))
+	(destructuring-bind
+	    (&key name pixmap clip-mask) icon
+	  (when name
+	    (tk::set-values shell :icon-name name))
+	  (when pixmap
+	    (tk::set-values shell :icon-pixmap (decode-pixmap pixmap)))
+	  (when mask-pixmap
+	    (tk::set-values shell :clip-mask (decode-pixmap mask-pixmap))))))))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 9ca10649..fd9aec4a 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.21 92/04/14 15:30:10 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.22 92/04/15 11:48:40 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -109,7 +109,7 @@
 						     (parent t)
 						     (sheet motif-label-pane))
   (with-accessors ((label gadget-label)
-		   (alignment gadget-alignment)) sheet
+		   (alignment silica::gadget-alignment)) sheet
     (values 'tk::xm-label
 	    (append
 	     (list :alignment 
@@ -182,19 +182,6 @@
   ;; Now does nothing
   )
 
-(defmethod gadget-value ((gadget motif-value-pane))
-  ;;--- We should use the scale functions to get the value
-  (let ((mirror (sheet-direct-mirror gadget)))
-    (if mirror 
-	(tk::get-values mirror :value)
-      (call-next-method))))
-
-(defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key)
-  (let ((gadget (sheet-mirror gadget)))
-    (when gadget
-      (tk::set-values gadget
-		      :value nv))))
-
 ;;; range pane mixin
 
 (defclass motif-range-pane (motif-value-pane) ())
@@ -248,32 +235,57 @@
 	     (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+)))))))
+
 (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
-      (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
+      (sx sy swidth sheight)
+      (tk::widget-best-geometry (sheet-direct-mirror m))
+    (declare (ignore sx sy))
+    (let ((fudge 16))
+      (ecase (gadget-orientation m)
+	(:vertical
+	 (make-space-requirement :width swidth
+				 :min-height fudge
+				 :height (* 2 fudge)
+				 :max-height +fill+))
+	(:horizontal
+	 (make-space-requirement :height sheight
+				 :min-width fudge
+				 :width (max (* 2 fudge) swidth)
+				 :max-width +fill+))))))
+	 
 ;;; Scroll-Bar
 
 
@@ -455,22 +467,35 @@
 	     (and nlines (list :rows nlines))
 	     (and value `(:value ,value))))))
 
-(defmethod set-mirror-geometry (parent (sheet motif-text-editor) initargs)
-  (multiple-value-bind (left top right bottom)
-      (sheet-actual-native-edges* sheet)
-      (setf (getf initargs :x) (floor left)
-	    (getf initargs :y) (floor top))
-    initargs))
+;(defmethod compute-initial-mirror-geometry (parent (sheet motif-text-editor) initargs)
+;  (multiple-value-bind (left top right bottom)
+;      (sheet-actual-native-edges* sheet)
+;      (setf (getf initargs :x) (floor left)
+;	    (getf initargs :y) (floor top))
+;      initargs))
+;
+;(defmethod compute-initial-mirror-geometry (parent (sheet motif-scrolling-window) initargs)
+;  (multiple-value-bind (left top right bottom)
+;      (sheet-actual-native-edges* sheet)
+;      (setf (getf initargs :x) (floor left)
+;	    (getf initargs :y) (floor top))
+;    initargs))
 
 (defmethod compose-space ((te motif-text-editor) &key width height)
   (declare (ignore width height))
   (let ((sr (call-next-method)))
     (setq sr (silica::copy-space-requirement sr))
+    ;;-- What it the correct thing to do???
     (setf (space-requirement-max-width sr) +fill+
 	  (space-requirement-max-height sr) +fill+)
     sr))
 
 
+(defmethod silica::gadget-supplied-scrolling (frame-manager frame (contents motif-text-editor) &rest ignore)
+  (declare (ignore ignore))
+  (with-look-and-feel-realization (frame-manager frame)
+    (make-pane 'motif-scrolling-window :contents contents)))
+
 ;;; Toggle button
 
 (defclass motif-toggle-button (xt-leaf-pane 
@@ -598,11 +623,10 @@
 			    (gadget-id client) 
 			    id)))
 
-;;; Lets have a frame so that it can be nice and pretty
-
+;; Frame-viewport that we need because a sheet can have
 
 (defclass xm-frame-viewport
-	  (sheet-single-child-mixin
+    (sheet-single-child-mixin
 	   sheet-permanently-enabled-mixin
 	   silica::wrapping-space-mixin
 	   pane
@@ -610,7 +634,25 @@
     ())
 
 
+(defmethod find-widget-class-and-initargs-for-sheet
+    ((port xt-port) (parent t) (sheet xm-frame-viewport))
+  (values 'xm-drawing-area 
+	  ;;---  These are duplicated
+	  (list :margin-width 0 
+		:resize-policy :none
+		:margin-height 0)))
 
+;(defmethod allocate-space ((fr xm-frame-viewport) width height)
+;  ;;-- 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))
+  (tk::add-callback widget 
+		    :resize-callback 
+		    'sheet-mirror-resized-callback
+		    sheet))
 
 (defclass motif-frame-pane (motif-geometry-manager
 			    mirrored-sheet-mixin
@@ -623,10 +665,12 @@
 (defmethod initialize-instance :after ((pane motif-frame-pane) &key
 							       frame-manager frame
 							       contents)
-  (let ((viewport (with-look-and-feel-realization (frame-manager frame)
-		    (make-pane 'xm-frame-viewport))))
-    (sheet-adopt-child pane viewport)
-    (sheet-adopt-child viewport contents)))
+  (if (typep contents 'mirrored-sheet-mixin)
+      (sheet-adopt-child pane contents)
+    (let ((viewport (with-look-and-feel-realization (frame-manager frame)
+		      (make-pane 'xm-frame-viewport))))
+      (sheet-adopt-child pane viewport)
+      (sheet-adopt-child viewport contents))))
 
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
@@ -644,3 +688,230 @@
   ;;-- We do not need to do anything here because
   ;;-- the pane should resize its child
   )
+
+;;; Scrolling Window
+
+(defclass motif-scrolling-window (motif-geometry-manager
+				  ask-widget-for-size-mixin
+				  mirrored-sheet-mixin
+				  sheet-single-child-mixin
+				  sheet-permanently-enabled-mixin
+				  pane)
+	  ;;-- probably one of the options is whether to have vertical
+	  ;;-- and/or horizontal scrollbars
+	  ())
+
+(defmethod initialize-instance :after ((pane motif-scrolling-window) &key contents)
+  (sheet-adopt-child pane contents))
+
+(defmethod compose-space ((fr motif-scrolling-window) &key width height)
+  (declare (ignore width height))
+  ;;--- This is not quite right because I think scrollbars are a bit
+  ;;--- bigger than this. But atleast its a start
+  (let ((fudge-factor (+ 16
+			 (tk::get-values (sheet-mirror fr)
+					 :spacing)))
+	(sr (silica::copy-space-requirement (compose-space
+					     (sheet-child fr)))))
+    (incf (space-requirement-width sr) fudge-factor)
+    (incf (space-requirement-height sr) fudge-factor)
+    ;;--- Is this the correct thing to do???
+    (setf (space-requirement-min-width sr) fudge-factor
+	  (space-requirement-min-height sr) fudge-factor)
+    sr))
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (parent t)
+						     (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.
+
+(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)
+  (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)
+  )
+
+;;; Option buttons
+
+(defclass motif-option-pane (xt-leaf-pane silica::labelled-gadget)
+	  ((items :initarg :items :accessor option-pane-items))
+  (:default-initargs :items nil))
+
+(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
+    (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))
+      (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
+
+(defmethod port-notify-user ((port motif-port)
+			     message-string 
+			     &key 
+			     (style :inform)
+			     (frame *application-frame*)
+			     (associated-window
+			      (frame-top-level-sheet frame))
+			     (title "Notify user")
+			     documentation
+			     (name title))
+  (let ((dialog (make-instance (ecase style
+				 (:inform 'tk::xm-information-dialog)
+				 (:error 'tk::xm-error-dialog)
+				 (:question 'tk::xm-question-dialog)
+				 (:warning 'tk::xm-warning-dialog))
+			       :parent (sheet-mirror associated-window)
+			       :name name
+			       :dialog-title title
+			       :message-string message-string
+			       ))
+	(result nil))
+    (multiple-value-bind
+	(help-button)
+	(get-message-box-child dialog :help)
+      (flet ((set-it (widget r)
+	       (declare (ignore widget))
+	       (setq result (list r)))
+	     (display-help (widget ignore)
+	       (declare (ignore widget ignore))
+	       (port-notif-user 
+		port
+		documentation
+		:associated-window associated-window)))
+	(tk::add-callback dialog :ok-callback #'set-it t)
+	(tk::add-callback dialog :cancel-callback #'set-it nil)
+	(if documentation
+	    (tk::add-callback help-button :activate-callback #'display-help)
+	  (xt::set-sensitive help-button nil))
+	(unwind-protect
+	    (progn
+	      (tk::manage-child dialog)
+	      (wait-for-callback-invocation
+	       (port associated-window)
+	       #'(lambda () result)
+	       "Waiting for dialog"))
+	  (tk::destroy-widget dialog))
+	(car result)))))
+
+
+(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)))
+
+(defun get-message-box-child (widget &rest children)
+  (values-list
+   (mapcar #'(lambda (child)
+	       (tk::convert-resource-in
+		widget
+		'tk::widget
+		(tk::xm-message-box-get-child 
+		 widget
+		 (encode-box-child child))))
+	   children)))
+
+(defun encode-box-child (child)
+  (let ((x (getf '(
+		   :none	          0 
+		   :apply	  1
+		   :cancel    2
+		   :default   3
+		   :ok        4
+		   :filter-label     5
+		   :filter-text      6
+		   :help      7
+		   :list		  8
+		   :history-list     :list
+		   :list-label	  9
+		   :message-label    10
+		   :selection-label  11
+		   :prompt-label     :selection-label
+		   :symbol-label     12
+		   :text	    	  13
+		   :value-text       :text
+		   :command-text     :text
+		   :separator    	  14
+		   :dir-list         15
+		   :dir-list-label   16
+		   :file-list        :list
+		   :file-list-label  :list-label
+		   ) 
+		 child)))
+    (cond ((null x)
+	   (error "cannot encode child ~S" child))
+	  ((symbolp x)
+	   (encode-box-child x))
+	  (t x))))
+
+;;;; Working
diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp
index b25fb5c6..5be5e84d 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.8 92/04/03 12:04:53 cer Exp Locker: cer $
+;; $fiHeader: xm-menus.lisp,v 1.9 92/04/10 14:27:51 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -51,7 +51,7 @@
 	      (progn
 		(setf (port-menu-cache port)
 		  (delete x (port-menu-cache port)))
-		(tk::destroy-widget amenu)))))))
+		(tk::destroy-widget (tk::widget-parent amenu))))))))
       
     (unless menu
       (multiple-value-setq
@@ -81,16 +81,19 @@
 	(tk::manage-child menu)
 	;; Now we have to wait
 	(port-force-output port)
-	(mp::process-wait "Returned value" #'(lambda () 
-					       ;;-- This is to deal
-					       ;;-- with the race
-					       ;;-- condition where
-					       ;;-- the menu go down
-					       ;;-- to quick
-					       (or (funcall closure)
-						   (not (tk::is-managed-p menu))))))
+	(wait-for-callback-invocation
+	 port
+	 #'(lambda () 
+	     ;;-- This is to deal
+	     ;;-- with the race
+	     ;;-- condition where
+	     ;;-- the menu go down
+	     ;;-- to quick
+	     (or (funcall closure)
+		 (not (tk::is-managed-p menu)))) 
+	 "Returned value"))
       (unless cache
-	(tk::destroy-widget menu))
+	(tk::destroy-widget (tk::widget-parent menu)))
       
       (values-list (nth-value 1 (funcall closure))))))
 
@@ -121,9 +124,7 @@
 		     :managed nil
 		     :separator-type :double-line
 		     :parent menu))
-    (labels ((destroy-menu-pixmap (widget)
-	       (tk::destroy-pixmap (tk:get-values widget :label-pixmap)))
-	     (make-menu-button (item class parent &rest options)
+    (labels ((make-menu-button (item class parent &rest options)
 	       (if simplep
 		   (apply #'make-instance
 			  class 
@@ -145,7 +146,9 @@
 				:label-type :pixmap
 				:label-pixmap pixmap
 				options)))
-		   (tk::add-callback button :destroy-callback #'destroy-menu-pixmap)
+		   (xt::add-widget-cleanup-function
+		    button
+		    #'tk::destroy-pixmap pixmap)
 		   button)))
 	     (construct-menu-from-items (menu items)
 	       (map nil #'(lambda (item)
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 6235b73e..305ec3bc 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.13 92/04/10 14:27:53 cer Exp Locker: cer $
+;; $fiHeader: xm-silica.lisp,v 1.14 92/04/15 11:48:43 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -80,7 +80,9 @@ about their children"))
 
 (defmethod update-geo-manager-sheet-children (geo-manager)
   (dolist (child (sheet-children geo-manager))
-    (mirror-region-updated (port geo-manager) child)))
+    ;;--- Yuck!
+    (when (typep child 'mirrored-sheet-mixin)
+      (mirror-region-updated (port geo-manager) child))))
 
 (defmethod find-shell-class-and-initargs ((port motif-port) sheet)
   (declare (ignore port))
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 86dc1e50..faf1acdb 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.7 92/04/10 14:27:56 cer Exp Locker: cer $
+;; $fiHeader: xt-frames.lisp,v 1.8 92/04/15 11:48:47 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -87,8 +87,9 @@
 		   :sheet (frame-top-level-sheet frame)
 		   :value (second item))))
 
-(defmethod clim-internals::port-notify-user ((port xt-port) 
-					     frame format-string &rest format-arguments)
+(defmethod port-notify-user ((port xt-port)
+			     message-string
+			     &key)
   (format excl::*initial-terminal-io* 
 	  "Notify ~a~%" 
-	  (list frame format-string format-arguments)))
+	  message-string))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index b111efc1..477aa7df 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.15 92/04/10 14:27:58 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.16 92/04/15 11:48:57 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -116,6 +116,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 	(setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel
 	      (tk::gcontext-background foreground-gcontext) background-pixel
 	      (tk::gcontext-foreground background-gcontext) background-pixel
+	      (tk::gcontext-background background-gcontext) background-pixel
 	      (tk::gcontext-foreground flipping-gcontext)
 	      (logxor foreground-pixel background-pixel))))))
       
@@ -286,11 +287,13 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 		 (multiple-value-bind (red green blue)
 		     (color-rgb ink)
 		   (tk::allocate-color
-		     (tk::default-colormap (port-display (port (medium-sheet medium))))
-		     (make-instance 'tk::color
-				    :red (truncate (* 65356 red))
-				    :green (truncate (* 65356 green))
-				    :blue (truncate (* 65356 blue))))))
+		    (tk::default-colormap (port-display (port
+							 (medium-sheet medium))))
+		    (let ((x #.(1- (ash 1 16))))
+		      (make-instance 'tk::color
+				    :red (truncate (* x red))
+				    :green (truncate (* x green))
+				    :blue (truncate (* x blue)))))))
 		(t
 		 (multiple-value-bind (r g b) (color-rgb ink)
 		   ;; The luminance formula isn't really right.  XXX
@@ -556,8 +559,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 			    ;; towards-point towards-x towards-y
 			    ;; transform-glyphs
 			    )
-  (let ((transform (sheet-device-transformation sheet))
-	(font (text-style-mapping port (medium-text-style medium))))
+  (let* ((transform (sheet-device-transformation sheet))
+	 (font (text-style-mapping port (medium-text-style medium)))
+	 (ascent (tk::font-ascent font)))
     (convert-to-device-coordinates transform x y)
     (when (typep string-or-char 'character)
       (setq string-or-char (string string-or-char)))
@@ -573,9 +577,15 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 		   (floor (text-style-height (medium-text-style medium) port) 2))))
       (:baseline nil)
       (:top
-	(incf y (tk::font-ascent font)))) 
+	(incf y ascent))) 
     (when (medium-drawable medium)
-      (let ((gc (decode-ink (medium-ink medium) medium)))
+      (let ((gc (adjust-ink
+		 medium
+		 (decode-ink (medium-ink medium) medium)
+		 (medium-ink medium)
+		 (medium-line-style medium)
+		 x 
+		 (- y ascent))))
 	(setf (tk::gcontext-font gc) font)
 	(tk::draw-string
 	  (medium-drawable medium)
@@ -587,6 +597,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 (defmethod port-write-string-1 ((port xt-port) medium
 				glyph-buffer start end 
 				x-font color x y)
+  (break "is this used anymore")
   (unless (= start end)
     (let* ((sheet (medium-sheet medium))
 	   (transform (sheet-device-transformation sheet))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 61e3e7b7..2c516896 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.18 92/04/10 14:27:59 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.19 92/04/15 11:49:06 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -368,18 +368,18 @@
 		       :native-y (x11::xbuttonevent-y event))))))
 
 (defmethod find-widget-class-and-initargs-for-sheet
-	   ((port xt-port) (parent t) (sheet sheet))
-  (values 'xm-drawing-area (list :resize-policy :grow)))
+    ((port xt-port) (parent t) (sheet sheet))
+  (error "we should not be here"))
 
 (defmethod find-widget-class-and-initargs-for-sheet :around 
 	   ((port xt-port) (parent t) (sheet sheet))
   (multiple-value-bind (class initargs)
       (call-next-method)
-    (setq initargs (set-mirror-geometry parent sheet initargs))
+    (setq initargs (compute-initial-mirror-geometry parent sheet initargs))
     (values class initargs)))
 
 
-(defmethod set-mirror-geometry (parent sheet initargs)
+(defmethod compute-initial-mirror-geometry (parent sheet initargs)
   ;;--- Should we pass in the size of the sheet even though it is
   ;; liable to be quite stupid
   ;; We really want to just create the gadgets and then let the layout
@@ -392,6 +392,8 @@
       (unless (typep parent 'tk::shell)
 	(setf (getf initargs :x) (fix-coordinate left)
 	      (getf initargs :y) (fix-coordinate top)))
+      ;;--- We should not do this, see realize-mirror :around in mirror
+      #+ignore
       (setf (getf initargs :width)  (fix-coordinate (- right left))
 	    (getf initargs :height) (fix-coordinate (- bottom top)))))
   initargs)
@@ -829,3 +831,39 @@
     (if (logtest x x11:mod1mask) +meta-key+ 0)
     (if (logtest x x11:mod2mask) +super-key+ 0)
     (if (logtest x x11:mod3mask) +hyper-key+ 0)))
+
+;;;---- This is just an experiment
+
+(defmethod engraft-medium :before ((medium t) (port xt-port) (pane clim-stream-pane))
+  (default-from-mirror-resources port pane))
+
+(defmethod engraft-medium :before ((medium t) (port xt-port) (pane top-level-sheet))
+  (default-from-mirror-resources port pane))
+
+;;-- What do we do about pixmap streams. I guess they should inherit
+;;-- properties from the parent.
+
+;;--- Unless the foreground, background and default-text-style have
+;;--- been set we want to query the resource database for the values
+;; Either (a) ask a widget or (b) Do it directly.
+;; Well it looks like we have to use a widget
+;; If we wanted to get a font then we are in trouble because
+
+(defun default-from-mirror-resources (port pane)
+  (let ((w (sheet-mirror pane)))
+    (multiple-value-bind
+	(foreground background)
+	;;-- What about the case when there is a pixmap
+	(tk::get-values w :foreground :background)
+      ;; Now we have to convert into CLIM colors.
+      (flet ((ccm (x)
+	       (multiple-value-bind
+		   (r g b)
+		   (tk::query-color (tk::default-colormap (port-display port)) x)
+		 (let ((x #.(1- (ash 1 16))))
+		   (make-rgb-color 
+		    (/ r x)
+		    (/ g x)
+		    (/ b x))))))
+	(setf (medium-foreground pane) (ccm foreground)
+	      (medium-background pane) (ccm background))))))
diff --git a/tk/convenience.lisp b/tk/convenience.lisp
index 037c0fdd..eb95c716 100644
--- a/tk/convenience.lisp
+++ b/tk/convenience.lisp
@@ -20,52 +20,11 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: convenience.lisp,v 1.5 92/03/09 17:40:34 cer Exp $
+;; $fiHeader: convenience.lisp,v 1.6 92/03/30 17:51:29 cer Exp Locker: cer $
 
 (in-package :tk)
 
 					;
-;
-;
-;(defmacro define-convenience-function (name entry-point class)
-;  (let ((c-function-name (intern (substitute #\_ #\- (symbol-name name)))))
-;    `(progn
-;       (defforeign ',c-function-name
-;	 :entry-point ,entry-point)
-;       (defun ,name (parent name &rest arglist)
-;	 (let ((arglist (make-arglist-for-class
-;			 (find-class ',class)
-;			 parent
-;			 arglist)))
-;	   (register-handle
-;	    (make-instance
-;	     ',class
-;	     :display display
-;	     :foreign-address
-;	     (,c-function-name
-;	      parent
-;	      (string-to-char* name)
-;	      arglist
-;	      (truncate (length arglist) 2)))))))))
-;	
-;
-;(define-convenience-function create-menu-bar 
-;			     "_XmCreateMenuBar"
-;			     xm-row-column)
-;
-;(define-convenience-function create-pulldown-menu 
-;			     "_XmCreatePulldownMenu" 
-;			     xm-row-column)
-;
-;(define-convenience-function create-row-column
-;			     "_XmCreateRowColumn"
-;			     xm-row-column)
-;
-;
-;(define-convenience-function create-radio-box
-;			     "_XmCreateRadioBox"
-;			     xm-row-column)
-
 (defmacro define-convenience-class (class superclasses entry-point)
   (let ((c-function-name
 	 (intern (substitute #\_ #\- 
@@ -99,3 +58,10 @@
 (define-convenience-class xm-pulldown-menu (xm-row-column) "_XmCreatePulldownMenu")
 (define-convenience-class xm-radio-box (xm-row-column) "_XmCreateRadioBox")
 (define-convenience-class xm-popup-menu (xm-row-column) "_XmCreatePopupMenu")
+
+(define-convenience-class xm-option-menu (xm-row-column) "_XmCreateOptionMenu")
+
+(define-convenience-class xm-question-dialog (xm-message-box) "_XmCreateQuestionDialog")
+(define-convenience-class xm-warning-dialog (xm-message-box) "_XmCreateWarningDialog")
+(define-convenience-class xm-information-dialog (xm-message-box) "_XmCreateInformationDialog")
+(define-convenience-class xm-error-dialog (xm-message-box) "_XmCreateErrorDialog")
diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp
index 98b8a686..4a190571 100644
--- a/tk/foreign-obj.lisp
+++ b/tk/foreign-obj.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign-obj.lisp,v 1.7 92/03/09 17:40:41 cer Exp Locker: cer $
+;; $fiHeader: foreign-obj.lisp,v 1.8 92/04/10 14:26:15 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -55,6 +55,10 @@
   (setf (gethash handle *xid->object-mapping*) object)
   object)
 
+(defun unregister-xid (object &optional (handle (foreign-pointer-address object)))
+  (remhash handle *xid->object-mapping*)
+  object)
+
 (defun intern-object-address (handle class &rest initargs)
   (apply #'intern-object-1 
 	 *address->object-mapping*
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 9765f84a..bd2854ae 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.9 92/03/30 17:51:35 cer Exp $
+;; $fiHeader: gcontext.lisp,v 1.10 92/04/15 11:44:44 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -44,8 +44,8 @@
 	       (font x-font)
 	       (subwindow-mode :int)
 	       (exposures :boolean)
-	       (clip-x :int)
-	       (clip-y :int)
+	       (clip-x-origin :int)
+	       (clip-y-origin :int)
 	       (clip-mask :pixmap)
 	       (dash-offset :int)
 	       (dashes :char)))
@@ -54,7 +54,7 @@
 	     '(function plane-mask foreground background
 			line-width line-style cap-style join-style fill-style
 			fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode
-			exposures clip-x clip-y clip-mask dash-offset dashes
+			exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes
 			arc-mode)))
 
 
@@ -89,7 +89,7 @@
 				       cap-style join-style fill-style fill-rule 
 				       arc-mode tile stipple ts-x ts-y
 				       font subwindow-mode 
-				       exposures clip-x clip-y
+				       exposures clip-x-origin clip-y-origin
 				       clip-mask clip-ordering 
 				       dash-offset dashes)
 
@@ -119,8 +119,8 @@
   (when font (setf (gcontext-font gcontext) font))
   (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
   (when exposures (setf (gcontext-exposures gcontext) exposures))
-  (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
-  (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
+  (when clip-x-origin (setf (gcontext-clip-x-origin gcontext) clip-x-origin))
+  (when clip-y-origin (setf (gcontext-clip-y-origin gcontext) clip-y-origin))
   (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
   (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
   (when dashes (setf (gcontext-dashes gcontext) dashes))
@@ -244,8 +244,8 @@
 (define-gc-accessor subwindow-mode (encode-enum decode-enum)
 		  '(:clip-by-children :include-inferiors))
 (define-gc-accessor exposures (encode-enum decode-enum) '(:off :on))
-(define-gc-accessor clip-x (encode-int16 decode-int16))
-(define-gc-accessor clip-y (encode-int16 decode-int16))
+(define-gc-accessor clip-x-origin (encode-int16 decode-int16))
+(define-gc-accessor clip-y-origin (encode-int16 decode-int16))
 
 (define-gc-accessor dash-offset (encode-card16 decode-card16))
 (define-gc-accessor arc-mode (encode-enum decode-enum)  '(:chord :pie-slice))
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 5458a634..dee05f8f 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.12 92/04/03 12:04:03 cer Exp Locker: cer $
+;; $fiHeader: make-classes.lisp,v 1.13 92/04/15 11:44:47 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -76,9 +76,14 @@
 (defclass xt-root-class (display-object)
   ((events :initform nil :accessor widget-event-handler-data)
    (callbacks :initform nil :accessor widget-callback-data)
-   (window-cache :initform nil))
+   (window-cache :initform nil)
+   (cleanups :initform nil :accessor widget-cleanup-functions))
   (:metaclass xt-class))
 
+(defmethod add-widget-cleanup-function ((widget xt-root-class) fn &rest args)
+  (push (list* fn args)
+	(widget-cleanup-functions widget)))
+
 (defmethod widget-display ((object xt-root-class))
   (object-display object))
 
diff --git a/tk/resources.lisp b/tk/resources.lisp
index c80a7551..0c781512 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.14 92/04/10 14:26:17 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.15 92/04/15 11:44:49 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -157,10 +157,17 @@
   (check-type value integer)
   value)
 
+(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-int)) value)
+  (check-type value integer)
+  value)
+
 
 (defmethod convert-resource-out ((parent t) (type (eql 'vertical-dimension)) value)
   value)
 
+(defmethod convert-resource-out ((parent t) (type (eql 'vertical-int)) value)
+  value)
+
 (defmethod convert-resource-out ((parent t) (type (eql 'visual-policy)) value)
   (ecase value
     (:constant 1)))
@@ -201,15 +208,22 @@
 (defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value)
   (convert-pixmap-out parent value))
 
+(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value)
+  (convert-pixmap-out parent value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value)
+  (convert-pixmap-out parent value))
+
+
 (defun convert-pixmap-out (parent value)
   (etypecase value
     (pixmap value)
     (string
      (let* ((display (widget-display parent))
 	    (screen (x11:xdefaultscreenofdisplay display))
-	    (white (screen_white_pixel screen))
-	    (black (screen_black_pixel screen)))
-       (get_pixmap screen (string-to-char* value) white black)))))
+	    (white (x11::xwhitepixel display 0))
+	    (black (x11::xblackpixel display 0)))
+       (get_pixmap screen (string-to-char* value) black white)))))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value)
   (if value 1 0))
@@ -542,3 +556,19 @@
 (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table))
 				(value (eql nil)))
   0)
+
+(define-enumerated-resource visual-policy (:variable :constant))
+(define-enumerated-resource scroll-bar-display-policy (:static :as-needed))
+
+(defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value)
+  (if value
+      (do* ((n (length value))
+	    ;;--- Malloc alert
+	    (r (excl::malloc (* n 4)))
+	    (v value (cdr v))
+	    (i 0 (1+ i)))
+	  ((null v)
+	   r)
+	(setf (x-arglist r i)
+	  (convert-resource-out parent 'xm-string (car v))))
+    0))
diff --git a/tk/widget.lisp b/tk/widget.lisp
index af9eb3d4..65ec6171 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.15 92/04/10 14:26:19 cer Exp Locker: cer $
+;; $fiHeader: widget.lisp,v 1.16 92/04/15 11:44:53 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -109,18 +109,19 @@
   (if (typep x 'clos::class) x
     (find-class x)))
 
-(defmethod widget-window (widget &optional (errorp t))
+(defmethod widget-window (widget &optional (errorp t) peek)
   (with-slots (window-cache) widget
     (or window-cache
-	(setf window-cache
-	  (let ((id (xt_window widget)))
-	    (if (zerop id)
-		(and errorp
-		     (error "Invalid window id ~D for ~S" id widget))
-	      (intern-object-xid
-	       id
-	       'window 
-	       :display (widget-display widget))))))))
+	(and (not peek)
+	     (setf window-cache
+	       (let ((id (xt_window widget)))
+		 (if (zerop id)
+		     (and errorp
+			  (error "Invalid window id ~D for ~S" id widget))
+		   (intern-object-xid
+		    id
+		    'window 
+		    :display (widget-display widget)))))))))
 
 (defun make-clx-window (display widget)
   (let* ((window-id (xt_window widget)))
@@ -151,6 +152,14 @@
        (setf (foreign-pointer-address w)
 	 (apply #'make-widget w args))))))
 
+(defmethod destroy-widget-cleanup ((widget xt-root-class))
+  (dolist (cleanup (widget-cleanup-functions widget))
+    (apply (car cleanup) (cdr cleanup)))
+  ;;--- When we start using gadgets things will be fun!
+  (let ((w (widget-window widget nil t)))
+    (when w (unregister-xid w)))
+  (unintern-widget widget))
+
 (defun intern-widget (widget-address &rest args)
   (unless (zerop widget-address)
     (multiple-value-bind
@@ -161,12 +170,12 @@
 	 (widget-class-of widget-address)
 	 args)
       (when newp
-	(add-callback widget :destroy-callback #'unintern-widget))
+	(add-callback widget :destroy-callback #'destroy-widget-cleanup))
       widget)))
 
 (defun register-widget (widget &optional (handle (foreign-pointer-address widget)))
   (register-address widget handle)
-  (add-callback widget :destroy-callback #'unintern-widget))
+  (add-callback widget :destroy-callback #'destroy-widget-cleanup))
 
 (defun unintern-widget (widget)
   (unintern-object-address (foreign-pointer-address widget)))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index d0a390a9..1421cfa5 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.13 92/03/30 17:51:52 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.14 92/04/15 11:44:54 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -91,6 +91,10 @@
    (height :initarg :height :reader pixmap-height)
    (depth :initarg :depth :reader drawable-depth)))
 
+(defun destroy-pixmap (pixmap)
+  (unregister-xid pixmap)
+  (x11:xfreepixmap (object-display pixmap) pixmap))
+  
 (defmethod initialize-instance :after
 	   ((p pixmap) &key foreign-address width height depth drawable)
   (with-slots (display) p
@@ -195,6 +199,18 @@
 	      (make-instance 'color :foreign-address y)))))
 
 
+(defun query-color (colormap x)
+  ;;--- Resource time
+  (let ((y (x11::make-xcolor)))
+    (setf (x11:xcolor-pixel y) x)
+    (x11:xquerycolor
+     (object-display colormap)
+     colormap
+     y)
+    (values 
+     (x11:xcolor-red y)
+     (x11:xcolor-green y)
+     (x11:xcolor-blue y))))
 
 (defun default-screen (display)
   (intern-object-address
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index 851d7a37..3aaf2ac7 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$
+;; $fiHeader: xm-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -34,3 +34,6 @@
 
 (defforeign 'get_pixmap
     :entry-point "_XmGetPixmap")
+
+(defforeign 'xm-message-box-get-child
+    :entry-point "_XmMessageBoxGetChild")
diff --git a/utils/regions.lisp b/utils/regions.lisp
index 2df2fa2e..97433c8c 100644
--- a/utils/regions.lisp
+++ b/utils/regions.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: regions.lisp,v 1.5 92/03/04 16:20:23 cer Exp $
+;; $fiHeader: regions.lisp,v 1.6 92/04/15 11:45:37 cer Exp Locker: cer $
 
 (in-package :clim-utils)
 
@@ -449,17 +449,6 @@
     (when (> y1 y2) (rotatef y1 y2))
     (make-bounding-rectangle-1 x1 y1 x2 y2)))
 
-#+Silica
-(defun make-bounding-rectangle (x1 y1 x2 y2)
-  (let ((x1 (float x1 0f0))
-	(y1 (float y1 0f0))
-	(x2 (float x2 0f0))
-	(y2 (float y2 0f0)))
-    (declare (type coordinate x1 y1 x2 y2))
-    (when (> x1 x2) (rotatef x1 x2))
-    (when (> y1 y2) (rotatef y1 y2))
-    (make-bounding-rectangle-1 x1 y1 x2 y2)))
-
 (defmethod make-load-form ((rectangle standard-bounding-rectangle))
   (with-slots (left top right bottom) rectangle
     `(make-bounding-rectangle ,left ,top ,right ,bottom)))
-- 
GitLab