From f457a34a3bcff76025c68f6adf643177cf4f4670 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Thu, 2 Jan 1992 15:12:33 +0000
Subject: [PATCH] fixes

---
 Makefile                        |  12 ++
 clim/accept-values.lisp         | 123 ++++++++++----------
 clim/clim-defs.lisp             |  13 +++
 clim/db-stream.lisp             |  24 +++-
 clim/frames.lisp                | 100 ++++++++++------
 clim/graph-formatting.lisp      |  15 +--
 clim/input-protocol.lisp        |   7 +-
 clim/menus.lisp                 |  22 +++-
 clim/output-protocol.lisp       |   3 +-
 clim/output-recording-defs.lisp | 172 +++++++++++++++++++++++----
 clim/stream-defprotocols.lisp   |  23 +++-
 clim/surround-output.lisp       |  25 ++--
 clim/sysdcl.lisp                |   2 +
 clim/table-formatting.lisp      | 108 +++++++++--------
 clim/text-output-recording.lisp |  32 +++---
 misc/go.lisp                    |   8 +-
 notes/plan.todo                 | 126 ++------------------
 silica/classes.lisp             |   5 +-
 silica/clim.lisp                |   5 +-
 silica/db-box.lisp              |   8 +-
 silica/db-layout.lisp           |  75 +++++++++---
 silica/db-table.lisp            |  19 +--
 silica/defsys.lisp              |   3 +
 silica/event.lisp               |   5 +-
 silica/graphics.lisp            |  46 +++++---
 silica/medium.lisp              | 126 ++++++++++++++++++--
 silica/mirror.lisp              |   6 +-
 silica/pkg.lisp                 |   5 +-
 silica/port.lisp                |   6 +-
 silica/protocols.lisp           |   1 +
 silica/sheet.lisp               |   5 +-
 silica/std-sheet.lisp           |   6 +-
 silica/sysdcl.lisp              |  35 ------
 silica/text-style.lisp          |  17 ++-
 test/test-suite.lisp            |  42 +++++--
 test/test.lisp                  |  19 +++
 tk-silica/image.lisp            |  25 ++++
 tk-silica/pkg.lisp              |   2 +
 tk-silica/sysdcl.lisp           |  10 +-
 tk-silica/xm-frames.lisp        |  21 +++-
 tk-silica/xm-gadgets.lisp       |  37 +++---
 tk-silica/xm-graphics.lisp      | 198 +++++++++++++++++++++++++-------
 tk-silica/xm-silica.lisp        |  39 +++++--
 tk/callbacks.lisp               |  24 ++++
 tk/convenience.lisp             |  24 ++++
 tk/defsys.lisp                  |  24 ++++
 tk/event.lisp                   |  24 ++++
 tk/examples.lisp                |  24 ++++
 tk/font.lisp                    |  24 ++++
 tk/foreign-obj.lisp             |  24 ++++
 tk/gcontext.lisp                |  48 ++++++--
 tk/graphics.lisp                |  71 ++++++++++++
 tk/init.lisp                    |  24 ++++
 tk/load-ol.lisp                 |  24 ++++
 tk/load-xm.lisp                 |  24 ++++
 tk/loadit.lisp                  |  24 ++++
 tk/macros.lisp                  |  24 ++++
 tk/make-classes.lisp            |  24 ++++
 tk/ol-examples.lisp             |  24 ++++
 tk/ol-init.lisp                 |  24 ++++
 tk/pkg.lisp                     |  24 ++++
 tk/resources.lisp               |  33 +++++-
 tk/widget.lisp                  |  31 +++++
 tk/xlib.lisp                    | 101 +++++++++++++++-
 tk/xm-init.lisp                 |  24 ++++
 tk/xm-protocols.lisp            |  24 ++++
 tk/xm-widgets.lisp              |  24 ++++
 tk/xtk.lisp                     |  24 ++++
 utils/condpat.lisp              |   1 +
 utils/defun-utilities.lisp      |   1 +
 utils/reader.lisp               |   1 +
 utils/regions.lisp              |  75 +++++++-----
 72 files changed, 1870 insertions(+), 553 deletions(-)
 delete mode 100644 silica/sysdcl.lisp

diff --git a/Makefile b/Makefile
index 97bac99b..2f2bf087 100644
--- a/Makefile
+++ b/Makefile
@@ -16,3 +16,15 @@ FRC :
 
 swm-tape:
 	tar cf $(DEVICE) `find misc $(SOMEDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print`
+
+xm-composer:
+	cd tk ; $(MAKE) xm-composer
+
+xm-dcl:
+	cd tk ; $(MAKE) xm-dcl
+
+# For the day the make dist happens.
+
+echo_src_files:
+	@find . '(' -name '*.cl' -o -name '*.lisp' ')' -print
+
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index e83529ed..76ac8593 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -19,7 +19,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: accept-values.lisp,v 1.10 91/08/05 13:25:15 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.1 91/11/25 10:00:56 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -190,6 +190,23 @@ Copyright (c) 1991, Franz Inc. All rights reserved
   (:top-level (accept-values-top-level))
   (:command-definer t))
 
+(define-application-frame accept-values-own-window (accept-values)
+  ()
+  (:pane 
+   (with-slots (stream own-window) *application-frame*
+     (silica::scrolling ()
+			(progn
+			  (setq stream
+			    (make-instance 'avv-stream
+					   :stream
+					   (setf own-window
+					     (silica::realize-pane 'extended-stream-pane
+								   :initial-cursor-visibility nil
+								   ))))
+			  own-window))))
+  (:command-table accept-values)
+  (:command-definer nil))
+
 ;; So the continuation can run with the proper value of *APPLICATION-FRAME*
 (defvar *avv-calling-frame*)
 
@@ -202,69 +219,46 @@ Copyright (c) 1991, Franz Inc. All rights reserved
   (let ((the-own-window nil)
 	(right-margin 10)
 	(bottom-margin 10))
-    (unwind-protect
-	(progn
-	  (when own-window
-	    #+Silica
-	    (error "Own-window AVV not supported yet.")
-	    (setq the-own-window
-		  (allocate-resource 'menu stream (window-root stream)))
-	    ;;--- make the window big.  We shouldn't have to do this.
-	    (multiple-value-bind (width height)
-		(window-inside-size (slot-value the-own-window 'parent))
-	      (bounding-rectangle-set-size the-own-window width height))
-	    (setf (window-label the-own-window) label)
-	    (when (listp own-window)
-	      (setf right-margin
-		    (process-spacing-arg the-own-window (getf own-window :right-margin 10)
-					 'accepting-values :right-margin))
-	      (setf bottom-margin
-		    (process-spacing-arg the-own-window (getf own-window :bottom-margin 10)
-					 'accepting-values :bottom-margin))))
-	  
-	  (clim-utils::using-resource (avv-stream avv-stream (or the-own-window stream))
-	    ;;--- This should resource the AVV application frame, too
-	    (let ((frame 
-		    #+Silica
-		    (make-application-frame (or frame-class 'accept-values)
-					    :stream avv-stream
-					    :continuation continuation
-					    :exit-boxes exit-boxes
-					    :own-window the-own-window
-					    :x-position x-position
-					    :y-position y-position
-					    :right-margin right-margin
-					    :bottom-margin bottom-margin
-					    :initially-select-query-identifier
-					      initially-select-query-identifier
-					    :resynchronize-every-pass
-					      resynchronize-every-pass
-					    :check-overlapping check-overlapping)
-		    #-Silica
-		    (make-application-frame 'accept-values
-					    :parent (slot-value avv-stream 'stream)
-					    :frame-class frame-class
-					    :stream avv-stream
-					    :exit-boxes exit-boxes
-					    :continuation continuation
-					    :own-window the-own-window
-					    :x-position x-position
-					    :y-position y-position
-					    :right-margin right-margin
-					    :bottom-margin bottom-margin
-					    :initially-select-query-identifier
-					      initially-select-query-identifier
-					    :resynchronize-every-pass
-					      resynchronize-every-pass
-					    :check-overlapping check-overlapping)))
-	      (when (silica::frame-top-level-sheet frame)
-		(window-expose (frame-top-level-window frame)))
-	      ;; Run the AVV and return its values
-	      (let ((*avv-calling-frame* *application-frame*))
-		(run-frame-top-level frame)))))
-      (when (and the-own-window (windowp the-own-window))
-	;; Deallocate menu resources deexposes them for us
-	(deallocate-resource 'menu the-own-window)))))
+    (if own-window
+	(let ((frame (make-application-frame (or frame-class 'accept-values-own-window)
+						 :continuation continuation
+						 :exit-boxes exit-boxes
+						 :own-window the-own-window
+						 :x-position x-position
+						 :y-position y-position
+						 :right-margin right-margin
+						 :bottom-margin bottom-margin
+						 :initially-select-query-identifier
+						 initially-select-query-identifier
+						 :resynchronize-every-pass
+						 resynchronize-every-pass
+						 :check-overlapping
+						 check-overlapping)))
+	  ;; What do we do about sizing?????
+	  ;; What do we do about positioning????
+	  (let ((*avv-calling-frame* *application-frame*))
+	    (run-frame-top-level frame)))
+      (clim-utils::using-resource (avv-stream avv-stream (or the-own-window stream))
+				  ;;--- This should resource the AVV application frame, too
+				  (let ((frame 
+					 (make-application-frame (or frame-class 'accept-values)
+								 :stream avv-stream
+								 :continuation continuation
+								 :exit-boxes exit-boxes
+								 :own-window the-own-window
+								 :x-position x-position
+								 :y-position y-position
+								 :right-margin right-margin
+								 :bottom-margin bottom-margin
+								 :initially-select-query-identifier
+								 initially-select-query-identifier
+								 :resynchronize-every-pass
+								 resynchronize-every-pass
+								 :check-overlapping
+								 check-overlapping)))
+				    ;; Run the AVV and return its values
+				    (let ((*avv-calling-frame* *application-frame*))
+				      (run-frame-top-level frame)))))))
 
 (defmethod accept-values-top-level ((frame accept-values) &rest args)
   (declare (ignore args))
@@ -327,6 +321,7 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 						  (with-end-of-page-action (:allow stream)
 						    (with-new-output-record (stream 'avv-output-record avv-record)
 						      (run-continuation stream avv-record)))))))
+			   #+ignore
 			   (replay avv stream)
 			   (unwind-protect
 			       (cond (own-window
diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp
index 052fe5de..c6b0e0a8 100644
--- a/clim/clim-defs.lisp
+++ b/clim/clim-defs.lisp
@@ -397,3 +397,16 @@
 			  :transformation (make-rotation-transformation ,angle
 									,@(if origin-p `(,origin) nil)))
      ,@body))
+
+(defmacro with-local-coordinates ((&optional stream) &body body)
+  (default-output-stream stream with-local-coordinates)
+  (let (( x '#:x)  ( y '#:y)
+	(tx '#:tx) (ty '#:ty))
+    `(multiple-value-bind (,x ,y)
+	 (stream-cursor-position* ,stream)
+       (multiple-value-bind (,tx ,ty)
+	   (transform-point* (medium-transformation ,stream) 0 0)
+	 (with-drawing-options
+	     (,stream :transformation (make-translation-transformation
+					(- ,x ,tx) (- ,y ,ty)))
+	   ,@body)))))
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index cb2edb48..163f3d66 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -82,9 +82,22 @@
 				 )
 	  ()
   (:default-initargs :medium t 
-		     :max-width +fill+ :min-width 0 :max-height +fill+ :min-height 0))
-
-
+    ;;:max-width +fill+ :min-width 0 :max-height +fill+ :min-height 0
+    ))
+
+(defmethod silica::default-space-requirements ((pane extended-stream-sheet)
+					       &key
+					       (width 0 widthp)
+					       (min-width width)
+					       (max-width
+						(if widthp width
+						  +fill+))
+					       (height 0 heightp)
+					       (min-height height)
+					       (max-height
+						(if heightp height +fill+)))
+
+  (values width min-width max-width height min-height max-height))
 
 ;;; We should straighten this out so that this can be
 ;;; subclass of LEAF-PANE.  Then it would get
@@ -151,7 +164,10 @@
     (apply #'call-next-method pane :width (max width history-width) :height (max height history-height) keys)))
 
 (defclass basic-clim-interactor (extended-stream-pane) 
-	  ((display-function :initarg :display-function
+	  ((incremental-redisplay-p
+	    :initarg :incremental-redisplay
+	    :initform nil)
+	   (display-function :initarg :display-function
 			     :initform nil
 			     :reader pane-display-function)
 	   (display-time :initarg :display-time
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 0cfb6e9f..b58e812e 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -38,8 +38,8 @@
    (panes :initarg :panes :accessor frame-panes)
    (top-level-sheet :accessor frame-top-level-sheet :initform nil)
    (shell :accessor frame-shell)
-   (state :initform :disabled :accessor frame-state 
-	  :type (member :disabled :enable :disabled :shrunk))
+   (state :initform :disowned :accessor frame-state 
+	  :type (member :disowned :disabled :enabled :shrunk))
    (command-table :initarg :command-table 
 		  :initform (find-command-table 'user-command-table)
 		  :accessor frame-command-table)
@@ -154,9 +154,21 @@
   (ecase (frame-state frame)
     (:enabled)
     ((:disabled :disowned)
-     (setf (frame-state frame) :enabled)
-     (layout-frame frame)
-     (note-frame-enabled (frame-manager frame) frame))))
+     (let ((old (frame-state frame)))
+       (setf (frame-state frame) :enabled)
+       ;; IF this is a new frame then if the user specified a width
+       ;; then we should be using that
+       ;; IF the frame already exists then we probably should be using
+       ;; the top level sheet size
+       (multiple-value-call
+	   #'layout-frame 
+	 frame
+	 (ecase old
+	   (:disowned (values))
+	   (:disabled
+	    (bounding-rectangle-size
+	     (frame-top-level-sheet frame)))))
+       (note-frame-enabled (frame-manager frame) frame)))))
 
 (defmethod disable-frame ((frame application-frame))
   (ecase (frame-state frame)
@@ -166,15 +178,16 @@
      (note-frame-disabled (frame-manager frame) frame))))
 
 (defmethod layout-frame ((frame application-frame) &optional width height)
-  (unless (and width height)
-    (let ((sr (compose-space (frame-panes frame))))
-      (setq width (silica::space-req-width sr)
-	    height (silica::space-req-height sr))))
-  (allocate-space (frame-panes frame) width height)
-  #+shouldwebedoingthiskindofthing?
-  (when (frame-top-level-sheet frame)
-    (silica::resize-sheet* (frame-top-level-sheet frame)
-			   width height)))
+  (when (frame-panes frame)
+    (unless (and width height)
+      (let ((sr (compose-space (frame-panes frame))))
+	(setq width (silica::space-req-width sr)
+	      height (silica::space-req-height sr))))
+    (allocate-space (frame-panes frame) width height)
+    ;; This is quite likely not going to work
+    (when (frame-top-level-sheet frame)
+      (silica::resize-sheet* (frame-top-level-sheet frame)
+			     width height))))
 
 (defun make-application-frame (class &rest options &key enable &allow-other-keys)
   (with-rem-keywords (options options '(:enable))
@@ -194,18 +207,22 @@
       (call-next-method))))
 
 (defmethod run-frame-top-level ((frame application-frame))
-  (unless (eq (frame-state frame) :enabled)
-    (enable-frame frame))
-  (let ((tl (frame-top-level frame)))
-    (if (atom tl)
-	(funcall tl frame)
-      (apply (car tl) frame (cdr tl)))))
+  (unwind-protect
+      (progn
+	(let ((tl (frame-top-level frame)))
+	  (if (atom tl)
+	      (funcall tl frame)
+	    (apply (car tl) frame (cdr tl)))))
+    (disable-frame frame)))
 
 (defun command-enabled-p (command frame) t)
 				
 (defmethod default-frame-top-level (frame
 				    &key command-parser command-unparser partial-command-parser
 					 (prompt "Command: "))
+  
+  (unless (eq (frame-state frame) :enabled)
+    (enable-frame frame))
   (let* ((*standard-output* (or (frame-standard-output frame) *standard-output*))
 	 (*query-io* (or (frame-query-io frame) *query-io*))
 	 (interactor (find-frame-pane-of-type frame 'interactor-pane))
@@ -224,18 +241,19 @@
 		  #'command-line-read-remaining-arguments-for-partial-command
 		#'menu-only-read-remaining-arguments-for-partial-command))))
     (loop
-      (redisplay-frame-panes frame)
-      (when interactor
-	(fresh-line *standard-input*)
-	(if (stringp prompt)
-	    (write-string prompt *standard-input*)
-	  (funcall prompt *standard-input* frame)))
-      (let ((command (read-frame-command frame :stream *standard-input*)))
+      (clim-utils::with-simple-abort-restart ("Abort Command")
+	(redisplay-frame-panes frame)
 	(when interactor
-	  (terpri *standard-input*))
-	;; Need this check in case the user aborted out of a command menu
-	(when command
-	  (execute-frame-command frame command))))))
+	  (fresh-line *standard-input*)
+	  (if (stringp prompt)
+	      (write-string prompt *standard-input*)
+	    (funcall prompt *standard-input* frame)))
+	(let ((command (read-frame-command frame :stream *standard-input*)))
+	  (when interactor
+	    (terpri *standard-input*))
+	  ;; Need this check in case the user aborted out of a command menu
+	  (when command
+	    (execute-frame-command frame command)))))))
 
 (defmethod redisplay-frame-panes (frame &key force-p)
   (map-over-sheets #'(lambda (sheet)
@@ -245,9 +263,23 @@
 		   (frame-top-level-sheet frame)))
 
 (defun redisplay-frame-pane (frame pane &key force-p)
-  (declare (ignore frame force-p))
   (when (pane-display-function pane)
-    (invoke-pane-redisplay-function frame pane)))
+    (let* ((ird (slot-value pane 'incremental-redisplay-p))
+	   (history 
+	    (and ird 
+		 (output-recording-stream-output-record pane)))
+	   (record (and history
+			(> (output-record-count history) 0)
+			(output-record-element history 0))))
+      (cond ((and ird (or force-p (null record)))
+	     (when force-p
+	       (window-clear pane))
+	     (updating-output (pane)
+			      (invoke-pane-redisplay-function frame pane)))
+	    (ird
+	     (redisplay record pane))
+	    (t
+	     (invoke-pane-redisplay-function frame pane))))))
 
 (defun invoke-pane-redisplay-function (frame pane)
   (let ((fn (pane-display-function pane)))
@@ -256,8 +288,10 @@
       (apply (car fn) frame pane (cdr fn)))))
 			 
 (defun execute-frame-command (frame command)
+  (declare (ignore frame))
   (apply (command-name command) (command-arguments command)))
 
+
 (defun frame-find-innermost-applicable-presentation (frame
 							   input-context 
 							   history-window px py)
diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp
index bc5b61c5..fe0cd772 100644
--- a/clim/graph-formatting.lisp
+++ b/clim/graph-formatting.lisp
@@ -1,13 +1,13 @@
 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graph-formatting.lisp,v 1.7 91/08/05 14:29:31 cer Exp $
+;; $fiHeader: graph-formatting.cl,v 1.1 91/12/17 13:58:42 cer Exp Locker: cer $
 
 (in-package :clim)
 
 "Copyright (c) 1989, 1990 International Lisp Associates.  All rights reserved."
 "Copyright (c) 1991, Franz Inc. All rights reserved"
 
-(defclass graph-output-record (linear-output-record)
+(defclass graph-output-record (standard-sequence-output-record)
      ((orientation :initarg :orientation)
       (generation-separation :initarg :generation-separation)
       (within-generation-separation :initarg :within-generation-separation)
@@ -18,14 +18,14 @@
 ;;--- This really needs its own AUGMENT-DRAW-SET method.
 (defmethod elements-never-overlap-p ((record graph-output-record)) t)
 
-(defclass graph-node-output-record (linear-output-record)
+(defclass graph-node-output-record (standard-sequence-output-record)
      ((node-children :accessor graph-node-children)
       (node-parent :accessor graph-node-parent))
   (:default-initargs :size 5))
 
 (define-output-record-constructor graph-node-output-record
-				  (&key x-position y-position (size 25))
-  :x-position x-position :y-position y-position :size size)
+				  (&key (size 25))
+   :size size)
 
 ;;; (Copy of the comment in table-formatting)
 ;;; Cells have been positioned manually, probably.
@@ -184,10 +184,11 @@
 (defun layout-graph-edges (graph stream)
   (let ((orientation (slot-value graph 'orientation)))
     (with-output-recording-options (stream :draw-p nil :record-p t)
-      (with-new-output-record (stream 'linear-output-record nil
+      (with-new-output-record (stream 'standard-sequence-output-record nil
 			       :parent graph)
 	(multiple-value-bind (xoff yoff)
-	    (convert-from-relative-to-absolute-coordinates
+	    (values 0 0)
+	    #+ignore(convert-from-relative-to-absolute-coordinates
 	      stream (output-record-parent graph))
 	  (labels ((draw-edges (parent)
 		     (multiple-value-bind (parent-x parent-y)
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 6df4b8f4..ba4e2dae 100644
--- a/clim/input-protocol.lisp
+++ b/clim/input-protocol.lisp
@@ -101,7 +101,7 @@
 
 (defmethod stream-set-cursor-position* :after ((stream input-protocol-mixin)
 					       x y)
-  (when (minusp x) (break "dunno"))
+  (when (minusp x) (warn "negative cursor x"))
   (let ((cursor (stream-text-cursor stream)))
     (when cursor
       (entity-set-position cursor x y))))
@@ -450,7 +450,10 @@
 ;;; Ok, there's still an issue.  Just how do we want to handle this, given
 ;;; that it's non-trivial to turn a character back into a key-press event.
 ;;; This issue is still pending.
-#+Ignore
+
+(warn "bogus")
+(defparameter *abort-characters* '(#\control-z #\^z))
+
 (defmethod receive-gesture :around ((stream input-protocol-mixin) (gesture character))
   (when (member gesture *abort-characters*)
     (abort))
diff --git a/clim/menus.lisp b/clim/menus.lisp
index ed883b0d..66d2e4a2 100644
--- a/clim/menus.lisp
+++ b/clim/menus.lisp
@@ -256,7 +256,7 @@
     (cond ((and old-output-history-info
 		(setq old-menu-contents (pop old-output-history-info))
 		(funcall cache-value-test old-output-history-info cache-value))
-	   (add-output-record menu old-menu-contents))
+	   (stream-add-output-record menu old-menu-contents))
 	  (t
 	   ;; "Draw" into deexposed menu for sizing only
 	   (with-output-recording-options (menu :draw-p nil :record-p t)
@@ -470,5 +470,25 @@
 	(setf y (max min-y (min y (- max-y height))))))
     (move-frame frame x y)))
 
+(warn "where should these be")
+
 (defmethod clim-internals::window-refresh (window)
   (warn "What does this do???"))
+
+
+(defmethod window-viewport-position* (window)
+  (bounding-rectangle*
+   (pane-viewport-region window)))
+
+
+(defmethod window-set-viewport-position* (window x y)
+  (scroll-extent window :x x :y y))
+
+(defmethod window-inside-size (window)
+  (bounding-rectangle-size (pane-viewport-region window)))
+
+(defun windowp (x)
+  (typep x 'silica::sheet))
+
+(defmethod (setf window-label) (nv window)
+  nil)
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index c2b91688..10882dc4 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -57,7 +57,8 @@
 			  :accessor stream-end-of-page-action)
       
       (text-margin :initarg :text-margin)
-      (default-text-margin :accessor stream-default-text-margin)
+      (default-text-margin :accessor stream-default-text-margin
+	:initform most-positive-fixnum)
 
       ;; TSTYLE
       ;; delete these 
diff --git a/clim/output-recording-defs.lisp b/clim/output-recording-defs.lisp
index fdf2f466..2d030bd5 100644
--- a/clim/output-recording-defs.lisp
+++ b/clim/output-recording-defs.lisp
@@ -22,7 +22,10 @@
 (defmacro define-output-recorder (class medium-graphics-function*
 				  medium-components 
 				  &key  points-to-transform
+					point-sequences-to-transform
 					bounding-rectangle
+					distances-to-transform
+					points-not-to-move
 					(superclasses '(graphics-displayed-output-record)))
   (let ((function-args (get medium-graphics-function* 'silica::args)))
     `(progn
@@ -36,6 +39,12 @@
 
 	 (when (stream-record-p medium)
 	   ;; Transform the coordinates
+	   ,@(mapcar #'(lambda (p)
+			 `(setq ,p (transform-point-sequence
+				    (medium-transformation medium)
+				    ,p)))
+		     point-sequences-to-transform)
+	   
 	   ,@(do ((p points-to-transform (cddr p))
 		  r)
 		 ((null p)
@@ -46,6 +55,19 @@
 					  ,(car p) ,(cadr p)))
 		     r))
 	   
+	   ,@(do ((p distances-to-transform (cddr p))
+		  r)
+		 ((null p)
+		  r)
+	       (push `(multiple-value-setq
+			  (,(car p) ,(cadr p))
+			(transform-distance (medium-transformation medium)
+					  ,(car p) ,(cadr p)))
+		     r))
+	   
+
+	   
+	   
 	   (let ((rec (make-instance ',class
 				     ,@(mapcan #'(lambda (arg)
 						   (list (intern arg :keyword)
@@ -66,16 +88,20 @@
 					     miny
 					     maxx
 					     maxy)
-	       
+	       ,@(mapcar #'(lambda (p)
+			     `(with-slots (,p) rec
+				(setf ,p (adjust-point-sequence ,p minx miny))))
+			 point-sequences-to-transform)
 	       ,@(when points-to-transform
 		   `((with-slots ,points-to-transform rec
 		       (setf ,@(do ((p points-to-transform (cddr p))
 				    r)
 				   ((null p) (nreverse r))
-				 (push (first p) r)
-				 (push `(- ,(first p) minx) r)
-				 (push (second p) r)
-				 (push `(- ,(second p) miny) r))))))
+				 (unless (member (car p) points-not-to-move)
+				   (push (first p) r)
+				   (push `(- ,(first p) minx) r)
+				   (push (second p) r)
+				   (push `(- ,(second p) miny) r)))))))
 				      
 	       (multiple-value-bind
 		   (cursor-x cursor-y)
@@ -94,24 +120,34 @@
 	     (minx miny)
 	     (bounding-rectangle-position* rec)
 	   (with-slots (,@function-args ,@medium-components) rec
-	     (silica::with-drawing-options 
-		 (stream ,@(mapcan #'(lambda (medium-component)
-				       (list (intern medium-component :keyword)
-					     medium-component))
-				   medium-components))
-	    
-	       (let ,(mapcar #'(lambda (p)
-				 (list p p))
-		      points-to-transform)
-		 (setf ,@(do ((p points-to-transform (cddr p))
-			      r)
-			     ((null p) (nreverse r))
-			   (push (first p) r)
-			   (push `(+ ,(first p) minx) r)
-			   (push (second p) r)
-			   (push `(+ ,(second p) miny) r)))
-		 (with-sheet-medium (medium stream)
-		   (,medium-graphics-function* medium ,@function-args)))))))
+	     (letf-globally (( (medium-transformation stream) +identity-transformation+))
+			    (silica::with-drawing-options 
+				(stream ,@(mapcan #'(lambda (medium-component)
+						      (list (intern medium-component :keyword)
+							    medium-component))
+						  medium-components))
+	       
+			      (let (,@(mapcar #'(lambda (p)
+						  (list p p))
+					      points-to-transform)
+				    ,@(mapcar #'(lambda (p)
+						  (list p p))
+					      point-sequences-to-transform))
+				,@(mapcar #'(lambda (p)
+					      `(setq ,p
+						 (adjust-point-sequence ,p (-
+									    minx) (- miny))))
+					  point-sequences-to-transform)
+				(setf ,@(do ((p points-to-transform (cddr p))
+					     r)
+					    ((null p) (nreverse r))
+					  (unless (member (car p) points-not-to-move)
+					    (push (first p) r)
+					    (push `(+ ,(first p) minx) r)
+					    (push (second p) r)
+					    (push `(+ ,(second p) miny) r))))
+				(with-sheet-medium (medium stream)
+				  (,medium-graphics-function* medium ,@function-args))))))))
        
        #+ignore
        (defmethod output-record-refined-sensitivity-test ())
@@ -126,8 +162,94 @@
 		  (min from-y to-y)
 		  (max from-x to-x)
 		  (max from-y to-y)))
-					 
-;; draw-rectangle*
+
+;;; This is all kind of broken because of the weirdness concerning the
+;;; radius-1/2-dx/y stuff. They are vectors that are center relative
+;;; Perhaps they just want to be scaled rather than translated.
+
+(define-output-recorder ellipse-output-record
+    silica::medium-draw-ellipse* (ink line-style)
+    :points-to-transform silica::(center-x 
+				  center-y 
+				  ) 
+    ;; When we move the output record these do not move!
+    ;; kuldge
+    :distances-to-transform silica::(radius-1-dx radius-1-dy
+						 radius-2-dx
+						 radius-2-dy)
+
+    :bounding-rectangle
+    silica::(clim-utils::elliptical-arc-box
+	     center-x 
+	     center-y 
+	     radius-1-dx
+	     radius-1-dy
+	     radius-2-dx
+	     radius-2-dy
+	     start-angle
+	     end-angle
+	     (silica::line-style-thickness (silica::medium-line-style medium))))
+
+(define-output-recorder rectangle-output-record
+    silica::medium-draw-rectangle* (ink line-style)
+    :points-to-transform silica::(from-x from-y to-x to-y)
+    :bounding-rectangle
+    silica::(values (min from-x to-x)
+		    (min from-y to-y)
+		    (max from-x to-x)
+		    (max from-y to-y)))
+
+
+
+(define-output-recorder polygon-output-record
+    silica::medium-draw-polygon* (ink line-style)
+    :point-sequences-to-transform silica::(list-of-x-and-ys)
+    :bounding-rectangle
+    silica::(point-sequence-bounding-rectangle list-of-x-and-ys))
+
+
+
 ;; etc etc
 
+(defun map-point-sequence (fn list-of-x-and-ys)
+  (do ((p list-of-x-and-ys (cddr p)))
+      ((null p))
+    (funcall fn (car p) (cadr p))))
+
+(defun transform-point-sequence (transformation list-of-x-and-ys)
+  (let (r)
+    (map-point-sequence
+     #'(lambda (x y)
+	 (multiple-value-setq
+	  (x y)
+	  (transform-point* transformation x y))
+	 (push x r)
+	 (push y r))
+     list-of-x-and-ys)
+    (nreverse r)))
+
+(defun adjust-point-sequence (list-of-x-and-ys dx dy)
+  (let (r)
+    (map-point-sequence
+     #'(lambda (x y)
+	 (push (- x dx) r)
+	 (push (- y dy) r))
+     list-of-x-and-ys)
+    (nreverse r)))
 
+
+(defun silica::point-sequence-bounding-rectangle (list-of-x-and-ys)
+  (let* ((minx (car list-of-x-and-ys))
+	 (miny (second list-of-x-and-ys))
+	 (maxx minx)
+	 (maxy miny))
+    (map-point-sequence
+     #'(lambda (x y)
+	 (minf minx x)
+	 (minf miny y)
+	 (maxf maxx x)
+	 (maxf maxy y))
+     list-of-x-and-ys)
+    (values minx miny maxx maxy)))
+
+       
diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp
index 5a678cf7..e899d0da 100644
--- a/clim/stream-defprotocols.lisp
+++ b/clim/stream-defprotocols.lisp
@@ -19,7 +19,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: stream-defprotocols.lisp,v 1.7 91/08/05 14:35:33 cer Exp $
+;; $fiHeader: stream-defprotocols.lisp,v 1.1 91/11/25 10:01:16 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -309,7 +309,26 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 	      ((stream drawing-state-mixin) function &rest x))
 
 (defoperation silica::medium-draw-line* drawing-state-mixin
-	      ((stream drawing-state-mixin) from-x from-y to-x to-y))
+  ((stream drawing-state-mixin) from-x from-y to-x to-y))
+
+(defoperation silica::medium-draw-polygon* drawing-state-mixin
+  ((stream drawing-state-mixin) list-of-x-and-ys closed filled))
+
+(defoperation silica::medium-draw-ellipse* drawing-state-mixin
+  ((stream drawing-state-mixin)  center-x center-y 
+				       radius-1-dx 
+				       radius-1-dy 
+				       radius-2-dx
+				       radius-2-dy 
+				       start-angle 
+				       end-angle 
+				       filled))
+
+(defoperation silica::medium-draw-rectangle* drawing-state-mixin
+  ((stream drawing-state-mixin)   from-x from-y to-x to-y filled))
+
+
+
 
 
 
diff --git a/clim/surround-output.lisp b/clim/surround-output.lisp
index a3330d34..8f6b3223 100644
--- a/clim/surround-output.lisp
+++ b/clim/surround-output.lisp
@@ -1,6 +1,6 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: clim; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: surround-output.lisp,v 1.3 91/08/05 14:35:37 cer Exp $
+;; $fiHeader: surround-output.cl,v 1.1 91/12/17 13:38:51 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -33,12 +33,12 @@
 	       (setq *border-shape-drawer-alist*
 		     (nconc *border-shape-drawer-alist* (list (list ',shape ',name))))))))))
 
-(defclass border-output-record (linear-output-record)
+(defclass border-output-record (standard-sequence-output-record)
     ((shape :initarg :shape)))
 
 (define-output-record-constructor border-output-record
-				  (&key x-position y-position (size 5) shape)
-  :x-position x-position :y-position y-position :size size :shape shape)
+				  (&key (size 5) shape)
+  :size size :shape shape)
 
 
 (define-border-type :rectangle (stream left top right bottom)
@@ -68,6 +68,7 @@
     (draw-line* stream left top right top)))
 
 ;; SURROUNDING-OUTPUT-WITH-BORDER macro in FORMATTED-OUTPUT-DEFS
+
 (defun surrounding-output-with-border-1 (stream shape continuation &key (move-cursor t))
   (let* ((body nil)				;the record containing the body
 	 (border-record				;the entire bordered output record
@@ -76,12 +77,16 @@
 	     (setq body (with-output-to-output-record (stream)
 			  (funcall continuation stream))))))
     (with-bounding-rectangle* (left top right bottom) body
-      (multiple-value-bind (xoff yoff)
-	  (convert-from-relative-to-absolute-coordinates
-	    stream (output-record-parent (output-record-parent body)))
-	(translate-fixnum-positions xoff yoff left top right bottom))
+
+			      #+ignore-should-do-something?
+			      (multiple-value-bind (xoff yoff)
+				  (convert-from-relative-to-absolute-coordinates
+				   stream (output-record-parent (output-record-parent body)))
+				(translate-fixnum-positions xoff yoff left top right
+							    bottom))
+			      
       (with-output-recording-options (stream :draw-p nil :record-p t)
-	(with-new-output-record (stream 'linear-output-record nil
+	(with-new-output-record (stream 'standard-sequence-output-record nil
 				 :parent border-record)
 	  (if (funcallable-p shape)
 	      (funcall shape stream body left top right bottom)
diff --git a/clim/sysdcl.lisp b/clim/sysdcl.lisp
index 40053eee..4005f94f 100644
--- a/clim/sysdcl.lisp
+++ b/clim/sysdcl.lisp
@@ -98,6 +98,8 @@
    :load-before-compile ("clim-defs" "incremental-redisplay"))
 
   ("menus")
+  ("surround-output")
+  ("graph-formatting")
   ("text-formatting")
   ("stream-trampolines"
    :load-before-compile ("defprotocol" "stream-defprotocols")
diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp
index b9c53748..2c383484 100644
--- a/clim/table-formatting.lisp
+++ b/clim/table-formatting.lisp
@@ -19,7 +19,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: table-formatting.lisp,v 1.9 91/08/05 14:35:38 cer Exp $
+;; $fiHeader: table-formatting.lisp,v 1.1 91/11/25 10:01:17 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -468,31 +468,37 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 				       multiple-columns multiple-columns-inter-column-spacing
 				       equalize-column-widths
 				       (move-cursor t))
-  (let ((table (with-new-output-record (stream record-type nil
-					:inter-row-spacing
-					  (or (process-spacing-arg stream inter-row-spacing
-								   'formatting-table
-								   ':inter-row-spacing)
-					      (stream-vsp stream))
-					:inter-column-spacing
-					  (or (process-spacing-arg stream inter-column-spacing
-								   'formatting-table
-								   ':inter-column-spacing)
-					      (stream-string-width stream " "))
-					:equalize-column-widths equalize-column-widths)
-		 (with-output-recording-options (stream :draw-p nil :record-p t)
-		   (with-end-of-line-action (:allow stream)
-		     (with-end-of-page-action (:allow stream)
-		       (funcall continuation stream)))))))
-    (adjust-table-cells table)
-    (when multiple-columns
-      (adjust-multiple-columns table stream
-			       (and (numberp multiple-columns) multiple-columns)
-			       (and multiple-columns multiple-columns-inter-column-spacing)))
-    (replay table stream)
-    (when move-cursor
-      (move-cursor-beyond-output-record stream table))
-    table))
+  (multiple-value-bind
+      (x y)
+      (stream-cursor-position* stream)
+    (let ((table (with-new-output-record (stream record-type nil
+						 :inter-row-spacing
+						 (or (process-spacing-arg stream inter-row-spacing
+									  'formatting-table
+									  ':inter-row-spacing)
+						     (stream-vsp stream))
+						 :inter-column-spacing
+						 (or (process-spacing-arg stream inter-column-spacing
+									  'formatting-table
+									  ':inter-column-spacing)
+						     (stream-string-width stream " "))
+						 :equalize-column-widths equalize-column-widths)
+		   (with-output-recording-options (stream :draw-p nil :record-p t)
+		     (with-end-of-line-action (:allow stream)
+		       (with-end-of-page-action (:allow stream)
+			 (funcall continuation stream)))))))
+      (adjust-table-cells table)
+      (when multiple-columns
+	(adjust-multiple-columns table stream
+				 (and (numberp multiple-columns) multiple-columns)
+				 (and multiple-columns
+				      multiple-columns-inter-column-spacing)))
+      ;; Added ??
+      (output-record-set-position* table x y)
+      (replay table stream)
+      (when move-cursor
+	(move-cursor-beyond-output-record stream table))
+      table)))
 
 ;; FORMATTING-CELL macro in FORMATTED-OUTPUT-DEFS
 (defmethod formatting-cell-internal ((stream output-protocol-mixin) continuation
@@ -759,29 +765,33 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 					   max-width max-height
 					   stream-width stream-height
 					   (move-cursor t))
-  (let ((menu (with-new-output-record (stream record-type nil
-				       :n-columns n-columns :n-rows n-rows
-				       :max-width max-width :max-height max-height
-				       :stream-width stream-width :stream-height stream-height
-				       :inter-row-spacing
-				         (or (process-spacing-arg stream inter-row-spacing
-								  'formatting-item-list
-								  ':inter-row-spacing)
-					     (stream-vsp stream))
-				       :inter-column-spacing
-				         (process-spacing-arg stream inter-column-spacing
-							      'formatting-item-list
-							      ':inter-column-spacing)
-				       :no-initial-spacing no-initial-spacing)
-		(with-output-recording-options (stream :draw-p nil :record-p t)
-		  (with-end-of-line-action (:allow stream)
-		    (with-end-of-page-action (:allow stream)
-		      (funcall continuation stream)))))))
-    (adjust-table-cells menu)
-    (replay menu stream)
-    (when move-cursor
-      (move-cursor-beyond-output-record stream menu))
-    menu))
+  (multiple-value-bind
+      (x y)
+      (stream-cursor-position* stream)
+    (let ((menu (with-new-output-record (stream record-type nil
+						:n-columns n-columns :n-rows n-rows
+						:max-width max-width :max-height max-height
+						:stream-width stream-width :stream-height stream-height
+						:inter-row-spacing
+						(or (process-spacing-arg stream inter-row-spacing
+									 'formatting-item-list
+									 ':inter-row-spacing)
+						    (stream-vsp stream))
+						:inter-column-spacing
+						(process-spacing-arg stream inter-column-spacing
+								     'formatting-item-list
+								     ':inter-column-spacing)
+						:no-initial-spacing no-initial-spacing)
+		  (with-output-recording-options (stream :draw-p nil :record-p t)
+		    (with-end-of-line-action (:allow stream)
+		      (with-end-of-page-action (:allow stream)
+			(funcall continuation stream)))))))
+      (adjust-table-cells menu)
+      #+ignoremaybe(output-record-set-position* menu x y)
+      (replay menu stream)
+      (when move-cursor
+	(move-cursor-beyond-output-record stream menu))
+      menu)))
 
 (defun format-items (item-list &key (stream *standard-output*) printer presentation-type
 				    inter-row-spacing inter-column-spacing
diff --git a/clim/text-output-recording.lisp b/clim/text-output-recording.lisp
index c0489880..dac1b013 100644
--- a/clim/text-output-recording.lisp
+++ b/clim/text-output-recording.lisp
@@ -101,6 +101,7 @@
 	 (color (slot-value record 'ink)))
     (declare (fixnum start end baseline))
     (with-sheet-medium (medium stream)
+      	     (letf-globally (( (medium-transformation medium) +identity-transformation+))
      (macrolet
       ((do-it (end-position)
 	 `(loop
@@ -135,7 +136,7 @@
 		(incf start))))))
       (multiple-value-bind (cursor-x cursor-y) (output-record-position* record)
 	(declare (fixnum cursor-x cursor-y))
-	(do-it end))))))
+	(do-it end)))))))
 
 (defmethod replay-output-record ((record styled-text-displayed-output-record) stream &optional region)
   (declare (ignore region))
@@ -148,6 +149,7 @@
 	 (color (slot-value record 'ink)))
     (declare (fixnum start end baseline))
     (with-sheet-medium (medium stream)
+            	     (letf-globally (( (medium-transformation medium) +identity-transformation+))
      (macrolet
       ((do-it (end-position)
 	 `(loop
@@ -186,7 +188,7 @@
 	    (do-it change-position)
 	    (setf text-style new-text-style
 		  start change-position)))
-	(do-it end))))))
+	(do-it end)))))))
 
 (defmethod add-string-output-to-text-record ((record text-displayed-output-record)
 					     text-string start end text-style
@@ -342,7 +344,12 @@
 			  (slot-value match 'text-style-changes)))
 	  (setf (output-record-contents-ok text) t)
 	  ;; make sure that old bounding-rect is the same relative position from
-	  ;; old-start-position as the bounding-rect is from start-position
+	  ;; old-start-position as the bounding-rect is from
+	  ;; start-position
+	  (multiple-value-bind (old-start-x old-start-y)
+		(bounding-rectangle-position* match)
+	      (output-record-set-old-start-position* text old-start-x old-start-y))
+	  #+ignore
 	  (multiple-value-bind (delta-x delta-y)
 	      (multiple-value-bind (ex ey) (bounding-rectangle-position* text)
 		(declare (fixnum ex ey))
@@ -362,23 +369,22 @@
   (let ((baseline 0)
 	(style (medium-default-text-style stream)))
     (declare (fixnum baseline))
-    (labels ((find-or-recurse (element y-offset)
-	       (declare (fixnum y-offset))
+    (labels ((find-or-recurse (element)
 	       (typecase element
 		 (styled-text-displayed-output-record
-		   (maxf baseline (the fixnum (+ y-offset (slot-value element 'baseline)))))
+		   (maxf baseline (the fixnum (+ (bounding-rectangle-min-y element) (slot-value element 'baseline)))))
 		 (text-displayed-output-record
 		   (maxf baseline
-			 (the fixnum (+ y-offset (- (text-style-height style stream)
+			 (the fixnum (+ (bounding-rectangle-min-y element)
+					 (- (text-style-height style stream)
 						    (text-style-descent style stream))))))
 		 (t
-		   (multiple-value-bind (xoff yoff) (output-record-position* element)
-		     (declare (fixnum yoff))
-		     (declare (ignore xoff))
-		     (map-over-output-record-elements element
-		       #'find-or-recurse 0 0 (the fixnum (+ yoff y-offset))))))))
+		  (map-over-output-record-children
+		   #'find-or-recurse
+		   element
+		   +everywhere+)))))
       (declare (dynamic-extent #'find-or-recurse))
-      (find-or-recurse record 0))
+      (find-or-recurse record))
     baseline))
 
 
diff --git a/misc/go.lisp b/misc/go.lisp
index dd334642..bbe93ba4 100644
--- a/misc/go.lisp
+++ b/misc/go.lisp
@@ -51,10 +51,6 @@
 (defsys::compile-system :xm-silica)
 (defsys::load-system :xm-silica)
 
-;(load "ws/sysdcl")
-;(defsys::compile-system :ws)
-;(defsys::load-system :ws)
-
 (defsys::compile-system :xm-ws)
 (defsys::load-system :xm-ws)
 
@@ -64,3 +60,7 @@
   )
 
 (load "test/test")
+
+(excl::compile-file-if-needed "test/test-suite")
+(load "test/test-suite")
+
diff --git a/notes/plan.todo b/notes/plan.todo
index 0f0ed47f..9634ec46 100644
--- a/notes/plan.todo
+++ b/notes/plan.todo
@@ -6,7 +6,6 @@
 % Xtk
   * Support for CLIM [1w]
 
-
 % Xm
   * Tidy up [2w]
 
@@ -28,16 +27,11 @@
   * General tidying up [2w]
     - Spec conformance - names etc
 
-== 14weeks
-
-%%% Part 2
+Total = 14weeks
 
-% Xlib
-  * CLX level support [4w]
-
-% Xtk
-  * Full interface [2w]
+================================================ 
 
+%%% 
 
 % OLIT
   * Implement for CLIM [1w]
@@ -46,9 +40,6 @@
 % Silica
   * OLIT [1w]
 
-== 10weeks
-
-
 % CLIM the next generation
   * Accept <-> gadget interface
 
@@ -58,110 +49,13 @@
   * Support for programming in motif
   * Support for programming in OpenLook
 
---------------------------------------------------
-% CLIM issues
-  * Output protocol
-
-  * Mirror geometry protocol
-
-  * Scroller, viewport protocol
-
-  * Keyboard events
-    - Keyboard focus in widgets.
-    - Keysym translation
-    - NEED to look at sources
-
-  * Repaint
-    - clipping region and redrawing the background
-    - weird ensure-cursor-visible-behavior
-
-  * application frames
-    - Just take the 0.9 layout stuff
-    - + some mechanism for defining
-    - command-menus.
-      + We can create a menu bar and generate items for it. One
-        problem is that they will always be sensitive even when the
-        input context is not for a command. There seems no easy way of
-        doing this. I guess they generate a command-event that gets
-        executed at some point.
-    - clim-interactor has a display-function slot? and when that is
-      non NIL we invoke it after a command?
-    - Perhaps CLIM panes do a compose-space by running 
-  * menus
-  * accepting-values and gadgets
-
-% ff issues
-  * templates for def-c-type accessors
-  * templates for foreign function stuff
-  * specify arg-names for the foreign function arglist
-  * Efficient generation of CLOS <-> address mapping
-    - We want to have type checking
-    - we want stub code to be compact.
-    - How about doing inline stuff.
-  * Arg checking.
-    - I really want to specify the names of the arguments but I do not
-      want to do any checking.
-
-% Xlib interface
-  * generate xlib.h.lisp
-  * provide CLOS wrappers for Objects
-  * implement function interface
-  * Silica need not use the wrappers
-
-% Xt interface
-  * generate intrinsics.h.lisp
-  * provide CLOS wrappers for objects
-  * implement function interface
-
-  * issues
-    - graphics
-    - events
-    - font accessors
-    - images
-    - cursors
-    - misc accessors for displays, screens etc
-    - window operations
-    - graphics
-      + finished encode/decode
-    - initialization
-    - type checking in convertors
-    - implement CLX functionality.
-
-% xtk
-  * Event Handlers
-  * Finish callbacks
-  * Convenience functions
-  * timers and mp
-  * alternative input
-  * initialization
-  * type checking in resources convertors
-
-% xm 
-  * Generate class definitions
-  * Interface to Xmu/UIL
-
-% ol
-  * Generate class definitions
-  * Interface to devGuide UIL
-
-% Extensive implementation of silica
-  * graphics
-    - perhaps we can steal the code from clx-implementation
-
-% Windshield
-  * Frames, generic gadget protocol
-
-% Motif specific application frame level
-  * Perhaps we just define all of the gadgets and start using them
-
-% Adaptive toolkit level
-  * This bit seems OK except for the lack of integration between
-    gadgets and commands etc.  However, it is important for windows to
-    be designed with a GUI-BUILDER and used from within CLIM
-
-  * The notion of callbacks just being generic functions seems bad.
-
-% Rest is up to swm
+====================================================
 
+%%%%%%%%%%%%%%%%%%%% &optional stuff
 
+% Xlib
+  * CLX level support [4w]
+
+% Xtk
+  * Full interface [2w]
 
diff --git a/silica/classes.lisp b/silica/classes.lisp
index f91a3c60..4c5ffa28 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 (defclass port () 
   ((server-path :reader port-server-path)
diff --git a/silica/clim.lisp b/silica/clim.lisp
index 5e55521f..95cb5b9a 100644
--- a/silica/clim.lisp
+++ b/silica/clim.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 (defclass clim-sheet (sheet
 		      
diff --git a/silica/db-box.lisp b/silica/db-box.lisp
index 9dddfd63..4f6dc969 100644
--- a/silica/db-box.lisp
+++ b/silica/db-box.lisp
@@ -28,11 +28,9 @@
 ;;; Boxing Panes
 ;;;
 
-(defclass box-pane (mute-input-mixin
-		    pane-background-mixin
-		    composite-pane 
-		    #+ignore list-contents-mixin
-		    space-req-cache-mixin)
+
+
+(defclass box-pane (layout-pane)
 	  ((space :initform 1 :initarg :space)
 	   contents))
 
diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp
index 69419c69..fcf233a0 100644
--- a/silica/db-layout.lisp
+++ b/silica/db-layout.lisp
@@ -147,20 +147,55 @@
 ;;; 
 
 (defclass space-req-mixin (layout-mixin)
-    ((space-req :reader pane-space-req)))
+	  ((initial-space-req :reader pane-initial-space-req)
+	   (space-req :reader pane-space-req)))
 
 (defmethod initialize-instance :after 
 	   ((pane space-req-mixin) 
+	    &rest args
 	    &key  
-	    (width 0) (max-width width) (min-width width)
-	    (height 0) (max-height height) (min-height height))
-  (setf (slot-value pane 'space-req)
-    (make-space-req :width width 
-		    :height height 
-		    :max-width max-width 
-		    :min-width min-width 
-		    :max-height max-height
-		    :min-height min-height)))
+	    width max-width min-width
+	    height max-height min-height)
+  (declare (ignore width min-width max-width
+		   height min-height max-height))
+  (multiple-value-bind
+      (width min-width max-width
+       height min-height max-height)
+      (apply #'default-space-requirements 
+	     pane 
+	     :allow-other-keys t
+	     args)
+    (setf (slot-value pane 'space-req)
+      (make-space-req :width width 
+		      :height height 
+		      :max-width max-width 
+		      :min-width min-width 
+		      :max-height max-height
+		      :min-height min-height)
+      (slot-value pane 'initial-space-req)
+      (make-space-req :width width 
+		      :height height 
+		      :max-width max-width 
+		      :min-width min-width 
+		      :max-height max-height
+		      :min-height min-height))))
+
+(defmethod default-space-requirements ((pane space-req-mixin) 
+				       &key 
+				       (width 0)
+				       (min-width width)
+				       (max-width width)
+				       (height 0)
+				       (min-height height)
+				       (max-height height))
+  (values width
+	  min-width
+	  max-width
+	  height
+	  min-height
+	  max-height))
+	  
+	  
 
 (defmethod compose-space ((pane space-req-mixin))
   (slot-value pane 'space-req))
@@ -190,7 +225,7 @@
 		      :max-height (or max-height height +fill+)
 		      :min-height (or min-height height 0)))))
 
-(defmethod compose-space ((pane client-space-req-mixin))
+(defmethod compose-space :around ((pane client-space-req-mixin))
   (or (slot-value pane 'client-space-req)
       (call-next-method)))
 
@@ -306,10 +341,10 @@
   (clear-space-req-cache pane))
 
 (defun clear-space-req-caches-in-tree (sheet)
-  (walk-tree #'(lambda (sheet depth nth) 
-		 (declare (ignore depth nth))
-		 (clear-space-req-cache sheet))
-	     sheet))
+  (clim-internals::map-over-sheets
+   #'(lambda (sheet) 
+       (clear-space-req-cache sheet))
+   sheet))
 
 (defun clear-space-req-caching-in-ancestors (menu)
   (do ((parent (sheet-parent menu) (sheet-parent parent)))
@@ -427,3 +462,13 @@
 	    (decf extra used))
 	    (push alloc sizes)))
       (nreverse sizes))))
+
+;;; Most of the layout panes should inherit from this
+
+(defclass layout-pane (mute-input-mixin
+		       pane-background-mixin
+		       composite-pane 
+		       space-req-cache-mixin
+		       sheet-permanently-enabled-mixin)
+	  ())
+
diff --git a/silica/db-table.lisp b/silica/db-table.lisp
index b562e6d0..50c64a4a 100644
--- a/silica/db-table.lisp
+++ b/silica/db-table.lisp
@@ -30,10 +30,7 @@
 
 
 
-(defclass table-pane (mute-input-mixin
-		      pane-background-mixin
-		      composite-pane 
-		      space-req-cache-mixin)
+(defclass table-pane (layout-pane)
 	  (row-space-reqs column-space-reqs contents))
 
 
@@ -74,7 +71,7 @@
       (dotimes (row (array-dimension contents 0))
 	(let ((min-h 0)
 	      (h 0)
-	      (max-h 0))
+	      (max-h nil))
 	  (dotimes (column (array-dimension contents 1))
 	    (let ((item (aref contents row column)))
 	      (when item
@@ -82,7 +79,10 @@
 		  ;; Max the heights
 		  (maxf h (space-req-height isr))
 		  (maxf min-h (space-req-min-height isr))
-		  (maxf max-h (space-req-max-height isr))))))
+		  ;; should this be min or max
+		  (if max-h
+		      (minf max-h (space-req-max-height isr))
+		    (setf max-h (space-req-max-height isr)))))))
 
 	  (push
 	   (make-space-req
@@ -102,7 +102,7 @@
       (dotimes (column (array-dimension contents 1))
 	(let ((min-w 0)
 	      (w 0)
-	      (max-w 0))
+	      (max-w nil))
 	
 	  (dotimes (row (array-dimension contents 0))
 	    (let ((item (aref contents row column)))
@@ -111,7 +111,10 @@
 		  ;; Max the widths
 		  (maxf w (space-req-width isr))
 		  (maxf min-w (space-req-min-width isr))
-		  (maxf max-w (space-req-max-width isr))))))
+		  ;; Should this be min or max???
+		  (if max-w
+		      (minf max-w (space-req-max-width isr))
+		    (setf max-w (space-req-max-width isr)))))))
 
 	  (push
 	   (make-space-req
diff --git a/silica/defsys.lisp b/silica/defsys.lisp
index 08c52dcb..835e8c4b 100644
--- a/silica/defsys.lisp
+++ b/silica/defsys.lisp
@@ -1,3 +1,4 @@
+;; -*- mode: common-lisp; package: user -*-
 
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
@@ -18,6 +19,8 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
 (defsystem :silica
   (:default-pathname ".")
   (|pkg|)
diff --git a/silica/event.lisp b/silica/event.lisp
index 35880427..aa3785d4 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 ;;; Event stuff
 
diff --git a/silica/graphics.lisp b/silica/graphics.lisp
index dc107d32..630303f6 100644
--- a/silica/graphics.lisp
+++ b/silica/graphics.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
+
 
 (defclass sheet-with-graphics-state ()
 	  ((foreground :initform +black+ :accessor sheet-foreground)
@@ -55,6 +59,11 @@
 	      x
 	    (push argname unspread-argument-names)
 	    (ecase type
+	      (point-sequence
+	       (destructuring-bind
+		   (new-name) names
+		 (push `(unspread-point-sequence ,argname) spread-arguments)
+		 (push new-name spread-argument-names)))
 	      (point
 	       (destructuring-bind 
 		   (x y) names
@@ -84,7 +93,8 @@
 			   x)
 			 'keyword))
 		    keyword))))
-	 )
+)					; eval-when
+
 	 
 (defmacro define-graphics-function (name arguments &body stuff)
   (let* ((spread-name (intern (format nil "~A*" name)))
@@ -97,7 +107,8 @@
 	    line-thickness
 	    line-unit
 	    line-dashes
-	    line-cap-shape))
+	    line-cap-shape
+	    line-joint-shape))
 	 (medium-graphics-function-name
 	  (intern (format nil "~A~A*" 'medium- name)))
 	 (port-function-name
@@ -171,19 +182,28 @@
 ;; draw-points
 ;; draw-polygon
 
+(define-graphics-function draw-polygon ((points point-sequence list-of-x-and-ys)
+					&key 
+					(closed t)
+					(filled t)))
+
+
+
 (define-graphics-function draw-ellipse ((center point center-x center-y)
-					radius-dx-1
-					radius-dy-1
-					radius-dx-2
-					radius-dy-2
+					radius-1-dx
+					radius-1-dy
+					radius-2-dx
+					radius-2-dy
 					&key 
-					(filled t)
-					start-angle
-					end-angle))
+					(start-angle 0)
+					(end-angle 2pi)
+					(filled t)))
+
+(defun draw-circle (medium center radius &rest args)
+  (apply #'draw-ellipse medium center 0 radius radius 0 args))
 
-(define-graphics-function draw-circle ((center point center-x center-y)
-				       radius
-				       &key (filled t)))
+(defun draw-circle* (medium center-x center-y radius &rest args)
+  (apply #'draw-ellipse* medium center-x center-y 0 radius radius 0 args))
 
 (define-graphics-function draw-text (string-or-char
 				     (point point x y)
diff --git a/silica/medium.lisp b/silica/medium.lisp
index d5e7e063..efd27fc1 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 (defmethod engraft-medium (medium port sheet)
   (declare (ignore sheet port))
@@ -56,7 +59,34 @@
 			  :sheet sheet)))
 			  
 
-(defun %make-line-style (&rest x) :line-style)
+(defclass line-style ()
+	  ((unit :type (member :normal :point)
+		 :initform :normal :initarg :unit
+		 :reader line-style-unit)
+	   (thickness :type real
+		      :initform 1 :initarg :thickness
+		      :reader line-style-thickness)
+	   (joint-shape :type (member :miter :bevel :round :none)
+			:initform :miter :initarg :joint-shape
+			:reader line-style-joint-shape)
+	   (cap-shape :type (member :butt :square :round :no-end-point)
+		      :initform :butt :initarg :cap-shape
+		      :reader line-style-cap-shape)
+	   (dashes :initform nil :initarg :dashes
+		   :reader line-style-dashes)
+	   ))
+
+(defun make-line-style-1 (line-unit line-thickness line-dashes
+			  line-joint-shape line-cap-shape)
+  (make-instance 'line-style
+		 :unit line-unit
+		 :thickness line-thickness
+		 :dashes line-dashes
+		 :joint-shape line-joint-shape
+		 :cap-shape line-cap-shape))
+
+(defun %make-line-style (&rest x) 
+  (apply #'make-instance 'line-style x))
 
 (defmethod invoke-with-drawing-options ((sheet sheet) function &rest options)
   (declare (dynamic-extent options))
@@ -67,39 +97,115 @@
 	  function
 	  options)))
 
+
+
+(defmethod invoke-with-drawing-options
+	   ((medium medium) continuation
+	    &key ink clipping-region transformation
+		 line-style line-unit line-thickness (line-dashes nil dashes-p)
+		 line-joint-shape line-cap-shape
+		 (text-style nil text-style-p) (text-family nil text-family-p)
+		 (text-face nil text-face-p) (text-size nil text-size-p))
+  (with-slots ((medium-ink ink)
+	       (medium-transformation transformation)
+	       (transformed-clipping-region region)
+	       (medium-line-style line-style)) medium
+    ;; Close the current output record if the drawing ink is changing
+    #+ignore-do-we-have-to-do-this
+    (unless (eq medium-ink ink)
+      (close-current-text-output-record medium))
+    (let* ((saved-ink medium-ink)
+	   (saved-transformation medium-transformation)
+	   (saved-clipping-region transformed-clipping-region)
+	   (saved-line-style medium-line-style))
+      (unwind-protect
+	  (progn
+	    (when ink
+	      (setf medium-ink ink))
+	    (when transformation
+	      (setf medium-transformation
+		    (compose-transformations saved-transformation transformation)))
+	    (when clipping-region
+	      (setf transformed-clipping-region
+		    (region-intersection saved-clipping-region
+					 (transform-region medium-transformation
+							   clipping-region))))
+	    (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p)
+		   (when (null line-style)
+		     (setf line-style saved-line-style))
+		   (setf medium-line-style
+			 (make-line-style-1
+			   (or line-unit (line-style-unit line-style))
+			   (or line-thickness (line-style-thickness line-style))
+			   (if dashes-p line-dashes (line-style-dashes line-style))
+			   (or line-joint-shape (line-style-joint-shape line-style))
+			   (or line-cap-shape (line-style-cap-shape line-style)))))
+		  (line-style
+		   (setf medium-line-style line-style)))
+	    (when (or text-family-p text-face-p text-size-p)
+	      (if text-style-p
+		  (setq text-style (with-stack-list (style text-family text-face text-size)
+				     (merge-text-styles style text-style)))
+		  (setq text-style (make-text-style text-family text-face text-size)
+			text-style-p t)))
+	    (if text-style-p
+		(flet ((call-continuation (stream)
+			 (declare (ignore stream))
+			 (funcall continuation)))
+		  (declare (dynamic-extent #'call-continuation))
+		  (with-text-style-internal medium text-style #'call-continuation medium))
+	        (funcall continuation)))
+	(setf medium-line-style saved-line-style)
+	(setf transformed-clipping-region saved-clipping-region)
+	(setf medium-transformation saved-transformation)
+	(setf medium-ink saved-ink)))))
+
+#+ignore
 (defmethod invoke-with-drawing-options ((medium medium) function 
+					&rest args
 					&key 
+					(line-cap-shape nil line-cap-shape-p)
+					(line-joint-shape nil line-joint-shape-p)
+					(line-dashes nil line-dashes-p) 
 					(line-thickness nil line-thickness-p)
+					(line-unit nil line-unit-p)
+					(line-style nil line-style-p)
 					(ink nil ink-p)
-					(text-style nil text-style-p)
 					(transformation nil trans-p)
 					(clipping-region nil clipping-region-p)
-					(line-style nil line-style-p)
 					(text-family nil text-family-p)
 					(text-face nil text-face-p)
-					(text-size nil text-size-p))
-  (when (or text-size-p text-face-p text-family-p line-style-p
-	    clipping-region-p)
-    (warn "unhandled option to invoke-with-drawing-options"))
+					(text-size nil text-size-p)
+					(text-style nil text-style-p))
+
+  (with-rem-keywords (new args '(:ink :text-style :line-style :transformation))
+    (when new
+      (warn "unhandled option to invoke-with-drawing-options ~S" new)))
   
   (let ((old-ink (if ink-p (medium-ink medium)))
 	(old-trans (if trans-p (medium-transformation medium)))
-	(old-text-style (if text-style-p (medium-text-style medium))))
+	(old-text-style (if text-style-p (medium-text-style medium)))
+	(old-line-style (if line-style-p (medium-line-style medium))))
     (unwind-protect
 	(progn
 	  (when ink-p 
 	    (setf (medium-ink medium) ink))
+	  ;; Should we not compose
 	  (when trans-p
 	    (setf (medium-transformation medium) transformation))
 	  (when text-style-p
 	    (setf (medium-text-style medium) text-style))
+	  (when line-style-p
+	    (setf (medium-line-style medium) line-style))
 	  (funcall function))
       (when ink-p
 	(setf (medium-ink medium) old-ink))
       (when trans-p
 	(setf (medium-transformation medium) old-trans))
       (when text-style-p
-	(setf (medium-text-style medium) old-text-style)))))
+	(setf (medium-text-style medium) old-text-style))
+      (when line-style-p
+	(setf  (medium-line-style medium) old-line-style)))))
 
 (defmethod allocate-medium (port sheet)
   (or (pop (port-media-cache port))
diff --git a/silica/mirror.lisp b/silica/mirror.lisp
index e98ad1ef..6bd8cbed 100644
--- a/silica/mirror.lisp
+++ b/silica/mirror.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
+
 
 ;;;; sheet-device-transformation - transformation from sheets
 ;;;; coordinate space to its mirror
diff --git a/silica/pkg.lisp b/silica/pkg.lisp
index 2d039ba4..a8a294de 100644
--- a/silica/pkg.lisp
+++ b/silica/pkg.lisp
@@ -1,4 +1,4 @@
-(defpackage :silica
+;; -*- mode: common-lisp; package: user -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(defpackage :silica
   (:use clim-lisp clim-utils)
   (:export
    #:*default-text-style*
diff --git a/silica/port.lisp b/silica/port.lisp
index 4df37f27..e3127f46 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
+
 
 ;; Ports and grafts
 
diff --git a/silica/protocols.lisp b/silica/protocols.lisp
index c55dd759..10ce206c 100644
--- a/silica/protocols.lisp
+++ b/silica/protocols.lisp
@@ -21,6 +21,7 @@
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
 ;;;
+;; $fiHeader$
 
 (in-package "CLIM-UTILS")
 
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index 2dd6ccca..52ae357b 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 (defmethod bounding-rectangle* ((x sheet))
   (bounding-rectangle* (sheet-region x)))
diff --git a/silica/std-sheet.lisp b/silica/std-sheet.lisp
index 1ec97a51..130ac39d 100644
--- a/silica/std-sheet.lisp
+++ b/silica/std-sheet.lisp
@@ -1,4 +1,4 @@
-(in-package :silica)
+;; -*- mode: common-lisp; package: silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,9 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :silica)
 
 (defclass standard-sheet (sheet
 			  mirrored-sheet-mixin
@@ -45,4 +48,5 @@
 
 (defmethod handle-event (sheet event)
   (declare (ignore sheet event))
+  #+ignore(warn "ignoring event ~S,~S" sheet event)
   nil)
diff --git a/silica/sysdcl.lisp b/silica/sysdcl.lisp
deleted file mode 100644
index a778f8c7..00000000
--- a/silica/sysdcl.lisp
+++ /dev/null
@@ -1,35 +0,0 @@
-
-;; 
-;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
-;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
-;;
-;; The software, data and information contained herein are proprietary
-;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
-;; given in confidence by Franz, Inc. pursuant to a written license
-;; agreement, and may be stored and used only in accordance with the terms
-;; of such license.
-;;
-;; Restricted Rights Legend
-;; ------------------------
-;; Use, duplication, and disclosure of the software, data and information
-;; contained herein by any agency, department or entity of the U.S.
-;; Government are subject to restrictions of Restricted Rights for
-;; Commercial Software developed at private expense as specified in FAR
-;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
-;; applicable.
-;;
-(in-package :cl-user)
-
-(defsys::defsystem :silica
-    (:default-pathname (frob-pathname "silica"))
-  ("pkg")
-  ("classes")
-  ("text-style")
-  ("macros")
-  ("sheet")
-  ("mirror")
-  ("event")
-  ("port")
-  ("medium")
-  ("graphics")
-  ("std-sheet"))
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index 6181e4ff..566de261 100644
--- a/silica/text-style.lisp
+++ b/silica/text-style.lisp
@@ -19,7 +19,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: text-style.lisp,v 1.1 91/08/30 15:16:23 cer Exp $
+;; $fiHeader: text-style.cl,v 1.1 91/11/25 10:01:59 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -579,7 +579,20 @@ Copyright (c) 1991, Franz Inc. All rights reserved
       (if *allow-loose-text-style-size-mapping*
 	  (let ((fonts (gethash (list family face) mapping-table)))
 	    (setf (gethash (list family face) mapping-table)
-	      (merge 'list fonts (list (list style result))
+	      (merge 'list 
+		     (list (list style result))
+		     (multiple-value-bind
+			 (a b c)
+			 (text-style-components style)
+			 (delete-if #'(lambda (old)
+					(multiple-value-bind
+					    (x y z)
+					    (text-style-components
+					     (car old))
+					  (and (equal x a)
+					       (equal y b)
+					       (= z c))))
+				    fonts))
 		     #'(lambda (one two)
 			 (< (slot-value (car one) 'size)
 			    (slot-value (car two) 'size))))))
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 2380ea81..5c96a9ec 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*-
 
-;; $fiHeader: test-suite.cl,v 1.1 91/12/10 16:57:32 cer Exp Locker: cer $
+;; $fiHeader: test-suite.cl,v 1.2 91/12/13 10:36:59 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -633,10 +633,32 @@ people, shall not perish from the earth.
 	 ,@body))))
 
 (defparameter *basic-shapes* `(
-  ("Rectangle" draw-rectangle* 0 0 90 100)
+ ("Rectangle" draw-rectangle* 0 0 90 100)
   ("Triangle" draw-polygon* (0 0 45 100 100 0))
   ("Circle" draw-circle* 50 50 50)
-  ("Polygon" draw-polygon* (0 0 10 100 50 50 90 100 100 10))))
+  ("Polygon" draw-polygon* (0 0 10 100 50 50 90 100 100 10))
+  ))
+
+#+ignore(define-test (basic-graphics-shapes graphics) (stream)
+  "Test basic graphics shapes"
+  (formatting-table 
+   (stream)
+   (formatting-row (stream)
+		   (formatting-cell (stream)
+				    (draw-polygon* stream '(0 0 45 100
+							    100 0) :ink +red+)))
+   (formatting-row (stream)
+		   (formatting-cell (stream)
+				    (draw-rectangle* stream 0 0 90 100)
+				    ))
+   (formatting-row (stream)
+		   (formatting-cell (stream)
+				    (draw-circle* stream 50 50 50)))
+   (formatting-row (stream)
+		   (formatting-cell (stream)
+				    (draw-polygon* stream '(0 0 10 100 50 50 90 100 100 10))
+				    ))
+   ))
 
 (define-test (basic-graphics-shapes graphics) (stream)
   "Test basic graphics shapes"
@@ -1322,6 +1344,8 @@ Luke Luck licks the lakes Luke's duck likes."))
       (multiple-value-bind (xoff yoff)
 	  ;; damn, we have to convert because we want to draw in table-cell relative
 	  ;; coordinates.
+	  (values 0 0)
+	#+ignore
 	  (#-Silica clim::convert-from-absolute-to-relative-coordinates
 	   #+Silica ci::convert-from-absolute-to-relative-coordinates 
 	    stream (output-record-parent record))
@@ -1339,6 +1363,8 @@ Luke Luck licks the lakes Luke's duck likes."))
       (multiple-value-bind (xoff yoff)
 	  ;; damn, we have to convert because we want to draw in table-cell relative
 	  ;; coordinates.
+	  (values 0 0)
+	#+ignore
 	  (#-Silica clim::convert-from-absolute-to-relative-coordinates
 	   #+Silica ci::convert-from-absolute-to-relative-coordinates
 	    stream (output-record-parent record))
@@ -1930,7 +1956,7 @@ Luke Luck licks the lakes Luke's duck likes."))
   (let ((data
 	  (clim-utils:with-standard-io-environment
 	    (let ((data nil)
-		  (*package* (or (find-package "COMMON-LISP-USER")
+		  (*package* (or (find-package :common-lisp-user)
 				 (error "Package COMMON-LISP-USER not found"))))
 	      (dolist (name-and-pathname specs)
 		(let* ((short-name (pop name-and-pathname))
@@ -2885,11 +2911,11 @@ Luke Luck licks the lakes Luke's duck likes."))
   (:command-definer nil)
   (:pane (with-slots (caption-pane display-pane) *application-frame*
 	     (silica::vertically ()
-				 (silica::scrolling
-				  ()
-				  (setf caption-pane
+				 (setf caption-pane
 				    (silica::realize-pane
-				     'application-pane)))
+				     'application-pane
+				     :height 50
+				     ))
 				 (silica::scrolling
 				  ()
 				  (setf display-pane
diff --git a/test/test.lisp b/test/test.lisp
index e5b95562..52da8762 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -134,3 +134,22 @@
 					   
 					   (object)
 					   (list object))
+
+
+(define-application-frame test-frame4 ()
+  (a b c)
+  (:command-table test-frame)
+  (:pane 
+   (vertically ()
+	       (realize-pane 'silica::push-button :label "Press me")
+	       (realize-pane 'silica::toggle-button)
+	       (realize-pane 'silica::slider)
+	       (realize-pane 'silica::text-field)
+	       (silica::scrolling
+		()
+		(silica::realize-pane
+		 'interactor-pane
+		 :width 300
+		 :max-width +fill+
+		 :height 300
+		 :max-height +fill+)))))
diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
index 0835c2d4..02fc91b5 100644
--- a/tk-silica/image.lisp
+++ b/tk-silica/image.lisp
@@ -1,3 +1,28 @@
+;; -*- mode: common-lisp; package: xm-silica -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
+
 (in-package :xm-silica)
 
 
diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp
index 9894a092..9272c89a 100644
--- a/tk-silica/pkg.lisp
+++ b/tk-silica/pkg.lisp
@@ -1,3 +1,4 @@
+;; -*- mode: common-lisp; package: user -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -17,6 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
 
 (defpackage :xm-silica
   (:use clim-lisp clim-utils silica tk))
diff --git a/tk-silica/sysdcl.lisp b/tk-silica/sysdcl.lisp
index 522289bc..24b3c2f2 100644
--- a/tk-silica/sysdcl.lisp
+++ b/tk-silica/sysdcl.lisp
@@ -1,4 +1,4 @@
-(in-package :cl-user)
+;; -*- mode: common-lisp; package: cl-user -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,12 +18,16 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :cl-user)
 
 (defsys::defsystem :xm-silica
-  (:default-pathname (frob-pathname "xm-silica"))
+    (:default-pathname (frob-pathname "xm-silica"))
   ("pkg")
   ("xm-silica")
-  ("xm-graphics"))
+  ("xm-graphics")
+  ("image"))
 
 (defsys::defsystem :xm-ws
   (:default-pathname (frob-pathname "xm-silica"))
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 4e5cbd90..c74e5d1c 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -1,4 +1,4 @@
-(in-package :xm-silica)
+;; -*- mode: common-lisp; package: xm-silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :xm-silica)
+
 
 (defclass motif-frame-manager (frame-manager) 
 	  ())
@@ -204,11 +208,24 @@ Can the basic motif stuff support lazy realization?
      'frame-wm-protocol-callback
      frame)))
 
+(defclass window-manager-event (event)
+	  ())
+
+(defclass wm-delete-window-event (window-manager-event)
+	  ((sheet :initarg :sheet :reader silica::event-sheet))
+  )
+
+(defmethod silica::handle-event (sheet (event wm-delete-window-event))
+  (clim::frame-exit clim::*application-frame*))
+
 (defun frame-wm-protocol-callback (widget frame)
   ;; Invoked when the Wm close function has been selected
   ;; We want to queue an "event" somewhere so that we can
   ;; synchronously quit from the frame
-  )
+  (distribute-event
+   (port frame)
+   (make-instance 'wm-delete-window-event
+		  :sheet (frame-top-level-sheet frame))))
 
 
 
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index c9cfc3af..ccfb6d25 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -29,11 +29,11 @@
 					     (push-button motif-push-button)
 					     (canvas motif-drawing-area)
 					     (text-field motif-text-field)
-					     (toggle-button
-					      motif-toggle-button)
+					     (toggle-button motif-toggle-button)
 					     (silica::menubar motif-menubar)
-					     ;;; One day
 					     (silica::viewport xm-viewport)
+					     
+					     ;; One day
 					     (line-editor-pane)
 					     (label-button-pane)
 					     (radio-button-pane)
@@ -229,7 +229,7 @@
 (defclass motif-scrollbar (motif-leaf-pane 
 			   silica::sheet-permanently-enabled-mixin
 			   gadget
-			   #+ignore motif-value-pane) 
+			   silica::scrollbar)
 	  ((orientation :initarg :orientation))
   (:default-initargs :orientation :horizontal))
 
@@ -344,8 +344,8 @@
 		    sheet))
 
 (defmethod allocate-space ((sheet motif-top-level-sheet) width height)
-  (allocate-space (car (sheet-children sheet)) width
-			  height))
+  (silica::resize-sheet*  (car (sheet-children sheet)) 
+			  width height))
 
 (defmethod compose-space ((sheet motif-top-level-sheet))
   (compose-space (car (sheet-children sheet))))
@@ -529,6 +529,10 @@
   (setf (slot-value vp 'viewport)
     (make-bounding-rectangle 0 0 (sheet-width vp) (sheet-height vp))))
 
+(defmethod allocate-space ((vp xm-viewport) width height)
+  ;; We do nothing to the child of a viewport
+  nil)
+
 (defmethod allocate-space :after ((vp xm-viewport) width height)
   (bounding-rectangle-set-size
    (silica::xm-viewport-viewport vp)
@@ -559,11 +563,11 @@
 	  '(:scrolling-policy :application-defined
 	    :scroll-bar-display-policy :static)))
 
-
-(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport))
-  (let* ((m (call-next-method)))
-    (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m)
-    m))
+; From the days when the parent used to be a motif scroll window
+;(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport))
+;  (let* ((m (call-next-method)))
+;    (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m)
+;    m))
 
 
 (defmethod add-sheet-callbacks  ((port motif-port) (sheet xm-viewport) widget)
@@ -616,16 +620,19 @@
   (clim::pane-scroller-sheet x))
 
 (defun clim::update-region (stream width height &key no-repaint)
-  (setf (sheet-region stream)
-    (make-bounding-rectangle  0 0 
-			      (max (bounding-rectangle-width stream) width)
-			      (max (bounding-rectangle-height stream) height))))
+  (when (or (> width (bounding-rectangle-width stream))
+	    (> height (bounding-rectangle-height stream)))
+    (setf (sheet-region stream)
+      (make-bounding-rectangle  0 0 
+				(max (bounding-rectangle-width stream) width)
+				(max (bounding-rectangle-height stream) height)))))
 
 (defun clim::scroll-extent (stream &key (x 0) (y 0))
 
   ;; This should copy-area and then do a repaint of the new stuff.
   ;; Perhaps for the time being we can just clear the current area and
   ;; then repaint the whole thing
+  #+ignore-why-is-this-here
   (setq y (min y (max (- (bounding-rectangle-height stream)
 			 (bounding-rectangle-height
 			  (clim::pane-viewport stream)))
diff --git a/tk-silica/xm-graphics.lisp b/tk-silica/xm-graphics.lisp
index f4824f18..26ac891c 100644
--- a/tk-silica/xm-graphics.lisp
+++ b/tk-silica/xm-graphics.lisp
@@ -1,4 +1,4 @@
-(in-package :xm-silica)
+;; -*- mode: common-lisp; package: xm-silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :xm-silica)
+
 
 (defmethod make-medium ((port motif-port) sheet)
   (make-instance 'motif-medium
@@ -64,7 +68,6 @@
 	   (tk::gcontext-foreground flipping-gcontext)
 	   (logxor foreground-pixel background-pixel)))))
       
-      
 
 
 (defmethod (setf medium-background) :after (ink (medium motif-medium))
@@ -104,26 +107,39 @@
 (defmethod clx-decode-ink ((ink contrasting-ink) stream)
   (clx-decode-ink (make-color-for-contrasting-ink ink) stream))
 
-(defmethod clx-decode-color :around ((medium motif-medium) color)
-  (or (gethash color (port-color-cache (port medium)))
-      (setf (gethash color (port-color-cache (port medium)))
-	(call-next-method))))
+      
+
+(defmethod clx-decode-color ((medium motif-medium) (x (eql +foreground+)))
+  (with-slots (foreground-gcontext) medium
+    (tk::gcontext-foreground foreground-gcontext)))
+
+(defmethod clx-decode-color ((medium motif-medium) (x (eql +background+)))
+  (with-slots (background-gcontext) medium
+    (tk::gcontext-foreground background-gcontext)))
+
+
+(defmethod clx-decode-color ((stream motif-medium) (ink standard-opacity))
+  (if (> (slot-value ink 'clim-utils::value) 0.5)
+      (clx-decode-color stream +foreground+)
+    (clx-decode-color stream +background+)))
 
 (defmethod clx-decode-color ((medium motif-medium) (ink color))
-  (multiple-value-bind
-      (red green blue)
-      (color-rgb ink)
-    (tk::allocate-color
-     (tk::default-colormap (port-display (port medium)))
-     (make-instance 'tk::color
-		    :red (truncate (* 65356 red))
-		    :green (truncate (* 65356 green))
-		    :blue (truncate (* 65356 blue))))))
-
-
-(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style)
+  (or (gethash ink (port-color-cache (port medium)))
+      (setf (gethash ink (port-color-cache (port medium)))
+	(multiple-value-bind
+	    (red green blue)
+	    (color-rgb ink)
+	  (tk::allocate-color
+	   (tk::default-colormap (port-display (port medium)))
+	   (make-instance 'tk::color
+			  :red (truncate (* 65356 red))
+			  :green (truncate (* 65356 green))
+			  :blue (truncate (* 65356 blue))))))))
+
+
+(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style x-origin y-origin)
   ;; This is used to adjust for the line-style
-  (declare (ignore ink line-style))
+  (declare (ignore ink))
 
   (let ((thickness (silica::line-style-thickness line-style)))
     (if (< thickness 2)
@@ -142,6 +158,12 @@
       ((:miter :none) :miter)
       (:bevel :bevel)
       (:round :round)))
+  
+  
+  (when (eq (tk::gcontext-fill-style gc) :tiled)
+    (setf (tk::gcontext-ts-x-origin gc) x-origin
+	  (tk::gcontext-ts-y-origin gc) y-origin))
+  
   gc)
 
 (defmethod clx-decode-ink :around ((ink t) (medium motif-medium))
@@ -165,6 +187,11 @@
       (transform-point* transform x y))
   (values (truncate x) (truncate y)))
 
+(defun devicize-distance (transform x y)
+  (multiple-value-setq (x y)
+      (transform-distance transform x y))
+  (values (truncate x) (truncate y)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
@@ -182,7 +209,9 @@
    (clx-adjust-ink medium
 		   (clx-decode-ink (medium-ink medium) medium)
 		   (medium-ink medium)
-		   (medium-line-style medium))
+		   (medium-line-style medium)
+		   (min x1 x2)
+		   (min y1 y2))
    x1
    y1
    x2
@@ -203,9 +232,11 @@
 	  (tk::draw-rectangle
 	   (tk::widget-window (sheet-mirror sheet))
 	   (clx-adjust-ink medium
-		   (clx-decode-ink (medium-ink medium) medium)
-		   (medium-ink medium)
-		   (medium-line-style medium)) 
+			   (clx-decode-ink (medium-ink medium) medium)
+			   (medium-ink medium)
+			   (medium-line-style medium)
+			   (min x1 x2)
+			   (min y1 y2))
 	   (min x1 x2)
 	   (min y1 y2)
 	   (abs (- x2 x1))
@@ -301,27 +332,56 @@
 (defmethod port-beep ((port motif-port) (sheet t))
   (x11:xbell (tk::display-handle (port-display port)) 100))
 
-(defmethod silica::port-draw-circle* ((port motif-port)
-				      sheet
-				      medium
-				      center-x
-				      center-y
-				      radius
-				      filled)
+
+(defmethod silica::port-draw-ellipse* ((port motif-port)
+				       sheet
+				       medium
+				       center-x
+				       center-y
+				       radius-1-dx 
+				       radius-1-dy 
+				       radius-2-dx
+				       radius-2-dy 
+				       start-angle 
+				       end-angle 
+				       filled)
   (let ((transform (compose-transformations
 		    (medium-transformation medium)
 		    (sheet-device-transformation sheet))))
     (multiple-value-setq (center-x center-y) 
       (devicize-point transform center-x center-y))
-    (tk::draw-circle
+    
+
+    (multiple-value-setq (radius-1-dx radius-1-dy) 
+      (devicize-distance transform  radius-1-dx radius-1-dy))
+    
+
+    (multiple-value-setq (radius-2-dx radius-2-dy) 
+      (devicize-distance transform radius-2-dx
+		       radius-2-dy))
+    
+    (tk::draw-ellipse
      (tk::widget-window (sheet-mirror sheet))
      (clx-adjust-ink medium
-		   (clx-decode-ink (medium-ink medium) medium)
-		   (medium-ink medium)
-		   (medium-line-style medium))
+		     (clx-decode-ink (medium-ink medium) medium)
+		     (medium-ink medium)
+		     (medium-line-style medium)
+		     (- center-x 
+			(if (zerop radius-1-dx)
+			    radius-2-dx
+			  radius-1-dx))
+		     (- center-y 
+			(if (zerop radius-1-dy)
+			    radius-2-dy
+			  radius-1-dy)))
      center-x
      center-y
-     radius
+     radius-1-dx 
+     radius-1-dy 
+     radius-2-dx
+     radius-2-dy 
+     start-angle 
+     end-angle 
      filled)))
    
 (ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint)
@@ -341,7 +401,9 @@
 			((and closed (not filled))
 			 (incf npoints))
 			(t npoints)))))
-	 (window (tk::widget-window (sheet-mirror sheet))))
+	 (window (tk::widget-window (sheet-mirror sheet)))
+	 (minx most-positive-fixnum)
+	 (miny most-positive-fixnum))
 		 
     (do ((ps list-of-x-and-ys (cddr ps))
 	 (i 0 (1+ i))
@@ -351,6 +413,8 @@
       (multiple-value-bind
 	  (x y)
 	  (devicize-point transform (car ps) (cadr ps))
+	(minf minx x)
+	(minf miny y)
 	(setf (xpoint-array-x points i) x
 	      (xpoint-array-y points i) y)))
     
@@ -365,7 +429,9 @@
 	 (tk::object-handle (clx-adjust-ink medium
 					    (clx-decode-ink (medium-ink medium) medium)
 					    (medium-ink medium)
-					    (medium-line-style medium)))
+					    (medium-line-style medium)
+					    minx
+					    miny))
 	 points
 	 npoints
 	 x11:complex
@@ -376,10 +442,62 @@
        (tk::object-handle (clx-adjust-ink medium
 					  (clx-decode-ink (medium-ink medium) medium)
 					  (medium-ink medium)
-					  (medium-line-style medium)))
+					  (medium-line-style medium)
+					  minx
+					  miny))
        points
        npoints
        x11:coordmodeorigin))))
-      
-    
+
+
+(defmethod clx-decode-ink ((ink rectangular-tile) medium)
+  (multiple-value-bind (pattern width height)
+      (decode-rectangular-tile ink)
+    (clx-decode-pattern pattern medium width height t)))
+
+(defmethod clx-decode-ink ((ink pattern) medium)
+  (clx-decode-pattern ink medium))
     
+(defmethod clx-decode-pattern ((pattern pattern) medium &optional width height tiled-p)    
+  (let ((ink-table (slot-value medium 'ink-table)))
+    (or  (gethash pattern ink-table)
+	 (setf (gethash pattern ink-table)
+	   (multiple-value-bind
+	       (array designs)
+	       (decode-pattern pattern)
+	     (let ((image-data (make-array (array-dimensions array))))
+	       (dotimes (w (array-dimension array 1))
+		 (dotimes (h (array-dimension array 0))
+		   (setf (aref image-data h w)
+		     (clx-decode-color medium 
+				       (elt designs (aref array h w))))))
+	       (let* ((pattern-height (array-dimension array 0))
+		      (pattern-width (array-dimension array 1))
+		      (image (make-instance 
+			      'tk::image
+			      :width pattern-width
+			      :height pattern-height
+			      :data image-data
+			      :depth 8 ;; hardwire
+			      ))
+		      (gc 
+		       (make-instance 'tk::gcontext
+				      :drawable (tk::display-root-window 
+						 (port-display (port
+								medium)))))
+		      (pixmap 
+		       (make-instance 'tk::pixmap
+				      :drawable (tk::display-root-window 
+						 (port-display (port
+								medium)))
+				    
+				      :width pattern-width
+				      :height pattern-height
+				      :depth 8)))
+		 (tk::put-image pixmap gc image :x 0 :y 0)
+		 (setf (tk::gcontext-tile gc) pixmap
+		       (tk::gcontext-fill-style gc) :tiled)
+		 gc)))))))
+		
+		
+	     
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index b353144d..2a6d620b 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -1,4 +1,4 @@
-(in-package :xm-silica)
+;; -*- mode: common-lisp; package: xm-silica -*-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -18,6 +18,10 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
+
+(in-package :xm-silica)
+
 
 (defmethod find-port-type ((type (eql ':motif)))
   'motif-port)
@@ -75,16 +79,14 @@
   
   (let* ()
     (flet ((font->text-style (font family)
-	     (let* ((tokens (disassemble-x-font-name (tk::font-name font)))
+	     (let* ((tokens (disassemble-x-font-name font))
 		    (italic (member (fifth tokens) '("i" "o") :test #'equalp))
 		    (bold (equalp (fourth tokens) "Bold"))
 		    (face (if italic
 			      (if bold '(:bold :italic) :italic)
 			    (if bold :bold :roman)))
-		    (designed-point-size (or (tk::font-property font :POINT_SIZE)
-					     (parse-integer (ninth tokens))))
-		    (designed-y-resolution (or (tk::font-property font :RESOLUTION_Y)
-					       (parse-integer (nth 10 tokens))))
+		    (designed-point-size (parse-integer (ninth tokens)))
+		    (designed-y-resolution (parse-integer (nth 10 tokens)))
 		    (point-size (float designed-point-size))
 		    (size (/ point-size 10)))
 	       (make-text-style family face size))))
@@ -92,17 +94,13 @@
 	(let ((family (car family-stuff)))
 	  (dolist (font-pattern (cdr family-stuff))
 	    (dolist (xfont (tk::list-font-names display font-pattern))
-	      (let ((xfont (make-instance
-						   'tk::font 
-						   :display display
-						   :name xfont)))
 	      (let ((text-style (font->text-style xfont family)))
 		;; prefer first font satisfying this text style, so
 		;; don't override if we've already defined one.
 		(unless (silica::text-style-mapping-exists-p
 			 display-device *standard-character-set* text-style t)
 		  (silica::add-text-style-mapping display-device *standard-character-set*
-					  text-style xfont))))))
+					  text-style xfont)))))
 	  ;; Now build the logical size alist for the family
 	  
 	  
@@ -328,7 +326,7 @@
       (sheet-mirror ma))))
 
 (defmethod find-shell-class-and-initargs (port sheet)
-  (values 'top-level-shell '()))
+  (values 'top-level-shell nil))
 
 (defmethod enable-mirror (port sheet)
   (declare (ignore port))
@@ -456,6 +454,23 @@
   (silica::text-style-mapping port nil font nil))
 
 
+
+(defmethod text-style-mapping :around ((device motif-port)
+				       character-set 
+				       text-style 
+				       etc)
+  (declare (ignore etc))
+  (let ((font (call-next-method)))
+    (when (or (stringp font) (symbolp font))
+      (let* ((font-name (string font)))
+	(setf font (make-instance 'tk::font 
+				    :display (port-display device)
+				    :name font-name))
+	(add-text-style-mapping
+	  device character-set (parse-text-style text-style) font)))
+    font))
+
+
 (defmethod silica::text-style-width ((text-style text-style) medium)
   (tk::font-width (realize-text-style (port medium) text-style)))
 
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index ffd536c2..ead8205d 100644
--- a/tk/callbacks.lisp
+++ b/tk/callbacks.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defforeign 'add_callback
diff --git a/tk/convenience.lisp b/tk/convenience.lisp
index 7b104ba0..e2edf484 100644
--- a/tk/convenience.lisp
+++ b/tk/convenience.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 					;
diff --git a/tk/defsys.lisp b/tk/defsys.lisp
index 4f51d92c..9eb4a528 100644
--- a/tk/defsys.lisp
+++ b/tk/defsys.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: user -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 
 (defsys::defsystem :xm-tk
   (:default-pathname (frob-pathname "tk"))
diff --git a/tk/event.lisp b/tk/event.lisp
index 124fa95c..2e6eed9d 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defforeign 'app_pending 
diff --git a/tk/examples.lisp b/tk/examples.lisp
index dbf46d37..e16f1022 100644
--- a/tk/examples.lisp
+++ b/tk/examples.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 ;;; CLM bitmap code
diff --git a/tk/font.lisp b/tk/font.lisp
index 9f113bb2..13de4ca9 100644
--- a/tk/font.lisp
+++ b/tk/font.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defclass font (handle-class)
diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp
index c8c7103d..56aedb48 100644
--- a/tk/foreign-obj.lisp
+++ b/tk/foreign-obj.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defclass handle-class ()
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 981663c7..2214315b 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (eval-when (compile load eval)
@@ -15,8 +39,8 @@
 	       (arc-mode :int)
 	       (tile :pixmap)
 	       (stipple :pixmap)
-	       (ts-x :int)
-	       (ts-y :int)
+	       (ts-x-origin :int)
+	       (ts-y-origin :int)
 	       (font x-font)
 	       (subwindow-mode :int)
 	       (exposures :boolean)
@@ -29,7 +53,7 @@
 	   (defconstant *gcontext-bit-mask*
 	     '(function plane-mask foreground background
 			line-width line-style cap-style join-style fill-style
-			fill-rule tile stipple ts-x ts-y font subwindow-mode
+			fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode
 			exposures clip-x clip-y clip-mask dash-offset dashes
 			arc-mode)))
 
@@ -126,14 +150,15 @@
 	 (x11:xchangegc
 	  (display-handle (object-display gc))
 	  (object-handle gc)
-	  ,(ash 1 (position name *gcontext-bit-mask*))
+	  ,(ash 1 (or (position name *gcontext-bit-mask*)
+		      (error "Cannot find ~S in gcontext components" name)))
 	  gc-values)
 	 nv))))
 
 (defmacro define-gc-reader (name decoder &rest args)
   `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) (gc)
     (,decoder 
-     (,(intern (format nil "~A~A" 'xgcvalues- name) :x11)
+     (,(intern (format nil "~A~A" '_xgc-values- name) :x11)
       (object-handle gc))
      ,@args)))
 
@@ -152,10 +177,10 @@
 ;(define-gc-accessor background  (encode-pixel decode-pixel))
 
 (defmethod gcontext-foreground ((gc gcontext))
-  (decode-pixel (x11:xgcvalues-foreground (object-handle gc))))
+  (decode-pixel (x11::_xgc-values-foreground (object-handle gc))))
 
 (defmethod gcontext-background ((gc gcontext))
-  (decode-pixel (x11:xgcvalues-background (object-handle gc))))
+  (decode-pixel (x11::_xgc-values-background (object-handle gc))))
 
 (defmethod (setf gcontext-foreground) (nv (gc gcontext))
   (x11:xsetforeground 
@@ -177,10 +202,13 @@
 (define-gc-accessor tile  (encode-pixmap decode-pixmap))
 (define-gc-accessor stipple  (encode-pixmap decode-pixmap))
 
+(defun encode-pixmap (x)
+  (object-handle x))
 
-(define-gc-accessor ts-x (encode-int16 decode-int16))
-(define-gc-accessor ts-y (encode-int16  decode-int16))
+(define-gc-accessor ts-x-origin (encode-int16 decode-int16))
+(define-gc-accessor ts-y-origin (encode-int16  decode-int16))
 
+   
 (define-gc-accessor font (encode-font decode-font))
 (define-gc-accessor line-style  (encode-enum decode-enum) '(:solid :dash :double-dash))
 (define-gc-accessor cap-style (encode-enum decode-enum) '(:not-last :butt :round :projecting))
@@ -327,6 +355,8 @@
 
 (defmethod encode-pixel ((x integer))
   x)
+
+(defun decode-pixel (x) x)
 (defmethod encode-pixel ((x color))
   (allocate-color (default-colormap display 0) x))
 
diff --git a/tk/graphics.lisp b/tk/graphics.lisp
index df8ad9c1..82060c95 100644
--- a/tk/graphics.lisp
+++ b/tk/graphics.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defun draw-point (drawable gcontext x y)
@@ -27,6 +51,53 @@
    y2))
 
 
+(defun draw-ellipse (drawable gcontext center-x 
+		     center-y
+		     radius-1-dx 
+		     radius-1-dy 
+		     radius-2-dx
+		     radius-2-dy 
+		     start-angle 
+		     end-angle 
+		     filled)
+  (multiple-value-bind (x-radius y-radius)
+      (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+	     (values (abs radius-2-dx) (abs radius-1-dy)))
+	    ((and (= radius-2-dx 0) (= radius-1-dy 0))
+	     (values (abs radius-1-dx) (abs radius-2-dy)))
+	    (t
+	     (let ((s-1 (+ (* radius-1-dx radius-1-dx) 
+			   (* radius-1-dy radius-1-dy)))
+		   (s-2 (+ (* radius-2-dx radius-2-dx) 
+			   (* radius-2-dy radius-2-dy))))
+	       (if (= s-1 s-2)
+		   (let ((r (truncate (sqrt s-1))))
+		     (values r r))
+		 ;; Degrade to drawing a rectilinear ellipse
+		 (values (truncate (sqrt s-1)) 
+			 (truncate (sqrt s-2)))))))
+    (if filled
+	(x11:xfillarc
+	 (display-handle (object-display drawable))
+	 (object-handle drawable)
+	 (object-handle gcontext)
+	 (- center-x x-radius)
+	 (- center-y y-radius)
+	 (* 2 x-radius)
+	 (* 2 y-radius)
+	 0
+	 (* 360 64))
+      (x11:xdrawarc
+       (display-handle (object-display drawable))
+       (object-handle drawable)
+       (object-handle gcontext)
+       (- center-x x-radius)
+       (- center-y y-radius)
+       (* 2 x-radius)
+       (* 2 y-radius)
+       0
+       (* 360 64)))))
+
 (defstub draw-lines (drawable gcontext points &key relative-p fill-p
 			    (shape :complex))
   )
diff --git a/tk/init.lisp b/tk/init.lisp
index c4b8d31c..2e12ace8 100644
--- a/tk/init.lisp
+++ b/tk/init.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 
 (in-package :tk)
 
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index 7aee1409..84c77942 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 #|
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index ffe7c1ad..140e07d5 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 #|
diff --git a/tk/loadit.lisp b/tk/loadit.lisp
index 6eb9d47c..04f8e6d4 100644
--- a/tk/loadit.lisp
+++ b/tk/loadit.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: user -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (load "pkg")
 (load "foreign-obj")
 (load "load-xm")
diff --git a/tk/macros.lisp b/tk/macros.lisp
index 17ecf840..fba667dd 100644
--- a/tk/macros.lisp
+++ b/tk/macros.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defmacro with-ref-par (bindings &body body)
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 223a8a8f..09511905 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (ff:defforeign 'insert_classes :return-type :fixnum)
diff --git a/tk/ol-examples.lisp b/tk/ol-examples.lisp
index 796d59ff..e441ccd7 100644
--- a/tk/ol-examples.lisp
+++ b/tk/ol-examples.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defun example-1 ()
diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp
index 5371b089..dddb01c5 100644
--- a/tk/ol-init.lisp
+++ b/tk/ol-init.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 
 (in-package :tk)
 
diff --git a/tk/pkg.lisp b/tk/pkg.lisp
index 8239ba3d..46716172 100644
--- a/tk/pkg.lisp
+++ b/tk/pkg.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: user -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (defpackage :tk
   (:use common-lisp ff)
   (:export
diff --git a/tk/resources.lisp b/tk/resources.lisp
index e66fc435..d64bba28 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defmacro define-enumerated-resource (type elements)
@@ -23,9 +47,9 @@
 
 (defun make-arglist-for-class (class parent args)
   (do ((new-args nil)
-       (resources (append 
-		   (class-resources class)
-		   (and parent (class-constraint-resources (class-of parent)))))
+       (resources-1 (class-resources class))
+       (resources-2 (and parent (class-constraint-resources
+				    (class-of parent))))
        keyword
        value)
       ((null args)
@@ -34,7 +58,8 @@
 		   :initial-contents (nreverse new-args)))
     (setq keyword (pop args)
 	  value (pop args))
-    (let ((resource (find keyword resources :key #'resource-name)))
+    (let ((resource (or (find keyword resources-1 :key #'resource-name)
+			(find keyword resources-2 :key #'resource-name))))
       (when resource
 	(push (resource-original-name resource) new-args)
 	(push (convert-resource-out parent (resource-type resource) value)
diff --git a/tk/widget.lisp b/tk/widget.lisp
index ee1c4b5b..693119f5 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $aclHeader$
+
 (in-package :tk)
 
 (defun app-create-shell (&rest args
@@ -59,6 +83,13 @@
   (manage_child (object-handle child)))
 
 
+(defforeign 'unmanage_child
+    :entry-point "_XtUnmanageChild")
+
+(defun unmanage-child (child)
+  (unmanage_child (object-handle child)))
+
+
 (defforeign 'create_popup_shell 
     :entry-point "_XtCreatePopupShell")
 
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 052889c6..4647a11a 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 ;;; Pathetic clos interface to Xlib
@@ -15,11 +39,29 @@
 
 
 
-(defclass window (display-object handle-class)
+(defclass drawable (display-object handle-class)
+	  ())
+	  
+(defclass window (drawable)
 	  ())
 
+(defclass pixmap (drawable)
+	  ())
 
-
+(defforeign 'x_create_pixmap
+    :entry-point "_XCreatePixmap")
+
+(defmethod initialize-instance :after ((p pixmap) &key width height
+						       depth drawable)
+  (setf (slot-value p 'handle)
+    (x_create_pixmap
+     (display-handle display)
+     (object-handle drawable)
+     width
+     height
+     depth))
+  (register-address p))
+		   
 (defun-c-callable x-error-handler (display (x :unsigned-long))
   (error "x-error:~S" 
 	 (get-error-text (x11:xerrorevent-error-code x))))
@@ -252,3 +294,58 @@
 	compose-status)
        (char*-to-string buffer)
        (aref keysym 0)))))
+
+(defclass image (handle-class)
+	  ((width :reader image-width :initarg :width)
+	   (height :reader image-height :initarg :height)))
+
+
+(defforeign 'x_create_image
+    :entry-point "_XCreateImage")
+
+(defmethod initialize-instance :after ((i image) &key width height data depth)
+  (let (v)
+    (ecase depth
+      (8 
+       (setq v (excl::malloc (* width height)))
+       (dotimes (w width)
+	 (dotimes (h height)
+	   (setf (sys::memref-int v (+ (* h width) w) 0 :unsigned-byte)
+	     (aref data h w))))))
+    (let* ((bytes-per-line 0)
+	   (bitmap-pad 8) ;;; Why is this 8 - if 0 get signal 8!
+	   (visual (x11:screen-root-visual
+		    (display-default-screen display)))
+	   (format x11:zpixmap)
+	   (offset 0)
+	   (x (x_create_image
+	       (display-handle display)
+	       visual
+	       depth
+	       format
+	       offset
+	       v
+	       width
+	       height
+	       bitmap-pad
+	       bytes-per-line)))
+      (setf (slot-value i 'handle) x))))
+
+
+(defforeign 'x_put_image
+    :entry-point "_XPutImage")
+
+(defmethod put-image (pixmap gc image &key x y)
+  (x_put_image
+   (display-handle display)
+   (object-handle pixmap)
+   (object-handle gc)
+   (object-handle image)
+   0 ;; src-x
+   0 ;; src-t
+   0 ;; dest-x
+   0 ;; dest-y
+   (image-width image)
+   (image-height image)))
+   
+  
diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp
index 412bf945..bad9bf6c 100644
--- a/tk/xm-init.lisp
+++ b/tk/xm-init.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 
 (in-package :tk)
 
diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp
index 3d6265a0..50002c50 100644
--- a/tk/xm-protocols.lisp
+++ b/tk/xm-protocols.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defforeign 'xm_add_protocol_callback
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index c3d22bd5..9bb8b48a 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (defgeneric make-widget (widget &key)
diff --git a/tk/xtk.lisp b/tk/xtk.lisp
index 245daaa0..c8b49cd2 100644
--- a/tk/xtk.lisp
+++ b/tk/xtk.lisp
@@ -1,3 +1,27 @@
+;; -*- mode: common-lisp; package: tk -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader$
+
 (in-package :tk)
 
 (def-c-typedef :cardinal :unsigned-int)
diff --git a/utils/condpat.lisp b/utils/condpat.lisp
index e74bea2d..50169f8b 100644
--- a/utils/condpat.lisp
+++ b/utils/condpat.lisp
@@ -18,6 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
 
 (in-package :clim-utils)
 
diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp
index 01ac0840..71f85ead 100644
--- a/utils/defun-utilities.lisp
+++ b/utils/defun-utilities.lisp
@@ -18,6 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
 
 (in-package :clim-utils)
 
diff --git a/utils/reader.lisp b/utils/reader.lisp
index 92f69822..5c396cea 100644
--- a/utils/reader.lisp
+++ b/utils/reader.lisp
@@ -18,6 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+;; $fiHeader$
 
 (in-package :clim-utils)
 
diff --git a/utils/regions.lisp b/utils/regions.lisp
index 647a48a2..5b33884c 100644
--- a/utils/regions.lisp
+++ b/utils/regions.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: regions.lisp,v 1.1 91/08/30 13:57:50 cer Exp Locker: cer $
+;; $fiHeader: regions.lisp,v 1.1 91/11/25 10:01:45 cer Exp Locker: cer $
 
 (in-package :clim-utils)
 
@@ -873,7 +873,9 @@
 ;; not axis-aligned.  It's not worth computing anything tighter because
 ;; the refined highlighting test will be faster than the computation of
 ;; a tighter box.
-(defun elliptical-arc-box (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
+
+(defun elliptical-arc-box (center-x center-y 
+			   radius-1-dx radius-1-dy radius-2-dx radius-2-dy
 			   theta-1 theta-2 thickness)
   (let* ((filled (null thickness))
 	 (thickness (or thickness 0))
@@ -888,35 +890,46 @@
     (setq theta-1 (mod theta-1 2pi)
 	  theta-2 (mod theta-2 2pi))
     ;;--- Fix the NYI stuff some year
-    (let* ((x-radius (cond ((zerop radius-1-dx) radius-2-dx)
-			   ((zerop radius-2-dx) radius-1-dx)
-			   (t (nyi))))
-	   (y-radius (cond ((zerop radius-1-dy) radius-2-dy)
-			   ((zerop radius-2-dy) radius-1-dy)
-			   (t (nyi))))
-	   (x1 (+ center-x (* x-radius (cos theta-1))))
-	   (y1 (+ center-y (* y-radius (sin theta-1))))
-	   (x2 (+ center-x (* x-radius (cos theta-2))))
-	   (y2 (+ center-y (* y-radius (sin theta-2))))
-	   (left (min x1 x2))
-	   (top (min y1 y2))
-	   (right (max x1 x2))
-	   (bottom (max y1 y2)))
-      (when (angle-between-angles-p pi-single-float theta-1 theta-2)
-	(minf left (- center-x x-radius)))
-      (when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2)
-	(minf top (- center-y y-radius)))
-      (when (angle-between-angles-p 0 theta-1 theta-2)
-	(maxf right (+ center-x x-radius)))
-      (when (angle-between-angles-p pi/2 theta-1 theta-2)
-	(maxf bottom (+ center-y y-radius)))
-      (when filled
-	(minf left center-x)
-	(minf top center-y)
-	(maxf right center-x)
-	(maxf bottom center-y))
-      (fix-rectangle (- left lthickness) (- top lthickness)
-		     (+ right rthickness) (+ bottom rthickness)))))
+    
+    (multiple-value-bind (x-radius y-radius)
+	(cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
+	       (values (abs radius-2-dx) (abs radius-1-dy)))
+	      ((and (= radius-2-dx 0) (= radius-1-dy 0))
+	       (values (abs radius-1-dx) (abs radius-2-dy)))
+	      (t
+	       (let ((s-1 (+ (* radius-1-dx radius-1-dx) 
+			     (* radius-1-dy radius-1-dy)))
+		     (s-2 (+ (* radius-2-dx radius-2-dx) 
+			     (* radius-2-dy radius-2-dy))))
+		 (if (= s-1 s-2)
+		     (let ((r (truncate (sqrt s-1))))
+		       (values r r))
+		   ;; Degrade to drawing a rectilinear ellipse
+		   (values (truncate (sqrt s-1)) 
+			   (truncate (sqrt s-2)))))))
+      (let* ((x1 (+ center-x (* x-radius (cos theta-1))))
+	     (y1 (+ center-y (* y-radius (sin theta-1))))
+	     (x2 (+ center-x (* x-radius (cos theta-2))))
+	     (y2 (+ center-y (* y-radius (sin theta-2))))
+	     (left (min x1 x2))
+	     (top (min y1 y2))
+	     (right (max x1 x2))
+	     (bottom (max y1 y2)))
+	(when (angle-between-angles-p pi-single-float theta-1 theta-2)
+	  (minf left (- center-x x-radius)))
+	(when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2)
+	  (minf top (- center-y y-radius)))
+	(when (angle-between-angles-p 0 theta-1 theta-2)
+	  (maxf right (+ center-x x-radius)))
+	(when (angle-between-angles-p pi/2 theta-1 theta-2)
+	  (maxf bottom (+ center-y y-radius)))
+	(when filled
+	  (minf left center-x)
+	  (minf top center-y)
+	  (maxf right center-x)
+	  (maxf bottom center-y))
+	(fix-rectangle (- left lthickness) (- top lthickness)
+		       (+ right rthickness) (+ bottom rthickness))))))
 
 (defun angle-between-angles-p (theta theta-1 theta-2)
   (unless (< theta-1 theta-2)
-- 
GitLab