From e436c422b88ee12156a585bbcf270554706eb61c Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Sun, 4 Oct 1992 14:16:52 +0000
Subject: [PATCH] fixes

---
 Makefile                   |  19 +++--
 clim/frames.lisp           |   5 +-
 demo/address-book.lisp     |   5 +-
 demo/color-editor.lisp     |  32 ++++++--
 demo/demo-activity.lisp    |   9 ++-
 demo/ico.lisp              | 146 ++++++++++++++++++++++++-------------
 demo/puzzle.lisp           |   3 +-
 silica/classes.lisp        |   4 +-
 silica/framem.lisp         |   2 +-
 silica/medium.lisp         |  31 +++++++-
 test/test-suite.lisp       |  23 +-----
 test/test.lisp             |   4 +-
 tk-silica/ol-gadgets.lisp  |  13 +++-
 tk-silica/xt-graphics.lisp |  98 ++++++++++++-------------
 tk-silica/xt-silica.lisp   |   7 +-
 tk/resources.lisp          |   6 +-
 utils/base-designs.lisp    |  15 +---
 utils/designs.lisp         | 123 ++++++++++---------------------
 utils/packages.lisp        |  75 +++++++++----------
 19 files changed, 333 insertions(+), 287 deletions(-)

diff --git a/Makefile b/Makefile
index a384f71c..97e58006 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.50 92/10/01 08:25:05 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.51 92/10/02 15:20:51 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
@@ -104,13 +104,22 @@ OL_UNDEFS=misc/undefinedsymbols.olit
 CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl clim-debugol.fasl \
 	   clim-debugxm.fasl climps.fasl climgg.fasl # clim1compat.fasl
 
-CLIMOBJS= clim-motif_d.o clim-olit_d.o  clim-motif.o clim-olit.o stub-xt.o stub-x.o \
+PUBLIC_OBJS=  stub-xt.o stub-x.o \
 	  xlibsupport.o MyDrawingA.o \
 	  olsupport.o xtsupport.o
 
+OL_LICENSED_OBJS=clim-olit.o clim-olit_d.o
+XM_LICENSED_OBJS=clim-motif_d.o  clim-motif.o 
+
+CLIMOBJS=$(PUBLIC_OBJS) $(XM_LICENSED_OBJS) $(OL_LICENSED_OBJS)
+
+INSTALLED_CLIMOBJS=$(PUBLIC_OBJS) $(XM_LICENSED_OBJS) $(OL_LICENSED_OBJS)
+
+
 # These are linked into the distribution
-FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-olit_d.o \
-	    `pwd`/clim-motif.o `pwd`/clim-olit.o \
+# `pwd`/clim-olit_d.o \ `pwd`/clim-olit.o \
+
+FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-motif.o \
 	    `pwd`/stub-xt.o `pwd`/stub-x.o \
 	   `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o `pwd`/xtsupport.o
 
@@ -705,7 +714,7 @@ makeclimolfasls	: compile-ol cat-ol
 
 
 install_clim	:
-	cp $(CLIMOBJS) $(CLIMFASLS) $(DEST)
+	cp $(INSTALLED_CLIMOBJS) $(CLIMFASLS) $(DEST)
 
 # Link in the libraries & distribution object files with standard names
 
diff --git a/clim/frames.lisp b/clim/frames.lisp
index f0a30dc8..0a8df2f1 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.44 92/09/30 18:03:45 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.45 92/10/02 15:19:25 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -67,6 +67,9 @@
 (defmethod graft ((frame standard-application-frame))
   (graft (frame-manager frame)))
 
+(defmethod frame-palette ((frame standard-application-frame))
+  (frame-manager-palette (frame-manager frame)))
+
 ;;--- These should really be somewhere else
 (defmethod frame-manager ((stream standard-encapsulating-stream))
   (frame-manager (encapsulating-stream-stream stream)))
diff --git a/demo/address-book.lisp b/demo/address-book.lisp
index 88a71404..9a998117 100644
--- a/demo/address-book.lisp
+++ b/demo/address-book.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: address-book.lisp,v 1.13 92/09/24 09:40:02 cer Exp Locker: cer $
+;; $fiHeader: address-book.lisp,v 1.14 92/09/30 18:04:06 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -44,6 +44,9 @@
   (add-address (make-address :name "John Irwin"
 			     :address "Franz, Inc."
 			     :number "510-548-3600"))
+  (add-address (make-address :name "Colin Meldrum"
+			     :address "Franz, Inc."
+			     :number "510-548-3600"))
   (add-address (make-address :name "Scott McKay"
 			     :address "Symbolics, Inc."
 			     :number "617-221-1000"))
diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp
index fc909bce..f9d356d3 100644
--- a/demo/color-editor.lisp
+++ b/demo/color-editor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: color-editor.lisp,v 1.4 92/10/02 09:22:38 cer Exp $
+;; $fiHeader: color-editor.lisp,v 1.5 92/10/02 15:20:34 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -14,7 +14,7 @@
   (display-color (pane-frame stream) stream))
 
 (define-application-frame color-chooser ()
-    ((color :accessor color :initform (make-rgb-color 0 0 0))
+    (color mutable-p
      red blue green
      intensity hue saturation)
   (:menu-bar nil)
@@ -78,11 +78,30 @@
 	  (vertically () display exit))
 	rgb ihs))))
 
+(defmethod run-frame-top-level :before ((frame color-chooser) &key)
+  (with-slots (mutable-p color) frame
+    (setf color
+      (if (setf mutable-p (palette-color-p (frame-palette frame)))
+	  (make-mutable-color :color +black+)
+	+black+))))
+
+(defmethod color ((frame color-chooser))
+  (with-slots (mutable-p color) frame
+    (if mutable-p
+	(mutable-color-color color)
+      color)))
+
+(defmethod (setf color) (new-color (frame color-chooser))
+  (with-slots (mutable-p color) frame
+    (if mutable-p
+	(mutate-color color new-color)
+      (setf color new-color))))
+
 (defmethod display-color ((frame color-chooser) stream)
   (with-bounding-rectangle* (left top right bottom) (window-viewport stream)
     (with-output-recording-options (stream :record nil)
       (draw-rectangle* stream left top right bottom
-		       :filled t :ink (color frame)))))
+		       :filled t :ink (slot-value frame 'color)))))
 
 (defmacro define-rgb-callbacks (color)
   (check-type color (member red green blue))
@@ -148,7 +167,10 @@
 
 (defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value)
   (declare (ignore id value))
-  (redisplay-frame-pane (pane-frame slider) 'display))
+  (let ((frame (pane-frame slider)))
+    (with-slots (mutable-p) frame
+      (unless mutable-p
+	(redisplay-frame-pane (pane-frame slider) 'display)))))
 
 
 (defvar *color-choosers* nil)
@@ -166,7 +188,7 @@
 		 (push (cons port frame) *color-choosers*))
 	     frame)))
     (run-frame-top-level frame)
-    (color frame)))
+    (slot-value frame 'color)))
 
 (define-demo "Color Chooser" do-color-chooser)
 
diff --git a/demo/demo-activity.lisp b/demo/demo-activity.lisp
index 09f2f078..070ddee2 100644
--- a/demo/demo-activity.lisp
+++ b/demo/demo-activity.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: demo-activity.lisp,v 1.1 92/09/22 19:43:05 cer Exp $
+;; $fiHeader: demo-activity.lisp,v 1.2 92/10/02 15:20:36 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -47,7 +47,12 @@
   (incf *untitled-count*))
 
 (define-demo-app-command (com-select-frame :name t :menu t) 
-    ((frame `((member ,@(frame-manager-frames *activity*)) :name-key ,#'frame-pretty-name)))
+    ((frame `((member ,@(frame-manager-frames *activity*)) 
+	      ;;-- After a frame is deleted it ends not being a member
+	      ;;-- of the presentation type so you get bogus
+	      ;;-- presentations and  the find in the present method
+	      ;;-- returns nil
+	      :name-key ,#'(lambda (x) (and x (frame-pretty-name x))))))
   (select-activity-active-frame *activity* frame))
 
 (define-demo-app-command (com-funky-add :name t :menu t) 
diff --git a/demo/ico.lisp b/demo/ico.lisp
index f99535a3..ca3ec3c5 100644
--- a/demo/ico.lisp
+++ b/demo/ico.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: ico.lisp,v 1.7 92/09/30 18:04:15 cer Exp Locker: cer $
+;; $fiHeader: ico.lisp,v 1.8 92/10/02 15:20:37 cer Exp Locker: cer $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -19,14 +19,24 @@
 ;;;
 ;;; ICO Frames
 ;;;
+(defparameter *background-color* +black+)
+(defparameter *line-color* +white+)
+(defparameter *face1-color* +red+)
+(defparameter *face2-color* +green+)
 
 (define-application-frame ico-frame ()
     ((ico-time-p :initform t)
+     (ico-buffers :initform 1)
+     (ico-color-group2 :initform nil)
+     (ico-color-group3 :initform nil)
+     (inks0 :initform (vector *background-color*))
+     (inks1 :initform (vector *line-color*))
+     (inks2 :initform (vector *face1-color*))
+     (inks3 :initform (vector *face2-color*))
      (ico-line-style :initform :thin)
      (draw-edges :initform t)
      (draw-faces :initform nil)
-     (ico-process :initform nil :accessor ico-process)
-     (ico-color-group :initform nil :accessor ico-color-group))
+     (ico-process :initform nil :accessor ico-process))
   (:command-table (ico-frame :inherit-from (accept-values-pane)))
   (:panes
     (target :application :width 400 :height 400)
@@ -41,24 +51,70 @@
 
 (defmethod display-options-pane ((frame ico-frame) pane &key max-width max-height)
   (declare (ignore max-width max-height))
-  (with-slots (ico-time-p ico-line-style draw-edges draw-faces) frame
-    (formatting-item-list (pane :n-rows 1)
-      (formatting-cell (pane)
-	(setf ico-time-p (accept 'boolean 
-				 :default ico-time-p
-				 :stream pane
-				 :prompt "Time")))
-      (formatting-cell (pane)
-	(let ((x (append (and draw-faces '(:faces))
-			 (and draw-edges '(:edges)))))
-	  (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
-	  (setf draw-edges (and (member :edges x) t)
-		draw-faces (and (member :faces x) t))))
-      (formatting-cell (pane)
-	(setf ico-line-style (accept '(member :thin :thick)
-				     :default ico-line-style
+  (formatting-item-list (pane :n-rows 1)
+      (with-slots (ico-time-p ico-buffers ico-line-style draw-edges draw-faces) frame
+	(formatting-cell (pane)
+	    (setf ico-time-p (accept 'boolean 
+				     :default ico-time-p
 				     :stream pane
-				     :prompt "Line Style"))))))
+				     :prompt "Time")))
+	(formatting-cell (pane)
+	    (let ((x (append (and draw-faces '(:faces))
+			     (and draw-edges '(:edges)))))
+	      (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
+	      (setf draw-edges (and (member :edges x) t)
+		    draw-faces (and (member :faces x) t))))
+	(formatting-cell (pane)
+	    (setf ico-line-style (accept '(member :thin :thick)
+					 :default ico-line-style
+					 :stream pane
+					 :prompt "Line Style")))
+	(formatting-cell (pane)
+	    (multiple-value-bind (buffering ptype changed)
+		(accept '(member :single :double :triple)
+			:default (svref #(:single :double :triple) (1- ico-buffers))
+			:stream pane
+			:prompt "Buffering")
+	      (declare (ignore ptype))
+	      (when changed
+		(with-slots (ico-color-group2 ico-color-group3
+			     inks0 inks1 inks2 inks3) frame    
+		  (case buffering
+		    (:single 
+		     (setf ico-buffers 1
+			   inks0 (vector *background-color*)
+			   inks1 (vector *line-color*)
+			   inks2 (vector *face1-color*)
+			   inks3 (vector *face2-color*)))
+		    (:double
+		     (let ((g (or ico-color-group2
+				  (setf ico-color-group2 (make-color-group 4 4)))))
+		       (setf ico-buffers 2
+			     inks0 (vector (group-color g 0 nil)
+					   (group-color g nil 0))
+			     inks1 (vector (group-color g 1 nil)
+					   (group-color g nil 1))
+			     inks2 (vector (group-color g 2 nil)
+					   (group-color g nil 2))
+			     inks3 (vector (group-color g 3 nil)
+					   (group-color g nil 3)))))
+		    (:triple
+		     (let ((g (or ico-color-group3
+				  (setf ico-color-group3 (make-color-group 4 4 4)))))
+		       (setf ico-buffers 3
+			     inks0 (vector (group-color g 0 nil nil)
+					   (group-color g nil 0 nil)
+					   (group-color g nil nil 0))
+			     inks1 (vector (group-color g 1 nil nil)
+					   (group-color g nil 1 nil)
+					   (group-color g nil nil 1))
+			     inks2 (vector (group-color g 2 nil nil)
+					   (group-color g nil 2 nil)
+					   (group-color g nil nil 2))
+			     inks3 (vector (group-color g 3 nil nil)
+					   (group-color g nil 3 nil)
+					   (group-color g nil nil 3)))))))))))))
+
 
 (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) ()
   (with-application-frame (frame)
@@ -77,8 +133,6 @@
   (catch-ball frame))
 
 (defmethod throw-ball ((frame ico-frame))
-  (unless (ico-color-group frame)
-    (setf (ico-color-group frame) (make-color-group 4 4)))
   (unless (ico-process frame)
     (setf (ico-process frame)
 	  (clim-sys:make-process #'(lambda ()
@@ -123,15 +177,6 @@
 (defun run-ico (frame &optional (count 1000000))
   (let* ((pane  (frame-target frame))
 	 (medium (sheet-medium pane))
-	 (group (ico-color-group frame))
-	 (i0 (vector (group-color group 0 nil) (group-color group nil 0)))
-	 (i1 (vector (group-color group 1 nil) (group-color group nil 1)))
-	 (i2 (vector (group-color group 2 nil) (group-color group nil 2)))
-	 (i3 (vector (group-color group 3 nil) (group-color group nil 3)))
-	 (background-color +black+)
-	 (line-color +white+)
-	 (face1-color +red+)
-	 (face2-color +green+)
 	 (win-w (bounding-rectangle-width pane))
 	 (win-h (bounding-rectangle-height pane))
 	 (ico-x (floor (* (- win-w ico-w) 128) 256))
@@ -148,8 +193,8 @@
     (declare (integer win-w win-h)
 	     (integer ico-x ico-y ico-dx ico-dy xtop ytop prev-x prev-y)
 	     (special prev-x prev-y))
-
-    (with-slots (draw-faces draw-edges) frame
+    (with-slots (draw-faces draw-edges ico-buffers inks0 inks1 inks2 inks3)
+	frame
       (ecase *ico-mode*
 	#+abc
 	(:abc (clear-region medium +everywhere+))
@@ -167,25 +212,23 @@
 	#+genera
 	(:genera
 	  (setq drawable (medium-drawable medium))))
-
       (window-clear pane)
-      (draw-rectangle* medium 0 0 win-w win-h :ink (group-color group 0 0))
       (dotimes (i count)
-	(let* ((buffer (mod i 2)))
+	(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 i0
-								 buffer) :filled t)
-	     	     
-
+	     (draw-rectangle* medium 0 0 win-w win-h :ink (svref inks0 buffer) :filled t)
 	     (when draw-edges
-	       (draw-lines* medium edges :ink (svref i1 buffer)
+	       (draw-lines* medium edges :ink (svref inks1 buffer)
 			    :line-thickness 
 			    (ecase (slot-value frame 'ico-line-style)
 			      (:thick 5)
@@ -197,15 +240,16 @@
 				:closed t
 				:filled t
 				:ink (if (oddp (car f))
-					 (svref i2 buffer)
-				       (svref i3 buffer)))))
-	     (with-delayed-mutations
-	       (mutate-color (svref i0 buffer) background-color)
-	       (mutate-color (svref i1 buffer) line-color)
-	       (mutate-color (svref i2 buffer) face1-color)
-	       (mutate-color (svref i3 buffer) face2-color))
-	     #+ignore
+					 (svref inks2 buffer)
+				       (svref inks3 buffer)))))
+	     (when (> ico-buffers 1)
+	       (with-delayed-mutations
+		 (mutate-color (svref inks0 buffer) *background-color*)
+		 (mutate-color (svref inks1 buffer) *line-color*)
+		 (mutate-color (svref inks2 buffer) *face1-color*)
+		 (mutate-color (svref inks3 buffer) *face2-color*)))
 	     (silica:medium-force-output medium))
+	    
 	    #+xlib-ignore
 	    (:clx 
 	     (setf (xlib:gcontext-foreground gcontext) white)
diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp
index 23a6ddce..3f572156 100644
--- a/demo/puzzle.lisp
+++ b/demo/puzzle.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: puzzle.lisp,v 1.16 92/09/24 09:40:14 cer Exp $
+;; $fiHeader: puzzle.lisp,v 1.17 92/10/02 15:20:47 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
@@ -83,7 +83,6 @@
 			   (cell-id (encode-puzzle-cell row column)))
 		      (updating-output (stream
 					:unique-id cell-id 
-					:cache-text #'equal
 					:cache-value value)
 			  (formatting-cell (stream :align-x :right)
 			      (unless (zerop value)
diff --git a/silica/classes.lisp b/silica/classes.lisp
index 1a3ef297..a018e760 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.20 92/09/30 18:03:12 cer Exp Locker: cer $
+;; $fiHeader: classes.lisp,v 1.21 92/10/02 15:18:05 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -113,6 +113,8 @@
 
 (defclass basic-palette (palette)
   ((port :reader palette-port :initarg :port)
+   (color-p :reader palette-color-p :initarg :color-p)
+   (mutable-p :reader palette-mutable-p :initarg :mutable-p)
    (color-cache :initform (make-hash-table) :reader palette-color-cache)
    (mutable-color-cache :initform (make-hash-table) 
 			:reader palette-mutable-color-cache)
diff --git a/silica/framem.lisp b/silica/framem.lisp
index e980499e..f4eed741 100644
--- a/silica/framem.lisp
+++ b/silica/framem.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: framem.lisp,v 1.18 92/09/30 18:03:14 cer Exp Locker: cer $
+;; $fiHeader: framem.lisp,v 1.19 92/10/02 15:18:20 cer Exp Locker: cer $
 
 (in-package :silica)
 
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 463e86a8..26f2bfb3 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: medium.lisp,v 1.23 92/09/24 09:37:46 cer Exp $
+;; $fiHeader: medium.lisp,v 1.24 92/10/02 15:18:28 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -424,3 +424,32 @@
 (generate-trampolines medium-protocol medium standard-sheet-output-mixin
 		      `(sheet-medium ,standard-sheet-output-mixin))
 
+;;; not clear that these should be here.
+
+(defmethod sheet-palette ((sheet sheet))
+  (let* ((frame (pane-frame sheet))
+	 (framem (and frame (frame-manager frame))))
+    (if framem
+	(frame-manager-palette framem)
+      (port-default-palette (port sheet)))))
+
+(defmethod medium-palette ((medium medium))
+  (sheet-palette (medium-sheet medium)))
+
+;;; especially these - could be with other named-color stuff in
+;;; utils/designs but things like port, sheet, medium aren't known
+;;; there.
+
+(defmethod find-named-color (name (port port))
+  (find-named-color name (port-default-palette port)))
+
+(defmethod find-named-color (name (sheet sheet))
+  (find-named-color name (sheet-palette sheet)))
+
+(defmethod find-named-color (name (medium medium))
+  (find-named-color name (medium-palette medium)))
+
+
+
+
+
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 05b1b6a1..12bf33fa 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.38 92/09/30 18:04:00 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.39 92/10/02 15:20:19 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -685,26 +685,7 @@ people, shall not perish from the earth.
 		    :towards-x x :towards-y 0)))))
 
 (defparameter *named-colors*
- '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+
-   +snow+ +ghost-white+ +white-smoke+ +gainsboro+ +floral-white+ +old-lace+ +linen+
-   +antique-white+ +papaya-whip+ +blanched-almond+ +bisque+ +peach-puff+ +navajo-white+
-   +moccasin+ +cornsilk+ +ivory+ +lemon-chiffon+ +seashell+ +honeydew+ +mint-cream+ +azure+
-   +alice-blue+ +lavender+ +lavender-blush+ +misty-rose+ +dark-slate-gray+ +dim-gray+
-   +slate-gray+ +light-slate-gray+ +gray+ +light-gray+ +midnight-blue+ +navy-blue+
-   +cornflower-blue+ +dark-slate-blue+ +slate-blue+ +medium-slate-blue+ +light-slate-blue+
-   +medium-blue+ +royal-blue+ +dodger-blue+ +deep-sky-blue+ +sky-blue+ +light-sky-blue+
-   +steel-blue+ +light-steel-blue+ +light-blue+ +powder-blue+ +pale-turquoise+ +dark-turquoise+
-   +medium-turquoise+ +turquoise+ +light-cyan+ +cadet-blue+ +medium-aquamarine+ +aquamarine+
-   +dark-green+ +dark-olive-green+ +dark-sea-green+ +sea-green+ +medium-sea-green+
-   +light-sea-green+ +pale-green+ +spring-green+ +lawn-green+ +chartreuse+
-   +medium-spring-green+ +green-yellow+ +lime-green+ +yellow-green+ +forest-green+ +olive-drab+
-   +dark-khaki+ +khaki+ +pale-goldenrod+ +light-goldenrod-yellow+ +light-yellow+ +gold+
-   +light-goldenrod+ +goldenrod+ +dark-goldenrod+ +rosy-brown+ +indian-red+ +saddle-brown+
-   +sienna+ +peru+ +burlywood+ +beige+ +wheat+ +sandy-brown+ +tan+ +chocolate+ +firebrick+
-   +brown+ +dark-salmon+ +salmon+ +light-salmon+ +orange+ +dark-orange+ +coral+ +light-coral+
-   +tomato+ +orange-red+ +hot-pink+ +deep-pink+ +pink+ +light-pink+ +pale-violet-red+ +maroon+
-   +medium-violet-red+ +violet-red+ +violet+ +plum+ +orchid+ +medium-orchid+ +dark-orchid+
-   +dark-violet+ +blue-violet+ +purple+ +medium-purple+ +thistle+))
+    '(+white+ +black+ +red+ +green+ +blue+ +yellow+ +cyan+ +magenta+))
 
 (define-test (colored-inks graphics) (stream)
   "Test colors"
diff --git a/test/test.lisp b/test/test.lisp
index ccd22db5..4fb51483 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: test.lisp,v 1.38 92/09/08 10:35:06 cer Exp $
+;; $fiHeader: test.lisp,v 1.39 92/09/24 09:39:44 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
@@ -34,7 +34,7 @@
       (make-pane 'push-button
         :label "press me"
 	:background +black+
-	:foreground +purple+
+	:foreground +cyan+
 	:text-style (make-text-style :serif :roman 20)))))
 
 
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 4ef5d466..1750431a 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.27 92/09/30 11:45:34 cer Exp Locker: cer $
+;; $fiHeader: ol-gadgets.lisp,v 1.28 92/10/02 15:20:54 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -438,12 +438,23 @@
 (defclass openlook-text-field (text-field xt-leaf-pane)
 	  ())
 
+;;-- Extreme hack alert
+
+(defmethod compose-space ((tf openlook-text-field) &key width height)
+  (declare (ignore width height))
+  (let ((string (gadget-value tf))
+	(font (tk::get-values (sheet-mirror tf) :font)))
+    (if (zerop (length string)) (setq string "fooofofofo"))
+    (make-space-requirement :width (* (length string) (tk::font-width font))
+			    :height (+ 5 (tk::font-height font)))))
+
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-text-field))
   (with-accessors ((value gadget-value)) sheet
     (values 'tk::text-field
 	    (append
+	     `(:chars-visible ,(if (zerop (length value)) 30 (length value)))
 	     (and value `(:string ,value))))))
 
 (defun openlook-text-field-edit-widget (tf &optional (mirror (sheet-direct-mirror tf)))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index d6a7b6e1..f2225f8d 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.42 92/09/30 18:04:28 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.43 92/10/02 15:21:08 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -64,22 +64,29 @@
 
 (defclass xt-palette (basic-palette)
   ((colormap :reader palette-colormap :initarg :colormap)
-   (color-p :initarg :color-p)
+   (xcolor-cache :initform (make-hash-table) :reader palette-xcolor-cache)
+   (named-color-cache :initform (make-hash-table :test #'equalp) 
+		      :reader palette-named-color-cache)
    (white-pixel :initarg :white-pixel)
    (black-pixel :initarg :black-pixel)))
 
-(defmethod make-palette ((port xt-port) &key colormap)
+(defun make-xt-palette (port colormap)
   (let* ((display (port-display port))
 	 (screen (tk::display-screen-number display)))
-    (unless colormap
-      (setq colormap (tk::create-colormap display screen)))
     (make-instance 'xt-palette
 		   :port port
 		   :colormap colormap
+		   :mutable-p (and 
+			       (member (port-visual-class port)
+				       '(:gray-scale :pseudo-color :direct-color))
+			       t)
 		   :color-p (port-color-p port)
 		   :white-pixel (x11:xwhitepixel display screen)
 		   :black-pixel (x11:xblackpixel display screen))))
 
+(defmethod make-palette ((port xt-port) &key)
+  (make-xt-palette port (tk::create-colormap (port-display port))))
+
 #+ignore
 (defmethod (setf frame-manager-palette) :after 
 	   ((palette xt-palette) (framem standard-frame-manager))
@@ -90,25 +97,36 @@
 					   frame)))))
 	(setf (tk::window-colormap window) colormap)))))
 
-(defmethod medium-palette ((medium xt-medium))
-  (frame-manager-palette 
-   (frame-manager (pane-frame (medium-sheet medium)))))
-   
+(defun get-xcolor (color palette)
+  (let ((xcolor-cache (palette-xcolor-cache palette)))
+    (or (gethash color xcolor-cache)
+	(setf (gethash color xcolor-cache)
+	  (multiple-value-bind (red green blue)
+	      (color-rgb color)
+	    (let* ((x #.(1- (ash 1 16))))
+	      (make-instance 'tk::color
+			     :red (truncate (* x red))
+			     :green (truncate (* x green))
+			     :blue (truncate (* x blue)))))))))
+
+(defmethod find-named-color (name (palette xt-palette))
+  (let ((named-color-cache (palette-named-color-cache palette)))
+    (or (gethash name named-color-cache)
+	(setf (gethash name named-color-cache)
+	  (let ((xcolor (tk::lookup-color (palette-colormap palette) name))
+		(x #.(1- (ash 1 16))))
+	    (make-rgb-color (/ (x11:xcolor-red xcolor) x)
+			    (/ (x11:xcolor-green xcolor) x)
+			    (/ (x11:xcolor-blue xcolor) x)))))))
+
 (defmethod update-palette-entry ((palette xt-palette) pixel color)
-  (let ((xcolor (cdr (decode-true-color palette color))))
+  (let ((xcolor (get-xcolor color palette)))
+    (setf (x11:xcolor-pixel xcolor) pixel)
     (with-slots (colormap) palette
       (tk::store-color
        colormap
        xcolor))))
 
-(defmethod update-palette-entry ((palette xt-palette) pixel (color named-color))
-  (with-slots (colormap) palette
-    (tk::store-named-color
-     colormap
-     (named-color-name color)
-     pixel
-     #.(logior x11:dored x11:dogreen x11:doblue))))
-
 (defmethod update-palette-entries ((palette xt-palette) updates)
   (with-slots (colormap) palette
     (let* ((n (ash (length updates) -1))
@@ -117,7 +135,7 @@
       (dotimes (i n)
 	(let ((pixel (aref updates j))
 	      (color (aref updates (1+ j))))
-	  (let ((xcolor (cdr (decode-true-color palette color))))
+	  (let ((xcolor (get-xcolor color palette)))
 	    (declare (ignore ignore))
 	    (setf (x11:xcolor-array-red xcolors i) (x11:xcolor-red xcolor)
 		  (x11:xcolor-array-green xcolors i) (x11:xcolor-green xcolor)
@@ -201,7 +219,6 @@
 			    (tk::object-display drawable))))
 	  (error "drawable and display do not match"))
 	(let* ((display (port-display port))
-	       (screen (tk::display-screen-number display))
 	       (drawable (or drawable
 			     (tk::display-root-window display))))
 	  (unless foreground-gcontext
@@ -388,7 +405,7 @@
 ;;; there otherwise make a gc using decode-color to get the foreground
 ;;; pixel value
 
-;;--- This is really on color, named-color, mutable-color, and group-color.
+;;--- This is really on color, mutable-color, and group-color.
 ;;--- Perhaps there should be a class like basic-color?
 
 (defmethod decode-ink ((ink design) (medium xt-medium))
@@ -519,7 +536,10 @@ and on color servers, unless using white or black")
 
 (defmethod decode-ink ((ink pattern) medium)
   (xt-decode-pattern ink medium))
-    
+
+(defmethod decode-color ((medium xt-medium) (design design))
+  (error "Drawing with design: ~A not yet implemented" design))
+
 (defmethod decode-color ((medium xt-medium) (x (eql +foreground-ink+)))
   (with-slots (foreground-gcontext) medium
     (tk::gcontext-foreground foreground-gcontext)))
@@ -534,30 +554,14 @@ and on color servers, unless using white or black")
       (decode-color stream +background-ink+)))
 
 (defmethod decode-color ((medium xt-medium) (color color))
-  (car (decode-true-color (medium-palette medium) color)))
-
-(defmethod decode-color ((medium xt-medium) (color named-color))
-  (car (decode-true-color (medium-palette medium) color)))
-
-;;; in this context a true-color means a named or and rgb (or equiv
-;;; ihs) color
-
-(defmethod decode-true-color ((palette xt-palette) (color color))
-  (let ((color-cache (palette-color-cache palette)))
+  (let* ((palette (medium-palette medium))
+	 (color-cache (palette-color-cache palette)))
     (or (gethash color color-cache)
 	(setf (gethash color color-cache)
 	  (with-slots (color-p white-pixel black-pixel) palette
 	    (cond (color-p
-		   (multiple-value-bind (red green blue)
-		       (color-rgb color)
-		     (let* ((x #.(1- (ash 1 16)))
-			    (xcolor (make-instance 'tk::color
-						   :red (truncate (* x red))
-						   :green (truncate (* x green))
-						   :blue (truncate (* x blue)))))
-		       (cons (tk::allocate-color
-			      (palette-colormap palette) xcolor)
-			     xcolor))))
+		   (tk::allocate-color
+		    (palette-colormap palette) (get-xcolor color palette)))
 		  ;;-- support gray-scale here
 		  (t
 		   (multiple-value-bind (r g b) (color-rgb color)
@@ -567,16 +571,6 @@ and on color servers, unless using white or black")
 			    white-pixel
 			  black-pixel)))))))))))
 
-(defmethod decode-true-color ((palette xt-palette) (color named-color))
-  (let ((color-cache (palette-color-cache palette)))
-    (or (gethash color color-cache)
-	(setf (gethash color color-cache)
-	   (let* ((colormap (palette-colormap palette))
-		  (xcolor (tk::lookup-color colormap
-					    (named-color-name color))))
-	     (cons (tk::allocate-color colormap xcolor)
-		   xcolor))))))
-
 (defmethod decode-color ((medium xt-medium) (color mutable-color))
   (let* ((palette (medium-palette medium))
 	 (mutable-color-cache (palette-mutable-color-cache palette)))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 9a28038f..21d8ac5b 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.48 92/09/30 18:04:31 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.49 92/10/02 15:21:11 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -107,7 +107,7 @@
 	      (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
 	      (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
 	      (slot-value port 'default-palette) 
-	      (make-palette port :colormap (tk::default-colormap (port-display port))))
+	      (make-xt-palette port (tk::default-colormap (port-display port))))
 	(let* ((screen (x11:xdefaultscreenofdisplay display))
 	       (bs-p (not (zerop (x11::screen-backing-store screen))))
 	       (su-p (not (zerop (x11::screen-save-unders screen))))
@@ -123,7 +123,8 @@
   (and *use-color*
        (> (port-depth port) 2)
        (member (port-visual-class port)
-	       '(:static-color :true-color :pseudo-color :direct-color))))
+	       '(:static-color :true-color :pseudo-color :direct-color))
+       t))
 
 (defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
 			     (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*")
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 0adc335c..a6cc7c1a 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.33 92/09/24 09:37:18 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.34 92/09/30 18:03:07 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -623,3 +623,7 @@
 (defmethod convert-resource-in ((parent t) (typep (eql 'char)) value)
   (cltl1:int-char value))
 
+(defmethod convert-resource-in ((parent t) (typep (eql 'font-struct)) value)
+  (make-instance 'font
+		 :display (widget-display parent)
+		 :foreign-address value))
diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp
index ae7d7766..ef0a6714 100644
--- a/utils/base-designs.lisp
+++ b/utils/base-designs.lisp
@@ -5,7 +5,7 @@
 "Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
 "Portions Copyright (c) 1992 Franz, Inc.  All rights reserved."
 
-;;; $fiHeader$
+;;; $fiHeader: base-designs.lisp,v 1.1 92/09/30 18:02:42 cer Exp $
 
 ;;; Designs
 
@@ -92,19 +92,6 @@
   (with-slots (color) color
     `(make-mutable-color ,color)))
 
-
-;;; Named Colors
-
-(defclass named-color (design)
-  ((name :type string :reader named-color-name :initarg :name)))
-
-(define-constructor make-named-color named-color (name)
-		    :name name)
-
-(defmethod make-load-form ((color named-color))
-  (with-slots (name) color
-    `(make-named-color ,name)))
-
 
 ;;; Color Groups
 
diff --git a/utils/designs.lisp b/utils/designs.lisp
index dd98108a..d454d284 100644
--- a/utils/designs.lisp
+++ b/utils/designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: designs.lisp,v 1.5 92/08/18 17:24:05 cer Exp $
+;; $fiHeader: designs.lisp,v 1.6 92/09/30 18:03:18 cer Exp $
 
 (in-package :clim-utils)
 
@@ -28,66 +28,18 @@
 	((= opacity 1) +everywhere+)
 	(t (make-standard-opacity-1 opacity))))
 
-
-;;; Named Colors
-
-(defmethod print-object ((color named-color) stream)
-  (print-unreadable-object (color stream :type t :identity t)
-    (princ (named-color-name color) stream)))
-
-(defmacro define-named-color (color)
-  (let* ((sym (symbol-name color))
-	 (name (substitute #\space #\-
-			   (string-downcase
-			    (subseq sym 1 (1- (length sym)))))))
-    `(defconstant ,color
-	 (make-named-color ,name))))
-			 
-(defmacro define-named-colors (&rest colors)
-  `(progn
-     ,@(mapcar #'(lambda (color)
-		   `(define-named-color ,color)) colors)))
-
-(define-named-colors
-    +black+ +white+ +red+ +green+ +blue+ +cyan+ +magenta+ +yellow+
-    +snow+ +ghost-white+ +white-smoke+ +gainsboro+ +floral-white+
-    +old-lace+ +linen+ +antique-white+ +papaya-whip+ +blanched-almond+
-    +bisque+ +peach-puff+ +navajo-white+ +moccasin+ +cornsilk+ +ivory+
-    +lemon-chiffon+ +seashell+ +honeydew+ +mint-cream+ +azure+
-    +alice-blue+ +lavender+ +lavender-blush+ +misty-rose+
-    +dark-slate-gray+ +dim-gray+ +slate-gray+ +light-slate-gray+ +gray+
-    +light-gray+ +midnight-blue+ +navy-blue+ +cornflower-blue+
-    +dark-slate-blue+ +slate-blue+ +medium-slate-blue+ +light-slate-blue+
-    +medium-blue+ +royal-blue+ +dodger-blue+ +deep-sky-blue+ +sky-blue+
-    +light-sky-blue+ +steel-blue+ +light-steel-blue+ +light-blue+
-    +powder-blue+ +pale-turquoise+ +dark-turquoise+ +medium-turquoise+
-    +turquoise+ +light-cyan+ +cadet-blue+ +medium-aquamarine+ +aquamarine+
-    +dark-green+ +dark-olive-green+ +dark-sea-green+ +sea-green+
-    +medium-sea-green+ +light-sea-green+ +pale-green+ +spring-green+
-    +lawn-green+ +chartreuse+ +medium-spring-green+ +green-yellow+
-    +lime-green+ +yellow-green+ +forest-green+ +olive-drab+ +dark-khaki+
-    +khaki+ +pale-goldenrod+ +light-goldenrod-yellow+ +light-yellow+
-    +gold+ +light-goldenrod+ +goldenrod+ +dark-goldenrod+ +rosy-brown+
-    +indian-red+ +saddle-brown+ +sienna+ +peru+ +burlywood+ +beige+
-    +wheat+ +sandy-brown+ +tan+ +chocolate+ +firebrick+ +brown+
-    +dark-salmon+ +salmon+ +light-salmon+ +orange+ +dark-orange+ +coral+
-    +light-coral+ +tomato+ +orange-red+ +hot-pink+ +deep-pink+ +pink+
-    +light-pink+ +pale-violet-red+ +maroon+ +medium-violet-red+
-    +violet-red+ +violet+ +plum+ +orchid+ +medium-orchid+ +dark-orchid+
-    +dark-violet+ +blue-violet+ +purple+ +medium-purple+ +thistle+)
-
 
 ;;; Gray colors
 
-(defconstant rgb-black (make-gray-color-1 0f0))
-(defconstant rgb-white (make-gray-color-1 1f0))
+(defconstant +black+ (make-gray-color-1 0f0))
+(defconstant +white+ (make-gray-color-1 1f0))
 
 (defun make-gray-color (luminosity)
   #+Genera (declare lt:(side-effects simple reducible))
   (assert (and (numberp luminosity) (<= 0 luminosity 1)) (luminosity)
     "The luminosity ~S is not a number between 0 and 1" luminosity)
-  (cond ((= luminosity 0) rgb-black)
-	((= luminosity 1) rgb-white)
+  (cond ((= luminosity 0) +black+)
+	((= luminosity 1) +white+)
 	(t (make-gray-color-1 (float luminosity 0f0)))))
 
 (defmethod print-object ((color gray-color) stream)
@@ -121,7 +73,7 @@
 	  "The blue value ~S is not a number between 0 and 1" blue)
   (if (= red green blue)
       (make-gray-color red)
-      (make-rgb-color-1 (float red 0f0) (float green 0f0) (float blue 0f0))))
+    (make-rgb-color-1 (float red 0f0) (float green 0f0) (float blue 0f0))))
 
 (defmethod print-object ((color rgb-color) stream)
   (print-unreadable-object (color stream :type t :identity t)
@@ -162,7 +114,7 @@
 	  "The hue value ~S is not a number between 0 and 1" hue)
   (assert (and (numberp saturation) (<= 0 saturation 1)) (saturation)
 	  "The saturation value ~S is not a number between 0 and 1" saturation)
-  (cond ((= intensity 0) rgb-black)
+  (cond ((= intensity 0) +black+)
 	(t
 	 (make-ihs-color-1 (float intensity 0f0) (float hue 0f0) (float saturation 0f0)))))
 
@@ -191,11 +143,25 @@
   (with-slots (intensity hue saturation) color
     (values intensity hue saturation)))
 
+
+(defmacro define-named-color (color r g b)
+  `(defconstant ,color 
+       (make-rgb-color-1 (float ,r 0f0) (float ,g 0f0) (float ,b 0f0))))
+
+;;; The primary colors
+
+(define-named-color +red+     1 0 0)
+(define-named-color +green+   0 1 0)
+(define-named-color +blue+    0 0 1)
+(define-named-color +cyan+    0 1 1)
+(define-named-color +magenta+ 1 0 1)
+(define-named-color +yellow+  1 1 0)
+
 
 ;;; Mutable Colors 
 
 (defun make-mutable-color (&key (color +black+))
-  (make-mutable-color-1 (ensure-color color)))
+  (make-mutable-color-1 color))
 
 (defmethod print-object ((color mutable-color) stream)
   (print-unreadable-object (color stream :type t :identity t)
@@ -203,32 +169,24 @@
 
 (defvar *doing-delayed-mutations* nil)
 
-(defun mutate-mutable (mutable color)
+(defmethod mutate-mutable ((mutable mutable-color) (color color))
   (if *doing-delayed-mutations*
       (dolist (palette (mutable-color-palettes mutable))
-	(let ((cell (gethash mutable (palette-mutable-color-cache palette)))
-	      (mutations (palette-delayed-mutations palette)))
-	  (vector-push-extend cell mutations)
-	  (vector-push-extend color mutations)))
+	(let ((cell (gethash mutable (silica:palette-mutable-color-cache palette)))
+	      (mutations (silica:palette-delayed-mutations palette)))
+	  (excl:without-interrupts
+	    (vector-push-extend cell mutations)
+	    (vector-push-extend color mutations))))
     (dolist (palette (mutable-color-palettes mutable))
-      (let ((cell (gethash mutable (palette-mutable-color-cache palette))))
+      (let ((cell (gethash mutable (silica:palette-mutable-color-cache palette))))
 	(update-palette-entry palette cell color)))))
 
-(defun ensure-color (color)
-  (assert (or (typep color 'color)
-	      (typep color 'named-color))
-      (color)
-    "~S is not of type ~S or ~S" color 'color 'named-color)
-  color)
-
-(defmethod (setf mutable-color-color) :before (color (mutable mutable-color))
-  (let ((color (ensure-color color)))
-    (mutate-mutable mutable color)))
+(defmethod (setf mutable-color-color) :after ((color color) (mutable mutable-color))
+  (mutate-mutable mutable color))
 
-(defmethod mutate-color ((mutable mutable-color) color)
-  (let ((color (ensure-color color)))
-    (setf (slot-value mutable 'color) color)
-    (mutate-mutable mutable color)))
+(defmethod mutate-color ((mutable mutable-color) (color color))
+  (setf (slot-value mutable 'color) color)
+  (mutate-mutable mutable color))
 
 ;;; note that the actual color mutation occurs on exiting the outermost
 ;;; with-delayed-mutations
@@ -243,8 +201,8 @@
 	   ,@body
 	 (progn
 	   (unless ,outer-doing-delayed-mutations
-	     (dolist (,palette *all-palettes*)
-	       (let ((,mutations (palette-delayed-mutations ,palette)))
+	     (dolist (,palette silica:*all-palettes*)
+	       (let ((,mutations (silica:palette-delayed-mutations ,palette)))
 		 (update-palette-entries ,palette ,mutations)
 		 (setf (fill-pointer ,mutations) 0)))))))))
 
@@ -264,11 +222,10 @@
 	(setf (gethash layers cache)
 	  (make-group-color color-group layers)))))
 
-(defmethod mutate-color ((group-color group-color) color)
-  (let ((color (ensure-color color)))
-    (with-delayed-mutations
-	(dolist (mutable (group-color-mutables group-color))
-	  (mutate-mutable mutable color)))))
+(defmethod mutate-color ((group-color group-color) (color color))
+  (with-delayed-mutations
+      (dolist (mutable (group-color-mutables group-color))
+	(mutate-mutable mutable color))))
 
 ;;; group-color-mutables should not be exported to the user. It is important
 ;;; that these mutables are not drawn with. Instead the fully specified group
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 50645a3f..5228d3db 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.31 92/09/30 18:03:24 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.32 92/10/02 15:18:52 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2028,60 +2028,36 @@
     contrasting-inks-limit
     design
     designp
+    find-named-color
+    group-color
+    make-color-group
     make-contrasting-inks
     make-flipping-ink
     make-gray-color
     make-ihs-color
+    make-mutable-color
     make-opacity
     make-rgb-color
+    mutable-color-color
+    mutate-color
     opacity
     opacity-value
     opacityp
+    with-delayed-mutations
+
+    ;; Palettes
     
-    
-    named-color
-    make-named-color
-    named-color-name
-   
     palette
-    *all-palettes*
-    basic-palette
+    palette-color-p
+    palette-mutable-p
+    palettep
     make-palette
-    default-palette
     port-default-palette
-    palette-color-cache
-    palette-mutable-color-cache
-    palette-color-group-cache
-    palette-delayed-mutations
-    color-cache
-    mutable-color-cache
-    color-group-cache
-    update-palette-entry
-    update-palette-entries
     medium-palette
+    sheet-palette
+    frame-palette
     frame-manager-palette
     
-    mutable-color
-    make-mutable-color
-    mutable-color-color
-    mutable-color-palettes
-    mutate-color
-    with-delayed-mutations
-    *doing-delayed-mutations*
-    
-    color-group
-    color-group-layers
-    color-group-cache
-    color-group-mutable-array
-
-    map-over-group-colors
-    group-color
-    group-color-group
-    group-color-layers
-    make-color-group
-    make-group-color
-    mutables
-    
     ;; Designs
     compose-in
     compose-out
@@ -3395,6 +3371,9 @@
     radians->degrees
 
     ;; From DESIGNS
+    color-group
+    color-group-layers
+    color-group-mutable-array
     color-luminosity
     composite-in
     composite-out
@@ -3409,16 +3388,23 @@
     flipping-ink
     gray-color
     gray-color-luminosity
+    group-color-group
+    group-color-layers
     ihs-color
     make-color-for-contrasting-ink
     make-design-from-output-record
     make-flipping-ink
     make-gray-color-for-contrasting-ink
+    map-over-group-colors    
+    mutable-color
+    mutable-color-palettes
     pattern
     rectangular-tile
     rgb-color
     stencil
-    stencil-array))
+    stencil-array
+    update-palette-entry
+    update-palette-entries))
 
 
 (#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-silica
@@ -3446,6 +3432,7 @@
 
   (:export
     *all-drawing-options*
+    *all-palettes*
     *modifier-keys*
     *null-text-style*
     *pointer-buttons*
@@ -3457,6 +3444,7 @@
     add-sheet-callbacks
     all-drawing-options-lambda-list
     allocate-event
+    basic-palette
     basic-pixmap-medium
     bury-mirror
     canvas
@@ -3470,6 +3458,7 @@
     clear-space-requirement-caches-in-tree
     click-event
     client-overridability-mixin
+    color-p
     compute-gadget-label-size
     compute-list-pane-selected-items
     compute-menu-bar-pane
@@ -3478,6 +3467,7 @@
     compute-text-y-adjustment
     copy-event
     deallocate-event
+    default-palette
     default-space-requirements
     define-character-face
     define-character-face-added-mappings
@@ -3560,11 +3550,16 @@
     mirror-visible-p
     mirrored-sheet-mixin
     modifier-keysym
+    mutable-p
     mute-repainting-mixin
     non-drawing-option-keywords
     note-layout-mixin-region-changed
     one-of-pane
     option-pane
+    palette-color-cache
+    palette-mutable-color-cache
+    palette-color-group-cache
+    palette-delayed-mutations
     parse-gesture-spec
     pixmap
     pixmap-from-menu-item
-- 
GitLab