diff --git a/ChangeLog.n b/ChangeLog.n
index c2aeb6cdb79edd00e65a361ab3727f8120dcf28a..d113bd382b978a0eb9bde940e74d3e97654c6651 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -10,6 +10,13 @@ If there are user-visible changes in this commit, then list the
 <standard changelog date stamp>
 	* <changes go here...>
 
+*******************************************************************************
+2.2.2.7 -- join from acl50 branch
+
+- changes from 2.2.1.55 to 2.2.1.68
+- cvs command: cvs update -d -j acl50_merge6 -j acl50
+- next merge tag: acl50_merge7
+
 *******************************************************************************
 2.2.2.6 -- join from acl50 branch
 
@@ -65,6 +72,155 @@ next merge tag: acl50_merge2
 (this should have been version 2.2.2.0, but was 2.2.1.17 instead)
 next merge tag: acl50_merge1
 
+*******************************************************************************
+2.2.1.68
+
+1999-06-24  Jeff
+
+	* aclpc/acl-medium.lisp,
+	* aclpc/acl-widget.lisp,
+	* clim/surround-output.lisp: fixes from Jeff (bug8171 and others)
+
+*******************************************************************************
+2.2.1.67
+
+1999-06-23    <layer@HOBART>
+
+	* aclpc/acl-frames.lisp: make select-file work: the binding of s1
+	using with-native-string was wrong, since that macro takes a lisp
+	string and lisp-string-to-scratch-c-string was returning a C
+	string (ie, a number); use :c not :foreign accessor in
+	lisp-string-to-scratch-c-string.
+	* aclpc/acl-medium.lisp: use (fslot-value-typed ... :foreign ...)
+	instead of (fslot-value-typed ... :foreign-static-gc ...) in
+	set-point, since the latter is an allocation type.
+	* aclpc/acl-widget.lisp: fix compile-time warning
+	* test/test-suite.lisp: select-file returns a pathname, so
+	namestring it before calling write-string
+
+*******************************************************************************
+2.2.1.66
+
+1999-06-23  Jeff Morrill  <jmorrill@pointnclick.com> 
+
+* demo/ico: limit number of cycles to 1000 to make timing more meaningful
+* silica/medium: optimization
+* sys/compile: set optimization levels for clim on Windows
+* test/test-suite: add test for select-file
+* aclpc/acl-class: fix bug in message processor
+* aclpc/acl-medium: optimization
+* aclpc/acl-port: optimization
+* aclpc/acl-widget: fix sizing of text editor, list panes; fix
+  redisplay problem of text fields
+
+*******************************************************************************
+2.2.1.65
+
+1999-06-22    <layer@HOBART>
+
+	* aclpc/acl-medium.lisp,
+	* aclpc/acl-frames.lisp: speed up ico demo by removing use of
+	anonymous foreign types.
+
+*******************************************************************************
+2.2.1.64
+
+1999-06-21  Kevin Layer  <layer@ultra>
+
+	* clim/input-protocol.lisp: bug8147: remove bogus dynamic-extent
+	for unix
+
+*******************************************************************************
+2.2.1.63
+
+1999-06-18  Kevin Layer  <layer@ultra>
+
+	* acl-medium.lisp: fix from Jeff
+	* clim/frames.lisp: fix from Jeff
+
+*******************************************************************************
+2.2.1.62
+
+1999-06-18  Kevin Layer  <layer@ultra>
+
+	* tk-silica/xm-gadgets.lisp: make it compile on unix
+
+*******************************************************************************
+2.2.1.61
+
+1999-06-18  Jeff Morrill  <jmorrill@pointnclick.com> 
+* aclpc/*.lisp: numerous changes that affect performance;
+  added PRINT-FILE function for windows (postscript still doesnt work).
+* clim/clim-defs: Change the treatment of input focus; a frame
+  no longer grabs the input focus away from another frame when
+  it goes through the command loop.  This means that you have
+  to click on an interactor pane before you can type into it.
+* clim/input-protocol: added dynamic-extent declaration
+* demo/ico: turn off output recording and get rid of some junk
+* tk-silica/xm-gadgets: added default print-file function
+  that does nothing for unix
+
+*******************************************************************************
+2.2.1.60
+
+1999-06-11  Kevin Layer  <layer@ultra>
+
+	* tk-silica/xm-gadgets.lisp: fix to method
+	discard-accelerator-event-p (for spr20230) from Jeff
+
+*******************************************************************************
+2.2.1.59
+
+1999-06-09    <layer@HOBART>
+
+	* aclpc/acl-frames.lisp: defun-c-callable -> defun-foreign-callable
+
+*******************************************************************************
+2.2.1.58
+
+1999-06-09  Jeff Morrill  <jmorrill@pointnclick.com> 
+
+* aclpc/*.lisp: Fix some recently introduced device context bugs.
+  Improve performance of drawing operations.  Add initial version
+  of PRINT-FILE enhancement.
+* demo/*.lisp: Fix a variety of minor bugs in the demos so that
+  testing can be more successful.
+* clim/cursor.lisp: don't erase the cursor on a destroyed window.
+* clim/db-stream: default view of accepting-values-pane should
+  be +gadget-dialog-view+
+
+*******************************************************************************
+2.2.1.57
+
+1999-06-07  Jeff Morrill  <jmorrill@pointnclick.com> 
+
+* aclpc/*.lisp: Numerous changes to avoid operations on invalid handles.
+  Also, CLIM will now avoid using SendMessage unless the window is in the 
+  same thread, avoiding a possible deadlock situation.
+
+*******************************************************************************
+2.2.1.56
+
+1999-06-02  Jeff Morrill  <jmorrill@pointnclick.com> 
+
+* aclpc/acl-widget, aclpc/winwidgh, clim/gadget-output: work on sizing
+  of text-fields yet again
+* utils/defun-utilities: fix up mb-to-string compatibility function
+
+*******************************************************************************
+2.2.1.55
+
+1999-05-21  Jeff Morrill  <jmorrill@pointnclick.com> 
+
+* aclpc/acl-class: Fix for gadgets w/ color backgrounds
+* aclpc/acl-frames: Cleanup
+* aclpc/acl-medium: Implement bitmaps with transparent background
+* aclpc/acl-mirror: Modularize realize-mirror some more
+* aclpc/acl-port: fixes for pointer cursor, gadget color, cleanup
+* aclpc/acl-widget: fixes for text gadget size, color, editability
+                    implement color buttons, button armed callbacks
+* aclpc/winwidgh: win:SRCOR seems to be missing, lets add our own.
+
 *******************************************************************************
 2.2.1.54
 
diff --git a/aclpc/acl-class.lisp b/aclpc/acl-class.lisp
index 0331d2a60006037647e58072ad7015caab643209..1c6f22614bdb1e974d871a16e33bcb4ff25c9e8a 100644
--- a/aclpc/acl-class.lisp
+++ b/aclpc/acl-class.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-class.lisp,v 1.12 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-class.lisp,v 1.13 1999/07/19 22:25:06 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -197,20 +197,23 @@
     (win:SetCursor wincursor)
     t))
 
-(defun maybe-set-cursor (sheet)
+(defmethod sheet-wants-default-pointer ((object t)) nil)
+
+(defmethod maybe-set-cursor (sheet)
   ;; This has a bug that it doesn't call defwindowproc
   ;; when the sheet is a text field.  This should get you the ibeam
   ;; cursor because that's the cursor for that class
   (let* ((cursor (or (port-grab-cursor *acl-port*)
 		     (sheet-pointer-cursor sheet)
-		     ;;(pointer-cursor (port-pointer *acl-port*))
-		     )))
-    (if cursor
-	(set-cursor sheet cursor)
-      (let ((parent (sheet-parent sheet)))
-	(or (and parent (maybe-set-cursor parent))
-	    (and (setq cursor (pointer-cursor (port-pointer (port sheet))))
-		 (set-cursor sheet cursor)))))))
+		     ))
+	 (parent (sheet-parent sheet)))
+    (cond (cursor
+	   (set-cursor sheet cursor))
+	  ((sheet-wants-default-pointer sheet) nil)
+	  ((and parent (maybe-set-cursor parent)))
+	  (t
+	   (and (setq cursor (pointer-cursor (port-pointer (port sheet))))
+		(set-cursor sheet cursor))))))
 
 (defvar *level* 0)
 
@@ -222,18 +225,12 @@
   nil)
 
 (defun loword (long)
-  (etypecase long
-    (integer (logand long #xffff))
-    #+broken
-    (word-vector (word-vector-ref long 1)))
-  )
+  (declare (optimize (speed 3) (safety 0)))
+  (ldb (byte 16 0) long))
 
 (defun hiword (long)
-  (etypecase long
-    (integer (logand #xffff (ash long -16)))
-    #+broken
-    (word-vector (word-vector-ref long 0)))
-  )
+  (declare (optimize (speed 3) (safety 0)))
+  (ldb (byte 16 16) long))
 
 ;; Process WM_MOUSEMOVE
 (defun onmousemove (window msg wparam lparam)
@@ -243,7 +240,8 @@
 	(sheet (mirror->sheet *acl-port* window)))
     (declare (ignore keys))
     (setq *win-result*
-      (if (or (not sheet) (note-pointer-motion *acl-port* sheet mx my))
+      (if (or (not sheet) 
+	      (note-pointer-motion *acl-port* sheet mx my))
 	  (win:DefWindowProc window msg wparam lparam)
 	win:FALSE))))
 
@@ -253,8 +251,9 @@
   ;; when the cursor is not moving.  JPM 5/98.
   (let* ((hit-code (loword lparam)))
     (cond ((eql hit-code win:HTCLIENT)
-	   (maybe-set-cursor (mirror->sheet *acl-port* window))
-	   (setq *win-result* win:TRUE))
+	   (setq *win-result* 
+	     (if (maybe-set-cursor (mirror->sheet *acl-port* window))
+		 win:TRUE win:FALSE)))
 	  (t 
 	   (setf (pointer-cursor (port-pointer *acl-port*)) :default)
 	   ;; If the hit-code is not HTCLIENT, then its not CLIM's problem.
@@ -317,16 +316,19 @@
 	(silica::draw-picture-button (mirror->sheet *acl-port* hwnd)
 				     state hdc rect)))))
 
+(defmethod isa-pushbutton ((object t)) nil)
+(defmethod isa-pushbutton ((object push-button)) t)
+
 ;; Process WM_CTLCOLOREDIT
 (defun onctlcoloredit (window msg wparam lparam)
-  (setq *win-result* (message-default window msg wparam lparam))
+  (declare (ignore msg window))
   (let ((hwnd (ct:ccallocate win:hwnd))
 	(hdc (ct:ccallocate win:hdc)))
     (setf (ct:handle-value win:hwnd hwnd) lparam
 	  (ct:handle-value win:hdc hdc) wparam)
     (let ((sheet (mirror->sheet *acl-port* hwnd)))
       (when sheet
-         (when (and (typep sheet 'silica::hpbutton-pane)
+         (when (and (isa-pushbutton sheet)
                     (slot-value sheet 'silica::pixmap))
            (let ((rect (ct:ccallocate win:rect)))
 	     (win:GetClientRect hwnd rect)
@@ -505,7 +507,7 @@
 ;; Process WM_GETMINMAXINFO
 (defun ongetminmaxinfo (window msg wparam lparam)
   (let ((sheet (mirror->sheet *acl-port* window)))
-    (if (typep sheet 'acl-top-level-sheet)
+    (if (istoplevel sheet)
 	(let ((min-width (acl-top-min-width sheet))
 	      (min-height (acl-top-min-height sheet)))
 	  ;; someone who knows how to use the pc ff interface should get
@@ -639,7 +641,7 @@
     (when (and (consp context-type)
 	       (eq (first context-type) 'command-name))
       (flet ((look (s)
-	       (when (and (typep s 'push-button)
+	       (when (and (isa-pushbutton s)
 			  (push-button-show-as-default s))
 		 (setq gadget s))))
 	(declare (dynamic-extent #'look))
@@ -1014,7 +1016,7 @@
 	      (format *standard-output* "keysym=~a char=~a modstate=~a~%"
 		      keysym char modstate)
 	      (if (and (or (eql keysym :end)
-			   (and (typep sheet 'silica::mswin-text-field)
+			   (and (silica::isa-textfield sheet)
 				(eql keysym :newline)))
 		       (eql modstate 0))
 		  (setq pass nil)) ;;; pass along the end character.
@@ -1083,7 +1085,7 @@
   ((device-handle1 :initarg :device-handle1
 		   :initform 0)
    (device-handle2 :initarg :device-handle1
-		   :initform (excl:with-native-string (d "DISPLAY")
+		   :initform  (excl:with-native-string (d "DISPLAY")
 			       (win:CreateDC d ct:hnull ct:hnull ct:hnull)))))
 
 (defun initialize-cg ()
@@ -1095,40 +1097,29 @@
   (setq *screen-device*
     (make-instance 'windows-screen-device)))
 
-(eval-when (compile load eval)
-  (defun make-cstructure (type length)
-    ;; create and return a region of memory of the
-    ;; given length.
-    ;; 
-    ;; in the mm implementation this was in malloc space, but since
-    ;; it is referenced using #. in files like message.cl, we better
-    ;; us a lisp structure so it will exist when the definition
-    ;; is fasled in.
-    ;;
-    ;; we've got to look into this later
-    ;;
-    ;;
-    (declare (ignore type))
-  
-    (ff:allocate-fobject `(:array :unsigned-char ,length) :lisp)))
+(defun make-cstructure (type length)
+  ;; create and return a region of memory of the
+  ;; given length.
+  (declare (ignore type))
+  (ff:allocate-fobject `(:array :unsigned-char ,length) :foreign-static-gc))
 
 (defun ensure-clim-initialized ()
   (unless *clim-initialized*
     (initialize-cg)
     (setf clim-window-proc-address 
-      (init-clim-win-proc clim-window-proc-address #.(make-cstructure 0 16)))
+      (init-clim-win-proc clim-window-proc-address (make-cstructure 0 16)))
     (setf clim-ctrl-proc-address 
-      (init-clim-ctrl-proc clim-ctrl-proc-address #.(make-cstructure 0 16)))
+      (init-clim-ctrl-proc clim-ctrl-proc-address (make-cstructure 0 16)))
     #+not-yet
     (setf tooltip-relay-address 
-      (init-tooltip-relay tooltip-relay-address #.(make-cstructure 0 16)))
+      (init-tooltip-relay tooltip-relay-address (make-cstructure 0 16)))
     (setq *clim-initialized* t)))
 
 (defun acl-clim::register-window-class (hcursor)
   ;; This is called by initialize-instance of acl-port.
   ;; It creates a (single) Windows window class for all clim windows.
   (unless *wndclass-registered*
-    (init-clim-win-proc clim-window-proc-address #.(make-cstructure 0 16))
+    (init-clim-win-proc clim-window-proc-address (make-cstructure 0 16))
     (let ((class (ff:allocate-fobject 'win:wndclassex 
 				      :foreign-static-gc nil))
 	  (icon (win:LoadIcon 0 win:IDI_APPLICATION)) ; (get-clim-icon)
@@ -1253,7 +1244,7 @@
 			      (or parent 0)
 			      menu
 			      *hinst*
-			      *win-x* ))))
+			      *win-x* )))) 
     (when (zerop window)
       (or (check-last-error "CreateWindowEx")
 	  (error "CreateWindowEx: unknown error")))
@@ -1369,4 +1360,6 @@
 	    ((and hwnd (win:IsDialogMessage hwnd msg)))
 	    (t 
 	     (win:TranslateMessage msg)
-	     (win:DispatchMessage msg))))))
+	     (win:DispatchMessage msg)))
+      (when nonblocking (return t))
+      )))
diff --git a/aclpc/acl-dc.lisp b/aclpc/acl-dc.lisp
index 83b79e07fc6f3e2913d3d62c04affc572fa4573a..b6974f87c37776a3c88866d5b383259ede42f25d 100644
--- a/aclpc/acl-dc.lisp
+++ b/aclpc/acl-dc.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-dc.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-dc.lisp,v 1.10 1999/07/19 22:25:09 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -64,14 +64,6 @@
 
 (defvar *original-font* nil)
 
-;;; Created Objects
-(defvar *created-pen* nil)
-(defvar *created-brush* nil)
-(defvar *created-tile* nil)
-(defvar *created-bitmap* nil)
-(defvar *created-font* nil)
-(defvar *created-region* nil)
-
 ;; Device context information
 (defstruct (dc-image (:predicate nil))
   (bitmapinfo nil)			; colors of unmasked bitmap
@@ -100,21 +92,7 @@
   (setf *white-brush* (win:GetStockObject win:WHITE_BRUSH))
   (setf *ltgray-brush* 
     (win:CreateSolidBrush (win:GetSysColor win:COLOR_BTNFACE)))
-  ;;
-  #+obsolete
-  (setf *black-image*
-    (make-dc-image :solid-1-pen *black-pen*
-		   :brush *black-brush*
-		   :text-color #x000000
-		   :background-color nil
-		   :rop2 win:R2_COPYPEN))
-  #+obsolete
-  (setf *white-image*
-    (make-dc-image :solid-1-pen *white-pen*
-		   :brush *white-brush*
-		   :text-color #xffffff
-		   :background-color nil
-		   :rop2 win:R2_COPYPEN))
+
   (setf *blank-image*
     #+possibly
     (make-dc-image :solid-1-pen *black-pen* 
@@ -141,35 +119,8 @@
 ;;;
 
 (defvar *original-bitmap* nil)
-(defvar *extra-objects* nil)
 
 (defun release-objects (window dc)
-  (when *created-pen*
-    (selectobject dc *black-pen*)
-    (win:DeleteObject *created-pen*)
-    (setq *created-pen* nil))
-  (when *created-brush*
-    (selectobject dc *white-brush*)
-    (win:DeleteObject *created-brush*)
-    (setq *created-brush* nil))
-  (when *created-tile*
-    (win:DeleteObject *created-tile*)
-    (setq *created-tile* nil))
-  (when *created-region*
-    (selectobject dc (ct::null-handle win:HRGN))
-    (win:DeleteObject *created-region*)
-    (setq *created-region* nil))
-  (when (and *created-font* *original-font*)
-    (selectobject dc *original-font*)
-    (win:DeleteObject *created-font*)
-    (setq *created-font* nil))     
-  (when (and *created-bitmap* *original-bitmap*)
-    (selectobject dc *original-bitmap*)
-    (win:DeleteObject *created-bitmap*)
-    (setq *created-bitmap* nil))
-  (dolist (xtra *extra-objects*)
-	(win:DeleteObject xtra))
-  (setq *extra-objects* nil)
   (win:ReleaseDC window dc))
 
 (defclass acl-pixmap (pixmap)
@@ -180,37 +131,45 @@
    (height :initarg :height :reader pixmap-height)
    (original-bitmap :initarg :original-bitmap)))
 
+(defmethod isa-pixmap ((object t)) nil)
+(defmethod isa-pixmap ((object acl-pixmap)) t)
+
+(defmethod isa-pixmap-medium ((object t)) nil)
+(defmethod isa-pixmap-medium ((object basic-pixmap-medium)) t)
+
 ;; The call to GetDC will cons a bignum (16 bytes).
 ;; We should probably try to optimize this some how
 ;; since it is called constantly during simple
 ;; things like repaint.
 (defmacro with-dc ((window dc) &rest body)
-  `(if (typep ,window 'acl-pixmap-medium)
-       (let ((,dc (pixmap-cdc (medium-drawable ,window))))
-	 ,@body)
-     ;; It was my intention to rewrite this to
-     ;; cache the DC, in combination with setting
-     ;; CS_OWNDC.
-     (let ((,dc 0))
-       (unwind-protect
-	   (progn
-	     (setq ,dc (getDc ,window))
-	     ,@body)
-	 (release-objects ,window ,dc)))))
+  ;; It was my intention to rewrite this to
+  ;; cache the DC, in combination with setting
+  ;; CS_OWNDC.
+  `(let ((,dc 0))
+     (unwind-protect
+	 (progn
+	   ;; There are occasions where GetDC returns 0
+	   ;; despite the fact that you did everything right.
+	   ;; "Since only five common device contexts are
+	   ;; available at any given time, failure to release
+	   ;; a device context can prevent other applications
+	   ;; from accessing a device context."  Microsoft document.
+	   (setq ,dc (getDc ,window))
+	   ,@body)
+       (unless (zerop ,dc)
+	 (ReleaseDC ,window ,dc)))))
 
+;; JPM: this macro should be rewritten to expand the body only once.
 (defmacro with-medium-dc ((medium dc) &rest body)
-  `(if (typep ,medium 'acl-pixmap-medium)
-       (let ((,dc (pixmap-cdc (medium-drawable ,medium))))
-	 ,@body)
-     ;; It was my intention to rewrite this to
-     ;; cache the DC, in combination with setting
-     ;; CS_OWNDC.
-     (let ((,dc 0))
-       (unwind-protect
-	   (progn
-	     (setq ,dc (getDc (medium-drawable ,medium)))
-	     ,@body)
-	 (release-objects (medium-drawable ,medium) ,dc)))))
+  `(cond ((isa-pixmap-medium ,medium)
+	  (let ((,dc (pixmap-cdc (medium-drawable ,medium)))) ,@body))
+	 ((isa-pixmap ,medium)
+	  (let ((,dc (pixmap-cdc ,medium))) ,@body))
+	 (t
+	  ;; It was my intention to rewrite this to
+	  ;; cache the DC, in combination with setting
+	  ;; CS_OWNDC.
+	  (with-dc ((medium-drawable ,medium) ,dc) ,@body))))
 
 (defmacro with-compatible-dc ((dc cdc) &rest body)
   `(let ((,cdc nil))
@@ -218,29 +177,40 @@
 	 (progn
 	   (setf ,cdc (win:CreateCompatibleDC ,dc))
 	   ,@body)
-       (selectobject ,cdc *original-bitmap*)
-       (when (and *created-bitmap*
-		  (not (ct::null-handle-p win:hbitmap *created-bitmap*)))
-	 (win:DeleteObject *created-bitmap*))
+       (when (valid-handle *original-bitmap*) 
+	 (selectobject ,cdc *original-bitmap*))
+       (when (valid-handle *created-bitmap*) 
+	 (or (win:DeleteObject *created-bitmap*)
+	     (error "DeleteObject")))
        (setf *created-bitmap* nil)
        (win:DeleteDC ,cdc))))
 
-(defun set-dc-for-drawing (dc image line-style)
+(defmacro valid-handle (handle)
+  `(let ((h ,handle))
+     (declare (fixnum h)
+	      (optimize (speed 3) (safety 0)))
+     (and h (not (zerop h)) (not (< -100 h 100)))))
+  
+(defun check-handle (handle)
+  (when (or (not (valid-handle handle)))
+    (error "invalid handle")))
+
+(defun set-dc-for-drawing-1 (dc image line-style)
   ;; Note: DASHES may be a list, i.e. (5 2).  CreatePen
   ;; only supports four dash types, and here we only use
   ;; one of them.  Complex dash patterns cannot be supported
   ;; using CreatePen.
+  (assert (valid-handle dc))
   (let* ((dashes (line-style-dashes line-style))
 	 (thickness (max 1 (round (line-style-thickness line-style))))
 	 (code (if dashes (- thickness) thickness))
 	 (brush *null-brush*)
 	 (pen (when (= code 1) (dc-image-solid-1-pen image)))
 	 (rop2 (dc-image-rop2 image))
-	 (text-color (dc-image-text-color image)))
+	 (text-color (dc-image-text-color image))
+	 (created-pen nil))
     (declare (fixnum thickness code))
     (unless pen
-      (when *created-pen*
-	(push *created-pen* *extra-objects*))
       (when (and dashes (> thickness 1))
 	;; CreatePen does not support thick dashed lines.
 	;; So render dashes with thickness=1.
@@ -249,88 +219,81 @@
       (when (= rop2 win:R2_XORPEN)
 	(setq text-color #xffffff))		; black
       (setq pen
-	(setq *created-pen*
+	(setq created-pen
 	  (createPen (if dashes win:PS_DASH win:PS_SOLID)
 		     thickness
 		     text-color))))
-    (selectobject dc pen)
+    (when (valid-handle pen) (selectobject dc pen))
     (if dashes
-	(win:SetBkMode dc win:TRANSPARENT)
-      (win:SetBkMode dc win:OPAQUE))
-    (when brush (selectobject dc brush))
-    (when rop2 (win:SetRop2 dc rop2))
-    t))
+	(SetBkMode dc win:TRANSPARENT)
+      (SetBkMode dc win:OPAQUE))
+    (when (valid-handle brush) (selectobject dc brush))
+    (when rop2 (SetRop2 dc rop2))
+    created-pen))
 
 (defun set-dc-for-filling (dc image &optional xorg yorg)
+  (assert (valid-handle dc))
   (let ((background-color (dc-image-background-color image))
         (text-color (dc-image-text-color image))
 	(brush (dc-image-brush image))
 	(pen *null-pen*)
 	(rop2 (dc-image-rop2 image)))
-    (selectobject dc pen)
+    (when (valid-handle pen) (selectobject dc pen))
     (when background-color
       (cond ((minusp background-color)
 	     ;; This affects brushes created with CreateHatchBrush.
-	     (win:SetBkMode dc win:TRANSPARENT))
+	     (SetBkMode dc win:TRANSPARENT))
 	    (t
-	     (win:SetBkMode dc win:OPAQUE)
-	     (win:SetBkColor dc background-color))))
-    (when text-color (win:SetTextColor dc text-color))
-    (when brush 
+	     (SetBkMode dc win:OPAQUE)
+	     (SetBkColor dc background-color))))
+    (when text-color (SetTextColor dc text-color))
+    (when (valid-handle brush)
       (when (and xorg yorg)
 	;; Is this working?  JPM.
 	(win:SetBrushOrgEx dc xorg yorg 0))
       (selectobject dc brush))
-    (when rop2  (win:SetRop2 dc rop2))
+    (when rop2  (SetRop2 dc rop2))
     t))
 
-(defun set-dc-for-ink (dc medium ink line-style &optional xorg yorg)
-  (let ((image (dc-image-for-ink medium ink)))
+(defun set-dc-for-ink-1 (dc image line-style &optional xorg yorg)
+  (let ((retval nil))
+    ;; For transparent patterns, we actually have two images.
+    ;; Callers should prevent us from getting here in that case,
+    ;; but in case they fail, do something responsible here:
+    (when (consp image) (setq image (second image)))
     (if line-style
-      (set-dc-for-drawing dc image line-style)
-      (set-dc-for-filling dc image xorg yorg))))
-
-(defun set-cdc-for-pattern (dc medium ink line-style)
-  (declare (ignore line-style))
-  (let ((image (dc-image-for-ink medium ink))
-	#+ign
-	size)
-    (when (typep ink 'pattern)
-      #+ign
-      (multiple-value-bind (array designs) (decode-pattern ink)
-	(declare (ignore array))
-	(setf size (length designs)))
-      (setf *created-bitmap* (dc-image-bitmap image))
-      (cond ((or (not *created-bitmap*)
-		 (ct::null-handle-p win:hbitmap *created-bitmap*))
-	     (format *terminal-io* "No bitmap (~s) ~%" *created-bitmap*))
-	    ((ct::null-handle-p win:hdc dc)
-	     (format *terminal-io* "No DC (~s) ~%" dc))
-	    (t
-	     (setf *original-bitmap* (selectobject dc *created-bitmap*))))
-      #+ign
-      (unless (> size 2)
-	(let ((background-color (dc-image-background-color image))
-	      (text-color (dc-image-text-color image)))
-	  (cond ((not background-color))
-		((minusp background-color)
-		 (win:SetBkMode dc win:TRANSPARENT))
-		(t
-		 (win:SetBkMode dc win:OPAQUE)
-		 (win:SetBkColor dc background-color)))
-	  (when text-color
-	    (win:SetTextColor dc text-color)))
-	(win:SetRop2 dc (dc-image-rop2 image))))
-    win:SRCCOPY))
-
-(defun set-dc-for-text (dc medium ink font)
-  (let* ((image (dc-image-for-ink medium ink))
-	 (text-color (dc-image-text-color image))
+	(setq retval (set-dc-for-drawing-1 dc image line-style))
+      (set-dc-for-filling dc image xorg yorg))
+
+    retval))
+
+(defmacro with-set-dc-for-ink ((dc medium ink line-style &optional xorg yorg) 
+			       &body body)
+  `(let ((..winpen.. nil))
+     (unwind-protect 
+	 (with-dc-image-for-ink (..image..) (,medium ,ink)
+           (setq ..winpen.. (set-dc-for-ink-1 ,dc ..image.. ,line-style
+					      ,xorg ,yorg))
+	   ,@body)
+       (when (valid-handle ..winpen..)
+	 (when (valid-handle *black-pen*) (selectobject ,dc *black-pen*))
+	 (or (win:DeleteObject ..winpen..) 
+	     (error "with-set-dc-for-ink: DeleteObject"))))))
+
+(defmethod isa-pattern ((object t)) nil)
+(defmethod isa-pattern ((object pattern)) t)
+
+(defun set-dc-for-text-1 (dc font image)
+  (when (consp image) (setq image (second image)))
+  (let* ((text-color (dc-image-text-color image))
+	 #+ignore
 	 (background-color (dc-image-background-color image))
 	 (brush (dc-image-brush image))
 	 (pen (dc-image-solid-1-pen image)))
     (win:SetMapMode dc win:MM_TEXT)
-    (when font (selectobject dc font))
+    (when (valid-handle font) (selectobject dc font))
+    ;; Seems like we never want opaque background. JPM.
+    #+ignore				
     (cond ((not background-color)
 	   (win:SetBkMode dc win:TRANSPARENT))
 	  ((minusp background-color)
@@ -338,13 +301,19 @@
 	  (t
 	   (win:SetBkMode dc win:OPAQUE)
 	   (win:SetBkColor dc background-color)))
-    (when brush (win:SelectObject dc brush))
-    (when pen (win:SelectObject dc pen))
-    (when text-color (win:SetTextColor dc text-color))
+    (SetBkMode dc win:TRANSPARENT)
+    (when (valid-handle brush) (SelectObject dc brush))
+    (when (valid-handle pen) (SelectObject dc pen))
+    (when text-color (SetTextColor dc text-color))
     ;; SetRop2 has no effect on text.  If you want to use
     ;; one, you have to draw into a bitmap and biblt that.
     t))
 
+(defmacro with-set-dc-for-text ((dc medium ink font) &body body)
+  `(with-dc-image-for-ink (..image..) (,medium ,ink)
+     (set-dc-for-text-1 ,dc ,font ..image..)
+     ,@body))
+
 (defgeneric dc-image-for-ink (medium ink))
 
 
diff --git a/aclpc/acl-frames.lisp b/aclpc/acl-frames.lisp
index 60cf2b4a2efb15fae5ad8ee5faed6950e0e8071b..6dd3abb013a931eff36d844c62d4134eb2390dfa 100644
--- a/aclpc/acl-frames.lisp
+++ b/aclpc/acl-frames.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-frames.lisp,v 1.10 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-frames.lisp,v 1.11 1999/07/19 22:25:09 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -36,8 +36,7 @@
 
 (defclass acl-frame-manager (standard-frame-manager)
     ((msmenubart :initarg :msmenubart :reader msmenubart))
-  (:default-initargs :dialog-view #+ignore +textual-dialog-view+
-		     +gadget-dialog-view+
+  (:default-initargs :dialog-view +gadget-dialog-view+
 		     :msmenubart t))
 
 (defmethod make-frame-manager ((port acl-port) &key palette)
@@ -95,10 +94,10 @@
 
 (defun keysymeql (keysyma keysymb)
   (or (eql keysyma keysymb)
-      (cond ((and (keywordp keysyma) (typep keysymb 'character))
+      (cond ((and (keywordp keysyma) (characterp keysymb))
 	     (eql keysyma (char->keysym keysymb))
 	     )
-	    ((and (keywordp keysymb) (typep keysyma 'character))
+	    ((and (keywordp keysymb) (characterp keysyma))
 	     (eql keysymb (char->keysym keysyma)))
 	    (t nil))))
 
@@ -261,7 +260,7 @@
 ;(win:EnableMenuItem menu menuid (if enablep win:MF_ENABLED win:MF_GRAYED))
 
 (defun keysym->char (keysym)
-  (if (typep keysym 'character)
+  (if (characterp keysym)
       keysym
   (let ((entry (rassoc keysym *keysym-alist*))
 	(code (position keysym *char->keysym*)))
@@ -395,10 +394,11 @@
 
 (defun make-menu-for-command-table (command-table menuhand frame 
 				    &optional top-level-sheet top-level-p)
+  (assert (valid-handle menuhand))
   (unless top-level-sheet
     (setq top-level-sheet (frame-top-level-sheet frame)))
-  ;; (re)initialize
-  (let ((count (win:getmenuitemcount menuhand)))
+  ;; First, delete any pre-existing menu items.
+  (let ((count (win:GetMenuItemCount menuhand)))
     (when (plusp count)
       (dotimes (position count)
 	;; Use position = 0 every time because the menu items get
@@ -433,14 +433,14 @@
 	      (record-accelerator frame acckey value top-level-sheet))
 	    (let ((menu-item-id (assign-command-menu-item-id value frame)))
 	      (excl:with-native-string (m (make-menu-text
-				      menu 
-				      ;; Don't display the accelerator key if
-				      ;; the command is going to land on the
-				      ;; menu bar itself,
-				      ;; Windows will not correctly display
-				      ;; such text.
-				      (if top-level-p nil acckey)
-				      item))
+					   menu 
+					   ;; Don't display the accelerator key if
+					   ;; the command is going to land on the
+					   ;; menu bar itself,
+					   ;; Windows will not correctly display
+					   ;; such text.
+					   (if top-level-p nil acckey)
+					   item))
 		(win:AppendMenu
 		 menuhand
 		 flags
@@ -471,14 +471,15 @@
 
 (defun compute-msmenu-bar-pane (frame top command-table)
   (let* ((mirror (sheet-mirror top))
-	 (menu-handle (win:GetMenu mirror))
+	 (menu-handle (win:GetMenu mirror)) 
 	 (command-table
 	  (if (listp command-table) (car command-table) command-table)))
     (when (silica::default-command-table-p command-table)
       ;; command-table arg comes from menu-bar slot of frame
       ;; and may be NIL T=menu-hbox-pane command-table-arg
-      (setq command-table (frame-command-table frame)))    
-    (make-menu-for-command-table command-table menu-handle frame top t)))
+      (setq command-table (frame-command-table frame)))
+    (when (valid-handle menu-handle)
+      (make-menu-for-command-table command-table menu-handle frame top t))))
 
 (defun update-menu-contents (sheet menuhand index)
   ;; Called just before making a menu active.  If the menu is associated
@@ -512,6 +513,17 @@
 			       win:MF_ENABLED
 			     win:MF_GRAYED)))))
 
+(defmethod frame-send-message (frame a b c d)
+  (let* ((me mp:*current-process*)
+	 (sheet (frame-top-level-sheet frame))
+	 (him (when sheet (clim-internals::sheet-thread sheet))))
+    (unless (eq me him)
+      ;; SendMessage will block, awaiting the response from the other thread.
+      ;; If the other thread sends a message to me, then you have a deadlock.
+      ;; So we have to have this restriction.
+      (error "SendMessage: attempt to send a message to a window in another thread"))
+    (win:SendMessage a b c d)))
+
 (defmethod initialize-tooltips ((frame standard-application-frame))
   ;; Create a tooltip control associated with this frame.
   ;; Note that this control won't do anything unless you
@@ -541,7 +553,9 @@
       (when (zerop tooltip-control)
 	(check-last-error "CreateWindow" :action :warn)
 	(return-from initialize-tooltips nil))
-      (win:SendMessage tooltip-control TTM_ACTIVATE 1 0)
+      (frame-send-message
+       (pane-frame sheet)
+       tooltip-control TTM_ACTIVATE 1 0)
       (flet ((tip (s)
 	       ;; I never got tool tips to work, so I didn't
 	       ;; really finish this part.  JPM 8/98.
@@ -553,13 +567,14 @@
 		uid (sheet-mirror s)
 		;;rect 0
 		hinst *hinst*
-		lpsztext -1 ;(coerce (string (type-of s)) 'simple-string)
+		lpsztext -1 
 		#+ign
 		(lisp-string-to-scratch-c-string 
 		 (princ-to-string label)))
 	       (setq status
-		 (win:SendMessage tooltip-control
-				  TTM_ADDTOOL 0 toolinfo))
+		 (frame-send-message frame
+				     tooltip-control
+				     TTM_ADDTOOL 0 toolinfo))
 	       (when (zerop status)
 		 (return-from initialize-tooltips nil))))
 	(declare (dynamic-extent #'tip))
@@ -627,6 +642,9 @@ to be run from another."
 (defmethod note-frame-deiconified ((framem acl-frame-manager) frame)
   (win:openicon (sheet-mirror (frame-top-level-sheet frame))))
 
+(defmethod accept-values-pane-p ((object t)) nil)
+(defmethod accept-values-pane-p ((object accept-values-pane)) t)
+
 (defmethod note-frame-enabled :around ((framem acl-frame-manager) frame)
   (call-next-method)
   (let ((*in-layout-avp* *in-layout-avp*)
@@ -634,7 +652,7 @@ to be run from another."
 	(avp nil))
     (when sheet
       (map-over-sheets #'(lambda (sheet)
-			   (when (typep sheet 'accept-values-pane)
+			   (when (accept-values-pane-p sheet)
 			     (setf avp t)))
 		       sheet)
       (setf *in-layout-avp* avp)
@@ -648,7 +666,7 @@ to be run from another."
         (*in-layout-frame* *in-layout-frame*))    
     (when (frame-top-level-sheet frame)
       (map-over-sheets #'(lambda (sheet)
-                           (when (typep sheet 'accept-values-pane)
+                           (when (accept-values-pane-p sheet)
                              (setf avp t)))
                        (frame-top-level-sheet frame))
       (setf *in-layout-frame* avp)
@@ -674,16 +692,9 @@ to be run from another."
   (let ((name (frame-pretty-name frame))
         (sheet (frame-top-level-sheet frame)))
     (when name
-      (let ((win (sheet-mirror sheet))
-            (cstr (ct:callocate (:char *) :size 256))
-	    (subsize (length name)))
-        (dotimes (i subsize)
-          (ct:cset (:char 256) cstr ((fixnum i)) (char-int (char name i))))
-	(ct:cset (:char 256) cstr ((fixnum subsize)) (char-int #\NULL))
-	(or #+removed (win:SetWindowText win cstr)
-	    (excl:with-native-string (cstr name)
-	      (win:SetWindowText win cstr))
-	    (check-last-error "SetWindowText"))))))
+      (or (excl:with-native-string (cstr name)
+	    (win:SetWindowText (sheet-mirror sheet) cstr))
+	  (check-last-error "SetWindowText")))))
 
 (defun select-messagebox-icon (style)
   ;; Decides which Windows icon matches this (standardized) style. 
@@ -768,401 +779,389 @@ to be run from another."
 		 ;; Use search rather than string-equal because
 		 ;; people tend to pad their labels with whitespace.
 		 (return-from find-label (first box)))))))
-    (cond ((= button-style win:mb_ok)
+    (cond ((= button-style win:MB_OK)
 	   (or (find-label "OK") :exit))
-	  ((= button-style win:mb_yesno)
-	   (cond ((= code win:idyes) (or (find-label "Yes") :exit))
-		 ((= code win:idno) (or (find-label "No") :abort))))
-	  ((= button-style win:mb_retrycancel)
-	   (cond ((= code win:idretry) (or (find-label "Retry") :exit))
-		 ((= code win:idcancel) (or (find-label "Cancel") :abort))))
-	  ((= button-style win:mb_okcancel)
+	  ((= button-style win:MB_YESNO)
+	   (cond ((= code win:IDYES) (or (find-label "Yes") :exit))
+		 ((= code win:IDNO) (or (find-label "No") :abort))))
+	  ((= button-style win:MB_RETRYCANCEL)
+	   (cond ((= code win:IDRETRY) (or (find-label "Retry") :exit))
+		 ((= code win:IDCANCEL) (or (find-label "Cancel") :abort))))
+	  ((= button-style win:MB_OKCANCEL)
 	   (cond ((= code win:idok) (or (find-label "OK") :exit))
-		 ((= code win:idcancel) (or (find-label "Cancel") :abort))))
-	  ((= button-style win:mb_yesnocancel)
-	   (cond ((= code win:idyes) (or (find-label "Yes") :exit))
-		 ((= code win:idno) (or (find-label "No") :no))
-		 ((= code win:idcancel) (or (find-label "Cancel") :abort))))
-	  ((= button-style win:mb_abortretryignore)
+		 ((= code win:IDCANCEL) (or (find-label "Cancel") :abort))))
+	  ((= button-style win:MB_YESNOCANCEL)
+	   (cond ((= code win:IDYES) (or (find-label "Yes") :exit))
+		 ((= code win:IDNO) (or (find-label "No") :no))
+		 ((= code win:IDCANCEL) (or (find-label "Cancel") :abort))))
+	  ((= button-style win:MB_ABORTRETRYIGNORE)
 	   (cond ((= code win:idabort) (or (find-label "Abort") :abort))
-		 ((= code win:idretry) (or (find-label "Retry") :retry))
-		 ((= code win:idignore) (or (find-label "Ignore") :exit)))))))
+		 ((= code win:IDRETRY) (or (find-label "Retry") :retry))
+		 ((= code win:IDIGNORE) (or (find-label "Ignore") :exit)))))))
 
 (defun message-box (hwnd message-string name &optional icon)
-  (excl:with-native-string (m (coerce message-string 'simple-string))
-    (excl:with-native-string (n (coerce name 'simple-string))
-       (win:messagebox hwnd
-		       m
-		       n
-		       (or icon 
-			   (logior win:MB_ICONSTOP 
-				   win:MB_TASKMODAL))))))
-
- (defmethod frame-manager-notify-user
-     ((framem acl-frame-manager) message-string
-      &key (style :inform)
-	   (frame nil frame-p)
-	   (associated-window
-	    (if frame-p
-		(frame-top-level-sheet frame)
-	      (graft framem)))
-	   (title "Notification") 
-	   documentation
-	   (exit-boxes '(:exit :abort))
-	   (name title)
-	   text-style
-      &allow-other-keys)
-   (declare (ignore documentation))	; FIXME
-   ;; Uses MessageBox() to put up a simple dialog box,
-   ;; unless the user has specified some fancy options, in
-   ;; which case accepting-values will have to suffice.
-   (let ((icon (select-messagebox-icon style))
-	 (buttons (select-messagebox-buttons exit-boxes)))
-     (if (and icon buttons (not text-style))
-	 (let* ((hwnd (sheet-mirror associated-window))
-		(code (message-box
-		       hwnd
-		       (coerce message-string 'simple-string) 
-		       (coerce name 'simple-string)
-		       (logior win:MB_TASKMODAL icon buttons)))
-		(symbol (select-messagebox-result code buttons exit-boxes)))
-	   ;; Notify-user is supposed to return T or NIL:
-	   (case symbol
-	     (:exit t)
-	     (:abort nil)
-	     (otherwise symbol)))
-       (let ((stream associated-window))
-	 (accepting-values (stream :exit-boxes exit-boxes
-				   :scroll-bars :both
-				   :label name
-				   :own-window t)
-	   (with-text-style (stream text-style)
-	     (write-string message-string stream)))))))
-
- (defun do-one-menu-item (popmenu item printer tick alist submenus)
-   (let ((*print-circle* nil))
-     (flet ((print-item (item)
-	      (silica::xlat-newline-return 
-	       (with-output-to-string (stream)
-		 ;; The click-right menu uses PRESENT at this point to
-		 ;; get the menu text, using the stream-default-view, which needs to be
-		 ;; set to textual-menu-view.
-		 (letf-globally (((stream-default-view stream) +textual-menu-view+))
-		   (funcall (or printer #'print-menu-item) item stream))))))
-       (declare (dynamic-extent #'print-item))
-       (incf tick)
-       (ecase (clim-internals::menu-item-type item)
-	 (:divider
-	  (win:appendmenu popmenu win:MF_SEPARATOR tick 0))
-	 (:label
-	  (excl:with-native-string (p-i (print-item item))
-	    (win:appendmenu popmenu win:MF_DISABLED tick 
-			    p-i)))
-	 (:item
-	  (if (clim-internals::menu-item-items item)
-	      (let ((submenu (win:createpopupmenu)))
-		(push submenu submenus)
-		;; submenu
-		(excl:with-native-string (p-i (print-item item))
-		  (win:appendmenu popmenu win:MF_POPUP submenu
-				  p-i))
-		(map nil
-		  #'(lambda (it)
-		      (multiple-value-setq (tick alist submenus)
-			(do-one-menu-item submenu it printer
-					  tick alist submenus)))
-		  (clim-internals::menu-item-items item)))
-	    (progn
-	      (push (list tick (menu-item-value item))
-		    alist)
-
-	      (excl:with-native-string (p-i (print-item item))
-		(if (clim-internals::menu-item-active item)
-		    (win:appendmenu popmenu win:MF_ENABLED tick 
-				    p-i)
+  (excl:with-native-string (m message-string)
+    (excl:with-native-string (n name)
+      (win:MessageBox hwnd m n
+		      (or icon 
+			  (logior win:MB_ICONSTOP 
+				  win:MB_TASKMODAL))))))
+ 
+(defmethod frame-manager-notify-user
+    ((framem acl-frame-manager) message-string
+     &key (style :inform)
+	  (frame nil frame-p)
+	  (associated-window
+	   (if frame-p
+	       (frame-top-level-sheet frame)
+	     (graft framem)))
+	  (title "Notification") 
+	  documentation
+	  (exit-boxes '(:exit :abort))
+	  (name title)
+	  text-style
+     &allow-other-keys)
+  (declare (ignore documentation))	; FIXME
+  ;; Uses MessageBox() to put up a simple dialog box,
+  ;; unless the user has specified some fancy options, in
+  ;; which case accepting-values will have to suffice.
+  (let ((icon (select-messagebox-icon style))
+	(buttons (select-messagebox-buttons exit-boxes)))
+    (if (and icon buttons (not text-style))
+	(let* ((hwnd (sheet-mirror associated-window))
+	       (code (message-box
+		      hwnd
+		      (coerce message-string 'simple-string) 
+		      (coerce name 'simple-string)
+		      (logior win:MB_TASKMODAL icon buttons)))
+	       (symbol (select-messagebox-result code buttons exit-boxes)))
+	  ;; Notify-user is supposed to return T or NIL:
+	  (case symbol
+	    (:exit t)
+	    (:abort nil)
+	    (otherwise symbol)))
+      (let ((stream associated-window))
+	(accepting-values (stream :exit-boxes exit-boxes
+				  :scroll-bars :both
+				  :label name
+				  :own-window t)
+	  (with-text-style (stream text-style)
+	    (write-string message-string stream)))))))
+
+(defun do-one-menu-item (popmenu item printer tick alist submenus)
+  (let ((*print-circle* nil))
+    (flet ((print-item (item)
+	     (silica::xlat-newline-return 
+	      (with-output-to-string (stream)
+		;; The click-right menu uses PRESENT at this point to
+		;; get the menu text, using the stream-default-view, which needs to be
+		;; set to textual-menu-view.
+		(letf-globally (((stream-default-view stream) +textual-menu-view+))
+		  (funcall (or printer #'print-menu-item) item stream))))))
+      (declare (dynamic-extent #'print-item))
+      (incf tick)
+      (ecase (clim-internals::menu-item-type item)
+	(:divider
+	 (win:AppendMenu popmenu win:MF_SEPARATOR tick 0))
+	(:label
+	 (excl:with-native-string (p-i (print-item item))
+	   (win:AppendMenu popmenu win:MF_DISABLED tick 
+			   p-i)))
+	(:item
+	 (if (clim-internals::menu-item-items item)
+	     (let ((submenu (win:CreatePopupMenu)))
+	       (push submenu submenus)
+	       ;; submenu
+	       (excl:with-native-string (p-i (print-item item))
+		 (win:AppendMenu popmenu win:MF_POPUP submenu
+				 p-i))
+	       (map nil
+		 #'(lambda (it)
+		     (multiple-value-setq (tick alist submenus)
+		       (do-one-menu-item submenu it printer
+					 tick alist submenus)))
+		 (clim-internals::menu-item-items item)))
+	   (progn
+	     (push (list tick (menu-item-value item))
+		   alist)
+	     
+	     (excl:with-native-string (p-i (print-item item))
+	       (if (clim-internals::menu-item-active item)
+		   (win:AppendMenu popmenu win:MF_ENABLED tick 
+				   p-i)
 		;;; Use win:MF_GRAYED rather than win:MF_DISABLED.
 		;;; The latter will also disable the command, but
 		;;; doesn't seem to affect the appearance.	       
-		  (win:appendmenu popmenu win:MF_GRAYED tick 
-				  p-i)))))))
-       (values tick alist submenus))))
-
- ;; Gets rid of scroll bars if possible.
- (defmethod frame-manager-menu-choose
-     ((framem acl-frame-manager) items &rest keys
-      &key printer
-	   presentation-type
-	   (associated-window (frame-top-level-sheet *application-frame*))
-	   text-style label
-	   foreground background
-	   cache
-	   (unique-id items)
-	   (id-test 'equal)
-	   (cache-value items)
-	   (cache-test #'equal)
-	   (gesture :select)
-	   row-wise
-	   n-columns
-	   n-rows
-	   x-position
-	   y-position
-	   scroll-bars)
-   ;; The basic theory of ignoring is that we ignore arguments
-   ;; that don't contribute functionality and just bring up
-   ;; the native menu without any fluff.
-   (declare (ignore text-style cache
-		    cache-test cache-value
-		    id-test unique-id label
-		    foreground background))
-   (if (or presentation-type ;; foreground background  
-	   row-wise n-columns n-rows scroll-bars)
-       (call-next-method)
-     #+simple-but-sure
-     (apply #'call-next-method framem items :scroll-bars nil keys)
-     (let ((popmenu (win:CreatePopupMenu))
-	   (submenus nil)
-	   (flags (logior win:tpm_returncmd ; return the selection
-			  win:tpm_nonotify ; don't notify clim
-			  (if (eq gesture :menu) 
-			      win:tpm_rightbutton
-			    win:tpm_leftbutton)))
-	   (rect 0)
-	   (tick 0)
-	   (alist nil)
-	   (code 0))
-       (when (zerop popmenu)
-	 (check-last-error "CreatePopupMenu"))
-       (unless (and x-position y-position)
-	 ;; Get screen coordinates of pointer.
-	 (let ((point (ct:ccallocate win:point)))
-	   (or (win:getCursorPos point)
-	       (check-last-error "GetCursorPos"))
-	   (setq x-position (ct:cref win:point point x))
-	   (setq y-position (ct:cref win:point point y))))
-       (setq x-position (truncate x-position))
-       (setq y-position (truncate y-position))
-       (map nil #'(lambda (item)
-		    (multiple-value-setq (tick alist submenus)
-		      (do-one-menu-item popmenu item printer 
-					tick alist submenus)))
-	    items)
-       ;; Bug here, exhibited by CAD Demo Create, that menu
-       ;; is sometimes never exposed.  TrackPopupMenu returns 0.  
-       ;; But most of the time this seems to work... 5/98 JPM.
-       (setq code
-	 (win:trackpopupmenu
-	  popmenu flags x-position y-position 
-	  0				; reserved, must be zero
-	  (sheet-mirror associated-window) rect))
-       (win:destroymenu popmenu)
-       (dolist (submenu submenus) (win:destroymenu submenu))
-       (cond ((zerop code)		; no item is selected
-	      nil)
-	     (t
-	      (let ((x (assoc code alist)))
-		(values (second x) (third x) :unknown-gesture))
-	      )))))
-
- (defun make-filter-string (dotted-pair)
-   (let ((*print-circle* nil))
-     (format nil "~a (~a)~a~a~a"
-	     (car dotted-pair) (cdr dotted-pair) (code-char 0)
-	     (cdr dotted-pair) (code-char 0))))
-
- (eval-when (compile load eval) 
-   ;; All pathnames returned by SELECT-FILE must fit in the scratch string,
-   ;; so make it pretty big.
-   (defconstant *scratch-string-length* 2048)
-   )
-
- (defparameter *scratch-lisp-string*
-     (make-string *scratch-string-length*))
-
- (defparameter *scratch-c-string*
-   (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*)))
-
- (defun lisp-string-to-scratch-c-string (lisp-string)
-   (let ((length (min (length lisp-string)
-		      (1- *scratch-string-length*))))
-     (dotimes (i length 
-		;; null term
-		(setf (ff:fslot-value-c '(:array :char 1)
-					 *scratch-c-string*
-					 length) 0))
-       (setf (ff:fslot-value-c '(:array char 1) *scratch-c-string*
-				i)
-	 (char-int (aref lisp-string i))))
-     *scratch-c-string*
-     ))
-
- (defun scratch-c-string-to-lisp-string ()
-   (ff:char*-to-string *scratch-c-string*))
-
- (defun pathnames-from-directory-and-filenames (filename-list)
-   ;; Takes a list consisting of a directory namestring followed
-   ;; by a set of filenames relative to that directory.
-   ;; This is the sort of list returned by the common dialog
-   ;; when multiple choices are allowed.
-   ;; Returns a list of complete pathnames.
-   (if (eq (length filename-list) 1)
-       ;; If only one choice, no separate directory is returned
-       ;; by the GetOpenFileName call.
-       filename-list
-     (let ((directory (car filename-list)))
-       ;; Windows doesn't stick a backslash on the end of the dir.
-       (unless (eql (aref directory (1- (length directory))) #\\)
-	 (setf directory (concatenate 'string directory "\\")))
-       (mapcar #'(lambda (filename)
-		   ;; cac removed call to namestring to have this function
-		   ;; return pathnames instead of strings.
-		   ;; 5-apr-94
-		   (merge-pathnames filename directory))
-	       (cdr filename-list)))))
-
- (defun delimited-string-to-list (string delimiter-char-or-string)
-   "Returns a list of substrings of STRING, separating it at DELIMETER-CHAR-OR-STRING"
-   (do* ((stringp (stringp delimiter-char-or-string))
-	 (delimiter-length (if stringp
-			       (length delimiter-char-or-string)
-			     1))
-	 (s string (subseq s (+ index delimiter-length)))
-	 (index
-	  (if stringp
-	      (search delimiter-char-or-string s)
-	    (position delimiter-char-or-string s))
-	  (if stringp
-	      (search delimiter-char-or-string s)
-	    (position delimiter-char-or-string s)))
-	 (list
-	  (list (subseq s 0 index))
-	  (nconc list (list (subseq s 0 index)))))
-       ((null index)
-	list)))
-
- (defun spaced-string-to-list (string) ;; <27>
-   (delimited-string-to-list string #\space))
-
- (cl:defparameter common-dialog-errors
-  '((#xffff . cderr_dialogfailure)
-    (#x0000 . cderr_generalcodes)
-    (#x0001 . cderr_structsize)
-    (#x0002 . cderr_initialization)
-    (#x0003 . cderr_notemplate)
-    (#x0004 . cderr_nohinstance)
-    (#x0005 . cderr_loadstrfailure)
-    (#x0006 . cderr_findresfailure)
-    (#x0007 . cderr_loadresfailure)
-    (#x0008 . cderr_lockresfailure)
-    (#x0009 . cderr_memallocfailure)
-    (#x000a . cderr_memlockfailure)
-    (#x000b . cderr_nohook)
-    (#x000c . cderr_registermsgfail)
-    (#x1000 . pderr_printercodes)
-    (#x1001 . pderr_setupfailure)
-    (#x1002 . pderr_parsefailure)
-    (#x1003 . pderr_retdeffailure)
-    (#x1004 . pderr_loaddrvfailure)
-    (#x1005 . pderr_getdevmodefail)
-    (#x1006 . pderr_initfailure)
-    (#x1007 . pderr_nodevices)
-    (#x1008 . pderr_nodefaultprn)
-    (#x1009 . pderr_dndmmismatch)
-    (#x100a . pderr_createicfailure)
-    (#x100b . pderr_printernotfound)
-    (#x100c . pderr_defaultdifferent)
-    (#x2000 . cferr_choosefontcodes)
-    (#x2001 . cferr_nofonts)
-    (#x2002 . cferr_maxlessthanmin)
-    (#x3000 . fnerr_filenamecodes)
-    (#x3001 . fnerr_subclassfailure)
-    (#x3002 . fnerr_invalidfilename)
-    (#x3003 . fnerr_buffertoosmall)
-    (#x4000 . frerr_findreplacecodes)
-    (#x4001 . frerr_bufferlengthzero)
-    (#x5000 . ccerr_choosecolorcodes)
-    ))
-
- (defun get-pathname-flags (save-p multiple-p warn-if-exists-p)
-   (logior
-    (if multiple-p win:OFN_ALLOWMULTISELECT 0)
-    (if save-p 0 win:OFN_FILEMUSTEXIST)
-    ;; This is only relevant if save-p:
-    (if warn-if-exists-p win:OFN_OVERWRITEPROMPT 0)
-    win:OFN_NOCHANGEDIR
-    win:OFN_HIDEREADONLY))
-
- (defun get-pathname (prompt directory stream allowed-types initial-name
-		      save-p multiple-p warn-if-exists-p)
-   (flet ((fill-c-string (string)
-	    (let ((c-string (ff:allocate-fobject-c '(:array :char 256)))
-		  (length (length string)))
-	      (assert (< length 255))
-	      (dotimes (i length)
-		(setf (ff:fslot-value-c '(:array char 1) c-string i)
-		  (char-int (aref string i))))
-	      (setf (ff:fslot-value-c '(:array :char 1) c-string length)
-		0)
-	      c-string)))
-     (let* ((open-file-struct (ct:ccallocate win:openfilename))
-	    (file-filter-string 
-	     (fill-c-string
-	      (apply #'concatenate 'string
-		     (mapcar #'make-filter-string allowed-types))))
-	    (initial-dir-string (fill-c-string (string directory)))
-	    (prompt-string (fill-c-string (string prompt))))
-       (excl:with-native-string (file-filter-string file-filter-string)
-	 (excl:with-native-string (s1 (lisp-string-to-scratch-c-string (or initial-name "")))
-	   (excl:with-native-string (initial-dir-string initial-dir-string)
-	     (excl:with-native-string (prompt-string prompt-string)
-
-	       (ct:csets win:openfilename open-file-struct
-			 lstructsize (ct:sizeof win:openfilename)
-			 hwndowner (or (and stream (sheet-mirror stream))
-				       0)
-			 hinstance 0	; no custom dialog
-			 lpstrfilter file-filter-string
-			 lpstrcustomfilter 0 
-			 nmaxcustfilter 0 ;; length of custom filter string
-			 nfilterindex 0	; zero means use custom-filter if supplied
-					 ; otherwise the first filter in the list
-			 lpstrfile s1
-			 nmaxfile *scratch-string-length*
-			 lpstrfiletitle 0 
-			 nmaxfiletitle 0
-			 lpstrinitialdir initial-dir-string
-			 lpstrtitle prompt-string
-			 flags (get-pathname-flags save-p multiple-p warn-if-exists-p)
-			 nfileoffset 0
-			 nfileextension 0 
-			 lpstrdefext 0
-			 lcustdata 0
-			 lpfnhook 0
-			 lptemplatename 0
-			 )))))
-             (let* ((result 
-	      (if save-p
-		  (win:GetSaveFileName open-file-struct)
-		(win:GetOpenFileName open-file-struct))))
-	(ff:free-fobject-c file-filter-string)
-	(ff:free-fobject-c initial-dir-string)
-	(ff:free-fobject-c prompt-string)
-	(if result ;; t means no errors and user said "OK"
-	    (if multiple-p
-		(pathnames-from-directory-and-filenames
-		 (spaced-string-to-list
-		  (string-downcase
-		   (scratch-c-string-to-lisp-string))))
-	      (pathname
-	       (string-downcase
-		(scratch-c-string-to-lisp-string))))
-	  (let ((error-code (win:CommDlgExtendedError)))
-	    (and (plusp error-code) ;; zero means cancelled, so return NIL
-		 (error (format nil 
-				"Common dialog error ~a."
-				(or (cdr (assoc error-code
-						common-dialog-errors))
-				    error-code))))))))))
+		 (win:AppendMenu popmenu win:MF_GRAYED tick 
+				 p-i)))))))
+      (values tick alist submenus))))
+
+;; Gets rid of scroll bars if possible.
+(defmethod frame-manager-menu-choose
+    ((framem acl-frame-manager) items &rest keys
+     &key printer
+	  presentation-type
+	  (associated-window (frame-top-level-sheet *application-frame*))
+	  text-style label
+	  foreground background
+	  cache
+	  (unique-id items)
+	  (id-test 'equal)
+	  (cache-value items)
+	  (cache-test #'equal)
+	  (gesture :select)
+	  row-wise
+	  n-columns
+	  n-rows
+	  x-position
+	  y-position
+	  scroll-bars)
+  ;; The basic theory of ignoring is that we ignore arguments
+  ;; that don't contribute functionality and just bring up
+  ;; the native menu without any fluff.
+  (declare (ignore text-style cache
+		   cache-test cache-value
+		   id-test unique-id label
+		   foreground background))
+  (if (or presentation-type ;; foreground background  
+	  row-wise n-columns n-rows scroll-bars)
+      (call-next-method)
+    #+simple-but-sure
+    (apply #'call-next-method framem items :scroll-bars nil keys)
+    (let ((popmenu (win:CreatePopupMenu))
+	  (submenus nil)
+	  (flags (logior win:tpm_returncmd ; return the selection
+			 win:tpm_nonotify ; don't notify clim
+			 (if (eq gesture :menu) 
+			     win:tpm_rightbutton
+			   win:tpm_leftbutton)))
+	  (rect 0)
+	  (tick 0)
+	  (alist nil)
+	  (code 0))
+      (when (zerop popmenu)
+	(check-last-error "CreatePopupMenu"))
+      (unless (and x-position y-position)
+	;; Get screen coordinates of pointer.
+	(let ((point (ct:ccallocate win:point)))
+	  (or (win:getCursorPos point)
+	      (check-last-error "GetCursorPos"))
+	  (setq x-position (ct:cref win:point point x))
+	  (setq y-position (ct:cref win:point point y))))
+      (setq x-position (truncate x-position))
+      (setq y-position (truncate y-position))
+      (map nil #'(lambda (item)
+		   (multiple-value-setq (tick alist submenus)
+		     (do-one-menu-item popmenu item printer 
+				       tick alist submenus)))
+	   items)
+      ;; Bug here, exhibited by CAD Demo Create, that menu
+      ;; is sometimes never exposed.  TrackPopupMenu returns 0.  
+      ;; But most of the time this seems to work... 5/98 JPM.
+      (setq code
+	(win:trackpopupmenu
+	 popmenu flags x-position y-position 
+	 0				; reserved, must be zero
+	 (sheet-mirror associated-window) rect))
+      (win:destroymenu popmenu)
+      (dolist (submenu submenus) (win:destroymenu submenu))
+      (cond ((zerop code)		; no item is selected
+	     nil)
+	    (t
+	     (let ((x (assoc code alist)))
+	       (values (second x) (third x) :unknown-gesture))
+	     )))))
+
+(defun make-filter-string (dotted-pair)
+  (let ((*print-circle* nil))
+    (format nil "~a (~a)~a~a~a"
+	    (car dotted-pair) (cdr dotted-pair) (code-char 0)
+	    (cdr dotted-pair) (code-char 0))))
+
+(eval-when (compile load eval) 
+  ;; All pathnames returned by SELECT-FILE must fit in the scratch string,
+  ;; so make it pretty big.
+  (defconstant *scratch-string-length* 2048)
+  )
+
+(defparameter *scratch-lisp-string*
+    (make-string *scratch-string-length*))
 
+(defparameter *scratch-c-string*
+  (ff:allocate-fobject-c `(:array :char ,*scratch-string-length*)))
+
+(eval-when (compile eval load)
+  ;; this type useful since we don't open code anonymous types well yet:
+  (ff:def-foreign-type foreign-string (:array :char 1))
+  )
+
+(defun lisp-string-to-scratch-c-string (lisp-string)
+  (let ((length (min (length lisp-string)
+		     (1- *scratch-string-length*))))
+    (dotimes (i length 
+	       ;; null term
+	       (setf (ff:fslot-value-typed 'acl-clim::foreign-string
+					   :c
+					   *scratch-c-string*
+					   length)
+		 0))
+      (setf (ff:fslot-value-typed 'acl-clim::foreign-string
+				  :c
+				  *scratch-c-string*
+				  i)
+	(char-int (aref lisp-string i))))
+    *scratch-c-string*))
+
+(defun scratch-c-string-to-lisp-string ()
+  (ff:char*-to-string *scratch-c-string*))
+
+(defun pathnames-from-directory-and-filenames (filename-list)
+  ;; Takes a list consisting of a directory namestring followed
+  ;; by a set of filenames relative to that directory.
+  ;; This is the sort of list returned by the common dialog
+  ;; when multiple choices are allowed.
+  ;; Returns a list of complete pathnames.
+  (if (eq (length filename-list) 1)
+      ;; If only one choice, no separate directory is returned
+      ;; by the GetOpenFileName call.
+      filename-list
+    (let ((directory (car filename-list)))
+      ;; Windows doesn't stick a backslash on the end of the dir.
+      (unless (eql (aref directory (1- (length directory))) #\\)
+	(setf directory (concatenate 'string directory "\\")))
+      (mapcar #'(lambda (filename)
+		  ;; cac removed call to namestring to have this function
+		  ;; return pathnames instead of strings.
+		  ;; 5-apr-94
+		  (merge-pathnames filename directory))
+	      (cdr filename-list)))))
+
+(defun delimited-string-to-list (string delimiter-char-or-string)
+  "Returns a list of substrings of STRING, separating it at DELIMETER-CHAR-OR-STRING"
+  (do* ((stringp (stringp delimiter-char-or-string))
+	(delimiter-length (if stringp
+                              (length delimiter-char-or-string)
+			    1))
+	(s string (subseq s (+ index delimiter-length)))
+	(index
+	 (if stringp
+	     (search delimiter-char-or-string s)
+	   (position delimiter-char-or-string s))
+	 (if stringp
+	     (search delimiter-char-or-string s)
+	   (position delimiter-char-or-string s)))
+	(list
+	 (list (subseq s 0 index))
+	 (nconc list (list (subseq s 0 index)))))
+      ((null index)
+       list)))
+
+(defun spaced-string-to-list (string) ;; <27>
+  (delimited-string-to-list string #\space))
+
+(cl:defparameter common-dialog-errors
+ '((#xffff . cderr_dialogfailure)
+   (#x0000 . cderr_generalcodes)
+   (#x0001 . cderr_structsize)
+   (#x0002 . cderr_initialization)
+   (#x0003 . cderr_notemplate)
+   (#x0004 . cderr_nohinstance)
+   (#x0005 . cderr_loadstrfailure)
+   (#x0006 . cderr_findresfailure)
+   (#x0007 . cderr_loadresfailure)
+   (#x0008 . cderr_lockresfailure)
+   (#x0009 . cderr_memallocfailure)
+   (#x000a . cderr_memlockfailure)
+   (#x000b . cderr_nohook)
+   (#x000c . cderr_registermsgfail)
+   (#x1000 . pderr_printercodes)
+   (#x1001 . pderr_setupfailure)
+   (#x1002 . pderr_parsefailure)
+   (#x1003 . pderr_retdeffailure)
+   (#x1004 . pderr_loaddrvfailure)
+   (#x1005 . pderr_getdevmodefail)
+   (#x1006 . pderr_initfailure)
+   (#x1007 . pderr_nodevices)
+   (#x1008 . pderr_nodefaultprn)
+   (#x1009 . pderr_dndmmismatch)
+   (#x100a . pderr_createicfailure)
+   (#x100b . pderr_printernotfound)
+   (#x100c . pderr_defaultdifferent)
+   (#x2000 . cferr_choosefontcodes)
+   (#x2001 . cferr_nofonts)
+   (#x2002 . cferr_maxlessthanmin)
+   (#x3000 . fnerr_filenamecodes)
+   (#x3001 . fnerr_subclassfailure)
+   (#x3002 . fnerr_invalidfilename)
+   (#x3003 . fnerr_buffertoosmall)
+   (#x4000 . frerr_findreplacecodes)
+   (#x4001 . frerr_bufferlengthzero)
+   (#x5000 . ccerr_choosecolorcodes)
+   ))
+
+(defun get-pathname-flags (save-p multiple-p warn-if-exists-p)
+  (logior
+   (if multiple-p win:OFN_ALLOWMULTISELECT 0)
+   (if save-p 0 win:OFN_FILEMUSTEXIST)
+   ;; This is only relevant if save-p:
+   (if warn-if-exists-p win:OFN_OVERWRITEPROMPT 0)
+   win:OFN_NOCHANGEDIR
+   win:OFN_HIDEREADONLY))
+
+(defun get-pathname (prompt directory stream allowed-types initial-name
+		     save-p multiple-p warn-if-exists-p)
+  (let ((open-file-struct (ct:ccallocate win:openfilename)))
+    (excl:with-native-string
+	(file-filter-string
+	 (apply #'concatenate 'string
+		(mapcar #'make-filter-string allowed-types)))
+      (let ((s1 (lisp-string-to-scratch-c-string (or initial-name ""))))
+	(excl:with-native-string (initial-dir-string (string directory))
+	  (excl:with-native-string (prompt-string (string prompt))
+
+	    (ct:csets win:openfilename open-file-struct
+		      lstructsize (ct:sizeof win:openfilename)
+		      hwndowner (or (and stream (sheet-mirror stream))
+				    0)
+		      hinstance 0	; no custom dialog
+		      lpstrfilter file-filter-string
+		      lpstrcustomfilter 0 
+		      nmaxcustfilter 0 ;; length of custom filter string
+		      nfilterindex 0	; zero means use custom-filter if supplied
+					; otherwise the first filter in the list
+		      lpstrfile s1
+		      nmaxfile *scratch-string-length*
+		      lpstrfiletitle 0 
+		      nmaxfiletitle 0
+		      lpstrinitialdir initial-dir-string
+		      lpstrtitle prompt-string
+		      flags (get-pathname-flags save-p multiple-p warn-if-exists-p)
+		      nfileoffset 0
+		      nfileextension 0 
+		      lpstrdefext 0
+		      lcustdata 0
+		      lpfnhook 0
+		      lptemplatename 0)))))
+    (let* ((result 
+	    (if save-p
+		(win:GetSaveFileName open-file-struct)
+	      (win:GetOpenFileName open-file-struct))))
+      (if result ;; t means no errors and user said "OK"
+	  (if multiple-p
+	      (pathnames-from-directory-and-filenames
+	       (spaced-string-to-list
+		(string-downcase
+		 (scratch-c-string-to-lisp-string))))
+	    (pathname
+	     (string-downcase
+	      (scratch-c-string-to-lisp-string))))
+	(let ((error-code (win:CommDlgExtendedError)))
+	  (and (plusp error-code) ;; zero means cancelled, so return NIL
+	       (error (format nil 
+			      "Common dialog error ~a."
+			      (or (cdr (assoc error-code
+					      common-dialog-errors))
+				  error-code)))))))))
 
 (defun get-directory (sheet title)
   (let* ((info (ct:ccallocate browseinfo)))
@@ -1431,10 +1430,13 @@ to be run from another."
 				  win:swp_nosize))
 	(acl-clim::check-last-error "SetWindowPos"))))
 
+(defmethod accept-values-frame-p ((object t)) nil)
+(defmethod accept-values-frame-p ((object clim-internals::accept-values-own-window)) t)
+
 (defmethod handle-event ((pane sheet) (event silica::window-close-event))
   (let ((frame (pane-frame pane)))
     (cond ((not frame))
-	  ((typep frame 'clim-internals::accept-values-own-window)
+	  ((accept-values-frame-p frame)
 	   ;; A window-close-event is supposed to equate to a "cancel" gesture.
 	   (abort))
 	  (t (frame-exit frame)))))
@@ -1577,3 +1579,243 @@ in a second Lisp process.  This frame cannot be reused."
 	     win:swp_nozorder
 	     win:swp_nosize)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Printer support
+
+(defun setup-escape-buffer (buffer code string)
+  (let ((length (length string)))
+    (assert (< length 1024))
+    ;; The header is the size of a "word"
+    (setf (ff:fslot-value-typed 'acl-clim::foreign-string :foreign buffer 0) 
+      (ldb (byte 8 0) code))
+    (setf (ff:fslot-value-typed 'acl-clim::foreign-string :foreign buffer 1) 
+      (ldb (byte 8 8) code))
+    (setf (ff:fslot-value-typed 'acl-clim::foreign-string :foreign buffer 2) 
+      (ldb (byte 8 16) code))
+    (setf (ff:fslot-value-typed 'acl-clim::foreign-string :foreign buffer 3) 
+      (ldb (byte 8 24) code))
+    ;; The rest is the actual string.
+    (dotimes (i length)
+      (setf (ff:fslot-value-typed 'acl-clim::foreign-string :foreign
+				  buffer (+ i 4))
+	(char-code (char string i))))
+    buffer))
+
+(defun print-postscript (filename printer)
+  ;; Print a file as postscript.
+  ;; 'printer' is an hdc
+  (assert (stringp filename))
+  (assert (acl-clim::valid-handle printer))
+  (let ((code 1)
+	(buffer (ff:allocate-fobject-c '(:array :char 1024)))
+	(prcode 4115 #+ig win:POSTSCRIPT_PASSTHROUGH)
+	(isa-psprinter t)
+	(docinfo (ff:allocate-fobject 'win:docinfo :foreign-static-gc)))
+
+    (setf (ct:cref win:docinfo docinfo cbSize) (ct:sizeof win:docinfo))
+    #+ignore
+    (excl:with-native-string (cstr filename)
+      (setf (ct:cref win:docinfo docinfo lpszDocName) cstr))
+    (setf (ct:cref win:docinfo docinfo lpszDocName) 
+      (ff:string-to-char* filename))
+    (setf (ct:cref win:docinfo docinfo lpszOutput) 0)
+    (setf (ct:cref win:docinfo docinfo lpszDatatype) 0)
+    (setf (ct:cref win:docinfo docinfo fwType) 0)
+    
+    (setup-escape-buffer buffer prcode "")
+    (setq isa-psprinter
+      (plusp (win:Escape printer win:QUERYESCSUPPORT 
+			 4 buffer 0)))
+    (unless isa-psprinter
+      (return-from print-postscript :error-postscript-not-supported))
+    (or (plusp (win:StartDoc printer docinfo))
+	(acl-clim::check-last-error "StartDoc"))
+    (with-open-file (stream filename :direction :input)
+      (loop 
+	(let ((line (read-line stream nil nil nil)))
+	  (unless line (return))
+	  (setup-escape-buffer buffer (length line) line)
+	  (win:Escape printer prcode (+ (length line) 4) buffer 0))))
+    (setq code (win:EndDoc printer))
+    (cond ((plusp code) nil)
+	  (t (acl-clim::check-last-error "EndDoc")
+	     :error))))
+
+(defun print-ascii (filename printer &key (xmargin 5) (ymargin 5))
+  ;; Print a file as plain ascii text.
+  ;; 'printer' is an hdc
+  (assert (stringp filename))
+  (assert (acl-clim::valid-handle printer))
+  (let ((code 0)
+	(x xmargin)
+	(y ymargin)
+	(currentline 0)
+	(lines-per-page nil)
+	(pagesize (win:GetDeviceCaps printer win:VERTRES))
+	(line-height 12)
+	(char-width 12)
+	(textmetric (ct:ccallocate win:textmetric))
+	(docinfo (ff:allocate-fobject 'win:docinfo :foreign-static-gc)))
+    (or (win:GetTextMetrics printer textmetric)
+	(acl-clim::check-last-error "GetTextMetrics"))
+    (setq line-height 
+      (+ (ct:cref win:textmetric textmetric tmHeight)
+	 (ct:cref win:textmetric textmetric tmExternalLeading)))
+    (setq char-width (ct:cref win:textmetric textmetric tmMaxCharWidth))
+    (setq ymargin (* ymargin line-height))
+    (setq xmargin (* xmargin char-width))
+    (setq x xmargin y ymargin)
+
+    (setf (ct:cref win:docinfo docinfo cbSize) (ct:sizeof win:docinfo))
+    #+ignore
+    (excl:with-native-string (cstr filename)
+      (setf (ct:cref win:docinfo docinfo lpszDocName) cstr))
+    (setf (ct:cref win:docinfo docinfo lpszDocName) 
+      (ff:string-to-char* filename))
+    (setf (ct:cref win:docinfo docinfo lpszOutput) 0)
+    (setf (ct:cref win:docinfo docinfo lpszDatatype) 0)
+    (setf (ct:cref win:docinfo docinfo fwType) 0)
+    
+    (decf pagesize (+ ymargin ymargin))    
+    (setq lines-per-page (1- (truncate pagesize line-height)))
+    
+    (or (plusp (win:StartDoc printer docinfo))
+	(acl-clim::check-last-error "StartDoc"))
+    (progn
+      (win:StartPage printer)
+      (with-open-file (stream filename :direction :input)
+	(loop 
+	  (let ((line (read-line stream nil nil nil)))
+	    (unless line (return))
+	    (multiple-value-bind (string i)
+		(silica::xlat-newline-return line)
+	      (excl:with-native-string (cstr string)
+		(win:TextOut printer x y cstr i)))
+	    (incf currentline)
+	    (incf y line-height)
+	    (when (> currentline lines-per-page)
+	      (win:EndPage printer)
+	      (win:StartPage printer)
+	      (setq currentline 1)
+	      (setq y ymargin))
+	    )))
+      (win:EndPage printer))
+    (setq code (win:EndDoc printer))
+    (cond ((plusp code) nil)
+	  (t (acl-clim::check-last-error "EndDoc")
+	     :error))))
+
+(defun determine-print-file-type (filename)
+  (unless (probe-file filename)
+    (return-from determine-print-file-type :none))
+  (with-open-file (stream filename :direction :input)
+    (let ((char1 (read-char stream nil nil nil))
+	  (char2 (read-char stream nil nil nil)))
+      (unless char1
+	(return-from determine-print-file-type :empty))
+      (cond ((and char2 (char= char1 #\%) (char= char2 #\!))
+	     :postscript)
+	    (t :ascii)))))
+
+(defmethod frame-manager-print-file
+    ((framem acl-clim::acl-frame-manager) filename
+     &key 	  
+     (frame nil frame-p)
+     (associated-window
+      (if frame-p
+	  (frame-top-level-sheet frame)
+	(graft framem)))
+     from-page to-page min-page max-page
+     ncopies collate-p 
+     print-to-file-p disable-print-to-file (hide-print-to-file t)
+     nopagenums noselection selection
+     nowarning nodialog)
+  (let* ((printdlg (ct:ccallocate win:printdlg))
+	 (hwnd (if associated-window (sheet-mirror associated-window) 0)))
+    (ct:csets win:printdlg printdlg
+	      lStructSize (ct:sizeof win:printdlg)
+	      hwndOwner hwnd
+	      hDevMode 0
+	      hdevnames 0        
+	      hdc 0
+	      flags (logior 
+		     ;; check the collate box
+		     (if collate-p win:pd_collate 0)
+		     ;; disable the printtofile check box
+		     (if disable-print-to-file win:pd_disableprinttofile 0)
+		     ;; hide the printtofile check box
+		     (if hide-print-to-file win:pd_hideprinttofile 0)
+		     ;; disable the pages radio button
+		     (if nopagenums win:pd_nopagenums 0)
+		     ;; disable the selection radio button
+		     (if noselection win:pd_noselection 0)
+		     ;; Prevents warning message from being displayed
+		     ;; when there is no default printer.
+		     (if nowarning win:pd_nowarning 0)
+		     ;; selects the pages radio button
+		     (if (or from-page to-page) win:pd_pagenums win:pd_allpages)
+		     ;; selects the printtofile check box
+		     (if print-to-file-p win:pd_printtofile 0)
+		     ;; suppress the dialog box
+		     (if nodialog win:psd_returndefault 0)
+		     ;; selects the selection radio button
+		     (if selection win:pd_selection 0)
+		     ;; return a device context to the printer
+		     win:pd_returndc)
+	      nfrompage (or from-page #xffff)
+	      ntopage (or to-page #xffff)
+	      nminpage (or min-page 1)
+	      nmaxpage (or max-page #xffff)
+	      ncopies (or ncopies 1))
+    (cond ((not (win:PrintDlg printdlg)) 
+	   ;; User cancelled, or there was an error.
+	   (let ((code (win:CommDlgExtendedError)))
+	     (if (zerop code) 
+		 nil			
+	       ;; Code will be among CDERR_* or PDERR_* families
+	       (error "PrintDlg failed with error code ~A" code))))
+	  (t
+	   (let ((hdc (ct:cref win:printdlg printdlg hdc)))
+	     (unwind-protect
+		 (ecase (determine-print-file-type filename)
+		   (:postscript 
+		    (case (print-postscript filename hdc)
+		      (:error-postscript-not-supported
+		       (frame-manager-notify-user
+			framem
+			"Printing Error: Printer does not support postscript"
+			:style :error))
+		      (:error
+		       (frame-manager-notify-user
+			framem
+			"Printing Error: Cannot print file"
+			:style :error)
+		       )))
+		   (:ascii 
+		    (case (print-ascii filename hdc)
+		      (:error
+		       (frame-manager-notify-user 
+			framem
+			"Printing Error: Cannot print file"
+			:style :error))))
+		   (:none
+		    (frame-manager-notify-user 
+		     framem
+		     "Printing Error: File does not exist"
+		     :style :error))
+		   (:empty
+		    (frame-manager-notify-user 
+		     framem
+		     "Printing Error: File is empty"
+		     :style :error)))
+	       (win:DeleteDC hdc)
+	       ))))))
+
+#+ignore
+(defun tester ()
+  (with-open-file (s "c:/tester.ps" :direction :output
+		   :if-exists :supersede)
+    (clim:with-output-to-postscript-stream (stream s)
+      ;(clim:draw-line* stream 0 0 100 100)
+      ;(clim:draw-line* stream 0 100 100 0)
+      (clim:draw-text* stream "Tester" 50 50))))
diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp
index 2d31eef5d1c9f3a0f29a23ecff3a6029b1a10e91..44dc6eedfac8e3ad1c2841a59ba9a2bfdc3c388e 100644
--- a/aclpc/acl-medium.lisp
+++ b/aclpc/acl-medium.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-medium.lisp,v 1.11 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-medium.lisp,v 1.12 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -90,30 +90,65 @@
     (setf window nil))
   nil)
 
-(defmethod select-acl-dc ((medium acl-medium) window dc)
+(defmethod select-acl-dc-1 ((medium acl-medium) window dc)
   (declare (ignore window))
-  (let* ((sheet (medium-sheet medium))
-	 (region (sheet-device-region sheet))
-	 (medium-region (medium-clipping-region medium))
-	 cleft ctop cright cbottom
-         winrgn
-	 (valid nil))
-    (unless (eq region +nowhere+)
-      (multiple-value-setq (cleft ctop cright cbottom) (bounding-rectangle* region))
-      (setf valid t)
-      (unless (or (eq medium-region +everywhere+) (eq medium-region +nowhere+))
-	(with-bounding-rectangle* (mleft mtop mright mbottom) medium-region
-	  (multiple-value-setq (valid cleft ctop cright cbottom)
-	    (multiple-value-call #'ltrb-overlaps-ltrb-p
-	      cleft ctop cright cbottom
-	      (transform-rectangle* 
-	       (sheet-device-transformation sheet)
-	       mleft mtop mright mbottom))))))
-    (when valid
-      (fix-coordinates cleft ctop cright cbottom)
-      (setq winrgn (createRectRgn cleft ctop cright cbottom))
-      (setf *created-region* winrgn)
-      (selectobject dc winrgn))))
+  (cond ((not (valid-handle dc))
+	 nil)
+	(t
+	 (let* ((sheet (medium-sheet medium))
+		(region (sheet-device-region sheet))
+		(medium-region (medium-clipping-region medium))
+		cleft ctop cright cbottom
+		winrgn
+		(valid nil))
+	   (unless (eq region +nowhere+)
+	     (multiple-value-setq (cleft ctop cright cbottom) 
+	       (bounding-rectangle* region))
+	     (setf valid t)
+	     (unless (or (eq medium-region +everywhere+) 
+			 (eq medium-region +nowhere+))
+	       (with-bounding-rectangle* (mleft mtop mright mbottom) 
+		   medium-region
+		 (multiple-value-setq (valid cleft ctop cright cbottom)
+		   (multiple-value-call #'ltrb-overlaps-ltrb-p
+		     cleft ctop cright cbottom
+		     (transform-rectangle* 
+		      (sheet-device-transformation sheet)
+		      mleft mtop mright mbottom))))))
+	   (when valid
+	     (fix-coordinates cleft ctop cright cbottom)
+	     (setq winrgn (createRectRgn cleft ctop cright cbottom))
+	     (let ((val1 (and (valid-handle winrgn)
+			      (SelectObject dc winrgn))))
+	       (values val1
+		       winrgn)))))))
+
+(defmacro with-selected-acl-dc ((var) (medium window dc) &rest body)
+  `(multiple-value-bind (,var ..winrgn..)
+       (select-acl-dc-1 ,medium ,window ,dc)
+     (when ,var
+       (unwind-protect
+	   (progn
+	     ,@body) 
+	 (when (valid-handle ..winrgn..)
+	   (or (win:DeleteObject ..winrgn..)
+	       (error "with-selected-acl-dc: DeleteObject")))))))
+
+(defmacro with-dc-image-for-ink ((image-var) (medium ink) &body body)
+  `(let ((,image-var nil)
+	 (..generated-bitmap.. nil)
+	 (..generated-mask-bitmap.. nil))
+     (unwind-protect 
+	 (progn 
+	   (multiple-value-setq (,image-var ..generated-bitmap.. ..generated-mask-bitmap..)
+	     (dc-image-for-ink ,medium ,ink))
+	   ,@body)
+       (when (and (valid-handle ..generated-bitmap..))
+	 (or (win:DeleteObject ..generated-bitmap..)
+	     (error "with-dc-image-for-ink: DeleteObject: bitmap")))
+       (when (and (valid-handle ..generated-mask-bitmap..))
+	 (or (win:DeleteObject ..generated-mask-bitmap..)
+	     (error "with-dc-image-for-ink: DeleteObject: mask-bitmap"))))))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +ltgray+)))
   ;; This is not supposed to be just ANY light gray.
@@ -127,12 +162,15 @@
   (color-rgb (wincolor->color (win:getSysColor win:COLOR_BTNFACE))))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +foreground-ink+)))
+  (declare (values image created-bitmap created-mask-bitmap))
   (dc-image-for-ink medium (medium-foreground medium)))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +background-ink+)))
+  (declare (values image created-bitmap created-mask-bitmap))
   (dc-image-for-ink medium (medium-background medium)))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink t))
+  (declare (values image created-bitmap created-mask-bitmap))
   ;; Don't blow out if somebody tries to use a fancy ink like compose-in.
   (dc-image-for-ink medium (medium-foreground medium)))
 
@@ -142,7 +180,7 @@
 	 (setq ink (medium-background medium)))
 	((eq ink +foreground-ink+)
 	 (setq ink (medium-foreground medium)))
-	((eq ink +transparent-ink+)
+	((transparent-ink-p ink)
 	 (return-from color->wincolor -1)
 	 ))
   (flet ((convert (x)
@@ -178,6 +216,7 @@
 			(convert blue))))))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink color))
+  (declare (values image created-bitmap created-mask-bitmap))
   (let ((cache (port-dc-cache (port medium))))
     (or (gethash ink cache)
 	(setf (gethash ink cache)
@@ -193,22 +232,27 @@
 			     )))))))
 
 ;;; ink for opacities, regions, etc
+(defmethod transparent-ink-p ((ink t)) (eq ink +nowhere+))
+(defmethod transparent-ink-p ((ink standard-opacity))
+  (let ((value (opacity-value ink)))
+    (< value 0.5)))
 
 ;;; +transparent-ink+ is also known as +nowhere+.
 (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +transparent-ink+)))
   *blank-image*)
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +everywhere+)))
+  (declare (values image created-bitmap created-mask-bitmap))
   (dc-image-for-ink medium +foreground-ink+))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink standard-opacity))
-  #+ignore
-  (cerror "Return Opacity 0" "Can't handle Opacities other than 0 and 1")
+  (declare (values image created-bitmap created-mask-bitmap))
   (if (>= (opacity-value ink) 0.5)
     (dc-image-for-ink medium +foreground-ink+)
     *blank-image*))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink region))
+  (declare (values image created-bitmap created-mask-bitmap))
   (dc-image-for-ink medium +foreground-ink+))
 
 ;;; ink for patterns, tiles, etc
@@ -227,7 +271,8 @@
 
 ;;;  just for now, later rationalize passing dc
 (defun dc-image-for-multi-color-pattern (medium ink array designs)
-  (declare (ignore ink))
+  (declare (ignore ink)
+	   (values (dc-image-list created-bitmap)))
   (let* ((dc-image (copy-dc-image
 		    (slot-value medium 'foreground-dc-image)))
 	 (tink (aref designs 1))
@@ -237,51 +282,109 @@
 	 (width (array-dimension array 1))
 	 (height (array-dimension array 0))
 	 (bits-per-pixel 8)
-	 (into (make-pixel-map width height (expt 2 bits-per-pixel))))
+	 (into (make-pixel-map width height (expt 2 bits-per-pixel)))
+	 (created-bitmap nil))
     (dotimes (i height)
       (dotimes (j width)
 	(setf (aref into i j) (aref array i j))))
     (setf *bitmap-array* into)
     (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs))
 	   (dc (win:GetDC 0))
-	   (bitmap (get-texture dc into bitmapinfo)))	
-      ;; To Do: replace BITMAP with INTO and just use 
-      ;; device-independent bitmap operations.
-      (setf (dc-image-bitmap dc-image) bitmap
-	    *created-bitmap* bitmap)
-      (setf (dc-image-background-color dc-image) bcolor)
-      (setf (dc-image-text-color dc-image) tcolor))
-    dc-image))
+	   (bitmap (unless (zerop dc)
+		     (get-texture dc into bitmapinfo))))
+      (when bitmap
+	;; To Do: replace BITMAP with INTO and just use 
+	;; device-independent bitmap operations.
+	(setf (dc-image-bitmap dc-image) bitmap
+	      created-bitmap bitmap)
+	(setf (dc-image-background-color dc-image) bcolor)
+	(setf (dc-image-text-color dc-image) tcolor)
+	(win:ReleaseDC 0 dc)))
+    (values dc-image
+	    created-bitmap)))
 
 (defun dc-image-for-transparent-pattern (medium ink array designs)
-  (declare (ignore ink))
+  (declare (ignore ink)
+	   (values (dc-image-list created-bitmap created-mask-bitmap)))
   (let* ((dc-image (copy-dc-image
 		    (slot-value medium 'foreground-dc-image)))
-	 (tink (aref designs 1))
-	 (bink (aref designs 0))
-	 (tcolor (color->wincolor tink medium))
-	 (bcolor (color->wincolor bink medium))
+	 (dc-image-mask (copy-dc-image
+			 (slot-value medium 'foreground-dc-image)))
+	 (ink0 (aref designs 0))
+	 (ink1 (aref designs 1))
+	 (color0 (color->wincolor ink0 medium))
+	 (color1 (color->wincolor ink1 medium))
 	 (width (array-dimension array 1))
 	 (height (array-dimension array 0))
 	 (bits-per-pixel 8)
-	 (into (make-pixel-map width height (expt 2 bits-per-pixel))))
-    (when (eq tink +transparent-ink+)
-      (rotatef tink bink)
-      (rotatef tcolor bcolor))
+	 (copy-arr (make-pixel-map width height (expt 2 bits-per-pixel)))
+	 (copy-arr-mask (make-pixel-map width height (expt 2 bits-per-pixel)))
+	 (transindex 0)
+	 (maincolor color1)
+	 (mainink ink1) 
+	 (created-bitmap nil)
+	 (created-mask-bitmap nil)
+	 )
+    (when (not (transparent-ink-p ink0))
+      (setq transindex 1
+	    maincolor color0
+	    mainink ink0))
     (dotimes (i height)
       (dotimes (j width)
-	(setf (aref into i j) (aref array i j))))
-    (setf *bitmap-array* into)
-    (let* ((bitmapinfo (get-bitmapinfo medium dc-image into designs))
+	(cond ((= (aref array i j) transindex)
+	       (setf (aref copy-arr i j) 0)
+	       (setf (aref copy-arr-mask i j) 0))
+	      (t
+	       (setf (aref copy-arr i j) 1)
+	       (setf (aref copy-arr-mask i j) 1)))
+	))
+    (setf *bitmap-array* copy-arr)
+    (let* ((bitmapinfo (get-bitmapinfo medium dc-image copy-arr 
+				       (make-array 2 :initial-contents 
+						   (list clim:+white+ 
+							 mainink))
+				       ))
 	   (dc (win:GetDC 0))
-	   (bitmap (get-texture dc into bitmapinfo)))	
-      ;; To Do: replace BITMAP with INTO and just use 
+	   (bitmap (get-texture dc copy-arr bitmapinfo)))
+      ;; To Do: replace BITMAP with COPY-ARR and just use 
       ;; device-independent bitmap operations.
-      (setf (dc-image-bitmap dc-image) bitmap
-	    *created-bitmap* bitmap)
-      (setf (dc-image-background-color dc-image) bcolor)
-      (setf (dc-image-text-color dc-image) tcolor))
-    dc-image))
+      (when bitmap
+	(setf (dc-image-bitmap dc-image) bitmap
+	      created-bitmap bitmap)
+	(setf (dc-image-background-color dc-image) 
+	  (color->wincolor clim:+white+ medium))
+	(setf (dc-image-text-color dc-image) maincolor)
+	(let* ((bitmapinfo-mask 
+		(get-bitmapinfo medium dc-image-mask copy-arr-mask
+				(make-array 2 :initial-contents 
+					    (list clim:+black+ 
+						  mainink))
+				))
+	       (dc-mask (win:GetDC 0))
+	       (bitmap-mask (get-texture dc-mask copy-arr-mask 
+					 bitmapinfo-mask)))
+	  ;; To Do: replace BITMAP with COPY-ARR and just use 
+	  ;; device-independent bitmap operations.
+	  (setf (dc-image-bitmap dc-image-mask) bitmap-mask)
+
+	  (setf created-mask-bitmap bitmap-mask)
+
+	  (setf (dc-image-background-color dc-image-mask) 
+	    (color->wincolor clim:+black+ medium))
+	  (setf (dc-image-text-color dc-image-mask) maincolor)
+	  ;; I guess we don't want to release the device context
+	  ;; until we destroy the rest of the image.
+	  ;;(unless (zerop dc) (win:ReleaseDC 0 dc))
+	  ;;(unless (zerop dc-mask) (win:ReleaseDC 0 dc-mask))
+	  ;;
+	  ;; Windows does not support transparent ink directly.  We have to
+	  ;; create transparency with two images.
+	  (values
+	   (list dc-image
+		 dc-image-mask)
+	   created-bitmap
+	   created-mask-bitmap)
+	  )))))
 
 (defun byte-align-pixmap (a)
   ;; Pad the pixmap so that the y dimension is a multiple of 4.
@@ -302,7 +405,7 @@
 (defun pattern-to-hatchbrush (pattern)
   (multiple-value-bind (array designs) (decode-pattern pattern)
     (let* ((tcolor (position-if 
-		    #'(lambda (ink) (not (eq ink +transparent-ink+)))
+		    #'(lambda (ink) (not (transparent-ink-p ink)))
 		    designs))
 	   (style nil))
       (unless tcolor (return-from pattern-to-hatchbrush nil))
@@ -319,36 +422,46 @@
 		  ((and a11 a12) win:HS_HORIZONTAL)
 		  ((and a11 a21) win:HS_VERTICAL)))))
       (unless style (setq style win:HS_FDIAGONAL))
-      (win:createhatchbrush
+      (win:CreateHatchBrush
        style
        (color->wincolor (elt designs tcolor))))))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink pattern))
+  (declare (values image created-bitmap created-mask-bitmap))
   ;; The "pattern" part of the ink is put into the brush.
-  ;; There seems to be a problem with two-color stipples.
+  ;; This will return a list of two DCs if one of the inks is transparent.
   (let ((cache (port-dc-cache (port medium))))
     (or (gethash ink cache)
-	(setf (gethash ink cache)
-	  (multiple-value-bind (array designs) (decode-pattern ink)
-	    (cond ((find +transparent-ink+ designs)
-		   ;; This is a terrible hack.
-		   ;; It avoids blowing out, and gives you a transparent stipple,
-		   ;; but it doesn't use the one you request.
-		   (setq array (byte-align-pixmap array))
-		   (let ((dc-image (dc-image-for-transparent-pattern
-				    medium ink array designs)))
-		     (setf (dc-image-brush dc-image) 
-		       (pattern-to-hatchbrush ink))
-		     dc-image))
-		  (t
-		   (setq array (byte-align-pixmap array))
-		   (let ((dc-image (dc-image-for-multi-color-pattern
-				    medium ink array designs)))
-		     ;; win95: creating brushes from patterns larger than
-		     ;; 8x8 is not supported.
-		     (setf (dc-image-brush dc-image)
-		       (win:createPatternBrush (dc-image-bitmap dc-image)))
-		     dc-image))))))))
+	(multiple-value-bind (array designs) (decode-pattern ink)
+	  (cond ((find-if #'transparent-ink-p designs)
+		 ;; This returns two images, which
+		 ;; are used as masks to support how 
+		 ;; windows draws patterns containing
+		 ;; transparent inks.
+		 ;;
+		 ;; NOTE: Not cached in hashtable.
+		 (setq array (byte-align-pixmap array))
+		 (let ((dc-image nil)
+		       (created-bitmap nil)
+		       (created-mask-bitmap nil))
+		   (multiple-value-setq (dc-image created-bitmap created-mask-bitmap)
+		     (dc-image-for-transparent-pattern medium ink array designs))
+		   (loop for DCI in dc-image
+		       do (setf (dc-image-brush dci) 
+			    (win:CreatePatternBrush (dc-image-bitmap dci))))
+		   (values dc-image
+			   created-bitmap
+			   created-mask-bitmap)))
+		(t
+		 (setq array (byte-align-pixmap array))
+		 (let ((dc-image (dc-image-for-multi-color-pattern medium ink array designs)))
+		   (setf (dc-image-brush dc-image)
+		     (win:CreatePatternBrush (dc-image-bitmap dc-image)))
+		   ;; Cache it now.  There is a bug that caching a pattern that
+		   ;; depends on foreground-ink or background-ink will cause
+		   ;; those settings to get captured permanently.
+		   (setf (gethash ink cache) dc-image)
+		   )))))))
 
 #|
 does anyone know how to make the bitmaps have transparent
@@ -381,17 +494,40 @@ draw icons and mouse cursors on the screen.
 |#
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink rectangular-tile))
+  (declare (values image created-bitmap created-mask-bitmap))
   ;; The only case we handle right now is stipples
   (let ((cache (port-dc-cache (port medium))))
     (or (gethash ink cache)
-	(setf (gethash ink cache)
-	  ;; The brush of PATTERN is used as the tile.
-	  (dc-image-for-ink medium (decode-rectangular-tile ink))))))
+	(let ((pattern (decode-rectangular-tile ink)))
+	  (multiple-value-bind (image created-bitmap created-mask-bitmap)
+	      (dc-image-for-ink medium pattern)
+	    ;; The brush of PATTERN is used as the tile.
+	    (cond ((and (atom image)
+			(null created-bitmap)
+			(null created-mask-bitmap))
+		   ;; It is not cached if it is a cons, to be consistent with
+		   ;; the non-caching behavior of patterns with transparent
+		   ;; inks.
+		   ;; Also, don't cache if it generated a bitmap or mask.
+		   (setf (gethash ink cache) image))
+		  ((consp image)
+		   ;; It is a transparent rectangular tile.  These don't
+		   ;; work right now, so lets use a Windows hatchbrush
+		   ;; for now.  We can cache a hatchbrush I think.
+		   (dolist (dci image)
+		     (setf (dc-image-background-color dci) -1) ; transparent
+		     (setf (dc-image-brush dci) 
+		       (pattern-to-hatchbrush pattern)))
+		   (setf (gethash ink cache) image)
+		   (setq created-bitmap nil)
+		   (setq created-mask-bitmap nil)))
+	    (values image created-bitmap created-mask-bitmap))))))
 
 (defun nyi ()
   (error "This NT CLIM operation is NYI (Not Yet Implemented)."))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink flipping-ink))
+  (declare (values image created-bitmap created-mask-bitmap))
   (let ((cache (port-dc-cache (port medium))))
     (or (gethash ink cache)
 	(setf (gethash ink cache)
@@ -401,8 +537,8 @@ draw icons and mouse cursors on the screen.
 		   (image2 (dc-image-for-ink medium ink2))
 		   (color (logxor (dc-image-text-color image1)
 				  (dc-image-text-color image2))))
-	      (unless (and (eql (dc-image-rop2 image1) win:r2_copypen)
-			   (eql (dc-image-rop2 image2) win:r2_copypen)
+	      (unless (and (eq (dc-image-rop2 image1) win:r2_copypen)
+			   (eq (dc-image-rop2 image2) win:r2_copypen)
 			   (null (dc-image-bitmap image1))
 			   (null (dc-image-bitmap image2)))
 		(nyi))
@@ -415,6 +551,7 @@ draw icons and mouse cursors on the screen.
 			       :background-color nil))))))))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink contrasting-ink))
+  (declare (values image created-bitmap created-mask-bitmap))
   (dc-image-for-ink medium (make-color-for-contrasting-ink ink)))
 
 (defmethod dc-image-for-ink ((medium acl-medium) (ink composite-out))
@@ -424,60 +561,66 @@ draw icons and mouse cursors on the screen.
   (error "Compositing is not supported."))
 
 (defmethod medium-draw-point* ((medium acl-medium) x y)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (medium-line-style medium)))
-          (convert-to-device-coordinates transform x y)
-          (set-dc-for-ink dc medium ink line-style)
-	  ;;(win:rectangle dc x y (+ x 1) (+ y 1))  pity it doesn't work
-	  (win:moveToEx dc x y null)
-	  (win:lineTo dc (+ x 1) (+ y 1))
-	  (selectobject dc old)
-	  )))))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (medium-line-style medium)))
+	      (if (identity-transformation-p transform)
+		  (fix-coordinates x y)
+		(convert-to-device-coordinates transform x y))
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		;;(win:rectangle dc x y (+ x 1) (+ y 1))  pity it doesn't work
+		(win:moveToEx dc x y null)
+		(win:lineTo dc (+ x 1) (+ y 1))
+		(when (valid-handle old) (SelectObject dc old))
+		))))))))
 
 (defmethod medium-draw-points* ((medium acl-medium) position-seq)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (medium-line-style medium)))
-          (set-dc-for-ink dc medium ink line-style)
-	  (do ((i 0 (+ i 2))
-               (j 1 (+ j 2)))
-            ((>= i (length position-seq)))
-            (let ((x (elt position-seq i))
-	          (y (elt position-seq j)))
-	      (convert-to-device-coordinates transform x y)
-              ;(win:rectangle dc x y x y)
-	      (win:moveToEx dc x y null)
-	      (win:lineTo dc (+ x 1) (+ y 1))))
-	  (selectobject dc old))))))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (medium-line-style medium))
+		   (L (length position-seq)))
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		(do ((i 0 (+ i 2))
+		     (j 1 (+ j 2)))
+		    ((>= i L))
+		  (let ((x (elt position-seq i))
+			(y (elt position-seq j)))
+		    (convert-to-device-coordinates transform x y)
+					;(win:rectangle dc x y x y)
+		    (win:moveToEx dc x y null)
+		    (win:lineTo dc (+ x 1) (+ y 1))))
+		(when (valid-handle old) (SelectObject dc old))))))))))
 
 (defmethod medium-draw-line* ((medium acl-medium) x1 y1 x2 y2)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-dc (window dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (medium-line-style medium)))
-          (convert-to-device-coordinates transform x1 y1 x2 y2)
-          (set-dc-for-ink dc medium ink line-style)
-          (win:moveToEx dc x1 y1 null)
-          (win:lineTo dc x2 y2)
-	  (selectobject dc old))))))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (medium-line-style medium)))
+	      (convert-to-device-coordinates transform x1 y1 x2 y2)
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		(win:moveToEx dc x1 y1 null)
+		(win:lineTo dc x2 y2)
+		(when (valid-handle old) (SelectObject dc old))))))))))
 
 (defmethod medium-draw-lines* ((medium acl-medium) position-seq)
   #+slow-but-sure
@@ -488,148 +631,224 @@ draw icons and mouse cursors on the screen.
 	   (clim:medium-draw-line* medium oldx oldy x y))
 	 (setq oldx x oldy y))
      position-seq))
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (medium-line-style medium)))
-          (set-dc-for-ink dc medium ink line-style)
-	  (let ((init t))
-	    (silica:map-position-sequence
-	     #'(lambda (x y)
-		 (convert-to-device-coordinates transform x y)
-		 (cond (init
-			(win:moveToEx dc x y null)
-			(setq init nil))
-		       (t
-			(win:lineTo dc x y))))
-	     position-seq))
-	  (selectobject dc old))))))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (medium-line-style medium)))
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		(let ((init t))
+		  (declare (optimize (speed 3) (safety 0)))
+		  (labels ((visit1 (x y)
+			     (fix-coordinates x y)
+			     (cond (init
+				    (win:MoveToEx dc x y null)
+				    (setq init nil))
+				   (t
+				    (win:LineTo dc x y))))
+			   (visit2 (x y)
+			     (convert-to-device-coordinates transform x y)
+			     (cond (init
+				    (win:MoveToEx dc x y null)
+				    (setq init nil))
+				   (t
+				    (win:LineTo dc x y)))))
+		    (declare (dynamic-extent #'visit1 #'visit2))
+		    (if (identity-transformation-p transform)
+			(silica:map-position-sequence #'visit1 position-seq)
+		      (silica:map-position-sequence #'visit2 position-seq))))
+		(when (valid-handle old) (SelectObject dc old))))))))))
 
 (defmethod medium-draw-rectangle* ((medium acl-medium)
 				   left top right bottom filled)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc)) 
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (and (not filled) (medium-line-style medium))))
-          (convert-to-device-coordinates transform
-					 left top right bottom)
-          (when (< right left) (rotatef right left))
-          (when (< bottom top) (rotatef bottom top))
-	  (cond ((typep ink 'pattern)
-		 ;; DRAW-PATTERN* ends up here.  In principle
-		 ;; we could skip this case and rely on the "brush"
-		 ;; to correctly paint the rectangle.  In practice,
-		 ;; this case is needed to correctly render patterns
-		 ;; larger than 8x8, due to limitations of CreatePatternBrush.
-		 (let ((cdc nil)
-		       (dc-image (dc-image-for-ink medium ink)))
-		   ;; Create compatable memory dc
-		   (setq cdc (win:createcompatibledc dc))
-		   ;; select a (Device-Dependent) bitmap into the dc
-		   (win:selectobject cdc (dc-image-bitmap dc-image))
-		   ;; Copy bitmap from memory dc to screen dc
-		   (win:bitblt dc left top (- right left) (- bottom top)
-			       cdc 0 0 win:srccopy)
-		   ;; Delete memory dc
-		   (win:deletedc cdc))
-		 t)
-		(t
-		 (let ((*the-dc* dc))
-		   (set-dc-for-ink dc medium ink 
-				   (if filled nil line-style)
-				   left top))
-		 (if filled
-		     (win:rectangle dc left top (1+ right) (1+ bottom))
-		   (win:rectangle dc left top right bottom))))
-	  (selectobject dc old))))))
-
-(defmethod medium-draw-rectangles* ((medium acl-medium) position-seq filled)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-        (let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (and (not filled) (medium-line-style medium)))
-	       (numrects (floor (length position-seq) 4))
-	       (rect -1))
-	  (set-dc-for-ink dc medium ink line-style)
-          (dotimes (i numrects)
-            (let ((left (elt position-seq (incf rect)))
-		  (top (elt position-seq (incf rect)))
-		  (right (elt position-seq (incf rect)))
-		  (bottom (elt position-seq (incf rect))))
+  (declare (fixnum left top right bottom)
+	   (optimize (speed 3) (safety 0)))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc) 
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (and (not filled) (medium-line-style medium))))
 	      (convert-to-device-coordinates transform
 					     left top right bottom)
 	      (when (< right left) (rotatef right left))
 	      (when (< bottom top) (rotatef bottom top))
-	      (if filled
-		  (win:rectangle dc left top (1+ right) (1+ bottom))
-		(win:rectangle dc left top right bottom))))
-	  (selectobject dc old))))))
-
-(defmethod medium-draw-polygon* ((medium acl-medium)
-				 position-seq closed filled)
-  (let ((window (medium-drawable medium))
-	(length (length position-seq))
-	(old nil))
-    (assert (evenp length))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-	(let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (and (not filled) (medium-line-style medium)))
-	       (length (length position-seq))
-	       (numpoints (floor length 2))
-	       (point-vector nil)
-	       (i 0))
-	  (when (and closed (not filled))
-	    (incf length 2)
-	    (incf numpoints))
-	  (setq point-vector (ff:allocate-fobject `(:array :long ,length)))
-	  (silica:map-position-sequence
-	   #'(lambda (x y)
-	       (convert-to-device-coordinates transform x y)
-	       (setf (ff:fslot-value-typed '(:array :long 1) :foreign
-					   point-vector i) 
-		 (truncate x))
+	      (cond ((isa-pattern ink)
+		     ;; DRAW-PATTERN* ends up here.  In principle
+		     ;; we could skip this case and rely on the "brush"
+		   ;; to correctly paint the rectangle.  In practice,
+		     ;; this case is needed to correctly render patterns
+		     ;; larger than 8x8, due to limitations of CreatePatternBrush.
+		     (let ((cdc nil))
+		       (with-dc-image-for-ink (dc-image) 
+			 (medium ink)
+			
+			 ;; Create compatable memory dc
+			 (setq cdc (win:createcompatibledc dc))
+			 (assert (valid-handle cdc))	
+			 (cond ((listp dc-image)
+				;; This is the case of a pattern that contains transparent ink.
+				;; Windows does not support transparent ink directly.
+				;; You can do this by creating two pictures, 
+				;; one with white in the transparent area (The Picture)
+				;; and the other with black in the transparent area. (The Mask)
+				;; Then use the bitblt API to blit the picture with
+				;; the SRCAND (&h8800c6) flag.  Then blit the mask in the 
+				;; same location with the SRCOR (&hee0086) flag.
+				(let* ((dci-pict (first dc-image))
+				       (dci-mask (second dc-image))
+				       (pictbm (dc-image-bitmap dci-pict))
+				       (maskbm (dc-image-bitmap dci-mask)))
+				  ;; select a (Device-Dependent) bitmap into the dc
+				  (when (valid-handle pictbm) (SelectObject cdc pictbm))
+				  ;; Copy bitmap from memory dc to screen dc
+				  (win:bitblt dc left top (- right left) (- bottom top)
+					      cdc 0 0 
+					      win:SRCAND)
+			 
+				  (when (valid-handle maskbm) (SelectObject cdc maskbm))
+				  (win:bitblt dc left top (- right left) (- bottom top)
+					      cdc 0 0 
+					      acl-clim::SRCOR)))
+			       (t
+				;; select a (Device-Dependent) bitmap into the dc
+				(let ((bm (dc-image-bitmap dc-image)))
+				  (when (valid-handle bm) (SelectObject cdc bm)))
+				;; Copy bitmap from memory dc to screen dc
+				(win:bitblt dc left top (- right left) (- bottom top)
+					    cdc 0 0 win:SRCCOPY)))
+			 ;; Delete memory dc
+			 (win:deletedc cdc)
+			 (when (valid-handle old) (SelectObject dc old))))
+		     t)
+		    (t
+		     (let ((*the-dc* dc))
+		       (with-set-dc-for-ink (dc medium ink
+						(if filled nil line-style)
+						left top)
+			 (if filled
+			     (win:rectangle dc left top (1+ right) (1+ bottom))
+			   (win:rectangle dc left top right bottom))
+			 (when (valid-handle old) (SelectObject dc old))
+			 t
+			 )))))))))))
+
+(defmethod medium-draw-rectangles* ((medium acl-medium) position-seq filled)
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (and (not filled) (medium-line-style medium)))
+		   (numrects (floor (length position-seq) 4))
+		   (rect -1))
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		(dotimes (i numrects)
+		  (let ((left (elt position-seq (incf rect)))
+			(top (elt position-seq (incf rect)))
+			(right (elt position-seq (incf rect)))
+			(bottom (elt position-seq (incf rect))))
+		    (convert-to-device-coordinates transform
+						   left top right bottom)
+		    (when (< right left) (rotatef right left))
+		    (when (< bottom top) (rotatef bottom top))
+		    (if filled
+			(win:rectangle dc left top (1+ right) (1+ bottom))
+		      (win:rectangle dc left top right bottom))))
+		(when (valid-handle old) (SelectObject dc old))))))))))
+
+(defparameter *point-vector* 
+    (ff:allocate-fobject `(:array :long 100) :foreign-static-gc))
+
+(defparameter *point-vector-type* 
+    (ff:compile-foreign-type `(:array :long 100)))
+
+(defun set-point (vector i x)
+  (declare (optimize (speed 3) (safety 0))
+	   (fixnum i))
+  (setf (ff:fslot-value-typed *point-vector-type* :foreign
+			      vector i)
+    x)
+  nil)
+
+(defun fill-point-vector (vector transform position-seq closed)
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((i 0))
+    (labels ((visit1 (x y)
+	       (fix-coordinates x y)
+	       (set-point vector i x)
 	       (incf i)
-	       (setf (ff:fslot-value-typed '(:array :long 1) :foreign
-					   point-vector i)
-		 (truncate y))
+	       (set-point vector i y)
 	       (incf i))
-	   position-seq)
-	  (when (and closed (not filled))
-	    (setf (ff:fslot-value-typed '(:array :long 1) :foreign
-					point-vector i)
-	      (ff:fslot-value-typed '(:array :long 1) :foreign
-				    point-vector 0))
-	    (incf i)
-	    (setf (ff:fslot-value-typed '(:array :long 1) :foreign
-					point-vector i)
-	      (ff:fslot-value-typed '(:array :long 1) :foreign
-				    point-vector 1))
-	    (incf i))
-	  (set-dc-for-ink dc medium ink line-style)
-	  (if filled
-	      (win:polygon dc point-vector numpoints)
-	    (win:polyline dc point-vector numpoints))
-	  (selectobject dc old)
-	  t)))))
+	     (visit2 (x y)
+	       (convert-to-device-coordinates transform x y)
+	       (set-point vector i x)
+	       (incf i)
+	       (set-point vector i y)
+	       (incf i)))
+      (declare (dynamic-extent #'visit1 #'visit2))
+      (if (identity-transformation-p transform)
+	  (silica:map-position-sequence #'visit1 position-seq)
+	(silica:map-position-sequence #'visit2 position-seq))
+      (when closed
+	;; Make the first point be the last.
+	(set-point vector i 
+		   (ff:fslot-value-typed *point-vector-type* :foreign
+					 vector 0))
+	(incf i)
+	(set-point vector i 
+		   (ff:fslot-value-typed *point-vector-type* :foreign
+					 vector 1))
+	(incf i))
+      i)))
+
+(defun draw-polygon-1 (medium position-seq dc filled closed old)
+  (let* ((sheet (medium-sheet medium))
+	 (transform (sheet-device-transformation sheet))
+	 (ink (medium-ink medium))
+	 (line-style (and (not filled) (medium-line-style medium)))
+	 (length (length position-seq))
+	 (numpoints (floor length 2))
+	 (point-vector nil))
+    (when (and closed (not filled))
+      (incf length 2)
+      (incf numpoints))
+    (setq point-vector *point-vector*)
+    (when (< (length point-vector) length)
+      (setq point-vector (ff:allocate-fobject `(:array :long ,length)))
+      (setq *point-vector* point-vector))
+    (fill-point-vector point-vector transform position-seq
+			       (and closed (not filled)))
+    (with-set-dc-for-ink (dc medium ink line-style)
+      (if filled
+	  (win:polygon dc point-vector numpoints)
+	(win:polyline dc point-vector numpoints))
+      (when (valid-handle old) (SelectObject dc old))
+      t)))
+
+(defmethod medium-draw-polygon* ((medium acl-medium) position-seq closed filled)
+  (without-scheduling
+    (let ((window (medium-drawable medium))
+	  (length (length position-seq)))
+      (assert (evenp length))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (draw-polygon-1 medium position-seq dc filled closed old)))))))
 
 (defconstant *ft* 0.0001)
 (defun-inline fl-= (x y) (< (abs (- x y)) *ft*))
@@ -638,66 +857,70 @@ draw icons and mouse cursors on the screen.
 				 center-x center-y
 				 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
 				 start-angle end-angle filled)
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-	(let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (line-style (and (not filled) (medium-line-style medium))))
-	  (convert-to-device-coordinates transform center-x center-y)
-	  (convert-to-device-distances
-	   transform radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
-	  (when (null start-angle)
-	    (setq start-angle 0.0
-		  end-angle 2pi))
-	  (set-dc-for-ink dc medium ink line-style)
-	  (multiple-value-bind (x-radius y-radius)
-	      (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
-		     (values (abs radius-2-dx) (abs radius-1-dy)))
-		    ((and (= radius-2-dx 0) (= radius-1-dy 0))
-		     (values (abs radius-1-dx) (abs radius-2-dy)))
-		    (t
-		     (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy)))
-			   (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy))))
-		       (if (= s-1 s-2)
-			   (let ((r (truncate (sqrt s-1))))
-			     (values r r))
-			 ;; Degrade to drawing a rectilinear ellipse
-			 (values (truncate (sqrt s-1)) 
-				 (truncate (sqrt s-2)))))))
-	    (let (left top right bottom)
-	      (setq left (- center-x x-radius)
-		    right (+ center-x x-radius)
-		    top (- center-y y-radius)
-		    bottom (+ center-y y-radius))
-	      (cond ((or (fl-= (- end-angle start-angle) 2pi)
-			 (fl-= (- end-angle start-angle) 0))
-		     #+++ignore
-		     (and (= start-angle 0)
-			  (= end-angle 2pi))
-		     ;; drawing a full ellipse
-		     (win:ellipse dc left top right bottom))
-		    ((null line-style)
-		     ;; drawing a pie slice
-		     (win:pie
-		      dc left top right bottom
-		      (round (1- (+ center-x (* (cos start-angle) x-radius))))
-		      (round (1- (- center-y (* (sin start-angle) y-radius))))
-		      (round (1- (+ center-x (* (cos end-angle) x-radius))))
-		      (round (1- (- center-y (* (sin end-angle) y-radius))))))
-		    (t
-		     ;; drawing an arc
-		     (win:arc
-		      dc left top right bottom
-		      (round (1- (+ center-x (* (cos start-angle) x-radius))))
-		      (round (1- (- center-y (* (sin start-angle) y-radius))))
-		      (round (1- (+ center-x (* (cos end-angle) x-radius))))
-		      (round (1- (- center-y (* (sin end-angle) y-radius)))))))
-	      ))
-	  (selectobject dc old))))))
+  (without-scheduling
+    (let ((window (medium-drawable medium)))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (let* ((sheet (medium-sheet medium))
+		   (transform (sheet-device-transformation sheet))
+		   (ink (medium-ink medium))
+		   (line-style (and (not filled) (medium-line-style medium))))
+	      (convert-to-device-coordinates transform center-x center-y)
+	      (convert-to-device-distances
+	       transform radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
+	      (when (null start-angle)
+		(setq start-angle 0.0
+		      end-angle 2pi))
+	      (with-set-dc-for-ink (dc medium ink line-style)
+		(multiple-value-bind (x-radius y-radius)
+		    (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+			   (values (abs radius-2-dx) (abs radius-1-dy)))
+			  ((and (= radius-2-dx 0) (= radius-1-dy 0))
+			   (values (abs radius-1-dx) (abs radius-2-dy)))
+			  (t
+			   (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy)))
+				 (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy))))
+			     (if (= s-1 s-2)
+				 (let ((r (truncate (sqrt s-1))))
+				   (values r r))
+			       ;; Degrade to drawing a rectilinear ellipse
+			       (values (truncate (sqrt s-1)) 
+				       (truncate (sqrt s-2)))))))
+		  (let (left top right bottom)
+		    (setq left (- center-x x-radius)
+			  right (+ center-x x-radius)
+			  top (- center-y y-radius)
+			  bottom (+ center-y y-radius))
+		    (cond ((or (fl-= (- end-angle start-angle) 2pi)
+			       (fl-= (- end-angle start-angle) 0))
+			   #+ignore
+			   (and (= start-angle 0)
+				(= end-angle 2pi))
+			   ;; drawing a full ellipse
+			   (win:ellipse dc left top right bottom))
+			  ((null line-style)
+			   ;; drawing a pie slice
+			   (win:pie
+			    dc left top right bottom
+			    (round (1- (+ center-x (* (cos start-angle) x-radius))))
+			    (round (1- (- center-y (* (sin start-angle) y-radius))))
+			    (round (1- (+ center-x (* (cos end-angle) x-radius))))
+			    (round (1- (- center-y (* (sin end-angle) y-radius))))))
+			  (t
+			   ;; drawing an arc
+			   (win:arc
+			    dc left top right bottom
+			    (round (1- (+ center-x (* (cos start-angle) x-radius))))
+			    (round (1- (- center-y (* (sin start-angle) y-radius))))
+			    (round (1- (+ center-x (* (cos end-angle) x-radius))))
+			    (round (1- (- center-y (* (sin end-angle) y-radius)))))))
+		    ))
+		(when (valid-handle old) (SelectObject dc old))))))))))
+
+(defmethod flipping-ink-p ((object t)) nil)
+(defmethod flipping-ink-p ((object clim-utils:flipping-ink)) t)
 
 (defmethod medium-draw-string* ((medium acl-medium)
 				string x y start end align-x align-y
@@ -705,48 +928,48 @@ draw icons and mouse cursors on the screen.
   ;; This is not supposed to try to draw multiline text.
   ;; For that, use WRITE-STRING.
   (declare (ignore transform-glyphs))
-  (unless end (setq end (length string)))
-  (let* ((transform (sheet-device-transformation (medium-sheet medium))))
-    (convert-to-device-coordinates transform x y)
-    (when towards-x
-      (convert-to-device-coordinates transform towards-x towards-y)))
-  (let* ((port (port medium))
-	 (text-style (medium-merged-text-style medium))
-	 (font (text-style-mapping port text-style))
-	 (window (medium-drawable medium))
-	 (ink (medium-ink medium))
-	 (old nil)
-	 (font-angle (pos-to-font-angle x y towards-x towards-y))
-	 (x-adjust 
-	  (compute-text-x-adjustment align-x medium 
-				     string text-style start end))
-	 (y-adjust
-	  (compute-text-y-adjustment align-y (acl-font-descent font) 
-				     (acl-font-ascent font) (acl-font-height font))))
-    (incf x x-adjust)
-    (incf y y-adjust)
-    (when towards-x
-      (incf towards-x x-adjust)
-      (incf towards-y y-adjust))
-    (cond ((zerop font-angle) 
-	   (decf y (acl-font-ascent font))) ;text is positioned by its top left 
-	  (t
-	   (setq font
-	     (port-find-rotated-font port font font-angle))))
-    (if (typep ink 'clim-utils:flipping-ink)
-	(medium-draw-inverted-string* medium string x y start end font text-style)
-      (with-medium-dc (medium dc)
-	(setq old (select-acl-dc medium window dc))
-	(when old
-	  (with-temporary-substring (substring string start end)
-	    (set-dc-for-text dc medium ink (acl-font-index font))
-	    (multiple-value-bind (cstr len)
-		(silica::xlat-newline-return substring)
-	      (or
-	       (excl:with-native-string (cstr cstr)
-		 (win:TextOut dc x y cstr len))
-	       (check-last-error "TextOut" :action :warn))))
-	  (selectobject dc old))))))
+  (without-scheduling
+    (unless end (setq end (length string)))
+    (let* ((transform (sheet-device-transformation (medium-sheet medium))))
+      (convert-to-device-coordinates transform x y)
+      (when towards-x
+	(convert-to-device-coordinates transform towards-x towards-y)))
+    (let* ((port (port medium))
+	   (text-style (medium-merged-text-style medium))
+	   (font (text-style-mapping port text-style))
+	   (window (medium-drawable medium))
+	   (ink (medium-ink medium))
+	   (font-angle (pos-to-font-angle x y towards-x towards-y))
+	   (x-adjust 
+	    (compute-text-x-adjustment align-x medium 
+				       string text-style start end))
+	   (y-adjust
+	    (compute-text-y-adjustment align-y (acl-font-descent font) 
+				       (acl-font-ascent font) (acl-font-height font))))
+      (incf x x-adjust)
+      (incf y y-adjust)
+      (when towards-x
+	(incf towards-x x-adjust)
+	(incf towards-y y-adjust))
+      (cond ((zerop font-angle) 
+	     (decf y (acl-font-ascent font))) ;text is positioned by its top left 
+	    (t
+	     (setq font
+	       (port-find-rotated-font port font font-angle))))
+      (if (flipping-ink-p ink)
+	  (medium-draw-inverted-string* medium string x y start end font text-style)
+	(with-medium-dc (medium dc)
+	  (with-selected-acl-dc (old) (medium window dc)
+				(when old
+				  (with-temporary-substring (substring string start end)
+				    (with-set-dc-for-text (dc medium ink (acl-font-index font))
+				      (multiple-value-bind (cstr len)
+					  (silica::xlat-newline-return substring)
+					(or (excl:with-native-string (cstr cstr)
+					      (win:TextOut dc x y cstr len))
+					    (check-last-error "TextOut" :action :warn)))
+		
+				      (when (valid-handle old) (SelectObject dc old)))))))))))
 
 (defmethod medium-draw-inverted-string* ((medium acl-medium)
 					 string x y start end font text-style)
@@ -754,44 +977,44 @@ draw icons and mouse cursors on the screen.
   ;; Strings cannot be drawn by calling (SetROP2 dc R2_XORPEN).
   ;; This has no effect on TextOut.  To get the same effect,
   ;; draw the string into a bitmap and draw the bitmap onto the screen.
-  (let (old
-	(window (medium-drawable medium))
-	(width 100)
-	(height 100))
-    (multiple-value-setq (width height) 
-      (text-size medium string :text-style text-style
-		 :start start :end end))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-	(with-temporary-substring (substring string start end)
-	  (let* ((cdc (win:CreateCompatibleDC dc))
-		 (hbm (win:CreateCompatibleBitmap cdc width height))
-		 (oldbm nil))
-	    (setq oldbm (win:SelectObject cdc hbm))
-	    ;; Set the bitmap to black, then draw the text in white.
-	    (set-dc-for-text cdc medium +black+ (acl-font-index font))
-	    (win:rectangle cdc 0 0 width height)
-	    (win:SetTextColor dc 0)	; white
-	    (set-dc-for-text cdc medium +white+ (acl-font-index font))
-	    (multiple-value-bind (cstr len)
-		(silica::xlat-newline-return substring)
-	      (or
-	       (excl:with-native-string (cstr cstr)
-		 (win:TextOut cdc 0 0 cstr len))
-	       (check-last-error "TextOut" :action :warn))
-	      )
-	    ;; Copy bitmap from memory dc to screen dc
-	    (win:BitBlt dc x y width height
-			cdc 0 0 win:SRCINVERT)
-	    ;; Restore the old bitmap
-	    (win:SelectObject cdc oldbm)
-	    ;; Delete the bitmap
-	    (win:DeleteObject hbm)
-	    ;; Delete memory dc
-	    (win:DeleteDC cdc)))
-	(selectobject dc old)))
-    nil))
+  (without-scheduling
+    (let ((window (medium-drawable medium))
+	  (width 100)
+	  (height 100))
+      (multiple-value-setq (width height) 
+	(text-size medium string :text-style text-style
+		   :start start :end end))
+      (with-medium-dc (medium dc)
+	(with-selected-acl-dc (old) 
+	  (medium window dc)
+	  (when old
+	    (with-temporary-substring (substring string start end)
+	      (let* ((cdc (win:CreateCompatibleDC dc))
+		     (hbm (win:CreateCompatibleBitmap cdc width height))
+		     (oldbm nil))
+		(when (valid-handle hbm) (setq oldbm (SelectObject cdc hbm)))
+		;; Set the bitmap to black, then draw the text in white.
+		(with-set-dc-for-text (cdc medium +black+ (acl-font-index font))
+		  (win:rectangle cdc 0 0 width height)
+		  (win:SetTextColor dc 0) ; white
+		  (with-set-dc-for-text (cdc medium +white+ (acl-font-index font))
+		    (multiple-value-bind (cstr len)
+			(silica::xlat-newline-return substring)
+		      (or (excl:with-native-string (cstr cstr)
+			    (win:TextOut cdc 0 0 cstr len))
+			  (check-last-error "TextOut" :action :warn))
+		      )
+		    ;; Copy bitmap from memory dc to screen dc
+		    (win:BitBlt dc x y width height
+				cdc 0 0 win:SRCINVERT)
+		    ;; Restore the old bitmap
+		    (when (valid-handle oldbm) (SelectObject cdc oldbm))
+		    ;; Delete the bitmap
+		    (or (win:DeleteObject hbm) (error "DeleteObject"))
+		    ;; Delete memory dc
+		    (win:DeleteDC cdc)
+		    (when (valid-handle old) (SelectObject dc old)))))))))
+      nil)))
 
 ;;; Enhance the bounding-box calculation for rotated text.
 (defmethod clim-internals::medium-text-bounding-box :around
@@ -840,43 +1063,9 @@ draw icons and mouse cursors on the screen.
 (defmethod medium-draw-character* ((medium acl-medium)
 				   char x y align-x align-y
 				   towards-x towards-y transform-glyphs)
-  (declare (ignore transform-glyphs))
-  (let ((window (medium-drawable medium))
-	(old nil))
-    (with-medium-dc (medium dc)
-      (setq old (select-acl-dc medium window dc))
-      (when old
-	(let* ((sheet (medium-sheet medium))
-	       (transform (sheet-device-transformation sheet))
-	       (ink (medium-ink medium))
-	       (text-style (medium-merged-text-style medium)))
-	  (convert-to-device-coordinates transform x y)
-	  (when towards-x
-	    (convert-to-device-coordinates transform towards-x towards-y))
-	  (let* ((font (text-style-mapping (port medium) text-style))
-		 (height (acl-font-height font))
-		 (descent (acl-font-descent font))
-		 (ascent (acl-font-ascent font)))
-	    (let ((x-adjust 
-		   (compute-text-x-adjustment align-x medium char text-style))
-		  (y-adjust
-		   (compute-text-y-adjustment align-y descent ascent height)))
-	      (incf x x-adjust)
-	      (incf y y-adjust)
-	      (when towards-x
-		(incf towards-x x-adjust)
-		(incf towards-y y-adjust)))
-	    (decf y ascent)		;text is positioned by its top left on acl
-	    (set-dc-for-text dc medium ink (acl-font-index font))
-	    (let ((cstr (ct:callocate (:char *) :size 2)))
-	      (ct:cset (:char 2) cstr 0 (char-int char))
-	      (or #+removed (win:textOut dc x y cstr 1)
-		  (excl:with-native-string (cstr (make-string
-					     1
-					     :initial-element char))
-		    (win:TextOut dc x y cstr 1))
-		  (check-last-error "TextOut" :action :warn)))))
-	(selectobject dc old)))))
+  (medium-draw-string* medium (make-string 1 :initial-element char)
+		       x y 0 1 align-x align-y towards-x towards-y
+		       transform-glyphs))
 
 (defmethod medium-draw-text* ((medium acl-medium)
 			      string-or-char x y start end
@@ -963,7 +1152,7 @@ draw icons and mouse cursors on the screen.
 	(read-pixmap s index)) 
     (format *trace-output* "LOADED pixmap~%")))
 
-(defstruct (texture-info #+ig (:include faslable-structure) (:constructor make-texture-info))
+(defstruct (texture-info (:constructor make-texture-info))
   (width nil :type (or null fixnum))
   (height nil :type (or null fixnum))
   (bits-per-pixel 1 :type fixnum)
diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp
index edad23286b0ffc2ed3dfda4d3cbd310372377f12..946bc899e251815b5653cf06330aa1a184165261 100644
--- a/aclpc/acl-mirror.lisp
+++ b/aclpc/acl-mirror.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-mirror.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-mirror.lisp,v 1.10 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -32,14 +32,12 @@
 
 (in-package :acl-clim)
 
-(defvar *screen* nil)
-
 ;;--- This isn't really right, all ports only have kludges for this
 (defmethod sheet-shell (sheet) sheet)
 
 (defmethod realize-graft ((port acl-port) graft)
-  (let ((handle (slot-value *screen-device* 'device-handle1)))
-   (setq *screen* handle)
+  (let ((screen (slot-value *screen-device* 'device-handle1)))
+   (setf (port-screen port) screen)
    (init-cursors)
    (with-slots (silica::pixels-per-point
 	        silica::pixel-width
@@ -47,7 +45,7 @@
 	        silica::mm-width
 	        silica::mm-height
 	        silica::units) graft
-   (with-dc (*screen* dc) 
+   (with-dc (screen dc) 
     (let ((screen-width (win:GetSystemMetrics win:SM_CXSCREEN)) 
 	  (screen-height (win:GetSystemMetrics win:SM_CYSCREEN))
 	  (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX))
@@ -67,13 +65,22 @@
 		   0 0 
 		   silica::pixel-width silica::pixel-height))))
 	(setf (sheet-native-transformation graft) +identity-transformation+)
-	(setf (sheet-direct-mirror graft) handle)
+	(setf (sheet-direct-mirror graft) screen)
 	(update-mirror-transformation port graft))))))
 
 (defmethod modal-frame-p ((frame t)) nil)
 (defmethod modal-frame-p ((frame clim-internals::accept-values-own-window)) t)
 (defmethod modal-frame-p ((frame clim-internals::menu-frame)) t)
 
+(defmethod scroller-pane-p ((pane t)) nil)
+(defmethod scroller-pane-p ((pane silica::scroller-pane)) t)
+
+(defmethod list-pane-p ((pane t)) nil)
+(defmethod list-pane-p ((pane list-pane)) t)
+
+(defmethod combo-box-p ((pane t)) nil)
+(defmethod combo-box-p ((pane option-pane)) t)
+
 (defmethod realize-mirror ((port acl-port) sheet)
   (multiple-value-bind (left top right bottom)
       (sheet-native-region* sheet)
@@ -90,22 +97,19 @@
 	   (msscrollwin nil)
 	   (childwin nil)
 	   (control nil)
-           (buttonstyle nil)
 	   (value nil)
 	   (items nil)
 	   (width (- right left))
 	   (height (- bottom top))
 	   gadget-id)
-      ;;mm: defined in acl-widg.lsp later
-      (declare (special silica::*hbutton-width* silica::*hbutton-height*))
       (assert (eq parent parent2) () "parents don't match!")
       ;; Wouldn't this COND work better as a pile of methods, or at least a
       ;; typecase? JPM 14Aug97
-      (cond ((typep sheet 'silica::scroller-pane)
+      (cond ((scroller-pane-p sheet)
 	     (setq msscrollwin t)
 	     (setq scroll (and (not (scroller-pane-gadget-supplies-scrolling-p sheet))
 			       (silica::scroller-pane-scroll-bar-policy sheet))))
-	    ((typep sheet 'silica::hlist-pane)
+	    ((list-pane-p sheet)
       	     (setq control :hlist)
 	     ;;mm: allocate gadget-id per parent
              (setq gadget-id (silica::allocate-gadget-id sheet))
@@ -119,7 +123,7 @@
 	       (setf value 
 		 (position value items :test #'equal
 			   :key (slot-value sheet 'silica::value-key)))))
-            ((typep sheet 'silica::mswin-combo-box-pane)
+            ((combo-box-p sheet)
       	     (setq control :hcombo)
 	     ;;mm: allocate gadget-id per parent
              (setq gadget-id (silica::allocate-gadget-id sheet))
@@ -132,55 +136,9 @@
 	     (setf value 
 	       (position value items 
 			 :key (set-gadget-value-key sheet)
-			 :test (set-gadget-test sheet))))
-	    ((typep sheet 'silica::hpbutton-pane)
-	     
-	     (setq control :hbutt)
-	     ;;mm: allocate gadget-id per parent
-             (setq gadget-id (silica::allocate-gadget-id sheet))
-	     (setf buttonstyle
-	       (if (push-button-show-as-default sheet)
-			     win:BS_DEFPUSHBUTTON
-			     win:BS_PUSHBUTTON)))
-	    ((typep sheet 'silica::hbutton-pane)
-	     (setq control :hbutt)
-	     ;;mm: allocate gadget-id per parent
-             (setq gadget-id (silica::allocate-gadget-id sheet))
-	     (setq value (slot-value sheet 'silica::value))
-	     (setq buttonstyle
-	       (ecase (gadget-indicator-type sheet)
-		 (:one-of win:BS_RADIOBUTTON)
-		 (:some-of win:BS_CHECKBOX)))))
-      (when (eq control :hbutt)
-	(multiple-value-bind (cwidth cheight)
-              (compute-gadget-label-size sheet)
-	  (setq top (+ top (* gadget-id 25)))
-	  (setq left (+ left 50))
-          (setq width (+ cwidth (* 2 silica::*hbutton-width*)))
-	  (setq height (max cheight (* 1 silica::*hbutton-height*)))))
+			 :test (set-gadget-test sheet)))))
       (setq window
-	(cond ((eq control :hbutt)
-	       (setq childwin t)
-	       (let ((label (slot-value sheet 'silica::label)))
-		 (typecase label
-		   ((or acl-pixmap pattern)
-		    (setf (slot-value sheet 'silica::pixmap)
-		      (if (typep label 'pattern)
-			  (with-sheet-medium (medium sheet)
-			    (with-output-to-pixmap 
-				(stream medium
-					:width (pattern-width label)
-					:height (pattern-height label))
-			      (draw-pattern* stream label 0 0)))
-			label))
-		    (setq buttonstyle win:BS_OWNERDRAW ;; pnc Aug97 for clim2bug740
-			  label nil)))
-		 (hbutton-open parent gadget-id
-				   left top width height 
-				   :buttonstyle buttonstyle
-				   :value value
-				   :label label)))
-	      ((eq control :hlist)
+	(cond ((eq control :hlist)
 	       (setq childwin t)
 	       (hlist-open parent gadget-id
 			       0 0 0 0	; resize left top width height 
@@ -196,7 +154,7 @@
 			       :mode (slot-value sheet 'silica::mode)
 			       :scroll-mode 
 			       (let ((p (sheet-parent sheet)))
-				 (and (typep p 'silica::scroller-pane)
+				 (and (scroller-pane-p p)
 				      (silica::scroller-pane-scroll-bar-policy p)))
 			       :horizontal-extent
 			       (silica::compute-set-gadget-dimensions sheet)
@@ -212,7 +170,7 @@
 			    :scroll-mode :vertical
 			    :name-key
 			    (slot-value sheet 'silica::name-key)))
-	      ((not (eql parent *screen*))
+	      ((not (eql parent (port-screen port)))
 	       (setq childwin t)
 	       (create-child-window
 		parent pretty-name scroll left top width height))
@@ -258,7 +216,9 @@
 	(let ((text-style (pane-text-style sheet)))
 	  (when text-style
 	    (let ((font (text-style-mapping port text-style)))
-	      (win:SendMessage window win:WM_SETFONT 
+	      (frame-send-message
+	       (pane-frame sheet)
+	       window win:WM_SETFONT 
 			       (acl-font-index font) 0)))))
       (when (and childwin (sheet-enabled-p sheet))
 	;; It's too soon for this.  Need to do this later, 
@@ -420,6 +380,9 @@
    (tooltip-control :initform nil :accessor tooltip-control)
    ))
 
+(defmethod istoplevel ((object t)) nil)
+(defmethod istoplevel ((object acl-top-level-sheet)) t)
+
 (defmethod initialize-instance :after ((sheet acl-top-level-sheet) &key background)
   ;; to cause make-instance to accept :background initializer
   (declare (ignore background))
@@ -447,8 +410,9 @@
 	    (mirror-native-edges* *acl-port* sheet)
 	  (declare (special *clim-icon*))
 	  (let ((dc (GetDc mirror)))
-	    (win:DrawIcon dc 0 0 *clim-icon*)
-	    (win:ReleaseDC mirror dc)))
+	    (unless (zerop dc)
+	      (win:DrawIcon dc 0 0 *clim-icon*)
+	      (win:ReleaseDC mirror dc))))
 	))))
 
 (defmethod realize-mirror :around ((port acl-port) 
diff --git a/aclpc/acl-pixmaps.lisp b/aclpc/acl-pixmaps.lisp
index 143b353dfe9837c383fa69f53907284f1deb3c02..f1f641b9ca9039b45f679f3ca105af532f324c6b 100644
--- a/aclpc/acl-pixmaps.lisp
+++ b/aclpc/acl-pixmaps.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-pixmaps.lisp,v 1.6 1999/02/25 08:23:25 layer Exp $
+;; $Id: acl-pixmaps.lisp,v 1.7 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -36,31 +36,40 @@
   (declare (ignore function))
   (unless (eq from-medium to-medium)
     (cerror "Continue" "Can't copy areas."))
-  (let ((window (medium-drawable from-medium)))
-    (with-dc (window dc)
-      (when (select-acl-dc from-medium window dc)
-        (let ((transform (sheet-device-transformation
-                           (medium-sheet from-medium))))
-        (convert-to-device-coordinates transform from-x from-y to-x to-y)
-        (convert-to-device-distances transform width height)
-        (let ((rleft (min from-x to-x))
-	      (rtop (min from-y to-y))
-	      (rright (+ (max from-x to-x) width))
-	      (rbottom (+ (max from-y to-y) height)))
-          (let ((scrollrect (ct:callocate win:rect))
-                (cliprect (ct:callocate win:rect)))
-            (setf (ct:cref win:rect scrollrect win::left) rleft)
-            (setf (ct:cref win:rect cliprect win::left) rleft)
-            (setf (ct:cref win:rect scrollrect win::top) rtop)
-            (setf (ct:cref win:rect cliprect win::top) rtop)
-            (setf (ct:cref win:rect scrollrect win::right) rright)
-            (setf (ct:cref win:rect cliprect win::right) rright)
-            (setf (ct:cref win:rect scrollrect win::bottom) rbottom)
-            (setf (ct:cref win:rect cliprect win::bottom) rbottom)
-            (win:ScrollDC dc (- to-x from-x) (- to-y from-y)
-		          scrollrect cliprect (ct:null-handle win::hrgn)
-			  0)
-		      )))))))
+  (let ((transform (sheet-device-transformation
+		    (medium-sheet from-medium))))
+    (convert-to-device-coordinates transform from-x from-y to-x to-y)
+    (convert-to-device-distances transform width height)
+    (let ((rleft (min from-x to-x))
+	  (rtop (min from-y to-y))
+	  (rright (+ (max from-x to-x) width))
+	  (rbottom (+ (max from-y to-y) height))
+	  (dx (- to-x from-x))
+	  (dy (- to-y from-y))
+	  (scrollrect (ct:callocate win:rect))
+	  (cliprect (ct:callocate win:rect)))
+      (assert (valid-handle scrollrect))
+      (assert (valid-handle cliprect))
+      (setf (ct:cref win:rect scrollrect win::left) rleft)
+      (setf (ct:cref win:rect cliprect win::left) rleft)
+      (setf (ct:cref win:rect scrollrect win::top) rtop)
+      (setf (ct:cref win:rect cliprect win::top) rtop)
+      (setf (ct:cref win:rect scrollrect win::right) rright)
+      (setf (ct:cref win:rect cliprect win::right) rright)
+      (setf (ct:cref win:rect scrollrect win::bottom) rbottom)
+      (setf (ct:cref win:rect cliprect win::bottom) rbottom)
+      (let ((window (medium-drawable from-medium)))
+	#+ign
+	(win:ScrollWindow window dx dy
+			  scrollrect cliprect)
+	(with-dc (window dc)
+	  (with-selected-acl-dc (old) (from-medium window dc)
+	    old
+	    (win:ScrollDC dc dx dy
+			  scrollrect cliprect 
+			  ;; Updateregn and Updaterect are NULL.
+			  0 0)
+	    ))))))
 
 ;; changed bop->winop to return the val let variable rather than the
 ;; winop let variable. I believe you can take out the winop stuff from
@@ -97,7 +106,8 @@
     (with-dc (window dc)
       (setq cdc (win:CreateCompatibleDC dc))
       (setq bitmap (win:CreateCompatibleBitmap dc width height))
-      (setf obitmap (selectobject cdc bitmap)))
+      (when (valid-handle bitmap)
+	(setf obitmap (SelectObject cdc bitmap))))
     (make-instance 'acl-pixmap 
       :bitmap bitmap
       :for-medium medium
@@ -109,10 +119,10 @@
 (defmethod port-deallocate-pixmap ((port acl-port) (pixmap acl-pixmap))
   (with-slots (bitmap cdc original-bitmap) pixmap
     (when bitmap
-      (win:DeleteObject bitmap)
+      (or (win:DeleteObject bitmap) (error "DeleteObject"))
       (setq bitmap nil))
     (when cdc
-      (selectobject cdc original-bitmap)
+      (when (valid-handle original-bitmap) (SelectObject cdc original-bitmap))
       (win:DeleteDC cdc)
       (setq bitmap nil cdc nil))))
 
@@ -134,17 +144,18 @@
     medium))
 
 (defmethod medium-copy-area 
-	   ((from-medium acl-medium) from-x from-y width height
-	    (to-medium acl-pixmap-medium) to-x to-y &optional (alu boole-1))
+    ((from-medium acl-medium) from-x from-y width height
+     (to-medium acl-pixmap-medium) to-x to-y &optional (alu boole-1))
   (let ((transform (sheet-device-transformation (medium-sheet from-medium)))
         (window (medium-drawable from-medium))
 	(cdc (pixmap-cdc (medium-drawable to-medium))))
     (convert-to-device-coordinates transform from-x from-y)
     (convert-to-device-distances transform width height)
     (with-dc (window dc)
-      (when (select-acl-dc from-medium window dc)
-	(win:BitBlt cdc to-x to-y width height dc from-x from-y 
-		    (bop->winop alu))))))
+      (with-selected-acl-dc (flag) (from-medium window dc)
+	(when flag 
+	  (win:BitBlt cdc to-x to-y width height dc from-x from-y 
+		      (bop->winop alu)))))))
 
 (defmethod medium-copy-area 
 	   ((from-medium acl-pixmap-medium) from-x from-y width height
@@ -154,9 +165,10 @@
 	(cdc (pixmap-cdc (medium-drawable from-medium))))
     (convert-to-device-coordinates transform to-x to-y)
     (with-dc (window dc)
-      (when (select-acl-dc to-medium window dc)
-        (win:BitBlt dc to-x to-y width height cdc from-x from-y 
-	            (bop->winop alu))))))
+      (with-selected-acl-dc (flag) (to-medium window dc)
+	(when flag 
+	  (win:BitBlt dc to-x to-y width height cdc from-x from-y 
+		      (bop->winop alu)))))))
 
 (defmethod medium-copy-area 
 	   ((from-medium acl-medium) from-x from-y width height
@@ -167,9 +179,10 @@
     (convert-to-device-coordinates transform from-x from-y)
     (convert-to-device-distances transform width height)
     (with-dc (window dc)
-      (when (select-acl-dc from-medium window dc)
-	(win:BitBlt cdc to-x to-y width height dc from-x from-y 
-		    (bop->winop alu))))))
+      (with-selected-acl-dc (flag) (from-medium window dc)
+        (when flag 
+	  (win:BitBlt cdc to-x to-y width height dc from-x from-y 
+		      (bop->winop alu)))))))
 
 (defmethod medium-copy-area 
 	   ((pixmap acl-pixmap) from-x from-y width height
@@ -179,9 +192,10 @@
 	(cdc (pixmap-cdc pixmap)))
     (convert-to-device-coordinates transform to-x to-y)
     (with-dc (window dc)
-      (when (select-acl-dc to-medium window dc)
-        (win:BitBlt dc to-x to-y width height cdc from-x from-y 
-	            (bop->winop alu))))))
+      (with-selected-acl-dc (flag) (to-medium window dc)
+        (when flag 
+	  (win:BitBlt dc to-x to-y width height cdc from-x from-y 
+		      (bop->winop alu)))))))
 
 (defmethod medium-draw-pixmap* ((medium acl-medium) pixmap x y
 				function)
diff --git a/aclpc/acl-port.lisp b/aclpc/acl-port.lisp
index d3634c17d4c4ffb3b97b579cae0eb1a62c123252..1da5d56ebcae8c00249e41b3e3a2652470124758 100644
--- a/aclpc/acl-port.lisp
+++ b/aclpc/acl-port.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-port.lisp,v 1.10 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-port.lisp,v 1.11 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -138,7 +138,8 @@
 (define-constructor make-acl-event-queue queue () )
 
 (defclass acl-port (basic-port)
-  (;; Cache used by dc-image-for-ink for mapping inks to device contexts:
+  ((screen :initform nil :accessor port-screen)
+   ;; Cache used by dc-image-for-ink for mapping inks to device contexts:
    (dc-cache :initform (make-hash-table) :accessor port-dc-cache)
    ;; Virtual key to keysym:
    (vk->keysym :initform (make-hash-table))
@@ -224,17 +225,22 @@
 (defmethod silica::port-set-pane-background ((port acl-port) pane medium ink)
   (declare (ignore pane))
   ;; Invoked :after (setf pane-background)
-  (setf (medium-background medium) ink))
+  (when (not (numberp MEDIUM))
+    ;;; On acl a medium is a number.
+    (setf (medium-background medium) ink)))
 
 (defmethod silica::port-set-pane-foreground ((port acl-port) pane medium ink)
   (declare (ignore pane))
   ;; Invoked :after (setf pane-foreground)
-  (setf (medium-foreground medium) ink))
+  (when (not (numberp MEDIUM))
+    ;;; On acl a medium is a number.
+    (setf (medium-foreground medium) ink)))
 
 (defmethod silica::port-set-pane-text-style ((port acl-port) pane medium style)
   (declare (ignore pane))
-  ;; Invoked :after (setf pane-text-style)
-  (setf (medium-text-style medium) style))
+  (when (not (numberp MEDIUM))
+    ;;; On acl a medium is a number.
+    (setf (medium-text-style medium) style)))
 
 (defmethod initialize-instance :before ((port acl-port) &key)
   (ensure-clim-initialized)
@@ -457,16 +463,16 @@
     (or (gethash style text-style->acl-font-mapping)
 	(setf (gethash style text-style->acl-font-mapping)
 	  (let ((name (silica::device-font-name style)))
-	    (make-device-font (win:getstockobject name)))))))
+	    (make-device-font (win:GetStockObject name)))))))
 
 (defun make-font-width-table (dc last-character first-character default-width)
-  (let* ((tepsize (ct:ccallocate win::size))
+  (let* ((tepsize (ct:ccallocate win:size))
 	 (string (make-string 1) )
 	 (array (make-array (1+ last-character))))
     (loop for i from first-character to last-character do
 	  (setf (char string 0) (code-char i))
 	  (cond ((excl:with-native-string (string string)
-		   (win:getTextExtentPoint dc string 1 tepsize))
+		   (win:GetTextExtentPoint dc string 1 tepsize))
 		 (setf (aref array i) (ct:cref win:size tepsize cx)))
 		(t
 		 ;; Why does this clause ever run?  getlasterror=10035.
@@ -475,7 +481,7 @@
     array))
 
 (defun make-system-font ()
-  (make-device-font (win:getstockobject win:system_font)))
+  (make-device-font (win:GetStockObject win:SYSTEM_FONT)))
 
 ;; This should be in the WIN package but isn't.
 ;; We use it to specify how Windows matches font requests to a
@@ -499,7 +505,7 @@
   (unless win-font
     (setq win-font
       (excl:with-native-string (vface (or face ""))
-	(win:createFont height		; logical height
+	(win:CreateFont height		; logical height
 			width		; logical average width
 			escapement	; angle of escapement (tenths of degrees)
 			orientation	; normally the same as escapement
@@ -524,13 +530,13 @@
 		 (sheet-mirror (frame-top-level-sheet *application-frame*))))
 	(tmstruct (ct:ccallocate win:textmetric)))
     (unless cw (setf cw *current-window*))
-    (unless (win:iswindow cw) 
+    (unless (win:IsWindow cw) 
       ;; This clause is for the rare case that you are doing drawing
       ;; from a background process the first time you attempt to use
       ;; this font.  It doesn't really matter which frame you pick.
       (let* ((framem (find-frame-manager))
 	     (frame (some #'(lambda (f)
-			      (when (win:iswindow
+			      (when (win:IsWindow
 				     (sheet-mirror (frame-top-level-sheet
 						    f)))
 				f))
@@ -538,12 +544,13 @@
 			    (frame-manager-frames framem)))))
 	(when frame
 	  (setq cw (sheet-mirror (frame-top-level-sheet frame))))))
-    (unless (win:iswindow cw) 
+    (unless (win:IsWindow cw) 
       (error "No window found for calculating text font metrics."))
     (with-dc (cw dc)
-      (win:setmapmode dc win:MM_TEXT)
-      (selectobject dc win-font)
-      (or (win:getTextMetrics dc tmstruct)
+      (win:SetMapMode dc win:MM_TEXT)
+      (assert (valid-handle dc))
+      (when (valid-handle win-font) (selectobject dc win-font))
+      (or (win:GetTextMetrics dc tmstruct)
 	  (check-last-error "GetTextMetrics"))
       (let ((average-character-width
 	     (ct:cref win:textmetric tmstruct tmavecharwidth))
@@ -613,12 +620,12 @@
 ;; The second element of each item is passed to
 ;; LoadCursor and SetCursor.
 (defvar *win-cursor-type-alist*
-    `((:appstarting ,win:idc_appstarting)
+    `((:appstarting ,win:IDC_APPSTARTING)
       (:default ,win:IDC_ARROW)
       (:position ,win:IDC_CROSS)
-      (:ibeam ,win:idc_ibeam)
+      (:ibeam ,win:IDC_IBEAM)
       #+ignore
-      (:no ,win:idc_no)
+      (:no ,win:IDC_NO)
       (:move ,win:IDC_SIZEALL)
       (:vertical-scroll ,win:IDC_SIZENS)
       (:horizontal-scroll ,win:IDC_SIZEWE)
@@ -627,22 +634,12 @@
 
 (defmethod port-set-pointer-cursor ((port acl-port) pointer cursor)
   (unless (eq (pointer-cursor pointer) cursor)
-    (win:setCursor (realize-cursor port cursor)) ; mouse cursor
+    (win:SetCursor (realize-cursor port cursor)) ; mouse cursor
     )
   cursor)
 
 (defmethod port-set-sheet-pointer-cursor ((port acl-port) sheet cursor)
-  (unless (eq (sheet-pointer-cursor sheet) cursor)
-    #+ignore
-    (win:setCursor (realize-cursor port cursor)) ; mouse cursor
-    ;; SetCursor doesn't seem to be the right thing.
-    ;; Each time the mouse moves, Windows sets the cursor back
-    ;; to the default for the class and then sends a WM_SETCURSOR
-    ;; message where we get a chance to SetCursor again.  
-    (win:setClassLong (sheet-mirror sheet) 
-		      -12		; GCL_HCURSOR
-		      (realize-cursor port cursor))
-    )
+  (unless (eq (sheet-pointer-cursor sheet) cursor) (set-cursor sheet cursor))
   cursor)
 
 (defmethod realize-cursor ((port acl-port) (cursor symbol))
@@ -674,29 +671,28 @@
 	(setf (getf cursor-cache cursor)
 	  (call-next-method)))))
 
-;; pointer-grabbing - how do you do this on windows? - the following
-;; simply deals with the handling of the cursor keyword (cim 10/14/96)
-
-;; I think you do this on windows by using SetCapture
-;; and ReleaseCapture.  JPM 5/98.
-
 (defmethod port-invoke-with-pointer-grabbed
     ((port acl-port) (sheet basic-sheet) continuation
      &key cursor &allow-other-keys)
   (clim-utils:letf-globally (((port-grab-cursor port) cursor))
-    (funcall continuation)))
+    (unwind-protect
+	(with-sheet-medium (medium sheet)
+	  (win:SetCapture (medium-drawable medium))
+	  (set-cursor sheet cursor)
+	  (funcall continuation))
+      (win:ReleaseCapture))))
 
 ;; X and Y are in native coordinates
 (defmethod port-set-pointer-position ((port acl-port) pointer x y)
   (declare (ignore pointer))
   (fix-coordinates x y)
-  (or (win:setCursorPos x y)
+  (or (win:SetCursorPos x y)
       (check-last-error "SetCursorPos")))
 
 (defmethod clim-internals::port-query-pointer ((port acl-port) sheet)
   (let ((point (ct:ccallocate win:point))
 	(native-x 0)(native-y 0))
-    (or (win:getCursorPos point)
+    (or (win:GetCursorPos point)
 	(check-last-error "GetCursorPos"))
     (let ((root-x (ct:cref win:point point x))
 	  (root-y (ct:cref win:point point y)))
@@ -761,7 +757,7 @@
 		(eq y pointer-y))
 	   nil)
 	  (t
-	   #+debug
+	  #+debug
 	   (format *trace-output* 
 		   "~% Was ~A ~A ~A IS ~A ~A ~A~%"
 		   pointer-sheet pointer-x pointer-y
@@ -775,9 +771,13 @@
 (defmethod flush-pointer-motion ((port acl-port))
   (with-slots (event-queue motion-pending pointer-sheet pointer-x pointer-y)
       port
-    (when pointer-sheet
+    (when (and pointer-sheet motion-pending)
       (let ((pointer (port-pointer port)))
 	(when pointer
+	  #+debug
+	  (format *trace-output* 
+		  "~% IS ~A ~A ~A~%"
+		  pointer-x pointer-y pointer-sheet)
 	  (queue-put event-queue
 		     (allocate-event 'pointer-motion-event
 				     :native-x pointer-x
@@ -821,27 +821,6 @@
   (let ((sheet (or (silica::event-mswin-control event) (event-sheet event))))
     (silica::dispatch-pointer-event-to-sheet port event sheet)))
 
-;; what's with this hacked queue-get?? (cim 9/16/96)
-
-#+obsolete
-(defmethod queue-get ((queue acl-event-queue) &optional default)
-  "return the element at the head of the queue
-   deleteing it from the queue"
-  (if (queue-empty-p queue)
-    default
-    (let ((event (queue-next queue))
-          (sheet nil))
-      (setf (clim-utils::queue-head queue)
-	(clim-utils::free-cons queue (clim-utils::queue-head queue)))
-      (if (and (or (typep event 'device-event)
-		   (typep event 'window-event))
-	       (or (not (setq sheet (event-sheet event)))
-		   (not (slot-value sheet 'silica::mirror))))
-	  (progn
-	    (deallocate-event event)
-	    (queue-get queue))
-	event))))
-
 (defvar *l-counter* 0)
 (defvar *nowait* nil)
 
@@ -849,7 +828,8 @@
 
 ;; Redefine function from utils/processes.lisp.
 (defun clim-utils::process-wait (state function &rest args)
-  (declare (dynamic-extent function args))
+  (declare (dynamic-extent function args)
+	   (optimize (speed 3) (safety 0)))
   #+someday
   (apply #'mp:process-wait state function args)
   (let ((result nil))
@@ -911,7 +891,7 @@
     (setf mirror (slot-value sheet 'silica::mirror))
     (if (not mirror)
       (deallocate-event event)
-      (unless (win:isIconic mirror)
+      (unless (win:IsIconic mirror)
         (let ((native-region (mirror-region port sheet)))
 	  (setf (slot-value event 'silica::native-region) native-region)
 	  (setf (slot-value event 'silica::region)
@@ -919,11 +899,20 @@
 				    native-region)))
         (call-next-method)))))
 
+(defvar *system-version* nil)
+
 (defun get-system-version ()
-  "Use win:GetVersion to determine the operating system being used."
-  (let* ((v (win:GetVersion))
-         (vh (hiword v)))
-    (if (>= vh 0) :winnt :win31)))
+  "Use win:GetVersionEx to determine the operating system being used."
+  (or *system-version*
+      (setq *system-version*
+	(let ((v (ff:allocate-fobject 'win::osversioninfo)))
+	  (setf (ct:cref win::osversioninfo v dwOSVersionInfoSize) 
+	    (ct:sizeof win::osversioninfo))
+	  (win::GetVersionEx v)
+	  (case (ct:cref win::osversioninfo v dwPlatformID)
+	    (#.WIN::VER_PLATFORM_WIN32_WINDOWS :win9598)
+	    (#.WIN::VER_PLATFORM_WIN32S :win31)
+	    (#.WIN::VER_PLATFORM_WIN32_NT :winnt))))))
 
 (defun silica::acl-mirror-with-focus ()
   (acl-port-mirror-with-focus *acl-port*))
diff --git a/aclpc/acl-prel.lisp b/aclpc/acl-prel.lisp
index c68d07fca040960c0340f058a67ed6689e6f3207..329089f99706dc22aefec5313efea8b7e8f7dffa 100644
--- a/aclpc/acl-prel.lisp
+++ b/aclpc/acl-prel.lisp
@@ -15,7 +15,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-prel.lisp,v 1.9 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-prel.lisp,v 1.10 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -47,7 +47,7 @@
   (declare (ignore id))
   (let* ((hwnd
 	  (excl:with-native-string (x "COMBOBOX")
-	    (excl:with-native-string (label (nstringify label))
+	    (excl:with-native-string (label label)
 	      (win:CreateWindowEx 
 	       0			; extended-style
 	       x			; classname
@@ -125,7 +125,7 @@
 	 (exstyle win:WS_EX_CLIENTEDGE)
 	 (hwnd
 	  (excl:with-native-string (classname "LISTBOX")
-	    (excl:with-native-string (windowname (nstringify label))
+	    (excl:with-native-string (windowname label)
 	      (win:CreateWindowEx exstyle
 				  classname ; classname
 				  windowname ; windowname
@@ -150,12 +150,6 @@
 	       )
 	  (dolist (item items)
 	    (setf item-name (funcall name-key item))
-	    #+ignore
-	    (setf subsize (length item-name))
-	    #+ignore
-	    (dotimes (i subsize)
-	      (ct:cset (:char 256) cstr ((fixnum i))
-		       (char-int (char item-name i))))
 	    (incf index)
 	    (excl:with-native-string (item-name item-name)
 	      (win:SendMessage hwnd win:LB_INSERTSTRING index item-name))
@@ -179,7 +173,6 @@
 	    (when i 
 	      (win:SendMessage 
 	       hwnd win:LB_SETCURSEL i 0))))
-
 	;; we put in the 20% hack because
 	;; compute-set-gadget-dimensions in acl-widg is
 	;; inherently wrong - see the comment (cim 9/25/96)
@@ -193,7 +186,7 @@
 (defun scrollbar-open (parent left top width height orientation)
   (let* ((hwnd
 	  (excl:with-native-string (classname "SCROLLBAR")
-	    (excl:with-native-string (windowname (nstringify ""))
+	    (excl:with-native-string (windowname "")
 	      (win:CreateWindowEx 
 	       0			; style
 	       classname		; classname
@@ -239,7 +232,7 @@
   (let* ((nlabel (cleanup-button-label label))
 	 (hwnd
 	  (excl:with-native-string (classname "BUTTON")
-	    (excl:with-native-string (windowname (nstringify nlabel) )
+	    (excl:with-native-string (windowname nlabel)
 	      (win:CreateWindowEx 0
 				  classname ; classname
 				  windowname ; windowname
@@ -277,7 +270,7 @@
   (declare (ignore id))
   (let* ((hwnd
 	  (excl:with-native-string (classname "EDIT")
-	    (excl:with-native-string (windowname (nstringify label))
+	    (excl:with-native-string (windowname label)
 	      (win:CreateWindowEx 
 	       win:WS_EX_CLIENTEDGE
 	       classname		; classname
@@ -329,15 +322,11 @@
 (defconstant +bitmapinfosize+ (+ (ct:sizeof win:bitmapinfoheader)
 				 (* +maxcolors+ (ct:sizeof win:rgbquad))))
 
-;; The use of this prevents bitmap drawing from being reentrant.  JPM 5/98.
-(defconstant +rgb-bitmapinfo+
-    (ct:callocate win:bitmapinfo :size +bitmapinfosize+))
-
 (defun acl-bitmapinfo (colors width height medium)
   (assert (<= (length colors) +maxcolors+))
   ;; returns the appropriate bitmapinfo and DIB_XXX_COLORS constant
   (let ((bitcount +bits-per-pixel+)
-	(bmi +rgb-bitmapinfo+))
+	(bmi (ct:callocate win:bitmapinfo :size +bitmapinfosize+)))
     (ct:csets win:bitmapinfoheader bmi
 	      biSize (ct:sizeof win:bitmapinfoheader)
 	      biWidth width
@@ -392,6 +381,9 @@
 	   pixel-map
 	   bitmapinfo 
 	   win:DIB_RGB_COLORS)))
+    ;; I guess we don't want to release the device context
+    ;; until we destroy the DIBitmap.
+    ;;(unless (zerop dc) (win:ReleaseDC 0 dc))
     (when (zerop texture-handle)
       ;;Below is Charley Cox's May 6 message from bug5991 (common graphics)
       ;;
diff --git a/aclpc/acl-scroll.lisp b/aclpc/acl-scroll.lisp
index 40d3e19a7a2a630367cad56ca2084be2ed180391..4128b99f16a3fefd6e34c85803850eb1d3f7635d 100644
--- a/aclpc/acl-scroll.lisp
+++ b/aclpc/acl-scroll.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-scroll.lisp,v 1.8 1999/02/25 08:23:25 layer Exp $
+;; $Id: acl-scroll.lisp,v 1.9 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -118,6 +118,10 @@
 (defmethod gadget-supplies-scrolling-p ((sheet hlist-pane)) t)
 (defmethod gadget-supplies-scrolling-p ((sheet acl-clim::acl-text-editor-pane)) t)
 
+(defmethod acl-clim::sheet-wants-default-pointer 
+    ((object silica::mswin-scroller-pane))
+  (acl-clim::sheet-wants-default-pointer (slot-value object 'contents)))
+
 (defmethod handle-event ((pane mswin-scroller-pane) 
 			 (event scrollbar-event))
   (with-slots (orientation action amount) event
diff --git a/aclpc/acl-widget.lisp b/aclpc/acl-widget.lisp
index 20675f68fccca5d2364ea4c4262eab5a220eb491..ebf05433b03ce7bbd3bc59a97a1fb48291e612d6 100644
--- a/aclpc/acl-widget.lisp
+++ b/aclpc/acl-widget.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: acl-widget.lisp,v 1.12 1999/05/04 01:21:00 layer Exp $
+;; $Id: acl-widget.lisp,v 1.13 1999/07/19 22:25:10 layer Exp $
 
 #|****************************************************************************
 *                                                                            *
@@ -30,9 +30,6 @@
 
 (in-package :silica)
 
-(defvar *hbutton-width* 21)
-(defvar *hbutton-height* 21)
-
 ;;mm: Some new mixins
 
 (defclass acl-gadget-id-mixin ()
@@ -60,13 +57,10 @@
 ;;; list panes
 
 (defclass hlist-pane
-	  (
-	   ;;mm: to keep track of Windows gadget ids
-	   acl-gadget-id-mixin   
+	  (acl-gadget-id-mixin   
            mirrored-sheet-mixin
 	   list-pane
 	   sheet-permanently-enabled-mixin
-	   ; try without this sheet-mute-input-mixin
 	   space-requirement-mixin
 	   basic-pane)
   ()
@@ -80,10 +74,9 @@
   (let ((mirror (sheet-direct-mirror pane))
 	(index 0))
     (when mirror
-      (setf index (win:SendMessage mirror win:LB_GETCURSEL 0 0))
+      (setf index (acl-clim::frame-send-message (pane-frame pane)
+				      mirror win:LB_GETCURSEL 0 0))
       (with-slots (items value mode value-key name-key) pane
-	;;mm: 11Jan95 - we need to invoke the callback so that list-pane-view 
-	;;              will return a value.
 	(ecase mode
 	  (:exclusive
 	   (setf (gadget-value pane :invoke-callback t)
@@ -104,7 +97,8 @@
 	(if (eq mode :nonexclusive)
 	    (let ((i 0))
 	      (dolist (item items)
-		(win:SendMessage
+		(acl-clim::frame-send-message
+		 (pane-frame pane)
 		 ;; what's the "correct" way of passing
 		 ;; both lo and hi parts without
 		 ;; combining them with an ash? (cim 9/20/96)
@@ -117,9 +111,9 @@
 		(incf i)))
 	  (let ((i (position value items
 			     :key value-key :test test)))
-	    (when i 
-	      (win:SendMessage 
-	       hwnd win:LB_SETCURSEL i 0))))
+	    (acl-clim::frame-send-message
+	     (pane-frame pane)
+	     hwnd win:LB_SETCURSEL (or i -1) 0)))
 	))))
 
 (defmethod handle-event :after ((pane hlist-pane) (event pointer-event))
@@ -137,49 +131,66 @@
 	(tsh 0))
     (with-slots (items name-key text-style) pane
       (with-sheet-medium (medium pane)
-	(multiple-value-setq (name-width tsh)
-	  (text-size medium "Frobnitz" :text-style text-style))
 	(dolist (item items)
 	  (multiple-value-bind (w h)
 	      (text-size medium (funcall name-key item) :text-style text-style)
-	    (declare (ignore h))
-	    (setq name-width (max name-width w))))))
+	    (setq name-width (max name-width w))
+	    (setq tsh (max h tsh))))
+	(when (and (zerop tsh) (zerop name-width))
+	  (multiple-value-setq (name-width tsh)
+	    (text-size medium "Frobnitz" :text-style text-style)))))
     (values name-width tsh)))
     
 (defmethod compose-space ((pane hlist-pane) &key width height)
   (declare (ignore width height))
   (with-slots (items name-key text-style visible-items
 		     initial-space-requirement) pane
-    (let ((name-width 0)
-	  (name-height 0)
-          (tsh 0)
-          (iwid (or (space-requirement-width initial-space-requirement) 0))
-          (ihgt (or (space-requirement-height initial-space-requirement) 0))
-	  )
+    (let* ((name-width 0)
+	   (name-height 0)
+	   (tsh 0)
+	   (iwid (or (space-requirement-width initial-space-requirement) 0))
+	   (ihgt (or (space-requirement-height initial-space-requirement) 0))
+#+ign
+	   (par (sheet-parent pane))
+#+ign
+	   (scroll-mode (and (acl-clim::scroller-pane-p par)
+			     (scroller-pane-scroll-bar-policy par)))
+	   )
       (multiple-value-setq (name-width tsh)
 	(compute-set-gadget-dimensions pane))
-      (setq name-height (* (if visible-items visible-items (max (length items) 1))
+      (setq name-height (* (or visible-items (max (length items) 1))
                            tsh))
-      (if (and (> iwid 0) #||(null items)||#)
+      (if (> iwid 0)
           (setq name-width iwid)
           (setq name-width (max name-width iwid)))
       (setq name-height (max name-height ihgt))
-      (make-space-requirement
-        :width (+ name-width 20)
-        :height name-height))))
 
-;;; When items are set in an hlist-pane the  mirror must be
-;;; made to update its appearance appropriately.
+      (let ((w (+ name-width 20))
+	    (h name-height))
+#+ign
+	(when (member scroll-mode '(:horizontal :both t :dynamic))
+	  (let ((wstx (win-scroll-thick :x)))
+	    ;; Allow for the horizontal scrollbar
+	    (setq h (+ h wstx))))
+	(make-space-requirement
+	 :width w
+	 :height h)))))
+
 (defmethod (setf set-gadget-items) :before (items (pane hlist-pane))
+  ;; When items are set in an hlist-pane the  mirror must be
+  ;; made to update its appearance appropriately.
   (with-slots (name-key mirror) pane
     (when mirror
-      (win:SendMessage mirror win:LB_RESETCONTENT 0 0)
+      (acl-clim::frame-send-message
+       (pane-frame pane)
+       mirror win:LB_RESETCONTENT 0 0)
       (dolist (item items)
-	(let ((str (acl-clim::nstringify (funcall name-key item)))
+	(let ((str (funcall name-key item))
 	      (pos (position item items)))
-	  ;;(break "insert gadget item [~a @ ~a]" str pos)
 	  (excl:with-native-string (str str)
-	    (win:SendMessage mirror win:LB_INSERTSTRING pos str))))
+	    (acl-clim::frame-send-message
+	     (pane-frame pane)
+	     mirror win:LB_INSERTSTRING pos str))))
       (win:InvalidateRect mirror ct:hnull win:TRUE)))) ;; make sure it updates
 
 (defmethod acl-clim::command-event :around ((gadget hlist-pane) 
@@ -195,7 +206,7 @@
 
 (defclass mswin-text-edit (acl-gadget-id-mixin 
 			   mirrored-sheet-mixin 
-			   text-field	;-pane
+			   text-field 
 			   sheet-permanently-enabled-mixin
 			   space-requirement-mixin
 			   basic-pane)
@@ -203,7 +214,8 @@
    (depth :initarg :depth)
    (x-margin :initarg :x-margin)
    (y-margin :initarg :y-margin)
-   ;; needed for text-editor
+   ;; We probably should be inheriting from text-editor,
+   ;; not text-field.
    (ncolumns :initarg :ncolumns
 	     :accessor gadget-columns)
    (nlines :initarg :nlines
@@ -225,9 +237,9 @@
   (declare (ignore region))
   nil)
 
-;; text-editor is one of the few things that you can specify:
-;;    :width '(4 :character)
 (defun process-width-specification (sheet width)
+  ;; text-editor is one of the few things that you can specify:
+  ;;    :width '(4 :character)
   (typecase width
     (cons
      (assert (eq (second width) :character))
@@ -236,21 +248,21 @@
 	      (style (medium-default-text-style medium))
 	      (style-width (text-style-width style medium))
 	      (margin (slot-value sheet 'x-margin))
-	      (border 2))
+	      (border 4))
 	 (+ border margin (* style-width nchars) margin border))))
     (string 
      (with-sheet-medium (medium sheet)
        (let ((w 
 	      (text-size sheet width
 			 :text-style (medium-default-text-style medium)))
-	     (border 2)
+	     (border 4)
 	     (margin (slot-value sheet 'x-margin)))
 	 (+ border margin w margin border))))
     (otherwise width)))
 
-;; text-editor is one of the few things that you can specify:
-;;    :height '(4 :line)
 (defun process-height-specification (sheet height)
+  ;; text-editor is one of the few things that you can specify:
+  ;;    :height '(4 :line)
   (typecase height
     (cons
      (assert (eq (second height) :line))
@@ -272,32 +284,70 @@
 	   (+ border margin h margin border)))))
     (otherwise height)))
 
+;; Kludge.  Sorry.  This is a workaround for the fact that
+;; the min height in a +text-field-view+ is zero.  At some
+;; point, lets try modifying +text-field-view+ and 
+;; +text-editor-view+ to supply better default sizes.
+(defvar *min-text-field-width* 75)
+(defvar *min-text-field-height* 25)
+
 (defmethod compose-space ((pane mswin-text-edit) &key width height)
-  (with-slots (x-margin y-margin initial-space-requirement) pane
-    ;; WIDTH
-    (unless width
-      ;; width from text-field-view comes in here
-      (setq width (space-requirement-width initial-space-requirement)))
-    (setq width (process-width-specification pane width))
-    (when (and width (< width 1)) (setq width nil))
-    (unless width
-      (let ((twidth (process-width-specification 
-		     pane (or (gadget-value pane) '(20 :character)))))
-	(setq width (max 50 twidth))))
-    ;; HEIGHT
-    (unless height
-      ;; height from text-field-view comes in here
-      (setq height (space-requirement-height initial-space-requirement)))
-    (setq height (process-height-specification pane height))
-    (when (and height (< height 1)) (setq height nil))
-    (unless height
-      (let ((theight (process-height-specification 
-		      pane (or (gadget-value pane) '(1 :line)))))
-	(setq height (max 25 theight))))
-    ;; FINALLY...
-    (make-space-requirement
-     :width  width
-     :height height)))
+  (declare (ignore width height))
+  ;; Note that text-editors are scrolled by  being given 
+  ;; a scroller-pane as a parent, but they have their own 
+  ;; "interior" scrollbars (this is different than text-fields.)
+  (with-slots (x-margin y-margin initial-space-requirement nlines ncolumns) pane
+    (let* ((par (sheet-parent pane))
+	   (scroll-mode (and (acl-clim::scroller-pane-p par)
+			     (scroller-pane-scroll-bar-policy par))))
+      (let ((w 0) 
+	    (min-w (process-width-specification pane '(1 :character)))
+	    (h 0)
+	    (value (gadget-value pane))
+	    (min-h (process-height-specification pane '(1 :line))))
+	;; WIDTH
+	(cond (initial-space-requirement
+	       ;; This is where accepting-values views factors in.
+	       (setq w (max (process-width-specification 
+			     pane (space-requirement-width initial-space-requirement))
+			    *min-text-field-width*)))
+	      (ncolumns
+	       (setq w (process-width-specification pane `(,ncolumns :character))))
+	      ((stringp value)
+	       (setq w (process-width-specification pane value)))
+	      (t
+	       (setq w (process-width-specification pane `(20 :character)))))
+	(when (member scroll-mode '(:horizontal :both t :dynamic))
+	  ;; Allow for the vertical scrollbar
+	  (let ((wsty (win-scroll-thick :y)))
+	    (setq min-w (+ min-w wsty))
+	    (setq w (+ w wsty))))
+	(setq w (max w min-w))
+
+	;; HEIGHT
+	(cond (initial-space-requirement
+	       ;; This is where accepting-values views factors in.
+	       (setq h (max (process-height-specification 
+			     pane (space-requirement-height initial-space-requirement))
+			    *min-text-field-height*)))
+	      (nlines
+	       (setq h (process-height-specification pane `(,nlines :line))))
+	      ((stringp value)
+	       (setq h (process-height-specification pane value)))
+	      (t
+	       (setq h (process-height-specification pane '(1 :line)))))
+
+	(when (member scroll-mode '(:horizontal :both t :dynamic))
+	  (let ((wstx (win-scroll-thick :x)))
+	    ;; Allow for the horizontal scrollbar
+	    (setq min-h (+ min-h wstx)
+		  h (+ h wstx))))
+	(setq h (max h min-h))
+
+	(make-space-requirement
+	 :width  w :min-width min-w
+	 :height h :min-height min-h
+	 )))))
 
 (defmethod initialize-instance :after ((sheet mswin-text-edit) 
 				       &key background label) 
@@ -372,30 +422,42 @@
       (setq value new)
       (when mirror
 	;; How do I get leftchar?
-	(setq topline (win:SendMessage mirror win:EM_GETFIRSTVISIBLELINE 0 0))
-	;; Don't redraw till I tell you:
-	(win:SendMessage mirror win:WM_SETREDRAW 0 0)
+	(setq topline (acl-clim::frame-send-message 
+		       (pane-frame pane)
+		       mirror win:EM_GETFIRSTVISIBLELINE 0 0))
+	;; Disable redraw to avoid flicker.
+	(acl-clim::frame-send-message
+	 (pane-frame pane) mirror win:WM_SETREDRAW 0 0)
 	;; Here's the text:
+	#+broken ; dies when string contains newline/return
 	(excl:with-native-string (s1 (xlat-newline-return new))
 	  (win:SetWindowText mirror s1))
+	(win:SetWindowText mirror (xlat-newline-return new))
 	;; Try to preserve the scroll position:
-	(win:SendMessage mirror win:EM_LINESCROLL leftchar topline)
-	;; Redraw now:
-	(win:SendMessage mirror win:WM_SETREDRAW 1 0)
+	(acl-clim::frame-send-message
+	 (pane-frame pane) mirror win:EM_LINESCROLL leftchar topline)
+	;; Enable redraw
+	(acl-clim::frame-send-message
+	 (pane-frame pane) mirror win:WM_SETREDRAW 1 0)
+	;; Force redraw
+	(win:InvalidateRect mirror 0 win:TRUE)
+	(or (win:UpdateWindow mirror)	; send a WM_PAINT message
+	    (acl-clim::check-last-error "UpdateWindow" :action :warn))
 	))))
 
 (defmethod gadget-value ((pane mswin-text-edit))
   (with-slots (mirror value) pane
     (if mirror	
-	(let* ((wl (win:SendMessage mirror 
-				    win:WM_GETTEXTLENGTH 
-				    0 0))
+	(let* ((wl (acl-clim::frame-send-message (pane-frame pane)
+				       mirror 
+				       win:WM_GETTEXTLENGTH 
+				       0 0))
 	       (teb
 		#+removed (make-string wl)
 		(make-array wl :element-type '(unsigned-byte 8)))
 	       (tlen (win:GetWindowText mirror teb (1+ wl))))
 	  (declare (ignorable tlen))
-	  (setf teb (unxlat-newline-return (excl:mb-to-string teb)))
+	  (setf teb (unxlat-newline-return (excl:mb-to-string teb))) 
 	  (setf value teb)
 	  ;; By the way, does anyone know why 
 	  ;; the second value is returned? -smh
@@ -411,11 +473,12 @@
       (call-next-method gadget port sheet wparam lparam))))
 
 (defmethod text-edit-flags ((sheet mswin-text-edit))
-  (logior win:ES_AUTOHSCROLL win:ES_LEFT win:WS_BORDER
-	  win:ES_MULTILINE win:ES_AUTOVSCROLL))
+  (logior 
+   (if (gadget-editable-p sheet) 0 win:ES_READONLY)
+   win:ES_AUTOHSCROLL win:ES_LEFT win:WS_BORDER
+   win:ES_MULTILINE win:ES_AUTOVSCROLL))
 
 (defmethod realize-mirror ((port acl-clim::acl-port) (sheet mswin-text-edit))
-  (declare (special *hbutton-width* *hbutton-height*))
   (multiple-value-bind (left top right bottom)
       (sheet-native-region* sheet)
     (fix-coordinates left top right bottom)
@@ -433,7 +496,7 @@
 			      :value (slot-value sheet 'value)
 			      :scroll-mode 
 			      (let ((p (sheet-parent sheet)))
-				(and (typep p 'scroller-pane)
+				(and (acl-clim::scroller-pane-p p)
 				     (scroller-pane-scroll-bar-policy p)))
 			      ))
       (setf (sheet-native-transformation sheet)
@@ -442,14 +505,18 @@
       (let ((text-style (pane-text-style sheet)))
 	(when text-style
 	  (let ((font (text-style-mapping port text-style)))
-	    (win:SendMessage window win:WM_SETFONT 
+	    (acl-clim::frame-send-message
+	     (pane-frame sheet)
+	     window win:WM_SETFONT 
 			     (acl-clim::acl-font-index font) 0))))
-      ;; Don't know how to set the y margins.
+      ;; Don't know how to set the y margins, but they look pretty good anyway.
       (with-slots (x-margin) sheet
-	(win:SendMessage window #xD3	; win:EM_SETMARGINS
-			 (logior 1	;win:EC_LEFTMARGIN 
-				 2	;win:EC_RIGHTMARGIN
-				 )
+	(acl-clim::frame-send-message
+	 (pane-frame sheet)
+	 window acl-clim::EM_SETMARGINS
+			 ;;acl-clim::EC_USEFONTINFO
+			 (logior acl-clim::EC_LEFTMARGIN 
+				 acl-clim::EC_RIGHTMARGIN)
 			 x-margin))
       ;; It's too soon for this.  Need to do this later, 
       ;; after the layout has been processed, but where?
@@ -463,11 +530,73 @@
       :external-label nil
       :x-margin 2 :y-margin 2))
 
+(defmethod isa-textfield ((object t)) nil)
+(defmethod isa-textfield ((object mswin-text-field)) t)
+
 (defmethod text-edit-flags ((sheet mswin-text-field))
-  (logior win:ES_AUTOHSCROLL win:ES_LEFT win:WS_BORDER))
+  (logior 
+   (if (gadget-editable-p sheet) 0 win:ES_READONLY)
+   win:ES_AUTOHSCROLL win:ES_LEFT win:WS_BORDER))
+
+(defmethod isa-viewport ((object t)) nil)
+(defmethod isa-viewport ((object viewport)) t)
+
+(defmethod compose-space ((pane mswin-text-field) &key width height)
+  ;;; Note that text-fields are scrolled by
+  ;;; being given a viewport as a parent (this is different
+  ;;; than text-editors.)
+  ;;;
+  ;;; As a result, if the parent is a viewport, and if width/height
+  ;;; is specified, we want to use that value (i.e. in order
+  ;;; to fill the space provided by the viewport).
+  (with-slots (x-margin y-margin initial-space-requirement nlines ncolumns) 
+      pane
+    (let* ((parent (sheet-parent pane))
+	   (parent-viewport-p (isa-viewport parent)))
+      (let ((w 0) 
+	    (min-w (process-width-specification pane '(1 :character)))
+	    (h 0)
+	    (value (gadget-value pane))
+	    (min-h (process-height-specification pane '(1 :line))))
+	;; WIDTH
+	(cond (parent-viewport-p
+	       (setq w (process-width-specification pane width)))
+	      (initial-space-requirement
+	       ;; This is where accepting-values views factors in.
+	       (setq w (max (process-width-specification 
+			     pane (space-requirement-width initial-space-requirement))
+			    *min-text-field-width*)))
+	      (ncolumns
+	       (setq w (process-width-specification pane `(,ncolumns :character))))
+	      ((stringp value)
+	       (setq w (process-width-specification pane value)))
+	      (t
+	       (setq w (process-width-specification pane `(20 :character)))))
+	(setq w (max w min-w))
+
+	;; HEIGHT
+	(cond (parent-viewport-p
+	       (setq h (process-height-specification pane height)))
+	      (initial-space-requirement
+	       ;; This is where accepting-values views factors in.
+	       (setq h (max (process-height-specification 
+			     pane (space-requirement-height initial-space-requirement))
+			    *min-text-field-height*)))
+	      (nlines
+	       (setq h (process-height-specification pane `(,nlines :line))))
+	      ((stringp value)
+	       (setq h (process-height-specification pane value)))
+	      (t
+	       (setq h (process-height-specification pane '(1 :line))))) 
+	(setq h (max h min-h))
+
+	(make-space-requirement
+	 :width  w :min-width min-w
+	 :height h :min-height min-h
+	 )))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; buttons
+;;; push buttons
 
 (defvar *default-picture-button-op*
     boole-and)
@@ -510,6 +639,76 @@
     ;; picture-buttons look better (cim 10/4/96)
     :x-margin 2 :y-margin 2))
 
+(defvar *hbutton-width* 21)
+(defvar *hbutton-height* 21)
+
+(defmethod realize-mirror ((port acl-clim::acl-port) (sheet hpbutton-pane))
+  (multiple-value-bind (left top right bottom)
+      (sheet-native-region* sheet)
+    (fix-coordinates left top right bottom)
+    (let* ((parent (sheet-mirror sheet))
+	   (parent2 (sheet-mirror (sheet-parent sheet)))
+           (window nil)
+           (buttonstyle nil)
+	   (value nil)
+	   (width (- right left))
+	   (height (- bottom top))
+	   gadget-id)
+      (assert (eq parent parent2) () "parents don't match!")
+      (setq gadget-id (silica::allocate-gadget-id sheet))
+      (setf buttonstyle
+	(if (push-button-show-as-default sheet)
+	    win:BS_DEFPUSHBUTTON
+	  win:BS_PUSHBUTTON))
+      (multiple-value-bind (cwidth cheight)
+	  (compute-gadget-label-size sheet)
+	(setq top (+ top (* gadget-id 25)))
+	(setq left (+ left 50))
+	(setq width (+ cwidth (* 2 *hbutton-width*)))
+	(setq height (max cheight (* 1 *hbutton-height*))))
+      (setq window
+	(let ((label (slot-value sheet 'silica::label))
+	      (resources (acl-clim::port-default-resources port)))
+	  (when (or (acl-clim::isa-pixmap label)
+		    (acl-clim::isa-pattern label))
+	    (setf (slot-value sheet 'silica::pixmap)
+	      (if (acl-clim::isa-pattern label)
+		  (with-sheet-medium (medium sheet)
+		    (with-output-to-pixmap 
+			(stream medium
+				:width (pattern-width label)
+				:height (pattern-height label))
+		      (draw-pattern* stream label 0 0)))
+		label))
+	    (setq buttonstyle win:BS_OWNERDRAW ;; pnc Aug97 for clim2bug740
+		  label nil))
+	  (unless (eq (pane-background sheet) 
+		      (getf resources :background))
+	    (setq buttonstyle win:BS_OWNERDRAW))
+	  (unless (eq (pane-foreground sheet) 
+		      (getf resources :foreground))
+	    (setq buttonstyle win:BS_OWNERDRAW))
+	  (acl-clim::hbutton-open parent gadget-id
+				  left top width height 
+				  :buttonstyle buttonstyle
+				  :value value
+				  :label label)))
+      (setf (sheet-native-transformation sheet)
+	(sheet-native-transformation (sheet-parent sheet)))
+      (setf (silica::gadget-id->window sheet gadget-id) window)
+      (let ((text-style (pane-text-style sheet)))
+	(when text-style
+	  (let ((font (text-style-mapping port text-style)))
+	    (acl-clim::frame-send-message
+	     (pane-frame sheet)
+	     window win:WM_SETFONT 
+			     (acl-clim::acl-font-index font) 0))))
+      (when (sheet-enabled-p sheet)
+	;; It's too soon for this.  Need to do this later, 
+	;; after the layout has been processed, but where?
+	(win:ShowWindow window win:SW_SHOW))
+      window)))
+
 (defmethod compose-space ((pane hpbutton-pane) &key width height)
   (declare (ignore width height))
   (with-slots (external-label x-margin y-margin initial-space-requirement) pane
@@ -539,27 +738,58 @@
 	    :height h :min-height h)))
       )))
 
+(defvar *background-brush* nil)
+
 (defmethod draw-picture-button ((pane hpbutton-pane) state hdc rect)
-  (multiple-value-bind (bwidth bheight)
-      (bounding-rectangle-size pane)
-    (let* ((pixmap (slot-value pane 'pixmap))
-	   (op (slot-value pane 'raster-op))
-	   (width (pixmap-width pixmap))
-	   (height (pixmap-height pixmap))
-	   (x (floor (- bwidth width) 2))
-	   (y (floor (- bheight height) 2))
-	   (selected (logtest state win:ODS_SELECTED)))
-      (when selected
-	(incf x)
-	(incf y))
+  ;; Handle the drawing part of owner-drawn buttons (BS_OWNERDRAW).
+  (assert (acl-clim::valid-handle hdc))
+  (let ((bg (acl-clim::color->wincolor (pane-background pane)))
+	(fg (acl-clim::color->wincolor (pane-foreground pane))))
+    (multiple-value-bind (bwidth bheight)
+	(bounding-rectangle-size pane)
+      (win:SetBkMode hdc win:OPAQUE)
+      (win:SetBkColor hdc bg)
+      (win:SetTextColor hdc fg)
+      (win:SetRop2 hdc win:R2_COPYPEN)
+      (let ((brush (win:CreateSolidBrush bg)))
+	(win:SelectObject hdc brush))
       (win:DrawEdge hdc
-		     rect 
-		     (if selected
-			 win:BDR_SUNKEN
-		       win:BDR_RAISED)
-		     (+ win:BF_RECT win:BF_MIDDLE))
-      (win:BitBlt hdc x y width height (acl-clim::pixmap-cdc pixmap) 0 0
-		   (acl-clim::bop->winop op)))))
+		    rect 
+		    (if (logtest state win:ODS_SELECTED)
+			win:BDR_SUNKEN
+		      win:BDR_RAISED)
+		    (+ win:BF_RECT win:BF_MIDDLE))
+      (win:rectangle hdc 1 1 (- bwidth 2) (- bheight 2))
+      (let ((pixmap (slot-value pane 'pixmap))
+	    (label (gadget-label pane)))
+	(cond (pixmap
+	       (let* ((op (slot-value pane 'raster-op))
+		      (width (pixmap-width pixmap))
+		      (height (pixmap-height pixmap))
+		      (x (floor (- bwidth width) 2))
+		      (y (floor (- bheight height) 2)))
+		 (when (logtest state win:ODS_SELECTED)
+		   (incf x)
+		   (incf y))
+		 (win:BitBlt hdc x y width height (acl-clim::pixmap-cdc pixmap) 0 0
+			     (acl-clim::bop->winop op))))
+	      (label
+	       (acl-clim::adjust-gadget-colors pane hdc)
+	       (with-sheet-medium (medium pane)
+		 (let* ((port (port medium))
+			(text-style (medium-merged-text-style medium))
+			(font (text-style-mapping port text-style))
+			(index (acl-clim::acl-font-index font)))
+		   (when (acl-clim::valid-handle index) (win:selectobject hdc index))
+		   (multiple-value-bind (cstr len)
+		       (silica::xlat-newline-return label)
+		     (multiple-value-bind (width height) 
+			 (text-size medium label :text-style text-style)
+		       (let ((x (floor (- bwidth width) 2))
+			     (y (floor (- bheight height) 2)))
+			 (or (win:TextOut hdc x y cstr len) 
+			     (acl-clim::check-last-error "TextOut" :action :warn)))
+		       ))))))))))
 
 ;; deallocate and pixmap associated with a picture button when it's
 ;; destroyed - this is the only note-sheet-degrafted method in the
@@ -567,24 +797,15 @@
 ;; (if any) need to be deallocated when controls are destroyed
 ;; (cim 10/11/96) 
 
-;; only destroy the pixmap if it was created from a pattern label - if 
-;; the the label was given as a pixmap leave it to the user to destroy 
-;; (cim 10/14/96)
-
 (defmethod note-sheet-degrafted :after ((pane hpbutton-pane))
+  ;; only destroy the pixmap if it was created from a pattern label - if 
+  ;; the the label was given as a pixmap leave it to the user to destroy 
+  ;; (cim 10/14/96)
   (let ((pixmap (slot-value pane 'pixmap))
 	(label (gadget-label pane)))
-    (when (and pixmap (typep label 'pattern))
+    (when (and pixmap (acl-clim::isa-pattern label))
       (port-deallocate-pixmap (port pixmap) pixmap))))
 
-;; This was copied from silica/db-button.lisp and specialized on
-;; hpbutton-pane and then the event class changed to
-;; window-change-event as with all the other fixes in this file. 
-;; silica/db-button.lisp should only be used for using the generic
-;; clim gadgets - when using native windows controls this code
-;; shouldn't be used - the fact that it was, was introducing strange
-;; bugs in the handling of push-button events. (cim 9/17/96)
-
 (defmethod handle-event ((pane hpbutton-pane) 
 			 (event window-change-event))
   ;; SPR18779.  This code runs as a result of pushing a button.
@@ -595,17 +816,13 @@
   (with-output-recording-options (*standard-input* :record t)
     (activate-callback pane (gadget-client pane) (gadget-id pane))))
 
-;; let's shadow generic db-butto methods (cim 9/18/96) - this needs
-;; some more work
-
 (defmethod handle-event ((pane hpbutton-pane) 
 			 (event pointer-enter-event))
-  nil)
+  (armed-callback pane (gadget-client pane) (gadget-id pane)))
 
 (defmethod handle-event ((pane hpbutton-pane) 
 			 (event pointer-exit-event))
-  nil)
-
+  (disarmed-callback pane (gadget-client pane) (gadget-id pane)))
 
 (defmethod (setf gadget-label) :after (str (pane hpbutton-pane))
   (with-slots (mirror) pane
@@ -613,6 +830,19 @@
       (excl:with-native-string (str str)
 	(win:SetWindowText mirror str)))))
 
+(defmethod (setf pane-background) :after (clr (pane hpbutton-pane))
+  (declare (ignore CLR))
+  (with-slots (mirror) pane
+    (when mirror
+      ;;; Work-around to force button to refresh.
+      (win:SetWindowText mirror (or (gadget-label PANE) "")))))
+
+(defmethod (setf pane-foreground) :after (clr (pane hpbutton-pane))
+  (declare (ignore CLR))
+  (with-slots (mirror) pane
+    (when mirror
+      ;;; Work-around to force button to refresh.
+      (win:SetWindowText mirror (or (gadget-label PANE) "")))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; hbutton-pane
@@ -630,27 +860,107 @@
 		     :text-style nil
 		     ))
 
+(defmethod realize-mirror ((port acl-clim::acl-port) (sheet hbutton-pane))
+  (multiple-value-bind (left top right bottom)
+      (sheet-native-region* sheet)
+    (fix-coordinates left top right bottom)
+    (let* ((parent (sheet-mirror sheet))
+	   (parent2 (sheet-mirror (sheet-parent sheet)))
+           (window nil)
+           (buttonstyle nil)
+	   (value nil)
+	   (width (- right left))
+	   (height (- bottom top))
+	   gadget-id)
+      (assert (eq parent parent2) () "parents don't match!")
+      (setq gadget-id (silica::allocate-gadget-id sheet))
+      (setq value (slot-value sheet 'silica::value))
+      (setq buttonstyle
+	(ecase (gadget-indicator-type sheet)
+	  (:one-of win:BS_RADIOBUTTON)
+	  (:some-of win:BS_CHECKBOX)))
+      (multiple-value-bind (cwidth cheight)
+	  (compute-gadget-label-size sheet)
+	(setq top (+ top (* gadget-id 25)))
+	(setq left (+ left 50))
+	(setq width (+ cwidth (* 2 *hbutton-width*)))
+	(setq height (max cheight (* 1 *hbutton-height*))))
+      (setq window
+	(let ((label (slot-value sheet 'silica::label))
+	      (resources (acl-clim::port-default-resources port)))
+	  (when (or (acl-clim::isa-pixmap label)
+		    (acl-clim::isa-pattern label))
+	    (setf (slot-value sheet 'silica::pixmap)
+	      (if (acl-clim::isa-pattern label)
+		  (with-sheet-medium (medium sheet)
+		    (with-output-to-pixmap 
+			(stream medium
+				:width (pattern-width label)
+				:height (pattern-height label))
+		      (draw-pattern* stream label 0 0)))
+		label))
+	    (setq buttonstyle win:BS_OWNERDRAW ;; pnc Aug97 for clim2bug740
+		  label nil))
+	  (unless (eq (pane-background sheet) 
+		      (getf resources :background))
+	    (setq buttonstyle win:BS_OWNERDRAW))
+	  (unless (eq (pane-foreground sheet) 
+		      (getf resources :foreground))
+	    (setq buttonstyle win:BS_OWNERDRAW))
+	  (acl-clim::hbutton-open parent gadget-id
+				  left top width height 
+				  :buttonstyle buttonstyle
+				  :value value
+				  :label label)))
+      (setf (sheet-native-transformation sheet)
+	(sheet-native-transformation (sheet-parent sheet)))
+      (setf (silica::gadget-id->window sheet gadget-id) window)
+      (let ((text-style (pane-text-style sheet)))
+	(when text-style
+	  (let ((font (text-style-mapping port text-style)))
+	    (acl-clim::frame-send-message
+	     (pane-frame sheet)
+	     window win:WM_SETFONT 
+			     (acl-clim::acl-font-index font) 0))))
+      (when (sheet-enabled-p sheet)
+	;; It's too soon for this.  Need to do this later, 
+	;; after the layout has been processed, but where?
+	(win:ShowWindow window win:SW_SHOW))
+      window)))
+
 (defmethod draw-picture-button ((pane hbutton-pane) state hdc rect)
   (multiple-value-bind (bwidth bheight)
       (bounding-rectangle-size pane)
-    (let* ((pixmap (slot-value pane 'pixmap))
-	   (op (slot-value pane 'raster-op))
-	   (width (pixmap-width pixmap))
-	   (height (pixmap-height pixmap))
-	   (x (floor (- bwidth width) 2))
-	   (y (floor (- bheight height) 2))
-	   (selected (logtest state win:ODS_SELECTED)))
-      (when selected
-	(incf x)
-	(incf y))
-      (win:DrawEdge hdc
-		     rect 
-		     (if selected
-			 win:BDR_SUNKEN
-		       win:BDR_RAISED)
-		     (+ win:BF_RECT win:BF_MIDDLE))
-      (win:BitBlt hdc x y width height (acl-clim::pixmap-cdc pixmap) 0 0
-		   (acl-clim::bop->winop op)))))
+    (win:SetBkMode hdc win:OPAQUE)
+    (win:SetBkColor hdc (acl-clim::color->wincolor (pane-background pane)))
+    (win:SetTextColor hdc (acl-clim::color->wincolor (pane-foreground pane)))
+    (win:SetRop2 hdc win:R2_COPYPEN)
+    (let ((brush (win:CreateSolidBrush 
+		  (acl-clim::color->wincolor (pane-background pane)))))
+      (when (acl-clim::valid-handle brush)
+	(win:SelectObject hdc brush)
+	(win:DeleteObject brush)))
+    (win:DrawEdge hdc
+		  rect 
+		  (if (logtest state win:ODS_SELECTED)
+		      win:BDR_SUNKEN
+		    win:BDR_RAISED)
+		  (+ win:BF_RECT win:BF_MIDDLE))
+    (let ((margin 1))
+      (win:rectangle hdc margin margin 
+		     (- bwidth margin margin) (- bheight margin margin)))
+    (let* ((pixmap (slot-value pane 'pixmap)))
+      (when pixmap
+	(let* ((op (slot-value pane 'raster-op))
+	       (width (pixmap-width pixmap))
+	       (height (pixmap-height pixmap))
+	       (x (floor (- bwidth width) 2))
+	       (y (floor (- bheight height) 2)))
+	  (when (logtest state win:ODS_SELECTED)
+	    (incf x)
+	    (incf y))
+	  (win:BitBlt hdc x y width height (acl-clim::pixmap-cdc pixmap) 0 0
+		      (acl-clim::bop->winop op)))))))
 
 (defmethod compose-space ((pane hbutton-pane) &key width height)
   (declare (ignore width height))
@@ -695,7 +1005,8 @@
   (declare (ignore invoke-callback))
   (with-slots (mirror) pane
     (when mirror
-      (win:SendMessage mirror win:BM_SETCHECK (if value 1 0) 0))))
+      (acl-clim::frame-send-message (pane-frame pane)
+			  mirror win:BM_SETCHECK (if value 1 0) 0))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; option panes
@@ -734,7 +1045,8 @@
 	(index 0))
     (with-slots (items value mode value-key) pane
       (when (and mirror items)
-        (setf index (win:SendMessage mirror win:CB_GETCURSEL 0 0))
+        (setf index (acl-clim::frame-send-message (pane-frame pane)
+					mirror win:CB_GETCURSEL 0 0))
         (setf (gadget-value pane :invoke-callback t) 
 	  (funcall value-key (elt items index)))))))
 
@@ -746,7 +1058,8 @@
 	  (i (position value items
 		       :key value-key :test test)))
       (when (and hwnd i)
-	(win:SendMessage hwnd win:CB_SETCURSEL i 0)))))
+	(acl-clim::frame-send-message (pane-frame pane)
+			    hwnd win:CB_SETCURSEL i 0)))))
 
 (defmethod handle-event :after ((pane mswin-combo-box-pane) 
 				(event pointer-event))
@@ -790,11 +1103,13 @@
   (fix-coordinates left top right bottom)
   (let* ((hwnd (sheet-mirror sheet))
 	 (height (min
-		  (* (+ 2 (win:SendMessage hwnd win:CB_GETCOUNT 0 0))
+		  (* (+ 2 (acl-clim::frame-send-message (pane-frame sheet)
+					      hwnd win:CB_GETCOUNT 0 0))
 		     ;; I'd have expected the wparam to be 0 here
 		     ;; according to the docs but this doesn't work
 		     ;; right (cim 9/25/96)
-		     (win:SendMessage hwnd win:CB_GETITEMHEIGHT -1 0))
+		     (acl-clim::frame-send-message (pane-frame sheet)
+					 hwnd win:CB_GETITEMHEIGHT -1 0))
 		  *combo-box-maximum-height*)))
     (win:SetWindowPos hwnd
 		      (ct:null-handle win:HWND) ; we really want win:HWND_TOP
@@ -809,13 +1124,17 @@
 (defmethod (setf set-gadget-items) :after (items (pane mswin-combo-box-pane))
   (with-slots (name-key mirror) pane
     (when mirror
-      (win:SendMessage mirror win:CB_RESETCONTENT 0 0)
+      (acl-clim::frame-send-message
+       (pane-frame pane)
+       mirror win:CB_RESETCONTENT 0 0)
       (dolist (item items)
 	(let ((str (acl-clim::nstringify (funcall name-key item)))
 	      (pos (position item items)))
 	  ;;(break "insert gadget item [~a @ ~a]" str pos)
 	  (excl:with-native-string (str str)
-	    (win:SendMessage mirror win:CB_INSERTSTRING pos str))))
+	    (acl-clim::frame-send-message
+	     (pane-frame pane)
+	     mirror win:CB_INSERTSTRING pos str))))
       ;; make sure it updates
       (win:InvalidateRect mirror ct:hnull win:TRUE)
       (note-sheet-region-changed pane))))
@@ -1034,6 +1353,9 @@
         (setq armed nil)
 	(disarmed-callback pane (gadget-client pane) (gadget-id pane))))))
 
+(defmethod isa-pull-down-menu ((object t)) nil)
+(defmethod isa-pull-down-menu ((object pull-down-menu)) t)
+
 (defmethod handle-event ((pane mswin-pull-down-menu-button)
 			 (event pointer-motion-event))
   (with-slots (next-menu x-margin normal-pattern) pane
@@ -1046,7 +1368,7 @@
 	  (when (and next-menu
 		     (> x (- (+ left x-margin pattern-width)
 			     sensitive-region)))
-	    (if (typep next-menu 'pull-down-menu)
+	    (if (isa-pull-down-menu next-menu)
 		(choose-from-pull-down-menu next-menu pane :cascade-p t)
 		(funcall next-menu pane))))))))
 
@@ -1153,10 +1475,8 @@
 	    (let ((*subsidiary-pull-down-menu* t))
 	      (loop
 	        (unless (winhandle-equal mirror
-			       (acl-clim::acl-port-mirror-with-focus
-			         acl-clim::*acl-port*))
-                  #||(format *terminal-io* "mirror=~a focus=~a~%" mirror (acl-clim::acl-port-mirror-with-focus
-			         acl-clim::*acl-port*))||#
+					 (acl-clim::acl-port-mirror-with-focus
+					  acl-clim::*acl-port*))
 		  (throw 'exit-pull-down-menu (values)))
 		(port-event-wait (port menu) #'waiter 
                             :wait-reason "Pull-Down Menu" :timeout 2)
@@ -1255,6 +1575,10 @@
   (declare (ignore label))
    )
 
+(defmethod acl-clim::sheet-wants-default-pointer 
+    ((object acl-clim::acl-text-editor-pane)) 
+  t)
+
 ;; new code to deal with resources - ie background foreground and
 ;; text-stlye for various windows controls (cim 10/12/96)
 
@@ -1264,19 +1588,16 @@
 ;; returned brush can be freed - is this a reasonable assumption? 
 ;; (cim 10/11/96)
 
-(defvar *background-brush* nil)
-
 (defmethod adjust-gadget-colors (pane hdc)
-  (let* ((bg (color->wincolor (pane-background pane)))
-	 (fg (color->wincolor (pane-foreground pane)))
-	 (new-brush (win:CreateSolidBrush bg))
-	 (old-brush *background-brush*))
-    (win:SetBkColor hdc bg)
-    (win:SetTextColor hdc fg)
-    (when old-brush
-      (win:DeleteObject old-brush))
-    (setq *background-brush* new-brush)
-    new-brush))
+  (excl:without-interrupts			; due to global variable
+    (when (acl-clim::valid-handle silica::*background-brush*)
+      (or (win:DeleteObject silica::*background-brush*) 
+	  (error "DeleteObject")))
+    (let* ((bg (color->wincolor (pane-background pane)))
+	   (fg (color->wincolor (pane-foreground pane))))
+      (win:SetBkColor hdc bg)
+      (win:SetTextColor hdc fg)
+      (setq silica::*background-brush* (win:CreateSolidBrush bg)))))
 
 (defmethod get-sheet-resources ((port acl-port) sheet)
   (declare (ignore sheet))
@@ -1385,3 +1706,11 @@
      (sheet-child pane)
      0 0
      (- width (* 2 thickness)) (- height (* 2 thickness)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Labelled-pane
+
+(defmethod (setf gadget-label) :after 
+	   ((new-label string) (gadget labelled-gadget-mixin))
+  (handle-repaint gadget T)
+  )
diff --git a/aclpc/winwidgh.lisp b/aclpc/winwidgh.lisp
index 5b8c8be32330b4cc258f34b843377811a77d0d6b..11de48b2457cd499b7ab49b2a5b25a23ee66894f 100644
--- a/aclpc/winwidgh.lisp
+++ b/aclpc/winwidgh.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: winwidgh.lisp,v 1.6 1999/05/04 01:21:03 layer Exp $
+;; $Id: winwidgh.lisp,v 1.7 1999/07/19 22:25:10 layer Exp $
 
 (in-package :acl-clim)
 
@@ -28,6 +28,13 @@
 (defconstant TTN_NEEDTEXTW (- TTN_FIRST 10)); unicode
 (defconstant TTN_NEEDTEXT TTN_NEEDTEXTA)
 
+(defconstant EM_SETMARGINS #xD3)
+(defconstant EC_LEFTMARGIN 1)
+(defconstant EC_RIGHTMARGIN 2)
+(defconstant EC_USEFONTINFO #xffff)
+
+(defvar SRCOR #xee0086)
+
 (ff:def-foreign-type browseinfo
     (:struct (hwndOwner win:hwnd)
 	     (pidlRoot win:long #+ig win:lpcitemidlist)
@@ -81,6 +88,37 @@
   :call-direct t
   :returning :int)
 
+;; This should be equivalent to win:getdc but not cons.
+(ff:def-foreign-call (ReleaseDC "ReleaseDC")
+    ((window :int) (dc :int))
+  :arg-checking nil
+  :call-direct t
+  :returning :int)
+
+(ff:def-foreign-call (SetBkMode "SetBkMode")
+    ((dc :int) (mode :int))
+  :arg-checking nil
+  :call-direct t
+  :returning :int)
+
+(ff:def-foreign-call (SetBkColor "SetBkColor")
+    ((dc :int) (color :int))
+  :arg-checking nil
+  :call-direct t
+  :returning :int)
+
+(ff:def-foreign-call (SetTextColor "SetTextColor")
+    ((dc :int) (color :int))
+  :arg-checking nil
+  :call-direct t
+  :returning :int)
+
+(ff:def-foreign-call (SetROP2 "SetROP2")
+    ((dc :int) (rop2 :int))
+  :arg-checking nil
+  :call-direct t
+  :returning :int)
+
 ;; This should be equivalent to win:selectobject but not cons.
 (ff:def-foreign-call (SelectObject "SelectObject")
     ((a :int) (b :int))
diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp
index 1de87f60c8906f3a5e4e5cdf6612c587e0880c54..2ca533e7de3a37b553e0dcf6ba24122b6b7d61db 100644
--- a/clim/clim-defs.lisp
+++ b/clim/clim-defs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: clim-defs.lisp,v 1.28 1998/08/06 23:15:50 layer Exp $
+;; $Id: clim-defs.lisp,v 1.29 1999/07/19 22:25:10 layer Exp $
 
 (in-package :clim-internals)
 
@@ -249,15 +249,51 @@
          (expand-presentation-type-abbreviation ,type) ,override
          #'body-continuation #'context-continuation))))
 
+;;; A problem can arise if the a command is launched asynchronous
+;;; (e.g. the command is launched by the program, not as the 
+;;; result of user-input).
+;;; Specifically, the input-focus can be snatched away from the
+;;; current user frame.
+;;;
+;;; The current rules are:
+;;; 1] On entry, note the original input-focus.
+;;;    Only set the input-focus to a new value if the frame
+;;;    of the new-input-focus is the same as the frame of 
+;;;    the original- input-focus.
+;;;    (I.e. don't snatch the input focus away if we are, for
+;;;    example, running an asynchronously launched command.)
+;;; 
+;;; 2] On exit, note the then current input-focus.
+;;;    Only re-set the input-focus to the original-input-focus
+;;;    if the frame of the now-current-input-focus is the
+;;;    same as the "new" value set above.
+;;;    (I.e. worry whether the input focus has been swapped 
+;;;    out from under us while we were waiting.)
+;;; 
 (defmacro with-input-focus ((stream &optional (doit t)) &body body)
-  (let ((old-input-focus '#:old-input-focus))
-    `(let ((,old-input-focus nil))
+  (let ((old-input-focus '#:old-input-focus)
+	(orig-input-focus '#:orig-input-focus)
+	(orig-input-focus-frame '#:orig-input-focus-frame)
+	(stream-frame '#:stream-frame)
+	)
+    `(let* ((,old-input-focus nil)
+	    (,stream-frame (and ,stream
+				(pane-frame ,stream)))
+	    (,orig-input-focus (and ,stream
+				    (port-keyboard-input-focus (port ,stream))))
+	    (,orig-input-focus-frame (and ,orig-input-focus
+					  (pane-frame ,orig-input-focus))))
        (unwind-protect
            (progn
-             (when ,doit
+             (when (and ,doit
+			(eq ,stream-frame 
+			    ,orig-input-focus-frame))
                (setq ,old-input-focus (stream-set-input-focus ,stream)))
              ,@body)
-         (when ,old-input-focus
+         (when (and ,old-input-focus
+		    (port-keyboard-input-focus (port ,stream))
+		    (eql (pane-frame (port-keyboard-input-focus (port ,stream)))
+			 ,stream-frame))
            (stream-restore-input-focus ,stream ,old-input-focus))))))
 
 
diff --git a/clim/cursor.lisp b/clim/cursor.lisp
index 073e04226383ee5c3de7da278389717896a0f266..5c54691dea21707cfd83f9a03b66f99a9660d76b 100644
--- a/clim/cursor.lisp
+++ b/clim/cursor.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: cursor.lisp,v 1.31 1998/08/06 23:15:51 layer Exp $
+;; $Id: cursor.lisp,v 1.32 1999/07/19 22:25:10 layer Exp $
 
 (in-package :clim-internals)
 
@@ -223,7 +223,9 @@
   ;;; type is currently one of CURSOR-ACTIVE, -FOCUS, or -STATE
   (let ((stream (slot-value cursor 'stream)))
     (when (and stream (port stream))
-      (port-note-cursor-change (port stream) cursor stream type old new))))
+      (let ((frame (pane-frame stream)))
+	(when (and frame (eq (frame-state frame) :enabled))
+	  (port-note-cursor-change (port stream) cursor stream type old new))))))
 
 ;;; The port needs to know about state transitions.  We originally had one
 ;;; function that simply knew when the cursor was changing from "on" to "off"
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 6234ce18798b73c4c3e32f1aaf30408d234d2ff3..cb35b98c2da4023f982c47cc9d63f0c48110ddbe 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: db-stream.lisp,v 1.68 1998/08/06 23:15:52 layer Exp $
+;; $Id: db-stream.lisp,v 1.69 1999/07/19 22:25:10 layer Exp $
 
 (in-package :clim-internals)
 
@@ -391,10 +391,9 @@
 (defclass interactor-pane (clim-stream-pane) ())
 (defclass application-pane (clim-stream-pane) ())
 
-#-aclpc
-;; 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 accept-values-pane (clim-stream-pane) 
+  ()
+  (:default-initargs :default-view +gadget-dialog-view+))
 
 (eval-when (compile)
   ;; defined later in the compilation...
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 17308959d0e7144d512ad482d82957390bb97609..fc289eddd7dca7c6438f6071025a3d898bc70075 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: frames.lisp,v 1.93 1999/05/04 01:21:04 layer Exp $
+;; $Id: frames.lisp,v 1.94 1999/07/19 22:25:10 layer Exp $
 
 (in-package :clim-internals)
 
@@ -1529,8 +1529,10 @@
     (multiple-value-bind (left   left-presentation   left-context
                           middle middle-presentation middle-context
                           right  right-presentation  right-context)
-        (find-applicable-translators-for-documentation presentation input-context
-                                                       frame window x y modifier-state)
+        (find-applicable-translators-for-documentation presentation
+input-context
+                                                       frame window x y
+modifier-state)
       (let* ((*print-length* 3)
              (*print-level* 2)
              (*print-circle* nil)
@@ -1539,21 +1541,25 @@
              (*print-pretty* nil))
         (flet ((document-translator (translator presentation context-type
                                      button-names separator)
-                 ;; Assumes 6 modifier keys and the reverse ordering of *MODIFIER-KEYS*
-                 (let ((bit #o20)
-                       (shift-name '(:double :hyper :super :meta :control :shift)))
+                 ;; Assumes 6 modifier keys and the reverse ordering of
+*MODIFIER-KEYS*
+                 (let ((bit #b100000)
+                       (shift-name '(:double :hyper :super :meta :control
+:shift)))
                    (declare (type fixnum bit))
                    (repeat 6                ;length of shift-name
                            (unless (zerop (logand bit modifier-state))
                              (write-string
                               (frame-modifier-key-documentation frame
-                                                                (car shift-name))
+                                                                (car
+shift-name))
                               stream)
                              (write-string "-" stream))
                            (pop shift-name)
                            (setq bit (the fixnum (ash bit -1)))))
                  (write-string
-                  (frame-pointer-button-documentation frame (car button-names))
+                  (frame-pointer-button-documentation frame (car
+button-names))
                   stream)
                  (dolist (button-name (cdr button-names))
                    (write-string "," stream)
@@ -1561,10 +1567,12 @@
                     (frame-pointer-button-documentation frame button-name)
                     stream))
                  (write-string ": " stream)
-                 (document-presentation-translator translator presentation context-type
+                 (document-presentation-translator translator presentation
+context-type
                                                    frame nil window x y
                                                    :stream stream
-                                                   :documentation-type :pointer)
+                                                   :documentation-type
+:pointer)
                  (write-string separator stream)))
           (declare (dynamic-extent #'document-translator))
           ;;--- The button names should be hard-wired in.  Consider 1-button
@@ -1580,7 +1588,8 @@
                                       '(:left :middle))
                                      (t '(:left)))))
               (document-translator left left-presentation left-context
-                                   button-name (if (or middle right) "; " "."))))
+                                   button-name (if (or middle right) "; "
+"."))))
           (when middle
             (let ((button-name (cond ((eq middle right)
                                       (setq right nil)
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index a3a2ca2edb1003bd9812a289b73cdee91bc30930..3242d6cf96b692c732b3ea76a99eb1bcc466fbc8 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: gadget-output.lisp,v 1.64 1998/08/06 23:15:56 layer Exp $
+;; $Id: gadget-output.lisp,v 1.65 1999/07/19 22:25:13 layer Exp $
 
 (in-package :clim-internals)
 
@@ -725,44 +725,42 @@
                                         default-supplied-p type
                                         prompt query-identifier
                                         &key (editable-p t))
-  #-(or aclpc acl86win32) (declare (ignore prompt))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget text-field)
-            (declare (ignore record gadget))             ;;-- This sucks
+	   (declare (ignore record gadget))             ;;-- This sucks
            (if active-p
                (activate-gadget text-field)
-               (deactivate-gadget text-field))
-            (setf (gadget-value text-field)
+	     (deactivate-gadget text-field))
+	   (setf (gadget-value text-field)
              (if default-supplied-p
                  (present-to-string default type)
                ""))))
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
       (let ((text-field (make-pane-from-view 
-                          'text-field view ()
-                          #+(or aclpc acl86win32) :label
-			  #+(or aclpc acl86win32) (and (stringp prompt) prompt)
-                          :value (if default-supplied-p
-                                     (present-to-string default type)
-                                   "")
-                          :client stream :id query-identifier
-                          :editable-p editable-p
-                          :value-changed-callback
-                            `(accept-values-note-text-field-changed-callback
-                               ,query-identifier)
-                          :focus-out-callback
-                            ;;--- Why do we check for editable-p?  If it
-                            ;;--- is read-only, won't this callback never be
-                            ;;--- called? (cim)
-                            (and editable-p
-                                 `(accept-values-string-field-changed-callback
-                                   ,stream ,query-identifier))
-                            :activate-callback
-                            (and editable-p
-                                 `(accept-values-string-field-changed-callback
-                                    ,stream ,query-identifier))
-                            :active active-p
-                            :help-callback (make-gadget-help type))))
-         (values text-field text-field)))))
+			 'text-field view ()
+			 :value (if default-supplied-p
+				    (present-to-string default type)
+				  "")
+			 :client stream :id query-identifier
+			 :editable-p editable-p
+			 :value-changed-callback
+			 `(accept-values-note-text-field-changed-callback
+			   ,query-identifier)
+			 :focus-out-callback
+			 ;;--- Why do we check for editable-p?  If it
+			 ;;--- is read-only, won't this callback never be
+			 ;;--- called? (cim)
+			 (and editable-p
+			      `(accept-values-string-field-changed-callback
+				,stream ,query-identifier))
+			 :activate-callback
+			 (and editable-p
+			      `(accept-values-string-field-changed-callback
+				,stream ,query-identifier))
+			 :active active-p
+			 :help-callback (make-gadget-help type))))
+	(values text-field text-field)))))
 
 (defmethod accept-values-note-text-field-changed-callback
            ((gadget text-field) new-value query)
@@ -831,42 +829,42 @@
                                     default-supplied-p type
                                     prompt query-identifier
                                     &key (editable-p t))
-  #-(or aclpc acl86win32) (declare (ignore prompt))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget button)
-            (declare (ignore record gadget))
+	   (declare (ignore record gadget))
            (if active-p
                (activate-gadget button)
-               (deactivate-gadget button))
-            (setf (gadget-value button)
+	     (deactivate-gadget button))
+	   (setf (gadget-value button)
              (if default-supplied-p
                  (present-to-string default type)
                ""))))
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
-      (let ((text-field (make-pane-from-view 'text-editor view '(:scroll-bars)
-                          #+(or aclpc acl86win32):label #+(or aclpc acl86win32) (and (stringp prompt) prompt)
-                          :value (if default-supplied-p
-                                     (present-to-string default type)
-                                   "")
-                          :client stream :id query-identifier
-                          :editable-p editable-p
-                          :value-changed-callback
-                            `(accept-values-note-text-field-changed-callback
-                               ,query-identifier)
-                          :focus-out-callback
-                            ;;--- Why do we check for editable-p?  If it
-                            ;;--- is read-only, won't this callback never be
-                            ;;--- called? (cim)
-                            (and editable-p
-                                 `(accept-values-string-field-changed-callback
-                                    ,stream ,query-identifier))
-                            :activate-callback
-                            (and editable-p
-                                 `(accept-values-string-field-changed-callback
-                                    ,stream ,query-identifier))
-                            :active active-p
-                            :help-callback (make-gadget-help type))))
-         (values (scrolling (:scroll-bars (getf (view-gadget-initargs view) :scroll-bars :both))
+      (let ((text-field (make-pane-from-view 
+			 'text-editor view '(:scroll-bars)
+			 :value (if default-supplied-p
+				    (present-to-string default type)
+				  "")
+			 :client stream :id query-identifier
+			 :editable-p editable-p
+			 :value-changed-callback
+			 `(accept-values-note-text-field-changed-callback
+			   ,query-identifier)
+			 :focus-out-callback
+			 ;;--- Why do we check for editable-p?  If it
+			 ;;--- is read-only, won't this callback never be
+			 ;;--- called? (cim)
+			 (and editable-p
+			      `(accept-values-string-field-changed-callback
+				,stream ,query-identifier))
+			 :activate-callback
+			 (and editable-p
+			      `(accept-values-string-field-changed-callback
+				,stream ,query-identifier))
+			 :active active-p
+			 :help-callback (make-gadget-help type))))
+	(values (scrolling (:scroll-bars (getf (view-gadget-initargs view) :scroll-bars :both))
                   text-field)
                 text-field)))))
 
diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp
index c82a32793ebeaa558542704fbb04fbbb3a1db7df..7ecef669554de6461cdfd41f93a54cf739d8593a 100644
--- a/clim/input-defs.lisp
+++ b/clim/input-defs.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: input-defs.lisp,v 1.24 1998/08/06 23:15:57 layer Exp $
+;; $Id: input-defs.lisp,v 1.25 1999/07/19 22:25:13 layer Exp $
 
 (in-package :clim-internals)
 
@@ -197,17 +197,27 @@
   (let ((sheet (slot-value pointer 'sheet)))
     (unless (eq new-value sheet)
       (when (and sheet (port sheet))
-        ;;--- Horrible cross-protocol modularity violation here, but
-        ;;--- it's hours before AAAI.  Note that this can cause blowouts
-        ;;--- in multi-processing systems if the function that does the
-        ;;--- unhighlighting depends on application state.
-        ;;---
-        ;;--- let's go the whole hog and make a stab at binding
-        ;;--- *application-frame* (cim 1/31/94)
+	;;--- Horrible cross-protocol modularity violation here, but
+	;;--- it's hours before AAAI.  Note that this can cause blowouts
+	;;--- in multi-processing systems if the function that does the
+	;;--- unhighlighting depends on application state.
+	;;---
+	;;--- let's go the whole hog and make a stab at binding
+	;;--- *application-frame* (cim 1/31/94)
         (when (output-recording-stream-p sheet)
-          (let ((*application-frame* (or (pane-frame sheet)
-                                         *application-frame*)))
-            (set-highlighted-presentation sheet nil nil)))))))
+	  (let ((frame (or (pane-frame sheet)
+			   *application-frame*)))
+	    ;; The sheet can point to a dead pane.
+	    ;; (For example, if the pointer was
+	    ;; last used to exit a frame.)
+	    ;; In that case, make sure it doesn't
+	    ;; try to update the presentation.
+	    ;;
+	    ;; Frame-State is one of 
+	    ;; (member :disowned :disabled :enabled :shrunk)	       
+	    (when (eq (frame-state frame) :enabled)
+	      (let ((*application-frame* frame))
+		(set-highlighted-presentation sheet nil nil)))))))))
 
 (defmethod pointer-decache ((pointer standard-pointer))
   ;;-- If the (sheet-transformation (pointer-sheet .)) has changed
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 6dd63a06d7e96e00959947a1a01fdc5c72c8834f..7c4f540594fe7d4241c6fa6c5260b55525900415 100644
--- a/clim/input-protocol.lisp
+++ b/clim/input-protocol.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: input-protocol.lisp,v 1.54 1999/02/25 08:23:29 layer Exp $
+;; $Id: input-protocol.lisp,v 1.55 1999/07/19 22:25:13 layer Exp $
 
 (in-package :clim-internals)
 
@@ -628,7 +628,7 @@
                           (> (get-internal-real-time) end-time))
                  (setq flag :timeout))
                flag))
-        #-Allegro (declare (dynamic-extent #'waiter))
+	#+os-threads (declare (dynamic-extent #'waiter))
         (port-event-wait (port stream) #'waiter 
           :wait-reason "Clim Input"
           :timeout timeout)
diff --git a/clim/surround-output.lisp b/clim/surround-output.lisp
index ef1bb54c61b8e26b7e1727e67dacb6552951e8f2..40370c22d745f0213c6ccb37d91177ce2f59fb2a 100644
--- a/clim/surround-output.lisp
+++ b/clim/surround-output.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: surround-output.lisp,v 1.16 1998/08/06 23:16:05 layer Exp $
+;; $Id: surround-output.lisp,v 1.17 1999/07/19 22:25:13 layer Exp $
 
 (in-package :clim-internals)
 
@@ -153,9 +153,7 @@
 			  (with-keywords-removed 
 			      (drawing-options drawing-options '(:move-cursor))
 			    (flet ((draw-surrounding-border ()
-				     (apply function stream body left top right bottom
-					    ;; probably should still pass drawing-options
-					    drawing-options)))
+				     (funcall function stream body left top right bottom)))
 			      (declare (dynamic-extent #'draw-surrounding-border))
 			      (apply #'invoke-with-drawing-options stream
 				     #'draw-surrounding-border drawing-options))))))))))
diff --git a/demo/browser.lisp b/demo/browser.lisp
index d261fe28e428970e89c791789dbbcf8737982b83..3ca590d9f9b9d45438bf78c7550976e8f78c7e1a 100644
--- a/demo/browser.lisp
+++ b/demo/browser.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: browser.lisp,v 1.28 1999/02/25 08:23:31 layer Exp $
+;; $Id: browser.lisp,v 1.29 1999/07/19 22:25:14 layer Exp $
 
 ;;; Simple extensible browser
 ;;; Scott McKay
@@ -1380,26 +1380,27 @@
     ((snapshot (with-slots (snapshots) *application-frame*
 		 `(snapshot ,snapshots))
 	       :prompt "snapshot to recover"))
-  (with-slots (browser-type browser-subtype root-nodes graph-type
-	       browser-ptype browser-options node-maker
-	       root-node-maker grapher-args tree-depth
-	       merge-duplicate-nodes all-nodes) *application-frame*
-    (unless (and (eql browser-type (snapshot-browser-type snapshot))
-		 (eql browser-subtype (snapshot-browser-subtype snapshot))
-		 (equal root-nodes (snapshot-root-nodes snapshot)))
-      (setq graph-type (snapshot-graph-type snapshot)
-	    browser-type (snapshot-browser-type snapshot)
-	    browser-subtype (snapshot-browser-subtype snapshot)
-	    browser-ptype (snapshot-browser-ptype snapshot)
-	    browser-options (copy-list (snapshot-browser-options snapshot))
-	    node-maker (snapshot-node-maker snapshot)
-	    root-node-maker (snapshot-root-node-maker snapshot)
-	    grapher-args (snapshot-grapher-args snapshot)
-	    tree-depth (snapshot-tree-depth snapshot)
-	    merge-duplicate-nodes (snapshot-merge-duplicate-nodes snapshot)
-	    root-nodes (copy-list (snapshot-root-nodes snapshot))
-	    all-nodes (copy-list (snapshot-all-nodes snapshot)))
-      (redisplay-frame-pane *application-frame* 'graph :force-p t))))
+  (when snapshot
+    (with-slots (browser-type browser-subtype root-nodes graph-type
+		 browser-ptype browser-options node-maker
+		 root-node-maker grapher-args tree-depth
+		 merge-duplicate-nodes all-nodes) *application-frame*
+      (unless (and (eql browser-type (snapshot-browser-type snapshot))
+		   (eql browser-subtype (snapshot-browser-subtype snapshot))
+		   (equal root-nodes (snapshot-root-nodes snapshot)))
+	(setq graph-type (snapshot-graph-type snapshot)
+	      browser-type (snapshot-browser-type snapshot)
+	      browser-subtype (snapshot-browser-subtype snapshot)
+	      browser-ptype (snapshot-browser-ptype snapshot)
+	      browser-options (copy-list (snapshot-browser-options snapshot))
+	      node-maker (snapshot-node-maker snapshot)
+	      root-node-maker (snapshot-root-node-maker snapshot)
+	      grapher-args (snapshot-grapher-args snapshot)
+	      tree-depth (snapshot-tree-depth snapshot)
+	      merge-duplicate-nodes (snapshot-merge-duplicate-nodes snapshot)
+	      root-nodes (copy-list (snapshot-root-nodes snapshot))
+	      all-nodes (copy-list (snapshot-all-nodes snapshot)))
+	(redisplay-frame-pane *application-frame* 'graph :force-p t)))))
 
 (define-presentation-to-command-translator recover-snapshot
     (snapshot com-recover-snapshot browser
diff --git a/demo/ico.lisp b/demo/ico.lisp
index fb629410b2d1a4c42239b2a17a438e4b3ecb4f24..e1f86c238b73106c715815baf9715b830740177a 100644
--- a/demo/ico.lisp
+++ b/demo/ico.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: ico.lisp,v 1.26 1998/08/06 23:16:27 layer Exp $
+;; $Id: ico.lisp,v 1.27 1999/07/19 22:25:14 layer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
@@ -209,7 +209,7 @@
 (defconstant ico-w/2 (floor ico-w 2))
 (defconstant ico-h/2 (floor ico-h 2))
 
-(defun run-ico (frame &optional (count 1000000))
+(defun run-ico (frame &optional (count 1000))
   (let* ((pane  (frame-target frame))
 	 (medium (sheet-medium pane))
 	 (win-w (bounding-rectangle-width pane))
@@ -232,99 +232,62 @@
 		     #-(or xlib-ignore genera) drawable))
 
     (with-slots (draw-faces draw-edges ico-buffers inks0 inks1 inks2 inks3) frame
-      (ecase *ico-mode*
-	#+abc
-	(:abc (clear-region medium +everywhere+))
-	#+clim
-	(:clim)
-	(:dont)
-	#+xlib-ignore
-	(:clx
-	  (setq display (on-x::x-display (port medium)))
-	  (setq black (xlib:screen-black-pixel (on-x::x-screen (port medium))))
-	  (setq white (xlib:screen-white-pixel (on-x::x-screen (port medium))))
-	  (setq drawable (medium-drawable medium))
-	  (setq gcontext (slot-value medium 'on-x::gcontext))
-	  (setf (xlib:gcontext-fill-style gcontext) :solid))
-	#+genera
-	(:genera
-	  (setq drawable (medium-drawable medium))))
-
-      (window-clear pane)
-      (dotimes (i count)
-	(let* ((ico-buffers ico-buffers)
-	       (inks0 inks0)
-	       (inks1 inks1)
-	       (inks2 inks2)
-	       (inks3 inks3)
-	       (buffer (mod i ico-buffers)))
-	  (multiple-value-setq (edges face-list)
-	    (calculate-ico ico-x ico-y draw-edges draw-faces edges face-list))
-	  ;; Draw ICO
-	  (ecase *ico-mode*
-	    #+clim
-	    (:clim
-	      (draw-rectangle* medium 0 0 win-w win-h :ink (svref inks0 buffer) :filled t)
-	      (when draw-edges
-		(draw-lines* medium edges :ink (svref inks1 buffer)
-			     :line-thickness
-			     (ecase (slot-value frame 'ico-line-style)
-			       (:thick 5)
-			       (:thin nil))))
-	      (when draw-faces
-		(do ((f face-list (cdr (cdddr (cdddr f)))))
-		    ((null f))
-		  (draw-polygon* medium (subseq f 1 7)
-				 :closed t
-				 :filled t
-				 :ink (if (oddp (car f))
-					  (svref inks2 buffer)
-					  (svref inks3 buffer)))))
-	      (when (> ico-buffers 1)
-		(with-delayed-recoloring
-		  (setf (layered-color-color (svref inks0 buffer)) *background-color*
-			(layered-color-color (svref inks1 buffer)) *line-color*
-			(layered-color-color (svref inks2 buffer)) *face1-color*
-			(layered-color-color (svref inks3 buffer)) *face2-color*)))
-	      (medium-force-output medium))
-
-	    #+xlib-ignore
-	    (:clx
-	      (setf (xlib:gcontext-foreground gcontext) white)
-	      (xlib:draw-rectangle drawable gcontext prev-x prev-y
-				   (1+ ico-w) (1+ ico-h) t)
-	      (setf (xlib:gcontext-foreground gcontext) black)
-	      (xlib:draw-segments drawable gcontext
-				  (mapcan
-				    #'(lambda (point)
-					(list (round (ico-point-x point))
-					      (round (ico-point-y point))))
-				    edges))
-	      (xlib:display-force-output display))
-
-	    #+genera
-	    (:genera
-	      (scl:send drawable :draw-rectangle
-			(1+ ico-w) (1+ ico-h) prev-x prev-y
-			:erase)
-	      (apply #'scl:send drawable :draw-lines :draw
-				(mapcan
-				  #'(lambda (point)
-				      (list (round (ico-point-x point))
-					    (round (ico-point-y point))))
-				  edges)))
-	    (:dont))
-
-	  (setq prev-x ico-x
-		prev-y ico-y)
-	  (incf ico-x ico-dx)
-	  (when (or (< ico-x 0) (> ico-x xtop))
-	    (decf ico-x (* ico-dx 2))
-	    (setq ico-dx (- ico-dx)))
-	  (incf ico-y ico-dy)
-	  (when (or (< ico-y 0) (> ico-y ytop))
-	    (decf ico-y (* ico-dy 2))
-	    (setq ico-dy (- ico-dy))))))))
+		(ecase *ico-mode*
+		  (:clim)
+		  (:dont))
+
+		(window-clear pane)
+		(dotimes (i count)
+		  (let* ((ico-buffers ico-buffers)
+			 (inks0 inks0)
+			 (inks1 inks1)
+			 (inks2 inks2)
+			 (inks3 inks3)
+			 (buffer (mod i ico-buffers)))
+		    (multiple-value-setq (edges face-list)
+		      (calculate-ico ico-x ico-y draw-edges draw-faces edges face-list))
+		    ;; Draw ICO
+		    (ecase *ico-mode*
+		      (:clim
+		       (with-drawing-options (medium :draw-p t :record-p nil)
+
+					     (draw-rectangle* medium 0 0 win-w win-h 
+							      :ink (svref inks0 buffer) 
+							      :filled t)
+					     (when draw-edges
+					       (draw-lines* medium edges :ink (svref inks1 buffer)
+							    :line-thickness
+							    (ecase (slot-value frame 'ico-line-style)
+							      (:thick 5)
+							      (:thin nil))))
+					     (when draw-faces
+					       (do ((f face-list (cdr (cdddr (cdddr f)))))
+						   ((null f))
+						 (draw-polygon* medium (subseq f 1 7)
+								:closed t
+								:filled t
+								:ink (if (oddp (car f))
+									 (svref inks2 buffer)
+								       (svref inks3 buffer)))))
+					     (when (> ico-buffers 1)
+					       (with-delayed-recoloring
+						(setf (layered-color-color (svref inks0 buffer)) *background-color*
+						      (layered-color-color (svref inks1 buffer)) *line-color*
+						      (layered-color-color (svref inks2 buffer)) *face1-color*
+						      (layered-color-color (svref inks3 buffer)) *face2-color*)))
+					     (medium-force-output medium)))
+		      (:dont))
+
+		    (setq prev-x ico-x
+			  prev-y ico-y)
+		    (incf ico-x ico-dx)
+		    (when (or (< ico-x 0) (> ico-x xtop))
+		      (decf ico-x (* ico-dx 2))
+		      (setq ico-dx (- ico-dx)))
+		    (incf ico-y ico-dy)
+		    (when (or (< ico-y 0) (> ico-y ytop))
+		      (decf ico-y (* ico-dy 2))
+		      (setq ico-dy (- ico-dy))))))))
 
 
 ;;;
diff --git a/demo/navfun.lisp b/demo/navfun.lisp
index f4e0c37d16c2e737e2a2e8a4761a664b48965105..cec633fc81b7f8dc16da8c4534587e01673b71c3 100644
--- a/demo/navfun.lisp
+++ b/demo/navfun.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: navfun.lisp,v 1.31 1998/08/06 23:16:28 layer Exp $
+;; $Id: navfun.lisp,v 1.32 1999/07/19 22:25:14 layer Exp $
 
 (in-package :clim-demo)
 
@@ -1115,7 +1115,7 @@
       (typep thing 'vor)))
 
 (define-presentation-type-abbreviation route-start-object ()
-  '(or airport named-intersection vor))
+  '(or named-intersection vor airport))
 
 ;;; Add <kind>
 (define-flight-planner-command (com-add-object :name t :menu "Add")
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 891e225ddb0c7083f87a0ad5f99970b2f89fd308..402c229178e682fc37cdd0a6b362b8e1e7bf5942 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: medium.lisp,v 1.44 1998/08/06 23:16:59 layer Exp $
+;; $Id: medium.lisp,v 1.45 1999/07/19 22:25:15 layer Exp $
 
 (in-package :silica)
 
@@ -343,10 +343,13 @@
                 (setf medium-transformation
                       (compose-transformations saved-transformation transformation)))
               (when clipping-region
-                (setf transformed-clipping-region
-                      (region-intersection saved-clipping-region
-                                           (transform-region medium-transformation
-                                                             clipping-region))))
+		(let ((tr (if (eq clipping-region +everywhere+)
+			      +everywhere+
+			    (transform-region medium-transformation clipping-region))))
+		  (setf transformed-clipping-region
+		    (if (eq tr +everywhere+)
+			saved-clipping-region
+		      (region-intersection saved-clipping-region tr)))))
               (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p)
                      (when (null line-style)
                        (setf line-style saved-line-style))
diff --git a/silica/port.lisp b/silica/port.lisp
index 51f5d064264c21d61fc3a74fde82046adc2d2915..1bcc24816e450939d7ec4787144a63fac1a3cab6 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: port.lisp,v 1.40 1998/08/06 23:17:00 layer Exp $
+;; $Id: port.lisp,v 1.41 1999/07/19 22:25:16 layer Exp $
 
 (in-package :silica)
 
@@ -210,16 +210,19 @@
                         (port (find-port :server-path server-path))
                         (orientation :default)
                         (units :device))
-  (unless port
-    (setq port (find-port :server-path server-path)))
-  (map-over-grafts #'(lambda (graft)
-                       (when (graft-matches-spec graft orientation units)
-                         (return-from find-graft graft)))
-                   port)
-  (make-instance (port-graft-class port)
-    :port port
-    :orientation orientation
-    :units units))
+  ;; Simultaneous calls to this function must not result in
+  ;; multiple grafts.
+  (without-scheduling			
+    (unless port
+      (setq port (find-port :server-path server-path)))
+    (map-over-grafts #'(lambda (graft)
+			 (when (graft-matches-spec graft orientation units)
+			   (return-from find-graft graft)))
+		     port)
+    (make-instance (port-graft-class port)
+      :port port
+      :orientation orientation
+      :units units)))
 
 (defgeneric realize-graft (port graft))
 
diff --git a/sys/compile.lisp b/sys/compile.lisp
index e98e1091acfc02f2ac3024ff38ea5834a0295943..4b2e42c7c4b8c3e942b13b17cfebcc2fe521bf7f 100644
--- a/sys/compile.lisp
+++ b/sys/compile.lisp
@@ -15,12 +15,14 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: compile.lisp,v 1.8 1999/02/25 08:23:39 layer Exp $
+;; $Id: compile.lisp,v 1.9 1999/07/19 22:25:17 layer Exp $
 
 (in-package :user)
 
 (set-case-mode :case-insensitive-upper)
 
+(proclaim '(optimize (speed 3) (safety 1) (debug 1)))
+
 #+(and allegro microsoft-32)
 (eval-when (compile load eval) 
   (pushnew :acl86win32 *features*))
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index a6fa2c1f3e1d6a9e983452cc42ffa2310da0bc14..2bea9fdda858fc3bce1592e1c3f8cfa26902c835 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 -*-
 
-;; $Id: test-suite.lisp,v 1.86 1999/05/04 01:21:09 layer Exp $
+;; $Id: test-suite.lisp,v 1.87 1999/07/19 22:25:17 layer Exp $
 
 (in-package :clim-user)
 
@@ -2490,6 +2490,10 @@ Luke Luck licks the lakes Luke's duck likes."))
    (make-application-frame 'list-pane-frame
                            :input-buffer (stream-input-buffer stream))))
 
+(define-test (select-file-test menus-and-dialogs) (stream)
+  "A simple test of SELECT-FILE."
+  (write-string
+   (namestring (select-file (pane-frame stream)))))
 
 
 ;;;; Benchmarks
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index c431488498d281dd2c674a56cd2c5751cccca55d..fcfc584509662eeba2e229008baeef08ded24dd5 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -15,7 +15,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: xm-gadgets.lisp,v 1.100 1999/02/25 08:23:44 layer Exp $
+;; $Id: xm-gadgets.lisp,v 1.101 1999/07/19 22:25:19 layer Exp $
 
 (in-package :xm-silica)
 
@@ -2115,7 +2115,7 @@
       ;;-- ignored too but there does not appear to be an easy way
       ;;-- of going from the osf name to the keysym that we need to ignore
       ;;--  osfMenuBar
-      (member (keyboard-event-key-name event) '(:f10 :tab))))
+      (member (keyboard-event-key-name event) '(:f10 #+ignore :tab))))
 
 
 ;; Support for help
@@ -2212,6 +2212,18 @@
 	       (font-set-from-font-list port font-list)))))
     `(:font-list ,font-list ,@initargs)))
 
+(defmethod frame-manager-print-file
+    ((framem motif-frame-manager) filename
+     &key 	  
+     (frame nil frame-p)
+     (associated-window
+      (if frame-p
+	  (frame-top-level-sheet frame)
+	(graft framem)))
+     &allow-other-keys)
+  (declare (ignore filename associated-window))
+  (error "not yet implemented for UNIX"))
+
 #+(version>= 5 0)
 (in-package :tk)
 
diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp
index 83b10fb785e4478d9c97b8812c56426130717887..4f7bb38facb5a6a1d0e450f4375290c58ced44fd 100644
--- a/utils/defun-utilities.lisp
+++ b/utils/defun-utilities.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: defun-utilities.lisp,v 1.16 1999/05/04 01:21:12 layer Exp $
+;; $Id: defun-utilities.lisp,v 1.17 1999/07/19 22:25:21 layer Exp $
 
 (in-package :clim-utils)
 
@@ -135,10 +135,10 @@
 
   #-(version>= 5 (0 1) :pre-beta2 7)
   (defun mb-to-string (mb-vector)
-    (let* ((lgth (1- (length mb-vector)))
+    (let* ((lgth (length mb-vector))
 	   (string (make-string lgth)))
       (dotimes (i lgth string)
-	(setf (schar string i) (aref mb-vector i)))))
+	(setf (schar string i) (code-char (aref mb-vector i))))))
 
   #-(version>= 5 (0 1) :pre-beta2 7)
   (eval-when (compile load eval) (export 'mb-to-string)))
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index 4207dcf92e4317dc8545df966c29fa738dba61ad..7117075734f67472cb8d6727a6243ba5cbee2011 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: lisp-utilities.lisp,v 1.40 1999/02/25 08:23:46 layer Exp $
+;; $Id: lisp-utilities.lisp,v 1.41 1999/07/19 22:25:21 layer Exp $
 
 (in-package :clim-utils)
 
@@ -176,11 +176,11 @@
 
 #+allegro
 (defmacro fix-coordinate (coord)
-  `(the fixnum (fixit ,coord)))
+  `(the fixnum (if (excl:fixnump ,coord) ,coord (fixit ,coord))))
 
 #+allegro
 (defun fixit (coord)
-  (declare (optimize speed))
+  (declare (optimize (speed 3) (safety 0)))
   (typecase coord
     (fixnum
      coord)
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 001705491f3a1ab46d5539d77ef3a7d7849ba74d..7ab742aa5de56fe3021058df12640428b90422f5 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -16,7 +16,7 @@
 ;; Commercial Software developed at private expense as specified in
 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
 ;;
-;; $Id: packages.lisp,v 1.91 1999/05/04 01:21:12 layer Exp $
+;; $Id: packages.lisp,v 1.92 1999/07/19 22:25:21 layer Exp $
 
 (in-package :common-lisp-user)
 
@@ -1146,7 +1146,8 @@
     setf*))
 
 
-
+
+
 ;; Define the CLIM package
 (defpackage clim
   (:use)                                ;use nothing
@@ -2370,6 +2371,7 @@
     frame-manager-frames
     frame-manager-notify-user
     frame-manager-pointer-documentation-stream
+    frame-manager-print-file  ; jpm 
     frame-manager-select-file
     frame-name
     frame-named-panes
@@ -2409,6 +2411,7 @@
     pointer-documentation-pane
     position-sheet-carefully
     position-sheet-near-pointer
+    print-file				; jpm
     raise-frame
     read-frame-command
     reconfigure-frame
@@ -2720,7 +2723,8 @@
 
 )) ;; ics-target-case
 
-
+
+
 ;; Now define all of the implementation packages
 (defpackage clim-utils
   #+Allegro (:implementation-packages :clim-utils :clim-silica
@@ -3266,7 +3270,8 @@
   #+Allegro
   (:import-from :excl #:non-dynamic-extent))
 
-
+
+
 ;; A package for casual use...
 (defpackage clim-user
   (:use clim-lisp clim))
@@ -3289,7 +3294,7 @@
 (cl:defvar *clim-major-version* 2)
 (cl:defvar *clim-minor-version* 2)
 (cl:defvar *clim-generation-version* 2)
-(cl:defvar *clim-build-version* 6)
+(cl:defvar *clim-build-version* 7)
 
 (cl:defparameter *clim-version*
     (cl:format () "~d.~d.~d.~a"