diff --git a/ChangeLog.n b/ChangeLog.n
index baf56ffc69be95da426ebf3fb02b8db76073c124..55b2cdb183810e9a0f8fdf43f32d1239386218c8 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -10,6 +10,54 @@ Tests for new features:	<`no new features', `no tests for new features', or
 <standard changelog date stamp>
 	* <changes go here...>
 
+*******************************************************************************
+Fri May 30 17:49:18 PDT 1997  Tom McClure <tomj@romeo>
+
+	* aclpc/acl-medium.lisp
+		- ellipse drawing fixes
+	* clim/accept-values.lisp
+		- made default action (when you hit enter) work better
+	* clim/db-stream.lisp
+		- pointer-documentation pane now defaults to menu font
+	* clim/drag-and-drop.lisp
+		- returned multiple-window drag-and-drop functionality
+	* clim/input-editor-commands.lisp, clim/menus.lisp,
+	  silica/port.lisp, test/test-suite.lisp,
+	  utils/defun-utilities.lisp, utils/defun.lisp,
+	  utils/designs.lisp
+		- removed references to obsolete feature microsoft-32
+	* clim/menus.lisp, xm/xm-frames.lisp
+		- fixed *default-menu-text-style*
+	* clim/output-protocol.lisp
+		- fixed aclpc char v. character bug
+	* clim/output-protocol.lisp, clim/text-recording.lisp
+		- fixed text baseline calculations
+	* silica/db-scroll.lisp
+		- most recent text output wasn't resizing extent
+	* sys/compile.lisp, sys/load.lisp
+		- major housecleaning
+	* tk/gcontext.lisp, tk-silica/xt-graphics.lisp,
+	  utils/transformations.lisp
+		- optimized transform-position
+	* tk/image.lisp
+		- xpm pixmaps were being written out with huge chars
+	* xm/xm-gadgets.lisp
+		- added option abort-on-cancel-p to notify-user
+	* tk-silica/xt-silica.lisp
+		- gave clim fonts explicit iso8859-1 encoding
+	* utils/base-designs.lisp
+		- removed aclpc ink constant weirdness from nt
+	* utils/extended-regions.lisp
+		- added many missing region methods
+		- fixed bugs in map-over-polygon-xxx and
+		  region-intersection for lines
+	* utils/region-arithmetic.lisp
+		- made path/area stuff agree with spec
+		- small optimization in make-region-difference
+	* utils/regions.lisp
+		- bounding-rectangles of partial ellipses fixed
+
+
 *******************************************************************************
 Documentation changes:	none
 Tests for new features:	no new features
diff --git a/Makefile.sun4-svr4 b/Makefile.sun4-svr4
index 481c6cee93d71db62cb876159e947805bcd65f72..13c1070ae80b9849f977fefe0ade716a9bb4684d 100644
--- a/Makefile.sun4-svr4
+++ b/Makefile.sun4-svr4
@@ -1,9 +1,12 @@
-# $Header: /repo/cvs.copy/clim2/Makefile.sun4-svr4,v 1.13 1997/02/05 01:42:08 tomj Exp $
+# $Header: /repo/cvs.copy/clim2/Makefile.sun4-svr4,v 1.14 1997/05/31 01:00:23 tomj Exp $
 #
 #  Makefile.sun4-svr4 for CLIM 2.0
 #
 
 include Makefile.defs
+#CL_HOME=/fi/scm/4.3/sunos5/src
+CL=$(CL_HOME)/dcl
+CLIM_HOME=$(CL_HOME)
 
 Makefile=Makefile.sun4-svr4
 
diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp
index 2db9113d9c508e61fdc0555ba24a63cc38c723ea..e5645c001e43fd74dd462c67903ceed85b81ac4d 100644
--- a/aclpc/acl-medium.lisp
+++ b/aclpc/acl-medium.lisp
@@ -625,18 +625,18 @@ stipples are not supported yet."))
 		     ;; drawing a pie slice
 		     (win::pie
 		       dc left top right bottom
-		       (round (+ (* (cos end-angle) x-radius) center-x))
-		       (round (+ (* (sin end-angle) y-radius) center-y))
-		       (round (+ (* (cos start-angle) x-radius) center-x))
-		       (round (+ (* (sin start-angle) y-radius) center-y))))
+		       (round (+ center-x (* (cos start-angle) x-radius)))
+		       (round (- center-y (* (sin start-angle) y-radius)))
+		       (round (+ center-x (* (cos end-angle) x-radius)))
+		       (round (- center-y (* (sin end-angle) y-radius)))))
 		    (t
 		      ;; drawing an arc
 		      (win::arc
 			dc left top right bottom
-			(round (+ (* (cos end-angle) x-radius) center-x))
-			(round (+ (* (sin end-angle) y-radius) center-y))
-			(round (+ (* (cos start-angle) x-radius) center-x))
-			(round (+ (* (sin start-angle) y-radius) center-y)))))
+			(round (+ center-x (* (cos start-angle) x-radius)))
+			(round (- center-y (* (sin start-angle) y-radius)))
+			(round (+ center-x (* (cos end-angle) x-radius)))
+			(round (- center-y (* (sin end-angle) y-radius))))))
 	      )))))))
 
 (defmethod medium-draw-string* ((medium acl-medium)
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index ae349acc2e8fb9f26f43fac0851b5309fec7ccb8..648aa0a845e2ed446d7826ab078791e4ae2fc8bc 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/accept-values.lisp,v 1.80 1997/02/05 01:42:38 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/accept-values.lisp,v 1.81 1997/05/31 01:00:29 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -861,7 +861,7 @@
 (defmethod accept-values-query-edit-value ((query accept-values-query) stream &key modify)
   (with-slots (presentation-type value changed-p prompt presentation) query
     (let ((stream (encapsulating-stream-stream stream))
-          (*editting-field-p* t))
+          (*editting-field-p* stream))
       (with-stream-cursor-position-saved (stream)
         (multiple-value-bind (xoff yoff)
             (convert-from-relative-to-absolute-coordinates
@@ -970,10 +970,25 @@
             changed-p t))))
 
 (define-gesture-name :exit-dialog  :keyboard (:end))
-#+allegro
-(define-gesture-name :exit-dialog  :keyboard (:newline) :unique nil)
 (define-gesture-name :abort-dialog :keyboard (:abort))
 
+(define-gesture-name :default-dialog  :keyboard (:newline))
+
+;; com-default-avv gets run when the "default" gesture is activated. On
+;; Motif this is when the user hits "return". In most cases we don't need
+;; to do anything because the :default-button mechanism should cause the
+;; correct command to be run - but to maintain compatibility with
+;; non-gadget style dialogs we check for +textual-dialog-view+ and then "do
+;; the Symbolics thing". (cim/tomj 5/21/97)
+
+(define-accept-values-command (com-default-avv :keystroke :default-dialog) ()
+  (let ((frame *application-frame*))
+    (with-slots (stream) frame
+      (when (eq (stream-default-view stream)
+		+textual-dialog-view+)
+	(com-exit-avv)))))
+
+
 (define-accept-values-command (com-exit-avv :keystroke :exit-dialog) ()
   (let ((frame *application-frame*))
     (with-slots (stream) frame
@@ -1514,7 +1529,7 @@
 
 (defun handle-exit-box-callback (gadget)
   (if *editting-field-p*
-      (beep)
+      (beep *editting-field-p*)
     (let ((id (gadget-id gadget)))
       (case id
         (:exit (com-exit-avv))
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 3e329fb179ef94eab21ff7cb91f3eabacd7c59e7..6c09298c14c443d70706ec7facc1cc5b763c4043 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.64 1997/02/14 23:57:01 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.65 1997/05/31 01:00:29 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -372,11 +372,13 @@
 (defclass application-pane (clim-stream-pane) ())
 
 #-aclpc
-;; apparently aclpc needs to do this in silica/framem.lisp since it refers
-;; to the class in a note-frame-enabled method   -tjm 12Feb97
+;; apparently aclpc needs to do this in silica/framem.lisp instead since it
+;; refers to the class in a note-frame-enabled method -tjm 12Feb97
 (defclass accept-values-pane (clim-stream-pane) ())
 
-(defclass pointer-documentation-pane (clim-stream-pane) ())
+(defclass pointer-documentation-pane (clim-stream-pane) ()
+  (:default-initargs
+      :text-style *default-menu-text-style*))
 
 (defclass title-pane (clim-stream-pane)
     ((display-string :initform nil :initarg :display-string)))
diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp
index 2375e3ee2dbc57af272d7a13f7392ee332892e10..9ec58a4d7aed9bf9e31d1bac43b1dadbce13c314 100644
--- a/clim/drag-and-drop.lisp
+++ b/clim/drag-and-drop.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/drag-and-drop.lisp,v 1.15 1997/02/07 00:20:51 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/drag-and-drop.lisp,v 1.16 1997/05/31 01:00:29 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -154,9 +154,9 @@
 		:move))
 	   (finish-on-release
 	    (and translators (presentation-translator-finish-on-release (first translators))))
-	   ;;--- needed this when we were calling (setf pointer-cursor)
+	   ;;--- spr15619: needed this when we were calling (setf pointer-cursor)
 	   ;;--- to change the mouse pointer to :move during the drag;
-	   ;;--- now we use sheet-pointer-cursor
+	   ;;--- now we use sheet-pointer-cursor.
 	   #+ignore (pointer (port-pointer (port window)))
 	   #+ignore (old-pointer-cursor (pointer-cursor pointer))
 	   (initial-x x)
@@ -195,17 +195,18 @@
 	;;--- when drop initiated an accepting-values, (setf pointer-cursor)
 	;;--- was losing, ie changing the cursor back to default on the wrong frame
 	(letf-globally ((#+ignore (pointer-cursor-override pointer)
-				  ;; why doesn't this work?
-				  #+ignore (sheet-pointer-cursor window)
-				  ;; calling sheet-pointer-cursor on the
-				  ;; top-level sheet is not quite right,
-				  ;; since we only want to change this for
-				  ;; the appropriate pane, not the whole
-				  ;; frame, but this is better than before
-				  ;;           1-24-97 tjm (w/colin) for spr15619
-				  #-ignore (sheet-pointer-cursor 
-					    (frame-top-level-sheet frame))
-				  pointer-cursor))
+			 ;; why doesn't this work?
+			 #+ignore (sheet-pointer-cursor window)
+			 ;; calling sheet-pointer-cursor on the top-level
+			 ;; sheet is not quite right, since we only want to
+			 ;; change this for the appropriate pane, not the
+			 ;; whole frame, but this at least ensures that the
+			 ;; pointer cursor will always revert to its
+			 ;; previous shape.
+			 ;;       1-24-97 tjm (w/colin) for spr15619
+			 #-ignore (sheet-pointer-cursor 
+				   (frame-top-level-sheet frame))
+			 pointer-cursor))
 	  #+ignore (setf (pointer-cursor pointer) pointer-cursor)
 	  (macrolet ((feedback (window x y state)
 		       `(funcall feedback frame from-presentation ,window
@@ -215,8 +216,13 @@
 				   (output-recording-stream-p ,window))
 			  (funcall highlighting frame ,presentation ,window ,state))))
 	    (block drag-presentation
+	      ;; :multiple-window t below was changed by colin (to nil) in
+	      ;; post-4.3 sources, since he had promised this to a customer
+	      ;; as a fix for something (spr?) but this breaks
+	      ;; functionality which is needed by other customers.
+	      ;;  cf spr15818    7feb97 --tjm 
 	      (tracking-pointer (window :context-type `((or ,@destination-types))
-					:multiple-window nil :highlight nil)
+					:multiple-window t :highlight nil)
 		(:presentation-button-press (presentation event)
 		 (unless finish-on-release
 		   (setq destination-event event
@@ -275,7 +281,7 @@
 	    (highlight destination last-window :unhighlight)
 	    (when last-x
 	      (feedback last-window last-x last-y :unhighlight)))
-	  ;; see above
+	  ;; see above "now we use ..."
 	  #+ignore (setf (pointer-cursor pointer) old-pointer-cursor))
 	;; The user has put down the presentation, figure out what to do
 	;;--- What if there is more than one translator?
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 61b2c7774c404deb2c173c82967b0580e6780f9a..3415bd9b622f5de42d973eb2e0bc83fc917929af 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.84 1997/02/05 01:43:30 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.85 1997/05/31 01:00:30 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -1037,6 +1037,7 @@
   ;; First display all the :accept-values panes, then display the rest.
   ;; We do this to ensure that all side-effects from :accept-values panes
   ;; have taken place.
+  (when *frame-layout-changing-p* (setq force-p t))
   (map-over-sheets #'(lambda (sheet)
                        (when (typep sheet 'accept-values-pane)
                          (redisplay-frame-pane frame sheet :force-p force-p)))
@@ -1063,8 +1064,6 @@
     (with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
       (loop
         (with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
-          (when *frame-layout-changing-p*
-            (setq force-p t))
           (unless *sizing-application-frame*
             (unless (member pane (slot-value frame 'initialized-panes))
               (setq force-p t)
diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp
index 4ace0168d55fa909d6efcb366b7d703b61b5499b..e7866f0dda5ca916691afb094a8920d5f6c1e29e 100644
--- a/clim/input-editor-commands.lisp
+++ b/clim/input-editor-commands.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/input-editor-commands.lisp,v 1.33 1997/02/07 00:20:53 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/input-editor-commands.lisp,v 1.34 1997/05/31 01:00:31 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -1278,13 +1278,13 @@ This may confused the input editor" gestures))
   (:ie-scroll-right            :scroll :super :meta)
   (:ie-input-editor-help    :help :control))
 
-#-(or (and (not microsoft-32) Allegro) Lucid)
+#-(or (and (not acl86win32) Allegro) Lucid)
 (define-input-editor-gestures
   (:ie-show-arglist            :a   :control :shift)
   (:ie-show-value            :v   :control :shift)
   (:ie-show-documentation   :d   :control :shift))
 
-#+(or (and (not microsoft-32) Allegro) Lucid)
+#+(or (and (not acl86win32) Allegro) Lucid)
 (define-input-editor-gestures
   (:ie-show-arglist            :a   :meta :shift)
   (:ie-show-value            :v   :meta :shift)
@@ -1391,7 +1391,7 @@ This may confused the input editor" gestures))
 (assign-input-editor-key-bindings
   (com-ie-swap-point-and-mark  (:ie-prefix-2 (:x :control))))
 
-#+(or (and Allegro (not microsoft-32)) Lucid)
+#+(or (and Allegro (not acl86win32)) Lucid)
 (assign-input-editor-key-bindings
   com-ie-forward-word               (:ie-prefix-1 :f)
   com-ie-backward-word               (:ie-prefix-1 :b)
@@ -1469,7 +1469,7 @@ This may confused the input editor" gestures))
 
 )        ;#+Genera
 
-#+(and Allegro (not microsoft-32))
+#+(and Allegro (not acl86win32))
 (progn
   (define-input-editor-gestures
       (:left-arrow :left-arrow)
diff --git a/clim/menus.lisp b/clim/menus.lisp
index 60b87fd61c70a4c9b4639103d130d36e7b6f6064..5e4711b79f26c69f9881998f7187bf202440d879 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/menus.lisp,v 1.50 1997/02/05 01:44:15 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/menus.lisp,v 1.51 1997/05/31 01:00:31 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -9,8 +9,10 @@
 
 (defvar *abort-menus-when-buried* t)
 
-(defparameter *default-menu-text-style* (make-text-style :fix :roman :normal))
-(defparameter *default-menu-label-text-style* (make-text-style :fix :italic :normal))
+(defparameter *default-menu-text-style* (make-text-style :sans-serif :roman :small))
+(defparameter *default-menu-label-text-style*
+    (merge-text-styles (make-text-style nil :italic nil)
+		       *default-menu-text-style*))
 
 (define-application-frame menu-frame ()
   (menu
@@ -309,7 +311,7 @@
                                            (medium-background associated-window))
               (medium-foreground menu) (or foreground
                                            (medium-foreground associated-window)))
-        (with-text-style (menu text-style)
+        (with-text-style (menu (or text-style *default-menu-text-style*))
           (with-end-of-line-action (menu :allow)
             (loop
               (multiple-value-bind (item gesture)
@@ -462,13 +464,13 @@
                            ;; on nt there is no server round trip so
                            ;; it's safe to check window-visibility
                            ;; (cim 9/16/96)
-                           (or #-(and Allegro (not microsoft-32)) 
+                           (or #-(and Allegro (not acl86win32))
                                (and *abort-menus-when-buried*
                                     (not (window-visibility menu)))
                                (pointer-motion-pending menu)))
                          (input-wait-handler (menu)
                            ;; Abort if the menu becomes buried
-                           #-(and Allegro (not microsoft-32))
+                           #-(and Allegro (not acl86win32))
                            (when (and *abort-menus-when-buried*
                                       (not (window-visibility menu)))
                              (return-from menu-choose-from-drawer nil))
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index aea7c11e904194b04ec8ba81cd272e4a62bb839d..78839555554e23f010ba18cfae731f3a82d94118 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/output-protocol.lisp,v 1.44 1997/02/05 01:44:19 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/output-protocol.lisp,v 1.45 1997/05/31 01:00:31 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -433,7 +433,7 @@
   (let ((text-style (merge-text-styles '(nil nil :very-small) 
                                        *default-text-style*))
         (ink (medium-ink stream))
-        (name (char-name character)))
+        (name (char-name #-aclpc character #+aclpc char)))
     (setq name (if name
                    (string-upcase name)
                    #+Genera (format nil "~O" (char-code character))
@@ -516,7 +516,8 @@
     (declare (type coordinate cursor-x cursor-y baseline height max-x))
     (unless (or draw-p record-p)
       (return-from stream-write-string string))        ;No deeds to do
-    (let* ((medium (sheet-medium stream)))
+    (let* ((medium (sheet-medium stream))
+	   (baseline-diff nil))
       (with-cursor-state (stream nil)
         (loop
           (multiple-value-bind (write-char next-char-index
@@ -525,26 +526,26 @@
                 stream medium string start end style cursor-x max-x glyph-buffer)
             (declare (type coordinate new-cursor-x new-baseline new-height))
             (declare (ignore font))
+	    (setf baseline-diff (max 0 (- baseline new-baseline)))
             (when record-p
               (stream-add-string-output
                 stream string start next-char-index style
                 (- new-cursor-x cursor-x) new-height new-baseline))
             (when draw-p
               (when (< baseline new-baseline)
-                (stream-note-line-height-change stream baseline new-baseline height
-                                                cursor-x cursor-y)
-                (setf baseline new-baseline))
+		(stream-note-line-height-change stream baseline new-baseline height
+						cursor-x cursor-y))
               (let ((amount (the fixnum (- next-char-index start))))
                 (unless (zerop amount)
                   ;;--- Need DRAW-GLYPHS, which will take a port-specific font
                   ;;--- object, as well as the :INK option.
                   (with-identity-transformation (medium)
                     (draw-text* medium string
-                                cursor-x (+ cursor-y (- baseline new-baseline))
+                                cursor-x (+ cursor-y baseline-diff)
                                 :text-style style
                                 :start start :end next-char-index
                                 :align-x :left :align-y :top)))))
-            (setf baseline (max baseline new-baseline)
+            (setf baseline (if (zerop baseline) new-baseline baseline)
                   height (max height new-height)
                   cursor-x new-cursor-x)
             (when (>= next-char-index end)
diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp
index 4e18bca3ed51778ccdc972f332b0ae235dcf8486..55a46607bf7ad573b7109ecfac4dd20b221df885 100644
--- a/clim/text-recording.lisp
+++ b/clim/text-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/clim/text-recording.lisp,v 1.21 1997/02/05 01:45:12 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/clim/text-recording.lisp,v 1.22 1997/05/31 01:00:32 tomj Exp $
 
 (in-package :clim-internals)
 
@@ -404,20 +404,22 @@
         (return-from get-text-output-record record)))
     (let* ((string (make-array 16 :element-type #+ANSI-90 'character #-ANSI-90 'string-char
                                   :fill-pointer 0 :adjustable t))
-           (record (if (not (eq style default-style))
-                       (make-styled-text-output-record 
-                         string (medium-ink stream) (medium-clipping-region stream))
-                       (make-standard-text-output-record
-                         string (medium-ink stream) (medium-clipping-region stream)))))
+           (record (if (eq style default-style)
+		     (make-standard-text-output-record
+		      string (medium-ink stream) (medium-clipping-region stream))
+		     (make-styled-text-output-record 
+		      string (medium-ink stream) (medium-clipping-region stream)))))
       (setf (stream-text-output-record stream) record)
-      (multiple-value-bind (abs-x abs-y)
-          (point-position
-            (stream-output-history-position stream))
-        (declare (type coordinate abs-x abs-y))
-        (multiple-value-bind (cx cy) (stream-cursor-position stream)
-          (declare (type coordinate cx cy))
-          (output-record-set-start-cursor-position
-            record (- cx abs-x) (- cy abs-y))))
+      (let ((baseline-diff (min 0 (- (text-style-ascent style (sheet-medium stream))
+				     (stream-baseline stream)))))
+	(multiple-value-bind (abs-x abs-y)
+	    (point-position
+	     (stream-output-history-position stream))
+	  (declare (type coordinate abs-x abs-y))
+	  (multiple-value-bind (cx cy) (stream-cursor-position stream)
+	    (declare (type coordinate cx cy))
+	    (output-record-set-start-cursor-position
+	     record (- cx abs-x) (- cy abs-y baseline-diff)))))
       ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing
       ;; in the history until then.  This should save an extra recompute-extent call
       ;; (one in here, one when the string is added).
diff --git a/make-symbolic-links.sh b/make-symbolic-links.sh
index a987722449bcd5c3877bddb7b309bced80e2cec8..22a6bd5a3177557684d46e39818c3ee8febe7da0 100644
--- a/make-symbolic-links.sh
+++ b/make-symbolic-links.sh
@@ -1,6 +1,6 @@
 #!/bin/sh
 #
-# $Header: /repo/cvs.copy/clim2/Attic/make-symbolic-links.sh,v 1.5 1997/05/24 03:52:34 tomj Exp $
+# $Header: /repo/cvs.copy/clim2/Attic/make-symbolic-links.sh,v 1.6 1997/05/31 01:00:23 tomj Exp $
 #
 # make a tree of links
 #
@@ -8,7 +8,7 @@
 # 'original' must be changed whenever the source tree is moved
 # It must be a pathname accessible from any machine on the net
 
-original=/net/romeo/home1/tomj/clim2-nt/clim2
+original=/net/romeo/home1/tomj/clim2
 linkdir=$1
 
 if test -z "$linkdir"; then
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index 13e6ec800f0cb151328eb18d630866b6bee5655c..3617e7c3827820adcce79eb364436f6ac2c22fa8 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.54 1997/02/05 01:50:50 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.55 1997/05/31 01:00:34 tomj Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -106,6 +106,9 @@
           hscroll-bar hscroll-bar-enabled-p
           vscroll-bar vscroll-bar-enabled-p t))
 
+      ;; tjm 15Mar97 otherwise most recent text-output-record not
+      ;; considered (spr15933)
+      (stream-force-output (sheet-child viewport))
       (with-bounding-rectangle* (left top right bottom)
           (viewport-contents-extent viewport)
         (with-bounding-rectangle* (vleft vtop vright vbottom)
diff --git a/silica/port.lisp b/silica/port.lisp
index 01d5b809518ed18e2fe28ec3c4c5e4eb8965af5f..48ac735c0d75abc7be3232e21dbf8aa0c312d50c 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/silica/port.lisp,v 1.37 1997/02/05 01:51:15 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/silica/port.lisp,v 1.38 1997/05/31 01:00:36 tomj Exp $
 
 (in-package :silica)
 
@@ -10,7 +10,7 @@
 
 ;; Ports and grafts
 
-(defvar *default-server-path* #+(and Allegro (not microsoft-32)) '(:motif)
+(defvar *default-server-path* #+(and Allegro (not acl86win32)) '(:motif)
                               #+Lucid '(:clx)
                               #+Genera `(:genera)
                               #+Cloe-Runtime `(:cloe)
diff --git a/sys/compile.lisp b/sys/compile.lisp
index 3e51dc116fc75d023f20b64602f62e25d48fc9d0..951dc85b17b7304b0680f8a3200edcb128f38332 100644
--- a/sys/compile.lisp
+++ b/sys/compile.lisp
@@ -1,6 +1,6 @@
 (in-package :user)
 
-#+(and Allegro microsoft-32)
+#+(and Allegro (or microsoft-32 mswindows))
 (eval-when (compile load eval) (push :acl86win32 *features*))
 
 #+acl86win32
diff --git a/sys/load.lisp b/sys/load.lisp
index 8ceff085b47587d3070093aca948eb7b322045c1..f0e330d55a3e9f650f9bdc71716f5f824075b01e 100644
--- a/sys/load.lisp
+++ b/sys/load.lisp
@@ -1,6 +1,6 @@
 (in-package :user)
 
-#+(and Allegro microsoft-32)
+#+(and Allegro (or microsoft-32 mswindows))
 (eval-when (compile load eval) (push :acl86win32 *features*))
 
 #+acl86win32
@@ -42,23 +42,22 @@
 
 (let (#+acl86win32 (excl::*enable-package-locked-errors* nil))
 
+(load (climpath "aclpc\\sysdcl.lisp"))
+
 #+aclpc (clim-defsystem:load-system "aclpc-clim")
 #+acl86win32 (load-system 'aclnt-clim)
 
-;;; to make a non-demo-loaded version, comment the following
-#+aclpc (load (climpath "test\\test-suite.fsl"))
-#+acl86win32 (load (climpath "test\\test-suite.fasl"))
-
-#+aclpc (load (climpath "demo\\sysdcl-pc.lisp"))
-#+acl86win32 (load (climpath "demo\\sysdcl.lisp"))
+(unless (and (boundp *no-clim-demos*) *no-clim-demos*)
+  #+aclpc (load (climpath "test\\test-suite.fsl"))
+  #+acl86win32 (load (climpath "test\\test-suite.fasl"))
+  #+aclpc (load (climpath "demo\\sysdcl-pc.lisp"))
+  #+acl86win32 (load (climpath "demo\\sysdcl.lisp"))
+  #+aclpc (clim-defsystem:load-system "clim-demo")
+  #+acl86win32 (load-system 'clim-demo))
 
 ) ;; end let #+acl86win32 (excl::*enable-package-locked-errors* nil)
 
-#-acl86win32
-(clim-defsystem:load-system "clim-demo")
-
 ;;; Remove this feature for the final world.
-
 #+acl86win32-uses-clim-defsystem
 (setq *features* (delete :defsystem *features*))
 
diff --git a/sys/sysdcl-pc.lisp b/sys/sysdcl-pc.lisp
index 973fbef450b8452988c3338259fe343116712c6b..6975f2b888f55f6b60c6a27e6d58a398b1c79922 100644
--- a/sys/sysdcl-pc.lisp
+++ b/sys/sysdcl-pc.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/sys/sysdcl-pc.lisp,v 1.3 1997/05/24 03:52:47 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/sys/sysdcl-pc.lisp,v 1.4 1997/05/31 01:00:38 tomj Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -208,12 +208,9 @@
   ("formatted-output-defs")
   ("recording-protocol" ;  :short-name "rprotoco"
    :load-before-compile ("recording-defs"))
-  ("text-recording"
-   :load-before-compile ("recording-protocol"))
-  ("graphics-recording"
-   :load-before-compile ("recording-protocol"))
-  ("design-recording"
-   :load-before-compile ("graphics-recording"))
+  ("text-recording" :load-before-compile ("recording-protocol"))
+  ("graphics-recording" :load-before-compile ("recording-protocol"))
+  ("design-recording" :load-before-compile ("graphics-recording"))
 
   ;; Input editing
   ("interactive-protocol" ;  :short-name "iprotoco"
@@ -231,75 +228,46 @@
   ("pixmap-streams")
 
   ;; Presentation types
-  ("ptypes1"
-   :load-before-compile ("clim-defs"))
-  ("completer"
-   :load-before-compile ("ptypes1"))
-  ("presentations"
-   :load-before-compile ("ptypes1"))
-  ("translators"
-   :load-before-compile ("presentations"))
-  ("histories"
-   :load-before-compile ("presentations"))
-  ("ptypes2"
-   :load-before-compile ("translators"))
-  ("standard-types"
-   :load-before-compile ("ptypes2"))
-  ("excl-presentations"
-   :load-before-compile ("presentations")
-   :features Allegro)
+  ("ptypes1" :load-before-compile ("clim-defs"))
+  ("completer" :load-before-compile ("ptypes1"))
+  ("presentations" :load-before-compile ("ptypes1"))
+  ("translators" :load-before-compile ("presentations"))
+  ("histories" :load-before-compile ("presentations"))
+  ("ptypes2" :load-before-compile ("translators"))
+  ("standard-types" :load-before-compile ("ptypes2"))
+  ("excl-presentations" :load-before-compile ("presentations") :features Allegro)
 
   ;; Formatted output
-  ("table-formatting"
-   :load-before-compile ("clim-defs" "incremental-redisplay"))
-  ("graph-formatting"
-   :load-before-compile ("clim-defs" "incremental-redisplay"))
-  ("surround-output" 
-   :load-before-compile ("clim-defs" "incremental-redisplay"))
-  ("text-formatting"
-   :load-before-compile ("clim-defs" "incremental-redisplay"))
+  ("table-formatting" :load-before-compile ("clim-defs" "incremental-redisplay"))
+  ("graph-formatting" :load-before-compile ("clim-defs" "incremental-redisplay"))
+  ("surround-output" :load-before-compile ("clim-defs" "incremental-redisplay"))
+  ("text-formatting" :load-before-compile ("clim-defs" "incremental-redisplay"))
 
   ;; Pointer tracking
   ("tracking-pointer")
-  ("dragging-output"
-   :load-before-compile ("tracking-pointer"))
+  ("dragging-output" :load-before-compile ("tracking-pointer"))
 
   ;; Gadgets
   ("db-stream")
   ("gadget-output")
 
   ;; Application building substrate
-  ("accept"
-   :load-before-compile ("clim-defs" "ptypes2"))
-  ("present"
-   :load-before-compile ("clim-defs" "ptypes2"))
-  ("command"
-   :load-before-compile ("clim-defs" "ptypes2"))
-  ("command-processor"
-   :load-before-compile ("clim-defs" "command"))
-  ("basic-translators"
-   :load-before-compile ("ptypes2" "command"))
-  ("frames" 
-   :load-before-compile ("clim-defs" "command-processor"))
+  ("accept" :load-before-compile ("clim-defs" "ptypes2"))
+  ("present" :load-before-compile ("clim-defs" "ptypes2"))
+  ("command" :load-before-compile ("clim-defs" "ptypes2"))
+  ("command-processor" :load-before-compile ("clim-defs" "command"))
+  ("basic-translators" :load-before-compile ("ptypes2" "command"))
+  ("frames" :load-before-compile ("clim-defs" "command-processor"))
   ("panes" :load-before-compile ("frames"))
-  ("default-frame" 
-   :load-before-compile ("frames"))
-  ("activities" 
-   :load-before-compile ("frames"))
-  ("db-menu"
-   :load-before-compile ("frames"))
-  ("db-list"
-   :load-before-compile ("db-menu"))
-  ("db-text"
-   :load-before-compile ("frames"))
-  ("noting-progress"
-   :load-before-compile ("frames"))
-  ("menus"
-   :load-before-compile ("defresource" "clim-defs"))
-  ("accept-values"
-   :load-before-compile ("clim-defs" "incremental-redisplay" "frames"))
-  ("drag-and-drop" 
-   :load-before-compile ("frames"))
+  ("default-frame" :load-before-compile ("frames"))
+  ("activities" :load-before-compile ("frames"))
+  ("db-menu" :load-before-compile ("frames"))
+  ("db-list" :load-before-compile ("db-menu"))
+  ("db-text" :load-before-compile ("frames"))
+  ("noting-progress" :load-before-compile ("frames"))
+  ("menus" :load-before-compile ("defresource" "clim-defs"))
+  ("accept-values" :load-before-compile ("clim-defs" "incremental-redisplay" "frames"))
+  ("drag-and-drop" :load-before-compile ("frames"))
   ("item-list-manager")
 
   ;; Bootstrap everything
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index af8fbe84a146fdb2a62abb5fd1d61f74cbe30aee..9cdf688a9385a3eae7f9be522752b29971deb334 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/sys/sysdcl.lisp,v 1.54 1997/05/24 03:52:47 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/sys/sysdcl.lisp,v 1.55 1997/05/31 01:00:39 tomj Exp $
 
 (in-package :cl-user)
 
@@ -182,6 +182,10 @@
    "gadgets"
    "db-border"
    "db-scroll"
+   #+acl86win32 "scroll-pane"
+   #+acl86win32 "db-button"
+   #+acl86win32 "db-label"
+   #+acl86win32 ("db-slider" (:load-before-compile "db-border"))
    ))
 
 (defsystem clim-standalone
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index c6f3aacff202409366db43c18529a247a19a5887..b13fdd8c4eec5e0f1e82d5c825c38e514c774a64 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/test/test-suite.lisp,v 1.80 1997/02/05 01:52:20 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/test/test-suite.lisp,v 1.81 1997/05/31 01:00:40 tomj Exp $
 
 (in-package :clim-user)
 
@@ -1941,10 +1941,11 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 
 (define-drag-and-drop-translator test-suite-dnd-blank
-    (drag-source string drop-target presentations
-                 :drag-documentation "Don't drop now"
+    (integer string blank-area presentations
+                 :drag-documentation ((object destination-object stream)
+                                      (format stream "Hello ~s on ~s" object destination-object))
                  :pointer-documentation "bar bar"
-                 :documentation "Documentatoin")
+                 :documentation "Documentation")
   ()
   (format nil "Dragged to blank area"))
 
@@ -2206,7 +2207,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 
 (define-test (gadgets-dialog menus-and-dialogs) (stream)
-  "An own-window ACCEPTING-VALUES dialog that has lots of gadgets inside of it."
+  "An ACCEPTING-VALUES dialog that has lots of gadgets inside of it."
   (gadgets-dialog-internal stream nil))
 
 (define-test (ozone-dialog menus-and-dialogs) (stream)
@@ -3400,9 +3401,8 @@ Luke Luck licks the lakes Luke's duck likes."))
 (define-benchmark (simple-menu-choose :iterations 10) (stream)
   "Pop up a simple menu of colors"
   (without-clim-input
-    (if #+(allegro (not microsoft-32))
-                (typep (port stream) 'xm-silica::xt-port)
-            #-(allegro (not microsoft-32)) nil
+   (if #-(or aclpc acl86win32) (typep (port stream) 'xm-silica::xt-port)
+       #+(or aclpc acl86win32) nil
         (sleep 0.1) ;; Avoid division by zero!
         (menu-choose '(("Red" :value +red+)
                        ("Green" :value +green+)
@@ -3419,9 +3419,8 @@ Luke Luck licks the lakes Luke's duck likes."))
 (define-benchmark (cached-menu-choose :iterations 10) (stream)
   "Pop up a cached menu of colors"
   (without-clim-input
-    (if #+(and allegro (not microsoft-32))
-                (typep (port stream) 'xm-silica::xt-port)
-            #-(and allegro (not microsoft-32)) nil
+   (if #-(or aclpc acl86win32) (typep (port stream) 'xm-silica::xt-port)
+       #+(or aclpc acl86win32) nil
         (sleep 0.1) ;; Avoid division by zero!
         (menu-choose '(("Red" :value +red+)
                        ("Green" :value +green+)
@@ -3528,7 +3527,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 (define-application-frame clim-tests ()
     ((history-class :initarg :history-class
-                    :initform 'standard-tree-output-history
+                    :initform 'standard-sequence-output-history
                     :reader clim-tests-history-class))
   (:command-table (clim-tests
                    :inherit-from (graphics
diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
index 0097bc431eab60008a3cd09a627e686cbd816f84..6f43e8818b6146bcc65ea31af3d31cb993f67734 100644
--- a/tk-silica/image.lisp
+++ b/tk-silica/image.lisp
@@ -19,7 +19,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk-silica/image.lisp,v 1.21 1997/02/05 01:53:47 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk-silica/image.lisp,v 1.22 1997/05/31 01:00:45 tomj Exp $
 
 (in-package :xm-silica)
 
@@ -267,7 +267,11 @@
 	     (if palette
 		 (find-named-color x palette)
 	       x)))
-      (let* ((codes (make-array (expt char-code-limit chars-per-pixel)))
+      ;;--- char-code-limit is 2^16, but the chars in xpm palettes will
+      ;;--- always be printable ascii.  use of char-code-limit here was
+      ;;--- creating prohibitively large arrays.  -tjm 3Mar97
+      (let* ((xpm-char-code-limit 256)
+	     (codes (make-array (expt xpm-char-code-limit chars-per-pixel)))
 	     (designs
 	      (do ((color-specs (read-strings) (cddr color-specs))
 		   (designs nil)
@@ -278,7 +282,7 @@
 		      (key 0))
 		  (dotimes (i chars-per-pixel)
 		    (setq key (+ (char-code (schar code i))
-				 (* key char-code-limit))))
+				 (* key xpm-char-code-limit))))
 		  (setf (svref codes key) index)
 		  (push color designs))))
 	     (array (make-array (list height width)))
@@ -293,7 +297,7 @@
 	       (let ((key 0))
 		 (dotimes (i chars-per-pixel)
 		   (setq key (+ (char-code (schar row index))
-				(* key char-code-limit)))
+				(* key xpm-char-code-limit)))
 		   (incf index))
 		 (setf (aref array i j) (svref codes key)))))
 	   (incf i)))
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index ecc2b9c5b60a8905ee7e884db51a4347b9656401..98ca7868e79c434cb88db11411bf22cc0e6fe0fc 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-frames.lisp,v 1.74 1997/02/05 01:54:00 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-frames.lisp,v 1.75 1997/05/31 01:00:45 tomj Exp $
 
 (in-package :xm-silica)
 
@@ -144,7 +144,9 @@
 	  #+ignore (remove-keywords
 		    (find-widget-resource-initargs-for-sheet port sheet)
 		    '(:font-list)))
-	 (menu-text-style (pane-text-style sheet))
+	 ;; menu-text-style used to be (pane-text-style sheet)
+	 ;; changed 28May97 -tjm
+	 (menu-text-style clim-internals::*default-menu-text-style*)
 	 (frame (pane-frame sheet))
 	 (top-command-table (or (menu-bar-command-table sheet)
 				(frame-command-table frame)))
@@ -377,7 +379,9 @@
 		     port associated-window
 		     :foreground foreground :background background)
 		    '(:font-list)))
-	 (default-text-style (sheet-text-style port associated-window))
+	 ;; default-text-style used to be (sheet-text-style port associated-window)
+	 ;; changed 28May97 -tjm
+	 (default-text-style clim-internals::*default-menu-text-style*)
 	 (menu-text-style (if text-style
 			      (merge-text-styles text-style
 						 default-text-style)
@@ -409,7 +413,8 @@
 		      initargs)))
 
     (when label
-      (let ((title (if (atom label) label (car label))))
+      (let ((title (if (atom label) label (car label)))
+	    (menu-text-style clim-internals::*default-menu-label-text-style*))
 	(check-type title string)
 	(destructuring-bind (&key text-style) (and (listp label) (cdr label))
 	  (apply #'make-instance 'xt::xm-label
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 5f8915be495fab405116a788a34a766485dcdb9b..319f0410b1a8acb2aa523f426b3d19c111425228 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -17,7 +17,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-gadgets.lisp,v 1.95 1997/02/05 01:54:03 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-gadgets.lisp,v 1.96 1997/05/31 01:00:46 tomj Exp $
 
 (in-package :xm-silica)
 
@@ -1562,7 +1562,8 @@
 					 :help))
                                       (name :notify-user)
 				      x-position
-				      y-position)
+				      y-position
+				      (abort-on-cancel-p nil))
   (let* ((initargs (find-widget-resource-initargs-for-sheet
 		    (port framem) associated-window
 		    :foreground foreground :background background
@@ -1620,7 +1621,9 @@
 		   #'(lambda () (or result (not (tk::is-managed-p dialog))))
 		   "Waiting for dialog")))
 	    (tk::destroy-widget dialog))
-	  (car result))))))
+	  (or (car result)
+	      (and abort-on-cancel-p
+		   (abort))))))))
 
 (defun process-exit-boxes (framem
 			   associated-window
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index ab9cf299976c975cbd88f19ddded9f469db7ef86..693266225b75440b1d3f835d8ffc088dc776e11e 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -19,7 +19,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.93 1997/02/05 01:54:14 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.94 1997/05/31 01:00:46 tomj Exp $
 
 (in-package :tk-silica)
 
@@ -504,22 +504,11 @@
 		       device-clip-region-tick)
 		   (null ink-clip-region))
 	(setf (tk::gcontext-clip-mask gc)
-	  (macrolet ((region-rectangle (region)
-		       `(with-bounding-rectangle* (left top right bottom) ,region
-		          (list (fix-coordinate left) (fix-coordinate top)
-				(fix-coordinate (- right left))
-				(fix-coordinate (- bottom top))))))
-	    (etypecase device-clip-region
-	      (everywhere :none)
-	      (nowhere nil)
-	      (standard-rectangle-set
-	       (let ((regions (region-set-regions device-clip-region))
-		     (rectangles nil))
-		 (dolist (region regions)
-		   (push (region-rectangle region) rectangles))
-		 rectangles))
-	      (standard-bounding-rectangle
-	       (list (region-rectangle device-clip-region))))))
+	  (etypecase device-clip-region
+	    (everywhere :none)
+	    (nowhere nil)
+	    (standard-rectangle-set device-clip-region)
+	    (standard-bounding-rectangle device-clip-region)))
 	(setf (ink-gcontext-last-clip-region-tick gc) device-clip-region-tick))))
 
   ;; tile and stipple origin
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 88c3311d04e212b1df112b3186a0019b7fcd2989..fa0dda01e81c97921d1cc8e9623163c18b95a0d2 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -19,7 +19,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-silica.lisp,v 1.106 1997/02/07 00:21:04 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-silica.lisp,v 1.107 1997/05/31 01:00:47 tomj Exp $
 
 (in-package :xm-silica)
 
@@ -163,10 +163,10 @@
     `(
       ;; ascii
       (0 "fixed"
-	 (:fix "-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
-	 (:sans-serif "-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*")
-	 (:serif "-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*"
-		 "-*-times-*-*-*-*-*-*-*-*-*-*-*-*"))
+	 (:fix "-*-courier-*-*-*-*-*-*-*-*-*-*-iso8859-1")
+	 (:sans-serif "-*-helvetica-*-*-*-*-*-*-*-*-*-*-iso8859-1")
+	 (:serif "-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-iso8859-1"
+		 "-*-times-*-*-*-*-*-*-*-*-*-*-iso8859-1"))
 
       ,@(excl:ics-target-case
 	 (:+ics
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 696ec2214f7e61a484206322247f4e4ac7dbab36..fa07d6970315761db1db73aa0366117483d72a9c 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -19,7 +19,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Header: /repo/cvs.copy/clim2/tk/gcontext.lisp,v 1.31 1997/02/05 01:52:44 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/tk/gcontext.lisp,v 1.32 1997/05/31 01:00:42 tomj Exp $
 
 (in-package :tk)
 
@@ -350,6 +350,44 @@
    gc
    nv))
 
+;; granted, this isn't the right thing to do, but it saves us from some
+;; nasty consing -tjm 11Apr97
+(defmethod (setf gcontext-clip-mask) ((nv clim-utils::standard-bounding-rectangle) (gc gcontext))
+  (let ((rs (x11:make-xrectangle-array :number 1)))
+    (clim-utils::with-bounding-rectangle* (left top right bottom) nv
+      (setf (x11:xrectangle-array-x rs 0) (clim-utils::fix-coordinate left)
+	    (x11:xrectangle-array-y rs 0) (clim-utils::fix-coordinate top)
+	    (x11:xrectangle-array-width rs 0) (clim-utils::fix-coordinate (- right left))
+	    (x11:xrectangle-array-height rs 0) (clim-utils::fix-coordinate (- bottom top))))
+    (x11:xsetcliprectangles
+     (object-display gc)
+     gc
+     0
+     0
+     rs
+     1
+     x11:unsorted)))
+
+(defmethod (setf gcontext-clip-mask) ((nv clim-utils::standard-rectangle-set) (gc gcontext))
+  (let* ((rectangles (clim-utils::region-set-regions nv))
+	 (n (length rectangles))
+	 (rs (x11:make-xrectangle-array :number n)))
+    (dotimes (i n)
+      (let ((r (nth i rectangles)))
+	(clim-utils::with-bounding-rectangle* (left top right bottom) r
+	  (setf (x11:xrectangle-array-x rs i) (clim-utils::fix-coordinate left)
+		(x11:xrectangle-array-y rs i) (clim-utils::fix-coordinate top)
+		(x11:xrectangle-array-width rs i) (clim-utils::fix-coordinate (- right left))
+		(x11:xrectangle-array-height rs i) (clim-utils::fix-coordinate (- bottom top))))))
+    (x11:xsetcliprectangles
+     (object-display gc)
+     gc
+     0
+     0
+     rs
+     n
+     x11:unsorted)))
+
 (defmethod (setf gcontext-clip-mask) ((nv list) (gc gcontext))
   (let* ((n (length nv))
 	 (rs (x11:make-xrectangle-array :number n)))
diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp
index 392416a15b06d745b2eed442a2fe91c0509beda4..e05a3e2c1b0721c0c2023523c57cd4dd4c9106f6 100644
--- a/utils/base-designs.lisp
+++ b/utils/base-designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/base-designs.lisp,v 1.11 1997/02/05 01:54:29 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/base-designs.lisp,v 1.12 1997/05/31 01:00:47 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -171,14 +171,14 @@
 
 (defmethod make-load-form ((design (eql (symbol-value '+foreground-ink+))) #-aclpc &optional #-aclpc environment)
   #-aclpc (declare (ignore environment))
-  #-(or aclpc acl86win32) '+foreground-ink+ #+(or aclpc acl86win32) '(symbol-value '+foreground-ink+))
+  #-aclpc '+foreground-ink+ #+aclpc '(symbol-value '+foreground-ink+))
 
 
 (defconstant +background-ink+ (make-instance 'design))
 
 (defmethod make-load-form ((design (eql (symbol-value '+background-ink+))) #-aclpc &optional #-aclpc environment)
   #-aclpc (declare (ignore environment))
-  #-(or aclpc acl86win32) '+background-ink+ #+(or aclpc acl86win32) '(symbol-value '+background-ink+))
+  #-aclpc '+background-ink+ #+aclpc '(symbol-value '+background-ink+))
 
 
 ;;; Flipping inks
diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp
index 5614506932dadea2a8fc664c6a11b4c9d641e780..9f66811287a5c4e0c804f0e6f4af103b1125ff01 100644
--- a/utils/defun-utilities.lisp
+++ b/utils/defun-utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;;; $Header: /repo/cvs.copy/clim2/utils/defun-utilities.lisp,v 1.11 1997/02/05 01:54:47 tomj Exp $
+;;; $Header: /repo/cvs.copy/clim2/utils/defun-utilities.lisp,v 1.12 1997/05/31 01:00:48 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -64,7 +64,7 @@
 (defmacro define-group (name type &body body)
   `(sys:multiple-definition ,name ,type ,@body))
 
-#+(and Allegro (not microsoft-32) (version>= 4 1))
+#+(and Allegro (not acl86win32) (version>= 4 1))
 (defmacro define-group (name type &body body)
   `(progn
      (excl::record-source-file ',name :type ',type)
diff --git a/utils/defun.lisp b/utils/defun.lisp
index 6113024625ff4defc73de6471254bbdf944077ca..1ee320bf8bde4dc65a882e89401320c0fbdc4530 100644
--- a/utils/defun.lisp
+++ b/utils/defun.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/defun.lisp,v 1.11 1997/02/14 23:57:18 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/defun.lisp,v 1.12 1997/05/31 01:00:49 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -356,9 +356,9 @@
     #+PCL `(pcl::method ,function-name ,@qualifiers ,specifier-list)
     #-PCL `(#-aclpc clos:method #+aclpc cl:method ,function-name ,specifier-list ,@qualifiers)))
 
-#+(and Allegro (not microsoft-32) (version>= 4 1))
+#+(and Allegro (not acl86win32) (version>= 4 1))
 (eval-when (compile load eval) (cltl1::require :scm))
-#+(and Allegro (not microsoft-32) (version>= 4 1))
+#+(and Allegro (not acl86win32) (version>= 4 1))
 (scm::define-simple-parser defmethod scm::defmethod-parser)
 
 #+Genera
diff --git a/utils/designs.lisp b/utils/designs.lisp
index 7cf0512c215b2f0fff88f95febd924ba333dc3ec..e2ae5aa482bc69d069e26cddb40282d8256bf2d1 100644
--- a/utils/designs.lisp
+++ b/utils/designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/designs.lisp,v 1.22 1997/02/05 01:54:50 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/designs.lisp,v 1.23 1997/05/31 01:00:51 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -360,7 +360,7 @@
       (values best-color
 	      best-distance))))
 
-#-(or aclpc (and allegro microsoft-32)) 
+#-(or aclpc acl86win32)
 (defmethod add-colors-to-palette ((palette basic-palette) &rest colors)
   (declare (dynamic-extent colors))
   (let ((colors-done nil)
@@ -375,10 +375,10 @@
 	    (deallocate-color color palette))
 	  (error condition))))))
 
-#+(or aclpc (and allegro microsoft-32)) 
+#+(or aclpc acl86win32)
 (defgeneric add-colors-to-palette (palette &rest colors))
 
-#+(or aclpc (and allegro microsoft-32)) 
+#+(or aclpc acl86win32)
 (defmethod add-colors-to-palette ((palette basic-palette) &rest colors)
   (declare (dynamic-extent colors))
   (let ((colors-done nil))
@@ -392,7 +392,7 @@
 	   (deallocate-color color palette))
 	 (error condition))))))
 
-#+(or aclpc (and allegro microsoft-32)) 
+#+(or aclpc acl86win32)
 (defgeneric remove-colors-from-palette (palette &rest colors))
 
 (defmethod remove-colors-from-palette ((palette basic-palette) &rest colors)
@@ -478,7 +478,7 @@
 	      (make-dynamic-color +black+)))
     set))
 
-#+(or aclpc (and allegro microsoft-32)) (defgeneric layered-color (set &rest layers))
+#+aclpc (defgeneric layered-color (set &rest layers))
 
 (defmethod layered-color ((set layered-color-set) &rest layers)
   (declare (dynamic-extent layers))
@@ -690,7 +690,7 @@
 ;;; Compatibility with the old stipple feature, perhaps temporary until
 ;;; rendering of tiles and patterns is fully implemented
 ;;; This could be done with methods, but there is very little point to that
-#-(or aclpc (and allegro microsoft-32))
+#-(or aclpc acl86win32)
 (defun decode-tile-as-stipple (rectangular-tile)
   (declare (values array width height))
   (multiple-value-bind (pattern width height)
@@ -705,7 +705,7 @@
 		   (eq (aref designs 1) +foreground-ink+))
 	  (values array width height))))))
 
-#+(or aclpc (and allegro microsoft-32))
+#+(or aclpc acl86win32)
 (defun decode-tile-as-stipple (rectangular-tile)
   (declare (values array width height))
   (multiple-value-bind (pattern width height)
diff --git a/utils/extended-regions.lisp b/utils/extended-regions.lisp
index 1264712ad9ce008d3dc3805665f5e137e424ee97..94abad6737fd7f3a814779ca42f4e9b240aa302f 100644
--- a/utils/extended-regions.lisp
+++ b/utils/extended-regions.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/extended-regions.lisp,v 1.8 1997/02/05 01:54:54 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/extended-regions.lisp,v 1.9 1997/05/31 01:00:51 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -98,6 +98,34 @@
     (and (region-contains-position-p line1 start-x start-y)
 	 (region-contains-position-p line1 end-x end-y))))
 
+;; spec says only coincidence satisfies region-intersects-region-p for lines
+;; this is often more useful since it returns true if they touch *anywhere*
+(defun segments-intersect-p (line1 line2)
+  (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1
+    (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2
+      (let ((sx1 sx1) (sy1 sy1) (ex1 ex1) (ey1 ey1)
+	    (sx2 sx2) (sy2 sy2) (ex2 ex2) (ey2 ey2))
+	(declare (type coordinate sx1 sy1 ex1 ey1
+		       sx2 sy2 ex2 ey2))
+	;; do the lines' x-components and y-components even overlap?
+	(and (>= (max sx2 ex2) (min sx1 ex1))
+	     (>= (max sx1 ex1) (min sx2 ex2))
+	     (>= (max sy2 ey2) (min sy1 ey1))
+	     (>= (max sy1 ey1) (min sy2 ey2))
+	     (let* ((dx1 (- ex1 sx1)) (dy1 (- ey1 sy1))
+		    (dx2 (- ex2 sx2)) (dy2 (- ey2 sy2))
+		    (dsx (- sx1 sx2)) (dsy (- sy1 sy2))
+		    (slope-diff (- (* dx1 dy2) (* dx2 dy1))))
+	       (if (= slope-diff 0)	; parallel
+		   (= (* dsy dx1) (* dsx dy1)) ; coincident
+		 (let ((r (/ (- (* dsy dx2) (* dsx dy2)) slope-diff))
+		       (s (/ (- (* dsy dx1) (* dsx dy1)) slope-diff)))
+		   (and (<= 0 r 1) (<= 0 s 1)))))))))) ; intersecting
+
+;; as per the dimensionality rules in the spec (why?)
+;; this only returns true if the segments coincide;
+;; use segments-intersect-p above to find out if they cross
+;; and point-of-intersection to get the p-o-i
 (defmethod region-intersects-region-p ((line1 standard-line) (line2 standard-line))
   (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1
     (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2
@@ -118,8 +146,29 @@
 	(declare (type coordinate sx1 sy1 ex1 ey1))
 	(with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2
 	  (declare (type coordinate sx2 sy2 ex2 ey2))
-	  (make-line* (max sx1 sx2) (max sy1 sy2) (min ex1 ex2) (min ey1 ey2))))
-      +nowhere+))
+	  (flet ((between-p (x1 y1 x2 y2 x y)
+		   (and (or (<= x1 x x2) (<= x2 x x1))
+			(or (<= y1 y y2) (<= y2 y y1)))))
+	    (let ((sx nil) (sy nil) (ex nil) (ey nil))
+	      ;;          A     B     C     D
+	      ;; line1:  ___  _____  ____ ____
+	      ;; line2: -----  ---  ----   ----
+	      (if (between-p sx1 sy1 ex1 ey1 sx2 sy2)
+		  ;; cases B/D
+		  (setf sx sx2 sy sy2))
+	      (if (between-p sx1 sy1 ex1 ey1 ex2 ey2)
+		  ;; cases B/C
+		  (if sx (setf ex ex2 ey ey2) ;; case B
+		    (setf sx ex2 sy ey2))) ;; case C
+	      (if (between-p sx2 sy2 ex2 ey2 sx1 sy1)
+		  ;; cases A/C
+		  (if sx (setf ex sx1 ey sy1) ;; case C
+		    (setf sx sx1 sy sy1))) ;; case A
+	      (if (between-p sx2 sy2 ex2 ey2 ex1 ey1)
+		  ;; cases A/D
+		  (setf ex ex1 ey ey1))
+	      (make-line* sx sy ex ey)))))
+    +nowhere+))
 
 (defmethod transform-region (transformation (line standard-line))
   (with-slots (start-x start-y end-x end-y) line
@@ -188,7 +237,7 @@
 	       (i 1))
 	  (loop
 	    (funcall function x y
-		     (setf x (aref coords (incf i))) (setf x (aref coords (incf i))))
+		     (setf x (aref coords (incf i))) (setf y (aref coords (incf i))))
 	    (when (= i ncoords) (return)))
 	  (when (polyline-closed polygon)
 	    (funcall function x y x1 y1)))
@@ -268,6 +317,521 @@
       (map-over-polygon-coordinates #'transform-coord polygon))
     (make-polygon* (nreverse coords))))
 
+;;; from patch3519, various missing region methods on polygons, polylines, etc.
+;;; note that these work in the hairy cases too, eg:
+;;;         _         
+;;; |\ /|  / \  |\  /|
+;;; | X | |   | | \/ |
+;;; |/ \|  \_/  |____|
+
+(defmethod region-contains-position-p ((polyline standard-polyline) x y)
+  (map-over-polygon-segments
+   #'(lambda (x1 y1 x2 y2)
+       (when (region-contains-position-p (make-line* x1 y1 x2 y2) x y)
+	 (return-from region-contains-position-p t)))
+   polyline))
+
+(define-symmetric-region-method region-intersects-region-p ((polyline standard-polyline) (other-region region))
+  (map-over-polygon-segments
+   #'(lambda (x1 y1 x2 y2)
+       (when (region-intersects-region-p (make-line* x1 y1 x2 y2) other-region)
+	 (return-from region-intersects-region-p t)))
+   polyline))
+
+(defmethod region-contains-region-p ((polyline standard-polyline) (line standard-line))
+  (let ((x nil) (y nil))
+    (map-over-polygon-segments
+     #'(lambda (x1 y1 x2 y2)
+	 (let ((this-segment (make-line* x1 y1 x2 y2)))
+	   (when (region-contains-region-p this-segment line)
+	     (return-from region-contains-region-p t))
+	   ;; also check for this case:  \__.__/
+	   ;; imagine parallel lines are   ---    superimposed.
+	   (unless (and x
+			(let ((last-n-segments (make-line* x y x2 y2)))
+			  ;; if the last few segments form a straight line...
+			  (and (region-contains-region-p last-n-segments this-segment)
+			       (if (region-contains-region-p last-n-segments line)
+				   (return-from region-contains-region-p t)
+				 ;; else-- no dice, but keep x and y
+				 ;; because maybe there's an even longer
+				 ;; straight line in the polyline
+				 t))))
+	     (setf x x1 y y1))))
+     polyline)))
+
+(defmethod region-contains-region-p ((polyline1 standard-polyline) (polyline2 standard-polyline))
+  (map-over-polygon-segments
+   #'(lambda (x1 y1 x2 y2)
+       (unless (region-contains-region-p polyline1 (make-line* x1 y1 x2 y2))
+	 (return-from region-contains-region-p nil)))
+   polyline2)
+  t)
+
+(defmethod region-contains-position-p ((polygon polygon) x y)
+  (with-bounding-rectangle* (left top right bottom) polygon
+    (and (<= left x right)
+	 (<= top y bottom)
+	 (let ((line-to-infinity (make-line* x y (+ 10 right) (+ 10 bottom)))
+	       (intersections 0))
+	   (map-over-polygon-segments
+	    #'(lambda (x1 y1 x2 y2)
+		(if (region-contains-position-p line-to-infinity x1 y1)
+		    (when (and (= x x1) (= y y1))
+		      ;; position is a vertex of the polygon [if not,
+		      ;; line-to-infinity crosses a vertex of the poly, but we
+		      ;; still don't incf this time since the same intersection
+		      ;; will have shown up in the previous segment and we don't
+		      ;; want to count it twice]
+		      (return-from region-contains-position-p t))
+		  (let ((segment (make-line* x1 y1 x2 y2)))
+		    (when (segments-intersect-p line-to-infinity segment)
+		      (when (region-contains-position-p segment x y)
+			;; position sits on a line of the polygon
+			(return-from region-contains-position-p t))
+		      (incf intersections)))))
+	    polygon)
+	   ;; position is bounded by polygon if line from position to infinity
+	   ;; crosses polygon boundaries an odd number of times
+	   (oddp intersections)))))
+
+(defmethod region-intersects-region-p ((polygon1 polygon) (polygon2 polygon))
+  (or (region-contains-region-p polygon1 polygon2)
+      (region-contains-region-p polygon2 polygon1)
+      (map-over-polygon-segments
+       #'(lambda (sx sy ex ey)
+	   (let ((segment-of-p1 (make-line* sx sy ex ey)))
+	     (map-over-polygon-segments
+	      #'(lambda (x1 y1 x2 y2)
+		  (when (segments-intersect-p segment-of-p1
+					      (make-line* x1 y1 x2 y2))
+		    (return-from region-intersects-region-p t)))
+	      polygon2)))
+       polygon1)))
+
+;; just-touches-p is useful in many situations when we know two things
+;; intersect but would like to determine whether they just touch or
+;; actually cross, ie the lines in T or V just touch but in X they cross.
+
+;; default to nil
+(defmethod just-touches-p ((region1 region) (region2 region)))
+
+(defmethod just-touches-p ((line1 standard-line) (line2 standard-line))
+  (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1
+    (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2
+      ;; if any segment endpoint is *on* the other segment, they don't cross
+      (or (region-contains-position-p line2 sx1 sy1)
+	  (region-contains-position-p line2 ex1 ey1)
+	  (region-contains-position-p line1 sx2 sy2)
+	  (region-contains-position-p line1 ex2 ey2)))))
+			  
+(define-symmetric-region-method just-touches-p ((polygon polygon) (line standard-line))
+  (and (not (region-contains-region-p polygon line))
+       ;; relies on map-over-polygon-segments returning nil on completion
+       (not (map-over-polygon-segments
+	     #'(lambda (x1 y1 x2 y2)
+		 (let ((segment (make-line* x1 y1 x2 y2)))
+		   (unless (or (not (segments-intersect-p segment line))
+			       (just-touches-p segment line))
+		     (return-from just-touches-p nil))))
+	     polygon))))
+
+(defmethod just-touches-p ((polygon1 polygon) (polygon2 polygon))
+  (and (not (map-over-polygon-segments
+	     #'(lambda (a b c d)
+		 (let ((segment-of-1 (make-line* a b c d)))
+		   (map-over-polygon-segments
+		    #'(lambda (x1 y1 x2 y2)
+			(let ((segment-of-2 (make-line* x1 y1 x2 y2)))
+			  (unless (or (not (segments-intersect-p segment-of-1 segment-of-2))
+				      (and (just-touches-p segment-of-1 polygon2)
+					   (just-touches-p segment-of-2 polygon1)))
+			    (return-from just-touches-p nil))))
+		    polygon2)))
+	     polygon1))))
+
+;; does-not-overlap-p might seem redundant but is a distinction which needs
+;; to be made in the case where a line meets an region on the border of a
+;; region-difference.
+
+(defmethod does-not-overlap-p ((region1 region) (region2 region))
+  (just-touches-p region1 region2))
+
+(defmethod does-not-overlap-p ((line1 standard-line) (line2 standard-line))
+  (not (region-intersects-region-p line1 line2)))
+
+;; if poly first, just-touches-p is called
+(defmethod does-not-overlap-p ((line standard-line) (poly polygon))
+  (not (region-intersects-region-p line poly)))
+
+
+(defmethod region-contains-region-p ((polygon polygon) (line standard-line))
+  (with-slots ((sx start-x) (sy start-y) (ex end-x) (ey end-y)) line
+    (declare (type coordinate sx sy ex ey))
+    (and (region-contains-position-p polygon sx sy)
+	 (region-contains-position-p polygon ex ey)
+	 (not (map-over-polygon-segments
+	       #'(lambda (x1 y1 x2 y2)
+		   (let ((segment (make-line* x1 y1 x2 y2)))
+		     (when (segments-intersect-p line segment)
+		       (unless (and (just-touches-p line segment)
+				    ;; make sure the midpoint is bounded--
+				    ;; remember, polygons can be concave
+				    (region-contains-position-p
+				     polygon
+				     (+ sx (/ (- ex sx) 2))
+				     (+ sy (/ (- ey sy) 2))))
+			 ;; line crosses out
+			 (return-from region-contains-region-p nil)))))
+	       polygon)))))
+
+(defmethod region-contains-region-p ((polygon1 polygon) (polygon2 polygon))
+  (map-over-polygon-segments
+   #'(lambda (x1 y1 x2 y2)
+       (unless (region-contains-region-p polygon1 (make-line* x1 y1 x2 y2))
+	 (return-from region-contains-region-p nil)))
+   polygon2)
+  t)
+
+(defmethod region-equal ((polygon1 polygon) (polygon2 polygon))
+  ;; inefficient?
+  (and (region-contains-region-p polygon1 polygon2)
+       (region-contains-region-p polygon2 polygon1)))
+
+(define-symmetric-region-method region-intersects-region-p ((polygon polygon) (line standard-line))
+  (or (region-contains-region-p polygon line)
+      (map-over-polygon-segments
+       #'(lambda (x1 y1 x2 y2)
+	   (when (segments-intersect-p line (make-line* x1 y1 x2 y2))
+	     (return-from region-intersects-region-p t)))
+       polygon)))
+
+;; previously missing region-set methods -- region-set is essentially equivalent to
+;; region-union since there are no specialized region-union methods
+
+(defmethod region-intersects-region-p ((set1 region-set) (set2 region-set))
+  (map-over-region-set-regions
+   #'(lambda (region-of-set1)
+       (map-over-region-set-regions
+	#'(lambda (region-of-set2)
+	    (when (region-intersects-region-p region-of-set1 region-of-set2)
+	      (return-from region-intersects-region-p t)))
+	set2))
+   set1)
+  nil)
+
+(defmethod region-equal ((set1 region-set) (set2 region-set))
+  ;; inefficient?  bah.  consider making this the primary method.
+  (and (region-contains-region-p set1 set2)
+       (region-contains-region-p set2 set1)))
+
+(define-symmetric-region-method region-intersects-region-p ((set region-set) (other-region region))
+  (map-over-region-set-regions
+   #'(lambda (set-region)
+       (when (region-intersects-region-p set-region other-region)
+	 (return-from region-intersects-region-p t)))
+   set))
+
+(defun point-of-intersection (sx1 sy1 ex1 ey1 sx2 sy2 ex2 ey2)
+  ;; do the lines' x-components and y-components even overlap?
+  (when (and (>= (max sx2 ex2) (min sx1 ex1))
+	     (>= (max sx1 ex1) (min sx2 ex2))
+	     (>= (max sy2 ey2) (min sy1 ey1))
+	     (>= (max sy1 ey1) (min sy2 ey2)))
+    (let* ((dx1 (- ex1 sx1)) (dy1 (- ey1 sy1))
+	   (dx2 (- ex2 sx2)) (dy2 (- ey2 sy2))
+	   (dsx (- sx1 sx2)) (dsy (- sy1 sy2))
+	   (slope-diff (- (* dx1 dy2) (* dx2 dy1))))
+      (unless (= slope-diff 0)		; parallel or coincident
+	(let ((r (/ (- (* dsy dx2) (* dsx dy2)) slope-diff))
+	      (s (/ (- (* dsy dx1) (* dsx dy1)) slope-diff)))
+	  (when (and (<= 0 r 1) (<= 0 s 1)) ; intersecting
+	    (values (+ sx1 (* r (- ex1 sx1))) ; xy of intersection
+		    (+ sy1 (* r (- ey1 sy1))))))))))
+
+(defmethod break-line-across-poly ((line standard-line) (poly polygon))
+  (with-slots ((sx start-x) (sy start-y) (ex end-x) (ey end-y)) line
+    (let ((poi nil))
+      (map-over-polygon-segments
+       #'(lambda (x1 y1 x2 y2)
+	   (multiple-value-bind (poi-x poi-y)
+	       (point-of-intersection x1 y1 x2 y2 sx sy ex ey)
+	     (when poi-x
+	       ;; index on distance from start point
+	       (let ((d (+ (abs (- sx poi-x))
+			   (abs (- sy poi-y)))))
+		 (push (list d poi-x poi-y) poi)))))
+       poly)
+      (let ((sorted-poi (apply #'append (mapcar #'cdr (sort poi #'< :key #'car)))))
+	(make-polyline* (append (list sx sy) sorted-poi (list ex ey)))))))
+
+(defmethod break-line-across-poly ((line1 standard-line) (line2 standard-line))
+  (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1
+    (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2
+      (flet ((between (x y)
+	       (if (and (or (<= sx1 x ex1) (<= ex1 x sx1))
+			(or (<= sy1 y ey1) (<= ey1 y sy1)))
+		   (+ (abs (- sx1 x)) (abs (- sy1 y))))))
+	(let* ((ds (between sx2 sy2))
+	       (de (between ex2 ey2))
+	       (mid (if (and ds de)
+			(if (> de ds)
+			    (list sx2 sy2 ex2 ey2)
+			  (list ex2 ey2 sx2 sy2))
+		      (if ds (list sx2 sy2)
+			(if de (list ex2 ey2))))))
+	  (make-polyline* (append (list sx1 sy1) mid (list ex1 ey1))))))))
+			    
+(defmethod region-contains-region-p ((region-set region-set) (line standard-line))
+  (let ((possibly-uncontained-parts (list line)))
+    (map-over-region-set-regions
+     #'(lambda (this-region)
+	 (let ((still-uncontained nil))
+	   (dolist (smaller-part possibly-uncontained-parts)
+	     (unless (region-contains-region-p this-region smaller-part)
+	       (if (region-intersects-region-p smaller-part this-region)
+		   (let ((broken-line (break-line-across-poly line this-region)))
+		     (map-over-polygon-segments
+		      #'(lambda (x1 y1 x2 y2)
+			  (let ((this-part (make-line* x1 y1 x2 y2)))
+			    (unless (region-contains-region-p this-region this-part)
+			      (push this-part still-uncontained))))
+		      broken-line))
+		 ;; else
+		 (push smaller-part still-uncontained))))
+	   (setf possibly-uncontained-parts
+	     (or still-uncontained
+		 (return-from region-contains-region-p t)))))
+     region-set)))
+
+(defmethod region-contains-region-p ((other-region region) (region-set region-set))
+  (map-over-region-set-regions
+   #'(lambda (this-region)
+       (unless (region-contains-region-p other-region this-region)
+	 (return-from region-contains-region-p nil)))
+   region-set)
+  t)
+
+(defmethod region-contains-region-p ((region-set region-set) (polygon polygon))
+  (map-over-polygon-segments
+   #'(lambda (x1 y1 x2 y2)
+       (unless (region-contains-region-p region-set (make-line* x1 y1 x2 y2))
+	 (return-from region-contains-region-p nil)))
+   polygon)
+  t)
+
+
+;; standard-region-intersection comparisons
+
+(defmethod region-contains-position-p ((set standard-region-intersection) x y)
+  (map-over-region-set-regions
+   #'(lambda (region)
+       (unless (region-contains-position-p region x y)
+	 (return-from region-contains-position-p nil)))
+   set)
+  t)
+
+;; this fails on the following case: it gives a false positive on an
+;; other-region which *does* intersect all regions in the set but not at
+;; their intersection eg the region-intersection of any two regions below
+;; with the third.
+;;
+;; poly A     poly B 
+;;  +--+       +--+
+;;  |   \     /   |
+;;--+----\---/----+-- line C
+;;  |     \ /     |
+;;  |      X      |
+;;  |     / \     |
+;;  +----/---+    |
+;;      /         |
+;;     +----------+
+;; but not to worry, we catch most of these cases with the specializations
+;; on lines/polys below
+(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (other-region region))
+  (map-over-region-set-regions
+   #'(lambda (set-region)
+       (unless (region-intersects-region-p set-region other-region)
+	 (return-from region-intersects-region-p nil)))
+   set)
+  t)
+
+(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (line standard-line))
+  (let ((possibly-intersecting-parts (list line)))
+    (map-over-region-set-regions
+     #'(lambda (this-region)
+	 (let ((intersects-so-far nil))
+	   (dolist (this-part possibly-intersecting-parts)
+	     (when (and (region-intersects-region-p this-region this-part)
+			(not (just-touches-p this-region this-part)))
+	       (let ((broken-line (break-line-across-poly line this-region)))
+		 (map-over-polygon-segments
+		  #'(lambda (x1 y1 x2 y2)
+		      (let ((this-subsegment (make-line* x1 y1 x2 y2)))
+			(when (region-contains-region-p this-region this-subsegment)
+			  (push this-subsegment intersects-so-far))))
+		  broken-line))))
+	   (setf possibly-intersecting-parts
+	     (or intersects-so-far
+		 (return-from region-intersects-region-p nil)))))
+       set))
+  t)
+
+(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (poly polygon))
+  (or (region-contains-region-p poly set)
+      (map-over-polygon-segments
+       #'(lambda (x1 y1 x2 y2)
+	   (when (region-intersects-region-p set (make-line* x1 y1 x2 y2))
+	     (return-from region-intersects-region-p t)))
+       poly)))
+
+(defmethod region-contains-region-p ((set standard-region-intersection) (other-region region))
+  (map-over-region-set-regions
+   #'(lambda (set-region)
+       (unless (region-contains-region-p set-region other-region)
+	 (return-from region-contains-region-p nil)))
+   set)
+  t)
+
+;; this fails too often - works for union but not intersection... but we
+;; catch many such cases with poly specialization below
+(defmethod region-contains-region-p ((other-region region) (set standard-region-intersection))
+  (map-over-region-set-regions
+   #'(lambda (set-region)
+       (unless (region-contains-region-p other-region set-region)
+	 (return-from region-contains-region-p nil)))
+   set)
+  t)
+
+;; what a headache... this checks through each side of each region in the
+;; set against all other regions in the set and hacks each side down into
+;; the part (if any) which is actually *in* all of them (ie bounding or
+;; inside the intersection).  As it goes it checks to make sure each such
+;; segment is contained by the poly in question.
+(defmethod region-contains-region-p ((poly polygon) (set standard-region-intersection))
+  (let ((current-region 0))
+    (map-over-region-set-regions
+     #'(lambda (this-region)
+	 ;; should check if polygon first
+	 (map-over-polygon-segments
+	  #'(lambda (x1 y1 x2 y2)
+	      (let ((parts-of-this-side (list (make-line* x1 y1 x2 y2)))
+		    (counter 0))
+		(dolist (that-region (region-set-regions set))
+		  (unless parts-of-this-side (return))
+		  (let ((smaller-parts nil))
+		    (unless (= counter current-region)
+		      (dolist (this-segment parts-of-this-side)
+			(if (region-intersects-region-p this-segment that-region)
+			    (let ((broken-line (break-line-across-poly this-segment that-region)))
+			      (map-over-polygon-segments
+			       #'(lambda (sx sy ex ey)
+				   (let ((subseg (make-line* sx sy ex ey)))
+				     (if (region-contains-region-p
+					  that-region subseg)
+					 (push subseg smaller-parts))))
+			       broken-line))))
+		      (setf parts-of-this-side smaller-parts)))
+		  (incf counter))
+		(dolist (segment-bounding-intersection parts-of-this-side)
+		  (unless (region-contains-region-p poly segment-bounding-intersection)
+		    (return-from region-contains-region-p nil)))))
+	  this-region)
+	 (incf current-region))
+     set))
+  t)
+
+
+;; standard-region-difference comparisons
+
+(defmethod region-contains-position-p ((diff standard-region-difference) x y)
+  (with-slots (region1 region2) diff
+    (and (region-contains-position-p region1 x y)
+	 (not (region-contains-position-p region2 x y)))))
+
+(defmethod region-contains-region-p ((diff standard-region-difference) (other-region region))
+  (with-slots (region1 region2) diff
+    (and (region-contains-region-p region1 other-region)
+	 (or (not (region-intersects-region-p region2 other-region))
+	     ;; okay to touch?
+	     (does-not-overlap-p region2 other-region)))))
+
+(defmethod region-contains-region-p ((other-region region) (diff standard-region-difference))
+  (with-slots (region1 region2) diff
+    (or (region-contains-region-p other-region region1)
+	(map-over-polygon-segments
+	 #'(lambda (x1 y1 x2 y2)
+	     (let ((this-side (make-line* x1 y1 x2 y2)))
+	       (if (and (region-intersects-region-p this-side region2)
+			(not (does-not-overlap-p this-side region2)))
+		   ;; what if region2 not poly?
+		   (let ((broken-line (break-line-across-poly this-side region2)))
+		     (map-over-polygon-segments
+		      #'(lambda (sx sy ex ey)
+			  (let ((subseg (make-line* sx sy ex ey)))
+			    (unless (or (region-contains-region-p region2 subseg)
+					(region-contains-region-p other-region subseg))
+			      (return-from region-contains-region-p nil))))
+		      broken-line))
+		 (unless (region-contains-region-p other-region this-side)
+		   (return-from region-contains-region-p nil)))))
+	 region1)
+	t)))
+
+(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (other-region region))
+  (with-slots (region1 region2) diff
+    (and (region-intersects-region-p region1 other-region)
+	 (or (not (region-intersects-region-p region2 other-region))
+	     (just-touches-p region2 other-region)))))
+
+(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (poly polygon))
+  (or (region-contains-region-p poly diff)
+      (region-contains-region-p diff poly)
+      (with-slots (region1 region2) diff
+	(and (region-intersects-region-p region1 poly)
+	     (or (not (region-intersects-region-p region2 poly))
+		 (and (region-contains-region-p poly region1)
+		      (not (region-contains-region-p region2 region1)))
+		 (does-not-overlap-p region2 poly)
+		 (map-over-polygon-segments
+		  #'(lambda (x1 y1 x2 y2)
+		      (when (region-intersects-region-p diff (make-line* x1 y1 x2 y2))
+			(return-from region-intersects-region-p t)))
+		  poly))))))
+
+(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (line standard-line))
+  (with-slots (region1 region2) diff
+    (and (region-intersects-region-p line region1)
+	 (or (not (region-intersects-region-p line region2))
+	     (does-not-overlap-p region2 line)
+	     (and (not (region-contains-region-p region2 line))
+		  (let ((broken-line (break-line-across-poly line region2)))
+		    (map-over-polygon-segments
+		     #'(lambda (x1 y1 x2 y2)
+			 (let ((this-subsegment (make-line* x1 y1 x2 y2)))
+			   (when (and (region-intersects-region-p this-subsegment region1)
+				      (not (region-contains-region-p region2 this-subsegment)))
+			     (return-from region-intersects-region-p t))))
+		     broken-line)))))))
+	
+
+;; line-poly-intersection assumes region-intersects-region-p is true.
+;; produces line(s) clipped to stay inside poly.
+;; we don't use this yet-- but spec says region-intersection and
+;; region-difference of paths and areas (eg lines and polys) should produce
+;; clipped lines... how to do this?
+#+ignore-for-now
+(defun line-poly-intersection (line poly)
+  (let ((segments nil)
+	(broken-line (break-line-across-poly line poly)))
+    (map-over-polygon-segments
+     #'(lambda (x1 y1 x2 y2)
+	 (let ((this-segment (make-line* x1 y1 x2 y2)))
+	   (when (region-contains-region-p poly this-segment)
+	     (push this-segment segments))))
+     broken-line)
+    (apply #'make-region-union segments)))
+
 
 ;;; Ellipses and elliptical arcs
 
diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp
index b885431ecff9bdee14a49639e583bc6a02654e57..bf174e4c60c8538099f108330df7d8dc48cf3318 100644
--- a/utils/region-arithmetic.lisp
+++ b/utils/region-arithmetic.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/region-arithmetic.lisp,v 1.16 1997/02/05 01:55:18 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/region-arithmetic.lisp,v 1.17 1997/05/31 01:00:52 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -100,6 +100,13 @@
   (if (region-intersects-region-p point path) point +nowhere+))
 (define-symmetric-region-method region-intersection ((point point) (area area))
   (if (region-intersects-region-p point area) point +nowhere+))
+;; this looks fishy to me-- what if the path and area are like so:
+;;      +-----+
+;;      |   --+-----
+;;      |     |
+;;      +-----+   then the path is *not* the intersection!
+;; and in fact the spec backs me up on this
+#+ignore ;; tjm 17Mar97
 (define-symmetric-region-method region-intersection ((path path) (area area))
   (if (region-intersects-region-p path area) path +nowhere+))
 
@@ -166,7 +173,9 @@
 (defmethod region-difference ((area area) (path path)) area)
 
 (defmethod region-difference ((region1 region) (region2 region))
-  (make-region-difference region1 region2))
+  (if (region-intersects-region-p region1 region2)
+      (make-region-difference region1 region2)
+    region1))
 
 
 ;;; Simple rectangle (LTRB) arithmetic
diff --git a/utils/regions.lisp b/utils/regions.lisp
index f67a6d992cb6c0edc72ff422aa3ef5f477e6e61f..fd9e0d4f8873ffe70ce8a33ccef89a5ead4f32cf 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 -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/regions.lisp,v 1.20 1997/02/07 00:21:08 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/regions.lisp,v 1.21 1997/05/31 01:00:52 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -838,6 +838,8 @@
     (map-over-region-set-regions #'contains-position-p region-set))
   nil)
 
+;; what if none of the chunks contain the other-region but they do as a whole?
+;; can we cover that case with strategic use of region-difference? -tjm 17Mar97
 (defmethod region-contains-region-p ((region-set region-set) (other-region region))
   (flet ((contains-region-p (region)
 	   (when (region-contains-region-p region other-region)
@@ -989,11 +991,11 @@
 	     (bottom (max y1 y2)))
 	(when (angle-between-angles-p pi-single-float theta-1 theta-2)
 	  (minf left (- x-radius)))
-	(when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2)
+	(when (angle-between-angles-p pi/2 theta-1 theta-2)
 	  (minf top (- y-radius)))
 	(when (angle-between-angles-p 0 theta-1 theta-2)
 	  (maxf right x-radius))
-	(when (angle-between-angles-p pi/2 theta-1 theta-2)
+	(when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2)
 	  (maxf bottom y-radius))
 	(when filled
 	  (minf left 0)
diff --git a/utils/transformations.lisp b/utils/transformations.lisp
index b61d755a55accd1baea7c8667f3faff2823f999b..a69d99e10665e2995452f1d0338360e25f84ff3c 100644
--- a/utils/transformations.lisp
+++ b/utils/transformations.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $Header: /repo/cvs.copy/clim2/utils/transformations.lisp,v 1.13 1997/02/05 01:55:24 tomj Exp $
+;; $Header: /repo/cvs.copy/clim2/utils/transformations.lisp,v 1.14 1997/05/31 01:00:53 tomj Exp $
 
 (in-package :clim-utils)
 
@@ -696,16 +696,18 @@
       (declare (type single-float tx ty))
       (values (coordinate (+ x tx)) (coordinate (+ y ty))))))
 
+;; coordinates *would* be single floats if we compiled with feature use-float-coordinates
+;; ... why *don't* we?
 (defmethod transform-position ((transform standard-transformation) x y)
+;;  (declare (optimize (speed 3) (safety 1) (debug 0)))
   (declare (type real x y))
-  (let ((x (coordinate x))
-	(y (coordinate y)))
-    (declare (type coordinate x y))
+  (let ((x #-ignore (float x 0f0) #+ignore (coordinate x))
+	(y #-ignore (float y 0f0) #+ignore (coordinate y)))
+    (declare (type #-ignore single-float #+ignore coordinate x y))
     (with-slots (mxx mxy myx myy tx ty) transform
       (declare (type single-float mxx mxy myx myy tx ty))
-      (values (coordinate (+ (* x mxx) (* y mxy) tx))
-	      (coordinate (+ (* x myx) (* y myy) ty))))))
-
+      (values (the #-ignore single-float #+ignore coordinate (+ (* x mxx) (* y mxy) tx))
+	      (the #-ignore single-float #+ignore coordinate (+ (* x myx) (* y myy) ty))))))
 
 (defmethod untransform-position ((transform identity-transformation) x y)
   (declare (type real x y))