diff --git a/cloe/cloe-port.lisp b/cloe/cloe-port.lisp
index 92c7a74c57c80c2a9291bd5124f13dae67c6bf8d..1ef9829818bd5749fd5e5e8e33fa419c67e24a7c 100644
--- a/cloe/cloe-port.lisp
+++ b/cloe/cloe-port.lisp
@@ -1,18 +1,111 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cloe-port.lisp,v 1.1 92/10/01 10:03:56 cer Exp $
+;; $fiHeader: cloe-port.lisp,v 1.2 92/10/28 11:32:31 cer Exp $
 
 (in-package :cloe-clim)
 
 "Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
 
 
+(defparameter *vk->keysym*
+	      `(
+		;; The semi-standard characters
+		(#x0d #\newline :enter :newline #\return :return)
+		(#x20 #\space :space)
+		(#x09 #\tab :tab)
+		(#x2e :delete)
+		(#x08 #\backspace :backspace :rubout)
+		;;(???? :page)
+		;;(???? :linefeed)
+		(#x1b #\escape :escape :abort)
+		;; The shifts
+		(#x10 :left-shift)
+		(#x11 :left-control)
+		(#x14 :caps-lock)
+		(#x12 :left-meta)
+		(#x90 :num-lock)
+		;; Non-standard keys
+		(#x03 :cancel)
+		(#x0c :clear :clear-input)
+		(#x13 :pause)
+		(#x21 :page-up)
+		(#x22 :page-down :scroll)
+		(#x23 :end)
+		(#x24 :home)
+		(#x25 :left)
+		(#x26 :up)
+		(#x27 :right)
+		(#x28 :down)
+		(#x29 :select)
+		(#x2b :execute)
+		(#x2c :print-screen)
+		(#x2d :insert)
+		(#x2f :help)
+		(#x60 :keypad-0)
+		(#x61 :keypad-1)
+		(#x62 :keypad-2)
+		(#x63 :keypad-3)
+		(#x64 :keypad-4)
+		(#x65 :keypad-5)
+		(#x66 :keypad-6)
+		(#x67 :keypad-7)
+		(#x68 :keypad-8)
+		(#x69 :keypad-9)
+		(#x6a :keypad-multiply)
+		(#x6b :keypad-add)
+		(#x6c :keypad-separator)
+		(#x6d :keypad-subtract)
+		(#x6e :keypad-decimal)
+		(#x6f :keypad-divide)
+		(#x70 :f1)
+		(#x71 :f2)
+		(#x72 :f3)
+		(#x73 :f4)
+		(#x74 :f5)
+		(#x75 :f6)
+		(#x76 :f7)
+		(#x77 :f8)
+		(#x78 :f9)
+		(#x79 :f10)
+		(#x7a :f11)
+		(#x7b :f12)
+		(#x7c :f13)
+		(#x7d :f14)
+		(#x7e :f15)
+		(#x7f :f16)
+		(#x80 :f17)
+		(#x81 :f18)
+		(#x82 :f19)
+		(#x83 :f20)
+		(#x84 :f21)
+		(#x85 :f22)
+		(#x86 :f23)
+		(#x87 :f24)
+		(#x91 :scroll-lock)
+		;;(???? :complete)
+		;;(???? :refresh)
+		))
+
+(defparameter *char->keysym*
+	      (let ((array (make-array 256 :initial-element nil)))
+		(dolist (char '(#\newline #\escape #\backspace #\tab #\space #\return))
+		  (setf (svref array (char-code char))
+			(intern (string-upcase (char-name char)) "KEYWORD")))
+		(loop for code from (char-code #\!) to (char-code #\~)
+		      do (setf (svref array code)
+			       (intern (string (char-upcase (code-char code))) "KEYWORD")))
+		array))
+
+
+
 (defvar *cloe-port* nil)
 
 (defclass cloe-port (basic-port)
     ((text-style->cloe-font-mapping :initform (make-hash-table))
      (font-cache-style :initform nil)
      (font-cache-font :initform nil)
+     (vk->keysym :initform (make-hash-table))
+     (keysym->keysym :initform (make-hash-table))
      logpixelsy
      (event-queue :initform (make-queue))
      (pointer-sheet :initform nil)
@@ -29,11 +122,11 @@
 ;;--- Eventually do better than this
 (defclass cloe-palette (basic-palette) ())
 
-(defmethod make-palette ((port cloe-port) &key color-p mutable-p)
+(defmethod make-palette ((port cloe-port) &key color-p dynamic-p)
   (make-instance 'cloe-palette
     :port port 
     :color-p color-p
-    :mutable-p mutable-p))
+    :dynamic-p dynamic-p))
 
 
 (defmethod initialize-instance :before ((port cloe-port) &key)
@@ -42,12 +135,22 @@
   (setf *cloe-port* port))
 
 (defmethod initialize-instance :after ((port cloe-port) &key)
-  (initialize-dc)
-  (setf (slot-value port 'logpixelsy) (win::get-device-caps *dc* 90))
-  (setf (slot-value port 'silica::default-palette) 
-	(make-palette port :color-p t))
+  (with-slots (logpixelsy silica::default-palette vk->keysym) port
+    (initialize-dc)
+    (setf logpixelsy (win::get-device-caps *dc* win::logpixelsy))
+    (setf silica::default-palette (make-palette port :color-p t))
+    (loop for (vk . keysym) in *vk->keysym* do
+      (setf (gethash vk vk->keysym) keysym))
+    (loop for code from (char-code #\!) to (char-code #\~)
+	  for char = (code-char code)
+	  do (push char (gethash (win::get-keymap char) vk->keysym)))
+    )
   nil)
 
+(defmethod destroy-port :before ((port cloe-port))
+  (when (eq port *cloe-port*)
+    (setf *cloe-port* nil)))
+
 
 
 (defstruct (cloe-font)
@@ -73,23 +176,6 @@
   family
   font-width-table)
 
-;;; Fill up the font width table for a variable width font
-;;; by asking windows the width of each character.
-;;; This doesn't quite work in the face of kerning.
-(defun initialize-font-width-table (font window)
-  ;; only need to run this on variable-width fonts.
-  (select-font (cloe-font-index font))
-  (let ((array (make-array (1+ (- 126 32)))))
-    (with-temporary-string (string :length 1)
-      (setf (fill-pointer string) 1)
-      (loop for i from 32 to 126 do
-	(setf (aref string 0) (code-char i))
-	(multiple-value-bind (width height)
-	    (win::get-text-extent window string)
-	  (declare (ignore height ))
-	  (setf (aref array (- i 32)) width))))
-    (setf (cloe-font-font-width-table font) array)))
-
 (defparameter *cloe-logical-size-alist*
 	      '((:tiny       6)
 		(:very-small 7)
@@ -251,64 +337,232 @@
 
 
 
-#||
-(defvar *vk->keysym* (make-array 256 :initial-element nil))
-(defvar *keysym->vk* (make-hash-table))
-
-(defmacro define-vk (vk keysym)
-  `(progn 
-     (setf (svref *vk->keysym* vk) keysym)
-     (setf (gethash ,keysym *keysym->vk*) ,vk)))
-
-(defun-inline vk->keysym (vk)
-  (svref *vk->keysym* vk))
-
-(defun-inline keysym->vk (keysym)
-  (gethash keysym *keysym->vk*))
-
-;; The semi-standard characters
-(define-vk 0x0d :return)
-(define-vk ???? :newline)
-(define-vk 0x09 :tab)
-(define-vk 0x2e :rubout)
-(define-vk 0x08 :backspace)
-(define-vk ???? :page)
-(define-vk ???? :linefeed)
-(define-vk 0x1b :escape)
-
-;; Other useful characters
-(define-vk 0x23 :end)
-(define-vk ???? :abort)
-(define-vk 0x2f :help)
-(define-vk ???? :complete)
-(define-vk 0x22 :scroll)
-(define-vk ???? :refresh)
-(define-vk ???? :clear-input)
-
-;; Finally, the shifts
-(define-vk 0x19 :left-shift)
-(define-vk ???? :right-shift)
-(define-vk 0x11 :left-control)
-(define-vk ???? :right-control)
-(define-vk 0x14 :caps-lock)
-(define-vk ???? :shift-lock)
-(define-vk 0x12 :left-meta)
-(define-vk ???? :right-meta)
-(define-vk ???? :left-super)
-(define-vk ???? :right-super)
-(define-vk ???? :left-hyper)
-(define-vk ???? :right-hyper)
-
-;; Non-standard keys found on Sun keyboards
-
-(define-vk 0x70 :f1)
-(define-vk 0x71 :f2)
-(define-vk 0x72 :f3)
-(define-vk 0x73 :f4)
-(define-vk 0x74 :f5)
-(define-vk 0x75 :f6)
-(define-vk 0x76 :f7)
-(define-vk 0x77 :f8)
-(define-vk 0x78 :f9)
-(define-vk 0x79 :f10)
-||#
+(defmethod port-canonicalize-gesture-spec 
+	   ((port cloe-port) gesture-spec &optional modifier-state)
+  (with-slots (vk->keysym) port
+    (multiple-value-bind (keysym shifts)
+	(if modifier-state
+	    (values gesture-spec modifier-state)
+	    (parse-gesture-spec gesture-spec))
+      (let ((char (typecase keysym
+		    (symbol
+		      (let ((code (position keysym *char->keysym*)))
+			(and code
+			     (code-char code))))
+		    (character
+		      (shiftf keysym (svref *char->keysym* (char-code keysym)))))))
+	(loop for keysyms being the hash-values of vk->keysym using (hash-key vk)
+	      when (member (or char keysym) keysyms)
+		do (setf keysym (first keysyms))
+	           (when (characterp keysym)
+		     (setf keysym (svref *char->keysym* (char-code keysym))))
+		   (when (logtest #x100 vk)
+		     (setf shifts (logior shifts +shift-key+)))
+		   (return))
+	(cons keysym shifts)))))
+
+
+
+(defun-inline sign-extend-16 (n)
+  (dpb n (byte 15 0) (- (ldb (byte 1 15) n))))
+
+(defmethod note-pointer-motion ((port cloe-port) sheet x y)
+  (with-slots (pointer-sheet pointer-x pointer-y) port
+    (setf pointer-sheet sheet)
+    (setf pointer-x x)
+    (setf pointer-y y)))
+
+(defmethod flush-pointer-motion ((port cloe-port))
+  (with-slots (event-queue pointer-sheet pointer-x pointer-y) port
+    (when pointer-sheet
+      (let ((pointer (port-pointer port)))
+	(when pointer
+	  (queue-put event-queue
+		     (allocate-event 'pointer-motion-event
+		       :native-x pointer-x
+		       :native-y pointer-y
+		       :modifier-state (port-modifier-state port)
+		       :pointer pointer
+		       :sheet pointer-sheet))))
+      (setf pointer-sheet nil))))
+
+;;; Convert a MS Windows shift mask into a CLIM modifier-state
+(defun windows-mask->modifier-state (mask)
+  (if (logtest win::mk_shift mask)
+      (if (logtest win::mk_control mask)
+	  (make-modifier-state :shift :control)
+	  (make-modifier-state :shift))
+      (if (logtest win::mk_control mask)
+	  (make-modifier-state :control)
+	  (make-modifier-state))))
+
+(defmethod event-handler ((port cloe-port) args)
+  (with-slots (event-queue pointer-sheet pointer-x pointer-y vk->keysym) port
+    (let ((sheet (mirror->sheet port (win::get-16bit args 0)))
+	  (message (win::get-16bit args 2)))
+      (declare (fixnum message))
+      (when sheet
+	(cond ((eql message win::wm_mousemove)
+	       (note-pointer-motion port sheet (win::get-16bit args 6) (win::get-16bit args 8)))
+
+	      ((eql message win::wm_paint)
+	       (let ((ileft (win::get-16bit args 4))
+		     (itop (win::get-16bit args 6))
+		     (iright (win::get-16bit args 8))
+		     (ibottom (win::get-16bit args 10)))
+		 (unless (or (= ileft iright) (= itop ibottom))	;seems to happen alot
+		   (queue-put event-queue
+			      (allocate-event 'window-repaint-event
+				;;--- Should this be (MIRROR-REGION PORT SHEET), as
+				;;--- it is in the :CONFIGURE-NOTIFY case?
+				:native-region (sheet-native-region sheet)
+				:region (make-bounding-rectangle ileft itop iright ibottom)
+				:sheet sheet)))))
+
+	      #||
+	      ;; scrolling
+	      ((or (eql message win::wm_hscroll)
+		   (eql message win::wm_vscroll))
+	       (let ((type (win::get-16bit args 4))
+		     (position (win::get-16bit args 6))
+		     (message (cond ((eql message win::wm_hscroll) :x)
+				    ((eql message win::wm_vscroll) :y))))
+		 (declare (fixnum type position))
+		 (multiple-value-bind (type position)
+		     (cond ((eql type win::sb_lineup)
+			    (values :relative-jump -1))
+			   ((eql type win::sb_linedown)
+			    (values :relative-jump +1))
+			   ((eql type win::sb_pageup)
+			    (values :screenful -1))
+			   ((eql type win::sb_pagedown)
+			    (values :screenful +1))
+			   ((eql type win::sb_thumbposition)
+			    (values :percentage position))
+			   ((eql type win::sb_top)
+			    (values :percentage 0))
+			   ((eql type win::sb_bottom)
+			    (values :percentage 100)))
+		   (when type
+		     (queue-put pending-scrolls (list message type position))
+		     (pushnew stream *cloe-windows-with-deferred-events*)))))
+	      ||#
+
+	      ;; resizing
+	      ((or (eql message win::wm_move)
+		   (eql message win::wm_size))
+	       (queue-put event-queue
+			  (allocate-event 'window-configuration-event
+			    :sheet sheet)))
+
+	      ;; character typed
+	      ((or (eql message win::wm_keydown)
+		   (eql message win::wm_syskeydown)
+		   (eql message win::wm_keyup)
+		   (eql message win::wm_syskeyup))
+	       (flush-pointer-motion port)
+	       (let ((code (win::get-16bit args 4)))
+		 (let ((vk (ldb (byte 8 0) code)))
+		   ;; CAPS LOCK
+		   (when (and (logtest #x0800 code)
+			      (<= #x41 vk #x5a))
+		     (setf code (logior #x100 code)))
+		   ;; NUM LOCK
+		   (when (and (logtest #x1000 code)
+			      (<= #x60 vk #x69))
+		     (setf code (logior #x100 code))))
+		 (let ((keysym (or (gethash (ldb (byte 9 0) code) vk->keysym)
+				   (gethash (ldb (byte 8 0) code) vk->keysym)))
+		       (char nil))
+		   (when (consp keysym)
+		     (setf keysym (first keysym)))
+		   (when (characterp keysym)
+		     (when (zerop (ldb (byte 2 9) code))
+		       (setf char keysym))
+		     (setf keysym (svref *char->keysym* (char-code keysym))))
+		   (queue-put event-queue
+			      (allocate-event 
+				(cond ((or (eql message win::wm_keydown)
+					   (eql message win::wm_syskeydown))
+				       'key-press-event)
+				      ((or (eql message win::wm_keyup)
+					   (eql message win::wm_syskeyup))
+				       'key-release-event))
+				:key-name keysym
+				:character char
+				:modifier-state (setf (port-modifier-state port)
+						      (ldb (byte 3 8) code))
+				:sheet sheet)))))
+
+	      ;; button press or release
+	      ((or (eql message win::wm_lbuttondown)
+		   (eql message win::wm_rbuttondown)
+		   (eql message win::wm_mbuttondown)
+		   (eql message win::wm_lbuttonup)
+		   (eql message win::wm_rbuttonup)
+		   (eql message win::wm_mbuttonup))
+	       (let ((modifier-state (windows-mask->modifier-state (win::get-16bit args 4)))
+		     (pointer (port-pointer port)))
+		 (when pointer
+		   (flush-pointer-motion port)
+		   (setf (port-modifier-state port) modifier-state)
+		   (multiple-value-bind (key button)
+		       (cond ((eql message win::wm_lbuttondown)
+			      (values 'pointer-button-press-event +pointer-left-button+))
+			     ((eql message win::wm_mbuttondown)
+			      (values 'pointer-button-press-event +pointer-middle-button+))
+			     ((eql message win::wm_rbuttondown)
+			      (values 'pointer-button-press-event +pointer-right-button+))
+			     ((eql message win::wm_lbuttonup)
+			      (values 'pointer-button-release-event +pointer-left-button+))
+			     ((eql message win::wm_mbuttonup)
+			      (values 'pointer-button-release-event +pointer-middle-button+))
+			     ((eql message win::wm_rbuttonup)
+			      (values 'pointer-button-release-event +pointer-right-button+)))
+		     (queue-put event-queue
+				(allocate-event key
+				  :native-x (win::get-16bit args 6)
+				  :native-y (win::get-16bit args 8)
+				  :button button
+				  :modifier-state modifier-state
+				  :pointer pointer
+				  :sheet sheet))))))
+	      )))))
+
+(defun win::vanilla-event (code length args)
+  (declare (ignore code length))		;because I don't know what they are!
+  (event-handler *cloe-port* args))
+
+;;;
+
+(defmethod process-next-event ((port cloe-port)
+			       &key (timeout nil) (wait-function nil)
+			       (state "Windows Event"))
+  (declare (ignore state))
+  (with-slots (event-queue) port
+    (let ((end-time (and timeout (+ (get-internal-real-time)
+				    (* internal-time-units-per-second timeout)))))
+      (win::await-response -1 nil nil)
+      (loop
+	(flush-pointer-motion port)
+	(let ((event (queue-get event-queue)))
+	  (when event
+	    (distribute-event port event)
+	    (return t)))
+	(when (and wait-function
+		   (funcall wait-function))
+	  (return nil))
+	(when (and end-time (>= (get-internal-real-time) end-time))
+	  (return nil))
+	(win::await-response -1 t t)))))
+
+(defmethod distribute-event :around ((port cloe-port) (event window-configuration-event))
+  (let* ((sheet (event-sheet event))
+	 (mirror (sheet-mirror sheet)))
+    (unless (win::is-iconic mirror)
+      (let ((native-region (mirror-region port sheet)))
+	(setf (slot-value event 'pyrex::native-region) native-region)
+	(setf (slot-value event 'pyrex::region)
+	      (untransform-region (sheet-native-transformation sheet) 
+				  native-region)))
+      (call-next-method))))
diff --git a/compatibility/clim1-compatibility.lisp b/compatibility/clim1-compatibility.lisp
index 8272c4889518ab7be8d0c65971c56dac892a342c..966266083e02c826f1dd50dfda3e65c252f363f7 100644
--- a/compatibility/clim1-compatibility.lisp
+++ b/compatibility/clim1-compatibility.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes; Patch-File: Yes -*-
 
-;; $fiHeader: clim1-compatibility.lisp,v 1.3 92/09/24 09:40:43 cer Exp $
+;; $fiHeader: clim1-compatibility.lisp,v 1.4 92/10/02 15:21:25 cer Exp $
 
 (in-package :clim-internals)
 
@@ -904,14 +904,14 @@
     (cons   (setq view (apply #'make-instance view))))
   (setq view (decode-indirect-view type view (frame-manager stream)))
 
-  ;; Call methods to do the work
+  ;; Call STREAM-ACCEPT to do the work.  It would be nice if we could
+  ;; call PROMPT-FOR-ACCEPT to generate the real query-id here, but we
+  ;; can't because we want to be able to decide exactly how it is called
+  ;; on a case-by-case basis.  For example, within ACCEPTING-VALUES...
   (with-keywords-removed (accept-args accept-args '(:stream :view))
-    (let ((query-identifier
-	    (apply #'prompt-for-accept
-		   (or *original-stream* stream) type view accept-args)))
-      (apply #'stream-accept (or *original-stream* stream) type
-			     :view view :query-identifier query-identifier
-			     accept-args))))
+    (apply #'stream-accept (encapsulated-stream stream) type
+			   :view view :query-identifier query-identifier
+			   accept-args)))
 
 (define-compiler-macro accept 
 		       (&whole form
@@ -1571,20 +1571,21 @@
 
 
 (defgeneric menu-choose (items &rest keys
-			 &key associated-window default-item default-style
+			 &key associated-window text-style default-item
 			      label printer presentation-type
 			      cache unique-id id-test cache-value cache-test
 			      max-width max-height n-rows n-columns
 			      x-spacing y-spacing
 			      cell-align-x cell-align-y
 			      pointer-documentation
+			      #+CLIM-1-compatibility default-style
 			      #+CLIM-1-compatibility inter-row-spacing
 			      #+CLIM-1-compatibility inter-column-spacing))
 
 ;; Are these reasonable defaults for UNIQUE-ID, CACHE-VALUE, ID-TEST, and CACHE-TEST?
 (defmethod menu-choose ((items t) &rest keys
 			&key (associated-window (frame-top-level-sheet *application-frame*))
-			     default-item default-style
+			     text-style default-item
 			     label printer presentation-type
 			     (cache nil) (unique-id items) (id-test #'equal)
 			     (cache-value items) (cache-test #'equal)
@@ -1592,15 +1593,17 @@
 			     x-spacing y-spacing 
 			     (cell-align-x ':left) (cell-align-y ':top)
 			     pointer-documentation
+			     #+CLIM-1-compatibility default-style
 			     #+CLIM-1-compatibility inter-row-spacing
 			     #+CLIM-1-compatibility inter-column-spacing)
   (declare (values value chosen-item gesture))
   (declare (ignore associated-window
-		   default-item default-style
+		   text-style default-item
 		   label printer presentation-type
 		   cache unique-id id-test cache-value cache-test
 		   max-width max-height n-rows n-columns
 		   x-spacing y-spacing cell-align-x cell-align-y
+		   #+CLIM-1-compatibility default-style
 		   #+CLIM-1-compatibility inter-row-spacing
 		   #+CLIM-1-compatibility inter-column-spacing
 		   pointer-documentation))
@@ -1639,7 +1642,7 @@
 	   ((framem standard-frame-manager) items &rest keys
 	    &key (associated-window
 		   (frame-top-level-sheet *application-frame*))
-		 default-item default-style
+		 text-style default-item
 		 label printer presentation-type
 		 (cache nil) (unique-id items) (id-test #'equal)
 		 (cache-value items) (cache-test #'equal)
@@ -1647,11 +1650,15 @@
 		 x-spacing y-spacing 
 		 (cell-align-x ':left) (cell-align-y ':top)
 		 pointer-documentation
+		 #+CLIM-1-compatibility default-style
 		 #+CLIM-1-compatibility inter-row-spacing
 		 #+CLIM-1-compatibility inter-column-spacing)
   (declare (values value chosen-item gesture))
   (declare (ignore keys))
   #+CLIM-1-compatibility
+  (when default-style
+    (setq text-style default-style))
+  #+CLIM-1-compatibility
   (when (or inter-row-spacing inter-column-spacing)
     (setq x-spacing inter-column-spacing
 	  y-spacing inter-row-spacing))
@@ -1664,10 +1671,9 @@
 	  ;; Lucid production compiler tries to use an undefined internal
 	  ;; variable if this LET isn't done.
 	  #+Lucid (items items))
-      (with-menu (menu associated-window)
-	(setf (window-label menu) label)
+      (with-menu (menu associated-window :label label)
 	(reset-frame (pane-frame menu) :title label)
-	(with-text-style (menu default-style)
+	(with-text-style (menu text-style)
 	  (with-end-of-line-action (menu :allow)
 	    (loop
 	      (multiple-value-bind (item gesture)
@@ -1700,7 +1706,7 @@
 (defun hierarchical-menu-choose (items
 				 &key (associated-window
 					(frame-top-level-sheet *application-frame*))
-				      default-item default-style
+				      text-style default-item
 				      label printer presentation-type
 				      x-position y-position
 				      (cache nil)
@@ -1709,10 +1715,14 @@
 				      max-width max-height n-rows n-columns
 				      x-spacing y-spacing 
 				      (cell-align-x ':left) (cell-align-y ':top)
+				      #+CLIM-1-compatibility default-style
 				      #+CLIM-1-compatibility inter-row-spacing
 				      #+CLIM-1-compatibility inter-column-spacing)
   (declare (values value chosen-item gesture))
   #+CLIM-1-compatibility
+  (when default-style
+    (setq text-style default-style))
+  #+CLIM-1-compatibility
   (when (or inter-row-spacing inter-column-spacing)
     (setq x-spacing inter-column-spacing
 	  y-spacing inter-row-spacing))
@@ -1722,9 +1732,8 @@
     (let ((item-printer (cond (presentation-type #'present-item)
 			      (printer printer)
 			      (t #'print-menu-item))))
-      (with-menu (menu associated-window)
-	(setf (window-label menu) label)
-	(with-text-style (menu default-style)
+      (with-menu (menu associated-window :label label)
+	(with-text-style (menu text-style)
 	  (multiple-value-bind (item gesture)
 	      (flet ((menu-choose-body (stream presentation-type)
 		       (draw-standard-menu stream presentation-type items default-item
@@ -1749,7 +1758,7 @@
 		     (hierarchical-menu-choose
 		       (menu-item-items item)
 		       :associated-window associated-window
-		       :default-style default-style
+		       :text-style text-style
 		       :x-position mr :y-position mt
 		       :cache cache
 		       :unique-id unique-id :id-test id-test
@@ -1865,11 +1874,12 @@
 
 (defmacro define-static-menu (name root-window items
 			      &rest keys
-			      &key default-item default-style
+			      &key text-style default-item 
 				   printer presentation-type
 				   max-width max-height n-rows n-columns
 				   x-spacing y-spacing 
 				   (cell-align-x ':left) (cell-align-y ':top)
+				   #+CLIM-1-compatibility default-style
 				   #+CLIM-1-compatibility inter-row-spacing
 				   #+CLIM-1-compatibility inter-column-spacing)
   (declare (ignore max-width max-height n-rows n-columns
@@ -1877,10 +1887,11 @@
 		   #+CLIM-1-compatibility inter-row-spacing
 		   #+CLIM-1-compatibility inter-column-spacing))
   (with-keywords-removed (drawer-keys keys
-			  '(:default-item :default-style :printer :presentation-type))
+			  '(:text-style :default-item :printer :presentation-type
+			    #+CLIM-1-compatibility :default-style))
     `(defvar ,name (define-static-menu-1 ',name ,root-window ',items
 					 :default-item ',default-item
-					 :default-style ',default-style
+					 :text-style (or ',default-style ',text-style)
 					 :presentation-type ',presentation-type
 					 :printer ',printer
 					 :drawer-args ,(copy-list drawer-keys)))))
diff --git a/demo/browser.lisp b/demo/browser.lisp
index 6619d9766f9ad984d468b03627a7e367e7724527..af43ecc6b25319700af58cc580130e2f2d05775f 100644
--- a/demo/browser.lisp
+++ b/demo/browser.lisp
@@ -3,7 +3,7 @@
 ;;; Simple extensible browser
 ;;; Scott McKay
 
-;; $fiHeader: browser.lisp,v 1.14 92/10/07 14:43:16 cer Exp Locker: cer $
+;; $fiHeader: browser.lisp,v 1.15 92/10/28 11:32:51 cer Exp $
 
 (in-package :clim-browser)
 
@@ -713,20 +713,20 @@
 ;;; The browser itself
 
 (define-application-frame browser ()
-			  ((graph-type :initform :graphical)
-			   (browser-type :initform nil)
-			   (browser-subtype :initform nil)
-			   (browser-ptype :initform nil)
-			   (browser-options :initform nil)
-			   (node-maker :initform #'false)
-			   (root-node-maker :initform #'false)
-			   (grapher-args :initform nil)
-			   (tree-depth :initform 1)
-			   (merge-duplicate-nodes :initform t)
-			   (root-nodes :initform nil)
-			   (all-nodes :initform nil)
-			   (auto-snapshot :initform t)
-			   (snapshots :initform nil))
+    ((graph-type :initform :graphical)
+     (browser-type :initform nil)
+     (browser-subtype :initform nil)
+     (browser-ptype :initform nil)
+     (browser-options :initform nil)
+     (node-maker :initform #'false)
+     (root-node-maker :initform #'false)
+     (grapher-args :initform nil)
+     (tree-depth :initform 1)
+     (merge-duplicate-nodes :initform t)
+     (root-nodes :initform nil)
+     (all-nodes :initform nil)
+     (auto-snapshot :initform t)
+     (snapshots :initform nil))
   (:command-definer t)
   (:command-table (browser :inherit-from (accept-values-pane)))
   (:panes
@@ -755,7 +755,6 @@
 	   (1/2 interactor) 
 	   (:fill control-panel)))))))
 
-
   
 #+genera (define-genera-application browser :select-key #\Triangle)
 #+genera (zwei:defindentation (define-browser-command 0 3 1 3 2 1))
@@ -1442,4 +1441,3 @@
     (run-frame-top-level frame)))
 
 (define-demo "Graphical Browser" do-browser)
-
diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp
index d082545e4d1cdf74db6aaccc66ae44c99e89210d..5f6066fa751bdad3b68664c8e1e6e2bf4f5cb829 100644
--- a/demo/cad-demo.lisp
+++ b/demo/cad-demo.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cad-demo.lisp,v 1.18 92/10/02 15:20:33 cer Exp $
+;; $fiHeader: cad-demo.lisp,v 1.19 92/10/07 14:43:18 cer Exp $
 
 (in-package :clim-demo)
 
@@ -850,7 +850,7 @@
   (make-drawing *application-frame*)
   (com-refresh))
 
-(define-cad-demo-command (com-exit-CAD-demo :menu "Exit" :keystroke #\X)
+(define-cad-demo-command (com-exit-cad-demo :menu "Exit" :keystroke #\X)
     ()
   (frame-exit *application-frame*))
 
diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp
index 6b5f3c89bae73bb69e4df0227f50cc9391b33863..6c81f9d16b9eff2a87a0ac5615cca2f1e6c540ab 100644
--- a/demo/demo-driver.lisp
+++ b/demo/demo-driver.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: demo-driver.lisp,v 1.16 92/10/28 11:32:55 cer Exp Locker: cer $
+;; $fiHeader: demo-driver.lisp,v 1.17 92/11/05 17:15:49 cer Exp $
 
 (in-package :clim-demo)
 
@@ -41,9 +41,9 @@
 	     (demo-menu-choose (list)
 	       (with-menu (menu (typecase port
 				  (frame-manager (graft port))
-				  (t (find-graft :port port))))
-		 (setf (window-label menu)
-		       '("Clim Demonstrations" :text-style (:fix :bold :normal)))
+				  (t (find-graft :port port)))
+				:label '("Clim Demonstrations"
+					 :text-style (:serif :bold :normal)))
 		 (menu-choose-from-drawer
 		   menu 'demo-menu-item
 		   #'(lambda (stream type)
diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp
index 5b434ba583e8d13717cb051f6ff42f3a23c56107..b51d61263ed0fcd4ff4c3f0332d32027a4cf9889 100644
--- a/demo/graphics-editor.lisp
+++ b/demo/graphics-editor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-editor.lisp,v 1.13 92/10/28 13:17:33 cer Exp $
+;; $fiHeader: graphics-editor.lisp,v 1.14 92/10/29 16:55:29 cer Exp $
 
 (in-package :clim-graphics-editor)
 
@@ -173,12 +173,12 @@
 		       (+ xoff (- left 3)) (+ yoff (- top 3))
 		       (+ xoff right 3) (+ yoff bottom 3)
 		       :ink (make-flipping-ink 
-			     (if (palette-color-p
-				  (frame-palette (pane-frame stream)))
-				 +red+
-			       +foreground-ink+)
-			     +background-ink+)
-		       :line-style (make-line-style :thickness 2) 
+			      (if (palette-color-p
+				    (frame-palette (pane-frame stream)))
+				  +red+
+				  +foreground-ink+)
+			      +background-ink+)
+		       :line-style (make-line-style :thickness 2)
 		       :filled nil))))
 
 (defmethod move-object :after ((object box) x y)
@@ -425,12 +425,12 @@
 	(last-box (slot-value *application-frame* 'last-box))
 	(style (slot-value *application-frame* 'style))
 	(shape (slot-value *application-frame* 'shape))
-	(flipping-ink #+allegro 
-		      (make-flipping-ink (if (palette-color-p
-					      (frame-palette *application-frame*))
-					     +blue+
-					   +foreground-ink+) 
-					 +background-ink+)
+	(flipping-ink #+allegro (make-flipping-ink
+				  (if (palette-color-p
+					(frame-palette *application-frame*))
+				      +blue+
+				      +foreground-ink+) 
+				  +background-ink+)
 		      #-allegro +flipping-ink+))
     ;;--- Zdrava supplies primitives to input basic objects such as
     ;;--- points, lines, rectangles and polygons, circles and ellipses,
diff --git a/demo/ico.lisp b/demo/ico.lisp
index 66bbc55bb81bdd07223f5a507066248559a69c77..920b594708727e5ab58e84f1dd4aa12cd5417927 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.12 92/10/28 13:17:35 cer Exp $
+;; $fiHeader: ico.lisp,v 1.13 92/10/29 16:55:32 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -72,52 +72,53 @@
 				     :prompt "Line style")))
       (when (palette-dynamic-p (frame-palette frame))
 	(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-set2 ico-color-set3
-					    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-set2
-				  (setf ico-color-set2 
-				    (make-layered-color-set 4 4)))))
-		       (setf ico-buffers 2
-			     inks0 (vector (layered-color g 0 nil)
-					   (layered-color g nil 0))
-			     inks1 (vector (layered-color g 1 nil)
-					   (layered-color g nil 1))
-			     inks2 (vector (layered-color g 2 nil)
-					   (layered-color g nil 2))
-			     inks3 (vector (layered-color g 3 nil)
-					   (layered-color g nil 3)))))
-		    (:triple
-		     (let ((g (or ico-color-set3
-				  (setf ico-color-set3
-				    (make-layered-color-set 4 4 4)))))
-		       (setf ico-buffers 3
-			     inks0 (vector (layered-color g 0 nil nil)
-					   (layered-color g nil 0 nil)
-					   (layered-color g nil nil 0))
-			     inks1 (vector (layered-color g 1 nil nil)
-					   (layered-color g nil 1 nil)
-					   (layered-color g nil nil 1))
-			     inks2 (vector (layered-color g 2 nil nil)
-					   (layered-color g nil 2 nil)
-					   (layered-color g nil nil 2))
-			     inks3 (vector (layered-color g 3 nil nil)
-					   (layered-color g nil 3 nil)
-					   (layered-color g nil nil 3))))))))))))))
+	  (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-set2 ico-color-set3
+			   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-set2
+				 (setf ico-color-set2 
+				       (make-layered-color-set 4 4)))))
+		      (setf ico-buffers 2
+			    inks0 (vector (layered-color g 0 nil)
+					  (layered-color g nil 0))
+			    inks1 (vector (layered-color g 1 nil)
+					  (layered-color g nil 1))
+			    inks2 (vector (layered-color g 2 nil)
+					  (layered-color g nil 2))
+			    inks3 (vector (layered-color g 3 nil)
+					  (layered-color g nil 3)))))
+		  (:triple
+		    (let ((g (or ico-color-set3
+				 (setf ico-color-set3
+				       (make-layered-color-set 4 4 4)))))
+		      (setf ico-buffers 3
+			    inks0 (vector (layered-color g 0 nil nil)
+					  (layered-color g nil 0 nil)
+					  (layered-color g nil nil 0))
+			    inks1 (vector (layered-color g 1 nil nil)
+					  (layered-color g nil 1 nil)
+					  (layered-color g nil nil 1))
+			    inks2 (vector (layered-color g 2 nil nil)
+					  (layered-color g nil 2 nil)
+					  (layered-color g nil nil 2))
+			    inks3 (vector (layered-color g 3 nil nil)
+					  (layered-color g nil 3 nil)
+					  (layered-color g nil nil 3))))))))))))))
+
 
 (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) ()
   (with-application-frame (frame)
@@ -133,10 +134,10 @@
       (let ((palette (frame-palette frame)))
 	(catch-ball frame)
 	(when ico-color-set2
-	  (remove-from-palette palette ico-color-set2)
+	  (remove-color-from-palette palette ico-color-set2)
 	  (setf ico-color-set2 nil))
 	(when ico-color-set3
-	  (remove-from-palette palette ico-color-set3)
+	  (remove-color-from-palette palette ico-color-set3)
 	  (setf ico-color-set3 nil))
 	(frame-exit frame)))))
 
diff --git a/demo/listener.lisp b/demo/listener.lisp
index 8f50f015cced3a5a1d3e74426f9555e0c1e5c948..484c65952f444b5e51c3bf3ddb1515f4f9474041 100644
--- a/demo/listener.lisp
+++ b/demo/listener.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: listener.lisp,v 1.21 92/10/07 14:43:36 cer Exp $
+;; $fiHeader: listener.lisp,v 1.22 92/10/28 11:33:00 cer Exp $
 
 (in-package :clim-demo)
 
@@ -220,14 +220,14 @@
     (with-output-recording-options (*lisp-listener-io* :draw t :record t)
       (lisp-listener-top-level *application-frame*))))
 
-(define-presentation-type restart-name ())
-
 (defvar *enter-debugger* '#:enter-debugger)
 (defun enter-debugger (stream)
   #+Genera
   (clim-internals::with-debug-io-selected (stream)
     (cl:break "Debugger break for ~A" (frame-pretty-name (pane-frame stream)))))
 
+(define-presentation-type restart-name ())
+
 (define-presentation-method presentation-typep (object (type restart-name))
   (or (eql object *enter-debugger*)
       (typep object 'restart)))
@@ -239,7 +239,7 @@
       (prin1 (restart-name object) stream)))
 
 (define-lisp-listener-command (com-invoke-restart :name t)
-    ((restart 'restart :gesture :select))
+    ((restart 'restart-name :gesture :select))
   (if (eql restart *enter-debugger*)
       (enter-debugger *standard-input*)
       (invoke-restart restart)))
@@ -266,7 +266,7 @@
 	(fresh-line stream)
 	(formatting-table (stream :x-spacing '(2 :character))
 	  (dolist (restart restarts)
-	    (with-output-as-presentation (stream restart 'restart
+	    (with-output-as-presentation (stream restart 'restart-name
 					  :single-box t :allow-sensitive-inferiors nil)
 	      (formatting-row (stream)
 		(formatting-cell (stream) stream)
@@ -276,7 +276,7 @@
 		(formatting-cell (stream)
 		  (format stream "~A" restart)))))
 	  #+Genera
-	  (with-output-as-presentation (stream *enter-debugger* 'restart
+	  (with-output-as-presentation (stream *enter-debugger* 'restart-name
 					:single-box t :allow-sensitive-inferiors nil)
 	    (formatting-row (stream)
 	      (formatting-cell (stream) stream)
diff --git a/demo/plot.lisp b/demo/plot.lisp
index f695ee3612f292ae271bf1da2f620093df4b5fa1..209306eea087ae819b397ca7f083db9e3728c5fe 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: plot.lisp,v 1.14 92/10/29 15:02:50 cer Exp Locker: cer $
+;; $fiHeader: plot.lisp,v 1.15 92/10/29 16:55:34 cer Exp $
 
 (in-package :clim-demo)
 
@@ -195,33 +195,32 @@
   (updating-output (stream :unique-id 'captions
 			   :cache-value (cons type (copy-list y-labels))
 			   :cache-test #'equalp)
-      (let ((n-lines (length y-labels))
-	    (ascent (text-style-ascent (medium-text-style stream) stream))
-	    (descent (text-style-descent (medium-text-style stream) stream))
-	    (i 0))
-	(surrounding-output-with-border (stream)
-	    (formatting-table (stream)
-		(dolist (label y-labels)
-		  (updating-output (stream :unique-id  label :id-test #'equalp)
-		      (formatting-row (stream)
-			  (updating-output (stream :unique-id (cons :ink label) :id-test #'equalp)
-			      (formatting-cell (stream)
-				  (if (eq type :plot)
-				      (progn
-					(draw-rectangle* stream 0 0 20 (+ ascent descent)
-							 :ink +background-ink+)
-					(draw-line* stream 0 (/ ascent 2) 20 (/ ascent 2)
-						    :ink (get-contrasting-inks stream n-lines i)
-						    :line-dashes
-						    (get-contrasting-dash-patterns stream n-lines i)))
-				    (draw-rectangle* stream 0 0 20 (+ ascent descent)
-						     :ink
-						     (get-contrasting-inks stream n-lines i)))))
-			(updating-output (stream :unique-id (cons :text label) :id-test #'equalp)
-			    (formatting-cell (stream)
-				(write-string label stream)))))
-		  (incf i)))))))
-	    
+    (let ((n-lines (length y-labels))
+	  (ascent (text-style-ascent (medium-text-style stream) stream))
+	  (descent (text-style-descent (medium-text-style stream) stream))
+	  (i 0))
+      (surrounding-output-with-border (stream)
+	(formatting-table (stream)
+	  (dolist (label y-labels)
+	    (updating-output (stream :unique-id  label :id-test #'equalp)
+	      (formatting-row (stream)
+		(updating-output (stream :unique-id (cons :ink label) :id-test #'equalp)
+		  (formatting-cell (stream)
+		    (if (eq type :plot)
+			(progn
+			  (draw-rectangle* stream 0 0 20 (+ ascent descent)
+					   :ink +background-ink+)
+			  (draw-line* stream 0 (/ ascent 2) 20 (/ ascent 2)
+				      :ink (get-contrasting-inks stream n-lines i)
+				      :line-dashes (get-contrasting-dash-patterns
+						     stream n-lines i))) 
+			(draw-rectangle* stream 0 0 20 (+ ascent descent)
+					 :ink
+					 (get-contrasting-inks stream n-lines i)))))
+		(updating-output (stream :unique-id (cons :text label) :id-test #'equalp)
+		  (formatting-cell (stream)
+		    (write-string label stream)))))
+	    (incf i)))))))
 
 (defun draw-axis (stream type width height
 		  x-min y-min x-max y-max x-labels y-labels 
diff --git a/genera/genera-medium.lisp b/genera/genera-medium.lisp
index c677d4da927a4e561dfd35ff9bad460af9c2c237..953feb39f8e0d2975855be1e1d4570628a7704c8 100644
--- a/genera/genera-medium.lisp
+++ b/genera/genera-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: genera-medium.lisp,v 1.12 92/09/24 09:39:50 cer Exp $
+;; $fiHeader: genera-medium.lisp,v 1.13 92/10/28 11:32:39 cer Exp $
 
 (in-package :genera-clim)
 
@@ -974,18 +974,27 @@
 	  (when towards-x
 	    (incf towards-x x-adjust)
 	    (incf towards-y y-adjust)))
-	(invoke-with-appropriate-drawing-state medium ink nil
-	  #'(lambda (window alu)
-	      (declare (sys:downward-function))
-	      (tv:prepare-sheet (window)
-		(let ((x (+ x (tv:sheet-left-margin-size window)))
-		      (y (+ y (tv:sheet-top-margin-size window))))
-		  (tv:sheet-draw-glyph (char-code character) font x y alu window)))
-	      (scl:send window :draw-glyph (char-code character) font x y alu))
-	  #'(lambda (window)
-	      (declare (sys:downward-function))
-	      (funcall (flavor:generic graphics:draw-glyph) window
-		       (char-code character) font x y))))))) 
+	(macrolet ((with-diacritic ((character font) &body body)
+		     ;; I am dumbfounded.  It seems that we need to bind the
+		     ;; fill pointer of the font structure beyond its usual
+		     ;; length if we want to output a diacritic character.
+		     `(if (diacritic-char-p ,character)
+			  (letf-globally (((tv:font-fill-pointer ,font) #o320))
+			    ,@body)
+			  ,@body)))
+	  (invoke-with-appropriate-drawing-state medium ink nil
+	    #'(lambda (window alu)
+		(declare (sys:downward-function))
+		(tv:prepare-sheet (window)
+		  (let ((x (+ x (tv:sheet-left-margin-size window)))
+			(y (+ y (tv:sheet-top-margin-size window))))
+		    (with-diacritic (character font)
+		      (tv:sheet-draw-glyph (char-code character) font x y alu window)))))
+	    #'(lambda (window)
+		(declare (sys:downward-function))
+		(with-diacritic (character font)
+		  (funcall (flavor:generic graphics:draw-glyph) window
+			   (char-code character) font x y)))))))))
 
 (defmethod medium-draw-text* ((medium genera-medium)
 			      string-or-char x y start end
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index 5bd2a5f7926bf39696bfdc2c6e6c23360816a75f..6b363878120e36af9f21052bc8c8043dca863994 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.13 92/10/29 15:02:54 cer Exp Locker: cer $
+;; $fiHeader: compile-1.lisp,v 1.14 92/11/05 17:15:56 cer Exp $
 
 (in-package :user)
 
@@ -77,6 +77,7 @@
   (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp")
     (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp")
     (clim-defsys::compile-system 'clim-toys))
+  (load "compatibility/sysdcl.lisp")
   #+ignore
   (clim-defsys::compile-system 'clim-compatibility :propagate t))
 
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index 796bbdbc3140c8abe784b4d9893f6ec193968aed..2f4258dc708759d55b2aed6fd5cbcd70eab73f06 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.17 92/10/29 15:02:55 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.18 92/11/05 17:15:57 cer Exp $
 
 ;;;; This should not matter
 ;;;; (setq *ignore-package-name-case* t)
@@ -52,7 +52,6 @@
 	(load "clim-debug.fasl")
 	(load "clim-debugol.fasl")))
 
-
      ;;-- What would be good is to mark the files in the system as having
      ;;-- been loaded
 
@@ -63,6 +62,7 @@
 
      (compile-file-if-needed "test/test-suite")
 
+
      (load "test/test-suite")
 
      (load "demo/sysdcl")
@@ -72,8 +72,8 @@
      (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp")
        (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp")
        (tenuring (clim-defsys::load-system 'clim-toys)))
-  
      (ignore-errors (require :composer))
+
    
      (ignore-errors
       (load (case sys
diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp
index d291925e8cb8ce0a59e502ad90f3a39e7588fdac..dd439f698fe55442a7fb03ce2072dedcb3c30072 100644
--- a/postscript/postscript-port.lisp
+++ b/postscript/postscript-port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: postscript-port.lisp,v 1.8 92/10/02 15:21:17 cer Exp $
+;; $fiHeader: postscript-port.lisp,v 1.9 92/10/28 11:33:29 cer Exp $
 
 (in-package :postscript-clim)
 
@@ -255,7 +255,8 @@
       (current-color :initform nil)		;for decoding stippled inks
       (features-sent :initform nil)
       (curfont :initform nil)			;a psfck structure
-      (ch1buf :initform (make-array 1 :element-type 'character))	;used for char ops.
+      (ch1buf :initform (make-array 1 :element-type #+ANSI-90 'character
+						    #-ANSI-90 'string-char))
       (header-comments :initform nil :initarg :header-comments)
       (orientation :initform :portrait :initarg :orientation)))
 
@@ -271,12 +272,6 @@
 (defmethod medium-clear-output ((medium postscript-medium))
   (clear-output (slot-value medium 'printer-stream)))
 
-;;; Methods that might be needed:
-;;; what about other "window" protocols?
-;;; host-window-margins
-;;; window-margins (being flushed, should return (values 0 0 0 0))
-;;; window-beep
-;;; window-clear (do a fresh-page?)
 
 ;;; Support routines
 
@@ -376,7 +371,8 @@
 		  (negative-p nil))
 	      (when (minusp n)
 		(setq negative-p t))
-	      (with-stack-array (string from :element-type 'character)
+	      (with-stack-array (string from :element-type #+ANSI-90 'character 
+							   #-ANSI-90 'string-char)
 		(macrolet ((add-char (char)
 			     `(setf (aref string (decf from)) ,char)))
 		  (when (/= frac 0)
@@ -641,7 +637,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def
   (make-instance 'postscript-palette
     :port port 
     :color-p t
-    :mutable-p nil))
+    :dynamic-p nil))
 
 (defmethod standardize-text-style ((port postscript-port) style &optional character-set)
   (declare (ignore character-set))
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index cf049926d8174369b70a23cd89110341ff49934c..77e6c18d6908e90c78349d44f13c28f4433952a7 100644
--- a/silica/db-scroll.lisp
+++ b/silica/db-scroll.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-scroll.lisp,v 1.32 92/09/24 09:37:33 cer Exp $
+;; $fiHeader: db-scroll.lisp,v 1.33 92/10/02 15:18:15 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -110,14 +110,14 @@
 	  scroller)
 	(progn
 	  (check-type scroll-bars
-		      (member :both :dynamic :vertical :horizontal))
+		      (member t :both :dynamic :vertical :horizontal))
 	  (with-slots (vertical-scroll-bar horizontal-scroll-bar
 		       (c contents) viewport foreground background) pane
 	    (with-look-and-feel-realization (frame-manager frame)
 	      (let ((verticalp
-		      (member scroll-bars '(:both :dynamic :vertical)))
+		      (member scroll-bars '(t :both :dynamic :vertical)))
 		    (horizontalp
-		      (member scroll-bars '(:both :dynamic :horizontal))))
+		      (member scroll-bars '(t :both :dynamic :horizontal))))
 		(setf vertical-scroll-bar 
 		      (and verticalp
 			   (make-pane 'scroll-bar 
diff --git a/silica/event.lisp b/silica/event.lisp
index 73ade3148df9f023c783d5fe9c4020f7014ce283..a8adf16f11a19058beb13feb5a91932aab71d041 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: event.lisp,v 1.26 92/10/28 11:30:45 cer Exp Locker: cer $
+;; $fiHeader: event.lisp,v 1.27 92/11/05 17:15:24 cer Exp $
 
 (in-package :silica)
 
@@ -562,23 +562,18 @@
     (process-event-locally sheet (event-read sheet))))
 
 (defun port-event-wait (port waiter 
-			&key (wait-reason #+Genera si:*whostate-awaiting-user-input*
-					  #-Genera "CLIM Input")
+			     &key (wait-reason #+Genera si:*whostate-awaiting-user-input*
+					       #-Genera "CLIM Input")
 			     timeout)
   (cond (*multiprocessing-p*
 	 (process-wait-with-timeout wait-reason timeout waiter) 
 	 (values))
 	(t 
 	 ;; Single process, so run the event processing loop right here
-	 (let ((finish-time (when timeout (+ (* timeout internal-time-units-per-second)
-					     (get-internal-real-time)))))
-	   (loop
-	     (when (or (and timeout (> (get-internal-real-time) finish-time))
-		       (funcall waiter))
-	       (return-from port-event-wait (values)))
-	     (process-next-event port
-				 :wait-function waiter
-				 :state wait-reason))))))
+	 (process-next-event port
+			     :timeout timeout
+			     :wait-function waiter
+			     :state wait-reason))))
 
 
 ;;; Event resources
diff --git a/silica/framem.lisp b/silica/framem.lisp
index c6f067ceb415cfe4cc41107cefc4972dba3bbdf6..eb4fc26cad83669ec1e62a9e218d40b0cc8f74d3 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.21 92/10/28 11:30:47 cer Exp Locker: cer $
+;; $fiHeader: framem.lisp,v 1.22 92/10/28 13:17:08 cer Exp $
 
 (in-package :silica)
 
@@ -21,7 +21,11 @@
     (unless palette
       (setf palette (port-default-palette port)))))
 
-;;--- This is most likely wrong
+(defmethod find-named-color (name (framem standard-frame-manager) &key (errorp t))
+  (find-named-color name (frame-manager-palette framem) :errorp errorp))
+
+;;--- This is most likely wrong, since it forces a 1-to-1 mapping
+;;--- between ports and grafts
 (defmethod graft ((framem standard-frame-manager))
   (car (port-grafts (port framem))))
 
@@ -187,9 +191,9 @@
 			 (label-pane generic-label-pane)
 			 (text-field text-field-pane)
 			 (text-editor text-editor-pane)
+			 (list-pane generic-list-pane)
+			 (option-pane generic-option-pane)
 			 ;;--- Need to do these
-			 (list-pane)
-			 (option-pane)
 			 (horizontal-divider-pane)
 			 (vertical-divider-pane)
 			 ))))
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index bc4d698d71f25d3ec7fbd3c1e777986a9fdb836c..49920e939814999e13261e7843afde0c754070b2 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.36 92/10/02 15:18:21 cer Exp $
+;; $fiHeader: gadgets.lisp,v 1.37 92/10/28 11:30:48 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -437,17 +437,6 @@
 (defmethod viewportp ((x t)) nil)
 (defmethod viewportp ((x viewport)) t)
 
-(defmethod allocate-space ((viewport viewport) width height)
-  ;; Make sure the child is at least as big as the viewport
-  ;; (VIEWPORT-REGION-CHANGED actually does this also)
-  (let* ((child (sheet-child viewport)))
-    (multiple-value-bind (cwidth cheight)
-	(bounding-rectangle-size child)
-      (when (or (< cwidth width)
-		(< cheight height))
-	(resize-sheet
-	  child (max width cwidth) (max height cheight))))))
-
 (defmethod compose-space ((viewport viewport) &key width height)
   (declare (ignore width height))
   (let ((sr (call-next-method)))
@@ -459,6 +448,17 @@
 	:width width :min-width 0 :max-width max-width
 	:height height :min-height 0 :max-height max-height))))
 
+(defmethod allocate-space ((viewport viewport) width height)
+  ;; Make sure the child is at least as big as the viewport
+  ;; (VIEWPORT-REGION-CHANGED actually does this also)
+  (let* ((child (sheet-child viewport)))
+    (multiple-value-bind (cwidth cheight)
+	(bounding-rectangle-size child)
+      (when (or (< cwidth width)
+		(< cheight height))
+	(resize-sheet
+	  child (max width cwidth) (max height cheight))))))
+
 (defmethod allocate-space :after ((viewport viewport) width height)
   (let ((vr (viewport-viewport-region viewport)))
     (multiple-value-bind (owidth oheight) (bounding-rectangle-size vr)
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 8268ad1fdef9c611928db8d67f1c1aad4cf62dc4..dfde5fc89be2fac1665ad5926b62efa794e6d27c 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.27 92/10/28 13:17:09 cer Exp $
+;; $fiHeader: medium.lisp,v 1.28 92/10/29 16:54:58 cer Exp $
 
 (in-package :silica)
 
@@ -314,30 +314,6 @@
   (setf (medium-sheet medium) nil)
   (push medium (port-medium-cache port)))
 
-
-;;; Support for colors
-
-;;--- Not clear that these should be here
-
-(defmethod sheet-palette ((sheet basic-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 basic-medium))
-  (sheet-palette (medium-sheet medium)))
-
-(defmethod find-named-color (name (port basic-port))
-  (find-named-color name (port-default-palette port)))
-
-(defmethod find-named-color (name (sheet basic-sheet))
-  (find-named-color name (sheet-palette sheet)))
-
-(defmethod find-named-color (name (medium basic-medium))
-  (find-named-color name (medium-palette medium)))
-
 
 ;; Make sheets do the medium protocol
 
diff --git a/silica/port.lisp b/silica/port.lisp
index 7946a1acd99125ffb5a77db3aee850ac61e28d03..dcbe8b42dab98cca5aab7e5b3cd1ea7d21247664 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.22 92/10/28 11:30:53 cer Exp $
+;; $fiHeader: port.lisp,v 1.23 92/10/29 16:55:00 cer Exp $
 
 (in-package :silica)
 
@@ -32,9 +32,6 @@
 			(return-from find-port port))))
   (make-port :server-path server-path))
 
-(defmethod find-named-color (name (port port))
-  (find-named-color name (port-default-palette port)))
-
 #+Genera
 (scl:add-initialization "Reset ports"
   '(progn
@@ -75,6 +72,9 @@
   (restart-port port))
 
 
+(defmethod find-named-color (name (port basic-port) &key (errorp t))
+  (find-named-color name (port-default-palette port) :errorp errorp))
+
 (defmethod port-pointer ((port basic-port))
   (with-slots (pointer grafts) port
     (or pointer
@@ -248,3 +248,4 @@
 (defgeneric graft-height (graft))
 (defgeneric graft-pixels-per-millimeter (graft))
 (defgeneric graft-pixels-per-inch (graft))
+
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index 578ca09a931e23d54d8e85e968cfad13085b4d78..eff6e15bba5dc3ada741cfa6551e68e4a9a3c56e 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sheet.lisp,v 1.29 92/10/02 15:18:33 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.30 92/10/28 11:30:54 cer Exp $
 
 (in-package :silica)
 
@@ -34,7 +34,7 @@
 
 (defmethod sheet-child ((sheet basic-sheet))
   (let ((children (sheet-children sheet)))
-    (unless (and children (null (cdr children)))
+    (when (cdr children)
       (error "The sheet ~S has more than one child" sheet))
     (car children)))
 
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index 7f4717ee7ddb8d869c65a9aff92daec987886e33..da1a6ef756be872d9b6dd17b25223e8bd5e4cfeb 100644
--- a/silica/text-style.lisp
+++ b/silica/text-style.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-style.lisp,v 1.13 92/09/24 09:37:55 cer Exp Locker: cer $
+;; $fiHeader: text-style.lisp,v 1.14 92/10/02 15:18:36 cer Exp $
 
 (in-package :silica)
 
@@ -165,7 +165,7 @@
 	      (member size *valid-text-style-sizes*)
 	      (eq size :smaller)
 	      (eq size :larger))
-    (error "The size ~S is not valid." size))
+    (error "The size ~S is not valid" size))
   ;; This needs to be fleshed out with error handlers, etc.
   (values family face size nil original-face))
 
@@ -314,7 +314,7 @@
 (defun add-text-face-class (name class)
   (let ((alist (assoc class *face->face-code-cache*)))
     (when (null alist)
-      (error "Can't define face ~S in unknown face class ~S." name class))
+      (error "Can't define face ~S in unknown face class ~S" name class))
     (unless (member name (cdr alist))
       (nconc alist (list name)))))
 
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 92172c26395b85c92c45797fdacad4b570f83b7f..80dbf905569b94269283c8247e9915507026ef43 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.28 92/09/30 18:03:56 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.29 92/10/02 15:20:16 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -303,6 +303,8 @@
    :load-before-compile ("frames"))
   ("db-menu"
    :load-before-compile ("frames"))
+  ("db-list"
+   :load-before-compile ("db-menu"))
   ("db-text"
    :load-before-compile ("frames"))
   ("noting-progress"
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index b538804224bc109729595d946705d593e8fc11a8..21070df5533afa4b9c447e50abe550d59fa8d2c6 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.41 92/10/28 08:19:47 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.42 92/10/28 11:32:18 cer Exp $
 
 (in-package :clim-user)
 
@@ -712,19 +712,20 @@ people, shall not perish from the earth.
 
 (define-test (colored-inks graphics) (stream)
   "Test colors"
-  (with-text-style (stream '(:sans-serif :italic :normal))
-    (format stream "~&~%~A~%" "Named Colors")
-    (formatting-table (stream)
-      (dolist (name *named-colors*)
-	(let ((color (if (symbolp name)
-			 (symbol-value name)
-			 (find-named-color name stream))))
-	  (when color
-	    (formatting-row (stream)
-	      (formatting-cell (stream)
-		(write-string (string name) stream))
-	      (formatting-cell (stream)
-		(draw-rectangle* stream 0 0 200 10 :ink color)))))))))
+  (let ((palette (frame-palette *application-frame*)))
+    (with-text-style (stream '(:sans-serif :italic :normal))
+      (format stream "~&~%~A~%" "Named Colors")
+      (formatting-table (stream)
+	(dolist (name *named-colors*)
+	  (let ((color (if (symbolp name)
+			   (symbol-value name)
+			   (find-named-color name palette :errorp nil))))
+	    (when color
+	      (formatting-row (stream)
+		(formatting-cell (stream)
+		  (write-string (string name) stream))
+		(formatting-cell (stream)
+		  (draw-rectangle* stream 0 0 200 10 :ink color))))))))))
 
 (define-test (patterned-graphics-shapes graphics) (stream)
   "Test patterned graphics shapes"
@@ -888,14 +889,14 @@ people, shall not perish from the earth.
   "Write some strings separated by horizontal cursor motion.  After refreshing, the output should look the same."
   (terpri stream)
   (let* ((width (bounding-rectangle-width stream))
-	 (rect-width (- (floor width 11) 10))
-	 (spacing 8))
+	 (rect-width (- (floor width 11) 10)))
     (multiple-value-bind (x y)
 	(stream-cursor-position stream)
-      (dotimes (i 11)
-	(stream-set-cursor-position stream x y)
-	(write-string (format nil "~1$" (float (/ i 10))) stream)
-	(incf x (+ rect-width spacing))))
+      (with-end-of-line-action (stream :allow)
+	(dotimes (i 11)
+	  (stream-set-cursor-position stream x y)
+	  (write-string (format nil "~1$" (float (/ i 10))) stream)
+	  (incf x rect-width))))
     (terpri stream)
     (stream-force-output stream)
     (sleep 2)
@@ -1677,12 +1678,14 @@ Luke Luck licks the lakes Luke's duck likes."))
   (graphics-dialog-internal stream t))
 
 (defun graphics-dialog-internal (stream &optional own-window)
-  (labels ((display-color (object stream)
+  (labels ((display-color (object stream &key acceptably)
+	     (declare (ignore acceptably))
 	     (with-room-for-graphics (stream)
 	       (draw-rectangle* stream 0 0 30 10 :ink
 				(color-name-color object))))
 	   (color-name-color (name)
 	     (ecase name
+	       (:foreground +foreground-ink+)
 	       (:red +red+)
 	       (:green +green+)
 	       (:blue +blue+))))
@@ -1693,49 +1696,50 @@ Luke Luck licks the lakes Luke's duck likes."))
 	  (draw-/-diagonal t)
 	  (draw-\\-diagonal t)
 	  (line-thickness 1)
-	  (color-name :red)
+	  (color-name :foreground)
 	  (line-thickness-units :normal))
       (accepting-values (stream :own-window own-window :label "Graphics Dialog")
-	  (setq square-dimension
-	    (accept 'number :stream stream
-		    :prompt "Size of square" :default square-dimension))
+	(setq square-dimension
+	      (accept 'number :stream stream
+		      :prompt "Size of square" :default square-dimension))
 	(terpri stream)
 	(setq draw-circle
-	  (accept 'boolean :stream stream
-		  :prompt "Draw the circle" :default draw-circle))
+	      (accept 'boolean :stream stream
+		      :prompt "Draw the circle" :default draw-circle))
 	(terpri stream)
 	(setq draw-square
-	  (accept 'boolean :stream stream
-		  :prompt "Draw the square" :default draw-square))
+	      (accept 'boolean :stream stream
+		      :prompt "Draw the square" :default draw-square))
 	(terpri stream)
 	(setq draw-point
-	  (accept 'boolean :stream stream
-		  :prompt "Draw point" :default draw-point))
+	      (accept 'boolean :stream stream
+		      :prompt "Draw point" :default draw-point))
 	(terpri stream)
 	(setq draw-/-diagonal
-	  (accept 'boolean :stream stream
-		  :prompt "Draw / diagonal" :default draw-/-diagonal))
+	      (accept 'boolean :stream stream
+		      :prompt "Draw / diagonal" :default draw-/-diagonal))
 	(terpri stream)
 	(setq draw-\\-diagonal
-	  (accept 'boolean :stream stream
-		  :prompt "Draw \\ diagonal" :default draw-\\-diagonal))
+	      (accept 'boolean :stream stream
+		      :prompt "Draw \\ diagonal" :default draw-\\-diagonal))
 	(terpri stream)
 	(setq line-thickness
-	  (accept 'number :stream stream
-		  :prompt "Line thickness" :default line-thickness))
+	      (accept 'number :stream stream
+		      :prompt "Line thickness" :default line-thickness))
 	(terpri stream)
 	(setq line-thickness-units
-	  (accept '(member :normal :point) :stream stream
-		  :prompt "Line style units" :default line-thickness-units))
+	      (accept '(member :normal :point) :stream stream
+		      :prompt "Line style units" :default line-thickness-units))
 	(terpri stream)
 	(setq color-name 
-	  (accept `((completion (:red :green :blue))
-		    :name-key ,#'identity
-		    :printer ,#'display-color)
-		  :view '(radio-box-view 
-			  :toggle-button-options (:indicator-type nil))
-		  :stream stream
-		  :prompt "Color" :default color-name))
+	      (accept `((completion (:foreground :red :green :blue))
+			:name-key ,#'identity
+			:printer ,#'display-color)
+		      :view #+allegro '(radio-box-view 
+					 :toggle-button-options (:indicator-type nil))
+			    #-allegro (stream-default-view stream)
+		      :stream stream
+		      :prompt "Color" :default color-name))
 	(terpri stream)
 	(with-drawing-options (stream :ink (color-name-color color-name))
 	  (with-room-for-graphics (stream)
@@ -2796,12 +2800,12 @@ Luke Luck licks the lakes Luke's duck likes."))
 				  menus-and-dialogs
 				  benchmarks)
 		   :menu (("Graphics" :menu graphics)
+			  ("Redisplay" :menu redisplay)
+			  ("Benchmarks" :menu benchmarks)
 			  ("Output Recording" :menu output-recording)
 			  ("Formatted Output" :menu formatted-output)
-			  ("Redisplay" :menu redisplay)
 			  ("Presentations" :menu presentations)
 			  ("Menus and Dialogs" :menu menus-and-dialogs)
-			  ("Benchmarks" :menu benchmarks)
 			  ("Exit" :command (exit-clim-tests)))))
   (:command-definer nil)
   (:panes 
diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp
index 1ed1c2b635bb3125247f99c848ea27a8f1cb1952..395185c7187a598f7c21a2ddc49e86a82038fc07 100644
--- a/tk-silica/ol-frames.lisp
+++ b/tk-silica/ol-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-frames.lisp,v 1.14 92/09/30 18:04:26 cer Exp $
+;; $fiHeader: ol-frames.lisp,v 1.15 92/10/28 11:33:14 cer Exp $
 
 
 (in-package :xm-silica)
@@ -57,9 +57,9 @@
 	    printer 
 	    presentation-type 
 	    associated-window
-	    default-style
+	    text-style
 	    label)
-  (declare (ignore default-style))
+  (declare (ignore text-style))
   (let* (value-returned 
 	 return-value
 	 (simplep (and (null printer)
diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp
index 8ca13f30fbcc3ae529b6ececba3553b4613479b8..446753854f3015721d7b946c4883f50bd2574784 100644
--- a/tk-silica/xm-dialogs.lisp
+++ b/tk-silica/xm-dialogs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: xm-dialogs.lisp,v 1.1 92/09/08 10:40:50 cer Exp $
 
 
 (in-package :clim-internals)
@@ -126,10 +126,7 @@
 ;  ;; This requires formatting-table and friends to return their bodies' values properly.
 ;  (with-slots (stream continuation resynchronize-every-pass check-overlapping
 ;	       selected-item initially-select-query-identifier
-;	       own-window own-window-x-position own-window-y-position
-;	       own-window-width own-window-height
-;	       own-window-right-margin own-window-bottom-margin
-;	       exit-button-stream) frame
+;	       own-window own-window-properties exit-button-stream) frame
 ;
 ;    (unless own-window (return-from accept-values-top-level (call-next-method)))
 ;
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index fd03a643b475e4235dd2ef07cee82bb4089d7afa..597b305d5b3aff89d289d2cbc00c0d4fd0aa1bcb 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.35 92/10/28 11:33:17 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.36 92/11/05 17:15:59 cer Exp $
 
 (in-package :xm-silica)
 
@@ -287,9 +287,9 @@
 	    printer 
 	    presentation-type 
 	    associated-window
-	    default-style
+	    text-style
 	    label)
-  (declare (ignore default-style))
+  (declare (ignore text-style))
   (let* (value-returned 
 	 return-value
 	 (simplep (and (null printer)
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 3b953da767b64f1b0760d2197d45b24c3383a269..08b4a2a55d370b974827dee9aa23514d48f5403d 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.52 92/10/28 11:33:18 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.53 92/11/06 14:32:44 colin Exp $
 
 (in-package :xm-silica)
 
@@ -454,17 +454,17 @@
    ;; comes up in the right place.
    ((popup-frame-p sheet)
     (values 'tk::xm-bulletin-board
-            (list :margin-width 0 :margin-height 0
-                  ;; Prevents buttons from deactivating dialog
-                  :auto-unmanage nil
-                  ;; We specify NIL for accelerators otherwise the
-                  ;; bulletin board messes with the event handling of
-                  ;; its drawing area children
-                  :accelerators nil
-                  :resize-policy :none
-                  :name (if (pane-frame sheet)
-                            (string (frame-name (pane-frame sheet)))
-                            "a CLIM pop-up"))))
+	    (list :margin-width 0 :margin-height 0
+		  ;; We specify NIL for accelerators otherwise the
+		  ;; bulletin board messes with the event handling of
+		  ;; its drawing area children
+		  :accelerators nil
+		  ;; Prevents buttons from deactivating dialog
+		  :auto-unmanage nil
+		  :resize-policy :none
+		  :name (if (pane-frame sheet)
+			    (string (frame-name (pane-frame sheet)))
+			    "a CLIM pop-up"))))
    (t
     (values 'tk::xm-my-drawing-area 
             (list :resize-policy :none
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index ffe6c764d3fa1f50aaa8c8407b976d0fc055ff7f..cab40906029892152aac10f6baa279bcdab8ef50 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.19 92/10/02 15:21:05 cer Exp $
+;; $fiHeader: xt-frames.lisp,v 1.20 92/10/28 11:33:20 cer Exp $
 
 
 (in-package :xm-silica)
@@ -88,7 +88,7 @@
 	    &key printer 
 		 presentation-type 
 		 (associated-window (frame-top-level-sheet *application-frame*))
-		 default-style label
+		 text-style label
 		 cache
 		 (unique-id items)
 		 (id-test 'equal)
@@ -122,7 +122,7 @@
 				      printer 
 				      presentation-type 
 				      associated-window
-				      default-style
+				      text-style
 				      label))
       (when cache
 	(push (list unique-id menu closure) 
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 8dd29d6fa2e09a733fa79729f2c77546621ab496..c191ef1f9281249a830eecb1a7099626ab661e45 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.48 92/10/29 16:55:44 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.49 92/11/06 10:01:19 colin Exp $
 
 (in-package :tk-silica)
 
@@ -94,12 +94,10 @@
   (make-xt-palette port (tk::create-colormap (port-display port))))
 
 (defmethod medium-palette ((medium xt-medium))
-  (let* ((sheet (medium-sheet medium))
-	 (frame (pane-frame sheet))
-	 (framem (and frame (frame-manager frame))))
-    (if framem
-	(frame-manager-palette framem)
-      (port-default-palette (port sheet)))))
+  (let ((frame (pane-frame (medium-sheet medium))))
+    (if frame
+	(frame-palette frame)
+	(port-default-palette (port sheet)))))
 
 #+ignore
 (defmethod (setf frame-manager-palette) :after 
@@ -123,7 +121,7 @@
 			     :green (truncate (* x green))
 			     :blue (truncate (* x blue)))))))))
 
-(defmethod find-named-color (name (palette xt-palette))
+(defmethod find-named-color (name (palette xt-palette) &key (errorp t))
   (let ((named-color-cache (palette-named-color-cache palette)))
     ;;-- What is the correct thing to do?
     ;;-- CLIM has names containing dashes instead of spaces
@@ -183,24 +181,24 @@
 (defmethod allocate-color ((color layered-color) (palette xt-palette))
   (allocate-color (layered-color-set color) palette))
 
-(defmethod free-color ((color color) (palette xt-palette))
+(defmethod deallocate-color ((color color) (palette xt-palette))
   (let* ((color-cache (palette-color-cache palette))
 	 (pixel (gethash color color-cache)))
     (when pixel
       (tk::free-color-cells (palette-colormap palette) pixel 0)
       (remhash color color-cache))))
 
-(defmethod free-color ((color dynamic-color) (palette xt-palette))
+(defmethod deallocate-color ((color dynamic-color) (palette xt-palette))
   (let* ((dynamic-color-cache (palette-dynamic-color-cache palette))
 	 (pixel (gethash color dynamic-color-cache)))
     (when pixel
       (tk::free-color-cells (palette-colormap palette) pixel 0)
       (remhash color dynamic-color-cache))))
 
-(defmethod free-color ((color layered-color) (palette xt-palette))
-  (free-color (layered-color-set color) palette))
+(defmethod deallocate-color ((color layered-color) (palette xt-palette))
+  (deallocate-color (layered-color-set color) palette))
 
-(defmethod free-color ((set layered-color-set) (palette xt-palette))
+(defmethod deallocate-color ((set layered-color-set) (palette xt-palette))
   (let* ((layered-color-cache (palette-layered-color-cache palette))
 	 (pixel-planes (gethash set layered-color-cache)))
     (when pixel-planes
@@ -234,7 +232,6 @@
 ;;   1. medium's sheet's device region changes
 ;;   2. medium's clipping region changes
 ;;   3. medium's sheet's device transformation changes
-
 (defmethod medium-clip-mask ((medium xt-medium))
   (with-slots (sheet clip-mask) medium
     (or clip-mask
@@ -607,10 +604,7 @@ 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 ((design design) (medium xt-medium))
   (decode-color-in-palette design (medium-palette medium)))
@@ -667,7 +661,7 @@ and on color servers, unless using white or black")
      (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))) 
+		  (pixel-planes (gethash set layered-color-cache)))
 	     (unless pixel-planes
 	       (setq pixel-planes (decode-layered-color-set set palette)))
 	     (multiple-value-list 
@@ -717,7 +711,7 @@ and on color servers, unless using white or black")
 	      (incf count))
 	    (push plane-masks planes)))
 	(let ((pixel-planes (cons pixel planes)))
-	  (map-over-layered-colors 
+	  (map-over-layered-colors  
 	   #'(lambda (dimensions)
 	       (let ((dynamic-color (apply #'aref dynamic-array dimensions))
 		     (pixel (decode-layered-color dimensions
@@ -734,6 +728,7 @@ and on color servers, unless using white or black")
 		      (make-color-for-contrasting-ink ink)
 		    (make-gray-color-for-contrasting-ink ink)) medium)))
 
+
 (defvar *default-dashes* '(4 4))
 
 (defun adjust-ink (gc medium line-style x-origin y-origin)
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 14cf0085bf7b81f3da7e7abc4a3f76bf3959bb16..919e85ecaecfb305e4c6d7a67af8d47da6c1addc 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.54 92/10/29 16:55:47 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.55 92/11/05 17:16:01 cer Exp $
 
 (in-package :xm-silica)
 
@@ -199,7 +199,7 @@
 		 (make-instance 'tk::font 
 				:display display
 				:name *xt-fallback-font*)))
-	    ;;; Perhaps we should just grab the first font we can find.
+	      ;;; Perhaps we should just grab the first font we can find.
 	      (t
 	       (error "Unable to determine default font"))))))
   (setup-opacities port display))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 6c574d661ab4a1d8b2840c1c839739f2f2e04e90..e894490d58a8992b1d9867c7f8b3d1a32e32ad8d 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.31 92/10/28 13:17:01 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.32 92/10/29 16:54:51 cer Exp $
 
 (in-package :tk)
 
@@ -339,7 +339,6 @@
 	(values (x11:xcolor-pixel y)
 		(make-instance 'color :foreign-address y))))))
 
-
 (defvar *pixel-array* 
     (make-array 1 :initial-element 0 :element-type '(unsigned-byte 32)))
 
@@ -352,6 +351,7 @@
    1
    planes))
 
+
 (defun allocate-named-color (colormap name)
   (let ((exact (x11::make-xcolor :in-foreign-space t))
 	(closest (x11::make-xcolor :in-foreign-space t)))
diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp
index 469e7ad3d0b4cc3d7127cc3378136bc99b3db59a..044ab24410678ba887b7e729af09a10b6406b538 100644
--- a/utils/base-designs.lisp
+++ b/utils/base-designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: base-designs.lisp,v 1.3 92/10/28 11:30:57 cer Exp $
+;; $fiHeader: base-designs.lisp,v 1.4 92/10/29 16:55:03 cer Exp $
 
 (in-package :clim-utils)
 
@@ -29,7 +29,7 @@
     ((value :type single-float :initarg :value :reader opacity-value)))
 
 (define-constructor make-standard-opacity-1 standard-opacity (value)
-		    :value value)
+  :value value)
 
 (defmethod make-load-form ((design standard-opacity))
   (with-slots (value) design
@@ -43,7 +43,7 @@
 	       :reader gray-color-luminosity)))
 
 (define-constructor make-gray-color-1 gray-color (luminosity)
-		    :luminosity luminosity)
+  :luminosity luminosity)
 
 (defmethod make-load-form ((color gray-color))
   (with-slots (luminosity) color
@@ -64,13 +64,14 @@
   (with-slots (red green blue) color
     `(make-rgb-color ,red ,green ,blue)))
 
+
 (defclass ihs-color (color)
     ((intensity  :type single-float :initarg :intensity)
      (hue	 :type single-float :initarg :hue)
      (saturation :type single-float :initarg :saturation)))
 
 (define-constructor make-ihs-color-1 ihs-color (intensity hue saturation)
-		    :intensity intensity :hue hue :saturation saturation)
+  :intensity intensity :hue hue :saturation saturation)
 
 (defmethod make-load-form ((color ihs-color))
   (with-slots (intensity hue saturation) color
@@ -91,7 +92,7 @@
      (layered-color-cache :reader palette-layered-color-cache
 			  :initform (make-hash-table))
      (delayed-recolors :reader palette-delayed-recolors
-			  :initform (make-array 32 :adjustable t :fill-pointer 0))))
+		       :initform (make-array 32 :adjustable t :fill-pointer 0))))
 
 (defgeneric make-palette (port &key))
 
@@ -113,7 +114,7 @@
 	       :accessor dynamic-color-palettes)))
 
 (define-constructor make-dynamic-color dynamic-color (color) 
-		    :color color)
+  :color color)
 
 (defmethod make-load-form ((color dynamic-color))
   (with-slots (color) color
@@ -123,23 +124,26 @@
 ;;; Layered Colors
 
 (defclass layered-color-set ()
-    ((layers :initform nil :reader layered-color-set-layers :initarg :layers)
-     (cache :initform (make-hash-table :test #'equal) :reader layered-color-set-cache)
-     (dynamic-array :reader layered-color-set-dynamic-array :initarg :dynamic-array)))
+    ((layers :initform nil :initarg :layers
+	     :reader layered-color-set-layers)
+     (cache :initform (make-hash-table :test #'equal)
+	    :reader layered-color-set-cache)
+     (dynamic-array :initarg :dynamic-array
+		    :reader layered-color-set-dynamic-array)))
 
 (define-constructor make-layered-color-set layered-color-set (&rest layers)
-		    :layers layers
-		    :dynamic-array (make-array layers))
+  :layers (copy-list layers)
+  :dynamic-array (make-array layers))
 
 (defgeneric layered-color (layered-color-set &rest layers))
 
 (defclass layered-color (design)
-    ((set :reader layered-color-set :initarg :set)
-     (layers :initform nil :reader layered-color-layers :initarg :layers)
-     (dynamics :initform nil))) 
+    ((set :initarg :set :reader layered-color-set)
+     (layers :initarg :layers :initform nil :reader layered-color-layers)
+     (dynamic-colors :initform nil))) 
    
 (define-constructor make-layered-color layered-color (set layers)
-		    :set set :layers layers)
+  :set set :layers layers)
 
 
 ;;; Foreground and background (indirect) inks
@@ -163,7 +167,7 @@
      (design2 :type design :initarg :design2)))
 
 (define-constructor make-flipping-ink-1 flipping-ink (design1 design2)
-		    :design1 design1 :design2 design2)
+  :design1 design1 :design2 design2)
 
 (defmethod make-load-form ((design flipping-ink))
   (with-slots (design1 design2) design
@@ -177,7 +181,7 @@
      (which-one :type integer :initarg :which-one)))
 
 (define-constructor make-contrasting-ink-1 contrasting-ink (which-one how-many)
-		    :which-one which-one :how-many how-many)
+  :which-one which-one :how-many how-many)
 
 (defmethod make-load-form ((design contrasting-ink))
   (with-slots (which-one how-many) design
diff --git a/utils/clos.lisp b/utils/clos.lisp
index f273adee431e1cdc2ba5d3878c52061d0f369f47..b36df8b5e33b9e898fa666b7d244c97c00dfc55d 100644
--- a/utils/clos.lisp
+++ b/utils/clos.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clos.lisp,v 1.6 92/05/22 19:27:07 cer Exp $
+;; $fiHeader: clos.lisp,v 1.7 92/07/01 15:45:28 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -18,22 +18,26 @@
 ;;; hook into that mechanism.
 
 #+PCL
-(defmacro define-constructor (name class lambda-list &rest initialization-arguments)
-  `(pcl::defconstructor ,name ,class ,lambda-list ,@initialization-arguments))
+(defmacro define-constructor (name class lambda-list &body initargs)
+  `(pcl::defconstructor ,name ,class ,lambda-list ,@initargs))
 
 #+(and PCL (not VDPCL))
 (pushnew 'compile pcl::*defclass-times*)
 
 #+Allegro-v4.0-constructors
-(defmacro define-constructor (name class lambda-list &rest initialization-arguments)
-  `(clos::defconstructor ,name ,class ,lambda-list ,@initialization-arguments))
+(defmacro define-constructor (name class lambda-list &body initargs)
+  `(clos::defconstructor ,name ,class ,lambda-list ,@initargs))
 
 #-(or PCL Allegro-v4.0-constructors)
-(defmacro define-constructor (name class lambda-list &rest initialization-arguments)
-  `(progn
-     (eval-when (compile load eval) (proclaim '(inline ,name)))
-     (defun ,name ,lambda-list
-       (make-instance ',class ,@initialization-arguments))))
+;; NB: any &REST argument is declared to have dynamic extent!
+(defmacro define-constructor (name class lambda-list &body initargs)
+  (let ((rest-arg (member '&rest lambda-list)))
+    `(progn
+       (eval-when (compile load eval) (proclaim '(inline ,name)))
+       (defun ,name ,lambda-list
+	 ,@(when rest-arg
+	     `((declare (dynamic-extent ,(second rest-arg)))))
+	 (make-instance ',class ,@initargs)))))
 
 #+(and Genera PCL)
 (scl:defmethod (:fasd-form #-VDPCL pcl::std-instance #+VDPCL pcl::iwmc-class) ()
@@ -87,9 +91,9 @@
 	  (name class args &body tuples)
   `(define-group ,name define-constructor-using-prototype-instance
      (define-constructor ,name ,class ,args
-			 ,@(mapcan #'(lambda (tuple)
-				       (list (second tuple) (third tuple)))
-				   tuples))))
+       ,@(mapcan #'(lambda (tuple)
+		     (list (second tuple) (third tuple)))
+		 tuples))))
 
 
 
diff --git a/utils/designs.lisp b/utils/designs.lisp
index 7cf1a54f5051e87d2248ee35fde629b4dd371c1f..fa30145adc2cc769fef8c053df4b4bfccd3f395b 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.9 92/10/28 13:17:12 cer Exp $
+;; $fiHeader: designs.lisp,v 1.10 92/10/29 16:55:05 cer Exp $
 
 (in-package :clim-utils)
 
@@ -122,17 +122,27 @@
 (define-primary-color +yellow+  1 1 0)
 
 
-(defvar *default-named-color-table* (make-hash-table :test #+Genera #'string-equal
-							   #-Genera #'equalp))
+(defvar *default-named-color-table*
+	(make-hash-table :test #+(or Genera Cloe-Runtime) #'string-equal
+			       #-(or Genera Cloe-Runtime) #'equalp))
 
 (defmacro define-named-color (color-name r g b)
   `(setf (gethash ,color-name *default-named-color-table*)
 	 (make-rgb-color ,(/ r 255.0) ,(/ g 255.0) ,(/ b 255.0))))
 
+(define-condition color-not-found (error)
+  ((color :initarg :color :reader color-not-found-color))
+  (:report (lambda (condition stream)
+	     (format stream "The color named ~S was not found"
+	       (color-not-found-color condition)))))
+
 ;; Simplest possible palette returns canned, silly X Windows colors
-(defmethod find-named-color (name (palette basic-palette))
-  (let ((name (if (symbolp name) (symbol-name name) name)))
-    (values (gethash name *default-named-color-table*))))
+(defmethod find-named-color (name (palette basic-palette) &key (errorp t))
+  (let ((name (if (symbolp name) (symbol-name name) name))
+	(color (gethash name *default-named-color-table*)))
+    (if (and (null color) errorp)
+	(error 'color-not-found :color name)
+	color)))
 
 ;; Default values for named colors
 (define-named-color "snow"              255 250 250)
@@ -294,29 +304,36 @@
 (defmethod color-ihs ((color ihs-color))
   (with-slots (intensity hue saturation) color
     (values intensity hue saturation)))
+
 
-;;; Palettes 
+;;; Palettes
 
-(define-condition palette-full (serious-condition) ())
+(define-condition palette-full (error)
+  ((palette :initarg :palette :reader palette-full-palette))
+  (:report (lambda (condition stream)
+	     (format stream "The palette ~S is full"
+	       (palette-full-palette condition)))))
 
-(defmethod add-to-palette ((palette basic-palette) &rest colors)
+(defmethod add-colors-to-palette ((palette basic-palette) &rest colors)
+  (declare (dynamic-extent colors))
   (let ((colors-done nil))
     (dolist (color colors)
       (handler-case
-	  (progn
-	    (push color colors-done)
-	    (allocate-color color palette))
+	(progn
+	  (push color colors-done)
+	  (allocate-color color palette))
 	(palette-full (condition)
-	  (dolist (color colors-done)
-	    (free-color color palette))
-	  (error condition))))))
+	 (dolist (color colors-done)
+	   (deallocate-color color palette))
+	 (error condition))))))
 
-(defmethod remove-from-palette ((palette basic-palette) &rest colors)
+(defmethod remove-colors-from-palette ((palette basic-palette) &rest colors)
+  (declare (dynamic-extent colors))
   (dolist (color colors)
-    (free-color color palette)))
+    (deallocate-color color palette)))
 
 
-;;; Dynamic Colors 
+;;; Dynamic Colors
 
 (defmethod print-object ((color dynamic-color) stream)
   (print-unreadable-object (color stream :type t :identity t)
@@ -330,7 +347,7 @@
 
 (defvar *doing-delayed-recolors* nil)
 
-(defmethod recolor-dynamic ((dynamic-color dynamic-color) (color color))
+(defmethod recolor-dynamic-color ((dynamic-color dynamic-color) (color color))
   (if *doing-delayed-recolors*
       (dolist (palette (dynamic-color-palettes dynamic-color))
 	(let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette)))
@@ -338,13 +355,13 @@
 	  (without-scheduling
 	    (vector-push-extend cell recolors)
 	    (vector-push-extend color recolors))))
-    (dolist (palette (dynamic-color-palettes dynamic-color))
-      (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette))))
-	(update-palette-entry palette cell color)))))
+      (dolist (palette (dynamic-color-palettes dynamic-color))
+	(let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette))))
+	  (update-palette-entry palette cell color)))))
 
 (defmethod (setf dynamic-color-color) :after
 	   ((color color) (dynamic-color dynamic-color))
-  (recolor-dynamic dynamic-color color))
+  (recolor-dynamic-color dynamic-color color))
 
 ;; Note that the actual color recoloring occurs on exiting the outermost
 ;; call to WITH-DELAYED-RECOLORING
@@ -380,10 +397,10 @@
 			 (progn 
 			   (setf (car dims) layer)
 			   (iterate rest-layers rest-set-layers rest-dims))
-		       (dotimes (i set-layer)
-			 (setf (car dims) i)
-			 (iterate rest-layers rest-set-layers rest-dims))))
-		 (funcall function dimensions))))
+			 (dotimes (i set-layer)
+			   (setf (car dims) i)
+			   (iterate rest-layers rest-set-layers rest-dims))))
+		   (funcall function dimensions))))
       (iterate layers set-layers dimensions))))
 
 (defmethod initialize-instance :after ((set layered-color-set) &key dynamic-array)
@@ -402,26 +419,25 @@
 		(make-layered-color set layers))))))
 
 (defmethod (setf layered-color-color) 
-    ((color color) (layered-color layered-color))
+	   ((color color) (layered-color layered-color))
   (with-delayed-recoloring
-      (dolist (dynamic-color (layered-color-dynamics layered-color))
-	(setf (dynamic-color-color dynamic-color) color))))
+    (dolist (dynamic-color (layered-color-dynamic-colors layered-color))
+      (setf (dynamic-color-color dynamic-color) color))))
   
-;; LAYERED-COLOR-DYNAMICS should not be exported to the user.  It is important
-;; that these dynamics are not drawn with.  Instead the fully specified layered
-;; colors should be used
-(defmethod layered-color-dynamics ((layered-color layered-color))
-  (with-slots (set layers dynamics) layered-color
-    (or dynamics
-	(setf dynamics
-	  (let ((dynamic-array (layered-color-set-dynamic-array set))
-		dynamics)
-	    (map-over-layered-colors 
-	     #'(lambda (dimensions)
-		 (push (apply #'aref dynamic-array dimensions) dynamics))
-	     set
-	     layers)
-	    dynamics)))))
+;; LAYERED-COLOR-DYNAMIC-COLORS should not be exported to the user.  It
+;; is important that these dynamics are not drawn with.  Instead, the
+;; fully specified layered is used.
+(defmethod layered-color-dynamic-colors ((layered-color layered-color))
+  (with-slots (set layers dynamic-colors) layered-color
+    (or dynamic-colors
+	(setf dynamic-colors
+	      (let ((dynamic-array (layered-color-set-dynamic-array set))
+		    (dynamics nil))
+		(map-over-layered-colors 
+		  #'(lambda (dimensions)
+		      (push (apply #'aref dynamic-array dimensions) dynamics))
+		  set layers)
+		dynamics)))))
 
 
 ;;; Foreground and background (indirect) inks
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index b6960f3b11505fb59d1aea4b2f57d505d8b0e4fb..f25fa9779d08a3a2e5006bba2ee675b821d971e0 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: lisp-utilities.lisp,v 1.20 92/10/02 15:18:50 cer Exp $
+;; $fiHeader: lisp-utilities.lisp,v 1.21 92/10/28 11:31:05 cer Exp $
 
 (in-package :clim-utils)
 
@@ -1223,10 +1223,17 @@
 (defun realp (x)
   (typep x 'real))
 
+#+(or Allegro Cloe-Runtime)
+(deftype eql (x) `(member ,x))
+
 (defconstant *end-of-file-marker* :eof)
 (deftype end-of-file-marker () 
-  #+Allegro '(member :eof)
-  #-Allegro '(eql :eof))
+  '(eql :eof))
+
+#+Cloe-Runtime
+(defmacro load-time-value (form &optional read-only-p)
+  (declare (ignore read-only-p))
+  form)
 
 
 ;;; Use a lambda-list to extract arguments from a list and bind variables.
diff --git a/utils/packages.lisp b/utils/packages.lisp
index c2be0da98b142f2cd10d7cd4f50ca8382d68a5bb..c2edca7685c7fd3d501f4438541d85343fad6e8b 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.35 92/10/28 13:17:14 cer Exp $
+;; $fiHeader: packages.lisp,v 1.36 92/10/29 16:55:06 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2023,23 +2023,24 @@
     +foreground-ink+
     color
     color-ihs
+    color-not-found
     color-rgb
     colorp
     contrasting-inks-limit
     design
     designp
+    dynamic-color-color
     find-named-color
     layered-color
     layered-color-color
-    make-layered-color-set
     make-contrasting-inks
+    make-dynamic-color
     make-flipping-ink
     make-gray-color
     make-ihs-color
-    make-dynamic-color
+    make-layered-color-set
     make-opacity
     make-rgb-color
-    dynamic-color-color
     opacity
     opacity-value
     opacityp
@@ -2058,18 +2059,18 @@
     pattern-width
     
     ;; Palettes
+    add-color-to-palette
     frame-manager-palette
     frame-palette
     make-palette
     palette
     palette-color-p
     palette-dynamic-p
+    palette-full
     palettep
     port-default-palette
-    palette-full
-    add-to-palette
-    remove-from-palette
-    
+    remove-color-from-palette
+
     ;; Extended output
     beep
     cursor
@@ -2123,6 +2124,7 @@
     copy-textual-output-history
     delete-output-record
     displayed-output-record
+    displayed-output-record-ink
     displayed-output-record-p
     erase-output-record
     graphics-displayed-output-record
@@ -2388,6 +2390,7 @@
     highlight-presentation
     highlight-presentation-method
     integer
+    input-context-type
     keyword
     list-pane-view
     make-presentation-type-specifier
@@ -2657,6 +2660,7 @@
     frame-drag-and-drop-highlighting
     frame-error-output
     frame-exit
+    frame-exit-frame
     frame-find-innermost-applicable-presentation
     frame-input-context-button-press-handler
     frame-maintain-presentation-histories
@@ -2720,7 +2724,6 @@
     ;; Meta-frames, aka activities
     *activity*
     activity
-    activity-exit
     activity-frame
     activity-frame-window-close
     activity-frame-window-select
@@ -2940,7 +2943,6 @@
     translate-positions
     viewport-to-drawing-surface-coordinates
     window-children
-    window-clear-area
     window-expose
     window-inside-bottom
     window-inside-edges
@@ -2953,10 +2955,8 @@
     window-label
     window-label-size
     window-margins
-    window-name
     window-parent
     window-root
-    window-set-inside-edges
     window-set-inside-size
     window-stack-on-bottom
     window-stack-on-top
@@ -3021,7 +3021,7 @@
     graphic-char-p
     alpha-char-p)
 
-  #+(and ANSI-90 Genera)
+  #+(or (and ANSI-90 Genera) Cloe-Runtime)
   (:import-from lisp
     string-char
     char-bits)
@@ -3029,7 +3029,7 @@
   (:shadowing-import-from cltl1
     string-char
     char-bits)
-  #+(or Allegro (and ANSI-90 Genera))
+  #+(or Allegro (and ANSI-90 Genera) Cloe-Runtime)
   (:export
     string-char
     char-bits)
@@ -3155,7 +3155,7 @@
     delete-timer
     make-timer
 
-    ;; From PROTOCOLS
+    ;; From PROTOCOLS, DEFPROTOCOL, and CLIM-STREAMS
     *outer-self*
     define-protocol-class
     define-slot-trampoline-template
@@ -3163,6 +3163,7 @@
     defoperation
     defprotocol
     defrole
+    encapsulated-stream
     find-protocol
     find-role 
     generate-trampolines
@@ -3248,37 +3249,37 @@
     *all-palettes*
     allocate-color
     basic-palette
-    layered-color-set
-    layered-color-set-layers
-    layered-color-set-dynamic-array
     color-luminosity
     composite-in
     composite-out
     composite-over
     contrasting-ink
     contrasting-ink-index
+    deallocate-color
     decode-flipping-ink
     decode-pattern
     decode-rectangular-tile
     decode-tile-as-stipple
+    dynamic-color
+    dynamic-color-palettes
+    flipping-ink
     flipping-ink
-    flipping-ink 
-    free-color
     gray-color
     gray-color-luminosity
-    layered-color-layers
     ihs-color
+    layered-color-layers
+    layered-color-set
+    layered-color-set-layers
+    layered-color-set-dynamic-array
     make-color-for-contrasting-ink
     make-design-from-output-record
     make-flipping-ink
     make-gray-color-for-contrasting-ink
-    map-over-layered-colors    
-    dynamic-color
-    dynamic-color-palettes
+    map-over-layered-colors
     palette-color-cache
+    palette-delayed-recolors
     palette-dynamic-color-cache
     palette-layered-color-cache
-    palette-delayed-recolors
     pattern
     rectangular-tile
     rgb-color
@@ -3391,6 +3392,8 @@
     gadget-supplied-scrolling
     gadget-visible-items
     generic-label-pane
+    generic-list-pane
+    generic-option-pane
     generic-scroller-pane
     get-drawing-function-description
     graft-mm-height
diff --git a/utils/protocols.lisp b/utils/protocols.lisp
index 1316a1be6088dcbac7cd371ae566fcf4187618b9..4f12c01c6f5049736bc1e18c981ee35a3b2a8f46 100644
--- a/utils/protocols.lisp
+++ b/utils/protocols.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: protocols.lisp,v 1.3 92/02/24 13:05:50 cer Exp $
+;; $fiHeader: protocols.lisp,v 1.4 92/07/01 15:45:43 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -195,6 +195,8 @@
 				 (setf (,writer ,player-var) (values ,@values-vars)))))))))))
 	     (role-slots (find-role role-name)))))))
 
+;; If you change this to maintain a more complex mapping than a simple
+;; binding of *ORIGINAL-STREAM*, change ENCAPSULATED-STREAM too.
 (defmacro generate-trampolines (protocol-name role-name role-player delegate-form
 				&optional (outer-self '*outer-self*))
   `(progn
diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp
index 7b9d4429b471fd2cbf662cf94f4f46836f7aec4a..6359faa5026bd662492da21323601634da7faa6a 100644
--- a/utils/region-arithmetic.lisp
+++ b/utils/region-arithmetic.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: region-arithmetic.lisp,v 1.7 92/05/07 13:11:43 cer Exp $
+;; $fiHeader: region-arithmetic.lisp,v 1.8 92/07/20 15:59:44 cer Exp $
 
 (in-package :clim-utils)
 
@@ -12,7 +12,7 @@
     ((regions :type list :initarg :regions)))
 
 (define-constructor make-region-union-1 standard-region-union (regions)
-		    :regions regions)
+  :regions regions)
 
 (defun make-region-union (&rest regions)
   (declare (dynamic-extent regions))
@@ -72,7 +72,7 @@
     ((regions :type list :initarg :regions)))
 
 (define-constructor make-region-intersection-1 standard-region-intersection (regions)
-		    :regions regions)
+  :regions regions)
 
 (defun make-region-intersection (&rest regions)
   (declare (dynamic-extent regions))
@@ -128,7 +128,7 @@
      (regions :type list)))
 
 (define-constructor make-region-difference standard-region-difference
-  (region1 region2)
+		    (region1 region2)
   :region1 region1 :region2 region2)
 
 (defmethod region-set-function ((region standard-region-difference)) 'set-difference)
@@ -341,8 +341,8 @@
 
 (define-constructor make-rectangle-set-1 standard-rectangle-set
 		    (rectangles left top right bottom)
-		    :rectangles rectangles
-		    :left left :top top :right right :bottom bottom)
+  :rectangles rectangles
+  :left left :top top :right right :bottom bottom)
 
 (defun make-rectangle-set (&rest rectangles)
   (declare (dynamic-extent rectangles))