diff --git a/Makefile.defs b/Makefile.defs
index 5e7cc28f0f1d27d7ba52c4a0fe1ddb8fc19837a7..eeb439fe6e071d69495e16f2d6ee3e4736633916 100644
--- a/Makefile.defs
+++ b/Makefile.defs
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.defs,v 1.1 93/03/01 14:26:08 cer Exp $
+# $fiHeader: Makefile.defs,v 1.2 93/03/01 15:59:11 cer Exp $
 #
 #  Makefile.defs for CLIM 2.0
 #
@@ -217,7 +217,6 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \
                         clim/defresource.fasl \
                         clim/temp-strings.fasl \
                         clim/clim-defs.fasl \
-                        clim/stipples.fasl \
                         clim/stream-class-defs.fasl \
                         clim/interactive-defs.fasl \
                         clim/cursor.fasl \
@@ -313,6 +312,7 @@ OL-CLIM-OBJS = tk/ol-classes.fasl \
 
 MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \
                    tk-silica/xt-silica.fasl \
+                   tk-silica/xt-stipples.fasl \
                    tk-silica/xm-silica.fasl \
                    tk-silica/xt-graphics.fasl \
                    tk-silica/xm-graphics.fasl \
@@ -330,6 +330,7 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \
 
 OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \
                       tk-silica/xt-silica.fasl \
+                      tk-silica/xt-stipples.fasl \
                       tk-silica/ol-silica.fasl \
                       tk-silica/xt-graphics.fasl \
                       tk-silica/ol-graphics.fasl \
@@ -395,7 +396,6 @@ ALL_SRC =	   utils/excl-verification.lisp \
                         clim/defresource.lisp \
                         clim/temp-strings.lisp \
                         clim/clim-defs.lisp \
-                        clim/stipples.lisp \
                         clim/stream-class-defs.lisp \
                         clim/interactive-defs.lisp \
                         clim/cursor.lisp \
@@ -483,6 +483,7 @@ ALL_SRC =	   utils/excl-verification.lisp \
               tk/make-widget.lisp \
 		   tk-silica/pkg.lisp \
                    tk-silica/xt-silica.lisp \
+                   tk-silica/xt-stipples.lisp \
                    tk-silica/xm-silica.lisp \
                    tk-silica/xt-graphics.lisp \
                    tk-silica/xm-graphics.lisp \
diff --git a/Makefile.generic b/Makefile.generic
index 380aba9572ff49f96a24f37963a1ac3f34e11a59..c73205dea511c36cc5dbda68bd20d1f886b5dfe3 100644
--- a/Makefile.generic
+++ b/Makefile.generic
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.generic,v 1.1 93/03/01 14:26:10 cer Exp $
+# $fiHeader: Makefile.generic,v 1.2 93/03/01 15:59:14 cer Exp $
 #
 #  Makefile.generic for CLIM 2.0
 #
@@ -124,7 +124,7 @@ tk/xm-defs.fasl : tk/xm-defs.lisp
 # Building
 
 clim-xm:	FORCE $(MOTIF_OBJS)
-	-$(RM) -f $(CLIM)
+	-$(RM) -f $(CLIMXM)
 	$(ECHO) " \
 		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
 		(setq sys::*libx11-pathname* \"$(XLIB)\") \
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index 287ebe4a59b3b0828996b981f907b2b693711e1b..612b2a3e701de4c98e7b6451d8aef4c5307938a9 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: accept-values.lisp,v 1.52 93/01/21 14:57:35 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.53 93/02/08 15:56:36 cer Exp $
 
 (in-package :clim-internals)
 
@@ -156,10 +156,11 @@
 	      (updating-output
 		  (stream :unique-id query-identifier
 			  :id-test #'equal
-			  :cache-value (cons active-p
-					     (if (accept-values-query-changed-p query)
+			  :cache-value (list (if (accept-values-query-changed-p query)
 						 (accept-values-query-value query)
-						 default))
+					       default) 
+					     ptype
+					     active-p)
 			  :cache-test #'(lambda (x y)
 					  (unless (accept-values-query-changed-p query)
 					    (equal x y))))
diff --git a/clim/cursor.lisp b/clim/cursor.lisp
index a7918234963e891c26b5c60a0063b4f39e0ac561..3d9ac1130d4cf7aa5e0a5517664facf91a5cb3d2 100644
--- a/clim/cursor.lisp
+++ b/clim/cursor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cursor.lisp,v 1.21 92/12/03 10:26:15 cer Exp $
+;; $fiHeader: cursor.lisp,v 1.22 93/01/21 14:57:42 cer Exp $
 
 (in-package :clim-internals)
 
@@ -174,7 +174,7 @@
 ;;; start blinking).
 (defmethod port-note-cursor-change :after ((port basic-port) 
 					   cursor stream (type (eql 'cursor-focus)) old new)
-  (declare (ignore old type cursor))
+  (declare (ignore old cursor))
   ;;--- This should really only do this when PORT-INPUT-FOCUS-SELECTION
   ;;--- is :SHEET-UNDER-POINTER, since this causes the "wrong" thing to
   ;;--- happen from the perspective of Genera users.  But where do we
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index 3e0dcb3209475e2554ebb25e397481d6cc9a1a3c..f4331b5489f028099f5454c16b582e6ec2808a3d 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadget-output.lisp,v 1.43 93/01/18 13:54:32 cer Exp $
+;; $fiHeader: gadget-output.lisp,v 1.44 93/02/08 15:56:49 cer Exp $
 
 (in-package :clim-internals)
 
@@ -670,21 +670,21 @@
   (declare (ignore new-value))
   (setf (accept-values-query-changed-p query) t))
 
-;;--- This is mostly nonsense.  If we enter something that is an error then
-;;--- the field value is unchanged.  What is the right thing to do?
 (defmethod accept-values-string-field-changed-callback
 	   ((gadget text-field) stream query)
   (let ((new-value (gadget-value gadget)))
     ;; Only do the accept when the field has changed
+    ;; Only call the callback if the query is still valid
     (when (and (accept-values-query-changed-p query)
 	       (accept-values-query-valid-p 
 		 query (accept-values-query-presentation query)))
-      ;; Only call the callback if the query is still valid
       (handler-case
 	(multiple-value-bind (object type index)
 	    (accept-from-string (accept-values-query-type query) new-value)
 	  (declare (ignore type))
-	  (assert (= index (length new-value)))
+	  ;; we can put this back in when we handle ol text-fields
+	  ;; correctly (see tk-silica/ol-gadgets)
+	  #+ignore (assert (= index (length new-value)))
 	  object)
 	(error () 
 	 (setf (accept-values-query-error-p query) t))
diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp
index d4a1a5cfd55c82ec97deafbd91bdb595866e9135..7287a94f2fa9d4a2bbe76e3e267668ea8256a64c 100644
--- a/clim/standard-types.lisp
+++ b/clim/standard-types.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: standard-types.lisp,v 1.24 92/12/14 15:02:19 cer Exp $
+;; $fiHeader: standard-types.lisp,v 1.25 92/12/16 16:46:58 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1484,12 +1484,15 @@
 (define-presentation-type form ()
   :options ((auto-activate nil boolean))
   ;; Handling of AUTO-ACTIVATE is done below...
-  :inherit-from `expression)
+  :inherit-from `((expression) :auto-activate ,auto-activate))
 
 (define-presentation-method presentation-type-history ((type form))
   ;; Share history with EXPRESSION
   (presentation-type-history-for-frame 'expression *application-frame*))
 
+;;; this overwrites the method defined by the above
+;;; define-presentation-type form. This doesn't seem very satisfactory
+
 (define-presentation-method map-over-presentation-type-supertypes ((type form) function)
   (with-presentation-type-decoded (name) type
     (funcall function name type)
diff --git a/misc/xtsupport.c b/misc/xtsupport.c
index 641bcada14520812f7d90c2f939398f3655f3e63..617ff7370c65138701d927bc46280fb5d6e2c9a0 100644
--- a/misc/xtsupport.c
+++ b/misc/xtsupport.c
@@ -1,7 +1,7 @@
-/* $fiHeader: xtsupport.c,v 1.1 92/08/19 10:23:08 cer Exp $ */
+/* $fiHeader: xtsupport.c,v 1.2 93/03/01 14:26:21 cer Exp $ */
 
 #ifdef sparc
-#include "IntrinsicI.h
+#include "/x11/R4/src/mit/lib/Xt/IntrinsicI.h"
 #endif
 
 #ifdef ultrix
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 43ac0dab3509f9de8759e6a636ab4d4161400776..59773011a52e0cf92eb45134e8b4397aa81ff88b 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: classes.lisp,v 1.29 92/12/16 16:48:28 cer Exp $
+;; $fiHeader: classes.lisp,v 1.30 93/01/11 15:45:14 colin Exp $
 
 (in-package :silica)
 
@@ -90,8 +90,7 @@
      (foreground :initform +black+ :accessor medium-foreground)
      (background :initform +white+ :accessor medium-background)
      (ink :initform +foreground-ink+ :accessor medium-ink)
-     (text-style :initform *default-text-style* 
-		 :accessor medium-text-style)
+     (text-style :initform nil :accessor medium-text-style)
      (default-text-style :initform *default-text-style*
 			 :accessor medium-default-text-style)
      (merged-text-style :initform *default-text-style*
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 0c882f1018ec3e295e8a4c71eb5b7d1463016e63..d1f2bd5256610ec8e8fb4f2c373541cfe3d93200 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.34 92/12/16 16:50:03 cer Exp $
+;; $fiHeader: sysdcl.lisp,v 1.35 92/12/17 15:33:24 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -209,7 +209,6 @@
   ("temp-strings")
   ("coral-defs" :features CCL-2)
   ("clim-defs")
-  ("stipples")
   
   ;; Definitions and protocols
   ("stream-class-defs")
@@ -408,6 +407,7 @@
      :load-before-compile (clim-standalone xm-tk))
   ("pkg")
   ("xt-silica")
+  ("xt-stipples")
   ("xm-silica")
   ("xt-graphics")
   ("xm-graphics")
@@ -432,6 +432,7 @@
      :load-before-compile (clim-standalone ol-tk))
   ("pkg")
   ("xt-silica")
+  ("xt-stipples")
   ("ol-silica")
   ("xt-graphics")
   ("ol-graphics")
diff --git a/test/postscript-tests.lisp b/test/postscript-tests.lisp
index 34e6752340cf79a3cee6af10b02363a2098cf447..f5ca78424c24d183a6cc8ebee41228608efbdc50 100644
--- a/test/postscript-tests.lisp
+++ b/test/postscript-tests.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: postscript-tests.lisp,v 1.3 92/12/01 09:46:38 cer Exp $
+;; $fiHeader: postscript-tests.lisp,v 1.4 92/12/16 16:50:10 cer Exp $
 
 (in-package :clim-user)
 
@@ -238,14 +238,27 @@
 ;      (draw-text* stream "Quid fecit Dominus!?!" 200 200
 ;		    :text-style '(:sans-serif :italic :large)))))
 
+(defvar *hearts-tile*
+    (make-rectangular-tile
+     (make-pattern #2A((0 1 1 0 1 1 0 0)
+		       (1 0 0 1 0 0 1 0)
+		       (1 0 0 1 0 0 1 0)
+		       (0 1 0 0 0 1 0 0)
+		       (0 0 1 0 1 0 0 0)
+		       (0 0 0 1 0 0 0 0)
+		       (0 0 0 0 0 0 0 0)
+		       (0 0 0 0 0 0 0 0))
+		   (list +foreground-ink+ +background-ink+))
+     8 8))
+
 ;(defun pat-ps (&optional file)
 ;  (ps-test
-;    (draw-rectangle* stream 100 100 200 200 :ink *hearts-stipple*)))
+;    (draw-rectangle* stream 100 100 200 200 :ink *hearts-tile*)))
 
 (define-postscript-test (pattern-test "Draws a heart patterned rectangle"
 				      clim-user::graphics)
 			()
-  (draw-rectangle* *standard-output* 100 100 200 200 :ink clim-internals::*hearts-stipple*))
+  (draw-rectangle* *standard-output* 100 100 200 200 :ink *hearts-tile*))
 
 ;(defun test-l-ps (&optional file)
 ;  (ps-test
@@ -294,7 +307,7 @@
 ;  (ps-test
 ;    (flet ((draw (stream)
 ;		 (draw-rectangle* stream 0 0 50 50
-;				  :ink *hearts-stipple*)
+;				  :ink *hearts-tile*)
 ;		 #+Ignore
 ;		 (draw-triangle* stream 50 50 50 75 75 50 :ink +cyan+)
 ;		 (draw-circle* stream 70 30 20)))
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 1082b5fc3fe3469beda37ca941517e8917dc3cb8..4a2b1cb464146ec0487beff85230c64dac950377 100644
--- a/tk-silica/ol-gadgets.lisp
+++ b/tk-silica/ol-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-gadgets.lisp,v 1.37 93/01/18 13:58:07 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.38 93/02/08 15:58:04 cer Exp $
 
 
 (in-package :xm-silica)
@@ -502,6 +502,11 @@
 (defun openlook-text-field-edit-widget (tf &optional (mirror (sheet-direct-mirror tf)))
   (tk::get-values mirror :text-edit-widget))
 
+;;; --we need to define an event handler to deal with the losing focus
+;;; correcly. At the moment this function is simply incorrect.
+;;; when this is fixed put back assert in clim/gadget-output
+;;; accept-values-string-field-changed-callback 
+
 (defmethod add-sheet-callbacks :after ((port openlook-port) 
 				       (sheet openlook-text-field) 
 				       (widget t))
@@ -509,6 +514,10 @@
     (tk::add-callback (openlook-text-field-edit-widget sheet widget)
 		      :post-modify-notification
 		      'queue-value-changed-event
+		      sheet)
+    (tk::add-callback (openlook-text-field-edit-widget sheet widget)
+		      :post-modify-notification
+		      'queue-losing-focus-event
 		      sheet)))
 
 (defmethod gadget-value ((gadget openlook-text-field))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 8bb2567653a6b1ed06950b1c1e9472d2a12698a8..959d06f746ebe99af48951808b13489be935831d 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.63 93/02/08 15:58:10 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.64 93/03/01 14:26:36 cer Exp $
 
 (in-package :xm-silica)
 
@@ -114,7 +114,8 @@
           (ecase alignment
             ((:left nil) :beginning)
             (:center :center)
-            (:right :end)))))
+            (:right :end))))
+      (setf (getf initargs :recompute-size) nil))
     (values class initargs)))
 
 (defmethod (setf gadget-label) :after (nv (sheet motif-labelled-gadget))
@@ -530,6 +531,7 @@
 ;;; 
 
 (defclass motif-text-editor (motif-losing-focus-callback-pane
+			     motif-value-changed-callback-pane
                              motif-action-pane
                              text-editor
                              xt-leaf-pane)
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 69b43180a5b1ddf070465500d05c3c7e1defdd82..2417ca06d7f821a890eddd54fc2055ead68a865e 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.62 93/01/21 14:59:31 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.63 93/02/10 10:04:25 cer Exp $
 
 (in-package :tk-silica)
 
@@ -71,14 +71,10 @@
        ,value)))
 
 (defclass xt-medium (basic-medium)
-  ((foreground-gcontext :reader medium-foreground-gcontext :initform nil)
-   (background-gcontext :reader medium-background-gcontext :initform nil)
-   (flipping-gcontext :reader medium-flipping-gcontext :initform nil)
-   (drawable :initform nil)
+  ((drawable :initform nil)
    (ink-table :initform (make-hash-table :test #'equal))
-   (clip-mask :initform nil)		; A cache.
    (indirect-inks :initform nil)
-   (tile-gcontext :initform nil)))
+   (clip-mask :initform nil)))
 
 (defmethod medium-drawable ((medium xt-medium))
   (with-slots (drawable sheet) medium
@@ -306,10 +302,7 @@
   (tk::widget-window mirror nil))
 
 (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet)
-  (with-slots (foreground-gcontext background-gcontext
-				   flipping-gcontext
-				   indirect-inks 
-				   drawable tile-gcontext clip-mask)
+  (with-slots (indirect-inks drawable clip-mask)
       medium
     (let ((palette (medium-palette medium)))
       (with-slots (white-pixel black-pixel)
@@ -323,71 +316,32 @@
 	(let* ((display (port-display port))
 	       (drawable (or drawable
 			     (tk::display-root-window display))))
-	  (unless foreground-gcontext
-	    (setf foreground-gcontext (tk::make-instance 'ink-gcontext
-							 :drawable drawable)))
-	  (unless background-gcontext
-	    (setf background-gcontext (tk::make-instance 'ink-gcontext
-							 :drawable drawable)))
-	  (unless flipping-gcontext
-	    (setf flipping-gcontext
-	      (tk::make-instance 'ink-gcontext 
-				 :drawable drawable
-				 :function boole-xor)))
-	  (unless tile-gcontext
-	    (setf tile-gcontext (make-instance 'ink-gcontext
-					       :drawable drawable
-					       :foreground black-pixel
-					       :background white-pixel)))
-	  (recompute-gcs medium))))))
+	  (invalidate-indirect-inks medium))))))
 
 (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet)
   (declare (ignore sheet))
-  (with-slots 
-       (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext
-			    ink-table drawable)
+  (with-slots (ink-table indirect-inks drawable)
       medium
     (setf drawable nil
 	  (medium-sheet medium) nil)
-    (macrolet ((loose-gc (gc)
-		 `(when ,gc
-		    (tk::free-gcontext ,gc)
-		    (setf ,gc nil))))
-      (maphash #'(lambda (ink gc) 
-		   (declare (ignore ink))
-		   (tk::free-gcontext gc))
-	       ink-table)
-      (clrhash ink-table)
-      (loose-gc foreground-gcontext)
-      (loose-gc background-gcontext)
-      (loose-gc flipping-gcontext)
-      (loose-gc tile-gcontext))))
-
-(defun recompute-gcs (medium)
-  (with-slots 
-      (foreground-gcontext background-gcontext flipping-gcontext
-			   ink-table indirect-inks)
+    (maphash #'(lambda (ink gc) 
+		 (declare (ignore ink))
+		 (tk::free-gcontext gc))
+	     ink-table)
+    (clrhash ink-table)
+    (setf indirect-inks nil)))
+
+(defun invalidate-indirect-inks (medium)
+  (with-slots (ink-table indirect-inks)
       medium
-    (when (and foreground-gcontext background-gcontext flipping-gcontext)
-      (let* ((palette (medium-palette medium))
-	     (foreground-pixel 
-	      (decode-color-in-palette (medium-foreground medium) palette))
-	     (background-pixel
-	      (decode-color-in-palette (medium-background medium) palette)))
-	(setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel
-	      (tk::gcontext-background foreground-gcontext) background-pixel
-	      (tk::gcontext-foreground background-gcontext) background-pixel
-	      (tk::gcontext-background background-gcontext) background-pixel
-	      (tk::gcontext-foreground flipping-gcontext)
-	      (logxor foreground-pixel background-pixel))
-	(dolist (ink indirect-inks)
-	  (tk::free-gcontext (gethash ink ink-table))
-	  (remhash ink ink-table))
-	(setf indirect-inks nil)))))
+    (dolist (ink indirect-inks)
+      (tk::free-gcontext (gethash ink ink-table))
+      (remhash ink ink-table))
+    (setf indirect-inks nil)))
 
 (defmethod (setf medium-background) :after (ink (medium xt-medium))
   (declare (ignore ink))
-  (recompute-gcs medium)
+  (invalidate-indirect-inks medium)
   ;;--- This should be a in Silica method
   ;;--- This breaks the default-from-mirror-resource code when you
   ;;--- change the layout of a sheet
@@ -397,81 +351,12 @@
 
 (defmethod (setf medium-foreground) :after (ink (medium xt-medium))
   (declare (ignore ink))
-  (recompute-gcs medium))
-
-(defmethod (setf medium-ink) :after (ink (medium xt-medium))
-  (declare (ignore ink))
-  (recompute-gcs medium))
+  (invalidate-indirect-inks medium))
 
 
 ;;; Colors and their monochrome imposters
 ;;; Much of this is taken from CLX-IMPLEMENTATION
 
-(defvar *luminosity-stipples*
-	(mapcar #'(lambda (entry)
-		    (cons (first entry) (apply #'make-stipple-image (second entry))))
-		'((0.1 (8 16 (#b0111111111111111
-			      #b1111110111111111
-			      #b1111111111110111
-			      #b1101111111111111
-			      #b1111111101111111
-			      #b1111111111111101
-			      #b1111011111111111
-			      #b1111111111011111)))
-		  (0.2 (8 8 (#b01111111
-			     #b11101111
-			     #b11111101
-			     #b10111111
-			     #b11110111
-			     #b11111110
-			     #b11011111
-			     #b11111011)))
-		  (0.3 (4 4 (#b0111
-			     #b1101
-			     #b1011
-			     #b1110)))
-		  (0.4 (3 3 (#b011
-			     #b101
-			     #b110)))
-		  (0.6 (2 2 (#b01
-			     #b10)))
-		  (0.7 (3 3 (#b100
-			     #b010
-			     #b001)))
-		  (0.8 (4 4 (#b1000
-			     #b0010
-			     #b0100
-			     #b0001)))
-		  (0.9 (8 8 (#b10000000
-			     #b00010000
-			     #b00000010
-			     #b01000000
-			     #b00001000
-			     #b00000001
-			     #b00100000
-			     #b00000100)))
-		  (0.95 (8 16 (#b1000000000000000
-			       #b0000001000000000
-			       #b0000000000001000
-			       #b0010000000000000
-			       #b0000000010000000
-			       #b0000000000000010
-			       #b0000100000000000
-			       #b0000000000100000))))))
-		
-;; The tk::image objects are created at load time to save startup time.
-;; Here a '0' means white, '1' black.
-(defun decode-luminosity (luminosity stipple-p)
-  (if (not stipple-p)
-      (if (< luminosity 0.5) 1 0)	; Questionable.  XX
-      (if (< luminosity 0.05)
-	  1
-	  (dolist (entry *luminosity-stipples* 0)
-	    (let ((l (car entry))
-		  (stipple (cdr entry)))
-	      (when (< luminosity l)
-		(return-from decode-luminosity stipple)))))))
-
 ;;; (indirect-ink-p ink) returns t if ink is an indirect ink or
 ;;; derived from an indirect ink
 
@@ -479,14 +364,11 @@
 
 (defgeneric indirect-ink-p (ink))
 
-(defmethod indirect-ink-p ((ink design))
-  nil)
-
-(defmethod indirect-ink-p ((ink (eql +foreground-ink+)))
-  t)
+(defmethod indirect-ink-p ((ink design)) nil)
 
-(defmethod indirect-ink-p ((ink (eql +background-ink+)))
-  t)
+(defmethod indirect-ink-p ((ink (eql +foreground-ink+))) t)
+(defmethod indirect-ink-p ((ink (eql +background-ink+))) t)
+(defmethod indirect-ink-p ((ink standard-opacity)) t)
 
 (defmethod indirect-ink-p ((ink flipping-ink))
   (multiple-value-bind (ink1 ink2)
@@ -494,260 +376,7 @@
     (or (indirect-ink-p ink1)
 	(indirect-ink-p ink2))))
 
-(defgeneric decode-ink (ink medium))
-
-;;; the default decode-ink method. If it's in the table get gc from
-;;; there otherwise make a gc using decode-color-in-palette to get the
-;;; pixel value
-
-;;--- This is really on color, dynamic-color, and layered-color.
-;;--- Perhaps there should be a class like basic-color?
-
-(defmethod decode-ink ((ink design) (medium xt-medium))
-  (with-slots (ink-table sheet drawable) medium
-    (or (gethash ink ink-table)
-	(let* ((drawable (or drawable
-			     (tk::display-root-window (port-display (port sheet)))))
-	       (new-gc (make-instance 'ink-gcontext :drawable drawable)))
-	  (multiple-value-bind (pixel mask)
-	      (decode-color-in-palette ink (medium-palette medium))
-	    (setf (tk::gcontext-foreground new-gc) pixel)
-	    (when mask
-	      (setf (tk::gcontext-plane-mask new-gc) mask)))
-	  (setf (gethash ink ink-table) new-gc)))))
-
-(defmethod decode-ink ((ink (eql +everywhere+)) medium)
-  (slot-value medium 'foreground-gcontext))
-
-(defmethod decode-ink ((ink (eql +foreground-ink+)) medium)
-  (slot-value medium 'foreground-gcontext))
-
-(defmethod decode-ink ((ink (eql +background-ink+)) medium)
-  (slot-value medium 'background-gcontext))
-
-(defmethod decode-ink ((ink (eql +flipping-ink+)) stream)
-  (slot-value stream 'flipping-gcontext))
-
-(defmethod decode-ink ((ink flipping-ink) (medium xt-medium))
-  (let ((palette (medium-palette medium)))
-    (with-slots (ink-table sheet drawable indirect-inks)
-	medium
-      (or (gethash ink ink-table)
-	  (let* ((drawable (or drawable
-			       (tk::display-root-window (port-display (port sheet)))))
-		 (new-gc (make-instance 'ink-gcontext 
-					:drawable drawable
-					:function boole-xor)))
-	    (multiple-value-bind (color1 color2)
-		(decode-flipping-ink ink)
-	      (cond ((palette-color-p palette)
-		     (setf (tk::gcontext-foreground new-gc)
-		       (logxor (decode-color color1 medium)
-			       (decode-color color2 medium))))
-		    ;;-- support gray-scale here
-		    (t
-		     ;; in a monochrome context there is only one
-		     ;; flipping ink availiable ie white <-> black
-		     (slot-value medium 'flipping-gcontext)))
-	      (when (indirect-ink-p ink)
-		(push ink indirect-inks))
-	      (setf (gethash ink ink-table) new-gc)))))))
-		 
-
-(defmethod decode-ink ((ink color) (medium xt-medium))
-  (let ((palette (medium-palette medium)))
-    (with-slots (white-pixel black-pixel) palette
-      (with-slots (ink-table sheet tile-gcontext drawable) medium
-	(or (gethash ink ink-table)
-	    (let* ((drawable 
-		    (or drawable 
-			(tk::display-root-window (port-display (port sheet)))))
-		   (new-gc (make-instance 'ink-gcontext :drawable drawable)))
-	      (cond ((palette-color-p palette)
-		     (setf (tk::gcontext-foreground new-gc)
-		       (decode-color-in-palette ink palette)))
-		    ;;-- support gray-scale here
-		    (t
-		     (multiple-value-bind (r g b) (color-rgb ink)
-		       (let* ((luminosity (color-luminosity r g b))
-			      (color (decode-luminosity luminosity t)))
-			 (cond 
-			  ((eq color 1)
-			   (setf (tk::gcontext-fill-style new-gc) :solid
-				 (tk::gcontext-foreground new-gc) black-pixel))
-			  ((eq color 0)
-			   (setf (tk::gcontext-fill-style new-gc) :solid
-				 (tk::gcontext-foreground new-gc) white-pixel))
-			  (t		; color is an image
-			   (setf (tk::gcontext-fill-style new-gc) :tiled)
-			   (let ((pixmap 
-				  (make-instance 
-				   'tk::pixmap
-				   :drawable drawable
-				   :width (tk::image-width color)
-				   :height (tk::image-height color)
-				   :depth (tk::drawable-depth drawable))))
-			     (tk::put-image pixmap tile-gcontext color)
-			     (setf (tk::gcontext-tile new-gc) pixmap))))))))
-	      (setf (gethash ink ink-table) new-gc)))))))
-
-(defmethod decode-ink ((ink (eql +nowhere+)) medium)
-  (decode-ink-opacity ink medium))
-
-(defmethod decode-ink ((ink standard-opacity) medium)
-  (decode-ink-opacity ink medium))
-
-(defmethod decode-ink-opacity (opacity medium)
-  (with-slots (ink-table sheet drawable foreground-gcontext ink-table)
-      medium
-    (let ((key (cons opacity foreground-gcontext)))
-      (or (gethash key ink-table)
-	  (unless (eq :solid (tk::gcontext-fill-style foreground-gcontext))
-	    (warn "opacities may only be use with solid colors ~
-and on color servers, unless using white or black")
-            (return-from decode-ink-opacity foreground-gcontext))
-	  (let* ((port (port sheet))
-		 (display (port-display port))
-		 (drawable (or drawable (tk::display-root-window display)))
-		 (new-gc (make-instance 'ink-gcontext :drawable drawable)))
-  	    (x11:xcopygc display foreground-gcontext -1 new-gc)
-	    (setf (tk::gcontext-stipple new-gc) (decode-opacity opacity port)
-		  (tk::gcontext-fill-style new-gc) :stippled)
-	    (setf (gethash key ink-table) new-gc))))))
-
-(defmethod decode-contrasting-ink ((ink contrasting-ink) medium)
-  (if (palette-color-p (medium-palette medium))
-      (make-color-for-contrasting-ink ink)
-    (make-gray-color-for-contrasting-ink ink)))
- 
-(defmethod decode-ink ((ink contrasting-ink) medium)
-  (decode-ink (decode-contrasting-ink ink medium) medium))
-
-(defmethod decode-ink ((ink pattern) medium)
-  (with-slots (ink-table) medium
-    (or (gethash ink ink-table)
-	(setf (gethash ink ink-table)
-	  (decode-pattern-ink ink medium)))))
-    
-
-(defmethod decode-color ((design design) (medium xt-medium))
-  (decode-color-in-palette design (medium-palette medium)))
-
-(defmethod decode-color ((x (eql +foreground-ink+)) (medium xt-medium))
-  (with-slots (foreground-gcontext) medium
-    (tk::gcontext-foreground foreground-gcontext)))
-
-(defmethod decode-color ((x (eql +background-ink+)) (medium xt-medium))
-  (with-slots (background-gcontext) medium
-    (tk::gcontext-foreground background-gcontext)))
-
-(defmethod decode-color ((ink standard-opacity) (medium xt-medium))
-  (if (> (opacity-value ink) 0.5)
-      (decode-color +foreground-ink+ medium)
-      (decode-color +background-ink+ medium)))
-
-(defmethod decode-color ((ink contrasting-ink) (medium xt-medium))
-  (decode-color (decode-contrasting-ink ink medium) medium))
-
-(defmethod decode-color-in-palette ((design design) (palette xt-palette))
-  (error "Drawing with design: ~A not yet implemented" design))
-
-(defmethod decode-color-in-palette ((color color) (palette xt-palette))
-  (let ((color-cache (palette-color-cache palette)))
-    (or (gethash color color-cache)
-	(setf (gethash color color-cache)
-	  (with-slots (white-pixel black-pixel) palette
-	    (cond ((palette-color-p palette)
-		   (handler-case
-		       (tk::allocate-color
-			(palette-colormap palette) (get-xcolor color palette))
-		     (tk::x-colormap-full ()
-		       (error 'palette-full))))
-		  ;;-- support gray-scale here
-		  (t
-		   (multiple-value-bind (r g b) (color-rgb color)
-		     (let ((luminosity (color-luminosity r g b)))
-		       (if (< luminosity 0.5) black-pixel white-pixel))))))))))
-
-(defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette))
-  (let ((dynamic-color-cache (palette-dynamic-color-cache palette)))
-    (or (gethash color dynamic-color-cache)
-	(let ((pixel (aref (handler-case
-			       (tk::alloc-color-cells
-				(palette-colormap palette) 1 0)
-			     (tk::x-colormap-full ()
-			       (error 'palette-full)))
-			   0)))
-	  (update-palette-entry palette pixel (dynamic-color-color color))
-	  (push palette (dynamic-color-palettes color))
-	  (setf (gethash color dynamic-color-cache) pixel)))))
-
-(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette))
-  (let ((layered-color-cache (palette-layered-color-cache palette)))
-    (values-list
-     (or (gethash color layered-color-cache)
-	 (setf (gethash color layered-color-cache)
-	   (let* ((set (layered-color-set color))
-		  (pixel-planes (gethash set layered-color-cache)))
-	     (unless pixel-planes
-	       (setq pixel-planes (decode-layered-color-set set palette)))
-	     (multiple-value-list 
-		 (decode-layered-color (layered-color-layers color) pixel-planes))))))))
-
-(defun decode-layered-color (layers pixel-planes)
-  (let ((pixel (car pixel-planes))
-	(planes (cdr pixel-planes))
-	(mask 0)) 
-    (dolist (layer layers)
-      (let ((plane-masks (pop planes)))
-	(if layer
-	    (dolist (plane-mask plane-masks)
-	      (when (zerop layer)
-		(return))
-	      (when (oddp layer)
-		(setq pixel (logior pixel plane-mask)))
-	      (setq layer (ash layer -1)))
-	  (dolist (plane-mask plane-masks)
-	    (setq mask (logior mask plane-mask))))))
-    (values pixel (lognot mask))))
-
-(defun decode-layered-color-set (set palette)
-  (let ((layered-color-cache (palette-layered-color-cache palette))
-	(dynamic-color-cache (palette-dynamic-color-cache palette))
-	(layers (layered-color-set-layers set))
-	(dynamic-array (layered-color-set-dynamic-array set))
-	layer-nplanes
-	(total-nplanes 0))
-    (dolist (layer layers)
-      (let ((nplanes (floor (log layer 2))))
-	(push nplanes layer-nplanes)
-	(incf total-nplanes nplanes)))
-    (multiple-value-bind (pixels masks)
-	(handler-case
-	    (tk::alloc-color-cells
-	     (palette-colormap palette) 1 total-nplanes)
-	  (tk::x-colormap-full ()
-	    (error 'palette-full)))
-      (let ((pixel (aref pixels 0))
-	    (count 0)
-	    (planes nil))
-	(dolist (nplanes layer-nplanes)
-	  (let ((plane-masks nil))
-	    (dotimes (i nplanes)
-	      (push (aref masks count) plane-masks)
-	      (incf count))
-	    (push plane-masks planes)))
-	(let ((pixel-planes (cons pixel planes)))
-	  (map-over-layered-colors  
-	   #'(lambda (dimensions)
-	       (let ((dynamic-color (apply #'aref dynamic-array dimensions))
-		     (pixel (decode-layered-color dimensions
-						  pixel-planes)))
-		 (setf (gethash dynamic-color dynamic-color-cache) pixel)
-		 (update-palette-entry palette pixel (dynamic-color-color dynamic-color))
-		 (push palette (dynamic-color-palettes dynamic-color))))
-	   set)
-	  (setf (gethash set layered-color-cache) pixel-planes))))))
+;;; adjust ink
 
 (defvar *default-dashes* '(4 4))
 
@@ -859,18 +488,120 @@ and on color servers, unless using white or black")
 		  (values (list x y width height) x-origin y-origin))))))))
     medium-clip-mask))
 
-#+ignore
-(defmethod decode-ink :around ((ink t) (medium xt-medium))
-  (let ((gc (call-next-method)))
-    gc))
+;;; decode ink
+
+(defgeneric decode-ink (ink medium))
 
-(defmethod decode-pattern-design ((ink (eql +nowhere+)) (medium xt-medium))
-  nil)
+;;; we provide this around method which implement a cache of already
+;;; decoded inks
 
-(defmethod decode-pattern-design ((ink design) (medium xt-medium))
-  (decode-color ink medium))
+;;; if the decode method for an ink calculates the gcontext by calling
+;;; decode-ink it should also return t as it's second value. (eg for
+;;; contrasting inks) This prevent problems with having multiple
+;;; entries for the same gc in the table which causes problems when
+;;; they need to be freed
 
-(defmethod decode-pattern-ink ((pattern pattern) medium) 
+(defmethod decode-ink :around ((ink design) (medium xt-medium))
+  (with-slots (ink-table indirect-inks) medium
+    (or (gethash ink ink-table)
+	(multiple-value-bind (gc recursive-p)
+	    (call-next-method)
+	  (unless recursive-p
+	    (when (indirect-ink-p ink)
+	      (push ink indirect-inks))
+	    (setf (gethash ink ink-table) gc))
+	  gc))))
+
+;;; the default decode-ink method. Make a gc using
+;;; decode-color-in-palette to get the pixel value
+
+;;--- This is really only makes sense for color, dynamic-color, and
+;;--- layered-color. Perhaps there should be a class like basic-color?
+
+(defmethod decode-ink ((ink design) (medium xt-medium))
+  (with-slots (sheet drawable) medium
+    (let* ((drawable (or drawable
+			 (tk::display-root-window (port-display (port sheet)))))
+	   (new-gc (make-instance 'ink-gcontext :drawable drawable)))
+      (multiple-value-bind (pixel mask)
+	  (decode-color ink medium)
+	(setf (tk::gcontext-foreground new-gc) pixel)
+	(when mask
+	  (setf (tk::gcontext-plane-mask new-gc) mask)))
+      new-gc)))
+
+(defmethod decode-ink ((ink flipping-ink) (medium xt-medium))
+  (with-slots (sheet drawable)
+      medium
+    (let* ((drawable (or drawable
+			 (tk::display-root-window (port-display (port sheet)))))
+	   (new-gc (make-instance 'ink-gcontext 
+				  :drawable drawable
+				  :function boole-xor)))
+      (multiple-value-bind (color1 color2)
+	  (decode-flipping-ink ink)
+	(setf (tk::gcontext-foreground new-gc)
+	  (logxor (decode-color color1 medium)
+		  (decode-color color2 medium))))
+      new-gc)))
+		 
+(defmethod decode-ink ((ink color) (medium xt-medium))
+  (let ((palette (medium-palette medium)))
+    (with-slots (white-pixel black-pixel) palette
+      (with-slots (sheet drawable) medium
+	(let* ((port (port sheet))
+	       (drawable 
+		(or drawable 
+		    (tk::display-root-window (port-display port))))
+	       (new-gc (make-instance 'ink-gcontext :drawable drawable)))
+	  (cond ((palette-color-p palette)
+		 (setf (tk::gcontext-foreground new-gc)
+		   (decode-color-in-palette ink palette)))
+		;;-- support gray-scale here
+		(t
+		 (multiple-value-bind (r g b) (color-rgb ink)
+		   (let ((luminosity (color-luminosity r g b)))
+		     (cond 
+		      ((<= luminosity 0.05)
+		       (setf (tk::gcontext-foreground new-gc) black-pixel))
+		      ((< 0.95 luminosity)
+		       (setf (tk::gcontext-foreground new-gc) white-pixel))
+		      (t
+		       (setf (tk::gcontext-fill-style new-gc) :opaque-stippled
+			     (tk::gcontext-foreground new-gc) white-pixel
+			     (tk::gcontext-background new-gc) black-pixel
+			     (tk::gcontext-stipple new-gc)
+			     (decode-stipple luminosity port))))))))
+	  new-gc)))))
+
+(defmethod decode-ink ((ink (eql +nowhere+)) (medium xt-medium))
+  (decode-ink-opacity ink medium))
+
+(defmethod decode-ink ((ink standard-opacity) (medium xt-medium))
+  (decode-ink-opacity ink medium))
+
+(defmethod decode-ink-opacity (opacity (medium xt-medium))
+  (with-slots (sheet drawable)
+      medium
+    (let* ((port (port sheet))
+	   (display (port-display port))
+	   (drawable (or drawable (tk::display-root-window display)))
+	   (new-gc (make-instance 'ink-gcontext :drawable drawable)))
+      (setf (tk::gcontext-foreground new-gc) (decode-color +foreground-ink+ medium)
+	    (tk::gcontext-stipple new-gc) (decode-stipple (opacity-value opacity) port)
+	    (tk::gcontext-fill-style new-gc) :stippled)
+      new-gc)))
+
+(defmethod decode-contrasting-ink ((ink contrasting-ink) (medium xt-medium))
+  (if (palette-color-p (medium-palette medium))
+      (make-color-for-contrasting-ink ink)
+    (make-gray-color-for-contrasting-ink ink)))
+ 
+(defmethod decode-ink ((ink contrasting-ink) (medium xt-medium))
+  (values 
+   (decode-ink (decode-contrasting-ink ink medium) medium) t))
+
+(defmethod decode-ink ((pattern pattern) (medium xt-medium)) 
   (multiple-value-bind (array designs)
       (decode-pattern pattern)
     (let* ((height (array-dimension array 0))
@@ -884,10 +615,11 @@ and on color servers, unless using white or black")
 
 	;; Cache the decoded designs from the pattern
 	(dotimes (n (length designs))
-	  (let ((pixel (decode-pattern-design (elt designs n) medium))) 
-	    (setf (svref design-pixels n) pixel)
-	    (unless pixel
-	      (setf transparent-p t))))
+	  (let ((design (elt designs n)))
+	    (if (eql design +nowhere+)
+		(setf transparent-p t)
+	      (setf (svref design-pixels n)
+		(decode-color design medium)))))
 	
 	(dotimes (w width)
 	  (dotimes (h height)
@@ -935,7 +667,9 @@ and on color servers, unless using white or black")
 	  gc))))
 
 ;;---the following extends a pattern for tiling by making it
-;;transparent. This causes problems in the test-suite.
+;;transparent. This causes problems in the test-suite. This is more
+;;correct with regards to the spec but maybe the spec is "wrong" on
+;;this one
 #+ignore 
 (defun decode-extended-pattern (pattern width height)
   (multiple-value-bind (array designs)
@@ -975,82 +709,202 @@ and on color servers, unless using white or black")
 	    (values extended-array designs))
 	(values array designs)))))
 	    
-(defmethod decode-ink ((ink rectangular-tile) medium)
-  (with-slots (ink-table) medium
-    (or (gethash ink ink-table)
-	(setf (gethash ink ink-table)
-	  (multiple-value-bind (pattern width height)
-	      (decode-rectangular-tile ink)
-	  (setf (gethash pattern ink-table)
-	    (multiple-value-bind (array designs)
-		(decode-extended-pattern pattern width height)
-	      (let* ((image-data (make-array (list height width)))
-		     (design-pixels (make-array (length designs)))
-		     (two-color-p (= (length designs) 2)) 
-		     two-color-fg two-color-bg)
-		(declare (simple-vector design-pixels))
-
-		;; Cache the decoded designs from the pattern
-		(dotimes (n (length designs))
-		  (let ((pixel (decode-pattern-design (elt designs n) medium)))
-		    (setf (svref design-pixels n) pixel)
-		    (unless (or two-color-p pixel)
-		      (error "Transparent tiled pattern ~S has more than two designs"
-			     pattern))))
+(defmethod decode-ink ((ink rectangular-tile) (medium xt-medium))
+  (multiple-value-bind (pattern width height)
+      (decode-rectangular-tile ink)
+    (multiple-value-bind (array designs)
+	(decode-extended-pattern pattern width height)
+      (let* ((image-data (make-array (list height width)))
+	     (design-pixels (make-array (length designs)))
+	     (two-color-p (= (length designs) 2)) 
+	     two-color-fg two-color-bg)
+	(declare (simple-vector design-pixels))
+
+	;; Cache the decoded designs from the pattern
+	(dotimes (n (length designs))
+	  (let ((design (elt designs n)))
+	    (if (eql design +nowhere+)
+		(unless two-color-p
+		  (error "Transparent tiled pattern ~S has more than two designs"
+			 pattern))
+	      (setf (svref design-pixels n)
+		(decode-color design medium)))))
 		
-		(when two-color-p
-		  (setq two-color-bg (svref design-pixels 0)
-			two-color-fg (svref design-pixels 1))
-		  ;; make sure that any transparent design is the bg
-		  (when (null (svref design-pixels 1))
-		    (rotatef two-color-bg two-color-fg)))
+	(when two-color-p
+	  (setq two-color-bg (svref design-pixels 0)
+		two-color-fg (svref design-pixels 1))
+	  ;; make sure that any transparent design is the bg
+	  (when (null (svref design-pixels 1))
+	    (rotatef two-color-bg two-color-fg)))
 	    
-		(dotimes (w width)
-		  (dotimes (h height)
-		    (let ((pixel (svref design-pixels (aref array h w))))
-		      (setf (aref image-data h w)
-			(if two-color-p
-			    (if (eq pixel two-color-bg)
-				0
-			      1)
-			  pixel)))))
-
-		(let* ((port (port (medium-sheet medium)))
-		       (drawable (or (slot-value medium 'drawable)
-				     (tk::display-root-window
-				      (port-display port)))) 
-		       (depth (if two-color-p
-				  1
-				(tk::drawable-depth drawable)))
-		       (image (make-instance 'tk::image
-					     :width width
-					     :height height
-					     :data image-data
-					     :depth depth))
-		       (gc (make-instance 'ink-gcontext :drawable drawable))
-		       (pixmap 
-			(make-instance 'tk::pixmap
-				       :drawable drawable
-				       :width width
-				       :height height
-				       :depth depth)))
-		  (tk::put-image pixmap 
-				 (if two-color-p
-				     (port-copy-gc-depth-1 port)
-				   gc) 
-				 image)
-		  (if two-color-p
-		      (setf (tk::gcontext-stipple gc) pixmap
-			    (tk::gcontext-fill-style gc) (if two-color-bg
-							     :opaque-stippled
-							   :stippled)
-			    (tk::gcontext-foreground gc) (or two-color-fg 0)
-			    (tk::gcontext-background gc) (or two-color-bg 0))
-		    (setf (tk::gcontext-tile gc) pixmap
-			  (tk::gcontext-fill-style gc) :tiled))
-		  gc)))))))))
+	(dotimes (w width)
+	  (dotimes (h height)
+	    (let ((pixel (svref design-pixels (aref array h w))))
+	      (setf (aref image-data h w)
+		(if two-color-p
+		    (if (eq pixel two-color-bg)
+			0
+		      1)
+		  pixel)))))
+
+	(let* ((port (port (medium-sheet medium)))
+	       (drawable (or (slot-value medium 'drawable)
+			     (tk::display-root-window
+			      (port-display port)))) 
+	       (depth (if two-color-p
+			  1
+			(tk::drawable-depth drawable)))
+	       (image (make-instance 'tk::image
+				     :width width
+				     :height height
+				     :data image-data
+				     :depth depth))
+	       (gc (make-instance 'ink-gcontext :drawable drawable))
+	       (pixmap 
+		(make-instance 'tk::pixmap
+			       :drawable drawable
+			       :width width
+			       :height height
+			       :depth depth)))
+	  (tk::put-image pixmap 
+			 (if two-color-p
+			     (port-copy-gc-depth-1 port)
+			   gc) 
+			 image)
+	  (if two-color-p
+	      (setf (tk::gcontext-stipple gc) pixmap
+		    (tk::gcontext-fill-style gc) (if two-color-bg
+						     :opaque-stippled
+						   :stippled)
+		    (tk::gcontext-foreground gc) (or two-color-fg 0)
+		    (tk::gcontext-background gc) (or two-color-bg 0))
+	    (setf (tk::gcontext-tile gc) pixmap
+		  (tk::gcontext-fill-style gc) :tiled))
+	  gc)))))
+
+;;; decode color
+
+(defgeneric decode-color (design medium))
+
+(defmethod decode-color ((design design) (medium xt-medium))
+  (decode-color-in-palette design (medium-palette medium)))
+
+(defmethod decode-color ((x (eql +everywhere+)) (medium xt-medium))
+  (decode-color-in-palette (medium-foreground medium) (medium-palette medium)))
+
+(defmethod decode-color ((x (eql +foreground-ink+)) (medium xt-medium))
+  (decode-color-in-palette (medium-foreground medium) (medium-palette medium)))
+
+(defmethod decode-color ((x (eql +background-ink+)) (medium xt-medium))
+  (decode-color-in-palette (medium-background medium) (medium-palette medium)))
+
+(defmethod decode-color ((ink standard-opacity) (medium xt-medium))
+  (if (> (opacity-value ink) 0.5)
+      (decode-color +foreground-ink+ medium)
+      (decode-color +background-ink+ medium)))
+
+(defmethod decode-color ((ink contrasting-ink) (medium xt-medium))
+  (decode-color (decode-contrasting-ink ink medium) medium))
+
+(defmethod decode-color-in-palette ((design design) (palette xt-palette))
+  (error "Drawing with design: ~A not yet implemented" design))
+
+(defmethod decode-color-in-palette ((color color) (palette xt-palette))
+  (let ((color-cache (palette-color-cache palette)))
+    (or (gethash color color-cache)
+	(setf (gethash color color-cache)
+	  (with-slots (white-pixel black-pixel) palette
+	    (cond ((palette-color-p palette)
+		   (handler-case
+		       (tk::allocate-color
+			(palette-colormap palette) (get-xcolor color palette))
+		     (tk::x-colormap-full ()
+		       (error 'palette-full))))
+		  ;;-- support gray-scale here
+		  (t
+		   (multiple-value-bind (r g b) (color-rgb color)
+		     (let ((luminosity (color-luminosity r g b)))
+		       (if (< luminosity 0.5) black-pixel white-pixel))))))))))
+
+(defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette))
+  (let ((dynamic-color-cache (palette-dynamic-color-cache palette)))
+    (or (gethash color dynamic-color-cache)
+	(let ((pixel (aref (handler-case
+			       (tk::alloc-color-cells
+				(palette-colormap palette) 1 0)
+			     (tk::x-colormap-full ()
+			       (error 'palette-full)))
+			   0)))
+	  (update-palette-entry palette pixel (dynamic-color-color color))
+	  (push palette (dynamic-color-palettes color))
+	  (setf (gethash color dynamic-color-cache) pixel)))))
 
+(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette))
+  (let ((layered-color-cache (palette-layered-color-cache palette)))
+    (values-list
+     (or (gethash color layered-color-cache)
+	 (setf (gethash color layered-color-cache)
+	   (let* ((set (layered-color-set color))
+		  (pixel-planes (gethash set layered-color-cache)))
+	     (unless pixel-planes
+	       (setq pixel-planes (decode-layered-color-set set palette)))
+	     (multiple-value-list 
+		 (decode-layered-color (layered-color-layers color) pixel-planes))))))))
 
+(defun decode-layered-color (layers pixel-planes)
+  (let ((pixel (car pixel-planes))
+	(planes (cdr pixel-planes))
+	(mask 0)) 
+    (dolist (layer layers)
+      (let ((plane-masks (pop planes)))
+	(if layer
+	    (dolist (plane-mask plane-masks)
+	      (when (zerop layer)
+		(return))
+	      (when (oddp layer)
+		(setq pixel (logior pixel plane-mask)))
+	      (setq layer (ash layer -1)))
+	  (dolist (plane-mask plane-masks)
+	    (setq mask (logior mask plane-mask))))))
+    (values pixel (lognot mask))))
+
+(defun decode-layered-color-set (set palette)
+  (let ((layered-color-cache (palette-layered-color-cache palette))
+	(dynamic-color-cache (palette-dynamic-color-cache palette))
+	(layers (layered-color-set-layers set))
+	(dynamic-array (layered-color-set-dynamic-array set))
+	layer-nplanes
+	(total-nplanes 0))
+    (dolist (layer layers)
+      (let ((nplanes (floor (log layer 2))))
+	(push nplanes layer-nplanes)
+	(incf total-nplanes nplanes)))
+    (multiple-value-bind (pixels masks)
+	(handler-case
+	    (tk::alloc-color-cells
+	     (palette-colormap palette) 1 total-nplanes)
+	  (tk::x-colormap-full ()
+	    (error 'palette-full)))
+      (let ((pixel (aref pixels 0))
+	    (count 0)
+	    (planes nil))
+	(dolist (nplanes layer-nplanes)
+	  (let ((plane-masks nil))
+	    (dotimes (i nplanes)
+	      (push (aref masks count) plane-masks)
+	      (incf count))
+	    (push plane-masks planes)))
+	(let ((pixel-planes (cons pixel planes)))
+	  (map-over-layered-colors  
+	   #'(lambda (dimensions)
+	       (let ((dynamic-color (apply #'aref dynamic-array dimensions))
+		     (pixel (decode-layered-color dimensions
+						  pixel-planes)))
+		 (setf (gethash dynamic-color dynamic-color-cache) pixel)
+		 (update-palette-entry palette pixel (dynamic-color-color dynamic-color))
+		 (push palette (dynamic-color-palettes dynamic-color))))
+	   set)
+	  (setf (gethash set layered-color-cache) pixel-planes))))))
 
 
 ;; Line (& maybe eventually non-rectangular polygon) clipping
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 0d2f1323f7ecd5282f4dc6b2d1dbcc9d78e7eed6..50d6200ed14f1f2273d7ae67de13a9f6b4bf0c81 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.68 93/01/21 14:59:36 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.69 93/02/08 15:58:19 cer Exp $
 
 (in-package :xm-silica)
 
@@ -30,7 +30,7 @@
      (context :reader port-context)     
      (copy-gc :initform nil)
      (copy-gc-depth-1 :initform nil)
-     (opacities :initform nil)
+     (stipples :initform nil :accessor port-stipples)
      ;; This next is true for servers like Suns, which (pretty much) always
      ;; can safely copy-area without generating graphics-exposures.
      (safe-backing-store :initform nil :accessor port-safe-backing-store)
@@ -220,7 +220,7 @@
 	      ;;; Perhaps we should just grab the first font we can find.
 	      (t
 	       (error "Unable to determine default font"))))))
-  (setup-opacities port display))
+  (setup-stipples port display))
 
 (defparameter *xt-logical-size-alist*
 	      '((:tiny       6)
@@ -236,103 +236,6 @@
   (standardize-text-style-1
     port style character-set *xt-logical-size-alist*))
 
-(defun make-stipple-image (height width patterns)
-  (make-instance 'tk::image :width width :height height
-		 :data (clim-internals::make-stipple-array height width patterns)
-		 :depth 1))
-
-(defvar *opacity-stipples*
-	(mapcar #'(lambda (entry)
-		    (cons (first entry)
-			  (apply #'make-stipple-image (second entry))))
-		'((+nowhere+ (1 1 (#b0)))
-		  (0.05 (8 16 (#b1000000000000000
-			       #b0000001000000000
-			       #b0000000000001000
-			       #b0010000000000000
-			       #b0000000010000000
-			       #b0000000000000010
-			       #b0000100000000000
-			       #b0000000000100000)))
-		  (0.1 (8 8 (#b10000000
-			     #b00010000
-			     #b00000010
-			     #b01000000
-			     #b00001000
-			     #b00000001
-			     #b00100000
-			     #b00000100)))
-		  (0.2 (4 4 (#b1000
-			     #b0010
-			     #b0100
-			     #b0001)))
-		  (0.3 (3 3 (#b100
-			     #b010
-			     #b001)))
-		  (0.4 (2 2 (#b10
-			     #b01)))
-		  (0.6 (3 3 (#b011
-			     #b101
-			     #b110)))
-		  (0.7 (4 4 (#b0111
-			     #b1101
-			     #b1011
-			     #b1110)))
-		  (0.8 (8 8 (#b01111111
-			     #b11101111
-			     #b11111101
-			     #b10111111
-			     #b11110111
-			     #b11111110
-			     #b11011111
-			     #b11111011)))
-		  (0.9 (8 16 (#b0111111111111111
-			      #b1111110111111111
-			      #b1111111111110111
-			      #b1101111111111111
-			      #b1111111101111111
-			      #b1111111111111101
-			      #b1111011111111111
-			      #b1111111111011111)))
-		  (+everywhere+ (1 1 (#b1))))))
-
-
-(defun setup-opacities (port display)
-  (let ((opacities nil)
-	(root (tk::display-root-window display))
-	gc)
-    (dolist (ls *opacity-stipples*)
-      (let ((pixmap (make-instance 'tk::pixmap
-		      :drawable root
-		      :width (tk::image-width (cdr ls))
-		      :height (tk::image-height (cdr ls))
-		      :depth 1)))
-	(unless gc
-	  (setq gc (make-instance 'tk::gcontext :drawable pixmap
-				  :foreground 1 :background 0)))
-	 (tk::put-image pixmap gc (cdr ls))
-	(push (cons (car ls) pixmap) opacities)))
-    (when gc
-      (tk::free-gcontext gc))
-    (setf (slot-value port 'opacities) (nreverse opacities))))
-
-;;
-;; Takes an opacity, and returns a clip mask (pixmap) for that opacity.
-;;
-(defun decode-opacity (opacity port)
-  (let ((pops (slot-value port 'opacities)))
-    (cond ((eq opacity +nowhere+)
-	   (cdar pops))
-	  ((eq opacity +everywhere+)
-	   (cdar (last pops)))
-	  (t
-	   (let ((lastpop (cdar pops))
-		 (value (opacity-value opacity)))
-	     (dolist (pop (cdr pops) lastpop)
-	       (if (< value (car pop))
-		   (return lastpop))
-	       (setq lastpop (cdr pop))))))))
-
 
 
 (defmethod destroy-mirror ((port xt-port) (sheet mirrored-sheet-mixin))
@@ -1723,8 +1626,12 @@ the geometry of the children. Instead the parent has control. "))
   (check-type y (signed-byte 16))
   (tk::set-values (frame-shell frame) :x x :y y))
 
+(defmethod port-resize-frame ((port xt-port) frame width height)
+  (check-type width (signed-byte 16))
+  (check-type height (signed-byte 16))
+  (tk::set-values (frame-shell frame) :width width :height height))
+
 (defmethod destroy-port ((port xt-port))
   (when (port-process port)
     (clim-sys:destroy-process (port-process port)))
   (port-terminated port (make-condition 'error)))
-
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index fe6a22da2bb7a0b4cf32e0c8a6f5d84077510678..bd12773432a9bd17164eb762d145cba767c9e476 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.38 93/01/11 15:45:55 colin Exp $
+;; $fiHeader: xlib.lisp,v 1.39 93/02/08 15:57:57 cer Exp $
 
 (in-package :tk)
 
@@ -634,53 +634,49 @@
    (height :reader image-height :initarg :height)
    (data :reader image-data :initarg :data)
    (depth :reader image-depth :initarg :depth)
+   (format :reader image-format :initform x11:zpixmap :initarg :format)
    (realized-displays :initform nil :accessor realized-displays)))
   
 
+(defconstant bitmap-pad 8)
+
 (defmethod realize-image (image display)
   (when (not (member display (realized-displays image)))
-    (let ((width (image-width image))
-	  (height (image-height image))
-	  (data (image-data image))
-	  (depth (image-depth image))
-	  v
-	  format
-	  (bytes-per-line 0)
-	  (bitmap-pad 8))		; Why is this 8 - if 0 get signal 8!
-					;  -- RTFM, dude.  (jdi)
-      (ecase depth
+    (let* ((width (image-width image))
+	   (height (image-height image))
+	   (data (image-data image))
+	   (depth (image-depth image))
+	   (format (image-format image))
+	   (bits-per-line (* width depth))
+	   (padded-bits-per-line (* bitmap-pad 
+				    (ceiling bits-per-line bitmap-pad)))
+	   (bytes-per-line (/ padded-bits-per-line 8))
+	   (v (excl::malloc (* bytes-per-line height)))
+	   (visual (x11:screen-root-visual
+		    (x11:xdefaultscreenofdisplay display)))
+	   (offset 0)
+	   (x (x11:xcreateimage display
+				visual
+				depth
+				format
+				offset
+				v
+				width
+				height
+				bitmap-pad
+				bytes-per-line)))
+      (case depth
 	(8 
-	 (setq format x11:zpixmap)
-	 (setq v (excl::malloc (* width height)))
 	 (dotimes (h height)
 	   (dotimes (w width)
-	     (setf (sys::memref-int v (+ (* h width) w) 0 :unsigned-byte)
+	     (setf (sys::memref-int v (+ (* h bytes-per-line) w) 0 :unsigned-byte)
 	       (aref data h w)))))
-	(1
-	 (setq format x11:zpixmap)
-	 (setq bytes-per-line (ceiling (/ width bitmap-pad)))
-	 (setq v (excl::malloc (* bytes-per-line height)))))
-      (let* ((visual (x11:screen-root-visual
-		      (x11:xdefaultscreenofdisplay display)))
-	     (offset 0)
-	     (x (x11:xcreateimage
-		 display
-		 visual
-		 depth
-		 format
-		 offset
-		 v
-		 width
-		 height
-		 bitmap-pad
-		 bytes-per-line)))
-	(case depth
-	  (1
-	   (dotimes (h height)
-	     (dotimes (w width)
-	       (x11:xputpixel x w h (aref data h w))))))
-	(setf (foreign-pointer-address image) x)))
-    (pushnew display (realized-displays image))))
+	(t
+	 (dotimes (h height)
+	   (dotimes (w width)
+	     (x11:xputpixel x w h (aref data h w))))))
+      (setf (foreign-pointer-address image) x))
+    (push display (realized-displays image))))
 
 (defmethod put-image (pixmap gc image
 		      &key (src-x 0) (src-y 0) (dest-x 0) (dest-y 0))
diff --git a/utils/packages.lisp b/utils/packages.lisp
index da4efcc9dc0fecffb003d331ff1b001a963750d7..daae5b541eb4413fcc9d7d7f3960a72db972095b 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.46 93/01/21 14:59:44 cer Exp $
+;; $fiHeader: packages.lisp,v 1.47 93/02/08 15:58:29 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -3494,6 +3494,7 @@
     port-invoke-with-pointer-grabbed
     port-mirror->sheet-table
     port-move-frame
+    port-resize-frame
     port-note-cursor-change
     port-note-frame-adopted
     port-note-gadget-activated
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index c8968f92ebf77cb32583ee1e978ec92801e7f4b8..8b99fa00234fb2032764db4c8f46fa04f721179c 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -45,7 +45,7 @@
 ;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
 ;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
 
-;;; $fiHeader: xlib-funs.lisp,v 1.8 92/09/30 18:03:32 cer Exp $
+;;; $fiHeader: xlib-funs.lisp,v 1.9 92/12/14 15:05:17 cer Exp $
 
 (in-package :x11)
 
@@ -2002,3 +2002,12 @@
   (bytes-buffer	int)
   (keysym-return (:pointer keysym))
   (status-in-out (:pointer xcomposestatus)))
+
+#+ignore
+(def-exported-foreign-function (xmatchvisualinfo (:return-type int)
+						 (:name "XMatchVisualInfo"))
+    (dpy (:pointer display))
+    (scr int)
+    (depth int)
+    (class int)
+    (vinfo-return (:pointer visual-info)))