diff --git a/Makefile b/Makefile
index 92090a1a57753598f45fac711e21b702542cc217..0021f3b928925151eb6b319f04f7ffa1e667ada8 100644
--- a/Makefile
+++ b/Makefile
@@ -1,8 +1,8 @@
-# $fiHeader: Makefile,v 1.26 92/05/06 15:37:50 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.27 92/05/07 13:13:41 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
-CL	= /vapor/usr/tech/cer/cl/src/dcl
+CL	= /usr/tech/cer/cl/src/dcl
 DUMP-CL	= $(CL)
 CLOPTS	= -qq
 
@@ -27,6 +27,11 @@ LOAD_XREF_INFO=nil
 SPEED	= 3
 SAFETY	= 1
 
+CFLAGS	= -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD -I/x11/motif-1.1/lib
+
+OLDSPACE = 15000000
+NEWSPACE = 5000000
+
 # Name of dumped lisp
 CLIM	= ./slim
 CLIM-SMALL	= ./slim-small
@@ -43,13 +48,14 @@ ECHO	= /bin/echo
 MV	= /usr/fi/mv-nfs
 TAGS	= /usr/fi/lib/emacs/etc/etags
 TMP	= /usr/tmp
+
 SRC_FILES = */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \
 	    misc/undefinedsymbols misc/undefinedsymbols.olit \
 	    misc/undefinedsymbols.motif misc/undefinedsymbols.xt
 
 DEST=/dev/null
 
-CL_SRC=/vapor/usr/tech/cer/cl/src
+CL_SRC=/usr/tech/cer/cl/src
 OPENWINHOME=/usr/openwin-3.0
 
 #MOTIFHOME=/usr/motif
@@ -82,8 +88,8 @@ XM_UNDEFS=misc/undefinedsymbols.motif
 OL_UNDEFS=misc/undefinedsymbols.olit
 
 CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl
-CLIMOBJS= stub-x.o stub-xt.o stub-motif.o stub-olit.o
-FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o
+CLIMOBJS= stub-x.o stub-xt.o stub-motif.o stub-olit.o xlibsupport.o MyDrawingA.o
+FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o `pwd`/xlibsupport.o `pwd`/MyDrawingA.o
 
 
 #
@@ -424,13 +430,13 @@ makeclimobjs	: $(CLIMOBJS)
 ################## Lower level Makefile stuff
 
 
-ol-dcl	:  stub-x.o stub-xt.o stub-olit.o
+ol-dcl	:  stub-x.o stub-xt.o stub-olit.o xlibsupport.o MyDrawingA.o
 	cd $(CL_SRC) ; /bin/rm -f ucl ;\
-	 make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(LIBXOL) $(OLXLIBS)' dcl
+	make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-olit.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(LIBXOL) $(OLXLIBS)' dcl
 
-xm-dcl	: stub-x.o stub-xt.o stub-motif.o
+xm-dcl	: stub-x.o stub-xt.o stub-motif.o xlibsupport.o MyDrawingA.o
 	cd $(CL_SRC) ; /bin/rm -f ucl ;\
-	make ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl	
+	make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(MOTIFLIB) $(XTLIB) $(XLIB)' dcl	
 
 dcl	: 
 	cd $(CL_SRC) ; /bin/rm -f ucl ;\
@@ -449,6 +455,12 @@ stub-x.c	:  $(UNDEFS) $(OL_UNDEFS) misc/make-stub-file
 stub-xt.c	:  $(XT_UNDEFS) misc/make-stub-file
 	misc/make-stub-file "void ___lisp_load_xt_stub ()"  $(XT_UNDEFS)  > stub-xt.c 
 
+xlibsupport.o	: xlib/xlibsupport.c
+	$(CC) -c $(CFLAGS) -o xlibsupport.o xlib/xlibsupport.c
+
+MyDrawingA.o: misc/MyDrawingA.c
+	$(CC) -c $(CFLAGS) -o MyDrawingA.o misc/MyDrawingA.c
+
 FRC	: 
 
 xm-composer : xm-dcl
diff --git a/clim/frames.lisp b/clim/frames.lisp
index ad6f3fa5111fa97525419ec3be007472453f777f..9b5964fc001db06e4acc871c3533074458e8ff8e 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.19 92/05/07 13:12:14 cer Exp Locker: cer $
+;; $fiHeader: frames.lisp,v 1.20 92/05/12 18:24:58 cer Exp Locker: cer $
 
 (in-package :clim-internals)
 
@@ -359,7 +359,7 @@
 	 (error "Invalid pane specification: ~S"
 		(list* name code rest)))))
 
-(defmethod find-pane-class-constructor ((typep t) &rest options)
+(defmethod find-pane-class-constructor ((type t) &rest options)
   (error "Unknown pane type ~S with options ~S" type options))
 
 (defmacro define-pane-type (type lambda-list &body body)
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index 717a3a5e3007b067f2190d8362f58ab1831dcfd2..da85ad8df4194e8b9de05308cdd1f057247cc2ed 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.4 92/04/28 09:26:19 cer Exp Locker: cer $
+;; $fiHeader: compile-1.lisp,v 1.5 92/05/07 13:13:46 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -47,8 +47,10 @@
   (let ((*enable-package-locked-errors* nil))
     (load "sys/defsystem")))
 
+
+
 (defun compile-it (sys)
-  (unless (ignore-errors (defsys::find-system sys))
+  (unless (ignore-errors (clim-defsys::find-system sys))
     (load "sys/sysdcl"))
   (clim-defsys::compile-system sys :propagate t)
   (tenuring
diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp
index bab56be6d45a23362f529ba3a3dd099a796dec8d..2b24b04bcf34a104d9b5046b97f3228cbbad4467 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,9 +20,9 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.4 92/04/21 20:28:22 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.5 92/05/07 13:13:47 cer Exp Locker: cer $
 
-(excl::free (excl::malloc 131072))
+(excl::free (excl::malloc 262145))
 
 (setq *ignore-package-name-case* t)
 (set-case-mode :case-insensitive-lower)
@@ -51,10 +51,10 @@
 	(load "climol.fasl")
 	(load "clim-debug.fasl")))
      #+ignore
-     (defsys::load-system sys)))
+     (clim-defsys:load-system sys)))
 
   #+ignore
-  (defsys:update-system sys)
+  (clim-defsys:update-system sys)
 
   ;;-- What would be good is to mark the files in the system as having
   ;;-- been loaded
diff --git a/silica/event.lisp b/silica/event.lisp
index 0fec52a8af4bc9e4caea140bef149c96ce8ccd35..e8853bf20c6e73195d03cd5ddeb78f19cbbf5c9a 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.9 92/04/15 11:45:08 cer Exp $
+;; $fiHeader: event.lisp,v 1.10 92/05/07 13:11:17 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -32,6 +32,12 @@
 
 (defgeneric port-keyboard-input-focus (port))
 
+(defmethod print-object ((event window-repaint-event) stream)
+  (with-slots (region) event
+    (with-bounding-rectangle* (left top right bottom) region
+      (print-unreadable-object (event stream :type t)
+	(format stream "/x ~A:~A y ~A:~A/" left right top bottom)))))
+
 (defmethod handle-event (client (event window-repaint-event))
   (handle-repaint client nil 
 		  (window-event-region event)))
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 889fb34e1a4984700d849d5e484b5273e8ab723e..bc28f171cd0b58b0948a23b3d248e098be4777b8 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: medium.lisp,v 1.9 92/04/10 14:26:37 cer Exp $
+;; $fiHeader: medium.lisp,v 1.10 92/05/07 13:11:25 cer Exp Locker: cer $
 
 (in-package :silica)
 
@@ -15,12 +15,14 @@
   (declare (ignore sheet port))
   nil)
 
+
 (defmethod invoke-with-sheet-medium ((sheet sheet) continuation)
-  (if (sheet-medium sheet)
-      (funcall continuation (sheet-medium sheet))
+  (let ((medium (sheet-medium sheet)))
+    (if medium
+	(funcall continuation medium)
       (with-temporary-medium (medium sheet)
 	(with-sheet-medium-bound (sheet medium)
-	  (funcall continuation medium)))))
+	  (funcall continuation medium))))))
 
 ;; Special-case the one we know is going to work all the time
 (defmethod invoke-with-sheet-medium ((sheet permanent-medium-sheet-output-mixin) continuation)
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 6fcbe2ded8f5172386f3ca57e1aec8fd5ac7d08d..f2c8ade40a38b7e3b34c1d368c6bf74906b88c92 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.14 92/04/21 20:28:13 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.15 92/05/07 13:13:14 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user)
 
@@ -431,9 +431,9 @@
      :load-before-compile (xlib))
   ;; General stuff
   ("pkg")
+  ("macros")
   ("xt-defs")				; Used to be 'xtk'.
   ("foreign-obj")
-  ("macros")
   ;; Xlib stuff
   ("xlib")
   ("font")
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index bb373890a9e5e866f2593d1c570f5018455ad25d..341af84d18d556999f1861ad41742ad21526d4e3 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.18 92/04/30 09:09:40 cer Exp Locker: cer $
+;; $fiHeader: test-suite.lisp,v 1.19 92/05/07 13:13:18 cer Exp Locker: cer $
 
 (in-package :clim-user)
 
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 41aae234e16acb7a409d702c653fdd0f3231f748..82135e094d1d3ba46c04a6e076cdcfc034ea3dfe 100644
--- a/tk-silica/ol-gadgets.lisp
+++ b/tk-silica/ol-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-gadgets.lisp,v 1.10 92/04/21 20:28:26 cer Exp Locker: cer $
+;; $fiHeader: ol-gadgets.lisp,v 1.11 92/05/07 13:13:51 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -136,7 +136,6 @@
 			   :button4-motion
 			   :button5-motion
 			   :button-motion
-			   :exposure
 			   )
 			 1
 			 'sheet-mirror-event-handler
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 44a6a90ac853e7bab4fd211de5e3fc79361d13e9..b6f2b5a5f3c00393f53ffa31e1c65293ef0ca70d 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.15 92/04/28 09:26:24 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.16 92/05/06 15:37:53 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -37,10 +37,7 @@
 
 (defmethod establish-wm-protocol-callbacks ((framem motif-frame-manager) frame)
   (let ((shell (frame-shell frame)))
-    (tk::set-values shell 
-		    :icon-name (frame-pretty-name frame)
-		    :title (frame-pretty-name frame)
-		    :delete-response :do-nothing)
+    (tk::set-values shell :delete-response :do-nothing)
     (tk::add-wm-protocol-callback
       shell 
       :wm-delete-window
@@ -319,6 +316,8 @@
 	  (tk::set-values shell 
 			  :x (fix-coordinate x)
 			  :y (fix-coordinate y)))))
+    
+    (tk::set-values shell :title (frame-pretty-name frame))
     (let ((icon (clim-internals::frame-icon frame)))
       (flet ((decode-pixmap (x)
 	       (etypecase x
@@ -330,9 +329,12 @@
 		       (decode-gadget-background medium sheet x))))))))
 	(destructuring-bind
 	    (&key name pixmap clipping-mask) icon
-	  (when name
+	  ;;-- Dialog shells do not have :icon-name resource
+	  (when (and name (typep shell 'tk::top-level-shell))
 	    (tk::set-values shell :icon-name name))
 	  (when pixmap
 	    (tk::set-values shell :icon-pixmap (decode-pixmap pixmap)))
 	  (when clipping-mask
 	    (tk::set-values shell :clip-mask (decode-pixmap clipping-mask))))))))
+
+
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index a7a8f68d651094d9ab723fb900cc50976ab164a6..120fc766ebbff4e1ce60d0c8835de98b124370f7 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.28 92/05/07 13:13:52 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.29 92/05/12 18:25:22 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -175,7 +175,7 @@
 						     (sheet motif-push-button))
   (values 'tk::xm-push-button nil))
 
-(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area))
+(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-my-drawing-area))
   (tk::add-callback widget 
 		    :expose-callback 
 		    'sheet-mirror-exposed-callback
@@ -195,7 +195,6 @@
 			   :button4-motion
 			   :button5-motion
 			   :button-motion
-			   :exposure
 			   )
 			 1
 			 'sheet-mirror-event-handler
@@ -212,7 +211,7 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet motif-drawing-area))
-  (values 'tk::xm-drawing-area (list :margin-width 0 
+  (values 'tk::xm-my-drawing-area (list :margin-width 0 
 				     :resize-policy :none
 				     :margin-height 0)))
 
@@ -416,7 +415,7 @@
 
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet motif-top-level-sheet)
-				       (widget tk::xm-drawing-area))
+				       (widget tk::xm-my-drawing-area))
   (tk::add-callback widget 
 		    :resize-callback 'sheet-mirror-resized-callback
 		    sheet))
@@ -438,7 +437,7 @@
 		  :resize-policy :none
 		  :name (string (frame-name (pane-frame sheet))))))
    (t
-    (values 'tk::xm-drawing-area 
+    (values 'tk::xm-my-drawing-area 
 	    (list :resize-policy :none
 		  :name (string (frame-name (pane-frame sheet)))
 		  :margin-width 0 :margin-height 0)))))
@@ -570,7 +569,7 @@
 #+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet clim-stream-sheet)
-				       (widget tk::xm-drawing-area))
+				       (widget tk::xm-my-drawing-area))
   ;;---- It would suprise me if we needed this.
   (tk::add-callback widget 
 		    :resize-callback 
@@ -617,7 +616,7 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
 						     (parent t)
 						     (sheet xm-viewport))
-  (values 'tk::xm-drawing-area
+  (values 'tk::xm-my-drawing-area
 	  '(:scrolling-policy :application-defined
 	    :margin-width 0 :margin-height 0
 	    :resize-policy :none
@@ -626,7 +625,7 @@
 #+ignore
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet xm-viewport)
-				       (widget tk::xm-drawing-area))
+				       (widget tk::xm-my-drawing-area))
   ;;--- I wonder whether this is needed since it should not be resized by
   ;; the toolkit and only as part of the goe management code that will
   ;; recurse to children anyway
@@ -709,7 +708,7 @@
 
 (defmethod find-widget-class-and-initargs-for-sheet
     ((port xt-port) (parent t) (sheet xm-frame-viewport))
-  (values 'xm-drawing-area 
+  (values 'tk::xm-my-drawing-area 
 	  ;;---  These are duplicated
 	  (list :margin-width 0 
 		:resize-policy :none
@@ -722,7 +721,7 @@
 
 (defmethod add-sheet-callbacks :after ((port motif-port) 
 				       (sheet xm-frame-viewport)
-				       (widget tk::xm-drawing-area))
+				       (widget tk::xm-my-drawing-area))
   (tk::add-callback widget 
 		    :resize-callback 
 		    'sheet-mirror-resized-callback
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 1c000b9c7d3f224e28c38746ff4a347119417453..a6bba1a2942cd54545c898555a228a14abf49df8 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.16 92/04/21 20:28:33 cer Exp Locker: cer $
+;; $fiHeader: xm-silica.lisp,v 1.17 92/04/30 09:09:53 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -32,7 +32,7 @@
   'motif-port)
 
 
-(defmethod change-widget-geometry ((parent tk::xm-drawing-area) child
+(defmethod change-widget-geometry ((parent tk::xm-my-drawing-area) child
 				   &rest args
 				   &key x y width height)
   (declare (ignore x y width height))
@@ -89,7 +89,7 @@ about their children"))
   (declare (ignore port))
   (cond ( ;;--- hack alert
 	 (popup-frame-p sheet)
-	 (values 'xm-dialog-shell
+	 (values 'tk::xm-dialog-shell
 		 (append
 		  (let ((x (find-shell-of-calling-frame sheet)))
 		    (and x `(:transient-for ,x)))
@@ -98,7 +98,7 @@ about their children"))
 	 (call-next-method))))
 
 (defmethod make-cursor-widget-for-port ((port motif-port) parent)
-  (make-instance 'tk::xm-drawing-area
+  (make-instance 'tk::xm-my-drawing-area
 		 :parent parent
 		 :background (tk::get-values parent :foreground)
 		 :width 2
diff --git a/tk-silica/xt-cursor.lisp b/tk-silica/xt-cursor.lisp
index 36d2999e4cadb77af4f7a84fa4692214d52b2578..0397881f79fe48fff75f7f8628ce8209c7ea1bd0 100644
--- a/tk-silica/xt-cursor.lisp
+++ b/tk-silica/xt-cursor.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-cursor.lisp,v 1.7 92/04/30 09:09:54 cer Exp Locker: cer $
+;; $fiHeader: xt-cursor.lisp,v 1.8 92/05/12 18:25:26 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -69,10 +69,10 @@
 	    (tk::add-widget-cleanup-function gadget #'(lambda () (setf (getf clim-internals::plist 'gadget) nil)))
 	    (xt::realize-widget gadget)
 	    (let ((window (tk::widget-window gadget)))
-	      (setf (tk::drawable-save-under window) t))
+	      (setf (tk::window-save-under window) t))
 	    ;;--- This really should be done somewhere else but where??????
 	    #+ignore
 	    (let ((window (tk::widget-window (sheet-mirror sheet))))
-	      (setf (xt::drawable-backing-store window) t))
+	      (setf (xt::window-backing-store window) t))
 	    gadget)))))
 
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 93292c940f069cb2ba3a6b2298204d1e4bfcb666..e12494b7689da32ce016581a7766bb18de7b317c 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -1,4 +1,4 @@
-U;; -*- mode: common-lisp; package: tk-silica -*-
+;; -*- mode: common-lisp; package: tk-silica -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: tk-silica -*-
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.19 92/04/28 09:26:35 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.20 92/05/07 13:13:58 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -29,6 +29,7 @@ U;; -*- mode: common-lisp; package: tk-silica -*-
    (background-gcontext :reader medium-background-gcontext :initform nil)
    (flipping-gcontext :reader medium-flipping-gcontext :initform nil)
    (drawable :initform nil)
+   (clip-mask :initform nil)		; A cache.
    (color-p)
    (ink-table :initform (make-hash-table :test #'equal))
    (tile-gcontext :initform nil)	; The following don't belong here.
@@ -42,6 +43,56 @@ U;; -*- mode: common-lisp; package: tk-silica -*-
 			sheet
 			(sheet-mirror sheet))))))
 
+
+;;
+;; Clip mask is invalidated when:
+;;   1. medium's sheet's device region changes
+;;   2. medium's clipping region changes
+;;   3. medium's sheet's device transformation changes
+(defmethod medium-clip-mask ((medium xt-medium))
+  (with-slots (sheet clip-mask) medium
+    (or clip-mask
+	(setf clip-mask
+	  (let* ((dr (sheet-device-region sheet))
+		 (mcr (medium-clipping-region medium)))
+	    (unless (eq mcr +everywhere+)
+	      (setq mcr (transform-region (sheet-device-transformation sheet) mcr))
+	      (setq dr (region-intersection dr (bounding-rectangle mcr))))
+	    (cond ((eq dr +everywhere+)
+		   :none)
+		  ((eq dr +nowhere+)
+		   :nowhere)
+		  (t
+		   (with-bounding-rectangle* (left top right bottom) dr
+		     (list (fix-coordinate left) (fix-coordinate top) 
+			   (fix-coordinate (- right left))
+			   (fix-coordinate (- bottom top)))))))))))
+
+(defmethod (setf medium-clipping-region) :after (cr (medium xt-medium))
+  (declare (ignore cr))
+  (with-slots (clip-mask) medium
+    (setf clip-mask nil)))
+
+;;;---------------------- You cannot have such a class since sheet-with-medium.
+;;; Probably we need a method that gets invoked on the medium to
+;;; invalidate any cached state.
+
+(warn "These should be specialized on an 'xt' subclass of sheet-with-medium!!!!!!!!!!!!!!!!!!!!!!!!!")
+
+(defmethod invalidate-cached-regions :after ((sheet silica::sheet-with-medium-mixin))
+  (let ((medium (sheet-medium sheet)))
+    (when medium
+      (with-slots (clip-mask) medium
+	(setf clip-mask nil)))))
+
+(defmethod invalidate-cached-transformations :after ((sheet silica::sheet-with-medium-mixin))
+  (let ((medium (sheet-medium sheet)))
+    (when medium
+      (with-slots (clip-mask) medium
+	(setf clip-mask nil)))))
+
+
+
 (defmethod deallocate-medium :after (port (medium xt-medium))
   (declare (ignore port))
   (with-slots (drawable) medium
@@ -326,14 +377,12 @@ and on color servers, unless using white or black")
 			 white-pixel
 			 black-pixel)))))))))
 
+(defvar *default-dashes* '(4 4))
 
 (defmethod adjust-ink ((medium xt-medium) gc ink line-style x-origin y-origin)
   (declare (ignore ink))
   (let* ((dashes (line-style-dashes line-style))
-	 (gc-line-style
-	  (etypecase dashes
-	    ((member nil t) :solid)
-	    (sequence :dash))))
+	 (gc-line-style (if dashes :dash :solid)))
 	
     (tk::set-line-attributes 
      gc
@@ -345,7 +394,8 @@ and on color servers, unless using white or black")
 			     thickness))))
        (when (< thickness 2)
 	 (setq thickness 0))
-       (round thickness))
+       (setq thickness (the fixnum (round thickness)))
+       thickness)
      gc-line-style
      (ecase (line-style-cap-shape line-style)
        (:butt :butt)
@@ -358,23 +408,12 @@ and on color servers, unless using white or black")
        (:round :round)))
     
     (when (eq gc-line-style :dash)
-      (setf (tk::gcontext-dashes gc) dashes))
+      (setf (tk::gcontext-dashes gc)
+	(if (excl::sequencep dashes) dashes *default-dashes*))
+      ;; The following isn't really right, but it's better than nothing.
+      (setf (tk::gcontext-dash-offset gc) (1- y-origin)))
     
-    (let* ((sheet (medium-sheet medium))
-	   (dr (sheet-device-region sheet))
-	   (mcr (medium-clipping-region medium)))
-      (unless (eq mcr +everywhere+)
-	(setq mcr (transform-region (sheet-device-transformation sheet) mcr))
-	(setq dr (region-intersection dr (bounding-rectangle mcr))))
-      (cond ((eq dr +everywhere+)
-	     (setf (tk::gcontext-clip-mask gc) :none))
-	    ((eq dr +nowhere+)
-	     (setf (tk::gcontext-clip-mask gc) :nowhere))
-	    (t
-	     (with-bounding-rectangle* (a b c d) dr
-	       (with-stack-list (x (fix-coordinate a) (fix-coordinate b) 
-				   (fix-coordinate (- c a)) (fix-coordinate (- d b)))
-		 (setf (tk::gcontext-clip-mask gc) x))))))
+    (setf (tk::gcontext-clip-mask gc) (medium-clip-mask medium))
     
     (when (member (tk::gcontext-fill-style gc) '(:tiled :stippled) :test #'eq)
       (setf (tk::gcontext-ts-x-origin gc) x-origin
@@ -432,69 +471,83 @@ and on color servers, unless using white or black")
 
 
 (defmethod port-draw-point* ((port xt-port) sheet medium x y)
-  (let ((transform (sheet-device-transformation sheet)))
-    (convert-to-device-coordinates transform x y))
-  (when (medium-drawable medium)
-    (let ((thickness (line-style-thickness (medium-line-style medium))))
-      (if (< thickness 2)
-	  (tk::draw-point
-	   (medium-drawable medium)
-	   (adjust-ink medium
-		       (decode-ink (medium-ink medium) medium)
-		       (medium-ink medium)
-		       (medium-line-style medium)
-		       x y)
-	   x y)
-	(let ((thickness (round thickness)))
-	  (tk::draw-ellipse (medium-drawable medium) 
-			    (adjust-ink medium
-					(decode-ink (medium-ink medium) medium)
-					(medium-ink medium)
-					(medium-line-style medium)
-					(- x thickness)
-					(- y thickness))
-			    x y 
-			    0
-			    thickness 
-			    0
-			    thickness 0 2pi
-			    t))))))
+  (let ((drawable (medium-drawable medium)))
+    (when drawable
+      (let* ((ink (medium-ink medium))
+	     (line-style (medium-line-style medium))
+	     (thickness (line-style-thickness line-style))
+	     (transform (sheet-device-transformation sheet)))
+	(convert-to-device-coordinates transform x y)
+	(cond ((< thickness 1.5)
+	       (tk::draw-point
+		drawable
+		(adjust-ink medium
+			    (decode-ink ink medium)
+			    ink
+			    line-style
+			    x y)
+		x y))
+	      (t
+	       (setq thickness (round thickness))
+	       (tk::draw-ellipse
+		drawable
+		(adjust-ink medium
+			    (decode-ink ink medium)
+			    ink
+			    line-style
+			    (the fixnum (- (the fixnum x) (the fixnum thickness)))
+			    (the fixnum (- (the fixnum y) (the fixnum thickness))))
+		x y 
+		0
+		thickness 
+		0
+		thickness 0 2pi
+		t)))))))
 
 (defmethod port-draw-line* ((port xt-port) sheet medium
 			    x1 y1 x2 y2)
-  (let ((transform (sheet-device-transformation sheet)))
-    (convert-to-device-coordinates transform
-      x1 y1 x2 y2))
-  (when (medium-drawable medium)
-    (tk::draw-line
-      (medium-drawable medium)
-      (adjust-ink medium
-		  (decode-ink (medium-ink medium) medium)
-		  (medium-ink medium)
-		  (medium-line-style medium)
-		  (min x1 x2) (min y1 y2))
-      x1 y1 x2 y2)))
+  (let ((drawable (medium-drawable medium)))
+    (when drawable
+      (let ((ink (medium-ink medium))
+	    (transform (sheet-device-transformation sheet)))
+	(convert-to-device-coordinates transform
+				       x1 y1 x2 y2)
+	(tk::draw-line
+	 drawable
+	 (adjust-ink medium
+		     (decode-ink ink medium)
+		     ink
+		     (medium-line-style medium)
+		     (the fixnum (min (the fixnum x1) (the fixnum x2)))
+		     (the fixnum (min (the fixnum y1) (the fixnum y2))))
+	 x1 y1 x2 y2)))))
 
 (defmethod port-draw-rectangle* ((port xt-port) sheet medium
 				 x1 y1 x2 y2 filled)
-  (let ((transform (sheet-device-transformation sheet)))
-    (if (rectilinear-transformation-p transform)
-	(progn
-	  (convert-to-device-coordinates transform
-	    x1 y1 x2 y2) 
-	  (when (medium-drawable medium)
-	    (tk::draw-rectangle
-	      (medium-drawable medium)
-	      (adjust-ink medium
-			  (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)) (abs (- y2 y1))
-	      filled)))
-      (port-draw-transformed-rectangle*
-	port sheet medium x1 y1 x2 y2 filled))))
+  (let ((drawable (medium-drawable medium)))
+    (when drawable
+      (let ((ink (medium-ink medium))
+	    (transform (sheet-device-transformation sheet)))
+	(cond ((rectilinear-transformation-p transform)
+	       (convert-to-device-coordinates transform
+					      x1 y1 x2 y2)
+	       (let ((min-x (min (the fixnum x1) (the fixnum x2)))
+		     (min-y (min (the fixnum y1) (the fixnum y2))))
+		 (declare (fixnum min-x min-y))
+		 (tk::draw-rectangle
+		  drawable
+		  (adjust-ink medium
+			      (decode-ink ink medium)
+			      ink
+			      (medium-line-style medium)
+			      min-x min-y)
+		  min-x min-y
+		  (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1))))
+		  (fast-abs (the fixnum (- (the fixnum y2) (the fixnum y1))))
+		  filled)))
+	      (t
+	       (port-draw-transformed-rectangle*
+		port sheet medium x1 y1 x2 y2 filled)))))))
 
 (defmethod port-draw-polygon* ((port xt-port) sheet medium
 			       list-of-x-and-ys
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 735db298195da9fe292e3f962dda30440c697167..b80bc42a46a6eaa653b7c83d5ea8dd825d16dd47 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.25 92/05/07 13:14:02 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.26 92/05/12 18:25:31 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -306,7 +306,11 @@
 		(sheet-mirror-resized-callback
 		 widget nil event sheet)
 		nil)
+	       ;; This is handled by the expose callback.
 	       (:expose
+		nil)
+	       (:expose
+		;; This gets called only for an XmBulletinBoard widget.
 		(sheet-mirror-exposed-callback
 		 widget 
 		 nil ; window
@@ -1002,26 +1006,30 @@
 (defun default-from-mirror-resources (port pane)
   (unless (and (medium-foreground pane)
 	       (medium-background pane))
-    (let ((w (sheet-mirror pane)))
+    (let* ((w (sheet-mirror pane))
+	   (dap (typep w 'tk::xm-drawing-area)))
+
       ;;-- What about the case when there is a pixmap
-      (when (typep w 'xm-drawing-area)
-	(multiple-value-bind
-	    (foreground background)
-	    (tk::get-values w :foreground :background)
-	  ;; Now we have to convert into CLIM colors.
-	  (flet ((ccm (x)
-		   (multiple-value-bind
-		       (r g b)
-		       (tk::query-color (tk::default-colormap (port-display port)) x)
-		     (let ((x #.(1- (ash 1 16))))
-		       (make-rgb-color 
-			(/ r x)
-			(/ g x)
-			(/ b x))))))
+      (multiple-value-bind
+	  (foreground background)
+	  (if dap
+	      (tk::get-values w :foreground :background)
+	    (values nil (tk::get-values w :background)))
+	;; Now we have to convert into CLIM colors.
+	(flet ((ccm (x)
+		 (multiple-value-bind
+		     (r g b)
+		     (tk::query-color (tk::default-colormap (port-display port)) x)
+		   (let ((x #.(1- (ash 1 16))))
+		     (make-rgb-color 
+		      (/ r x)
+		      (/ g x)
+		      (/ b x))))))
+	  (when foreground
 	    (unless (medium-foreground pane)
-	      (setf (medium-foreground pane) (ccm foreground)))
-	    (unless (medium-background pane)
-	      (setf (medium-background pane) (ccm background)))))))))
+	      (setf (medium-foreground pane) (ccm foreground))))
+	  (unless (medium-background pane)
+	    (setf (medium-background pane) (ccm background))))))))
 
 ;;;--- Gadget activation deactivate
 
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index 0161de06c78f362b4a442cefc3ffb024b978f081..72ca6a186bc8058a7ee9cd28de751b4c86529b86 100644
--- a/tk/callbacks.lisp
+++ b/tk/callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: callbacks.lisp,v 1.11 92/05/06 15:37:07 cer Exp Locker: cer $
+;; $fiHeader: callbacks.lisp,v 1.12 92/05/07 13:10:47 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -63,7 +63,7 @@
      *callback-handler-address*
      (caar (push
 	    (list (new-callback-id) (cons function args) type)
-	    (widget-callback-data widget ))))))
+	    (widget-callback-data widget))))))
 
 (defvar *callback-ids* 0)
 (defun new-callback-id ()
@@ -128,7 +128,7 @@
   (let ((z (assoc x *callback-name-alist*)))
     (unless z (error "No such Callback: ~S" x))
     (values (or (third z)
-		(setf (third z) (string-to-char* (second z))))
+		(setf (third z) (second z)))
 	    (fourth z))))
 
 (defmethod spread-callback-data (widget data (type (eql :activate)))
diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp
index 3c5a6a858ce078b32d71ef6fc3369ee45ebbc2a3..434d09ad61b2c1039230e225d6cb82ca116b34dd 100644
--- a/tk/foreign-obj.lisp
+++ b/tk/foreign-obj.lisp
@@ -20,23 +20,27 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign-obj.lisp,v 1.9 92/04/21 16:12:19 cer Exp Locker: cer $
+;; $fiHeader: foreign-obj.lisp,v 1.10 92/05/07 13:10:48 cer Exp Locker: cer $
 
 (in-package :tk)
 
-;;; There should be multiple mappings:
-;;; Xid -> object
-;;; Address -> object
-
 (defvar *address->object-mapping* (make-hash-table :test 'equal))
-(defvar *xid->object-mapping* (make-hash-table :test 'equal))
+
+(defclass display (ff:foreign-pointer)
+  ((context :initarg :context :reader display-context)
+   (xid->object-mapping :initform (make-hash-table :test #'equal)
+			:fixed-index 0)))
+
+(defmacro display-xid->object-mapping (object)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (excl::slot-value-using-class-name 'display ,object 'xid->object-mapping)))
+
+(defun find-object-from-xid (handle display &optional (errorp t))
+  (find-object-from-handle handle (display-xid->object-mapping display) errorp))
 
 (defun find-object-from-address (handle &optional (errorp t))
   (find-object-from-handle handle *address->object-mapping* errorp))
 
-(defun find-object-from-xid (handle &optional (errorp t))
-  (find-object-from-handle handle *xid->object-mapping* errorp))
-
 (defun find-object-from-handle (handle table errorp)
   (cond ((gethash handle table))
 	(errorp 
@@ -50,12 +54,12 @@
   (remhash handle *address->object-mapping*)
   (setf (ff:foreign-pointer-address object) 0))
 
-(defun register-xid (object &optional (handle (foreign-pointer-address object)))
-  (setf (gethash handle *xid->object-mapping*) object)
+(defun register-xid (object display &optional (handle (foreign-pointer-address object)))
+  (setf (gethash handle (display-xid->object-mapping display)) object)
   object)
 
-(defun unregister-xid (object &optional (handle (foreign-pointer-address object)))
-  (remhash handle *xid->object-mapping*)
+(defun unregister-xid (object display &optional (handle (foreign-pointer-address object)))
+  (remhash handle (display-xid->object-mapping display))
   object)
 
 (defun intern-object-address (handle class &rest initargs)
@@ -70,9 +74,9 @@
 	 *address->object-mapping*
 	 handle))
 
-(defun intern-object-xid (handle class &rest initargs)
+(defun intern-object-xid (handle class display &rest initargs)
   (apply #'intern-object-1 
-	 *xid->object-mapping*
+	 (display-xid->object-mapping display)
 	 handle 
 	 class 
 	 initargs))
diff --git a/tk/foreign.lisp b/tk/foreign.lisp
index 3eb05c3482bc629387f2badb0bfb4c667fa52365..f8e0a867ad25acc5d8619a383bdf96cedb4cb7a4 100644
--- a/tk/foreign.lisp
+++ b/tk/foreign.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign.lisp,v 1.9 92/04/15 11:44:43 cer Exp Locker: cer $
+;; $fiHeader: foreign.lisp,v 1.10 92/04/21 20:27:30 cer Exp $
 
 (in-package :tk)
 
@@ -75,10 +75,6 @@
 	(error "cannot open the display: ~A" host)
       d)))
 
-(defclass display (ff:foreign-pointer)
-  ((context :initarg :context :reader display-context)))
-
-
 (defmethod initialize-instance :after ((d display) &rest args
 				       &key display
 				       &allow-other-keys)
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 7b9de41ade1b1850dc6252f6528253a0fefe4f25..11e1ad827a088d32f07859d7a7d1e2bc4ea3ff01 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.13 92/04/28 09:25:02 cer Exp Locker: cer $
+;; $fiHeader: gcontext.lisp,v 1.14 92/05/12 18:24:17 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -114,9 +114,8 @@
        (define-gc-writer ,name ,encoder ,@args)
        ',name)))
 
-
 (defclass gcontext (display-object)
-  ())
+  ((cached-clip-mask :initform nil)))
 
 (defmethod initialize-instance :after ((gcontext gcontext)
 				       &key
@@ -216,8 +215,12 @@
   (nth x '(:solid :tiled :stippled :opaque-stippled)))
 
 (defun encode-fill-style (x)
-  (or (position x '(:solid :tiled :stippled :opaque-stippled))
-      (error "~s is not a fill style" x)))
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (:solid 0)
+    (:tiled 1)
+    (:stippled 2)
+    (:opaque-stippled 3)))
 
 (defmethod (setf gcontext-fill-style) (nv (gc gcontext))
   (x11:xsetfillstyle
@@ -241,14 +244,21 @@
 (define-gc-accessor cap-style (encode-cap-style decode-cap-style))
 
 (defun encode-cap-style (x)
-  (or (position x '(:not-last :butt :round :projecting))
-      (error "~s is not a cap style" x)))
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (:not-last 0)
+    (:butt 1)
+    (:round 2)
+    (:projecting 3)))
 
 (define-gc-accessor join-style (encode-join-style decode-join-style))
 
 (defun encode-join-style (x)
-  (or (position x '(:miter :round :bevel))
-      (error "~s is not a join-style" x)))
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (:miter 0)
+    (:round 1)
+    (:bevel 2)))
 
 (define-gc-accessor subwindow-mode (encode-enum decode-enum)
 		  '(:clip-by-children :include-inferiors))
@@ -306,21 +316,19 @@
 
 
 (defmethod (setf gcontext-clip-mask) ((nv cons) (gc gcontext))
-  (destructuring-bind
-   (x y width height) nv
-   (let ((r (x11:make-xrectangle)))
-     (setf (x11:xrectangle-x r) x
-	   (x11:xrectangle-y r) y
-	   (x11:xrectangle-width r) width
-	   (x11:xrectangle-height r) height)
-     (x11:xsetcliprectangles
-      (object-display gc)
-      gc
-      0					; clip-x-origin
-      0					; clip-y-origin
-      r
-      1
-      x11:unsorted))))
+  (let ((r (x11:make-xrectangle)))
+    (setf (x11:xrectangle-x r) (first nv)
+	  (x11:xrectangle-y r) (second nv)
+	  (x11:xrectangle-width r) (third nv)
+	  (x11:xrectangle-height r) (fourth nv))
+    (x11:xsetcliprectangles
+     (object-display gc)
+     gc
+     0					; clip-x-origin
+     0					; clip-y-origin
+     r
+     1
+     x11:unsorted)))
 
 (defmethod (setf gcontext-clip-mask) ((nv (eql :nowhere)) (gc gcontext))
   (x11:xsetcliprectangles
@@ -332,11 +340,21 @@
    0
    x11:unsorted))
 
+(defmethod (setf gcontext-clip-mask) :around (nv (gc gcontext))
+  (with-slots (cached-clip-mask) gc
+    (unless (or (eq cached-clip-mask nv)
+		(equal cached-clip-mask nv))
+      (call-next-method)
+      (setf cached-clip-mask nv))))
+  
 (define-gc-accessor line-style  (encode-line-style decode-style))
 
 (defun encode-line-style (x)
-  (or (position x '(:solid :dash :double-dash))
-      (error "~S is not a valid line-style" x)))
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (:solid 0)
+    (:dash 1)
+    (:double-dash 2)))
 
 (defmethod (setf gcontext-dashes) (nv (gc gcontext))
   (multiple-value-bind (n v)
@@ -352,7 +370,7 @@
 (defun encode-dashes (nv)
   (declare (optimize (speed 3) (safety 0)))
   (let* ((n (length nv))
-	 (v (make-array n :element-type '(unsigned-byte 8))))
+	 (v (excl:make-static-array n :element-type '(unsigned-byte 8))))
     (declare (fixnum n)
 	     (type (simple-array (unsigned-byte 8) (*)) v))
     (etypecase nv
@@ -386,15 +404,18 @@
   (declare (special gc))
   (if (= x #16rffffffff)
       (error "cannot decode font")
-    (let ((font (find-object-from-xid x nil)))
+    (let* ((display (object-display gc))
+	   (font (find-object-from-xid x display nil)))
       (or font
-	  (query-font (object-display gc) x)))))
+	  (query-font display x)))))
 
-(defun decode-pixmap (x) 
+(defun decode-pixmap (x)
+  (declare (special gc))
   (and (/= #16rffffffff x)
        (intern-object-xid
 	x
-	'pixmap)))
+	'pixmap
+	(object-display gc))))
 
 (defun decode-clip-mask (x) x)
 (defun decode-enum (x y)
diff --git a/tk/graphics.lisp b/tk/graphics.lisp
index 8472c13a7097d22a1f73148c4aadff1d3b744902..24892bbbe02caf157f08c0d851718a66ae8324cb 100644
--- a/tk/graphics.lisp
+++ b/tk/graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: graphics.lisp,v 1.6 92/03/24 19:36:10 cer Exp $
+;; $fiHeader: graphics.lisp,v 1.7 92/04/15 11:44:45 cer Exp $
 
 (in-package :tk)
 
@@ -127,6 +127,7 @@
      y
      width height)))
 
+#+ignore
 (defun text-extents (font sequence &key (start 0) end translate)
   (unless end (setq end (length sequence)))
   (with-ref-par ((direction 0)
@@ -153,10 +154,7 @@
 					; something-else
 		   ))))
 		   
-
-
-
-
+#+ignore
 (defun text-width (font sequence &key (start 0) end translate)
   (unless end (setq end (length sequence)))
   (x11:xtextwidth font
@@ -189,14 +187,6 @@
 (defun draw-string (drawable gc x y string &optional (start 0) end)
   (unless start (setq start 0))
   (unless end (setq end (length string)))
-  (x11::xdrawstring
-   (object-display drawable)
-   drawable
-   gc
-   x y 
-   (+ start (string-to-char* string))
-   (- end start))
-  #+ignore
   (x11:lisp-xdrawstring
    (object-display drawable)
    drawable
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index 2da445027594580691fb3382f99548273e732b09..bdab8e7da78ecbd0316e2f3d3e4db770bcab61b4 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -20,16 +20,23 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.10 92/04/03 12:04:00 cer Exp $
+;; $fiHeader: load-xm.lisp,v 1.11 92/05/07 13:10:51 cer Exp Locker: cer $
 
 (in-package :tk)
 
+
+
 ;;;; 
 (defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
 (defvar *libxm-pathname* "/x11/motif-1.1/lib/Xm/libXm.a")
 (defvar *libxt-pathname* "/x11/R4/src/mit/lib/Xt/libXt_d.a")
 
 (defun load-from-xm ()
+  (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea"))
+    (load "MyDrawingA.o"
+	  :system-libraries (list *libxm-pathname* *libxt-pathname*
+				  x11::*libx11-pathname*)
+	  :print t))
   (x11::load-undefined-symbols-from-library
    "stub-motif.o"
    (x11::symbols-from-file 
diff --git a/tk/macros.lisp b/tk/macros.lisp
index 1548d2c8a629abf471cc80fa57468efd0059d010..71ef44caf3a9c8ccc3168f99ad24e8a5166f4634 100644
--- a/tk/macros.lisp
+++ b/tk/macros.lisp
@@ -20,12 +20,11 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: macros.lisp,v 1.8 92/03/09 17:40:46 cer Exp $
+;; $fiHeader: macros.lisp,v 1.9 92/03/30 17:51:41 cer Exp $
 
 (in-package :tk)
 
-(defvar *temp-with-ref-par* nil)
-(defparameter *temp-with-ref-par-p* t)
+(defvar *with-ref-par-resource* nil)
 
 (defmacro with-ref-par (bindings &body body)
   (if (null bindings)
@@ -34,11 +33,17 @@
 	((var value &optional (type :signed-long)) &rest more-bindings) bindings
       (let ((val (gensym)))
 	`(let ((,val ,value)
-	       (,var (or (and *temp-with-ref-par-p* (pop *temp-with-ref-par*))
+	       (,var (or (pop *with-ref-par-resource*)
 			 (make-array 1 :element-type '(unsigned-byte 32)))))
 	   (declare (type (simple-array (unsigned-byte 32) (1)) ,var))
 	   (setf (aref ,var 0) ,val)
 	   (multiple-value-prog1
 	       (with-ref-par ,more-bindings ,@body)
-	     (when *temp-with-ref-par-p*
-	       (push ,var *temp-with-ref-par*))))))))
+	     (push ,var *with-ref-par-resource*)))))))
+
+
+(defmacro object-display (object)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (excl::slot-value-using-class-name 'display-object ,object
+					'display)))
+  
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 5803a31f9973fa4b5cc80958945ef3519cf21b2d..d9660d49a8f987cccccadb1cf2527b79b37a3527 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.15 92/04/21 20:27:34 cer Exp Locker: cer $
+;; $fiHeader: make-classes.lisp,v 1.16 92/05/07 13:10:52 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -62,11 +62,6 @@
 
 
 
-(defclass display-object (ff:foreign-pointer)
-  ((display :initarg :display
-	    :reader object-display
-	    :fixed-index 0)))
-
 (defclass xt-root-class (display-object)
   ((events :initform nil :accessor widget-event-handler-data)
    (callbacks :initform nil :accessor widget-callback-data)
diff --git a/tk/meta-tk.lisp b/tk/meta-tk.lisp
index 4cd5d7fa5b21d0bfcfc283fb51395d0a154d67b1..533c86f33bb5efb0b4e864134c3c81e36a84113e 100644
--- a/tk/meta-tk.lisp
+++ b/tk/meta-tk.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: meta-tk.lisp,v 1.6 92/03/09 17:40:49 cer Exp $
+;; $fiHeader: meta-tk.lisp,v 1.7 92/03/30 17:51:45 cer Exp $
 
 
 (in-package :tk)
@@ -40,7 +40,13 @@
 		     :reader class-direct-resources)
    (constraint-resources :initform nil
 			 :initarg :direct-constraints
-			 :reader class-direct-constraint-resources)))
+			 :reader class-direct-constraint-resources)
+   (get-values-cache :initform (make-hash-table :test #'equal)
+		     :type hash-table
+		     :reader class-get-values-cache)
+   (set-values-cache :initform (make-hash-table :test #'equal)
+		     :type hash-table
+		     :reader class-set-values-cache)))
 
 (defmethod class-handle ((class xt-class))
   (unless (clos::class-finalized-p class)
diff --git a/tk/pkg.lisp b/tk/pkg.lisp
index 208d6fb5251027e1ea93f0a69e655fdc4d98c99b..cbd9cce13879338f3eb4130d3ba703a0e2cd77c7 100644
--- a/tk/pkg.lisp
+++ b/tk/pkg.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.7 92/03/30 17:51:47 cer Exp $
+;; $fiHeader: pkg.lisp,v 1.8 92/04/21 20:27:39 cer Exp $
 
 (defpackage :tk
   ;;-- No we really need
@@ -30,11 +30,9 @@
   (:import-from :excl #:if*)
   (:export
    #:initialize-motif-toolkit
-   #:xm-drawing-area
    #:widget-parent
    #:manage-child
    #:get-values
-   #:xm-dialog-shell
    #:top-level-shell
    #:popup
    #:manage-child
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 2df817e74e2ffaced9fbc21954139f19ab797689..259acd0df3b7f1d4c4fc2fe21b4cfa0d302c999a 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -1,4 +1,4 @@
-;; -*- mode: common-lisp; package: tk -*-
+; -*- mode: common-lisp; package: tk -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,113 +20,28 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.19 92/05/06 15:37:08 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.20 92/05/07 13:10:59 cer Exp Locker: cer $
 
 (in-package :tk)
 
 (defmacro define-enumerated-resource (type elements)
   `(progn
-     (defmethod convert-resource-out ((parent t) (type (eql ',type)) value)
+     (defmethod convert-resource-out (parent (type (eql ',type)) value)
+       (declare (ignore parent))
        (or (position value ',elements)
 	   (error "cannot convert ~S to type ~S" value ',type)))
-     (defmethod convert-resource-in ((parent t) (type (eql ',type)) value)
-       (declare (ignorable parent))
-       (setq value (ash value -24))
+     (defmethod resource-type-get-memref-type ((type (eql ',type)))
+       :unsigned-byte)
+     (defmethod convert-resource-in (parent (type (eql ',type)) value)
+       (declare (ignore parent))
        (elt ',elements value))))
 
-
-
-(defun set-values (widget &rest values)
-  (let ((arglist (make-arglist-for-class (class-of widget) widget values)))
-    (xt_set_values widget
-		arglist
-		(truncate (length arglist) 2))))
-
-
-(defun make-arglist-for-class (class parent args)
-  (do ((new-args nil)
-       (resources-1 (class-resources class))
-       (resources-2 (and parent (class-constraint-resources
-				    (class-of parent))))
-       keyword
-       value)
-      ((null args)
-       (make-array (length new-args)
-		   :element-type '(signed-byte 32)
-		   :initial-contents (nreverse new-args)))
-    (setq keyword (pop args)
-	  value (pop args))
-    (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)
-	      new-args)))))
-
-
-(defmethod convert-resource-out (parent type value)
-  (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value)
-  (convert-resource-out parent type value))
-
-(defmethod convert-resource-out :around (parent type value)
-  (declare (optimize (speed 3))
-	   (ignore parent type value))
-  (let ((result (call-next-method)))
-    (if (integerp result)
-	result
-      (ff:foreign-pointer-address result))))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
-  (xm_string_create_l_to_r (string-to-char* value) (string-to-char* "")))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'orientation)) value)
-  (ecase value
-    (:vertical 1)
-    (:horizontal 2)))
-
-(defun get-values (widget &rest resources)
-  (let* ((class (class-of widget))
-	 (class-resources (class-resources class))
-	 (arglist nil)
-	 rds)
-    
-    ;;-- This class resource
-    ;;-- Accumulate resources into a resource allocated vector
-    (dolist (r resources)
-      (let ((resource (find r class-resources :key #'resource-name)))
-	(unless resource
-	  (error "No such resource ~S for class ~S widget ~S"
-		 r class widget))
-	;;--- Need to resource allocate this
-	(push resource rds)
-	(push (resource-original-name resource) arglist)
-	(push (make-x-arglist) arglist)))
-    
-    ;;-- We ought to be ashamed of ourselves for using coerce
-    ;;-- This also ought to be resource allocated
-    (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32))))
-    (xt_get_values widget
-		arglist
-		(truncate (length arglist) 2))
-    ;;--- Perhaps this list should be a vector that is resource
-    ;;-- allocated.
-    (do ((rs (nreverse rds) (cdr rs))
-	 (i 1 (+ i 2))
-	 values)
-	((null rs)
-	 (values-list (nreverse values)))
-      (push
-       (convert-resource-in
-	widget
-	(resource-type (car rs))
-	(x-arglist (aref arglist i) 0))
-       values))))
-
-
 (defmethod convert-resource-in (class type value)
   (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value)
   (convert-resource-in class type value))
 
+
+
 (defconstant xm_string_default_char_set "")
 
 (defmethod convert-resource-in (class (type (eql 'xm-string)) value)
@@ -138,6 +53,7 @@
 	 (xm_string_get_l_to_r value xm_string_default_char_set string)
 	 (char*-to-string (aref string 0)))))
 
+
 (define-enumerated-resource separator-type (:no-line 
 					    :single-line
 					    :double-line 
@@ -145,230 +61,36 @@
 					    :double-dashed-line
 					    :shadow-etched-in
 					    :shadow-etched-out))
-      
-(defmethod convert-resource-out ((parent t) (type (eql 'menu-widget)) value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-dimension)) value)
-  (check-type value integer)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-int)) value)
-  (check-type value integer)
-  value)
-
-
-(defmethod convert-resource-out ((parent t) (type (eql 'vertical-dimension)) value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'vertical-int)) value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'visual-policy)) value)
-  (ecase value
-    (:constant 1)))
-
 
 (define-enumerated-resource scrolling-policy (:automatic :application-defined))
 
-
-
-(defmethod convert-resource-out ((parent t) (type (eql 'scroll-bar-display-policy)) value)
-  (ecase value
-    (:static 0)))
-
-
-#+ignore
-(defmethod convert-resource-out ((parent t) (type (eql 'packing)) value)
-  (ecase value
-    (:pack-column 2)))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'short)) value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'label-type)) value)
-  (ecase value
-    (:pixmap 1)
-    (:string 2)))
-
-
-(defmethod convert-resource-out ((parent t) (type (eql 'alignment)) value)
-  (ecase value
-    (:center 1)
-    (:beginning 0)
-    (:end 2)))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value)
-  (convert-pixmap-out parent value))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value)
-  (convert-pixmap-out parent value))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value)
-  (convert-pixmap-out parent value))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value)
-  (convert-pixmap-out parent value))
-
-
-(defun convert-pixmap-out (parent value)
-  (etypecase value
-    (pixmap value)
-    (string
-     (let* ((display (widget-display parent))
-	    (screen (x11:xdefaultscreenofdisplay display))
-	    (white (x11::xwhitepixel display 0))
-	    (black (x11::xblackpixel display 0)))
-       (xm_get_pixmap screen (string-to-char* value) white black)))))
-
-
-(defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value)
-  (if value 1 0))
-
-(defmethod convert-resource-out ((parent  t) (type (eql 'string)) value)
-  (string-to-char* value))
-
 (define-enumerated-resource dialog-style (:modeless
 					  :primary-application-modal
 					  :full-application-modal
 					  :system-modal))
 
-(defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value)
-  (make-instance 'font
-    :display (widget-display parent)
-    :name value))
-
-
-(defmethod convert-resource-in ((parent t) (type (eql 'string)) value)
-  (unless (zerop value)
-    (char*-to-string value)))
-
-(defmethod convert-resource-in ((parent t) (type (eql 'boolean))
-				value)
-  (not (zerop (ash value -24))))
-
-(defmethod convert-resource-in ((parent t) (type (eql 'cardinal)) value)
-  value)
-
-;; We have to do this because we pass a pointer to :unsigned-long but
-;; the actual type is :short
-(defmethod convert-resource-in ((parent t) (type (eql 'vertical-dimension)) value)
-  (ash value -16))
-
-(defmethod convert-resource-in ((parent t) (type (eql 'horizontal-dimension)) value)
-  (ash value -16))
-
-(defmethod convert-resource-in ((parent t) (type (eql 'horizontal-position)) value)
-  (convert-16bit-resource-in value))
-
-(defmethod convert-resource-in ((parent t) (type (eql 'vertical-position)) value)
-  (convert-16bit-resource-in value))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'pixel)) value)
-  (etypecase value
-	     (integer value)
-	     (color (allocate-color (default-colormap (widget-display parent))
-				    value))))
-			   
-
-(defmethod convert-resource-in ((parent t) (type (eql 'pixel)) value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-position))  value)
-  value)
-
-(defmethod convert-resource-out ((parent t) (type (eql 'vertical-position))  value)
-  value)
-
 (define-enumerated-resource resize-policy (:none :grow :any))
 
-(defmethod convert-resource-in ((parent t) (type (eql 'int)) value) value)
-(defmethod convert-resource-out ((parent t) (type (eql 'int)) value) value)
-
-
 (define-enumerated-resource indicator-type (nil :n-of-many :one-of-many))
 
-
-(defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-dim)) x) x)
-(defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-pos)) x) x)
-(defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-dim)) x) x)
-(defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-pos)) x) x)
-
-(defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-dim)) x) x)
-(defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-pos)) x) x)
-(defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-dim)) x) x)
-(defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-pos)) x) x)
-
-
 (define-enumerated-resource delete-response (:destroy :unmap :do-nothing))
 
-(defmethod convert-resource-out ((parent t) (type (eql 'window)) x)
-  x)
-
-
 (define-enumerated-resource keyboard-focus-policy (:explicit :pointer))
   
+(define-enumerated-resource packing (:no-packing
+				     :tight
+				     :column
+				     :none))
 
+(define-enumerated-resource edit-mode (:multi-line :single-line))
 
-(defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value)
-  (etypecase value
-    (pixmap
-     (encode-pixmap value))))
-
-
-
-(defmethod convert-resource-in ((widget t) (type (eql 'widget-list)) x)
-  (let ((r nil))
-    (dotimes (i (widget-num-children widget))
-      (push (convert-resource-in 
-	     widget 'widget (xt-widget-list x i))
-	    r))
-    (nreverse r)))
-
-
-(defmethod convert-resource-in ((widget t) (type (eql 'widget)) x)
-  (intern-widget x :display (widget-display widget)))
-
-(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x)
-  x)
-
-;; Could not think of anywhere better!
-
-
-(defun setup (&optional (hostspec "localhost:0"))
-  (let* ((context (create-application-context))
-	 (display (make-instance 'display 
-		    :host hostspec
-		    :context context))
-	 (app (app-create-shell :display display
-				:widget-class 'application-shell)))
-    (values context display app)))
-
-(defun initialize-motif-toolkit (hostspec)
-  (setup hostspec))
-
-
-;;; ol resource
-
-(defmethod convert-resource-out ((parent t) (type (eql 'position)) value)
-  value)
-
-(defmethod convert-resource-in ((parent t) (type (eql 'position)) value)
-  (convert-16bit-resource-in value))
-
-(defun convert-16bit-resource-in (value)
-  (let ((x (ash value -16)))
-    ;; 16bit signed value!
-    (if (>= x (ash 1 15))
-	(- x (ash 1 16))
-      x)))
-
-(defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value)
-  value)
+(define-enumerated-resource visual-policy (:variable :constant))
 
-(defmethod convert-resource-in ((parent t) (type (eql 'dimension)) value)
-  (ash value -16))
+(define-enumerated-resource scroll-bar-display-policy (:static :as-needed))
 
+(define-enumerated-resource selection-policy (:single-select 
+					      :multiple-select 
+					      :extended-select :browse-select))
 ;; from OpenLook.h
 
 (defparameter *ol-defines* '(
@@ -524,38 +246,308 @@
 		       ))
 
 (defmethod convert-resource-in (parent (type (eql 'ol-define)) value)
-  (setq value (ash value -16))
+  (declare (ignore parent))
   (or (car (find value *ol-defines* :key #'second))
       (call-next-method)))
 
 
 (defmethod convert-resource-out (parent (type (eql 'ol-define)) value)
+  (declare (ignore parent))
   (or (second (find value *ol-defines* :key #'first))
       (call-next-method)))
+
+
+
+;; Note that the current set-values implemenation only works for resources
+;; that fit in a 32bit word.  You were warned!
+
+(defun fill-sv-cache (class resources)
+  (let* ((len (length resources))
+	 (class-resources (class-resources class))
+	 (arglist (make-xt-arglist :number len))
+	 (rds nil)
+	 (i 0))
+    (dolist (r resources)
+      (let ((resource (find r class-resources :key #'resource-name :test #'eq)))
+	(unless resource
+	  (error "No such resource ~S for widget of class ~S "
+		 r class))
+	(let ((type (resource-type resource)))
+	  (push (list (resource-type-set-conversion-p type)
+		      type)
+		rds))
+	(setf (xt-arglist-name arglist i) (resource-original-name resource))
+	(incf i)))
+    (setf (gethash resources (class-set-values-cache class))
+      (list* arglist len (nreverse rds)))))
+
+(defun set-values (widget &rest resources-and-values)
+  (declare (optimize (speed 3))
+	   (dynamic-extent resources-and-values))
+  (let ((resources nil)
+	(values nil))
+    (do ((rvs resources-and-values (cddr rvs)))
+	((null rvs))
+      (push (car rvs) resources)
+      (push (cadr rvs) values))
+    (setq resources (nreverse resources))
+    (setq values (nreverse values))
+    (excl::without-interrupts
+      ;; We don't really want anyone else to grab the same cache entry.
+      (let* ((class (class-of widget))
+	     (entry (gethash resources (class-set-values-cache class))))
+	(declare (optimize (safety 0)))
+	(unless entry
+	  (setf entry (fill-sv-cache class resources)))
+    
+	(destructuring-bind (arglist length &rest resource-descriptions)
+	    entry
+	  (do ((resdess resource-descriptions (cdr resdess))
+	       (i 0 (1+ i))
+	       (values values (cdr values)))
+	      ((null resdess))
+	    (destructuring-bind (convert-p type)
+		(car resdess)
+	      ;; Yuck -- the following should be handled somehow by cstructs...
+	      (setf (sys:memref-int (xt-arglist arglist i) 4 0 :signed-long)
+		(if convert-p
+		    (convert-resource-out widget type (car values))
+		  (car values)))))
+	  (xt_set_values widget arglist length))))))
+
+;; This is used by initialize-instance methods for widgets...
+(defun make-arglist-for-class (class parent args)
+  (declare (optimize (speed 3) (safety 0)))
+  (do ((new-args nil)
+       (resources-1 (class-resources class))
+       (resources-2 (and parent (class-constraint-resources
+				    (class-of parent))))
+       keyword
+       value)
+      ((null args)
+       (make-array (length new-args)
+		   :element-type '(signed-byte 32)
+		   :initial-contents (nreverse new-args)))
+    (setq keyword (pop args)
+	  value (pop args))
+    (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)
+	(let ((type (resource-type resource)))
+	  (push
+	   (if (resource-type-set-conversion-p type)
+	       (convert-resource-out parent type value)
+	     value)
+	   new-args))))))
+
+
+
+
+
+;; I would really prefer to define these as separate methods.  However
+;; that leads to a lot of code!
+(defmethod resource-type-get-conversion-p (type)
+  (case type
+    (position nil)
+    (vertical-position nil)
+    (horizontal-position nil)
+    (shell-vert-pos nil)
+    (shell-horiz-pos nil)
+    (dimension nil)
+    (vertical-dimension nil)
+    (horizontal-dimension nil)
+    (shell-vert-dim nil)
+    (shell-horiz-dim nil)
+    (cardinal nil)
+    (pixel nil)
+    (int nil)
+    (t t)))
+
+(defmethod resource-type-set-conversion-p (type)
+  (case type
+    (position nil)
+    (vertical-position nil)
+    (horizontal-position nil)
+    (shell-vert-pos nil)
+    (shell-horiz-pos nil)
+    (dimension nil)
+    (vertical-dimension nil)
+    (vertical-int nil)
+    (horizontal-dimension nil)
+    (horizontal-int nil)
+    (shell-vert-dim nil)
+    (shell-horiz-dim nil)
+    (cardinal nil)
+    (pixel nil)
+    (short nil)
+    (int nil)
+   (t t)))
   
+(defmethod resource-type-get-memref-type (type)
+  (case type
+    (position :signed-word)
+    (vertical-position :signed-word)
+    (horizontal-position :signed-word)
+    (shell-vert-pos :signed-word)
+    (shell-horiz-pos :signed-word)
+    (dimension :signed-word)
+    (vertical-dimension :signed-word)
+    (horizontal-dimension :signed-word)
+    (shell-vert-dim :signed-word)
+    (shell-horiz-dim :signed-word)
+    (int :signed-long)
+    (boolean :unsigned-byte)
+    (ol-define :unsigned-word)
+   (t :unsigned-long)))
+
+
+
+(defun fill-gv-cache (class resources)
+  (setq resources (copy-list resources)) ; So get-values can declare dynamic-extent
+  (let* ((len (length resources))
+	 (class-resources (class-resources class))
+	 (arglist (make-xt-arglist :number len))
+	 (rds nil)
+	 (i 0))
+    (dotimes (j len)
+      (setf (xt-arglist-value arglist j) (excl::malloc 8))) ; A crock...
+    (dolist (r resources)
+      (let ((resource (find r class-resources :key #'resource-name :test #'eq)))
+	(unless resource
+	  (error "No such resource ~S for widget of class ~S "
+		 r class))
+	(let ((type (resource-type resource)))
+	  (push (list (resource-type-get-memref-type type)
+		      (resource-type-get-conversion-p type)
+		      type)
+		rds))
+	(setf (xt-arglist-name arglist i) (resource-original-name resource))
+	(incf i)))
+    (setf (gethash resources (class-get-values-cache class))
+      (list* arglist len (nreverse rds)))))
+    
+(defun get-values (widget &rest resources)
+  (declare (optimize (speed 3))
+	   (dynamic-extent resources))
+  (excl::without-interrupts
+    ;; We don't really want anyone else to grab the same cache entry.
+    (let* ((class (class-of widget))
+	   (entry (gethash resources (class-get-values-cache class))))
+      (declare (optimize (safety 0)))
+      (unless entry
+	(setf entry (fill-gv-cache class resources)))
+    
+      (destructuring-bind (arglist length &rest resource-descriptions)
+	  entry
+	(xt_get_values widget arglist length)
+
+	(let ((i 0)
+	      (values nil))
+	  (dolist (resource-desc resource-descriptions)
+	    (destructuring-bind (get-memref-type convert-p type)
+		resource-desc
+	      (let ((value (sys:memref-int (xt-arglist-value arglist i) 0 0
+					   get-memref-type)))
+		(incf i)
+		(if convert-p
+		    (setq value (convert-resource-in widget type value)))
+		(push value values))))
+	  (values-list (nreverse values)))))))
+
+
 
-(define-enumerated-resource packing (:no-packing
-				     :tight
-				     :column
-				     :none))
+(defmethod convert-resource-out (parent type value)
+  (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value)
+  (convert-resource-out parent type value))
 
+(defmethod convert-resource-out :around (parent type value)
+  (declare (optimize (speed 3))
+	   (ignore parent type value))
+  (let ((result (call-next-method)))
+    (if (integerp result)
+	result
+      (ff:foreign-pointer-address result))))
 
-(define-enumerated-resource edit-mode (:multi-line :single-line))
+(defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
+  (xm_string_create_l_to_r (string-to-char* value) (string-to-char* "")))
 
+(defmethod convert-resource-out ((parent t) (type (eql 'orientation)) value)
+  (ecase value
+    (:vertical 1)
+    (:horizontal 2)))
 
-;;; Accelerator table stuff
+(defmethod convert-resource-out ((parent t) (type (eql 'menu-widget)) value)
+  value)
 
-(defmethod convert-resource-in (parent (type (eql 'xt::accelerator-table))
-				(value (eql 0)))
-  nil)
+(defmethod convert-resource-out ((parent t) (type (eql 'label-type)) value)
+  (ecase value
+    (:pixmap 1)
+    (:string 2)))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'alignment)) value)
+  (ecase value
+    (:center 1)
+    (:beginning 0)
+    (:end 2)))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value)
+  (convert-pixmap-out parent value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value)
+  (convert-pixmap-out parent value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value)
+  (convert-pixmap-out parent value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value)
+  (convert-pixmap-out parent value))
+
+(defun convert-pixmap-out (parent value)
+  (etypecase value
+    (pixmap value)
+    (string
+     (let* ((display (widget-display parent))
+	    (screen (x11:xdefaultscreenofdisplay display))
+	    (white (x11::xwhitepixel display 0))
+	    (black (x11::xblackpixel display 0)))
+       (xm_get_pixmap screen value white black)))))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value)
+  (if value 1 0))
+
+(defmethod convert-resource-out ((parent  t) (type (eql 'string)) value)
+  (string-to-char* value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value)
+  (make-instance 'font
+    :display (widget-display parent)
+    :name value))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'pixel)) value)
+  (etypecase value
+	     (integer value)
+	     (color (allocate-color (default-colormap (widget-display parent))
+				    value))))
+			   
+(defmethod convert-resource-out ((parent t) (type (eql 'window)) x)
+  x)
+
+(defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value)
+  (etypecase value
+    (pixmap
+     (encode-pixmap value))))
 
+(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x)
+  x)
+
+;;; Accelerator table stuff
 (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table))
 				(value (eql nil)))
+  (declare (ignore parent))
   0)
 
-(define-enumerated-resource visual-policy (:variable :constant))
-(define-enumerated-resource scroll-bar-display-policy (:static :as-needed))
-(define-enumerated-resource selection-policy (:single-select :multiple-select :extended-select :browse-select))
+
 
 (defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value)
   (if value
@@ -566,10 +558,38 @@
 	    (i 0 (1+ i)))
 	  ((null v)
 	   r)
-	(setf (x-arglist r i)
+	(setf (xt-arglist r i)
 	  (convert-resource-out parent 'xm-string (car v))))
     0))
 
+
+
+(defmethod convert-resource-in ((widget t) (type (eql 'widget-list)) x)
+  (let ((r nil))
+    (dotimes (i (widget-num-children widget))
+      (push (convert-resource-in 
+	     widget 'widget (xt-widget-list x i))
+	    r))
+    (nreverse r)))
+
+(defmethod convert-resource-in ((parent t) (type (eql 'string)) value)
+  (unless (zerop value)
+    (char*-to-string value)))
+
+(defmethod convert-resource-in ((parent t) (type (eql 'boolean)) value)
+  (not (zerop value)))
+
+(defmethod convert-resource-in ((widget t) (type (eql 'widget)) x)
+  (intern-widget x :display (widget-display widget)))
+
+;;; Accelerator table stuff
+(defmethod convert-resource-in (parent (type (eql 'xt::accelerator-table))
+				(value (eql 0)))
+  (declare (ignore parent))
+  nil)
+
+
+
 ;;-- This is a problem cos we dont know the number of items
 
 (defmethod convert-resource-in (parent (type (eql 'xm-string-table)) value)
@@ -585,3 +605,4 @@
   (etypecase value
     ;;-- Should check to see if its registered
     (integer value)))
+
diff --git a/tk/widget.lisp b/tk/widget.lisp
index ae12733e7bbe4c3a8a6517ccb3a2b1900893ed22..f7a26e83395bf28e03b118e06e6a3f9cac26ab33 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: widget.lisp,v 1.17 92/04/21 16:12:25 cer Exp Locker: cer $
+;; $fiHeader: widget.lisp,v 1.18 92/04/21 20:27:42 cer Exp $
 
 (in-package :tk)
 
@@ -61,7 +61,7 @@
   (let* ((class (find-class-maybe widget-class))
 	 (handle (class-handle class))
 	 (arglist (make-arglist-for-class class parent args)))
-    (funcall fn (string-to-char* name )
+    (funcall fn name
 	     handle
 	     parent
 	     arglist
@@ -74,15 +74,11 @@
   (xt_manage_child child))
 
 (defun unmanage-child (child)
-  (unmanage_child child))
+  (xt_unmanage_child child))
 
 (defun is-managed-p (widget)
     (not (zerop (xt_is_managed widget))))
 
-
-(defun unmanage-child (child)
-  (xt_unmanage_child child))
-
 (defun manage-children (children)
   (xt_manage_children (map '(simple-array (signed-byte 32))
 		     #'ff:foreign-pointer-address 
@@ -126,7 +122,8 @@
 			  (error "Invalid window id ~D for ~S" id widget))
 		   (intern-object-xid
 		    id
-		    'window 
+		    'window
+		    (widget-display widget)
 		    :display (widget-display widget)))))))))
 
 (defun make-clx-window (display widget)
@@ -163,7 +160,7 @@
     (apply (car cleanup) (cdr cleanup)))
   ;;--- When we start using gadgets things will be fun!
   (let ((w (widget-window widget nil t)))
-    (when w (unregister-xid w)))
+    (when w (unregister-xid w (object-display widget))))
   (unintern-widget widget))
 
 (defun intern-widget (widget-address &rest args)
@@ -247,3 +244,19 @@
 
 (defun set-sensitive (widget value)
   (xtsetsensitive widget (if value 1 0)))
+
+
+;; Could not think of anywhere better!
+
+(defun setup (&optional (hostspec "localhost:0"))
+  (let* ((context (create-application-context))
+	 (display (make-instance 'display 
+		    :host hostspec
+		    :context context))
+	 (app (app-create-shell :display display
+				:widget-class 'application-shell)))
+    (values context display app)))
+
+(defun initialize-motif-toolkit (hostspec)
+  (setup hostspec))
+
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 7ae9eb6c5795a519fb79733289d04db5c25a5191..9cb872e61e4f1caaa6e07e080181a17d85417fde 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,80 +20,131 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.15 92/04/21 16:12:27 cer Exp Locker: cer $
+;; $fiHeader: xlib.lisp,v 1.16 92/04/21 20:27:43 cer Exp $
 
 (in-package :tk)
 
 ;;; Pathetic clos interface to Xlib
 
-(defclass screen (display-object) ())
-
-#+obsolete
-(defun screen-gcontext (screen)
-  (let ((gc (x-screen-gc screen)))
-    (or (find-object-from-address gc nil)
-	(register-address
-	 (make-instance 'gcontext
-			:display (object-display screen)
-			:foreign-address gc)))))
-
-
+(defclass display-object (ff:foreign-pointer)
+  ((display :initarg :display
+	    :fixed-index 0)))
 
+(defclass screen (display-object) ())
 
 (defclass drawable (display-object) ())
 	  
 (defclass window (drawable) ())
 
-;; Ugh.  This should be part of a general purpose mechanism
-(defmethod drawable-depth ((window window))
-  (let ((attrs (x11:make-xwindowattributes)))
-    (x11:xgetwindowattributes (object-display window)
-			      window
-			      attrs)
-    (x11:xwindowattributes-depth attrs)))
+(eval-when (compile load eval)
+  (defconstant *window-set-attributes-bit-mask*
+      '(background-pixmap background-pixel border-pixmap border-pixel
+	bit-gravity win-gravity backing-store backing-planes backing-pixel
+	override-redirect save-under event-mask do-not-propogate-mask
+	colormap cursor))
+  ;; Not really supported yet:
+  (defconstant *window-configure-bit-mask*
+      '(x y width height border-width sibling stacking-mode)))
+
+(eval-when (compile eval)
+  (defmacro define-window-reader (name &optional decoder &rest args)
+    `(defmethod ,(intern (format nil "~A-~A" 'window name)) ((window window))
+       ,(let ((body
+	       `(let ((attrs (x11:make-xwindowattributes)))
+		  (x11:xgetwindowattributes (object-display window)
+					    window
+					    attrs)
+		  (,(intern (format nil "~a-~a" 'xwindowattributes name) :x11)
+		   attrs))))
+	  (if decoder
+	      `(,decoder ,body ,@args)
+	    body))))
+  (defmacro define-window-writer (name &optional encoder &rest args)
+    `(progn
+       (defmethod (setf ,(intern (format nil "~A-~A" 'window name)))
+	   (nv (window window))
+	 (let ((attrs (x11::make-xsetwindowattributes)))
+	   (setf (,(intern (format nil "~a-~a" 'xsetwindowattributes name) :x11)
+		  attrs)
+	     ,(if encoder
+		  `(,encoder nv ,@args)
+		`nv))
+	   (x11:xchangewindowattributes
+	    (object-display window)
+	    window
+	    ,(ash 1 (or (position name *window-set-attributes-bit-mask*)
+			(error "Cannot find ~S in window attributes" name)))
+	    attrs)
+	   nv))))
+  (defmacro define-window-accessor (name (&optional encoder decoder) &rest args)
+    `(progn
+       (define-window-reader ,name ,decoder ,@args)
+       (define-window-writer ,name ,encoder ,@args)
+       ',name)))
+
+(define-window-accessor backing-store (encode-backing-store decode-backing-store))
+
+(defun encode-backing-store (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    ((t :always) 2)
+    (:when-mapped 1)
+    ((nil :not-useful) 0)))
     
-(defmethod (setf drawable-save-under) (nv (window window))
-  (let ((attrs (x11:make-xsetwindowattributes)))
-    (setf (x11:xsetwindowattributes-save-under attrs) (if nv 1 0))
-    (x11:xchangewindowattributes (object-display window)
-				 window
-				 x11::cwsaveunder ;; 
-				 attrs)
-    nv))
-
-(defmethod drawable-save-under ((window window))
-  (let ((attrs (x11:make-xwindowattributes)))
-    (x11:xgetwindowattributes (object-display window)
-			      window
-			      attrs)
-    (not (zerop (x11:xwindowattributes-save-under attrs)))))
+(defun decode-backing-store (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (2 :always)
+    (1 :when-mapped)
+    (0 :not-useful)))
+    
+(defun encode-save-under (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    ((t :on) 1)
+    ((nil :off) 0)))
+    
+(defun decode-save-under (x)
+  (declare (optimize (speed 3) (safety 0)))
+  (ecase x
+    (1 t)
+    (0 nil)))
 
+(define-window-accessor save-under (encode-save-under decode-save-under))
 
-(defmethod (setf drawable-backing-store) (nv (window window))
-  (let ((attrs (x11:make-xsetwindowattributes)))
-    (setf (x11:xsetwindowattributes-backing-store attrs) (if nv 1 0))
-    (x11:xchangewindowattributes (object-display window)
-				 window
-				 x11::cwbackingstore ;; 
-				 attrs)
-    nv))
+;;--- Something else should be here.
 
-(defmethod drawable-backing-store ((window window))
+(defmethod window-depth ((window window))
   (let ((attrs (x11:make-xwindowattributes)))
     (x11:xgetwindowattributes (object-display window)
 			      window
 			      attrs)
-    (not (zerop (x11:xwindowattributes-backing-store attrs)))))
+    (x11:xwindowattributes-depth attrs)))
+
+(defmethod drawable-width ((window window))
+  (window-width window))
+(defmethod drawable-height ((window window))
+  (window-height window))
+(defmethod drawable-depth ((window window))
+  (window-depth window))
 
   
 (defclass pixmap (drawable)
   ((width :initarg :width :reader pixmap-width)
    (height :initarg :height :reader pixmap-height)
-   (depth :initarg :depth :reader drawable-depth)))
+   (depth :initarg :depth :reader pixmap-depth)))
+
+(defmethod drawable-width ((pixmap pixmap))
+  (pixmap-width pixmap))
+(defmethod drawable-height ((pixmap pixmap))
+  (pixmap-height pixmap))
+(defmethod drawable-depth ((pixmap pixmap))
+  (pixmap-depth pixmap))
 
 (defun destroy-pixmap (pixmap)
-  (unregister-xid pixmap)
-  (x11:xfreepixmap (object-display pixmap) pixmap))
+  (let ((display (object-display pixmap)))
+    (unregister-xid pixmap display)
+    (x11:xfreepixmap display pixmap)))
   
 (defmethod initialize-instance :after
 	   ((p pixmap) &key foreign-address width height depth drawable)
@@ -107,7 +158,7 @@
 	 width
 	 height
 	 depth))
-      (register-xid p))))
+      (register-xid p display))))
 
 (defun-c-callable x-error-handler ((display :unsigned-long) (x :unsigned-long))
   (error "x-error:~S" 
@@ -119,9 +170,9 @@
 
 
 (defun get-error-text (code display-handle)
-  (let ((s (string-to-char* (make-string 1000))))
+  (let ((s (make-string 1000)))
     (x11::xgeterrortext display-handle code s 1000)
-    (char*-to-string s)))
+    s))
       
 (defun setup-error-handlers ()
   (x11:xseterrorhandler (register-function 'x-error-handler))
@@ -135,6 +186,7 @@
   (intern-object-xid
    (x11:xdefaultrootwindow display)
    'window
+   display
    :display display))
 
 (defmethod display-screen-number (display)
@@ -148,6 +200,7 @@
    (x11:xdefaultcolormap display
 			 screen)
    'colormap
+   display
    :display 
    display))
 
@@ -177,7 +230,7 @@
     (if (zerop (x11:xlookupcolor
 		(object-display colormap)
 		colormap
-		(string-to-char* color-name)
+		color-name
 		exact
 		closest))
 	(error "Could not find ~S in colormap ~S" color-name colormap)
@@ -245,10 +298,12 @@
 	   (intern-object-xid
 	    (aref root 0) 
 	    'window
+	    display
 	    :display display)
 	   (intern-object-xid
 	    (aref child 0) 
 	    'window
+	    display
 	    :display display)
 	   (aref root-x 0)
 	   (aref root-y 0)
diff --git a/tk/xm-classes.lisp b/tk/xm-classes.lisp
index 74f6e479cc4739efd4cdac0e2c1e1fa500e3e77f..8304e732dd453d2302e7975edfb08a3f609d4479 100644
--- a/tk/xm-classes.lisp
+++ b/tk/xm-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-classes.lisp,v 1.3 92/03/30 17:51:54 cer Exp $
+;; $fiHeader: xm-classes.lisp,v 1.4 92/04/15 11:44:56 cer Exp $
 
 
 (provide :climxm)
@@ -76,4 +76,7 @@
 				"_xmTextFieldWidgetClass"
 				"_xmTextWidgetClass"
 				"_xmToggleButtonGadgetClass"
-				"_xmToggleButtonWidgetClass"))
+				"_xmToggleButtonWidgetClass"
+				
+				"_xmMyDrawingAreaWidgetClass"
+				))
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index 51e0454299fb874e1ca38b662c35ac69d41542e6..756d9db8fa96f75bd8a6e4da86502eeeb2b4d405 100644
--- a/tk/xm-defs.lisp
+++ b/tk/xm-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-defs.lisp,v 1.3 92/04/28 09:25:07 cer Exp Locker: cer $
+;; $fiHeader: xm-defs.lisp,v 1.4 92/05/06 15:37:10 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -28,7 +28,7 @@
 
 (in-package :tk)
 
-(def-c-type (xm-proto-callback-info :no-defuns) :struct
+(def-c-type (xm-proto-callback-info :no-defuns :in-foreign-space) :struct
 	     (handle :int)
 	     (data :int))
 
diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp
index d26f77b1622df5c04c4b34d30deaa45d0231c853..94705362e4f743d5e11b8ca51156040f35c0a63d 100644
--- a/tk/xm-protocols.lisp
+++ b/tk/xm-protocols.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-protocols.lisp,v 1.6 92/04/21 20:27:48 cer Exp Locker: cer $
+;; $fiHeader: xm-protocols.lisp,v 1.7 92/04/28 09:25:10 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -83,7 +83,7 @@
 (defun xm-intern-atom (shell name &optional only-if-exists)
   (xm_intern_atom
    (object-display shell)
-   (string-to-char* (string name))
+   (string name)
    (if only-if-exists 1 0)))
 
 
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index c9cbeb6f6182d1ecb83f8819aed11063f07a863b..26b6e7596f65f458999ba54582707097524fe247 100644
--- a/tk/xt-defs.lisp
+++ b/tk/xt-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-defs.lisp,v 1.1 92/04/21 16:40:03 cer Exp Locker: cer $
+;; $fiHeader: xt-defs.lisp,v 1.2 92/04/21 20:27:50 cer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -139,7 +139,13 @@
 
 (def-c-type (class-array :no-defuns) 1 :unsigned-long)
 
-(def-c-type (x-arglist :in-foreign-space :no-defuns) 1 :unsigned-long)
+(def-c-type (xt-arg-val :no-defuns) * :void)
+
+(def-c-type (xt-arg :in-foreign-space :no-defuns) :struct
+  (name  * :char)
+  (value xt-arg-val))
+
+(def-c-type (xt-arglist :in-foreign-space :no-defuns) 1 xt-arg)
 
 (def-c-type (xt-widget-list :no-defuns) 1 * xt-widget)
 
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index 475b190db61f1ec2d1c818bbcf7eb66b334b23f4..5ff7cbca68dd7a4c567b880942cc8168b87714e6 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: lisp-utilities.lisp,v 1.8 92/04/15 11:45:31 cer Exp $
+;; $fiHeader: lisp-utilities.lisp,v 1.9 92/05/07 13:11:38 cer Exp Locker: cer $
 
 (in-package :clim-utils)
 
@@ -123,6 +123,14 @@
      ,@(mapcar #'(lambda (x) `(setq ,x (fix-coordinate ,x)))
 	       coords)))
 
+;; Assume that the value is a fixnum and that the result is a fixnum.
+(defmacro fast-abs (int)
+  (let ((val (gensym)))
+    `(let ((,val ,int))
+       (declare (fixnum ,val))
+       (the fixnum (if (< ,val 0) (the fixnum (- 0 ,val)) ,val)))))
+    
+
 ;; COORDINATE-PAIRS is a list of pairs of coordinates.
 ;; The coordinates must be of type COORDINATE
 (defmacro translate-coordinates (x-delta y-delta &body coordinate-pairs)
@@ -136,34 +144,44 @@
 			  (the coordinate (+ ,(second pts) ,y-delta))) forms))
 	   (nreverse forms)))))
 
+;;
+;; Note that this macro evaluates its arguments multiple times.
+;;
 (defmacro convert-to-device-coordinates (transform &body positions)
   (assert (evenp (length positions)) (positions)
-	  "There must be an even number of elements in ~S" positions)
-  (let ((forms nil))
+    "There must be an even number of elements in ~S" positions)
+  (let ((forms nil)
+	(nx (gensym))
+	(ny (gensym)))
     (loop
       (when (null positions)
 	(return `(progn ,@(nreverse forms))))
       (let* ((x (pop positions))
 	     (y (pop positions)))
-	(push `(multiple-value-setq (,x ,y)
-		 (multiple-value-bind (nx ny) 
-		     (transform-position ,transform ,x ,y)
-		   (values (fix-coordinate nx) (fix-coordinate ny))))
+	(push `(multiple-value-bind (,nx ,ny) 
+		   (transform-position ,transform ,x ,y)
+		 (setq ,x (fix-coordinate ,nx)
+		       ,y (fix-coordinate ,ny)))
 	      forms)))))
 
+;;
+;; Note that this macro evaluates its arguments multiple times.
+;;
 (defmacro convert-to-device-distances (transform &body positions)
   (assert (evenp (length positions)) (positions)
 	  "There must be an even number of elements in ~S" positions)
-  (let ((forms nil))
+  (let ((forms nil)
+	(nx (gensym))
+	(ny (gensym)))
     (loop
       (when (null positions)
 	(return `(progn ,@(nreverse forms))))
       (let* ((x (pop positions))
 	     (y (pop positions)))
-	(push `(multiple-value-setq (,x ,y)
-		 (multiple-value-bind (nx ny) 
-		     (transform-distance ,transform ,x ,y)
-		   (values (fix-coordinate nx) (fix-coordinate ny))))
+	(push `(multiple-value-bind (,nx ,ny) 
+		   (transform-distance ,transform ,x ,y)
+		 (setq ,x (fix-coordinate ,nx)
+		       ,y (fix-coordinate ,ny)))
 	      forms)))))
 
 
diff --git a/utils/packages.lisp b/utils/packages.lisp
index f2f10d513e10e17451c322d1bcfc19e35d38b1cd..14b42b3157e18ff20800e1e27ff17b1083f0882a 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.14 92/05/06 15:37:27 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.15 92/05/07 13:11:40 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -3082,6 +3082,7 @@
     doseq
     dovector
     evacuate-list
+    fast-abs
     find-class-that-works
     fintern
     flatten-arglist
diff --git a/xlib/load-xlib.lisp b/xlib/load-xlib.lisp
index 57171f45b2f69b76dae84225af634023cd6eed4a..fdc7b073178a703759a5257a69ccb550a23b6f5b 100644
--- a/xlib/load-xlib.lisp
+++ b/xlib/load-xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xlib.lisp,v 1.1 92/03/24 19:43:50 cer Exp Locker: cer $
+;; $fiHeader: load-xlib.lisp,v 1.2 92/03/30 17:52:17 cer Exp $
 
 (in-package :x11)
 
@@ -50,6 +50,8 @@
 
 (defvar *libx11-pathname* "/x11/R4/src/mit/lib/X/libX_d.a")
 
+(unless (ff:get-entry-point (ff:convert-to-lang "lisp_XDrawString"))
+  (load "xlibsupport.o" :system-libraries (list *libx11-pathname*) :print t))
 (x11::load-undefined-symbols-from-library
  "stub-x.o"
  (x11::symbols-from-file "misc/undefinedsymbols")
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index dc3ea8a530be0280bd1b93bcf11cadb10214dad8..756ee9b124553676cb6ca34cb95e1de59476d07e 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -45,7 +45,7 @@
 ;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
 ;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
 
-;;; $fiHeader: xlib-funs.lisp,v 1.3 92/03/30 17:52:19 cer Exp $
+;;; $fiHeader: xlib-funs.lisp,v 1.5 92/04/21 20:28:07 cer Exp $
 
 (in-package :x11)
 
@@ -805,6 +805,7 @@
 (def-exported-foreign-function (xrefreshkeyboardmapping (:return-type int) (:name "_XRefreshKeyboardMapping")) 
    (event (:pointer xmappingevent)))
 
+#+ignore
 (def-exported-foreign-function (xusekeymap (:return-type int) (:name "_XUseKeymap")) 
    (filename (:pointer char)))