diff --git a/Makefile b/Makefile
index 5f0537b766356794df85979691bfeb026e6de05d..aded3456a128ac372b328a480a772c02be6cdf25 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.21 92/04/10 14:27:40 cer Exp Locker: cer $
+# $fiHeader: Makefile,v 1.22 92/04/15 11:48:32 cer Exp Locker: cer $
 # 
 #  Makefile for CLIM 2.0
 #
@@ -26,9 +26,9 @@ 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
+SRC_FILES = */*.lisp *.lisp Makefile */Makefile misc/make-stub-file \
+	    misc/undefinedsymbols misc/undefinedsymbols.olit \
+	    misc/undefinedsymbols.motif misc/undefinedsymbols.xt
 
 DEST=/dev/null
 
@@ -72,7 +72,12 @@ FCLIMOBJS= `pwd`/stub-motif.o `pwd`/stub-olit.o `pwd`/stub-x.o `pwd`/stub-xt.o
 #
 # "Compile time objects" -- these go into clim-debug.fasl
 #
-DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl
+DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \
+	     xlib/x11-keysyms.fasl xlib/load-xlib.fasl xlib/last.fasl \
+	     tk/xt-defs.fasl tk/xm-defs.fasl 
+
+# This should be in the clim-debug file but it seems a pain to have to compile it up
+# tk/ol-defs.fasl
 
 #
 # "Load time objects" -- these go into clim.fasl
@@ -183,7 +188,6 @@ XT-TK-OBJS =  xlib/load-xlib.fasl \
                 tk/font.fasl \
                 tk/gcontext.fasl \
                 tk/graphics.fasl \
-                tk/xtk.fasl \
                 tk/meta-tk.fasl \
                 tk/make-classes.fasl \
                 tk/foreign.fasl \
@@ -208,6 +212,7 @@ XM-TK-OBJS = tk/xm-classes.fasl \
 OL-CLIM-OBJS = tk/ol-classes.fasl \
 	     tk/load-ol.fasl \
 		tk/xt-funs.fasl \
+		tk/ol-funs.fasl \
                 tk/ol-init.fasl \
                 tk/ol-callbacks.fasl \
                 tk/make-widget.fasl
@@ -264,8 +269,10 @@ compile-ol:	$(CLIMOBJS) FORCE
 
 # Concatenation
 
-cat-xm:	climg.fasl climxm.fasl clim-debug.fasl
-cat-ol:	climg.fasl climol.fasl clim-debug.fasl
+cat:	cat-xm cat-ol
+cat-g:	climg.fasl clim-debug.fasl
+cat-xm:	cat-g climxm.fasl
+cat-ol:	cat-g climol.fasl
 
 climg.fasl	: $(GENERIC-OBJS) $(XT-OBJS)
 	$(CAT)  $(GENERIC-OBJS) $(XT-OBJS) > $(TMP)/clim.fasl_`whoami`
@@ -303,6 +310,7 @@ clim-xm:	FORCE
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
 	ls -lt $(CLIM) >> Clim-sizes.n
+	size $(CLIM) >> Clim-sizes.n
 	ls -lt $(CLIM)
 
 clim-ol:	FORCE
@@ -314,6 +322,7 @@ clim-ol:	FORCE
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
 	ls -lt $(CLIM) >> Clim-sizes.n
+	size $(CLIM) >> Clim-sizes.n
 	ls -lt $(CLIM)
 
 
@@ -323,6 +332,7 @@ clim-small:	FORCE
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL)
 	ls -lt $(CLIM-SMALL) >> Clim-sizes.n
+	size $(CLIM) >> Clim-sizes.n
 	ls -lt $(CLIM-SMALL)
 
 # Training
@@ -336,7 +346,9 @@ train	:	FORCE
 # Misc
 
 clean:
-	find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f clim*.fasl clim-debug.fasl
+	find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \
+	  $(CLIMOBJS) slim slim-small
+
 
 cheapclean:
 	find $(CHEAP_CLEAN) -name "*.fasl" -print | xargs rm -f
@@ -410,9 +422,9 @@ stub-xt.c	:  $(XT_UNDEFS) misc/make-stub-file
 FRC	: 
 
 xm-composer : xm-dcl
-	cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2
+	cd /usr/composer2 ; make CL=$(CL) rebuild-c2
 
 ol-composer : ol-dcl
-	cd /usr/composer2 ; make CL=/vapor/usr/tech/cer/cl/src/dcl rebuild-c2
+	cd /usr/composer2 ; make CL=$(CL) rebuild-c2
 
 
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index d2b03f4e9581fc8e9f58bccd8ae9db84f76cf0fd..670f4741122f96523bbd5f9b1ba2425256503f0a 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.1 92/03/24 19:45:40 cer Exp Locker: cer $
+;; $fiHeader: compile-1.lisp,v 1.2 92/04/10 14:27:44 cer Exp Locker: cer $
 
 (in-package :user)
 
@@ -33,6 +33,17 @@
 (setf (sys:gsgc-switch :print) t)
 (setf (sys:gsgc-switch :stats) t)
 
+(setq comp:generate-call-count-code-switch
+  (named-function |(> debug 1)| 
+		  (lambda (safety size speed debug)
+		    (declare (ignore safety size speed))
+		    (> debug 1))))
+(setq comp:declared-fixnums-remain-fixnums-switch
+  (named-function |(> speed 2)|
+		  (lambda (safety size speed debug)
+		    (declare (ignore safety size debug))
+		    (> speed 2))))
+
 (setq *compile-print* nil)
 
 (unless (find-package 'clim-defsystem)
@@ -43,7 +54,7 @@
 
 
 (defun compile-it (sys)
-  (unless (errorset (clim-defsys::find-system sys))
+  (unless (ignore-errors (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 c0a77598108d326aba4d31f451de3e6e59c4e915..3376e01a539b915e02fe8e04f8b79b3c5b9cf3f0 100644
--- a/misc/dev-load-1.lisp
+++ b/misc/dev-load-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dev-load-1.lisp,v 1.2 92/04/10 14:27:45 cer Exp Locker: cer $
+;; $fiHeader: dev-load-1.lisp,v 1.3 92/04/15 11:48:34 cer Exp Locker: cer $
 
 (excl::free (excl::malloc 131072))
 
@@ -40,6 +40,7 @@
    (let ((*load-source-file-info* t)
 	 (*load-xref-info* nil)
 	 (excl:*global-gc-behavior* nil))
+     #-ignore
      (ecase sys
        (motif-clim
 	(load "climg.fasl")
@@ -48,7 +49,12 @@
        (openlook-clim
 	(load "climg.fasl")
 	(load "climol.fasl")
-	(load "clim-debug.fasl")))))
+	(load "clim-debug.fasl")))
+     #+ignore
+     (defsys::load-system sys)))
+
+  #+ignore
+  (defsys:update-system sys)
 
   ;;-- What would be good is to mark the files in the system as having
   ;;-- been loaded
diff --git a/misc/load-xm.lisp b/misc/load-xm.lisp
index b104f0d655f3e63908c5cae7b93ad80f18d84836..82cf58ad51f23f3652bec2dd3444ff25b9d231b0 100644
--- a/misc/load-xm.lisp
+++ b/misc/load-xm.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.1 92/02/16 20:31:30 cer Exp $
+;; $fiHeader: load-xm.lisp,v 1.2 92/02/24 13:09:54 cer Exp $
 
 (excl::free (excl::malloc 131072))
 
@@ -32,4 +32,5 @@
        (*load-xref-info* nil)
        (excl:*global-gc-behavior* nil))
    (let ((*enable-package-locked-errors* nil))
-     (load "clim.fasl"))))
+     (load "climg.fasl")
+     (load "climxm.fasl"))))
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index e0128018f918cad54a5e37f896ef8d3181472245..98ed6b5b7ee0643f6cef56457ad4cb0b76ef376c 100644
--- a/silica/db-scroll.lisp
+++ b/silica/db-scroll.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-scroll.lisp,v 1.14 92/04/15 11:45:04 cer Exp Locker: cer $
+;; $fiHeader: db-scroll.lisp,v 1.15 92/04/21 16:12:37 cer Exp Locker: cer $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -307,12 +307,11 @@
 	     (let ((region (viewport-viewport-region vp)))
 	       ;;---- we should make the sheet-region bigger at this point
 	       ;; perhaps we do a union of the sheet-region and the viewport
-	       (with-sheet-medium (medium vp)
-		 (draw-rectangle* medium
-				  0 0 
-				  (bounding-rectangle-width region)
-				  (bounding-rectangle-height region)
-				  :ink +background-ink+ :filled t))
+	       (with-sheet-medium (medium stream)
+		 (multiple-value-call #'draw-rectangle* 
+		   medium
+		   (bounding-rectangle* region)
+		   :ink +background-ink+ :filled t))
 	       (replay (stream-output-history stream) stream region)))))))))
 
 
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index 6d51331f3b378e4ebb3b8456a0287de96a687b39..bfe22afbe0d88decb30e734cc0c3ef175953a9ea 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.12 92/04/10 14:27:13 cer Exp Locker: cer $
+;; $fiHeader: sysdcl.lisp,v 1.13 92/04/15 11:47:38 cer Exp Locker: cer $
 
 (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user)
 
@@ -433,6 +433,7 @@ o     :needed-systems (clim-standalone)
      :load-before-compile (xlib))
   ;; General stuff
   ("pkg")
+  ("xt-defs")				; Used to be 'xtk'.
   ("foreign-obj")
   ("macros")
   ;; Xlib stuff
@@ -442,8 +443,6 @@ o     :needed-systems (clim-standalone)
   ("graphics")
   
   ;; Toolkit stuff
-  ;; ("load-xt")
-  ("xtk")
   ("meta-tk")
   ("make-classes")
   ("foreign")
@@ -461,9 +460,10 @@ o     :needed-systems (clim-standalone)
      :needed-systems (xt-tk)
      :load-before-compile (xt-tk))
   ;; Motif specific stuff
+  ("xm-defs")
+  ("xm-classes")
   ("load-xm")
-  ;;--- This is really in tk but because of the loading
-  ("xt-funs")
+  ("xt-funs") ;;--- This is really in tk but because of the loading
   ("xm-funs")
   ("xm-classes")
   ("xm-init")
@@ -483,9 +483,11 @@ o     :needed-systems (clim-standalone)
      :needed-systems (xt-tk)
      :load-before-compile (xt-tk))
   ;; OpenLook specific stuff
-  ("load-ol")
-  ("xt-funs")
+  ("ol-defs")
   ("ol-classes")
+  ("load-ol")
+  ("xt-funs") ;;--- This is really in tk but because of the loading
+  ("ol-funs")
   ("ol-init")
   ("ol-callbacks")
   #+ignore("ol-examples")
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index f03fa8c58b266526f4223043d3d0f65780cefd16..40db8d26ad8e628f4692faf2ae04a546f0350ae8 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.8 92/04/10 14:27:47 cer Exp Locker: cer $
+;; $fiHeader: ol-gadgets.lisp,v 1.9 92/04/15 11:48:38 cer Exp Locker: cer $
 
 
 (in-package :xm-silica)
@@ -136,8 +136,9 @@
 			   :button4-motion
 			   :button5-motion
 			   :button-motion
+			   :exposure
 			   )
-			 0
+			 1
 			 'sheet-mirror-event-handler
 			 sheet))
 
diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp
index b15de6dcd906766b5c1e67e568ff5dbd9315fedf..db95a33cb8f611ec6d01e0da3566420433c8aa16 100644
--- a/tk-silica/pkg.lisp
+++ b/tk-silica/pkg.lisp
@@ -18,9 +18,11 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.3 92/01/31 14:56:21 cer Exp $
+;; $fiHeader: pkg.lisp,v 1.4 92/02/24 13:06:14 cer Exp $
 
-(defpackage :xm-silica
-  (:use clim-lisp clim-utils clim silica tk))
+(defpackage :tk-silica
+  (:nicknames :xm-silica)
+  (:use clim-lisp clim-utils clim silica tk)
+  (:import-from :excl #:if*))
 
   
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 8392f14aad5b788a7aab995944ee9c929851dd08..74c06d537611455f7b71331714e7c7ddc576d319 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.12 92/04/10 14:27:49 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.lisp,v 1.13 92/04/21 16:13:26 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -316,5 +316,5 @@
 	    (tk::set-values shell :icon-name name))
 	  (when pixmap
 	    (tk::set-values shell :icon-pixmap (decode-pixmap pixmap)))
-	  (when mask-pixmap
-	    (tk::set-values shell :clip-mask (decode-pixmap mask-pixmap))))))))
+	  (when clip-mask
+	    (tk::set-values shell :clip-mask (decode-pixmap clip-mask))))))))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index fd9aec4a998f7b95559e1ab87df420e5dd40a3c4..7682a8ef97700d0fc51f24715846eea452f08fb6 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.22 92/04/15 11:48:40 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.lisp,v 1.23 92/04/21 16:13:27 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -157,8 +157,9 @@
 			   :button4-motion
 			   :button5-motion
 			   :button-motion
+			   :exposure
 			   )
-			 0
+			 1
 			 'sheet-mirror-event-handler
 			 sheet))
 
@@ -424,7 +425,7 @@
 			   :button-press
 			   :button-release
       			   )
-			 0
+			 1
 			 'sheet-mirror-event-handler
 			 sheet))
 
@@ -818,6 +819,7 @@
 			      (frame-top-level-sheet frame))
 			     (title "Notify user")
 			     documentation
+			     exit-boxes
 			     (name title))
   (let ((dialog (make-instance (ecase style
 				 (:inform 'tk::xm-information-dialog)
@@ -831,8 +833,8 @@
 			       ))
 	(result nil))
     (multiple-value-bind
-	(help-button)
-	(get-message-box-child dialog :help)
+	(ok-button cancel-button help-button)
+	(get-message-box-child dialog :ok :cancel :help)
       (flet ((set-it (widget r)
 	       (declare (ignore widget))
 	       (setq result (list r)))
@@ -844,9 +846,21 @@
 		:associated-window associated-window)))
 	(tk::add-callback dialog :ok-callback #'set-it t)
 	(tk::add-callback dialog :cancel-callback #'set-it nil)
-	(if documentation
-	    (tk::add-callback help-button :activate-callback #'display-help)
-	  (xt::set-sensitive help-button nil))
+
+	(flet ((set-button-set (name button)
+		 (let ((x (assoc name exit-boxes)))
+		   (cond ((and x (null (second x)))
+			  (tk::unmanage-child button))
+			 ((second x)
+			  (tk::set-values button :label-string (second x)))))))
+	  (set-button-state :ok ok-button)
+	  (set-button-state :cancel cancel-button)
+	  (set-button-state :help help-button)
+	  
+	  (if documentation
+	      (tk::add-callback help-button :activate-callback #'display-help)
+	    (xt::set-sensitive help-button nil)))
+	
 	(unwind-protect
 	    (progn
 	      (tk::manage-child dialog)
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 305ec3bcb2c08e02ac676a73afc4af2cb31453fe..9a1cdebdc709988af3c9322f438d0ccbb2c0616d 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.14 92/04/15 11:48:43 cer Exp Locker: cer $
+;; $fiHeader: xm-silica.lisp,v 1.15 92/04/21 16:13:30 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -31,6 +31,7 @@
 (defmethod find-port-type ((type (eql ':motif)))
   'motif-port)
 
+
 (defmethod change-widget-geometry ((parent tk::xm-drawing-area) child
 				   &rest args
 				   &key x y width height)
diff --git a/tk-silica/xt-cursor.lisp b/tk-silica/xt-cursor.lisp
index e0a35c283cda82ecd3e86f0f6fe34b789a2bc70b..e90de9366bbebdcc6d42b8710a790880843d1b4a 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: xm-cursor.lisp,v 1.3 92/03/04 16:20:33 cer Exp Locker: cer $
+;; $fiHeader: xt-cursor.lisp,v 1.4 92/04/03 12:04:55 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -65,11 +65,9 @@
 		  port mirror)))
 	    (xt::realize-widget gadget)
 	    (let ((window (tk::widget-window gadget)))
-	      (setf (tk::drawable-save-under window) t
-		    (xt::drawable-backing-store window) t))
+	      (setf (tk::drawable-save-under window) t))
 	    ;;--- This really should be done somewhere else but where??????
 	    (let ((window (tk::widget-window (sheet-mirror sheet))))
-		(setf (tk::drawable-save-under window) t
-		      (xt::drawable-backing-store window) t))
+	      (setf (xt::drawable-backing-store window) t))
 	    gadget)))))
 
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 477aa7df85cd9043fbb624178858ecf52411aa73..abb9260eeee14781cbdf675073be7d999dc558a5 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -1,4 +1,4 @@
-U;; -*- mode: common-lisp; package: xm-silica -*-
+U;; -*- mode: common-lisp; package: tk-silica -*-
 ;;
 ;;				-[]-
 ;; 
@@ -20,9 +20,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.16 92/04/15 11:48:57 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.17 92/04/21 16:13:36 cer Exp Locker: cer $
 
-(in-package :xm-silica)
+(in-package :tk-silica)
 
 (defclass xt-medium (medium)
   ((foreground-gcontext :reader medium-foreground-gcontext :initform nil)
@@ -30,8 +30,8 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
    (flipping-gcontext :reader medium-flipping-gcontext :initform nil)
    (drawable :initform nil)
    (color-p)
-   (ink-table :initform (make-hash-table))
-   (stipple-gcontext :initform nil)		; These don't belong here.
+   (ink-table :initform (make-hash-table :test #'equal))
+   (tile-gcontext :initform nil)	; The following don't belong here.
    (white-pixel :initform 0)
    (black-pixel :initform 1)))
 
@@ -53,7 +53,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 
 (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet)
    (with-slots (foreground-gcontext background-gcontext flipping-gcontext color-p
-		drawable stipple-gcontext white-pixel black-pixel)
+		drawable tile-gcontext white-pixel black-pixel)
       medium
     (setf (medium-sheet medium) sheet)
     (when (and drawable
@@ -75,7 +75,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
       (setf color-p (color-medium-p medium))
       (setf white-pixel (x11:xwhitepixel display screen))
       (setf black-pixel (x11:xblackpixel display screen))
-      (setf stipple-gcontext (make-instance 'tk::gcontext
+      (setf tile-gcontext (make-instance 'tk::gcontext
 				 :drawable drawable
 				 :foreground black-pixel
 				 :background white-pixel))
@@ -84,7 +84,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet)
   (declare (ignore sheet))
   (with-slots 
-       (foreground-gcontext background-gcontext flipping-gcontext stipple-gcontext
+       (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext
 	drawable)
       medium
     (setf drawable nil
@@ -96,7 +96,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
       (loose-gc foreground-gcontext)
       (loose-gc background-gcontext)
       (loose-gc flipping-gcontext)
-      (loose-gc stipple-gcontext))))
+      (loose-gc tile-gcontext))))
 
 (defparameter *use-color* t)		; For debugging monochrome
 (defun color-medium-p (medium)
@@ -140,11 +140,6 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 ;;; Colors and their monochrome imposters
 ;;; Much of this is taken from CLX-IMPLEMENTATION
 
-(defun make-stipple-image (height width patterns)
-  (make-instance 'tk::image :width width :height height
-		 :data (clim-internals::make-stipple-array height width patterns)
-		 :depth 1))
-
 (defvar *luminance-stipples*
 	(mapcar #'(lambda (entry)
 		    (cons (first entry) (apply #'make-stipple-image (second entry))))
@@ -212,6 +207,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 
 (defgeneric decode-ink (ink medium))
 
+(defmethod decode-ink ((ink (eql +everywhere+)) medium)
+  (slot-value medium 'foreground-gcontext))
+
 (defmethod decode-ink ((ink (eql +foreground-ink+)) medium)
   (slot-value medium 'foreground-gcontext))
 
@@ -222,19 +220,18 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
   (slot-value stream 'flipping-gcontext))
 
 (defmethod decode-ink ((ink color) (medium xt-medium))
-  (with-slots (ink-table sheet stipple-gcontext white-pixel black-pixel drawable
-			 color-p)
+  (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable
+			 color-p ink-table)
       medium
-    (let ((drawable (or drawable
-			(tk::display-root-window (port-display (port sheet)))))
-	  (ink-table (slot-value medium 'ink-table)))
-      (or (gethash ink ink-table)
-	  (let ((new-gc (make-instance 'tk::gcontext :drawable drawable)))
-	    (cond (color-p
-		   (setf (tk::gcontext-foreground new-gc)
-		     (decode-color medium ink)))
-		  (t
-		   (multiple-value-bind (r g b) (color-rgb ink)
+    (or (gethash ink ink-table)
+	(let ((drawable (or drawable
+			    (tk::display-root-window (port-display (port sheet)))))
+	      (new-gc (make-instance 'tk::gcontext :drawable drawable)))
+	  (cond (color-p
+		 (setf (tk::gcontext-foreground new-gc)
+		   (decode-color medium ink)))
+		(t
+		 (multiple-value-bind (r g b) (color-rgb ink)
 		   ;; The luminance formula isn't really right.  XXX
 		   (let* ((luminance (color-luminosity r g b))
 			  (color (decode-luminance luminance t)))
@@ -244,16 +241,43 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 			   ((eq color 0)
 			    (setf (tk::gcontext-fill-style new-gc) :solid
 				  (tk::gcontext-foreground new-gc) white-pixel))
-			   (t			; color is an image
+			   (t		; color is an image
 			    (setf (tk::gcontext-fill-style new-gc) :tiled)
 			    (let ((pixmap (make-instance 'tk::pixmap
 					    :drawable drawable
 					    :width (tk::image-width color)
 					    :height (tk::image-height color)
 					    :depth (tk::drawable-depth drawable))))
-			      (tk::put-image pixmap stipple-gcontext color)
+			      (tk::put-image pixmap tile-gcontext color)
 			      (setf (tk::gcontext-tile new-gc) pixmap))))))))
-	    (setf (gethash ink ink-table) new-gc))))))
+	  (setf (gethash ink ink-table) new-gc)))))
+
+(defmethod decode-ink ((ink (eql +nowhere+)) medium)
+  (decode-ink-opacity ink medium))
+
+(defmethod decode-ink ((ink standard-opacity) medium)
+  (decode-ink-opacity ink medium))
+
+(defmethod decode-ink-opacity (opacity medium)
+  (with-slots (ink-table sheet tile-gcontext white-pixel black-pixel drawable
+			 foreground-gcontext color-p ink-table)
+      medium
+    (let ((key (cons opacity foreground-gcontext)))
+      (or (gethash key ink-table)
+	  (unless (eq :solid (tk::gcontext-fill-style foreground-gcontext))
+	    (warn "opacities may only be use with solid colors ~
+and on color servers, unless using white or black")
+            (return-from decode-ink-opacity foreground-gcontext))
+	  (let* ((port (port sheet))
+		 (display (port-display port))
+		 (drawable (or drawable (tk::display-root-window display)))
+		 (new-gc (make-instance 'tk::gcontext :drawable drawable)))
+  
+	    (x11:xcopygc display foreground-gcontext -1 new-gc)
+	    (setf (tk::gcontext-stipple new-gc) (decode-opacity opacity port)
+		  (tk::gcontext-fill-style new-gc) :stippled)
+	    (setf (gethash key ink-table) new-gc))))))
+  
 
 (defmethod decode-ink ((ink contrasting-ink) stream)
   (decode-ink (make-color-for-contrasting-ink ink) stream))
@@ -354,11 +378,12 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 				   (fix-coordinate (- c a)) (fix-coordinate (- d b)))
 		 (setf (tk::gcontext-clip-mask gc) x))))))
     
-    (when (eq (tk::gcontext-fill-style gc) :tiled)
+    (when (member (tk::gcontext-fill-style gc) '(:tiled :stippled) :test #'eq)
       (setf (tk::gcontext-ts-x-origin gc) x-origin
 	    (tk::gcontext-ts-y-origin gc) y-origin))
     gc))
 
+#+ignore
 (defmethod decode-ink :around ((ink t) (medium xt-medium))
   (let ((gc (call-next-method)))
     gc))
@@ -473,21 +498,19 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
       (port-draw-transformed-rectangle*
 	port sheet medium x1 y1 x2 y2 filled))))
 
-(ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint)
-  
 (defmethod port-draw-polygon* ((port xt-port) sheet medium
 			       list-of-x-and-ys
 			       closed filled)
   (let* ((transform (sheet-device-transformation sheet))
 	 (npoints (/ (length list-of-x-and-ys) 2))
-	 (points (excl::malloc ;; BUG BUG BUG
-		  (* 4 (cond ((and closed (not filled))
-			      (incf npoints))
-			     (t npoints)))))
+	 (points (xt::make-xpoint-array :number (cond ((and closed (not filled))
+						       (incf npoints))
+						      (t npoints))))
 	 (window (medium-drawable medium))
 	 ;; These really are fixnums, since we're fixing coordinates below
 	 (minx most-positive-fixnum)
-	 (miny most-positive-fixnum))
+	 (miny most-positive-fixnum)
+	 ink)
     (do ((ps list-of-x-and-ys (cddr ps))
 	 (i 0 (1+ i))
 	 r)
@@ -498,21 +521,22 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 	(convert-to-device-coordinates transform x y)
 	(minf minx x)
 	(minf miny y)
-	(setf (xpoint-array-x points i) x
-	      (xpoint-array-y points i) y)))
+	(setf (tk::xpoint-array-x points i) x
+	      (tk::xpoint-array-y points i) y)))
     (when (and closed (not filled))
-      (setf (xpoint-array-x points (- npoints 1)) (xpoint-array-x points 0)
-	    (xpoint-array-y points (- npoints 1)) (xpoint-array-y points 0)))
+      (setf (tk::xpoint-array-x points (- npoints 1)) (tk::xpoint-array-x points 0)
+	    (tk::xpoint-array-y points (- npoints 1)) (tk::xpoint-array-y points 0)))
+    (setq ink 
+      (adjust-ink medium (decode-ink (medium-ink medium) medium)
+		  (medium-ink medium)
+		  (medium-line-style medium)
+		  minx miny))
     (when (medium-drawable medium)
       (if filled
 	  (x11:xfillpolygon
 	   (tk::object-display window)
 	   window
-	   (adjust-ink medium
-		       (decode-ink (medium-ink medium) medium)
-		       (medium-ink medium)
-		       (medium-line-style medium)
-		       minx miny)
+	   ink
 	   points
 	   npoints
 	   x11:complex
@@ -520,11 +544,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 	(x11:xdrawlines
 	  (tk::object-display window)
 	  window
-	  (adjust-ink medium
-		      (decode-ink (medium-ink medium) medium)
-		      (medium-ink medium)
-		      (medium-line-style medium)
-		      minx miny)
+	  ink
 	  points
 	  npoints
 	  x11:coordmodeorigin)))))
@@ -644,5 +664,37 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
 	       (height (- from-bottom from-top))
 	       (copy-gc (port-copy-gc port)))
 	  (when (and from-drawable to-drawable)
-	    (tk::copy-area from-drawable copy-gc from-left from-top width height
-			   to-drawable to-left to-top)))))))
+	    (with-port-event-lock (port)
+	      (let ((seq-no 0))
+		(without-interrupts
+		  (setq seq-no (x11:xnextrequest (port-display port)))
+		  (tk::copy-area from-drawable copy-gc from-left from-top
+				 width height to-drawable to-left to-top))
+		(let ((event
+		       (tk::get-event-matching-sequence-and-types
+			to-drawable seq-no
+			'(:graphics-expose :no-expose))))
+		  (case (tk::event-type event)
+		    (:no-expose
+		     nil)
+		    (:graphics-expose
+		     (loop
+		       (let* ((minx (x11::xexposeevent-x event))
+			      (miny (x11::xexposeevent-y event))
+			      (width (x11::xexposeevent-width event))
+			      (height (x11::xexposeevent-height event))
+			      (maxx (+ minx width))
+			      (maxy (+ miny height)))
+			 (dispatch-repaint
+			  to-sheet
+			  (make-instance 'window-repaint-event
+			    :native-region (make-bounding-rectangle minx miny maxx maxy)
+			    :region (untransform-region
+				     (sheet-native-transformation to-sheet)
+				     (make-bounding-rectangle minx miny maxx maxy))
+			    :sheet to-sheet)))
+		       (setq event (tk::get-event-matching-sequence-and-types
+				    to-drawable seq-no '(:graphics-expose) 
+				    :block nil))
+		       (unless event
+			 (return))))))))))))))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 2c516896be56705b9f1d40e2d2c105a9929fbbf7..13d4bb5737f66eaf55a68953f13a7b8f5320133c 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.19 92/04/15 11:49:06 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.20 92/04/21 16:13:39 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -29,8 +29,11 @@
      (display :reader port-display)
      (context :reader port-context)     
      (copy-gc :initform nil)
+     (opacities :initform nil)
      (type :allocation :class 
 	   :initform :xt :reader port-type)
+     (event-lock :initform (clim-sys:make-lock "port event lock")
+		 :reader port-event-lock)
      (menu-cache
       :initform nil
       :accessor port-menu-cache))
@@ -42,8 +45,23 @@
     (or copy-gc
 	(setf copy-gc
 	  (make-instance 'tk::gcontext
-			 :display display
-			 :foreign-address (x11:screen-default-gc (x11:xdefaultscreenofdisplay (port-display port))))))))
+	    :display display
+	    :graphics-exposures :on
+	    :foreign-address (x11:screen-default-gc
+			      (x11:xdefaultscreenofdisplay display)))))))
+
+
+
+(defmethod restart-port ((port xt-port))
+  (let ((process (silica::port-process port)))
+    (when process
+      (clim-sys:destroy-process process)))
+  (setf (silica::port-process port)
+    (mp:process-run-restartable-function
+     (list :name (format nil "CLIM Event Dispatcher for ~A"
+			 (port-server-path port))
+	   :priority 1000)
+     #'silica::port-event-loop port)))
 
 (defmacro destructure-x-server-path ((&key display) path &body body)
   ;;-- Of course the port ends up with an unspecified server-path.
@@ -134,7 +152,8 @@
 				  :name *xt-fallback-font*)))
 	    ;;; Perhaps we should just grab the first font we can find.
 	    (t
-	     (error "Unable to determine default font"))))))
+	     (error "Unable to determine default font")))))
+  (setup-opacities port display))
 
 (defparameter *xt-logical-size-alist*
 	      '((:tiny       6)
@@ -150,7 +169,105 @@
   (standardize-text-style-1
     port style character-set *xt-logical-size-alist*))
 
+(defun make-stipple-image (height width patterns)
+  (make-instance 'tk::image :width width :height height
+		 :data (clim-internals::make-stipple-array height width patterns)
+		 :depth 1))
+
+(defvar *opacity-stipples*
+	(mapcar #'(lambda (entry)
+		    (cons (first entry)
+			  (apply #'make-stipple-image (second entry))))
+		'((+nowhere+ (1 1 (#b0)))
+		  (0.05 (8 06 (#b1000000000000000
+			      #b0000001000000000
+			      #b0000000000001000
+			      #b0010000000000000
+			      #b0000000010000000
+			      #b0000000000000010
+			      #b0000100000000000
+			      #b0000000000100000)))
+		  (0.1 (8 8 (#b10000000
+			     #b00010000
+			     #b00000010
+			     #b01000000
+			     #b00001000
+			     #b00000001
+			     #b00100000
+			     #b00000100)))
+		  (0.2 (4 4 (#b1000
+			     #b0010
+			     #b0100
+			     #b0001)))
+		  (0.3 (3 3 (#b100
+			     #b010
+			     #b001)))
+		  (0.4 (2 2 (#b10
+			     #b01)))
+		  (0.6 (3 3 (#b011
+			     #b101
+			     #b110)))
+		  (0.7 (4 4 (#b0111
+			     #b1101
+			     #b1011
+			     #b1110)))
+		  (0.8 (8 8 (#b01111111
+			     #b11101111
+			     #b11111101
+			     #b10111111
+			     #b11110111
+			     #b11111110
+			     #b11011111
+			     #b11111011)))
+		  (0.9 (8 06 (#b0111111111111111
+			       #b1111110111111111
+			       #b1111111111110111
+			       #b1101111111111111
+			       #b1111111101111111
+			       #b1111111111111101
+			       #b1111011111111111
+			       #b1111111111011111)))
+		  (+everywhere+ (1 1 (#b1))))))
+
+
+(defun setup-opacities (port display)
+  (let ((opacities nil)
+	(root (tk::display-root-window display))
+	gc)
+    (dolist (ls *opacity-stipples*)
+      (let ((pixmap (make-instance 'tk::pixmap
+		      :drawable root
+		      :width (tk::image-width (cdr ls))
+		      :height (tk::image-height (cdr ls))
+		      :depth 1)))
+	(unless gc
+	  (setq gc (make-instance 'tk::gcontext :drawable pixmap
+				  :foreground 1 :background 0)))
+	 (tk::put-image pixmap gc (cdr ls))
+	(push (cons (car ls) pixmap) opacities)))
+    (when gc
+      (tk::free-gcontext gc))
+    (setf (slot-value port 'opacities) (nreverse opacities))))
+
+;;
+;; Takes an opacity, and returns a clip mask (pixmap) for that opacity.
+;;
+(defun decode-opacity (opacity port)
+  (let ((pops (slot-value port 'opacities)))
+    (cond ((eq opacity +nowhere+)
+	   (cdar pops))
+	  ((eq opacity +everywhere+)
+	   (cdar (last pops)))
+	  (t
+	   (let ((lastpop (cdar pops))
+		 (value (opacity-value opacity)))
+	     (dolist (pop (cdr pops) lastpop)
+	       (if (< value (car pop))
+		   (return lastpop))
+	       (setq lastpop (cdr pop))))))))
+
 
+
 (defmethod destroy-mirror ((port xt-port) sheet)
   ;;-- I dont think that we should do this.
   (tk::destroy-widget (sheet-direct-mirror sheet)))
@@ -166,7 +283,7 @@
 	(initialize-mirror port sheet widget)
 	widget))))
 
-(defmethod initialize-mirror (port sheet widget)
+(defmethod initialize-mirror ((port xt-port) sheet widget)
   (add-sheet-callbacks port sheet widget))
 
 (defmethod add-sheet-callbacks ((port xt-port) sheet (widget t))
@@ -178,9 +295,12 @@
     (declare (ignore same-p root child root-x root-y))
     (let ((modifiers (logand #16rff mask))
 	  (button (ash mask -8)))
+      #+ignore
+      (format excl:*initial-terminal-io* "Got event ~s~%" (tk::event-type event))
       (let ((clim-event
 	     (ecase (tk::event-type event)
-	       ((:map-notify :unmap-notify)
+	       ((:map-notify :unmap-notify :selection-clear :selection-request
+		 :selection-notify :client-message :mapping-notify)
 		nil)
 	       (:configure-notify
 		(sheet-mirror-resized-callback
@@ -204,7 +324,6 @@
 				 (state->modifiers
 				  (x11::xkeyevent-state event)
 				  nil))))
-    
 	       (:key-release
 		(multiple-value-bind (character keysym)
 		    (lookup-character-and-keysym sheet widget event)
@@ -216,7 +335,6 @@
 				 (state->modifiers
 				  (x11::xkeyevent-state event)
 				  nil))))
-    
 	       (:button-press
 		(make-instance 'pointer-button-press-event
 			       :sheet sheet
@@ -300,6 +418,9 @@
 	 (height (x11::xexposeevent-height event))
 	 (maxx (+ minx width))
 	 (maxy (+ miny height)))
+    #+ignore
+    (format excl:*initial-terminal-io* "Got expose event ~s~%"
+	    (tk::event-type event))
     (dispatch-repaint
       sheet
       (make-instance 'window-repaint-event
@@ -540,10 +661,23 @@
 		(list  target-left  target-top w h)
 		(list nx ny nw nh)))))))
 
-(defmethod process-next-event (port &key wait-function timeout)
-  (tk::process-one-event (port-context port)
-			 :wait-function wait-function
-			 :timeout timeout))
+(defmacro with-port-event-lock ((port) &body body)
+  `(clim-sys:with-lock-held ((port-event-lock ,port))
+     ,@body))
+
+(defmethod process-next-event ((port xt-port) &key wait-function timeout)
+  (with-slots (context event-lock) port
+    (multiple-value-bind (mask reason)
+	(tk::wait-for-event context
+			    :wait-function wait-function
+			    :timeout timeout)
+      (clim-sys:with-lock-held (event-lock)
+	;; Make sure there is still an event ready, so we don't block in C.
+	(multiple-value-setq (mask reason)
+	  (tk::wait-for-event context
+			      :wait-function wait-function
+			      :timeout timeout))
+	(tk::process-one-event context mask reason)))))
 
 (defmethod port-force-output ((port xt-port))
   ;;--- move to tk
@@ -592,10 +726,6 @@
 (defmethod text-style-descent ((text-style standard-text-style) (port xt-port))
   (tk::font-descent (text-style-mapping port text-style)))
 					
-#+ignore
-(ff::defforeign 'xtsetkeyboardfocus
-    :entry-point "_XtSetKeyboardFocus")
-
 (defmethod stream-set-input-focus (stream)
   nil)
 
@@ -786,9 +916,8 @@
 
 (defun lookup-character-and-keysym (sheet mirror event)
   (declare (ignore sheet mirror))
-  (multiple-value-bind (ignore character keysym)
+  (multiple-value-bind (character keysym)
       (tk::lookup-string event)
-    (declare (ignore ignore))
     (setq character (and (= (length character) 1) (aref character 0)))
     ;;--- Map the asci control-characters into the common lisp
     ;;--- control characters except where they are special!
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index e90d18d0c05b79eed61d6bc881ed7a3271de7a0e..541ca7e00f39fd2836f6ca28b7fd0232c126d878 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.8 92/03/09 17:40:32 cer Exp Locker: cer $
+;; $fiHeader: callbacks.lisp,v 1.9 92/03/30 17:51:25 cer Exp $
 
 (in-package :tk)
 
@@ -57,7 +57,7 @@
   (multiple-value-bind
       (name type)
       (convert-callback-name callback-name)
-    (add_callback
+    (xt_add_callback
      widget
      name
      *callback-handler-address*
@@ -131,20 +131,9 @@
 		(setf (third z) (string-to-char* (second z))))
 	    (fourth z))))
 
-
-(def-c-type (x-push-button-callback-struct :in-foreign-space) :struct
-  (reason :int)
-  (event * x11:xevent)
-  (click-count :int))
-
 (defmethod spread-callback-data (widget data (type (eql :activate)))
   (x-push-button-callback-struct-click-count data))
 
-(def-c-type (x-drawing-area-callback :in-foreign-space) :struct
-  (reason :int)
-  (event * x11:xevent)
-  (window x11:window))
-
 (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area)))
   (values (x-drawing-area-callback-window call-data)
 	  (x-drawing-area-callback-event call-data)))
diff --git a/tk/convenience.lisp b/tk/convenience.lisp
index eb95c716717b2770307a87348dd475580458dc26..426ff780eeaa9e9a7e4a6d42e6e19721bd0f8fa8 100644
--- a/tk/convenience.lisp
+++ b/tk/convenience.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: convenience.lisp,v 1.6 92/03/30 17:51:29 cer Exp Locker: cer $
+;; $fiHeader: convenience.lisp,v 1.7 92/04/21 16:12:18 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -51,7 +51,7 @@
 		  arglist
 		  (truncate (length arglist) 2))))
 	   (when managed
-	     (manage_child o))
+	     (xt_manage_child o))
 	   o)))))
 
 (define-convenience-class xm-menu-bar (xm-row-column) "_XmCreateMenuBar")
diff --git a/tk/event.lisp b/tk/event.lisp
index 759f10f9c145a6654c8201a0971512f126957806..a66e382a88ef634a43e9e5b472a34e5341f45835 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -20,58 +20,102 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.7 92/03/30 17:51:31 cer Exp $
+;; $fiHeader: event.lisp,v 1.8 92/04/15 11:44:40 cer Exp Locker: cer $
 
 (in-package :tk)
 
 (defun simple-event-loop (context)
-  (loop 
-      (process-one-event context)))
+  (loop
+    (multiple-value-bind (mask reason)
+	(wait-for-event context)
+      (process-one-event context mask reason))))
 
 (defconstant *xt-im-xevent*		1)
 (defconstant *xt-im-timer*		2)
 (defconstant *xt-im-alternate-input*	4)
 (defconstant *xt-im-all* (logior *xt-im-xevent*  *xt-im-timer*  *xt-im-alternate-input*))
 
-(defun process-one-event (context &key timeout wait-function)
-  (let (mask
+(defun wait-for-event (context &key timeout wait-function)
+  (let ((mask 0)
 	(fds (mapcar #'(lambda (display)
 			 (x11::display-fd display))
 		     (application-context-displays context)))
-	reason)
+	(reason nil))
+    (declare (fixnum mask))
     
-    (unwind-protect
-	(progn (mapc #'multiprocessing::mpwatchfor fds)
-	       (flet ((wait-function ()
-				     (or (plusp (setq mask (app-pending context)))
-					 (and wait-function
-					      (funcall wait-function)
-					      (setq reason :wait)))))
-		     (if timeout
-			 (multiprocessing:process-wait-with-timeout 
-			  "Waiting for toolkit" 
-			  timeout
-			  #'wait-function)
-		       (mp::process-wait 
-			"Waiting for toolkit" 
-			#'wait-function))))
-      (mapc #'multiprocessing::mpunwatchfor fds))
-    (cond ((plusp mask)
-	   (app-process-event 
-	    context 
-	    ;; Because of a feature in the OLIT toolkit we need to
-	    ;; give preference to events rather than timer events
-	    (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask))
-	   t)
-	  (reason :wait-function)
-	  (t :timeout))))
-
-
-(defun app-pending (context)
-  (app_pending context))
-
-(defun app-process-event (context mask)
-  (app_process_event context mask))
+    (flet ((wait-function (fd)
+	     (declare (ignore fd))
+	     (or (plusp (setq mask (xt_app_pending context)))
+		 (and wait-function
+		      (funcall wait-function)
+		      (setq reason :wait)))))
+      (mp:wait-for-input-available fds :wait-function #'wait-function
+				   :timeout timeout))
+    (values mask reason)))
+
+(defun process-one-event (context mask reason)
+  (cond ((plusp mask)
+	 (xt_app_process_event
+	  context
+	  ;; Because of a feature in the OLIT toolkit we need to
+	  ;; give preference to events rather than timer events
+	  (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask))
+	 t)
+	(reason :wait-function)
+	(t :timeout)))
+
+(defun-c-callable match-event-sequence-and-types ((display :unsigned-long)
+						  (event :unsigned-long)
+						  (arg :unsigned-long))
+  ;; Arg points to a n element (unsigned-byte 32) vector, where the first
+  ;; element is the display, the second is the sequence number, and
+  ;; the other elements are the event types to be matched (null terminated).
+  (let ((desired-display (sys:memref-int arg 0 0 :unsigned-long))
+	(desired-sequence (sys:memref-int arg 4 0 :unsigned-long))
+	(event-type (x11:xevent-type event)))
+    (if (and (eql desired-display display)
+	     (eql desired-sequence (x11:xanyevent-serial event))
+	     (do* ((i 8 (+ i 4))
+		   (desired-type (sys:memref-int arg i 0 :unsigned-long)
+				 (sys:memref-int arg i 0 :unsigned-long)))
+		 ((zerop desired-type) nil)
+	       (if (eql desired-type event-type)
+		   (return t))))
+	1
+      0)))
+
+
+(defparameter *match-event-sequence-and-types-address*
+    (register-function 'match-event-sequence-and-types))
+
+(defun get-event-matching-sequence-and-types (display-object seq-no types
+					      &key (block t))
+  (unless (consp types)
+    (setq types (list types)))
+  (let ((display (object-display display-object))
+	(data (make-array (+ 3 (length types))
+			  :element-type '(unsigned-byte 32)))
+	(i 2)
+	(resulting-event (x11:make-xevent)))
+    (declare (type (simple-array (unsigned-byte 32) (*)) data)
+	     (fixnum i)) 
+    (setf (aref data 0) (ff:foreign-pointer-address display))
+    (setf (aref data 1) seq-no)
+    (dolist (type types)
+      (setf (aref data i) (position type tk::*event-types*))
+      (incf i))
+    (setf (aref data i) 0)
+    (cond (block
+	   (x11:xifevent display resulting-event
+			 *match-event-sequence-and-types-address* data)
+	   resulting-event)
+	  ((zerop (x11:xcheckifevent display resulting-event
+				     *match-event-sequence-and-types-address*
+				     data))
+	   nil)
+	  (t
+	   resulting-event))))
+
 
 (defvar *event* nil)
 
@@ -93,7 +137,7 @@
 (defvar *event-handler-address* (register-function 'event-handler))
 
 (defun add-event-handler (widget events maskable function &rest args)
-  (add_event_handler
+  (xt_add_event_handler
    widget
    (encode-event-mask events)
    maskable
diff --git a/tk/font.lisp b/tk/font.lisp
index e936c9cc93ced2c4498b7070d995d92492e43a90..dbf4ac054fd5b3dc21ba3836367650d47872af9b 100644
--- a/tk/font.lisp
+++ b/tk/font.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: font.lisp,v 1.8 92/03/30 17:51:32 cer Exp $
+;; $fiHeader: font.lisp,v 1.9 92/04/15 11:44:42 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -47,8 +47,6 @@
 		    :display display
 		    :foreign-address h)))
 
-(def-c-type (xcharstruct-vector :in-foreign-space) 1 x11:xcharstruct)
-
 (defmethod font-width (font)
   (x11::xfontstruct-max-bounds-width font))
  
@@ -79,8 +77,6 @@
 	 (x11:xfontstruct-per-char font)
 	 (- index min)))))
 
-(def-c-type (xfontname-list :in-foreign-space) 1 * :char)
-
 (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
   (with-ref-par ((n 0))
     (let* ((names (x11:xlistfonts display
@@ -94,8 +90,6 @@
 	    (setf (elt seq i) (char*-to-string (xfontname-list names i))))
 	(x11::xfreefontnames names)))))
 
-(def-c-type (xfontstruct-array :in-foreign-space) 1 x11::xfontstruct)
-
 (defun list-font-names-with-info (display pattern &key (max-fonts 65535) (result-type 'list))
   (with-ref-par ((n 0)
 		 (fonts 0))
diff --git a/tk/foreign.lisp b/tk/foreign.lisp
index d5ffe848cfe445c9978beb696978b2531a0721bf..3eb05c3482bc629387f2badb0bfb4c667fa52365 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.8 92/04/03 12:03:57 cer Exp Locker: cer $
+;; $fiHeader: foreign.lisp,v 1.9 92/04/15 11:44:43 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -40,12 +40,12 @@
   (register-function 'toolkit-warning-handler))
 
 (defmethod initialize-instance :after ((c application-context) &key context)
-  (let ((context (or context (create_application_context))))
+  (let ((context (or context (xt_create_application_context))))
     (setf (foreign-pointer-address c) context)
-    (app_set_error_handler 
+    (xt_app_set_error_handler 
      context
      *error-handler-function-address*)
-    (app_set_warning_handler
+    (xt_app_set_warning_handler
      context
      *warning-handler-function-address*)))
 
@@ -61,7 +61,7 @@
 			  (argc 0)
 			  (argv 0))
   (let ((d (with-ref-par ((argc argc))
-	     (open_display context
+	     (xt_open_display context
 			   (if host 
 			       host
 			     0)
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index bd2854ae3f663a98d94ff4e016c7813d0bd36b20..cea65e4c22d2683f1daac2a36c1adad05b0ba3db 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,66 +20,104 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.10 92/04/15 11:44:44 cer Exp Locker: cer $
+;; $fiHeader: gcontext.lisp,v 1.11 92/04/21 16:12:21 cer Exp Locker: cer $
 
 (in-package :tk)
 
 (eval-when (compile load eval)
-	   (defconstant *gcontext-components* 
-	     '((function :int)
-	       (plane-mask :unsigned-long)
-	       (foreground :unsigned-long)
-	       (background :unsigned-long)
-	       (line-width :int)
-	       (line-style :int)
-	       (cap-style :int)
-	       (join-style :int)
-	       (fill-style :int)
-	       (fill-rule :int)
-	       (arc-mode :int)
-	       (tile :pixmap)
-	       (stipple :pixmap)
-	       (ts-x-origin :int)
-	       (ts-y-origin :int)
-	       (font x-font)
-	       (subwindow-mode :int)
-	       (exposures :boolean)
-	       (clip-x-origin :int)
-	       (clip-y-origin :int)
-	       (clip-mask :pixmap)
-	       (dash-offset :int)
-	       (dashes :char)))
-
-	   (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-origin ts-y-origin font subwindow-mode
-			exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes
-			arc-mode)))
-
-
-(eval-when (compile load eval)
-	   (defun gcontext-component-to-slot-definition (x)
-	     (destructuring-bind
-	      (name c-type) x
-	      `(,name :reader ,(intern (format nil "~A-~A" 'gcontext name)))))
+  #+ignore
+  (defconstant *gcontext-components* 
+      '((function :int)
+	(plane-mask :unsigned-long)
+	(foreground :unsigned-long)
+	(background :unsigned-long)
+	(line-width :int)
+	(line-style :int)
+	(cap-style :int)
+	(join-style :int)
+	(fill-style :int)
+	(fill-rule :int)
+	(arc-mode :int)
+	(tile :pixmap)
+	(stipple :pixmap)
+	(ts-x-origin :int)
+	(ts-y-origin :int)
+	(font x-font)
+	(subwindow-mode :int)
+	(graphics-exposures :boolean)
+	(clip-x-origin :int)
+	(clip-y-origin :int)
+	(clip-mask :pixmap)
+	(dash-offset :int)
+	(dashes :char)))
+
+
+  (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-origin ts-y-origin font subwindow-mode
+	graphics-exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes
+	arc-mode)))
+
+
+(eval-when (compile eval)
+  #+ignore
+  (defun gcontext-component-to-slot-definition (x)
+    (destructuring-bind
+	(name c-type) x
+      (declare (ignore c-type))
+      `(,name :reader ,(intern (format nil "~A-~A" 'gcontext name)))))
   
-	   (defun gcontext-component-to-writer  (x)
-	     (destructuring-bind
-	      (name c-type) x
-	      `(defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) 
-		 (nv gc)
-		 (set-gcontext-component 
-		  gc 
-		  ,(intern (symbol-name name) :keyword)
-		  nv)
-		 (setf (slot-value gc ',name) nv)))))
+  #+ignore
+  (defun gcontext-component-to-writer  (x)
+    (destructuring-bind
+	(name c-type) x
+      (declare (ignore c-type))
+      `(defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name))) 
+	   (nv gc)
+	 (set-gcontext-component 
+	  gc 
+	  ,(intern (symbol-name name) :keyword)
+	  nv)
+	 (setf (slot-value gc ',name) nv))))
+  
+  (defmacro define-gc-writer (name encoder &rest args)
+    `(progn
+       (defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name)))
+	   (nv (gc gcontext))
+	 (let ((gc-values (x11::make-xgcvalues)))
+	   (setf (,(intern (format nil "~A~A"
+				   'xgcvalues-
+				   name)
+			   :x11)
+		  gc-values)
+	     (,encoder nv ,@args))
+	 
+	   (x11:xchangegc
+	    (object-display gc)
+	    gc
+	    ,(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 gcontext))
+       (,decoder 
+	(,(intern (format nil "~A~A" '_xgc-values- name) :x11)
+	 gc)
+	,@args)))
+  
+  (defmacro define-gc-accessor (name (encoder decoder) &rest args)
+    `(progn
+       (define-gc-reader ,name ,decoder ,@args)
+       (define-gc-writer ,name ,encoder ,@args)
+       ',name)))
 
 
 (defclass gcontext (display-object)
   ())
 
-
 (defmethod initialize-instance :after ((gcontext gcontext)
 				       &key
 				       foreign-address
@@ -89,14 +127,17 @@
 				       cap-style join-style fill-style fill-rule 
 				       arc-mode tile stipple ts-x ts-y
 				       font subwindow-mode 
-				       exposures clip-x-origin clip-y-origin
+				       graphics-exposures clip-x-origin clip-y-origin
 				       clip-mask clip-ordering 
 				       dash-offset dashes)
 
   (unless foreign-address
-    (setf foreign-address (x11::xcreategc display drawable 0 0)
-	  (foreign-pointer-address gcontext) foreign-address
-	  (slot-value gcontext 'display) (object-display drawable))
+    (unless drawable
+      (error ":drawable must be specified when creating gcontext"))
+    (let ((display (object-display drawable)))
+      (setf foreign-address (x11::xcreategc display drawable 0 0)
+	    (foreign-pointer-address gcontext) foreign-address
+	    (slot-value gcontext 'display) display))
     (register-address gcontext foreign-address))
     
     ;;; Set the ones that are specified
@@ -118,7 +159,7 @@
   (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
   (when font (setf (gcontext-font gcontext) font))
   (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
-  (when exposures (setf (gcontext-exposures gcontext) exposures))
+  (when graphics-exposures (setf (gcontext-graphics-exposures gcontext) graphics-exposures))
   (when clip-x-origin (setf (gcontext-clip-x-origin gcontext) clip-x-origin))
   (when clip-y-origin (setf (gcontext-clip-y-origin gcontext) clip-y-origin))
   (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
@@ -127,7 +168,6 @@
   gcontext)
 
 
-
 (defun free-gcontext (gc)
   (x11:xfreegc 
    (object-display gc)
@@ -137,38 +177,7 @@
 (defun lispify-function-name (name)
   (intern (substitute #\_ #\- (symbol-name (lispify-tk-name name)))))
 
-(defmacro define-gc-writer (name encoder &rest args)
-  `(progn
-     (defmethod (setf ,(intern (format nil "~A-~A" 'gcontext name)))
-	 (nv (gc gcontext))
-       (let ((gc-values (x11::make-xgcvalues)))
-	 (setf (,(intern (format nil "~A~A"
-				 'xgcvalues-
-				 name)
-			 :x11)
-		gc-values)
-	       (,encoder nv ,@args))
-	 
-	 (x11:xchangegc
-	  (object-display gc)
-	  gc
-	  ,(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 gcontext))
-    (,decoder 
-     (,(intern (format nil "~A~A" '_xgc-values- name) :x11)
-      gc)
-     ,@args)))
-
-(defmacro define-gc-accessor (name (encoder decoder) &rest args)
-  `(progn
-     (define-gc-reader ,name ,decoder ,@args)
-     (define-gc-writer ,name ,encoder ,@args)
-     ',name))
+
 
 ;;; Accessors for the gc
 
@@ -243,7 +252,8 @@
 
 (define-gc-accessor subwindow-mode (encode-enum decode-enum)
 		  '(:clip-by-children :include-inferiors))
-(define-gc-accessor exposures (encode-enum decode-enum) '(:off :on))
+
+(define-gc-accessor graphics-exposures (encode-enum decode-enum) '(:off :on))
 (define-gc-accessor clip-x-origin (encode-int16 decode-int16))
 (define-gc-accessor clip-y-origin (encode-int16 decode-int16))
 
@@ -322,33 +332,33 @@
       (error "~S is not a valid line-style" x)))
 
 (defmethod (setf gcontext-dashes) (nv (gc gcontext))
-  (multiple-value-bind
-      (n v)
+  (multiple-value-bind (n v)
       (encode-dashes nv)
     (x11:xsetdashes
      (object-display gc)
      gc
      0
      v
-     n)
-    (excl::free v)))
+     n)))
 
 
 (defun encode-dashes (nv)
-  (let (n v)
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((n (length nv))
+	 (v (make-array n :element-type '(unsigned-byte 8))))
+    (declare (fixnum n)
+	     (type (simple-array (unsigned-byte 8) (*)) v))
     (etypecase nv
-      (list 
-       (setq n (length nv))
-       (setq v (excl::malloc n))
+      (list
        (let ((i 0))
+	 (declare (fixnum i))
 	 (dolist (x nv)
-	   (setf (sys::memref-int v i 0 :unsigned-byte) x)
+	   (declare (type (unsigned-byte 8) x))
+	   (setf (aref v i) x)
 	   (incf i))))
       (vector
-       (setq n (length nv))
-       (setq v (excl::malloc n))
        (dotimes (i n)
-	 (setf (sys::memref-int v i 0 :unsigned-byte) (aref nv i)))))
+	 (setf (aref v i) (the (unsigned-byte 8) (aref nv i))))))
     (values n v)))
   
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -366,11 +376,12 @@
 (defun decode-card16 (x) x)
 
 (defun decode-font (x) 
+  (declare (special gc))
   (if (= x #16rffffffff)
       (error "cannot decode font")
     (let ((font (find-object-from-xid x nil)))
       (or font
-	  (query-font display x)))))
+	  (query-font (object-display gc) x)))))
 
 (defun decode-pixmap (x) 
   (and (/= #16rffffffff x)
@@ -411,18 +422,14 @@
 					      *gcontext-bit-mask*
 					      :test #'string=))
 			       r)))))
-    `(let ((,tgc (allocate-temp-gc gc)))
-       (x11:xcopygc (object-display gc)
-		  gc
-		  ,bits
-		  ,tgc)
+    `(let* ((,tgc (allocate-temp-gc gc))
+	    (.gc. ,gc)
+	    (.display. (object-display .gc.)))
+       (x11:xcopygc .display. .gc. ,bits ,tgc)
        (unwind-protect
 	   (progn ,@(nreverse setfs)
 		  ,@body)
-	 (x11:xcopygc (object-display gc)
-		    ,tgc
-		    ,bits
-		    gc)
+	 (x11:xcopygc .display. ,tgc ,bits .gc.)
 	 (deallocate-temp-gc ,tgc)))))
 
 (defun allocate-temp-gc (gc)
@@ -430,6 +437,8 @@
 		 :drawable (display-root-window (object-display gc))))
 
 (defun deallocate-temp-gc (gc)
+  (x11:xfreegc (object-display gc) gc)
+  (setf (ff:foreign-pointer-address gc) 0)
   nil)
 
 #|
@@ -437,13 +446,11 @@
 	       (print gc))
 |#
 
+(defun decode-pixel (x) x)
+
 (defmethod encode-pixel ((x integer))
   x)
 
-(defun decode-pixel (x) x)
 (defmethod encode-pixel ((x color))
-  (allocate-color (default-colormap display 0) x))
-
-
-    
-   
+  (declare (special gc))
+  (allocate-color (default-colormap (object-display gc) 0) x))
diff --git a/tk/init.lisp b/tk/init.lisp
index 401118689c0b588fbb8373a032be91017ea4ed28..d3ece19a63a7f5600ee83f8f09280467c6a48a7e 100644
--- a/tk/init.lisp
+++ b/tk/init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: init.lisp,v 1.3 92/01/31 14:54:45 cer Exp $
+;; $fiHeader: init.lisp,v 1.4 92/02/24 13:03:05 cer Exp $
 
 
 (in-package :tk)
@@ -28,6 +28,6 @@
 (defvar *done* nil)
 (unless *done*
   (insert_classes)
-  (toolkit-initialize)
+  (xt_toolkit_initialize)
   (make-classes)
   (setq *done* t))
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index dee05f8f875e53713c9791c93aad9b91bd3689fb..e01f193a5aa0d7ee1d473db3c23fd578be306ac4 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,22 +20,16 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.13 92/04/15 11:44:47 cer Exp Locker: cer $
+;; $fiHeader: make-classes.lisp,v 1.14 92/04/21 16:12:22 cer Exp Locker: cer $
 
 (in-package :tk)
 
-#+obsolete
-(ff:defforeign 'insert_classes :return-type :fixnum)
-
-
 (defun get-entry-point-value (x)  
   (let ((xx (make-array 1 :element-type '(unsigned-byte 32))))
     (unless (zerop (get-entry-points (vector x) xx))
       (error "Cannot find the entry-point for: ~S" x))
     (aref xx 0)))
 
-(def-c-type (class-array :in-foreign-space) 1 :unsigned-long)
-
 (defun get-foreign-variable-value (x)
   (class-array (get-entry-point-value x) 0))
 
@@ -60,10 +54,10 @@
       r)))
       
 (defun get-resource-list (class) 
-  (get-resource-list-internal class #'get-resource-list-1 'resource))
+  (get-resource-list-internal class #'xt_get_resource_list 'resource))
 
 (defun get-constraint-resource-list (class) 
-  (get-resource-list-internal class #'get-constraint-resource-list-1
+  (get-resource-list-internal class #'xt_get_constraint_resource_list
 			      'constraint-resource))
 
 
@@ -134,7 +128,7 @@
     (dolist (class-ep classes)
       (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep)
       (let ((h (get-foreign-variable-value class-ep)))
-	(initialize-widget-class h)
+	(xt_initialize_widget_class h)
 	(push (list h
 		    (get-resource-list h)
 		    (get-constraint-resource-list h))
@@ -154,10 +148,10 @@
 	(let ((class
 	       (clos::ensure-class
 		(lispify-class-name (widget-class-name handle))
-		:direct-superclasses (list (if (zerop (xtk-class-superclass handle))
+		:direct-superclasses (list (if (zerop (xt-class-superclass handle))
 					       'xt-root-class
 					     (lispify-class-name (widget-class-name
-								  (xtk-class-superclass handle)))))
+								  (xt-class-superclass handle)))))
 		:direct-slots nil
 		:metaclass 'xt-class
 		:direct-resources  direct-resources
@@ -204,7 +198,7 @@
 
 	
 (defun widget-class-name (h)
-  (char*-to-string (xtk-class-name h)))
+  (char*-to-string (xt-class-name h)))
 
 (defun lispify-class-name (x) 
   (let ((name (lispify-tk-name x)))
diff --git a/tk/ol-callbacks.lisp b/tk/ol-callbacks.lisp
index 2d0d904c9107fac30f1c72de563099c6b83a7238..05e867dc2ab83c57880012c47e4ce9504c783e89 100644
--- a/tk/ol-callbacks.lisp
+++ b/tk/ol-callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-callbacks.lisp,v 1.4 92/02/24 13:03:34 cer Exp Locker: cer $
+;; $fiHeader: ol-callbacks.lisp,v 1.5 92/03/09 17:40:50 cer Exp $
 
 (in-package :tk)
 
@@ -39,21 +39,6 @@
 				(:dnd_animate           7)
 				))
 
-(def-c-type (ol-callback-struct :in-foreign-space) :struct
-	    (reason :int))
-
-(def-c-type (ol-expose-callback-struct :in-foreign-space) :struct
-	    (reason :int)
-	    (event * x11:xevent))
-
-
-(def-c-type (ol-resize-callback-struct :in-foreign-space) :struct
-	    (reason :int)
-	    (x xt-position)
-	    (y xt-position)
-	    (width xt-dimension)
-	    (height xt-dimension))
-
 (defun find-ol-callback-reason (call-data)
   (or (car (find (tk::ol-callback-struct-reason call-data)
 		 *ol-callback-reasons*
diff --git a/tk/ol-defs.lisp b/tk/ol-defs.lisp
index 9155388866275e536456644cdb5adafb8c763aba..edbd52472fe25383d6cf13bf7bf0fa1f0c83681a 100644
--- a/tk/ol-defs.lisp
+++ b/tk/ol-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-init.lisp,v 1.8 92/03/24 19:36:17 cer Exp $
+;; $fiHeader: ol-defs.lisp,v 1.1 92/04/21 16:40:05 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
diff --git a/tk/ol-funs.lisp b/tk/ol-funs.lisp
index b9844b2464fad7299f4ed26ab0e644adce204ef6..038ae3dd45fb14241679f970dc2341d5b51e3778 100644
--- a/tk/ol-funs.lisp
+++ b/tk/ol-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-init.lisp,v 1.8 92/03/24 19:36:17 cer Exp $
+;; $fiHeader: ol-funs.lisp,v 1.1 92/04/21 16:40:06 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp
index 5f2b2ccf33450c10f39c6b64aad1698c946896f3..2c0107a086d9ce0c80be035699e5d8691399077c 100644
--- a/tk/ol-init.lisp
+++ b/tk/ol-init.lisp
@@ -20,13 +20,11 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-init.lisp,v 1.9 92/04/03 12:04:05 cer Exp Locker: cer $
+;; $fiHeader: ol-init.lisp,v 1.10 92/04/10 14:26:16 cer Exp Locker: cer $
 
 
 (in-package :tk)
 
-(defforeign 'ol_toolkit_initialize :entry-point "_OlToolkitInitialize")
-
 (defun ol-initialize ()
   (ol_toolkit_initialize))
 
@@ -49,18 +47,6 @@
 	(char*-to-string message)))
 
 
-(defforeign 'ol_set_warning_handler 
-    :entry-point "_OlSetWarningHandler")
-
-(defforeign 'ol_set_error_handler 
-  :entry-point "_OlSetErrorHandler")
-
-(defforeign 'ol_set_va_display_error_msg_handler
-    :entry-point "_OlSetVaDisplayErrorMsgHandler")
-
-(defforeign 'ol_set_va_display_warning_msg_handler
-    :entry-point "_OlSetVaDisplayWarningMsgHandler")
-
 (ol_set_warning_handler (register-function 'ol-warning-handler))
 (ol_set_va_display_warning_msg_handler (register-function 'ol-warning-va-handler))
 (ol_set_error_handler (register-function 'ol-error-handler))
diff --git a/tk/pkg.lisp b/tk/pkg.lisp
index 8d1fd7aa468afde347554d5693b77406968d367e..208d6fb5251027e1ea93f0a69e655fdc4d98c99b 100644
--- a/tk/pkg.lisp
+++ b/tk/pkg.lisp
@@ -20,13 +20,14 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.6 92/03/09 17:40:55 cer Exp Locker: cer $
+;; $fiHeader: pkg.lisp,v 1.7 92/03/30 17:51:47 cer Exp $
 
 (defpackage :tk
   ;;-- No we really need
   ;; to use the x11 package?
   (:use :common-lisp :ff #+ignore :x11)
   (:nicknames :xt)
+  (:import-from :excl #:if*)
   (:export
    #:initialize-motif-toolkit
    #:xm-drawing-area
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 0c78151206b21010c0e45b3847d7991ba0dd1c26..f678d423965191db09e6899021cfef31ce05efc5 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.15 92/04/15 11:44:49 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.16 92/04/21 16:12:23 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -30,13 +30,15 @@
        (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))
        (elt ',elements value))))
 
 
+
 (defun set-values (widget &rest values)
   (let ((arglist (make-arglist-for-class (class-of widget) widget values)))
-    (set_values widget
+    (xt_set_values widget
 		arglist
 		(truncate (length arglist) 2))))
 
@@ -75,15 +77,13 @@
       (ff:foreign-pointer-address result))))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
-  (string_create_l_to_r (string-to-char* value) (string-to-char* "")))
+  (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)))
 
-(def-c-type (x-arglist :in-foreign-space) 1 :unsigned-long)
-
 (defun get-values (widget &rest resources)
   (let* ((class (class-of widget))
 	 (class-resources (class-resources class))
@@ -107,8 +107,7 @@
     ;;-- This also ought to be resource allocated
     
     (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32))))
-    
-    (get_values widget
+    (xt_get_values widget
 		arglist
 		(truncate (length arglist) 2))
     
@@ -136,7 +135,7 @@
 (defmethod convert-resource-in (class (type (eql 'xm-string)) value)
   (and (not (zerop value))
        (with-ref-par ((string 0))
-	 (string_get_l_to_r value xm_string_default_char_set string)
+	 (xm_string_get_l_to_r value xm_string_default_char_set string)
 	 (char*-to-string (sys:memref-int (foreign-pointer-address string) 0 0
 					  :signed-long)))))
 
@@ -223,7 +222,8 @@
 	    (screen (x11:xdefaultscreenofdisplay display))
 	    (white (x11::xwhitepixel display 0))
 	    (black (x11::xblackpixel display 0)))
-       (get_pixmap screen (string-to-char* value) black white)))))
+       (xm_get_pixmap screen (string-to-char* value) white black)))))
+
 
 (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value)
   (if value 1 0))
@@ -320,13 +320,11 @@
 
 
 
-(def-c-type (xtk-widget-list :in-foreign-space) 1 * xtk-widget)
-
 (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 (xtk-widget-list x i))
+	     widget 'widget (xt-widget-list x i))
 	    r))
     (nreverse r)))
 
@@ -341,15 +339,16 @@
 
 
 (defun setup (&optional (hostspec "localhost:0"))
-  (setq context (create-application-context))
-  (setq display (make-instance 'display 
-			       :host hostspec
-			       :context context))
-  (setq app (app-create-shell :display display :widget-class 'application-shell)))
+  (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)
-  (values context display app))
+  (setup hostspec))
 
 
 ;;; ol resource
diff --git a/tk/widget.lisp b/tk/widget.lisp
index 65ec6171a1072b2e13c35eb2e9c5f72fe2d57d17..ae12733e7bbe4c3a8a6517ccb3a2b1900893ed22 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.16 92/04/15 11:44:53 cer Exp Locker: cer $
+;; $fiHeader: widget.lisp,v 1.17 92/04/21 16:12:25 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -37,23 +37,23 @@
      (apply #'make-instance
 	    class
 	    :foreign-address
-	    (app_create_shell application-name
-			      application-class
-			      handle
-			      display
-			      arglist
-			      (truncate (length arglist) 2))
+	    (xt_app_create_shell application-name
+				 application-class
+				 handle
+				 display
+				 arglist
+				 (truncate (length arglist) 2))
 	    :display display
 	    args))))
 
 (defun create-widget (name widget-class parent &rest args)
   (apply #'create-widget-1 
-	 #'create_widget name widget-class parent 
+	 #'xt_create_widget name widget-class parent 
 	 args))
 
 (defun create-managed-widget (name widget-class parent &rest args)
   (apply #'create-widget-1 
-	 #'create_managed_widget name widget-class parent 
+	 #'xt_create_managed_widget name widget-class parent 
 	 args))
 
 
@@ -68,10 +68,10 @@
 	     (truncate (length arglist) 2))))
 
 (defun realize-widget (widget)
-  (realize_widget widget))
+  (xt_realize_widget widget))
 
 (defun manage-child (child)
-  (manage_child child))
+  (xt_manage_child child))
 
 (defun unmanage-child (child)
   (unmanage_child child))
@@ -79,26 +79,32 @@
 (defun is-managed-p (widget)
     (not (zerop (xt_is_managed widget))))
 
+
+(defun unmanage-child (child)
+  (xt_unmanage_child child))
+
 (defun manage-children (children)
-  (manage_children (map '(simple-array (signed-byte 32))
+  (xt_manage_children (map '(simple-array (signed-byte 32))
 		     #'ff:foreign-pointer-address 
 		     children)
 		   (length children)))
 		     
 (defun destroy-widget (widget)
-  (destroy_widget widget))
+  (xt_destroy_widget widget))
 
 (defun popup (shell)
-       (_popup shell 0))
+       (xt_popup shell
+	       0))
+
 
 (defun popdown (shell)
-       (_popdown shell))
+       (xt_popdown shell))
 
 (defun create-popup-shell (name widget-class parent &rest args)
   (let* ((class (find-class-maybe widget-class))
 	 (handle (class-handle class))
 	 (arglist (make-arglist-for-class class parent args)))
-    (create_popup_shell
+    (xt_create_popup_shell
 	     (string-to-char* name)
 	     handle
 	     parent
@@ -129,7 +135,7 @@
 
 (defun widget-class-of (x)
   (intern-widget-class
-   (xtk-widget-widget-class x)))
+   (xt-widget-widget-class x)))
 
 (defun intern-widget-class (class)
   (find-object-from-address class))
@@ -184,19 +190,6 @@
   (let ((x (xt_parent widget)))
     (and (not (zerop x)) (intern-widget x))))
 
-(def-c-type xt-geometry-mask :unsigned-int)
-(def-c-type xt-position :short)
-(def-c-type xt-dimension :unsigned-short)
-
-(def-c-type (xt-widget-geometry :in-foreign-space) :struct
-  (request-mode xt-geometry-mask)
-  (x xt-position)
-  (y xt-position)
-  (width xt-dimension)
-  (height xt-dimension)
-  (border-width xt-dimension)
-  (sibling xtk-widget)
-  (stack-mode :int))
 
 (defconstant xt-geometry-yes 0)
 (defconstant xt-geometry-no 1)
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 1421cfa52613d2bbaa7f80c597a2481b0994281b..7ae9eb6c5795a519fb79733289d04db5c25a5191 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.14 92/04/15 11:44:54 cer Exp Locker: cer $
+;; $fiHeader: xlib.lisp,v 1.15 92/04/21 16:12:27 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -155,7 +155,7 @@
 
 (defmethod initialize-instance :after ((x color) &key foreign-address red green blue)
   (unless foreign-address
-    (setq foreign-address (x11::make-xcolor))
+    (setq foreign-address (x11::make-xcolor :in-foreign-space t))
     (setf (x11::xcolor-red foreign-address) red
 	  (x11:xcolor-green foreign-address) green
 	  (x11:xcolor-blue foreign-address) blue
@@ -172,8 +172,8 @@
 	     (x11:xcolor-blue cm)))))
 
 (defun lookup-color (colormap color-name)
-  (let ((exact (x11::make-xcolor))
-	(closest (x11::make-xcolor)))
+  (let ((exact (x11::make-xcolor :in-foreign-space t))
+	(closest (x11::make-xcolor :in-foreign-space t)))
     (if (zerop (x11:xlookupcolor
 		(object-display colormap)
 		colormap
@@ -185,7 +185,8 @@
 	      (make-instance 'color :foreign-address closest)))))
 
 (defun allocate-color (colormap x)
-  (let ((y (x11::make-xcolor)))
+  (let ((y (x11::make-xcolor :in-foreign-space t))
+	(x x))
     (setf (x11:xcolor-red y) (x11:xcolor-red x)
 	  (x11:xcolor-green y) (x11:xcolor-green x)
 	  (x11:xcolor-blue y) (x11:xcolor-blue x))
@@ -344,25 +345,25 @@
 	     (error "cannot encode event-mask ~S" mask))))))
 
 
-(warn "remove me")
+(defvar *lookup-string-buffers* nil)
 
 (defun lookup-string (event)
-  (let ((buffer (string-to-char* (load-time-value (make-string 4 :initial-element #\null)))))
-    ;;-- Before anyone goes changing this again they need to remember
-    ;;-- that buffer needs to be zeroed before hand
-    (with-ref-par 
-	((keysym 0))
-      (values
-       (x11:xlookupstring
-	event
-	buffer
-	2
-	keysym
-	0)
-       (prog1
-	   (char*-to-string buffer)
-	 (excl::free buffer))
-       (aref keysym 0)))))
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((buffer (or (pop *lookup-string-buffers*)
+		    (excl::malloc 256))))
+    (declare (type (unsigned-byte 32) buffer))
+    (with-ref-par ((keysym 0))
+      (let* ((nchars (x11:xlookupstring event buffer 256 keysym 0))
+	     (result (make-string nchars)))
+	(declare (fixnum nchars)
+		 (simple-string result))
+	(dotimes (i nchars)
+	  (declare (fixnum i))
+	  (setf (schar result i)
+	    (code-char (sys:memref-int buffer 0 i :unsigned-byte))))
+	(push buffer *lookup-string-buffers*)
+	(values result
+		(aref keysym 0))))))
 
 (defclass image (ff:foreign-pointer)
   ((width :reader image-width :initarg :width)
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index 85214ff85b994869c61b3f4b01697e52a6bf2420..73bdfb6d9b3247c35aa52a6287d317b2d40b325d 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-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp $
+;; $fiHeader: xm-defs.lisp,v 1.1 92/04/21 16:40:04 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp
index 6624f05219a8696f293a127fb24880859cee314b..756646180da32acec1b79f4c2e9d22b2a3dbea3c 100644
--- a/tk/xm-font-list.lisp
+++ b/tk/xm-font-list.lisp
@@ -20,25 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-font-list.lisp,v 1.5 92/03/09 17:41:05 cer Exp $
+;; $fiHeader: xm-font-list.lisp,v 1.6 92/03/30 17:51:55 cer Exp $
 
 (in-package :tk)
 
-(defforeign 'xm_font_list_init_font_context
-    :entry-point "_XmFontListInitFontContext")
-
-(defforeign 'xm_font_list_free_font_context
-    :entry-point "_XmFontListFreeFontContext")
-
-
-(defforeign 'xm_font_list_get_next_font
-    :entry-point "_XmFontListGetNextFont")
-
-(defforeign 'xm_font_list_create
-    :entry-point "_XmFontListCreate")
-
-
-
 (defmethod convert-resource-out (parent (type (eql 'font-list)) value)
   (declare (ignore parent))
   (when (atom value)
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index 3aaf2ac711c02e2986dc062229dc3eea173e0dba..2d5ea2fbc093932dcd153980a768de84eadcddf6 100644
--- a/tk/xm-funs.lisp
+++ b/tk/xm-funs.lisp
@@ -20,20 +20,49 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp Locker: cer $
+;; $fiHeader: xm-funs.lisp,v 1.2 92/04/21 16:12:29 cer Exp Locker: cer $
+
+;;
+;; This file contains compile time only code -- put in clim-debug.fasl.
+;;
 
 (in-package :tk)
 
-(defforeign 'string_create_l_to_r
+(defforeign 'xm_string_create_l_to_r
     :entry-point "_XmStringCreateLtoR"
     :return-type :integer)
 
-(defforeign 'string_get_l_to_r
+(defforeign 'xm_string_get_l_to_r
     :entry-point "_XmStringGetLtoR"
     :return-type :integer)
 
-(defforeign 'get_pixmap
+(defforeign 'xm_get_pixmap
     :entry-point "_XmGetPixmap")
 
+(defforeign 'xm_font_list_init_font_context
+    :entry-point "_XmFontListInitFontContext")
+
+(defforeign 'xm_font_list_free_font_context
+    :entry-point "_XmFontListFreeFontContext")
+
+(defforeign 'xm_font_list_get_next_font
+    :entry-point "_XmFontListGetNextFont")
+
+(defforeign 'xm_font_list_create
+    :entry-point "_XmFontListCreate")
+
+(defforeign 'xm_add_protocol_callback
+    :entry-point "_XmAddProtocolCallback")
+
+(defforeign 'xm_intern_atom 
+    :entry-point "_XmInternAtom")
+
+(defforeign 'xm_main_window_set_area :entry-point
+  "_XmMainWindowSetAreas")
+
+(ff:defforeign 'xm_process_traversal
+    :entry-point "_XmProcessTraversal")
+
 (defforeign 'xm-message-box-get-child
     :entry-point "_XmMessageBoxGetChild")
+
diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp
index 759a50ff515e7342305b6265e916672f1909cea8..ee17b10b7fbd89d15b026d5856ea2a424725f14f 100644
--- a/tk/xm-protocols.lisp
+++ b/tk/xm-protocols.lisp
@@ -20,25 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-protocols.lisp,v 1.4 92/02/24 13:04:05 cer Exp Locker: cer $
+;; $fiHeader: xm-protocols.lisp,v 1.5 92/03/09 17:41:09 cer Exp $
 
 (in-package :tk)
 
-(defforeign 'xm_add_protocol_callback
-    :entry-point "_XmAddProtocolCallback")
-
-(defforeign 'xm_intern_atom 
-    :entry-point "_XmInternAtom")
-
-(def-c-type (proto-callback-info :in-foreign-space) :struct
-	     (handle :int)
-	     (data :int))
-
-(def-c-type (protocol :in-foreign-space) :struct
-  (object * :char)
-  (ext * :char)
-  (protocol * :char))
-
 (defun-c-callable protocol-callback-handler ((something-weird-widget :unsigned-long)
 					     (x :unsigned-long)
 					     (call-data
@@ -49,13 +34,13 @@
   
   #+ignore
   (print (list something-weird-widget
-	       (protocol-object something-weird-widget)
-	       (protocol-ext something-weird-widget)
-	       (protocol-protocol something-weird-widget)
-	       (proto-callback-info-handle x)))
+	       (xm-protocol-object something-weird-widget)
+	       (xm-protocol-ext something-weird-widget)
+	       (xm-protocol-protocol something-weird-widget)
+	       (xm-proto-callback-info-handle x)))
   
-  (callback-handler-1 (proto-callback-info-handle x)
-		      (proto-callback-info-data x)
+  (callback-handler-1 (xm-proto-callback-info-handle x)
+		      (xm-proto-callback-info-data x)
 		      call-data))
 
 (defvar *protocol-callback-handler-address* (register-function 'protocol-callback-handler))
@@ -71,9 +56,9 @@
      (if (integerp property) property (xm-intern-atom shell property))
      (if (integerp protocol) protocol (xm-intern-atom shell protocol))
      *protocol-callback-handler-address*
-     (let ((x (make-proto-callback-info)))
-       (setf (proto-callback-info-handle x) shell
-	     (proto-callback-info-data x)
+     (let ((x (make-xm-proto-callback-info)))
+       (setf (xm-proto-callback-info-handle x) shell
+	     (xm-proto-callback-info-data x)
 	     (caar (push
 		    (list (new-callback-id) (cons function args) type)
 		    (widget-callback-data shell))))
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index b2476a1646119a8ac68f0956a9f229e3c7428db5..56146cdf73b61ea3e54aa89ec2fc33bf9d60ca1d 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-widgets.lisp,v 1.4 92/01/31 14:55:20 cer Exp $
+;; $fiHeader: xm-widgets.lisp,v 1.5 92/02/24 13:04:08 cer Exp $
 
 (in-package :tk)
 
@@ -44,9 +44,6 @@
   (remf :name args)
   (apply #'create-popup-shell name (class-of w) parent args))
 
-(defforeign 'xm_main_window_set_area :entry-point
-  "_XmMainWindowSetAreas")
-
 (tk::add-resource-to-class (find-class 'vendor-shell)
 			   (make-instance 'resource
 					  :name :delete-response
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index 5604c3b0c13b4973fe38d44f687be7ad538d0d36..c9cbeb6f6182d1ecb83f8819aed11063f07a863b 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,v 1.7 92/03/30 17:51:58 cer Exp $
+;; $fiHeader: xt-defs.lisp,v 1.1 92/04/21 16:40:03 cer Exp Locker: cer $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index bf9465287c9c803c47ed04634fd7f115ea27b016..158312311cb7d1f7c53035ec815a699ed149f5d2 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -20,66 +20,106 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-funs.lisp,v 1.1 92/03/30 17:58:40 cer Exp Locker: cer $
+;; $fiHeader: xt-funs.lisp,v 1.2 92/04/10 14:26:20 cer Exp Locker: cer $
 
+;;
+;; This file contains compile time only code -- put in clim-debug.fasl.
+;;
 
 (in-package :xt)
 
-(defforeign 'quark_to_string
-    :entry-point "_XrmQuarkToString")
+(defforeign 'xt_get_resource_list :entry-point "_XtGetResourceList")
+(defforeign 'xt_get_constraint_resource_list :entry-point "_XtGetConstraintResourceList")
 
-(defforeign 'get-resource-list-1 :entry-point "_XtGetResourceList")
-(defforeign 'get-constraint-resource-list-1 :entry-point "_XtGetConstraintResourceList")
+(defforeign 'xt_initialize_widget_class :entry-point "_XtInitializeWidgetClass")
 
-(defforeign 'initialize-widget-class :entry-point "_XtInitializeWidgetClass")
+(defforeign 'xt_free
+    :arguments '(ff:foreign-address)
+    :call-direct t
+    :callback nil
+    :arg-checking nil
+    :return-type :void
+    :entry-point "_XtFree")
 
-(defforeign 'xt_free :entry-point "_XtFree")
-
-(defforeign 'toolkit-initialize
+(defforeign 'xt_toolkit_initialize
     :entry-point "_XtToolkitInitialize")
 
-(defforeign 'create_application_context
+(defforeign 'xt_create_application_context
     :entry-point "_XtCreateApplicationContext")
 
 
-(defforeign 'app_set_error_handler
+(defforeign 'xt_app_set_error_handler
     :entry-point "_XtAppSetErrorHandler")
 
-(defforeign 'app_set_warning_handler
+(defforeign 'xt_app_set_warning_handler
     :entry-point "_XtAppSetWarningHandler")
 
-(defforeign 'open_display
+(defforeign 'xt_open_display
     :entry-point "_XtOpenDisplay")
 
-(defforeign 'app_create_shell 
+(defforeign 'xt_app_create_shell 
     :entry-point "_XtAppCreateShell")
 
 ;;;; 
 
-(defforeign 'create_widget :entry-point "_XtCreateWidget")
-(defforeign 'create_managed_widget :entry-point "_XtCreateManagedWidget")
-(defforeign 'realize_widget :entry-point "_XtRealizeWidget")
-(defforeign 'manage_child :entry-point "_XtManageChild")
+(defforeign 'xt_create_widget :entry-point "_XtCreateWidget")
+(defforeign 'xt_create_managed_widget
+    :arguments '(simple-string ff:foreign-address ff:foreign-address
+		 ff:foreign-address fixnum)
+    :call-direct t
+    :callback t
+    :arg-checking nil
+    :return-type :unsigned-integer
+    :entry-point "_XtCreateManagedWidget")
+
+(defforeign 'xt_realize_widget :entry-point "_XtRealizeWidget")
+(defforeign 'xt_manage_child :entry-point "_XtManageChild")
 (defforeign 'xt_is_managed :entry-point "_XtIsManaged")
-(defforeign 'unmanage_child :entry-point "_XtUnmanageChild")
-(defforeign 'manage_children :entry-point "_XtManageChildren")
-(defforeign 'destroy_widget :entry-point "_XtDestroyWidget")
-(defforeign 'create_popup_shell :entry-point "_XtCreatePopupShell")
-(defforeign '_popup :entry-point "_XtPopup")
-(defforeign '_popdown :entry-point "_XtPopdown")
+(defforeign 'xt_unmanage_child :entry-point "_XtUnmanageChild")
+(defforeign 'xt_manage_children :entry-point "_XtManageChildren")
+(defforeign 'xt_destroy_widget :entry-point "_XtDestroyWidget")
+(defforeign 'xt_create_popup_shell :entry-point "_XtCreatePopupShell")
+(defforeign 'xt_popup :entry-point "_XtPopup")
+(defforeign 'xt_popdown :entry-point "_XtPopdown")
 (defforeign 'xt_window :entry-point "_XtWindow")
 (defforeign 'xt_parent :entry-point "_XtParent")
 (defforeign 'xt_query_geometry :entry-point "_XtQueryGeometry")
 (defforeign 'xt_configure_widget :entry-point "_XtConfigureWidget")
 
-(defforeign 'set_values :entry-point "_XtSetValues")
-(defforeign 'get_values :entry-point "_XtGetValues")
-
-(defforeign 'app_pending :return-type :fixnum :entry-point "_XtAppPending")
-(defforeign 'app_process_event :entry-point "_XtAppProcessEvent")
-(defforeign 'add_event_handler :entry-point "_XtAddEventHandler")
+(defforeign 'xt_set_values
+    :arguments '(ff:foreign-address ff:foreign-address fixnum)
+    :call-direct t
+    :callback t
+    :arg-checking nil
+    :return-type :void
+    :entry-point "_XtSetValues")
+(defforeign 'xt_get_values
+    :arguments '(ff:foreign-address ff:foreign-address fixnum)
+    :call-direct t
+    :callback t
+    :arg-checking nil
+    :return-type :void
+    :entry-point "_XtGetValues")
+
+
+(defforeign 'xt_app_pending
+    :arguments '(ff:foreign-address)
+    :call-direct t
+    ;; Maybe callback can be safely set to nil...
+    :callback t
+    :arg-checking nil
+    :return-type :fixnum
+    :entry-point "_XtAppPending")
+(defforeign 'xt_app_process_event
+    :arguments '(ff:foreign-address fixnum)
+    :call-direct t
+    :callback t
+    :arg-checking nil
+    :return-type :void
+    :entry-point "_XtAppProcessEvent")
+(defforeign 'xt_add_event_handler :entry-point "_XtAddEventHandler")
 (defforeign 'xt_build_event_mask :entry-point "_XtBuildEventMask")
 
-(defforeign 'add_callback :entry-point "_XtAddCallback")
+(defforeign 'xt_add_callback :entry-point "_XtAddCallback")
 (defforeign 'xt_has_callbacks :entry-point "_XtHasCallbacks")
 (ff::defforeign 'xtsetsensitive :entry-point "_XtSetSensitive")
diff --git a/tk/xt-init.lisp b/tk/xt-init.lisp
index b31e57162d7d4507b58146d719bf5930464f6b8b..183007cdb1484fceeda4db78642790fa01199bd2 100644
--- a/tk/xt-init.lisp
+++ b/tk/xt-init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-init.lisp,v 1.3 92/03/24 19:36:21 cer Exp Locker: cer $
+;; $fiHeader: xt-init.lisp,v 1.4 92/04/03 12:04:09 cer Exp Locker: cer $
 
 
 (in-package :tk)
@@ -29,5 +29,6 @@
 
 (defun xt-initialize ()
   (unless *xt-done*
-    (toolkit-initialize)
+    (xt_toolkit_initialize)
+    (define-toolkit-classes *intrinsic-classes*)
     (setq *xt-done* t)))
diff --git a/utils/processes.lisp b/utils/processes.lisp
index 4fd9758676f0d394dca352524915c3b79665c0a0..f76c9ffc6d76e562e5adc2a36105122475d93a51 100644
--- a/utils/processes.lisp
+++ b/utils/processes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: processes.lisp,v 1.2 92/01/31 15:07:26 cer Exp $
+;; $fiHeader: processes.lisp,v 1.3 92/02/24 13:05:49 cer Exp $
 
 (in-package :clim-utils)
 
@@ -37,9 +37,9 @@
   )
 
 (defun make-lock (&optional (lock-name "a CLIM lock"))
-  #-(or Genera Minima) (declare (ignore lock-name))
+  #-(or Genera Minima Allegro) (declare (ignore lock-name))
   #{
-    Allegro	(mp::make-process-lock)
+    Allegro	(mp::make-process-lock :name lock-name)
     lispworks	(mp::make-lock)
     Lucid	nil
     CCL-2	nil
diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp
index 8afdd297587a5ba5a90308da25501530f2c747a5..0adf11d1472b53a5d51d9d5c43d8f7a12d05fda8 100644
--- a/xlib/ffi.lisp
+++ b/xlib/ffi.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ffi.lisp,v 1.9 92/03/30 17:52:16 cer Exp $
+;; $fiHeader: ffi.lisp,v 1.10 92/04/15 11:45:43 cer Exp Locker: cer $
 
 (in-package :x11)
 
@@ -53,37 +53,42 @@
 (defun fintern (control &rest args)
   (intern (apply #'format nil control args)))
 
-(defmacro def-exported-foreign-struct (name &rest slots)
-  `(progn
-     (eval-when (eval load compile)
-       (export '(,name
-		 ,(fintern "~A~A" 'make- name)
-		 ,@(mapcar #'(lambda (x)
-			       (fintern "~A-~A" name (car x)))
-		    slots))))
-     ,(flet ((foo-slot (slot)
-	       (destructuring-bind
-		   (name &key type) slot
-		 `(,name ,@(trans-slot-type type)))))
-	(if (notany #'(lambda (s) (member :overlays (cdr s))) slots)
-	    `(ff::def-c-type (,name :in-foreign-space :no-defuns)
-	       ,@(mapcar #'foo-slot slots))
-	  (destructuring-bind
-	      ((first-slot-name . first-options) . other-slots) slots
-	    (if (and (null (member :overlays first-options))
-		     (every #'(lambda (slot)
-				t
-				#+ignore
-				(eq (getf (cdr slot) :overlays)
-				    first-slot-name))
-			    other-slots))
-		`(ff::def-c-type (,name :in-foreign-space :no-defuns) :union
-				 ,@(mapcar #'(lambda (slot)
-					       (setq slot (copy-list slot))
-					       (remf (cdr slot) :overlays)
-					       (foo-slot slot))
-					   slots))
-	      (error ":overlays used in a way we cannot handle")))))))
+(defmacro def-exported-foreign-struct (name-and-options &rest slots)
+  (let (name (options nil))
+    (if (atom name-and-options)
+	(setq name name-and-options)
+      (setq name (car name-and-options)
+	    options (cdr name-and-options)))
+    `(progn
+       (eval-when (eval load compile)
+	 (export '(,name
+		   ,(fintern "~A~A" 'make- name)
+		   ,@(mapcar #'(lambda (x)
+				 (fintern "~A-~A" name (car x)))
+		      slots))))
+       ,(flet ((foo-slot (slot)
+		 (destructuring-bind
+		     (name &key type) slot
+		   `(,name ,@(trans-slot-type type)))))
+	  (if (notany #'(lambda (s) (member :overlays (cdr s))) slots)
+	      `(ff::def-c-type (,name :no-defuns ,@options)
+		 ,@(mapcar #'foo-slot slots))
+	    (destructuring-bind
+		((first-slot-name . first-options) . other-slots) slots
+	      (if (and (null (member :overlays first-options))
+		       (every #'(lambda (slot)
+				  t
+				  #+ignore
+				  (eq (getf (cdr slot) :overlays)
+				      first-slot-name))
+			      other-slots))
+		  `(ff::def-c-type (,name :no-defuns ,@options) :union
+				   ,@(mapcar #'(lambda (slot)
+						 (setq slot (copy-list slot))
+						 (remf (cdr slot) :overlays)
+						 (foo-slot slot))
+					     slots))
+		(error ":overlays used in a way we cannot handle"))))))))
 	  
 
 (defun trans-slot-type (type)
diff --git a/xlib/x11-keysyms.lisp b/xlib/x11-keysyms.lisp
index b6457aa0685f5d449e5e7832403b4bcb96eb1812..ec3a272197807a2f80833ae59d28ffd0213e462d 100644
--- a/xlib/x11-keysyms.lisp
+++ b/xlib/x11-keysyms.lisp
@@ -18,24 +18,31 @@
 ;; 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.
-;;
-;;;
-;;; Unpublished--all rights reserved under the copyright laws of the United
-;;; States. Sun considers its source code as an unpublished, proprietary trade
-;;; secret, and it is available only under strict license provisions.  This
-;;; copyright notice is placed here only to protect Sun in the event the source
-;;; is deemed a published work.  Disassembly, decompilation, or other means of
-;;; reducing the object code to human readable form is prohibited by the 
-;;; license agreement under which this code is provided to the user or 
-;;; company in possession of this copy.
-;;; 
-;;; RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the Government
-;;; is subject to restrictions as set forth in subparagraph (c) (1)(ii) of the
-;;; Rights in Technical Data and Computer Software Clause at DFARS 252.227-7013
-;;; (Oct. 1988) and FAR 52.227-19(c) (June 1987) Sun Microsystems, Inc. 2550
-;;; Garcia Avenue, Mountain View, California 94043.
-;; $fiHeader: x11-keysyms.lisp,v 1.4 92/02/16 20:55:26 cer Exp $
 
+;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
+;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
+;;      registered trademark of USL. Used by written permission of the owners.
+;;
+;;      (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered
+;;      trademark of Bigelow & Holmes. Permission to use the Lucida
+;;      trademark is hereby granted only in association with the images
+;;      and fonts described in this file.
+;;
+;;      SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES
+;;      MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF
+;;      THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS"
+;;      WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND.
+;;      SUN  MICROSYSTEMS, INC., USL AND BIGELOW  & HOLMES,
+;;      SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES
+;;      WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED
+;;      WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+;;      PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS,
+;;      INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY
+;;      SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
+;;      OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
+;;      OR PROFITS, WHETHER IN AN ACTION OF  CONTRACT, NEGLIGENCE
+;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
+;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
 
 ;;;@(#)x11-keysym.lisp	1.3 11/29/90
 
diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp
index 991c384fc64922a5e08430c6b3adf646f3c12afa..c475517dd41c8dd13baa3d4475f8c777b3163219 100644
--- a/xlib/xlib-defs.lisp
+++ b/xlib/xlib-defs.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: common-lisp; package: x11 -*-
-;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
+;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -21,6 +21,31 @@
 ;;
 ;;; $fiHeader: xlib-defs.lisp,v 1.1 92/03/06 17:06:59 cer Exp $
 
+;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
+;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
+;;      registered trademark of USL. Used by written permission of the owners.
+;;
+;;      (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered
+;;      trademark of Bigelow & Holmes. Permission to use the Lucida
+;;      trademark is hereby granted only in association with the images
+;;      and fonts described in this file.
+;;
+;;      SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES
+;;      MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF
+;;      THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS"
+;;      WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND.
+;;      SUN  MICROSYSTEMS, INC., USL AND BIGELOW  & HOLMES,
+;;      SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES
+;;      WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED
+;;      WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+;;      PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS,
+;;      INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY
+;;      SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
+;;      OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
+;;      OR PROFITS, WHETHER IN AN ACTION OF  CONTRACT, NEGLIGENCE
+;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
+;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
+
 (in-package :x11)
 
 ;;; This is a Lucid Common Lisp Foreign Function Interface for Xlib.  It was generated
@@ -1278,7 +1303,7 @@
   (display :type (:pointer display))
   (window :type window))
 
-(def-exported-foreign-struct xevent
+(def-exported-foreign-struct (xevent :no-substruct-accessors)
   (type :type int)
   (xany :type xanyevent :overlays type)
   (xkey :type xkeyevent :overlays xany)
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index 5d77f694724a6b64814297af7f2ebe40a21b2d39..dc3ea8a530be0280bd1b93bcf11cadb10214dad8 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: common-lisp; package: x11 -*-
-;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
+;;; (c) Copyright  1990 Sun Microsystems, Inc.  All Rights Reserved.
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca.  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca.  All rights reserved.
@@ -19,6 +19,32 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
+
+;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
+;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
+;;      registered trademark of USL. Used by written permission of the owners.
+;;
+;;      (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered
+;;      trademark of Bigelow & Holmes. Permission to use the Lucida
+;;      trademark is hereby granted only in association with the images
+;;      and fonts described in this file.
+;;
+;;      SUN MICROSYSTEMS, INC., USL, AND BIGELOW & HOLMES
+;;      MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF
+;;      THIS SOURCE OR OBJECT CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS"
+;;      WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND.
+;;      SUN  MICROSYSTEMS, INC., USL AND BIGELOW  & HOLMES,
+;;      SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES
+;;      WITH REGARD TO THIS CODE, INCLUDING ALL IMPLIED
+;;      WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+;;      PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS,
+;;      INC., USL OR BIGELOW & HOLMES BE LIABLE FOR ANY
+;;      SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
+;;      OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
+;;      OR PROFITS, WHETHER IN AN ACTION OF  CONTRACT, NEGLIGENCE
+;;      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 $
 
 (in-package :x11)
@@ -156,8 +182,8 @@
 
 (def-exported-foreign-function (xcheckifevent (:return-type int) (:name "_XCheckIfEvent")) 
    (dpy (:pointer display))
-   (predicate (:pointer :pointer))
    (event (:pointer xevent))
+   (predicate (:pointer :pointer))
    (arg (:pointer char)))
 
 (def-exported-foreign-function (xcheckmaskevent (:return-type int) (:name "_XCheckMaskEvent")) 
@@ -694,8 +720,8 @@
 
 (def-exported-foreign-function (xifevent (:return-type int) (:name "_XIfEvent")) 
    (dpy (:pointer display))
-   (predicate (:pointer :pointer))
    (event (:pointer xevent))
+   (predicate (:pointer :pointer))
    (arg (:pointer char)))
 
 (def-exported-foreign-function (xinitextension (:return-type (:pointer xextcodes)) (:name "_XInitExtension"))