From bfdcc498bc176786a341311fc92a9460f3a30a34 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 1 Dec 1992 09:47:32 +0000
Subject: [PATCH] Makefile		Moved the training code into
 misc/train.lisp and made                         it run the postscript
 training code clim/activities.lisp		If there are frames in the
 activity it now                         select-activity-initial-frame and
 then enable-activity-frames.                         Otherwise it calls
 start-initial-application-frame                         followed by
 start-other-application-frames clim/clim-defs.lisp		Added
 scroll-bar option to with-menu clim/db-stream.lisp		Removing the
 spacing code for allegro 'cos it                         makes the windows
 look messy clim/frames.lisp		Made the sheet positioning code call
 port-move-frame clim/graphics-recording.lisp		draw-rectangles* with
 non rectilinear                         transform does the right thing
 clim/input-protocol.lisp	Invoke *click-outside-menu-handler*
 appropriately clim/menus.lisp		scroll-bar option for menubars.
 Mousing grabbing in                         menus now works
 climtoys/bezier.lisp	Added define-test to draw the cloud climtoys/ib.lisp
 Reorganized menus climtoys/sysdcl.lisp	Added test-driver.lisp and
 coverage.lisp climtoys/test-clim.lisp	Moved the code to test-driver.lisp and
 added more tests climtoys/test-demo.lisp Moved the code to test-driver.lisp
 and added more tests demo/bitmap-editor.lisp	Made colors black and white
 demo/graphics-demos.lisp		Made the demos have regular lisp      
                   symbols as names silica/classes.lisp		Added
 grabbing-sheet to port silica/db-border.lisp		added labelling macro
 silica/db-scroll.lisp		(bounding-rectangle-min-x extent) no longer
 ignored silica/event.lisp		event distribution now takes into
 account                         grabbing code. silica/graphics.lisp   
 draw-rectangles and non rectilinear transforms silica/port.lisp	
 find-port now passes server-path to make-port silica/sheet.lisp      
 port-invoke-with-pointer-grabbed letf's the grabbing-sheet slot in the port
 test/postscript-tests.lisp :file sends output to postscript.output
 test/test-suite.lisp		Tests for draw-rectangles*, reading bitmap    
                     files, bezier curves, drag and drop, fixed menu          
               tests, tk/graphics.lisp 	Added draw-rectangles tk/widget.lisp
 	Removed make-clx-window tk/xm-widgets.lisp 	Removed dead code
 tk/xt-defs.lisp		added xrectangle-array tk-silica/image.lisp 
 Fixed bitmap reading code tk-silica/xm-dialogs.lisp tk-silica/xm-silica.lisp
 	change-geometry for dialog shell                         specifies :x,
 :y, menu-frame used override-redirect tk-silica/xt-frames.lisp		added
 menu methods tk-silica/xt-graphics.lisp		added
 medium-draw-rectangles tk-silica/xt-silica.lisp		added
 port-move-frame utils/clos.lisp		Commented out dynamic class
 nonsense utils/packages.lisp		Deleted bad-to-tailpos stuff

---
 Makefile                     |  18 +---
 clim/activities.lisp         |  15 +--
 clim/clim-defs.lisp          |   9 +-
 clim/db-stream.lisp          |   7 +-
 clim/frames.lisp             |   9 +-
 clim/graphics-recording.lisp |  10 +-
 clim/input-protocol.lisp     |  24 +++--
 clim/menus.lisp              |  74 ++++++++------
 clim/output-protocol.lisp    |   3 +-
 demo/bitmap-editor.lisp      |   4 +-
 demo/graphics-demos.lisp     |  18 ++--
 misc/train.lisp              |  42 ++++++++
 silica/classes.lisp          |   6 +-
 silica/db-border.lisp        |  15 ++-
 silica/db-scroll.lisp        |  15 +--
 silica/event.lisp            |   7 +-
 silica/graphics.lisp         |  33 +++++-
 silica/port.lisp             |   5 +-
 silica/sheet.lisp            |   7 +-
 test/postscript-tests.lisp   |   7 +-
 test/test-suite.lisp         | 149 ++++++++++++++++++++++-----
 tk-silica/image.lisp         | 189 ++++++++++++++++++-----------------
 tk-silica/xm-dialogs.lisp    |   4 +-
 tk-silica/xm-silica.lisp     |  27 ++++-
 tk-silica/xt-frames.lisp     |  11 +-
 tk-silica/xt-graphics.lisp   | 111 ++++++++++++++------
 tk-silica/xt-silica.lisp     |   8 +-
 tk/graphics.lisp             |  19 +++-
 tk/widget.lisp               |   6 +-
 tk/xm-widgets.lisp           |   8 +-
 tk/xt-defs.lisp              |   3 +-
 utils/clos.lisp              |  92 ++++++++---------
 utils/packages.lisp          |  11 +-
 33 files changed, 655 insertions(+), 311 deletions(-)
 create mode 100644 misc/train.lisp

diff --git a/Makefile b/Makefile
index 1c1fb529..16195c02 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.67 92/11/11 17:46:21 cer Exp $
+# $fiHeader: Makefile,v 1.68 92/11/20 08:44:11 cer Exp $
 #
 #  Makefile for CLIM 2.0
 #
@@ -11,17 +11,12 @@ CLOPTS	= -qq
 # Training
 
 TRAIN_TIMES=2
+# view, file, print
+PSVIEW=file
 
 TRAIN_LISP= \
-	(progn \
-	(load \"test/test.lisp\") \
-	(clim-user::train-clim-2  $(TRAIN_TIMES)) \
-	(clim-user::do-frame-tests) \
-	(compile-file \"misc/clos-preload.cl\" \
-	:output-file \
-	(if (excl::featurep :clim-motif) \"misc/clos-preloadxm.fasl\" \
-	    \"misc/clos-preloadol.fasl\") \
-	)) \
+	(load \"misc/train.lisp\") \
+	(train-clim :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \
 	(exit 0)
 
 TRAIN_TEXT = \
@@ -678,9 +673,6 @@ benchmark:
 	(clim-user::benchmark-clim $(BENCHMARK_FILE)) \
 "  | $(CLIM) $(CLOPTS) -batch
 
-
-PSVIEW=view
-
 testps :
 	$(ECHO) "\
 	(load \"climtoys/test-clim.lisp\") \
diff --git a/clim/activities.lisp b/clim/activities.lisp
index 68d96d8d..86196560 100644
--- a/clim/activities.lisp
+++ b/clim/activities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: activities.lisp,v 1.6 92/11/13 14:45:48 cer Exp $
+;; $fiHeader: activities.lisp,v 1.7 92/11/20 08:44:24 cer Exp $
 
 (in-package :clim-internals)
 
@@ -62,12 +62,15 @@
   (signal 'frame-exit :frame activity))
 
 (defmethod default-frame-top-level ((activity activity) &key &allow-other-keys)
-  (if (activity-active-frame activity)
-      (enable-activity-frames activity)
+  (if (frame-manager-frames activity)
+      (progn
+	(setf (activity-active-frame activity)
+	  (select-activity-initial-frame activity))
+	(enable-activity-frames activity))
     (setf (activity-active-frame activity)
-	(or (select-activity-initial-frame activity)
-	    (prog1 (start-initial-application-frame activity)
-	      (start-other-application-frames activity)))))
+      (prog1 (start-initial-application-frame activity)
+	(start-other-application-frames activity))))
+  ;; 
   (unwind-protect
       (loop
 	(let ((*activity* activity)
diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp
index 38a6a623..12791ff3 100644
--- a/clim/clim-defs.lisp
+++ b/clim/clim-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clim-defs.lisp,v 1.17 92/11/19 14:17:07 cer Exp $
+;; $fiHeader: clim-defs.lisp,v 1.18 92/11/20 08:44:29 cer Exp $
 
 (in-package :clim-internals)
 
@@ -274,13 +274,15 @@
 
 ;;; From MENUS.LISP
 ;;; For now, MENU-CHOOSE requires that you pass in a parent.
-(defmacro with-menu ((menu &optional (associated-window nil aw-p) &key label) &body body)
+(defmacro with-menu ((menu &optional (associated-window nil aw-p)
+				     &rest options &key label scroll-bars) &body body)
+  (declare (ignore label scroll-bars))
   (let ((window '#:associated-window))
     `(let ((,window ,(if aw-p
 			 associated-window
 			 `(frame-top-level-sheet *application-frame*))))	;once-only
        (using-resource (,menu menu (window-top-level-window ,window) (window-root ,window)
-			:label ,label)
+			      ,@options)
 	 (letf-globally (((stream-default-view ,menu) +textual-menu-view+))
 	   ,@body)))))
 
@@ -324,6 +326,7 @@
 (defvar *application-frame*)
 (defvar *pointer-documentation-output* nil)
 (defvar *assume-all-commands-enabled* nil)
+(defvar *click-outside-menu-handler* nil)
 
 ;; Bound to T when the frame is being layed out
 (defvar *sizing-application-frame* nil)
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 9647b971..54f7841b 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-stream.lisp,v 1.36 92/11/09 10:54:22 cer Exp $
+;; $fiHeader: db-stream.lisp,v 1.37 92/11/19 14:17:21 cer Exp $
 
 (in-package :clim-internals)
 
@@ -356,7 +356,10 @@
 	    (setq pane `(vertically () ,label ,pane))))))
     `(let (,stream)
        (values 
-	 (outlining (:thickness 1)
+	(outlining (:thickness 1)
+   	   #+allegro
+	   ,pane
+	   #-allegro
 	   (spacing (:thickness 1)
 	     ,pane))
 	 ,stream))))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 0b30fdec..04cf63b9 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.50 92/11/09 10:54:28 cer Exp $
+;; $fiHeader: frames.lisp,v 1.51 92/11/19 14:17:33 cer Exp $
 
 (in-package :clim-internals)
 
@@ -927,7 +927,10 @@
 	  (setq left (- graft-width width)))
 	(when (> bottom graft-height)
 	  (setq top (- graft-height height)))
-	(move-sheet sheet (max 0 left) (max 0 top))))))
+	(port-move-frame (port sheet) (pane-frame sheet) (max 0 left) (max 0 top))))))
+
+(defmethod port-move-frame ((port basic-port) frame x y)
+  (move-sheet (frame-top-level-sheet frame) x y))
 
 ;; Moves the sheet to be near where the pointer is.  It's safest to use this
 ;; on a top-level sheet.
@@ -1114,8 +1117,6 @@
 (defmethod execute-frame-command ((frame standard-application-frame) command)
   (apply (command-name command) (command-arguments command)))
 
-(defvar *click-outside-menu-handler* nil)
-
 (defmethod command-enabled (command-name (frame standard-application-frame))
   (with-slots (disabled-commands) frame
     (or *assume-all-commands-enabled*
diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp
index 55752539..ea4abf46 100644
--- a/clim/graphics-recording.lisp
+++ b/clim/graphics-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-recording.lisp,v 1.16 92/11/19 14:17:48 cer Exp $
+;; $fiHeader: graphics-recording.lisp,v 1.17 92/11/20 08:44:38 cer Exp $
 
 (in-package :clim-internals)
 
@@ -376,7 +376,13 @@
 (define-graphics-recording draw-rectangles (ink line-style clipping-region)
   :bounding-rectangle 
     (position-sequence-bounding-rectangle 
-      position-seq line-style)
+     position-seq line-style)
+  :recording-hook
+  (unless (rectilinear-transformation-p (medium-transformation stream))
+    ;; Not too inefficient, since we're about to create an output record anyway
+    (silica::medium-draw-transformed-rectangles*
+     stream position-seq filled)
+    (return-from medium-draw-rectangles* nil))
   :refined-position-test
     ((x y)
      (let ((position-seq (slot-value record 'position-seq))
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index ac899263..e7bbef6d 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.32 92/11/19 14:18:01 cer Exp $
+;; $fiHeader: input-protocol.lisp,v 1.33 92/11/20 08:44:41 cer Exp $
 
 (in-package :clim-internals)
 
@@ -45,11 +45,11 @@
       (if (and gesture
 	       pointer-button-press-handler
 	       (typep gesture 'pointer-button-press-event))
-	  ;; If we call a normal translator, we'll throw to a tag outside of
-	  ;; this function that was established by WITH-INPUT-CONTEXT.  If we
-	  ;; call an action, it will throw to NO-TRANSLATION, and return here
-	  ;; In that case, we want to loop through this again.
-	  (funcall pointer-button-press-handler stream gesture)
+	    ;; If we call a normal translator, we'll throw to a tag outside of
+	    ;; this function that was established by WITH-INPUT-CONTEXT.  If we
+	    ;; call an action, it will throw to NO-TRANSLATION, and return here
+	    ;; In that case, we want to loop through this again.
+	    (funcall pointer-button-press-handler stream gesture)
 	;; A "normal" gesture
 	(return-from stream-read-gesture
 	  (values gesture flag)))
@@ -277,7 +277,17 @@
   (if *pointer-button-press-handler*
       ;; This may throw or something, but otherwise we will return NIL
       ;; which will cause the gesture to be eaten
-      (progn (funcall *pointer-button-press-handler* stream gesture)
+      (progn 
+	#+allegro
+	(when (and *click-outside-menu-handler*
+		   (output-recording-stream-p stream)
+		   (not 
+		    (region-contains-position-p
+		     (stream-output-history stream)
+		     (pointer-event-x gesture)
+		     (pointer-event-y gesture))))
+	  (funcall *click-outside-menu-handler*))
+	(funcall *pointer-button-press-handler* stream gesture)
 	     nil)
       ;; No button press handler, just return the gesture
       gesture))
diff --git a/clim/menus.lisp b/clim/menus.lisp
index 0212b0d0..7af69fe4 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.34 92/10/28 13:17:24 cer Exp $
+;; $fiHeader: menus.lisp,v 1.35 92/11/06 19:00:05 cer Exp $
 
 (in-package :clim-internals)
 
@@ -13,18 +13,24 @@
 (defparameter *default-menu-label-text-style* (make-text-style :fix :italic :normal))
 
 (define-application-frame menu-frame ()
-    (menu label)
+			  (menu 
+			   label 
+			   (scroll-bars :initarg :scroll-bars 
+					:initform t
+					:reader menu-frame-scroll-bars))
   (:pane
-    (with-slots (menu label) *application-frame*
-      (outlining ()
-	(vertically ()
-	  (setq label (make-pane 'label-pane 
-			:label ""
-			:text-style *default-menu-label-text-style*))
-	  (scrolling ()
-	    (setq menu (make-pane 'clim-stream-pane
-			 :initial-cursor-visibility nil)))))))
-
+   (with-slots (menu label scroll-bars) *application-frame*
+     (outlining ()
+		(vertically ()
+		    (setq label (make-pane 'label-pane 
+					   :label ""
+					   :text-style *default-menu-label-text-style*))
+		  (if scroll-bars
+		      (scrolling (:scroll-bars  scroll-bars )
+				 (setq menu (make-pane 'clim-stream-pane
+						       :initial-cursor-visibility nil)))
+		    (setq menu (make-pane 'clim-stream-pane
+					  :initial-cursor-visibility nil)))))))
   (:menu-bar nil))
 
 (defmethod frame-calling-frame ((frame menu-frame))
@@ -32,22 +38,24 @@
        *application-frame*))
 
 ;; Returns a stream that corresponds to the pane holding the menu
-(defun get-menu (&key port)
+(defmethod frame-manager-get-menu ((framem standard-frame-manager) &key scroll-bars)
   (let ((frame (make-application-frame 'menu-frame
-				       :parent port
+				       :scroll-bars scroll-bars
+				       :parent framem
 				       :save-under t)))
     ;; This so that ports can do something interesting with popped-up
     ;; menu frames, such as implemented "click off menu to abort".
     (setf (getf (frame-properties frame) :menu-frame) t)
     (values (slot-value frame 'menu) frame)))
 
-(defresource menu (associated-window root &key label)
-  :constructor (let* ((port (if (null root) (find-port) (port root))))
-		 (get-menu :port port))
+(defresource menu (associated-window root &key label (scroll-bars t))
+  :constructor (let* ((framem (if (null root) (find-frame-manager) (frame-manager root))))
+		 (frame-manager-get-menu framem :scroll-bars scroll-bars))
   :deinitializer (window-clear menu)
   :initializer (initialize-menu (port menu) menu :label label)
   ;; Horrible kludge in the case where no associated window is passed in.
-  :matcher (eq (port menu) (port root)))
+  :matcher (and (eq scroll-bars (menu-frame-scroll-bars (pane-frame menu)))
+		(eq (frame-manager menu) (frame-manager root))))
 
 (defmethod initialize-menu ((port basic-port) menu &key label)
   ;;--- Should this flush the menu's event queue?
@@ -308,21 +316,27 @@
 
 
 (defmacro with-mouse-grabbed-in-window ((window &rest options) &body body)
-  `(flet ((with-mouse-grabbed-in-window-body () ,@body))
-     (declare (dynamic-extent #'with-mouse-grabbed-in-window-body))
-     (invoke-with-mouse-grabbed-in-window
-       ,window #'with-mouse-grabbed-in-window-body ,@options)))
-
-(defmethod invoke-with-mouse-grabbed-in-window ((window t) continuation &key)
+  (let ((m (gensym)))
+    `(flet ((with-mouse-grabbed-in-window-body () ,@body))
+       (declare (dynamic-extent #'with-mouse-grabbed-in-window-body))
+       (let ((,m ,window))
+	 (invoke-with-mouse-grabbed-in-window
+	  (frame-manager ,m)
+	  ,m #'with-mouse-grabbed-in-window-body ,@options)))))
+
+(defmethod invoke-with-mouse-grabbed-in-window ((framem standard-frame-manager) (window t) continuation &key)
   (funcall continuation))
 
 (defmacro with-menu-as-popup ((menu) &body body)
-  `(flet ((with-menu-as-popup-body () ,@body))
-     (declare (dynamic-extent #'with-menu-as-popup-body))
-     (invoke-with-menu-as-popup
-       ,menu #'with-menu-as-popup-body)))
-
-(defmethod invoke-with-menu-as-popup ((window t) continuation)
+  (let ((m (gensym)))
+    `(flet ((with-menu-as-popup-body () ,@body))
+       (declare (dynamic-extent #'with-menu-as-popup-body))
+       (let ((,m ,menu))
+	 (invoke-with-menu-as-popup
+	  (frame-manager ,m)
+	  ,m #'with-menu-as-popup-body)))))
+
+(defmethod invoke-with-menu-as-popup ((framem standard-frame-manager) (window t) continuation)
   (funcall continuation))
 
 ;; The drawer gets called with (stream presentation-type &rest drawer-args).
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 17bf4c81..b207be9f 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: output-protocol.lisp,v 1.27 92/11/06 19:00:08 cer Exp $
+;; $fiHeader: output-protocol.lisp,v 1.28 92/11/20 08:44:47 cer Exp $
 
 (in-package :clim-internals)
 
@@ -181,6 +181,7 @@
     (values cursor-x cursor-y)))
 
 (defmethod stream-set-cursor-position ((stream output-protocol-mixin) x y)
+  
   (with-slots (cursor-x cursor-y current-line-height baseline) stream
     (when x 
       (setf cursor-x (coordinate x)))
diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp
index 0c2cf582..d58922a0 100644
--- a/demo/bitmap-editor.lisp
+++ b/demo/bitmap-editor.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: bitmap-editor.lisp,v 1.8 92/11/18 15:54:17 colin Exp $
+;; $fiHeader: bitmap-editor.lisp,v 1.9 92/11/20 08:45:16 cer Exp $
 
 (in-package :clim-demo)
 
@@ -32,7 +32,7 @@
      (array :initarg :array :initform nil)
      (current-color :initarg :current-color :initform 1)
      (colors :initarg :colors :initform 
-	     (list +background-ink+ +foreground-ink+)))
+	     (list +white+ +black+)))
   (:panes
     (palette :accept-values
 	     :width :compute :height :compute
diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp
index c9e0a2e8..e31debf5 100644
--- a/demo/graphics-demos.lisp
+++ b/demo/graphics-demos.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-demos.lisp,v 1.10 92/07/20 16:01:20 cer Exp $
+;; $fiHeader: graphics-demos.lisp,v 1.11 92/10/07 14:43:30 cer Exp $
 
 (in-package :clim-demo)
 
@@ -19,19 +19,19 @@
     (:default
       (vertically () demo explanation))))
 
-(define-graphics-demo-command (com-Exit-Graphics-Demo :menu "Exit")
+(define-graphics-demo-command (com-exit-graphics-demo :menu "Exit")
     ()
   (frame-exit *application-frame*))
 
 (defmacro define-gdemo (name explanation (window) &body body)
   `(define-graphics-demo-command (,(intern (format nil "~A-~A-~A" 'com name 'graphics-demo))
-				  :menu ,name) ()
+				  :menu ,(nstring-capitalize (substitute #\space #\- (string name)))) ()
      (explain ,explanation)
      (let ((,window (get-frame-pane *application-frame* 'demo)))
        (window-clear ,window)
        ,@body)))
 
-(define-gdemo "Spin" "A simple example of the use of affine transforms.
+(define-gdemo spin "A simple example of the use of affine transforms.
 Take a simple function that draws a picture and invoke it
 repeatedly under various rotations."
 	      (stream)
@@ -49,7 +49,7 @@ repeatedly under various rotations."
 		(with-translation (stream 100 0)
 		  (draw stream))))))))))
 
-(define-gdemo "Big Spin" "A more complex example using both
+(define-gdemo big-spin "A more complex example using both
 rotation and scaling."
 	      (stream)
   (multiple-value-bind (w h) (window-inside-size stream)
@@ -101,7 +101,7 @@ rotation and scaling."
 	  (draw-line* ws x2 y3 x2 y4 :ink ink))))
     ))
 
-(define-gdemo "CBS Logo" ""
+(define-gdemo cbs-logo ""
 	      (stream)
   (multiple-value-bind (w h) (window-inside-size stream)
     (with-translation (stream (round w 2) (round h 2))
@@ -162,7 +162,7 @@ rotation and scaling."
     ((= i 10))
   (setf (aref *polygons* i) (compute-regular-polygon 0 1 0 -1 i)))
 
-(define-gdemo "Polygons" ""
+(define-gdemo polygons ""
 	      (stream)
   (multiple-value-bind (w h) (window-inside-size stream)
     (with-translation (stream (- (round w 2) 200) (round h 2))
@@ -184,7 +184,7 @@ rotation and scaling."
 (defun random-ink ()
   (nth (random (length *random-ink-list*)) *random-ink-list*))
 
-(define-gdemo "Circles" "A lot of circles in a variety of colors.
+(define-gdemo circles "A lot of circles in a variety of colors.
 On a monochrome display, stipples are used to simulate the colors."
 	      (stream)
   (let* ((radius 20)
@@ -197,7 +197,7 @@ On a monochrome display, stipples are used to simulate the colors."
 	    ((> x (- wid separation)) nil)
 	  (draw-circle* stream x y radius :filled nil :ink (random-ink)))))))
 
-(define-gdemo "Maze" "This simple maze drawer uses the graphics
+(define-gdemo maze "This simple maze drawer uses the graphics
 scaling feature to adjust the maze size
 to the window in which it is displayed."
 	      (stream)
diff --git a/misc/train.lisp b/misc/train.lisp
new file mode 100644
index 00000000..895da43c
--- /dev/null
+++ b/misc/train.lisp
@@ -0,0 +1,42 @@
+;; -*- mode: common-lisp; package: user -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
+(defun train-clim (&key (train-times 2) (psview nil))
+  (load "test/test.lisp") 
+  (clim-user::train-clim-2 train-times) 
+  (clim-user::do-frame-tests) 
+  (when psview
+    (load "test/postscript-tests.lisp")
+    (clim-user::run-postscript-tests :output psview))
+  (with-open-file (*standard-output* "coverage-report.lisp" 
+		   :if-exists :supersede :direction :output)
+    (generate-coverage-report))
+  (compile-file "misc/clos-preload.cl" 
+		:output-file 
+		(if (excl::featurep :clim-motif) 
+		    "misc/clos-preloadxm.fasl" 
+		  "misc/clos-preloadol.fasl")))
+
+
+
diff --git a/silica/classes.lisp b/silica/classes.lisp
index d69cea31..9a4f80bd 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: classes.lisp,v 1.23 92/10/28 11:30:42 cer Exp Locker: cer $
+;; $fiHeader: classes.lisp,v 1.24 92/10/28 13:17:04 cer Exp $
 
 (in-package :silica)
 
@@ -53,7 +53,9 @@
      (allow-loose-text-style-size-mapping 
        :initform nil :initarg :allow-loose-text-style-size-mapping)
      (canonical-gesture-specs :reader port-canonical-gesture-specs
-			      :initform (make-hash-table :test #'equal))))
+			      :initform (make-hash-table :test #'equal))
+     (grabbing-sheet :initform nil :accessor port-grabbing-sheet)))
+
 
 )	;locally
 
diff --git a/silica/db-border.lisp b/silica/db-border.lisp
index 0480523d..83e87da1 100644
--- a/silica/db-border.lisp
+++ b/silica/db-border.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-border.lisp,v 1.12 92/09/24 09:37:27 cer Exp $
+;; $fiHeader: db-border.lisp,v 1.13 92/10/02 15:18:07 cer Exp $
 
 "Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
  Portions copyright (c) 1991, 1992 by Symbolics, Inc.  All rights reserved."
@@ -89,6 +89,19 @@
 		     ;; mechanism for the Motif/OpenLook ports
 		     :text-style nil))
 
+(defmacro labelling ((&rest options 
+		       &key (label-alignment #+Genera :bottom #-Genera :top) 
+		       &allow-other-keys) 
+		      &body contents)
+   (setq options (remove-keywords options '(:label-alignment)))
+   `(ecase label-alignment
+      (:bottom
+	(vertically () 
+	  ,@contents (make-pane 'label-pane ,@options)))
+      (:top
+	(vertically ()
+	    (make-pane 'label-pane ,@options) ,@contents))))
+
 (defclass generic-label-pane 
 	  (label-pane
 	   space-requirement-mixin
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index 1a3abe2d..e5011d0f 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.34 92/11/06 19:03:40 cer Exp $
+;; $fiHeader: db-scroll.lisp,v 1.35 92/11/19 14:24:50 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -262,12 +262,13 @@
 	(:horizontal
 	  (scroll-extent
 	    contents
-	    :x (* (max 0 (- (bounding-rectangle-width extent)
-			    (bounding-rectangle-width region)))
-		  (if (= size (gadget-range sheet))
-		      0
-		      (/ (- value (gadget-min-value sheet))
-			 (- (gadget-range sheet) size))))
+	    :x (+ (bounding-rectangle-min-x extent)
+		  (* (max 0 (- (bounding-rectangle-width extent)
+			       (bounding-rectangle-width region)))
+		     (if (= size (gadget-range sheet))
+			 0
+		       (/ (- value (gadget-min-value sheet))
+			  (- (gadget-range sheet) size)))))
 	    :y (bounding-rectangle-min-y region)))))))
 
 (defun update-region (sheet nleft ntop nright nbottom &key no-repaint)
diff --git a/silica/event.lisp b/silica/event.lisp
index 82f2d7e6..1c281698 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: event.lisp,v 1.28 92/11/06 19:03:44 cer Exp $
+;; $fiHeader: event.lisp,v 1.29 92/11/19 14:24:54 cer Exp $
 
 (in-package :silica)
 
@@ -514,6 +514,11 @@
     (let ((sheet (let ((v (port-trace-thing port)))
 		   (and (not (zerop (fill-pointer v)))
 			(aref v (1- (fill-pointer v)))))))
+      ;;--- This is not quite right. We need to transform the
+      ;;--- coordinates better. Also it should probably override 
+      ;;--- the sheet in the trace-thing.
+      (unless sheet 
+	(setq sheet (port-grabbing-sheet port)))
       (when (and sheet (port sheet))
 	(multiple-value-bind (tx ty)
 	    (untransform-position (sheet-device-transformation sheet) x y)
diff --git a/silica/graphics.lisp b/silica/graphics.lisp
index 30c99fae..7ce700b7 100644
--- a/silica/graphics.lisp
+++ b/silica/graphics.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics.lisp,v 1.22 92/11/19 14:25:00 cer Exp $
+;; $fiHeader: graphics.lisp,v 1.23 92/11/20 08:45:50 cer Exp $
 
 (in-package :silica)
 
@@ -576,7 +576,36 @@
 (define-graphics-generic draw-rectangles ((points point-sequence position-seq)
 					  &key (filled t))
   :drawing-options :line-joint
-  :position-sequences-to-transform (position-seq))
+  :position-sequences-to-transform (position-seq)
+  :medium-method-body
+  (let ((transform (medium-transformation medium)))
+    (cond ((rectilinear-transformation-p transform)
+	   (setq position-seq (transform-position-sequence transform position-seq))
+	   (call-next-method medium position-seq filled))
+	  (t
+	   (medium-draw-transformed-rectangles* medium position-seq filled)))))
+
+(defun medium-draw-transformed-rectangles* (stream position-seq filled)
+  (let ((len (length position-seq)))
+    (assert (zerop (mod len 4)))
+    (macrolet ((guts (x1 y1 x2 y2)
+		 `(let ((x1 ,x1) 
+			(y1 ,y1) 
+			(x2 ,x2) 
+			(y2 ,y2))
+		    (with-stack-list (list x1 y1 x2 y1 x2 y2 x1 y2)
+		      (medium-draw-polygon* stream list t filled)))))
+      (if (listp position-seq)
+	  (do ((position-seq position-seq))
+	      ((null position-seq))
+	    (guts (pop position-seq) (pop position-seq) 
+		  (pop position-seq) (pop position-seq)))
+	(do ((i 0 (+ i 4)))
+	    ((= i len))
+	  (guts (aref position-seq i)
+		(aref position-seq (+ 1 i))
+		(aref position-seq (+ 2 i))
+		(aref position-seq (+ 3 i))))))))
 
 ;; DRAW-PATTERN* is a special case of DRAW-RECTANGLE*, believe it or not...
 (defun draw-pattern* (medium pattern x y &key clipping-region transformation)
diff --git a/silica/port.lisp b/silica/port.lisp
index 5298893a..a288041d 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.24 92/11/06 19:03:56 cer Exp $
+;; $fiHeader: port.lisp,v 1.25 92/11/19 14:25:03 cer Exp $
 
 (in-package :silica)
 
@@ -31,7 +31,8 @@
   (map-over-ports #'(lambda (port)
 		      (when (port-match port server-path) 
 			(return-from find-port port))))
-  (apply #'make-port initargs))
+  (with-keywords-removed (initargs initargs '(:server-path))
+    (apply #'make-port :server-path server-path initargs)))
 
 #+Genera
 (scl:add-initialization "Reset ports"
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index eff6e15b..4a8efcf1 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sheet.lisp,v 1.30 92/10/28 11:30:54 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.31 92/11/06 19:03:59 cer Exp $
 
 (in-package :silica)
 
@@ -482,6 +482,11 @@
   (declare (dynamic-extent options))
   (apply #'port-invoke-with-pointer-grabbed (port sheet) sheet continuation options))
 
+(defmethod port-invoke-with-pointer-grabbed :around
+    ((port basic-port) (sheet basic-sheet) continuation &key)
+  (letf-globally (((port-grabbing-sheet port) sheet))
+    (call-next-method)))
+
 (defmethod port-invoke-with-pointer-grabbed 
 	   ((port basic-port) (sheet basic-sheet) continuation &key)
   (funcall continuation))
diff --git a/test/postscript-tests.lisp b/test/postscript-tests.lisp
index 46dfc2bf..94de657a 100644
--- a/test/postscript-tests.lisp
+++ b/test/postscript-tests.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: postscript-tests.lisp,v 1.1 92/10/02 15:17:39 cer Exp $
+;; $fiHeader: postscript-tests.lisp,v 1.2 92/10/28 11:32:17 cer Exp $
 
 (in-package :clim-user)
 
@@ -96,6 +96,11 @@
 		       :name ,command-name-string)
 	  ,args
 	(ecase output
+	  (:file
+	   (with-open-file
+	       (file-stream "postscript.output" :direction :output :if-exists :supersede)
+	     (with-output-to-postscript-stream (*standard-output* file-stream)
+	       ,command-body-form)))
 	  (:view
 	    (with-drawing-display-window (*standard-output*)
 	      ,command-body-form))
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index efca8e53..1467b125 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.45 92/11/13 14:46:50 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.46 92/11/20 08:45:55 cer Exp $
 
 (in-package :clim-user)
 
@@ -673,7 +673,24 @@ people, shall not perish from the earth.
     (format-graphics-sample stream "Large Point" '(draw-point* 0 0 :line-thickness 5)))
   (formatting-graphics-samples (stream "Some Lines")
     (format-graphics-sample stream "Some Lines"
-      '(draw-lines* (0 0 10 100 50 50 90 100 100 10 40 50))))
+	'(draw-lines* (0 0 10 100 50 50 90 100 100 10 40 50))))
+  (formatting-graphics-samples (stream "Some Rectangles")
+    (format-graphics-sample stream "Some Rectangles"
+			    '(draw-rectangles* (0 0 10 100 50 50 90
+						100 100 10 40 50)))
+    
+    (format-graphics-sample stream "A rectangle" '(draw-rectangle* 0 0 10 100))
+    (format-graphics-sample stream "A rectangles" '(draw-rectangle* 50 50 90 100 ))
+    (format-graphics-sample stream "A rectangle" '(draw-rectangle*  100 10 40 50)))
+  (with-rotation (stream .5)
+      (formatting-graphics-samples (stream "Some rotated rectangles")
+	 (format-graphics-sample stream "Some Rectangles"
+				 '(draw-rectangles* (0 0 10 100 50 50 90
+						     100 100 10 40
+						     50)))
+	 (format-graphics-sample stream "A rectangle" '(draw-rectangle* 0 0 10 100))
+	 (format-graphics-sample stream "A rectangle" '(draw-rectangle* 50 50 90 100 ))
+	 (format-graphics-sample stream "A rectangle" '(draw-rectangle*  100 10 40 50))))
   (formatting-graphics-samples (stream "Many Points")
     (format-graphics-sample stream "Many Small Points"
       '(draw-points* (0 0 10 110 50 50 90 110 100 10 50 40)))
@@ -706,6 +723,17 @@ people, shall not perish from the earth.
 	(draw-text* stream "Dont be silly in the City." x 200
 		    :towards-x x :towards-y 0)))))
 
+(define-test (negative-extent graphics) (stream)
+  "Draw things at -ve values. You should be able to scroll and see all of it"
+  (let ((x 400)
+	(y 400))
+    (draw-point* stream (- x) 0 :ink +red+ :line-thickness 3)
+    (draw-point* stream x 0 :ink +red+ :line-thickness 3)
+    (draw-point* stream 0  (- y) :ink +red+ :line-thickness 3)
+    (draw-point* stream 0 y :ink +red+ :line-thickness 3)
+    (draw-line* stream (- x) 0 x 0)
+    (draw-line* stream 0 (- y) 0 y)))
+
 (define-test (pixmap-test graphics) (stream)
   "Test pixmap code"
   (with-sheet-medium (medium stream)
@@ -721,7 +749,39 @@ people, shall not perish from the earth.
 	(dotimes (i 5)
 	  (unless (= i j)
 	    (sleep 0.25)
-	    (copy-from-pixmap pixmap 0 0 100 100 medium (* j 100) (* i 100))))))))
+	    (copy-from-pixmap pixmap 0 0 100 100 medium (* j 100) (* i
+								     100))))))))
+
+#+allegro
+(define-test (read-image-test graphics) (stream)
+  "Test image reading code"
+  (formatting-table (stream)
+      (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus"))
+	(formatting-row (stream)
+	    (formatting-cell (stream)
+		(write-string name stream))
+	  (formatting-cell (stream)
+	      (let ((filename (format nil "/usr/include/X11/bitmaps/~A" name)))
+		(if (probe-file filename)
+		    (let ((pattern (xm-silica::make-pattern-from-file
+				    filename 
+				    (list +background-ink+ +foreground-ink+))))
+		      (draw-rectangle* stream 0 0 (pattern-width pattern) (pattern-height pattern) :ink pattern))
+		  (write-string "not found" stream))))))))
+
+#+Allegro
+(define-test (draw-some-bezier-curves graphics) (stream)
+  "Draw bezier curve"
+  (let ((points (list 0 0 100 300 300 300 400 0 200 200 150 30 0 0)))
+    (formatting-item-list (stream)
+	(dolist (filled '(nil t))
+	  (formatting-cell (stream)
+	      (with-scaling (stream 0.5)
+		(draw-bezier-polygon* stream points :filled filled)
+		(do ((points points (cddr points)))
+		    ((null points))
+		  (draw-point* stream (car points) (cadr points) :line-thickness 2
+			       :ink +red+))))))))
 
 (defparameter *named-colors*
  '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+
@@ -1405,6 +1465,8 @@ Luke Luck licks the lakes Luke's duck likes."))
       (read-gesture :stream stream)
       (table-graphics-test-column i))))
 
+
+
 
 ;;; Redisplay tests
 
@@ -1616,6 +1678,32 @@ Luke Luck licks the lakes Luke's duck likes."))
     (accept 'integer :stream stream)
     (fresh-line stream)))
 
+(define-presentation-type drag-source ()
+  :inherit-from 'integer)
+
+(define-presentation-type drop-target ()
+  :inherit-from 'integer)
+
+(define-drag-and-drop-translator test-suite-dnd
+    (drag-source string drop-target presentations)
+  (presentation destination-presentation)
+  (princ-to-string (list (presentation-object presentation) (presentation-object destination-presentation))))
+
+
+(define-test (drag-and-drop-tests presentations) (stream)
+  "Try drag and drop"
+  (formatting-table (stream)
+      (dotimes (i 3)
+	(formatting-row (stream)
+	    (formatting-cell (stream)
+		(with-output-as-presentation (stream i 'drag-source)
+		  (format stream "Drag source ~D" i)))
+	  (formatting-cell (stream)
+	      (with-output-as-presentation (stream i 'drop-target)
+		(format stream "drop target ~D" i))))))
+  (loop
+    (terpri stream)
+    (accept 'string :stream stream)))
 
 ;;; Menus
 
@@ -1701,12 +1789,13 @@ Luke Luck licks the lakes Luke's duck likes."))
 			   :text-style '(:sans-serif :roman :large))))
 	   (draw-compass (stream ptype)
 	     #+Genera (declare (sys:downward-function))
-	     (draw-line* stream 0 25 0 -25 :line-thickness 2)
-	     (draw-line* stream 25 0 -25 0 :line-thickness 2)
-	     (dolist (point '((n 0 -30) (s 0 30) (e 30 0) (w -30 0)))
-	       (apply #'draw-compass-point stream ptype point))))
+	     (with-room-for-graphics (stream :first-quadrant nil)
+	       (draw-line* stream 0 25 0 -25 :line-thickness 2)
+	       (draw-line* stream 25 0 -25 0 :line-thickness 2)
+	       (dolist (point '((n 0 -30) (s 0 30) (e 30 0) (w -30 0)))
+		 (apply #'draw-compass-point stream ptype point)))))
     #+ignore (declare (dynamic-extent #'draw-compass-point #'draw-compass))
-    (with-menu (menu stream)
+    (with-menu (menu stream :scroll-bars nil)
       #-silica (setf (window-label menu) "Compass point")
       (format stream "~S" (menu-choose-from-drawer menu 'menu-item #'draw-compass)))))
 
@@ -1971,6 +2060,12 @@ Luke Luck licks the lakes Luke's duck likes."))
 		   (l (member :red :blue :green) :view +option-pane-view+))))))
 
 
+(define-test (input-editor-tests menus-and-dialogs) (stream)
+  "Type lots of input editor commands"
+  (loop
+    (fresh-line stream)
+    (accept 'string :stream stream)))
+
 
 ;;;; Benchmarks
 
@@ -2103,7 +2198,8 @@ Luke Luck licks the lakes Luke's duck likes."))
     (run-benchmarks-internal pathname comment)))
 
 (define-command (run-benchmarks-to-dummy-file :command-table benchmarks :menu t)
-    ((file 'pathname))
+    (&key 
+     (file '(null-or-type pathname) :default nil))
   (run-benchmarks-internal file "no comment"))
 
 (defun run-benchmarks-internal (pathname comment)
@@ -2114,13 +2210,14 @@ Luke Luck licks the lakes Luke's duck likes."))
 	(let ((time (funcall function :careful t)))
 	  (push (list (first benchmark) time) data))))
     (setq data (reverse data))
-    (let ((*package* (or (find-package :common-lisp-user)
-			 (error "Package COMMON-LISP-USER not found"))))
-      (with-open-file (s pathname :direction :output)
-	(format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
-	(format s "~%;on ~A ~A.~%" (machine-type) (machine-instance))
-	(when comment (format s ";~A~%" comment))
-	(print data s)))))
+    (when pathname
+      (let ((*package* (or (find-package :common-lisp-user)
+			   (error "Package COMMON-LISP-USER not found"))))
+	(with-open-file (s pathname :direction :output)
+	  (format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version))
+	  (format s "~%;on ~A ~A.~%" (machine-type) (machine-instance))
+	  (when comment (format s ";~A~%" comment))
+	  (print data s))))))
 
 (define-command (generate-report :command-table benchmarks :menu t)
     ()
@@ -2995,7 +3092,9 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 
 (define-application-frame clim-tests ()
-    ()
+			  ((history-class :initarg :history-class 
+					  :initform 'standard-tree-output-history
+					  :reader clim-tests-history-class))
   (:command-table (clim-tests
 		   :inherit-from (graphics
 				  output-recording
@@ -3014,17 +3113,19 @@ Luke Luck licks the lakes Luke's duck likes."))
 			  ("Exit" :command (exit-clim-tests)))))
   (:command-definer nil)
   (:panes 
-    (caption-pane
+   (caption-pane
       (outlining ()
 	(scrolling (:scroll-bars :vertical)
-	  (make-pane 'application-pane :height 50))))
-    (display-pane 
-      (outlining ()
-	(scrolling ()
-	  (make-pane 'application-pane)))))
+		   (make-pane 'application-pane 
+			      :height 50
+			      :output-record
+			      (make-instance (clim-tests-history-class *application-frame*))))))
+    (display-pane :application
+		  :output-record
+		  (make-instance (clim-tests-history-class *application-frame*))))
   (:layouts
     (:default
-      (vertically () caption-pane display-pane))))
+	(vertically () caption-pane display-pane))))
 
 (defmethod frame-standard-output ((frame clim-tests))
   (get-frame-pane frame 'display-pane))
diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
index 957501fe..aa0c6874 100644
--- a/tk-silica/image.lisp
+++ b/tk-silica/image.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: image.lisp,v 1.4 92/02/24 13:06:04 cer Exp $
+;; $fiHeader: image.lisp,v 1.5 92/11/20 08:46:30 cer Exp $
 
 
 (in-package :xm-silica)
@@ -37,97 +37,100 @@
   ;; Creates an image from a C include file in standard X11 format
   (declare (type (or pathname string stream) pathname))
   (declare (values image))
-  (flet ((kintern (x) (intern x :keyword))
-	 ;;;-- This does the wrong thing.
-	 (correct-case (x) x))
-    (with-open-file (fstream pathname :direction :input)
-      (let ((line "")
-	    (properties nil)
-	    (name nil)
-	    (name-end nil))
-	(declare (type string line)
-		 (type list properties))
-	;; Get properties
+  (with-open-file (fstream pathname :direction :input)
+    (let ((line "")
+	  (properties nil)
+	  (name nil)
+	  (name-end nil))
+      (declare (type string line)
+	       (type list properties))
+      ;; Get properties
 
-	(loop
-	  (setq line (read-line fstream))
-	  (when  (> (length line) 0)
-	    (when (char= (aref line 0) #\#)
-	      (return))))
-	(loop
-	  (when  (> (length line) 0)
-	    (unless (char= (aref line 0) #\#)
-	      (return))
-	    (flet ((read-keyword (line start end)
-		     (cdr (find-if #'(lambda (pair)
-				       (string= (car pair)
-						line :start2 start
-						:end2 end))
-				   '(("image" . :image)
-				     ("width" . :width)
-				     ("height". :height)
-				     ("depth" . :depth)
-				     ("left-pad" . :left-pad))))))
-	      (when (null name)
-		(setq name-end (position #\_ line :test #'char= :from-end t)
-		      name (read-keyword line 8 name-end))
-		(unless (eq name :image)
-		  (setf (getf properties :name) name)))
-	      (let* ((ind-start (1+ name-end))
-		     (ind-end (position #\Space line :test #'char=
-					:start ind-start))
-		     (ind (read-keyword line ind-start ind-end))
-		     (val-start (1+ ind-end))
-		     (val (parse-integer line :start val-start)))
-		(when ind
-		  (setf (getf properties ind) val)))))
-	  (setq line (read-line fstream)))
+      (loop
+	(setq line (read-line fstream))
+	(when  (> (length line) 0)
+	  (when (char= (aref line 0) #\#)
+	    (return))))
+      (loop
+	(when  (> (length line) 0)
+	  (unless (char= (aref line 0) #\#)
+	    (return))
+	  (flet ((read-keyword (line start end)
+		   (cdr (find-if #'(lambda (pair)
+				     (string= (car pair)
+					      line :start2 start
+					      :end2 end))
+				 '(("image" . :image)
+				   ("width" . :width)
+				   ("height". :height)
+				   ("depth" . :depth)
+				   ("left-pad" . :left-pad))))))
+	    (when (null name)
+	      (setq name-end (position #\_ line :test #'char= :from-end t)
+		    name (read-keyword line 8 name-end))
+	      (unless (eq name :image)
+		(setf (getf properties :name) name)))
+	    (let* ((ind-start (1+ name-end))
+		   (ind-end (position #\Space line :test #'char=
+				      :start ind-start))
+		   (ind (read-keyword line ind-start ind-end))
+		   (val-start (1+ ind-end))
+		   (val (parse-integer line :start val-start)))
+	      (when ind
+		(setf (getf properties ind) val)))))
+	(setq line (read-line fstream)))
       
-	(multiple-value-bind (width height depth left-pad)
-	    (flet ((extract-property (ind &rest default)
-		     (prog1 (apply #'getf properties ind default)
-		       (remf properties ind))))
-	      (values (extract-property :width)
-		      (extract-property :height)
-		      (extract-property :depth 1)
-		      (extract-property :left-pad 0)))
-	  (unless (and width height) (error "Not a BITMAP file"))
-	  (let* ((bits-per-pixel
-		  (cond ((> depth 24) 32)
-			((> depth 16) 24)
-			((> depth 8)  16)
-			((> depth 4)   8)
-			((> depth 2)   4)
-			((> depth 1)   2)
-			(t 1)))
-		 (data (make-array (list height width)))
-		 (w 0)
-		 (h 0))
-	    (labels ((read-a-byte ()
-		       (peek-char #\x fstream)
-		       (read-char fstream)
-		       (+ (* 16 (digit-char-p (read-char fstream) 16))
-			  (digit-char-p (read-char fstream) 16)))
-		     (store-byte (x)
-		       (setf (aref data h w) x)
-		       (incf w)
-		       (when (= w width)
-			 (setq w 0)
-			 (incf h))
-		       (when (= h height)
-			 (return-from read-bitmap-file
-			   (values data
-				   width 
-				   height
-				   depth)))))
-	      (loop
-		(let ((x 0))
-		  (dotimes (i (ceiling bits-per-pixel 8))
-		    (setf x (ash x 8))
-		    (incf x (read-a-byte)))
-		  (if (>= bits-per-pixel 8)
-		      (store-byte x)
-		    (dotimes (j (/ 8 bits-per-pixel))
-		      (store-byte
-		       (ldb (byte bits-per-pixel (* j bits-per-pixel))
-			    x)))))))))))))
+      (multiple-value-bind (width height depth left-pad)
+	  (flet ((extract-property (ind &rest default)
+		   (prog1 (apply #'getf properties ind default)
+		     (remf properties ind))))
+	    (values (extract-property :width)
+		    (extract-property :height)
+		    (extract-property :depth 1)
+		    (extract-property :left-pad 0)))
+	(unless (and width height) (error "Not a BITMAP file"))
+	(let* ((bits-per-pixel
+		(cond ((> depth 24) 32)
+		      ((> depth 16) 24)
+		      ((> depth 8)  16)
+		      ((> depth 4)   8)
+		      ((> depth 2)   4)
+		      ((> depth 1)   2)
+		      (t 1)))
+	       (data (make-array (list height width)))
+	       (bits-per-line (* width bits-per-pixel))
+	       (bytes-per-line (ceiling bits-per-line 8))
+	       #+ignore
+	       (padded-bits-per-line
+		(* (ceiling bits-per-line 32) 32))
+	       #+ignore
+	       (padded-bytes-per-line
+		(ceiling padded-bits-per-line 8)))
+	  (labels ((read-a-byte ()
+		     (peek-char #\x fstream)
+		     (read-char fstream)
+		     (+ (* 16 (digit-char-p (read-char fstream) 16))
+			(digit-char-p (read-char fstream) 16))))
+	      
+	    (dotimes (i height)
+	      (dotimes (j bytes-per-line)
+		(let* ((byte (read-a-byte))
+		       (bit-index (* j 8)))
+		  (multiple-value-bind (pixel-offset offset-in-pixel)
+		      (truncate bit-index bits-per-pixel)
+		    (if (<= bits-per-pixel 8)
+			(dotimes (bit (/ 8 bits-per-pixel))
+			  (let ((zz (+ pixel-offset bit)))
+			    (when (< zz width)
+			      (setf (aref data i zz)
+				(ldb (byte bits-per-pixel (* bits-per-pixel bit)) byte)))))
+		      (progn
+			(assert (zerop (mod bits-per-pixel 8)))
+			(when (< pixel-offset width)
+			  (setf (aref data i pixel-offset)
+			    (dpb byte (byte 8 offset-in-pixel) (aref data i pixel-offset))))))))))
+	      
+	    (values data
+		    width 
+		    height
+		    depth)))))))
diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp
index 093e6da9..ad92c79a 100644
--- a/tk-silica/xm-dialogs.lisp
+++ b/tk-silica/xm-dialogs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-dialogs.lisp,v 1.2 92/11/06 19:04:28 cer Exp $
+;; $fiHeader: xm-dialogs.lisp,v 1.3 92/11/20 08:46:39 cer Exp $
 
 
 (in-package :clim-internals)
@@ -266,3 +266,5 @@
 ;	      (unless own-window
 ;		(move-cursor-beyond-output-record (slot-value stream 'stream) avv))))
 ;	  (values-list return-values))))))
+
+
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index ed1d93b5..d15214c3 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.27 92/10/29 16:55:43 cer Exp $
+;; $fiHeader: xm-silica.lisp,v 1.28 92/11/20 08:46:48 cer Exp $
 
 (in-package :xm-silica)
 
@@ -45,6 +45,9 @@
   (declare (ignore x y width height))
   (apply #'tk::configure-widget child args))
 
+;;--- Why is this here???
+;;--- It should be in xt-silica
+
 (defmethod change-widget-geometry ((parent tk::shell) child
 				   &rest args
 				   &key x y width height)
@@ -52,17 +55,35 @@
   ;;-- shells decide where windows are positioned!
   (tk::set-values child :width width :height height))
 
+(defmethod change-widget-geometry ((parent tk::xm-dialog-shell) child
+				   &rest args
+				   &key x y width height)
+  (declare (ignore x y args))
+  (tk::set-values child :width width :height height :x x :y y))
+
+
 (defclass motif-geometry-manager (xt-geometry-manager) ())
 
 
 (defmethod find-shell-class-and-initargs ((port motif-port) sheet)
-  (cond ( ;;--- hack alert
+  (cond 
+   #+ignore
+   ((typep (pane-frame sheet) 'clim-internals::menu-frame)
+    (values 'xt::override-shell
+	    '(:width 1
+	    :height 1)))
+   
+   ( ;;--- hack alert
 	 (popup-frame-p sheet)
 	 (values 'tk::xm-dialog-shell
 		 (append
 		  (let ((x (find-shell-of-calling-frame sheet)))
 		    (and x `(:transient-for ,x)))
-		  '(:keyboard-focus-policy :pointer))))
+		  '(:keyboard-focus-policy :pointer)
+		  (and (typep (pane-frame sheet)
+			      'clim-internals::menu-frame)
+		       '(:override-redirect t)))))
+	 
 	(t
 	 (call-next-method))))
 
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index c22c0654..eb2b3045 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.22 92/11/09 19:56:05 cer Exp $
+;; $fiHeader: xt-frames.lisp,v 1.23 92/11/20 08:46:53 cer Exp $
 
 
 (in-package :xm-silica)
@@ -186,3 +186,12 @@
 
 (defmethod note-frame-deiconified ((framem xt-frame-manager) frame)
   (tk::set-values (frame-shell frame) :iconic nil))
+
+;;; 
+
+(defmethod invoke-with-menu-as-popup ((framem xt-frame-manager) (window t) continuation)
+  (funcall continuation))
+
+
+(defmethod invoke-with-mouse-grabbed-in-window ((framem xt-frame-manager) (window t) continuation &key)
+  (silica::invoke-with-pointer-grabbed window continuation))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index e3199d00..a6553697 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.53 92/11/19 14:25:30 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.54 92/11/20 08:46:56 cer Exp $
 
 (in-package :tk-silica)
 
@@ -1152,38 +1152,89 @@ and on color servers, unless using white or black")
 	   points
 	   npoints))))))
 
+(defmethod medium-draw-rectangles* ((medium xt-medium) rectangles filled) 
+  (let ((drawable (medium-drawable medium)))
+    (when drawable
+      (let* ((ink (medium-ink medium))
+	     (sheet (medium-sheet medium))
+	     (transform (sheet-device-transformation sheet))
+	     (len (length rectangles))
+	     (nrects (/ len 4))
+	     (rects (xt::make-xrectangle-array :number nrects))
+	     (overall-min-x #.(1- (ash 1 16)))
+	     (overall-min-y #.(1- (ash 1 16))))
+	(assert (zerop (mod len 4)) () "Must be a multiple of 4")
+	(assert (rectilinear-transformation-p transform))
+	(macrolet ((guts (x1 y1 x2 y2)
+		     `(let ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2))
+			(convert-to-device-coordinates transform x1 y1 x2 y2)
+			;; Clipping a rectangle is ridiculously easy.
+			(unless (valid-point-p x1 y1)
+			  (setq x1 (min (max -32000 (the fixnum x1)) 32000))
+			  (setq y1 (min (max -32000 (the fixnum y1)) 32000)))
+			(unless (valid-point-p x2 y2)
+			  (setq x2 (min (max -32000 (the fixnum x2)) 32000))
+			  (setq y2 (min (max -32000 (the fixnum y2)) 32000)))
+			(let ((min-x (min (the fixnum x1) (the fixnum x2)))
+			      (min-y (min (the fixnum y1) (the fixnum y2)))
+			      (max-x (max (the fixnum x1) (the fixnum x2)))
+			      (max-y (max (the fixnum y1) (the fixnum y2))))
+			  (declare (fixnum min-x min-y max-x max-y))
+			  (minf overall-min-x min-x)
+			  (minf overall-min-y min-y)
+			  (setf (tk::xrectangle-array-x rects i) min-x 
+				(tk::xrectangle-array-y rects i) min-y
+				(tk::xrectangle-array-width rects i) (- max-x min-x)
+				(tk::xrectangle-array-height rects i) (- max-y min-y))
+			  (incf i)))))
+	  (let ((i 0))
+	    (if (listp rectangles)
+		(loop
+		  (when (null rectangles) (return nil))
+		  (guts (pop rectangles) (pop rectangles) (pop rectangles) (pop rectangles)))
+	      (do ((j 0 (+ j 4)))
+		  ((= j len))
+		(guts (aref rectangles j) (aref rectangles (+ 1 j)) (aref rectangles (+ 2 j)) (aref rectangles (+ 3 j))))))
+	  (tk::draw-rectangles
+	   drawable
+	   (adjust-ink (decode-ink ink medium)
+		       medium
+		       (medium-line-style medium)
+		       overall-min-x overall-min-y)
+	   rects
+	   nrects
+	   filled))))))
+
 (defmethod medium-draw-rectangle* ((medium xt-medium) x1 y1 x2 y2 filled)
   (let ((drawable (medium-drawable medium)))
     (when drawable
       (let* ((ink (medium-ink medium))
 	     (sheet (medium-sheet medium))
 	     (transform (sheet-device-transformation sheet)))
-	(cond ((rectilinear-transformation-p transform)
-	       (convert-to-device-coordinates transform
-					      x1 y1 x2 y2)
-	       ;; Clipping a rectangle is ridiculously easy.
-	       (unless (valid-point-p x1 y1)
-		 (setq x1 (min (max -32000 (the fixnum x1)) 32000))
-		 (setq y1 (min (max -32000 (the fixnum y1)) 32000)))
-	       (unless (valid-point-p x2 y2)
-		 (setq x2 (min (max -32000 (the fixnum x2)) 32000))
-		 (setq y2 (min (max -32000 (the fixnum y2)) 32000)))
-	       (let ((min-x (min (the fixnum x1) (the fixnum x2)))
-		     (min-y (min (the fixnum y1) (the fixnum y2))))
-		 (declare (fixnum min-x min-y))
-		 (tk::draw-rectangle
-		  drawable
-		  (adjust-ink (decode-ink ink medium)
-			      medium
-			      (medium-line-style medium)
-			      min-x min-y)
-		  min-x min-y
-		  (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1))))
-		  (fast-abs (the fixnum (- (the fixnum y2) (the fixnum y1))))
-		  filled)))
-	      (t
-	       (port-draw-transformed-rectangle*
-		(port sheet) sheet medium x1 y1 x2 y2 filled)))))))
+	(assert (rectilinear-transformation-p transform))
+	(convert-to-device-coordinates transform
+				       x1 y1 x2 y2)
+	;; Clipping a rectangle is ridiculously easy.
+	(unless (valid-point-p x1 y1)
+	  (setq x1 (min (max -32000 (the fixnum x1)) 32000))
+	  (setq y1 (min (max -32000 (the fixnum y1)) 32000)))
+	(unless (valid-point-p x2 y2)
+	  (setq x2 (min (max -32000 (the fixnum x2)) 32000))
+	  (setq y2 (min (max -32000 (the fixnum y2)) 32000)))
+	(let ((min-x (min (the fixnum x1) (the fixnum x2)))
+	      (min-y (min (the fixnum y1) (the fixnum y2))))
+	  (declare (fixnum min-x min-y))
+	  (tk::draw-rectangle
+	   drawable
+	   (adjust-ink (decode-ink ink medium)
+		       medium
+		       (medium-line-style medium)
+		       min-x min-y)
+	   min-x min-y
+	   (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1))))
+	   (fast-abs (the fixnum (- (the fixnum y2) (the fixnum y1))))
+	   filled))))))
+
 
 (defmethod medium-draw-polygon* ((medium xt-medium) position-seq closed filled)
   (medium-draw-polygon-1 medium  position-seq closed filled))
@@ -1691,11 +1742,9 @@ and on color servers, unless using white or black")
 		       (elt points (+ 5 i))
 		       (elt points (+ 6 i))
 		       (elt points (+ 7 i))
-		       distance))
-      
-      (collect (elt points (1- last)) (elt points last)))
+		       distance)
+	(collect (elt points (+ 6 i)) (elt points (+ 7 i)))))
     
-    (print (length (cdr head)) excl:*initial-terminal-io*)
     (medium-draw-polygon-1 medium (cdr head) nil filled)))
 
 
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 7d4946dc..ab4bf422 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.59 92/11/19 14:25:34 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.60 92/11/20 08:47:01 cer Exp $
 
 (in-package :xm-silica)
 
@@ -1676,5 +1676,7 @@ the geometry of the children. Instead the parent has control. "))
      0					; time
      )))
 
-
-
+(defmethod clim-internals::port-move-frame ((port xt-port) frame x y)
+  (check-type x (signed-byte 16))
+  (check-type y (signed-byte 16))
+  (tk::set-values (sheet-direct-mirror (frame-top-level-sheet frame)) :x x :y y))
diff --git a/tk/graphics.lisp b/tk/graphics.lisp
index 3f8a18dc..60fbe3be 100644
--- a/tk/graphics.lisp
+++ b/tk/graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: graphics.lisp,v 1.9 92/06/16 19:10:49 cer Exp $
+;; $fiHeader: graphics.lisp,v 1.10 92/11/20 08:46:08 cer Exp $
 
 (in-package :tk)
 
@@ -32,10 +32,6 @@
    x
    y))
 
-(defmacro defstub (name arglist)
-  `(defun ,name ,arglist
-     (error "~S not done yet" ',name)))
-
 (defun draw-line (drawable gcontext x1 y1 x2 y2)
   (x11:xdrawline
    (object-display drawable)
@@ -117,6 +113,19 @@
      y
      width height)))
 
+
+(defun draw-rectangles (drawable gcontext rects nrects &optional
+				  fill-p)
+  (if fill-p
+      (x11::xfillrectangles
+       (object-display drawable)
+       drawable
+       gcontext rects nrects)
+    (x11::xdrawrectangles
+     (object-display drawable)
+     drawable
+     gcontext rects nrects)))
+
 #+ignore
 (defun text-extents (font sequence &key (start 0) end translate)
   (unless end (setq end (length sequence)))
diff --git a/tk/widget.lisp b/tk/widget.lisp
index eb8a8a46..7ad8a54b 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.24 92/08/18 17:53:46 cer Exp Locker: cer $
+;; $fiHeader: widget.lisp,v 1.25 92/09/08 10:34:07 cer Exp $
 
 (in-package :tk)
 
@@ -131,10 +131,6 @@
 		    (widget-display widget)
 		    :display (widget-display widget)))))))))
 
-(defun make-clx-window (display widget)
-  (let* ((window-id (xt_window widget)))
-    (make-clx-window-from-id display window-id)))
-
 (defun widget-class-of (x)
   (intern-widget-class
    (xt-widget-widget-class x)))
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index 6829c61e..aa243371 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-widgets.lisp,v 1.9 92/09/08 10:34:10 cer Exp $
+;; $fiHeader: xm-widgets.lisp,v 1.10 92/09/24 09:37:19 cer Exp $
 
 (in-package :tk)
 
@@ -39,6 +39,12 @@
   (remf args :name)
   (apply #'create-popup-shell name (class-of w) parent args))
 
+#+ignore
+(defmethod make-widget ((w override-shell) &rest args &key parent (name "") &allow-other-keys)
+  (remf args :parent)
+  (remf args :name)
+  (apply #'create-popup-shell name (class-of w) parent args))
+
 (defmethod make-widget ((w xm-menu-shell) &rest args &key parent (name "") &allow-other-keys)
   (remf args :parent)
   (remf args :name)
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index 6e607756..a5331fba 100644
--- a/tk/xt-defs.lisp
+++ b/tk/xt-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-defs.lisp,v 1.5 92/06/23 08:19:20 cer Exp $
+;; $fiHeader: xt-defs.lisp,v 1.6 92/11/20 08:46:24 cer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -162,3 +162,4 @@
 (def-c-type (xpoint-array :no-defuns) 1 x11::xpoint)
 (def-c-type (xsegment-array :no-defuns) 1 x11::xsegment)
 (def-c-type (xarc-array :no-defuns) 1 x11::xarc)
+(def-c-type (xrectangle-array :no-defuns) 1 x11::xrectangle)
diff --git a/utils/clos.lisp b/utils/clos.lisp
index b36df8b5..077d7830 100644
--- a/utils/clos.lisp
+++ b/utils/clos.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clos.lisp,v 1.7 92/07/01 15:45:28 cer Exp $
+;; $fiHeader: clos.lisp,v 1.8 92/11/06 19:04:58 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -101,51 +101,51 @@
 ;;; Dynamic Class Creation
 ;;;
 
-(defvar *dynamic-classes* (make-hash-table :test #'equal))
-
-(eval-when (compile load eval) (proclaim '(inline %make-standard-class)))
-(defun %make-standard-class (name supers)
-  
-  #+Lucid
-  ;; Jonl thinks this is okay, but I personally find it pretty gross. -- RR
-  (eval `(defclass ,name ,supers ()))
-  
-  #-Lucid
-  ;; by which we mean PCL and Genera CLOS, at this point
-  (let ((class (make-instance 'standard-class :direct-superclasses supers)))
-    ;; Note that this does NOT make it so that you can find this
-    ;; class with (find-class name)
-    (setf (class-name class) name)
-    class))
-
-(defun find-dynamic-class (name-fn &rest supers)
-  (declare (dynamic-extent supers))
-  (when supers
-    (do ((tail supers (cdr tail)))
-	((null tail))
-      (when (not #-PCL (typep (car tail) 'standard-class)
-		 #+PCL (classp (car tail)))
-	(setf (car tail) (find-class (car tail))))))
-      
-  (or (gethash supers *dynamic-classes*)
-      ;;
-      ;;  If there is no entry for a dynamic class with these supers
-      ;;  then we have to create one.  This involves creating the class,
-      ;;  setting its supers and adding the entry to *dynamic-classes*.
-      ;;  
-      (let ((supers (copy-list supers)))
-	(setf (gethash supers *dynamic-classes*)
-	      (%make-standard-class
-		(intern (funcall name-fn) (find-package :silica))
-		supers)))))
-
-(defun add-mixin (object mixin-class)
-  (let ((class (class-of object)))
-    (if (member mixin-class (class-precedence-list class) :test #'eq)
-	(error "The class of ~S already includes ~S." object mixin-class)
-	(change-class object
-		      (find-dynamic-class #'(lambda () "???")
-					  mixin-class class)))))
+;(defvar *dynamic-classes* (make-hash-table :test #'equal))
+;
+;(eval-when (compile load eval) (proclaim '(inline %make-standard-class)))
+;(defun %make-standard-class (name supers)
+;  
+;  #+Lucid
+;  ;; Jonl thinks this is okay, but I personally find it pretty gross. -- RR
+;  (eval `(defclass ,name ,supers ()))
+;  
+;  #-Lucid
+;  ;; by which we mean PCL and Genera CLOS, at this point
+;  (let ((class (make-instance 'standard-class :direct-superclasses supers)))
+;    ;; Note that this does NOT make it so that you can find this
+;    ;; class with (find-class name)
+;    (setf (class-name class) name)
+;    class))
+;
+;(defun find-dynamic-class (name-fn &rest supers)
+;  (declare (dynamic-extent supers))
+;  (when supers
+;    (do ((tail supers (cdr tail)))
+;	((null tail))
+;      (when (not #-PCL (typep (car tail) 'standard-class)
+;		 #+PCL (classp (car tail)))
+;	(setf (car tail) (find-class (car tail))))))
+;      
+;  (or (gethash supers *dynamic-classes*)
+;      ;;
+;      ;;  If there is no entry for a dynamic class with these supers
+;      ;;  then we have to create one.  This involves creating the class,
+;      ;;  setting its supers and adding the entry to *dynamic-classes*.
+;      ;;  
+;      (let ((supers (copy-list supers)))
+;	(setf (gethash supers *dynamic-classes*)
+;	      (%make-standard-class
+;		(intern (funcall name-fn) (find-package :silica))
+;		supers)))))
+;
+;(defun add-mixin (object mixin-class)
+;  (let ((class (class-of object)))
+;    (if (member mixin-class (class-precedence-list class) :test #'eq)
+;	(error "The class of ~S already includes ~S." object mixin-class)
+;	(change-class object
+;		      (find-dynamic-class #'(lambda () "???")
+;					  mixin-class class)))))
 
 ;;;
 ;;; DEFGENERIC ... because it isn't there.
diff --git a/utils/packages.lisp b/utils/packages.lisp
index eb73c1cc..7e886b2b 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.39 92/11/19 14:25:49 cer Exp $
+;; $fiHeader: packages.lisp,v 1.40 92/11/20 08:47:13 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -3593,3 +3593,12 @@
 ;; A package for casual use...
 (#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-user
   (:use clim-lisp clim))
+
+;;;; Nasty hack to improve debugability
+;;;; Dont need it right now.
+;#+allegro
+;(let ((package (find-package :compiler))
+;      (symbol (and package (intern :bad-to-tailpos package))))
+;  (when (boundp symbol)
+;    (dolist (sym '(clim:beep))
+;      (push sym (symbol-value symbol)))))
-- 
GitLab