From b71ef75be74e2655163d90cf17b99101a7d1636f Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Fri, 17 Jan 1992 17:49:53 +0000
Subject: [PATCH] fixes

---
 clim/accept-values.lisp    |   8 +-
 clim/gadget-output.lisp    |  16 +-
 misc/go.lisp               |  41 ++-
 silica/gadgets.lisp        | 111 +++++--
 test/test-suite.lisp       |   8 +-
 test/test.lisp             |  10 +
 tk-silica/sysdcl.lisp      |  26 +-
 tk-silica/xm-frames.lisp   | 253 +++++---------
 tk-silica/xm-gadgets.lisp  | 662 ++++++++++++-------------------------
 tk-silica/xm-graphics.lisp | 490 +--------------------------
 tk-silica/xm-silica.lisp   | 511 +---------------------------
 tk-silica/xt-silica.lisp   |   4 +-
 tk/callbacks.lisp          |  27 +-
 tk/defsys.lisp             |  43 +--
 tk/examples.lisp           |  13 +-
 tk/foreign-obj.lisp        |  12 +-
 tk/load-ol.lisp            | 126 +++++--
 tk/load-xm.lisp            |  56 ++--
 tk/macros.lisp             |  21 +-
 tk/make-classes.lisp       |  28 +-
 tk/make-widget.lisp        |   4 +-
 tk/ol-examples.lisp        |  85 ++++-
 tk/ol-init.lisp            | 114 ++++---
 tk/resources.lisp          | 212 +++++++++++-
 tk/widget.lisp             |  20 +-
 tk/xm-widgets.lisp         |  32 +-
 tk/xtk.lisp                |  73 +++-
 27 files changed, 1109 insertions(+), 1897 deletions(-)

diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index e19c9e36..f20c4980 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -19,7 +19,7 @@
 ;; applicable.
 ;;
 
-;; $fiHeader: accept-values.lisp,v 1.2 92/01/02 15:11:54 cer Exp Locker: cer $
+;; $fiHeader: accept-values.lisp,v 1.3 92/01/06 20:44:10 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -759,7 +759,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 	 (avv-stream (car stream-and-record))
 	 (avv-record (cdr stream-and-record)))
     (cond (avv-stream
-	   (letf-globally (((stream-default-view avv-stream) +dialog-view+))
+	   (letf-globally (((stream-default-view avv-stream) 
+			    (port-dialog-view (port avv-stream))))
 	     (redisplay avv-record avv-stream :check-overlapping check-overlapping)
 	     (when resynchronize-every-pass
 	       (redisplay avv-record avv-stream :check-overlapping check-overlapping))))
@@ -769,7 +770,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved
 (defun accept-values-pane-displayer-1 (frame pane displayer)
   (let ((avv-stream (make-instance 'avv-stream :stream pane))
 	(avv-record nil))
-    (letf-globally (((stream-default-view avv-stream) +dialog-view+))
+    (letf-globally (((stream-default-view avv-stream) 
+		     (port-dialog-view (port avv-stream))))
       (setq avv-record
 	    (updating-output (avv-stream)
 	      (with-new-output-record (avv-stream 'avv-output-record avv-record)
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index ac54f2e8..979f781b 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gadget-output.cl,v 1.1 92/01/06 20:36:58 cer Exp Locker: cer $
+;; $fiHeader: gadget-output.cl,v 1.2 92/01/08 14:58:58 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -120,7 +120,7 @@
     (realize-pane 'silica::toggle-button
 		  :client stream
 		  :id query-identifier
-		  :set default)))
+		  :value default)))
 
 
 (define-presentation-method accept-present-default ((type integer)
@@ -253,23 +253,27 @@
   (declare (ignore present-p))
   ;; value-key, test, sequence
   (with-output-as-gadget (:stream stream)
-    (let* ((frame-pane
+    (let* (
+	   #+ignore
+	   (frame-pane
 	    (realize-pane 'silica::frame-pane))
 	   (gadget
 	    (realize-pane 'silica::radio-box 
 			  :client stream
 			  :id query-identifier
-			  :parent frame-pane)))
+			  #+ignore :parent 
+			  #+ignore frame-pane)))
       (dolist (element sequence)
 	(realize-pane 'toggle-button 
-		      :set (and default-supplied-p
+		      :value (and default-supplied-p
 				(funcall test 
 					 (funcall value-key element)
 					 (funcall value-key default)))
 		      :label (princ-to-string element)
 		      :id element
 		      :parent gadget))
-      frame-pane)))
+      gadget
+      #+ignore frame-pane)))
 
 (defmethod silica::value-changed-callback ((gadget silica::radio-box)
 					   (client avv-stream)
diff --git a/misc/go.lisp b/misc/go.lisp
index 422a5765..ff2f5875 100644
--- a/misc/go.lisp
+++ b/misc/go.lisp
@@ -22,6 +22,7 @@
       excl::*load-source-file-info* t)
 
 (without-package-locks
+ (excl::compile-file-if-needed "sys/defsystem")
  (load "sys/defsystem")
  (load "sys/sysdcl"))
 
@@ -46,15 +47,36 @@
 
 
 (load "tk/defsys.cl")
-(defsys::compile-system :xm-tk)
-(defsys::load-system :xm-tk)
-
-(load "xm-silica/sysdcl.cl")
-(defsys::compile-system :xm-silica)
-(defsys::load-system :xm-silica)
-
-(defsys::compile-system :xm-ws)
-(defsys::load-system :xm-ws)
+(defsys::compile-system :basic-tk)
+(defsys::load-system :basic-tk)
+
+(let ((which (or (and (boundp 'which)
+		      which)
+		 :motif)))
+  (let ((sys
+	 (ecase which
+	   (:motif :xm-tk)
+	   (:openlook :ol-tk))))
+    (defsys::compile-system sys)
+    (defsys::load-system sys))
+
+  (defsys::compile-system :hi-tk)
+  (defsys::load-system :hi-tk)
+
+  (load "xm-silica/sysdcl.cl")
+  
+  (let ((sys (ecase which
+	       (:motif :xm-silica)
+	       (:openlook :ol-silica))))
+    (defsys::compile-system sys)
+    (defsys::load-system sys))
+
+  
+  (let ((sys (ecase which
+	       (:motif :xm-ws)
+	       (:openlook :ol-ws))))
+    (defsys::compile-system sys)
+    (defsys::load-system sys)))
 
 #+:composer
 (progn
@@ -62,6 +84,7 @@
   (load "draw-sheets")
   )
 
+(excl::compile-file-if-needed "test/test")
 (load "test/test")
 
 (excl::compile-file-if-needed "test/test-suite")
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 73f016c8..5df2caca 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -18,45 +18,106 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gadgets.cl,v 1.4 92/01/06 20:44:20 cer Exp Locker: cer $
+;; $fiHeader: gadgets.cl,v 1.5 92/01/08 14:59:00 cer Exp Locker: cer $
 
 (in-package :silica)
 
+;;; Does this make sense
+;;; We want to be able to specify visual attributes of gadgets
 
-(defclass gadget ()
+(defclass foreground-background-and-text-style-mixin ()
+	  ((foreground :initform nil :initarg :foreground)
+	   (background :initform nil :initarg :background)
+	   (text-style :initform nil :initarg :text-style)))
+
+(defclass gadget (foreground-background-and-text-style-mixin)
 	  ((id :initarg :id :reader gadget-id :initform nil)
 	   (client :initarg :client :initform nil :accessor gadget-client)))
 
-(defclass value-gadget (gadget) ())
-
-(defmethod value-changed-callback ((v gadget) (client t) (id t) (value t))
-  ())
+(defclass value-gadget (gadget) 
+	  ((value :initarg :value
+		  :initform nil
+		  :reader gadget-initial-value)
+	   (value-changed-callback 
+	    :initarg :value-changed-callback
+	    :initform nil
+	    :reader gadget-value-changed-callback)))
+
+(defmethod value-changed-callback ((gadget gadget) (client t) (id t) (value
+								 t))
+  (when (gadget-value-changed-callback gadget)
+    (invoke-callback-function
+     (gadget-value-changed-callback gadget)
+     gadget
+     value)))
+
+(defun invoke-callback-function (function &rest args)
+  (if (consp function)
+      (apply (car function) (append args (cdr function)))
+    (apply function args)))
 
 (defgeneric gadget-value (gadget))
 
-(defgeneric (setf gadget-value) (gadget))
+(defmethod gadget-value ((gadget gadget))
+  (with-slots (value) gadget
+    value))
+
+(defmethod value-changed-callback :before ((gadget gadget) client id new-value)
+  (declare (ignore id client))
+  (with-slots (value) gadget
+    (setf value new-value)))
+
+(defgeneric (setf gadget-value) (nv gadget))
+
+(defmethod (setf gadget-value) :after (nv (gadget gadget))
+  (with-slots (value) gadget
+    (setf value nv)))
+
+;;;;;;;;;;;;;
 
-(defclass action-gadget (gadget) ())
+(defclass action-gadget (gadget) 
+	  ((action-callback 
+	    :initarg :action-callback
+	    :initform nil
+	    :reader gadget-action-callback)))  
+
+(defmethod activate-callback ((gadget gadget) (client t) (id t))
+  (when (gadget-action-callback gadget)
+    (invoke-callback-function
+     (gadget-action-callback gadget)
+     gadget)))
+
+;;; Basic gadgets-mixins
+
+(defclass oriented-gadget ()
+	  ((orientation :initarg :orientation
+			:reader gadget-orientation))
+  
+  (:default-initargs :orientation :horizontal))
+
+(defclass labelled-gadget ()
+	  ((label :initarg :label
+		  :reader gadget-label))
+  (:default-initargs :label ""))
 
-(defmethod activate-callback ((v gadget) (client t) (id t))
-  ())
 
 ;;;;;;;;;;;;;;;;;;;; The intent is that the real implementations
 ;;;;;;;;;;;;;;;;;;;; inherit from these
 
 ;; slider
 
-(defclass slider () ())
+(defclass slider (value-gadget oriented-gadget)
+	  ())
 
 ;; push-button
 
-(defclass silica::push-button () ())
+(defclass silica::push-button (action-gadget labelled-gadget) 
+	  ())
 
-;; toggle-button
 ;; scroll-bar
 
 
-(defclass scrollbar ()
+(defclass scrollbar (value-gadget oriented-gadget)
 	  ((current-value :initform nil)
 	   (current-size :initform nil)))
 
@@ -67,7 +128,8 @@
 ;; radio-box [exclusive-choice]
 ;; .. [inclusive-choice]
 
-(defclass silica::radio-box () ())
+(defclass silica::radio-box (value-gadget oriented-gadget) 
+	  ())
 
 ;; menu-bar
 
@@ -80,11 +142,14 @@
 
 ;; text-edit
 
-(defclass text-field () ())
+(defclass text-field (value-gadget action-gadget) 
+	  ())
 
 ;; toggle buttton
 
-(defclass toggle-button () ())
+(defclass toggle-button (value-gadget labelled-gadget) 
+	  ((indicator-type :initarg :indicator-type :initform :some-of
+			   :reader gadget-indicator-type)))
 
 ;;; Viewport
 
@@ -114,18 +179,14 @@
   ((value :initarg :value :reader event-value)))
 
 (defmethod handle-event ((gadget value-gadget) (event value-changed-gadget-event))
-  (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) (slot-value event 'value)))
+  (value-changed-callback gadget 
+			  (gadget-client gadget)
+			  (gadget-id gadget)
+			  (slot-value event 'value)))
 
 (defclass activate-gadget-event (gadget-event) ())
 
 (defmethod handle-event ((gadget  action-gadget) (event activate-gadget-event))
   (activate-callback gadget (gadget-client gadget) (gadget-id gadget)))
 
-;; Does this make sense
-
-(defclass foreground-background-and-text-style-mixin ()
-	  ((foreground :initform nil :initarg :foreground)
-	   (background :initform nil :initarg :background)
-	   (text-style :initform nil :initarg :text-style)))
-
 ;;; Do these have readers and writers?
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 8083590e..5873d6fa 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*-
 
-;; $fiHeader: test-suite.cl,v 1.4 92/01/06 20:44:32 cer Exp Locker: cer $
+;; $fiHeader: test-suite.cl,v 1.5 92/01/08 14:59:16 cer Exp Locker: cer $
 
 (in-package :clim)
 
@@ -2917,12 +2917,14 @@ Luke Luck licks the lakes Luke's duck likes."))
 			  ("Exit" :command (exit-clim-tests)))))
   (:command-definer nil)
   (:pane (with-slots (caption-pane display-pane) *application-frame*
-	     (silica::vertically ()
+	   (silica::vertically ()
+			       (silica::scrolling
+				  ()
 				 (setf caption-pane
 				    (silica::realize-pane
 				     'application-pane
 				     :height 50
-				     ))
+				     )))
 				 (silica::scrolling
 				  ()
 				  (setf display-pane
diff --git a/test/test.lisp b/test/test.lisp
index 0833816b..2098e921 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -49,6 +49,16 @@
 		(make-text-style
 		 :serif :roman 20)))))
 
+
+(define-application-frame test-frame0 ()
+  (a b c)
+  (:command-table test-frame)
+  (:pane 
+   (silica::scrolling
+    ()
+    (silica::realize-pane
+     'interactor-pane))))
+
 (define-application-frame test-frame2 ()
   (a b c)
   (:command-table test-frame)
diff --git a/tk-silica/sysdcl.lisp b/tk-silica/sysdcl.lisp
index 24b3c2f2..1181c643 100644
--- a/tk-silica/sysdcl.lisp
+++ b/tk-silica/sysdcl.lisp
@@ -18,20 +18,42 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: sysdcl.cl,v 1.2 92/01/02 15:09:42 cer Exp Locker: cer $
 
 (in-package :cl-user)
 
 (defsys::defsystem :xm-silica
     (:default-pathname (frob-pathname "xm-silica"))
   ("pkg")
+  ("xt-silica")
   ("xm-silica")
+  ("xt-graphics")
   ("xm-graphics")
   ("image"))
 
+(defsys::defsystem :ol-silica
+    (:default-pathname (frob-pathname "xm-silica"))
+  ("pkg")
+  ("xt-silica")
+  ("ol-silica")
+  ("xt-graphics")
+  ("ol-graphics")
+  ("image"))
+
+
 (defsys::defsystem :xm-ws
-  (:default-pathname (frob-pathname "xm-silica"))
+    (:default-pathname (frob-pathname "xm-silica"))
+  ("xt-frames")
   ("xm-frames")
+  ("xt-gadgets")
   ("xm-gadgets"))
 
+(defsys::defsystem :ol-ws
+    (:default-pathname (frob-pathname "xm-silica"))
+  ("xt-frames")
+  ("ol-frames")
+  ("xt-gadgets")
+  ("ol-gadgets"))
+
+
 
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index c0162d2b..a50ea179 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,184 +18,22 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.cl,v 1.2 92/01/02 15:09:43 cer Exp Locker: cer $
+;; $fiHeader: xm-frames.cl,v 1.3 92/01/06 20:43:59 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
+;; Motif stuff
 
-(defclass motif-frame-manager (frame-manager) 
+(defclass motif-frame-manager (xt-frame-manager)
 	  ())
 
 (defmethod make-frame-manager ((port motif-port))
   (make-instance ' motif-frame-manager :port port))
 
-(defmethod adopt-frame ((framem motif-frame-manager) (frame application-frame))
-  (call-next-method)
-  (when (frame-panes frame)
-    (let* ((top-pane (frame-panes frame))
-	   (sheet (make-instance 'motif-top-level-sheet 
-				 :region (make-bounding-rectangle
-					  0 0 (sheet-width
-					       top-pane) 
-					  (sheet-height top-pane))
-				 :parent (find-graft))))
-      (setf (frame-top-level-sheet frame) sheet
-	    (frame-shell frame) (sheet-shell sheet))
-      (adopt-child sheet (frame-panes frame))
-      (establish-wm-protocol-callbacks frame))))
+(defmethod adopt-frame :after ((framem motif-frame-manager) (frame application-frame))
+  (establish-wm-protocol-callbacks framem frame))
 
-(defmethod note-frame-enabled :after ((framem motif-frame-manager) frame)
-  ;; Perhaps we want to resize the top leve sheet if there is one
-  (when (frame-top-level-sheet frame)
-    (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)))
-
-(defmethod note-frame-disabled :after ((framem motif-frame-manager) frame)
-  (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil))
-
-;;; Definitions of the individual classes
-
-;;; Main window
-
-(defclass motif-main-window (motif-composite-pane)
-  (
-   (contents :accessor main-window-contents :initform nil)
-   (command-window :initform nil :accessor main-window-command-window)
-   command-window-location
-   menu-bar
-   message-window
-   ))
-
-(defmethod initialize-instance :after ((mw motif-main-window)
-				       &key
-				       command-window
-				       command-window-location
-				       menu-bar
-				       message-window
-				       contents)
-  (when contents
-    (setf (main-window-contents mw) contents))
-  (when command-window
-    (setf (main-window-command-window mw) command-window))
-  (when message-window
-    (setf (main-window-message-window mw) message-window)))
-
-(defmethod (setf main-window-contents) :after (nv (mw motif-main-window))
-  (unless (sheet-parent nv)
-    (adopt-child mw nv)))
-
-(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window))
-  (unless (sheet-parent nv)
-    (adopt-child mw nv)))
-
-#+ignore
-(defmethod realize-mirror :around (port (motif-main-window))
-  (let ((m (call-next-method)))
-    (tk::xm_set_main_window_areas
-     (object-handle m)
-     .. 
-     (and command-window (realize-mirror port command-window))
-     ..
-     (and message-window (realize-mirror port message-window))
-     ...)))
-
-;;; Drawing area
-
-#+ignore
-(defclass motif-drawing-area (motif-composite-pane) ())
-
-;;; Row colum
-
-(defclass motif-row-colum (motif-composite-pane) ())
-
-;;; Push button
-
-#+ignore
-(defclass motif-push-button (motif-leaf-pane) ())
-
-;;; Menu bar
-
-(defclass motif-menu-bar (motif-composite-pane) ())
-(defclass motif-pulldown-menu (motif-composite-pane) ())
-
-(defclass motif-cascade-button (motif-composite-pane)
-  ((submenu :accessor cascade-button-submenu :initform nil))
-  )
-
-(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button))
-  (let ((m (call-next-method)))
-    (when (cascade-button-submenu sheet)
-      (tk::set-values m :sub-menu-id 
-		      (realize-mirror port (cascade-button-submenu sheet))))
-    m))
-
-  
-
-#+ignore
-(define-application-frame motif-example-frame ()
-  :pane (make-instance 'motif-main-window
-		       ))
-
-#|
-
-(defmethod compose-space ((sheet motif-pane))
-  (multiple-value-bind
-      (width height)
-      (tk::get-values (sheet-mirror sheet) :width :height)
-    (make-instance 'space-req
-		   :width width
-		   :height height)))
-
-(make-instance 'motif-main-window
-	       :parent ..
-	       :contents ...)
-
-;; What about all the readers/writers that are applicable?
-;; We have to trampoline those?
-
-(setf (sheet-resource sheet :x) value)
-
-Can the basic motif stuff support lazy realization?
-
-|#
-
-#+ignore
-(define-motif-sheet motif-menu-bar tk::xm-menu-bar)
-
-
-;; Leaf panes
-
-
-
-;;; definition of the composite pane stuff
-
-;;; So once we have done all this we will be able to
-;;; define-application-frames using motif widgets
-;;; Still need a stream pane though
-
-;;; These frames use the Motif layout technology but perhaps we can
-;;; plug in CLIM style stuff too.
-
-;;; Need a pane we can draw on.
-
-;;; Perhaps a :resources initarg to specify resources
-
-;;; Do scrollbars come from the use of the scrolling macro.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; How do we interface to motif UIL.
-;;; Perhaps use the name of the widget??
-;;; We can query the UIL file to obtain the widget hiearchy.
-
-;;; Gadget callbacks are not interfaced to the CP.
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Final step is mapping abstract gadgets onto motif gadgets
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defmethod establish-wm-protocol-callbacks (frame)
+(defmethod establish-wm-protocol-callbacks ((framem motif-frame-manager) frame)
   (let ((shell (frame-shell frame)))
     (tk::set-values shell 
 		    :icon-name (frame-name frame)
@@ -208,6 +46,82 @@ Can the basic motif stuff support lazy realization?
      'frame-wm-protocol-callback
      frame)))
 
+;;; Definitions of the individual classes
+
+;; This looks like garbage??
+
+;(defclass motif-main-window (motif-composite-pane)
+;  (
+;   (contents :accessor main-window-contents :initform nil)
+;   (command-window :initform nil :accessor main-window-command-window)
+;   command-window-location
+;   menu-bar
+;   message-window
+;   ))
+;
+;(defmethod initialize-instance :after ((mw motif-main-window)
+;				       &key
+;				       command-window
+;				       command-window-location
+;				       menu-bar
+;				       message-window
+;				       contents)
+;  (when contents
+;    (setf (main-window-contents mw) contents))
+;  (when command-window
+;    (setf (main-window-command-window mw) command-window))
+;  (when message-window
+;    (setf (main-window-message-window mw) message-window)))
+;
+;(defmethod (setf main-window-contents) :after (nv (mw motif-main-window))
+;  (unless (sheet-parent nv)
+;    (adopt-child mw nv)))
+;
+;(defmethod (setf main-window-command-window) :after (nv (mw motif-main-window))
+;  (unless (sheet-parent nv)
+;    (adopt-child mw nv)))
+;
+;#+ignore
+;(defmethod realize-mirror :around (port (motif-main-window))
+;  (let ((m (call-next-method)))
+;    (tk::xm_set_main_window_areas
+;     (object-handle m)
+;     .. 
+;     (and command-window (realize-mirror port command-window))
+;     ..
+;     (and message-window (realize-mirror port message-window))
+;     ...)))
+
+;;;; Drawing area
+;
+;#+ignore
+;(defclass motif-drawing-area (motif-composite-pane) ())
+;
+;;;; Row colum
+;
+;(defclass motif-row-colum (motif-composite-pane) ())
+;
+;;;; Push button
+
+;#+ignore
+;(defclass motif-push-button (motif-leaf-pane) ())
+
+;;; Menu bar
+
+;(defclass motif-menu-bar (motif-composite-pane) ())
+;(defclass motif-pulldown-menu (motif-composite-pane) ())
+;
+;(defclass motif-cascade-button (motif-composite-pane)
+;  ((submenu :accessor cascade-button-submenu :initform nil))
+;  )
+;
+;(defmethod realize-mirror :around ((port motif-port) (sheet motif-cascade-button))
+;  (let ((m (call-next-method)))
+;    (when (cascade-button-submenu sheet)
+;      (tk::set-values m :sub-menu-id 
+;		      (realize-mirror port (cascade-button-submenu sheet))))
+;    m))
+
 (defclass window-manager-event (event)
 	  ())
 
@@ -238,8 +152,7 @@ Can the basic motif stuff support lazy realization?
 					      (clim-internals::frame-command-table frame))
 			pane)))
 
-(defclass motif-menubar (motif-leaf-pane
-			 sheet-permanently-enabled-mixin) 
+(defclass motif-menubar (xt-leaf-pane) 
 	  ((command-table :initarg :command-table)))
 
 (defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-menubar))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 6bc8c033..9ff41854 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,93 +18,43 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.cl,v 1.4 92/01/06 20:44:01 cer Exp Locker: cer $
+;; $fiHeader: xm-gadgets.cl,v 1.5 92/01/08 14:58:39 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
-
-(defmethod realize-pane-internal ((realizer motif-frame-manager)
-				  frame
-				  abstract-type
-				  &rest options)
-  (let ((type (second (assoc abstract-type '(
-					     (silica::scroll-bar motif-scrollbar)
-					     (slider motif-slider)
-					     (push-button motif-push-button)
-					     (canvas motif-drawing-area)
-					     (text-field motif-text-field)
-					     (toggle-button motif-toggle-button)
-					     (silica::menubar motif-menubar)
-					     (silica::viewport xm-viewport)
-					     (silica::radio-box motif-radio-box)
-					     (silica::frame-pane motif-frame-pane)
-					     ;; One day
-					     (line-editor-pane)
-					     (label-button-pane)
-					     (radio-button-pane)
-					     (horizontal-divider-pane)
-					     (vertical-divider-pane)
-					     (label-pane)
+(defmethod realize-pane-class ((realizer motif-frame-manager) class &rest options) 
+  (declare (ignore options))
+  (second (assoc class '(
+			 (silica::scroll-bar motif-scrollbar)
+			 (slider motif-slider)
+			 (push-button motif-push-button)
+			 (canvas motif-drawing-area)
+			 (text-field motif-text-field)
+			 (toggle-button motif-toggle-button)
+			 (silica::menubar motif-menubar)
+			 (silica::viewport xm-viewport)
+			 (silica::radio-box motif-radio-box)
+			 (silica::frame-pane motif-frame-pane)
+			 (silica::top-level-sheet motif-top-level-sheet)
+			 ;; One day
+			 (line-editor-pane)
+			 (label-button-pane)
+			 (radio-button-pane)
+			 (horizontal-divider-pane)
+			 (vertical-divider-pane)
+			 (label-pane)
 				   ;;;
-					     (list-pane)
-					     (menu-bar)
-					     (caption-pane)
-					     (scroll-bar)
-					     (radio-box)
-					     (cascade-button)
-					     )))))
-    (if type
-	(apply #'make-instance
-	       type 
-	       :frame frame
-	       :frame-manager realizer
-	       (apply #'realize-pane-arglist
-		      realizer
-		      abstract-type options))
-      (call-next-method))))
-
-(defmethod realize-pane-arglist (realizer type &rest options)
-  options)
+			 (list-pane)
+			 (menu-bar)
+			 (caption-pane)
+			 (scroll-bar)
+			 (radio-box)
+			 (cascade-button)
+			 ))))
 
 ;;; We now need a lot of classes that mirror the xm classes.
 
 
-(defclass motif-pane (silica::pane) (#+ignore resources))
-
-(defmethod allocate-space ((p motif-pane) width height)
-  (when (sheet-mirror p)
-    (tk::set-values (sheet-mirror p) :width width :height height)))
-
-
-#+ignore
-(defmethod initialize-instance :after ((x motif-pane) &rest args)
-  (setf (slot-value x 'resources) args))
-
-#+ignore
-(defmethod  find-widget-class-and-initargs-for-sheet :around (port (sheet motif-pane))
-  (multiple-value-bind
-      (x y) (call-next-method)
-    (clos::doplist (key value) (slot-value sheet 'resources)
-		   (unless (getf y key)
-		     (setf (getf y key) value)))
-    (values x y)))
-
-(defclass motif-composite-pane () ())
-
-(defclass ask-widget-for-size-mixin () ())
-
-(defmethod compose-space ((pane ask-widget-for-size-mixin))
-  (multiple-value-bind
-      (x y width height borderwidth
-	 care-x care-y care-width care-height care-borderwidth)
-      (tk::widget-best-geometry (sheet-direct-mirror pane))
-    (declare (ignore x y borderwidth care-x care-y care-width
-		     care-height care-borderwidth)) 
-    (make-instance 'silica::space-req :width width :height height)))
-
-(defclass motif-leaf-pane (motif-pane mirrored-sheet-mixin ask-widget-for-size-mixin)
-	  ())
-
 ;;; Motif widgets that support the :value resource and value-changed callback
 
 (defclass motif-value-pane () ())
@@ -115,13 +65,14 @@
 		    'queue-value-changed-event
 		    sheet))
 
+(defmethod silica::gadget-value ((gadget motif-value-pane))
+  (if (sheet-direct-mirror gadget)
+      (tk::get-values (sheet-mirror gadget) :value)
+    (call-next-method)))
 
-
-(defmethod gadget-value ((gadget motif-value-pane))
-  (tk::get-values (sheet-mirror gadget) :value))
-
-(defmethod (setf gadget-value) (nv (gadget motif-value-pane))
-  (tk::set-values (sheet-mirror gadget) :value nv))
+(defmethod (setf silica::gadget-value) (nv (gadget motif-value-pane))
+  (when (sheet-mirror gadget)
+    (tk::set-values (sheet-mirror gadget) :value nv)))
 
 (defmethod queue-value-changed-event (widget sheet)
   (declare (ignore widget))
@@ -129,7 +80,7 @@
    (port sheet)
    (make-instance 'value-changed-gadget-event
 		  :gadget sheet
-		  :value (gadget-value sheet))))
+		  :value (silica::gadget-value sheet))))
 
 ;;; Motif widgets that support the activate callback
 
@@ -141,32 +92,6 @@
 		    'queue-active-event
 		    sheet))
 
-;;; Push button
-
-(defclass motif-push-button (motif-leaf-pane 
-			     silica::push-button
-			     action-gadget
-			     motif-action-pane
-			     sheet-permanently-enabled-mixin
-			     silica::foreground-background-and-text-style-mixin) 
-	  ((label-string :initarg :label-string :initform "")))
-
-(defmethod realize-pane-arglist (realizer (type (eql 'push-button))
-				 &rest args 
-				 &key (label ""))
-  (list* :label-string label
-	 (with-rem-keywords (args args '(:label))
-	   (apply #'call-next-method realizer type args))))
-
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button))
-  (values 'tk::xm-push-button 
-	  (list :label-string (slot-value sheet 'label-string))))
-
-;;; This widget knows how big it wants to be so asking it returns a
-;;; meaningful answer. ie.  Something other than the current size.
-
-;; This should support the arm-callback
-
 (defmethod queue-active-event (widget count sheet)
   (declare (ignore widget count))
   (distribute-event
@@ -174,20 +99,22 @@
    (make-instance 'activate-gadget-event
 		  :gadget sheet)))
 
+;;; Push button
 
-;; Drawing area
+(defclass motif-push-button (xt-leaf-pane 
+			     silica::push-button
+			     motif-action-pane) 
+	  ())
 
-(defclass motif-drawing-area (motif-leaf-pane 
-			      standard-sheet-input-mixin
-			      permanent-medium-sheet-output-mixin
-			      mute-repainting-mixin) ())
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-drawing-area))
-  (values 'tk::xm-drawing-area (list :margin-width 0 
-				     :resize-policy :none
-				     :margin-height 0)))
 
-(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget)
+(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button))
+  (declare (ignore port))
+  (with-accessors ((label silica::gadget-label)) sheet
+    (values 'tk::xm-push-button 
+	    (list :label-string label))))
+
+(defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area))
   (tk::add-callback widget 
 		    :expose-callback 
 		    'sheet-mirror-exposed-callback
@@ -196,7 +123,6 @@
 		    :input-callback 
 		    'sheet-mirror-input-callback
 		    sheet)
-
   (tk::add-event-handler widget
 			 '(:enter-window 
 			   :leave-window
@@ -213,35 +139,45 @@
 			 'sheet-mirror-event-handler
 			 sheet))
 
+;; Drawing area
+;; Who uses this anyway??????????????
+
+(defclass motif-drawing-area (xt-leaf-pane 
+			      standard-sheet-input-mixin
+			      permanent-medium-sheet-output-mixin
+			      mute-repainting-mixin) 
+	  ())
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-drawing-area))
+  (values 'tk::xm-drawing-area (list :margin-width 0 
+				     :resize-policy :none
+				     :margin-height 0)))
+
+(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-drawing-area) widget)
+  ;; Now does nothing
+  )
+
 ;;; Slider
 
-(defclass motif-slider (silica::client-overridability
-			motif-leaf-pane 
-			sheet-permanently-enabled-mixin
-			value-gadget 
+(defclass motif-slider (xt-leaf-pane
 			motif-value-pane
 			slider)
-	  ((value :initarg :value :initform nil)
-	   (orientation :initarg :orientation)) 
-  (:default-initargs :orientation :horizontal))
+	  ())
 
-(defmethod realize-pane-arglist (realizer (type (eql 'slider)) &rest args &key orientation)
-  (append (and orientation (list :orientation orientation))
-	  (with-rem-keywords (args args '(:orientation))
-	    (apply #'call-next-method realizer type args))))
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-slider))
-  (with-slots (orientation value) sheet
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet motif-slider))
+  (with-accessors ((orientation silica::gadget-orientation)
+		   (value silica::gadget-value)) sheet
     (values 'tk::xm-scale 
 	    (append
 	     (list :orientation orientation)
 	     (and value (list :value value))))))
 
-;; This should suport the drag callback
 
 (defmethod compose-space ((m motif-slider))
   (let ((x 16))
-    (ecase (slot-value m 'orientation)
+    (ecase (silica::gadget-orientation m)
       (:vertical
        (silica::make-space-req :width x
 			       :min-height x
@@ -256,22 +192,15 @@
 ;;; Scrollbar
 
 
-(defclass motif-scrollbar (motif-leaf-pane 
-			   silica::sheet-permanently-enabled-mixin
-			   gadget
+(defclass motif-scrollbar (xt-leaf-pane
 			   silica::scrollbar)
-	  ((orientation :initarg :orientation))
-  (:default-initargs :orientation :horizontal))
-
-(defmethod realize-pane-arglist (realizer (type (eql 'silica::scrollbar)) 
-				 &rest args &key orientation)
-  (list* :orientation orientation
-	 (with-rem-keywords (args args '(:orientation))
-			    (apply #'call-next-method realizer type args))))
+	  ())
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-scrollbar))
-  (values 'tk::xm-scroll-bar 
-	  (list :orientation (slot-value sheet 'orientation))))
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-scrollbar))
+  (with-accessors ((orientation silica::gadget-orientation)) sheet
+		  (values 'tk::xm-scroll-bar 
+			  (list :orientation orientation))))
 
 (defmethod (setf silica::scrollbar-size) (nv (sb motif-scrollbar))
   (tk::set-values (sheet-direct-mirror sb) :slider-size nv)
@@ -281,7 +210,8 @@
   (tk::set-values (sheet-direct-mirror sb) :value nv)
   nv)
 
-(defmethod silica::change-scrollbar-values ((sb motif-scrollbar) &rest args &key slider-size value)
+(defmethod silica::change-scrollbar-values ((sb motif-scrollbar) &rest args 
+					    &key slider-size value)
   (declare (ignore slider-size value))
   (apply #'tk::set-values
 	(sheet-direct-mirror sb)
@@ -308,7 +238,7 @@
 
 (defmethod compose-space ((m motif-scrollbar))
   (let ((x 16))
-    (ecase (slot-value m 'orientation)
+    (ecase (silica::gadget-orientation m)
       (:vertical
        (silica::make-space-req :width x
 			       :min-height x
@@ -324,6 +254,7 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+
 (defclass motif-top-level-sheet (
 				 #+ignore sheet
 				 mirrored-sheet-mixin
@@ -343,32 +274,33 @@
 (defmethod stream-read-char-no-hang ((x motif-top-level-sheet))
   nil)
 
-(defmethod add-sheet-callbacks :after ((port motif-port) (sheet
-							  motif-top-level-sheet) widget)
-
-  (tk::add-callback widget 
-		    :expose-callback 
-		    'sheet-mirror-exposed-callback
-		    sheet)
-  (tk::add-callback widget 
-		    :input-callback 
-		    'sheet-mirror-input-callback
-		    sheet)
-  (tk::add-event-handler widget
-			 '(:enter-window 
-			   :leave-window
-			   :pointer-motion-hint
-			   :pointer-motion
-			   :button1-motion
-			   :button2-motion
-			   :button3-motion
-			   :button4-motion
-			   :button5-motion
-			   :button-motion
-			   )
-			 0
-			 'sheet-mirror-event-handler
-			 sheet)
+(defmethod add-sheet-callbacks :after ((port motif-port) 
+				       (sheet motif-top-level-sheet)
+				       widget)
+
+;  (tk::add-callback widget 
+;		    :expose-callback 
+;		    'sheet-mirror-exposed-callback
+;		    sheet)
+;  (tk::add-callback widget 
+;		    :input-callback 
+;		    'sheet-mirror-input-callback
+;		    sheet)
+;  (tk::add-event-handler widget
+;			 '(:enter-window 
+;			   :leave-window
+;			   :pointer-motion-hint
+;			   :pointer-motion
+;			   :button1-motion
+;			   :button2-motion
+;			   :button3-motion
+;			   :button4-motion
+;			   :button5-motion
+;			   :button-motion
+;			   )
+;			 0
+;			 'sheet-mirror-event-handler
+;			 sheet)
   (tk::add-callback widget 
 		    :resize-callback 
 		    'sheet-mirror-resized-callback
@@ -381,7 +313,8 @@
 (defmethod compose-space ((sheet motif-top-level-sheet))
   (compose-space (car (sheet-children sheet))))
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-top-level-sheet))
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-top-level-sheet))
   (values 'tk::xm-drawing-area 
 	  (list :resize-policy :none
 		:margin-width 0 :margin-height 0)))
@@ -389,28 +322,31 @@
 
 ;;;; text field
 
-(defclass motif-text-field (motif-leaf-pane value-gadget
-			    sheet-permanently-enabled-mixin
+(defclass motif-text-field (xt-leaf-pane
 			    motif-value-pane motif-action-pane
 			    text-field)
 	  ())
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-text-field))
-  (values 'tk::xm-text-field nil))
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-text-field))
+  (with-accessors ((value silica::gadget-value)) sheet
+    (values 'tk::xm-text-field 
+	    (append
+	     (and value `(:value ,value))))))
+
 
 ;;; Toggle button
 
-(defclass motif-toggle-button (motif-leaf-pane 
-			       sheet-permanently-enabled-mixin
-			       motif-value-pane 
-			       value-gadget
+(defclass motif-toggle-button (xt-leaf-pane 
+			       motif-value-pane
 			       toggle-button)
-	  ((set :initarg :set :initform nil)
-	   (indicator-type :initarg :indicator-type :initform :some-of)
-	   (label :initform nil :initarg :label)))
+	  ())
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-toggle-button))
-  (with-slots (set label indicator-type) sheet
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-toggle-button))
+  (with-accessors ((set silica::gadget-value)
+		   (label silica::gadget-label)
+		   (indicator-type silica::gadget-indicator-type)) sheet
     (values 'tk::xm-toggle-button 
 	    (append (list :set set)
 		    (and label (list :label-string label))
@@ -419,104 +355,48 @@
 			    (:one-of :one-of-many)
 			    (:some-of :n-of-many)))))))
 
-(defmethod gadget-value ((gadget  motif-toggle-button))
-  (tk::get-values (sheet-mirror gadget) :set))
+(defmethod silica::gadget-value ((gadget motif-toggle-button))
+  (if (sheet-direct-mirror gadget)
+      (tk::get-values (sheet-mirror gadget) :set)
+    (call-next-method)))
 
-(defmethod (setf gadget-value) (nv (gadget motif-toggle-button))
-  (tk::set-values (sheet-mirror gadget) :set nv))
+(defmethod (setf silica::gadget-value) (nv (gadget motif-toggle-button))
+  (when (sheet-direct-mirror gadget)
+    (tk::set-values (sheet-mirror gadget) :set nv)))
 
-(defmethod sheet-shell (sheet)
-  (do ((w (sheet-mirror sheet) (tk::widget-parent w)))
-      ((typep w '(or tk::shell null))
-       w)))
-
-(defmethod xm-silica::add-sheet-callbacks :after
-	   ((port motif-port) 
-	    (sheet clim::extended-stream-sheet)
-	    (widget t))
+(defmethod xm-silica::add-sheet-callbacks :after ((port motif-port) 
+						  (sheet clim::extended-stream-sheet)
+						  (widget t))
   (declare (ignore sheet))
-  (tk::add-callback widget 
-		    :expose-callback 
-		    'sheet-mirror-exposed-callback
-		    sheet)
-  (tk::add-callback widget 
-		    :input-callback 
-		    'sheet-mirror-input-callback
-		    sheet)
-  (tk::add-event-handler widget
-			 '(:enter-window 
-			   :leave-window
-			   :pointer-motion-hint
-			   :pointer-motion
-			   :button1-motion
-			   :button2-motion
-			   :button3-motion
-			   :button4-motion
-			   :button5-motion
-			   :button-motion
-			   )
-			 0
-			 'sheet-mirror-event-handler
-			 sheet)
+;  (tk::add-callback widget 
+;		    :expose-callback 
+;		    'sheet-mirror-exposed-callback
+;		    sheet)
+;  (tk::add-callback widget 
+;		    :input-callback 
+;		    'sheet-mirror-input-callback
+;		    sheet)
+;  (tk::add-event-handler widget
+;			 '(:enter-window 
+;			   :leave-window
+;			   :pointer-motion-hint
+;			   :pointer-motion
+;			   :button1-motion
+;			   :button2-motion
+;			   :button3-motion
+;			   :button4-motion
+;			   :button5-motion
+;			   :button-motion
+;			   )
+;			 0
+;			 'sheet-mirror-event-handler
+;			 sheet)
+  ;; It would suprise me if we needed this.
   (tk::add-callback widget 
 		    :resize-callback 
 		    'sheet-mirror-resized-callback
 		    sheet))
 
-;;; scrolling stuff
-;
-;;;; Scroller Sheet -> xm-scrollbar, make some scrollbars also
-;;;; Viewport Sheet -> xm-drawing-area 
-;;;; Child of the viewport has its transform altered to accomplish the
-;;;; scrolling
-;
-;(defclass xm-scroller-sheet (motif-pane
-;			     gadget
-;			     mirrored-sheet-mixin
-;			     silica::sheet-single-child-mixin
-;			     mute-repainting-mixin
-;			     ask-widget-for-size-mixin)
-;	  (horizontal-scrollbar
-;	   vertical-scrollbar))
-;
-;(defmethod compose-space ((sheet xm-scroller-sheet))
-;  (let ((req (call-next-method)))
-;    (setf (silica::space-req-max-height req) silica::+fill+
-;	  (silica::space-req-max-width req) silica::+fill+)
-;    req))
-;
-;(defmethod initialize-instance :after ((scroller xm-scroller-sheet) &key contents)
-;  (let ((vp (make-instance 'xm-viewport :parent scroller)))
-;    (adopt-child vp contents)))
-;
-;(defmethod find-widget-class-and-initargs-for-sheet (port (sheet xm-scroller-sheet))
-;  (values 'tk::xm-scrolled-window
-;	  '(:scrolling-policy :application-defined
-;	    :scroll-bar-display-policy :static)))
-;
-;(defmethod realize-mirror :around ((port motif-port) (sheet xm-scroller-sheet))
-;  (let* ((m (call-next-method))
-;	 (sb1 (make-instance 'tk::xm-scroll-bar :parent m :orientation :horizontal))
-;	 (sb2 (make-instance 'tk::xm-scroll-bar :parent m :orientation
-;			     :vertical)))
-;    (setf (slot-value sheet 'horizontal-scrollbar) sb1
-;	  (slot-value sheet 'vertical-scrollbar) sb2)
-;    (tk::set-values m :horizontal-scroll-bar sb1 :vertical-scroll-bar sb2)
-;    (add-scrollbar-callbacks sheet)
-;    m))
-;
-;(defun add-scrollbar-callbacks (sheet)
-;  (with-slots (horizontal-scrollbar vertical-scrollbar) sheet
-;    (tk::add-callback horizontal-scrollbar
-;		      :value-changed-callback
-;		      'scrollbar-changed-callback
-;		      :horizontal
-;		      sheet)
-;    (tk::add-callback vertical-scrollbar
-;		      :value-changed-callback
-;		      'scrollbar-changed-callback
-;		      :vertical
-;		      sheet)))
 
 (defun scrollbar-changed-callback (widget which scroller)
   (let* ((vp (silica::sheet-child scroller))
@@ -547,10 +427,7 @@
 		     0
 		   (/ value (- 100 size)))))
 	  :y (bounding-rectangle-min-y viewport)))))))
-
-
 	
-
 ;;;;;;;;;;;;;;;
 
 (defclass xm-viewport (mirrored-sheet-mixin
@@ -583,174 +460,47 @@
    (silica::sheet-child vp)
    vp))
 
-;(defun update-scrollbar (horizontal-scrollbar minx maxx vminx vmaxx)
-;  (let  ((size (truncate (* 100 
-;			    (if (zerop (- maxx minx))
-;				1.0
-;				(min 1.0 (/ (- vmaxx vminx) (- maxx minx)))))))
-;	 (pos (min 1.0
-;		   (max 0.0
-;			(if (zerop (- (- maxx minx) (- vmaxx vminx)))
-;			    0.0
-;			    (/ (- vminx minx) 
-;				      (- (- maxx minx) (- vmaxx vminx))))))))
-;    (tk::set-values horizontal-scrollbar
-;		    :slider-size size
-;		    :value (min (- 100 size) 
-;				(truncate (* 100 pos))))))
-
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet xm-viewport))
+
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet xm-viewport))
   (values 'tk::xm-drawing-area
 	  '(:scrolling-policy :application-defined
 	    :margin-width 0 :margin-height 0
 	    :resize-policy :none
 	    :scroll-bar-display-policy :static)))
 
-; From the days when the parent used to be a motif scroll window
-;(defmethod realize-mirror :around ((port motif-port) (sheet xm-viewport))
-;  (let* ((m (call-next-method)))
-;    (tk::set-values (sheet-mirror (silica::sheet-parent sheet)) :work-window m)
-;    m))
-
-
-(defmethod add-sheet-callbacks  ((port motif-port) (sheet xm-viewport) widget)
+(defmethod add-sheet-callbacks  :after ((port motif-port) (sheet xm-viewport) widget)
+  ;; I wonder whether this is needed since it should not be resized by
+  ;; the toolkit and only as part of the goe management code that will
+  ;; recurse to children anyway
   (tk::add-callback widget 
 		    :resize-callback 
 		    'sheet-mirror-resized-callback
 		    sheet)
-  (tk::add-callback widget 
-		    :expose-callback 
-		    'sheet-mirror-exposed-callback
-		    sheet)
-  (tk::add-callback widget 
-		    :input-callback 
-		    'sheet-mirror-input-callback
-		    sheet)
-  (tk::add-event-handler widget
-			 '(:enter-window 
-			   :leave-window
-			   :pointer-motion-hint
-			   :pointer-motion
-			   :button1-motion
-			   :button2-motion
-			   :button3-motion
-			   :button4-motion
-			   :button5-motion
-			   :button-motion
-			   )
-			 0
-			 'sheet-mirror-event-handler
-			 sheet))
-
-;;; We have the viewport
-
-;;; Viewport describes the region that is being mapped onto
-
-
-(defmethod clim::pane-viewport-sheet (x)
-  (and (typep (silica::sheet-parent x) 'xm-silica::xm-viewport)
-       (silica::sheet-parent x)))
-
-(defmethod clim::pane-viewport (x)
-  (clim::pane-viewport-sheet x))
-
-(defmethod clim::pane-viewport-region (x)
-  (let ((vp (clim::pane-viewport-sheet x)))
-    (and vp
-	 (silica::xm-viewport-viewport vp))))
-
-(defun clim::pane-scroller (x)
-  (clim::pane-scroller-sheet x))
-
-(defun clim::update-region (stream width height &key no-repaint)
-  (when (or (> width (bounding-rectangle-width stream))
-	    (> height (bounding-rectangle-height stream)))
-    (setf (sheet-region stream)
-      (make-bounding-rectangle  0 0 
-				(max (bounding-rectangle-width stream) width)
-				(max (bounding-rectangle-height stream) height)))))
-
-(defun clim::scroll-extent (stream &key (x 0) (y 0))
-
-  ;; This should copy-area and then do a repaint of the new stuff.
-  ;; Perhaps for the time being we can just clear the current area and
-  ;; then repaint the whole thing
-  #+ignore-why-is-this-here
-  (setq y (min y (max (- (bounding-rectangle-height stream)
-			 (bounding-rectangle-height
-			  (clim::pane-viewport stream)))
-		      0)))
-  (let ((vp (clim::pane-viewport stream)))
-    (setf (sheet-transformation stream)
-      (make-translation-transformation (- x) (- y)))
-    (bounding-rectangle-set-position*
-     (silica::xm-viewport-viewport vp) x y)
-    (with-sheet-medium (medium vp)
-      (draw-rectangle*
-	medium
-	0 0 
-	(bounding-rectangle-width (silica::xm-viewport-viewport vp))
-	(bounding-rectangle-height (silica::xm-viewport-viewport vp))
-	:ink +background+
-	:filled t))
-    (clim::replay
-     (clim-internals::output-recording-stream-output-record stream)
-     stream
-     (silica::xm-viewport-viewport vp))))
-
-
-(defmethod find-widget-class-and-initargs-for-sheet 
-    ((port motif-port)
-     (sheet 
-      silica::foreground-background-and-text-style-mixin))
-  (multiple-value-bind
-      (class initargs)
-      (call-next-method)
-    (with-slots
-	(silica::foreground silica::background silica::text-style)
-	sheet
-      
-      ;; Background can either be a pixel of a bitmap
-      ;; Foreground has to be a pixel
-      ;; clx-decode-gadget-background
-      ;; clx-decode-gadget-foreground
-      
-      (when silica::background
-	(with-sheet-medium (medium sheet)
-	  (setf initargs
-	    (append (clx-decode-gadget-background medium sheet silica::background) 
-		    initargs))))
-      
-      (when silica::foreground
-	(with-sheet-medium (medium sheet)
-	  (setf initargs
-	    (append (clx-decode-gadget-foreground medium sheet silica::foreground)
-		    initargs))))
-
-      (when silica::text-style
-	(setf (getf initargs :font-list)
-	  (realize-text-style port silica::text-style)))
-
-      (values class initargs))))
-
-(defmethod clx-decode-gadget-background (medium sheet ink)
-  (declare (ignore sheet))
-  (let ((gc (clx-decode-ink ink medium)))
-    (if (tk::gcontext-tile gc)
-	(list :background-pixmap (tk::gcontext-tile gc))
-      (list :background (tk::gcontext-foreground gc)))))
-
-
-(defmethod clx-decode-gadget-foreground (medium sheet ink)
-  (declare (ignore sheet))
-  (let ((gc (clx-decode-ink ink medium)))
-    (if (tk::gcontext-tile gc)
-	(error "Gadget foreground cannot be pixmap")
-      (list :foreground (tk::gcontext-foreground gc)))))
-
+;  (tk::add-callback widget 
+;		    :expose-callback 
+;		    'sheet-mirror-exposed-callback
+;		    sheet)
+;  (tk::add-callback widget 
+;		    :input-callback 
+;		    'sheet-mirror-input-callback
+;		    sheet)
+;  (tk::add-event-handler widget
+;			 '(:enter-window 
+;			   :leave-window
+;			   :pointer-motion-hint
+;			   :pointer-motion
+;			   :button1-motion
+;			   :button2-motion
+;			   :button3-motion
+;			   :button4-motion
+;			   :button5-motion
+;			   :button-motion
+;			   )
+;			 0
+;			 'sheet-mirror-event-handler
+;			 sheet)
+  )
 
-;; Implementation of radio box
-;; should this be a composite-motif-pane
 
 ;; In some ways this behaves like a leaf since the management of the
 ;; children is left to the row column widget
@@ -760,17 +510,16 @@
 			    sheet-permanently-enabled-mixin
 			    silica::radio-box
 			    silica::pane
-			    gadget
 			    ask-widget-for-size-mixin)
-	   ((orientation :initarg :orientation)
-	    (current-selection :accessor radio-box-current-selection))
-  (:default-initargs :orientation :horizontal))
+	   ((current-selection :accessor radio-box-current-selection)))
 
 (defmethod adopt-child :after ((gadget motif-radio-box) child)
   (setf (silica::gadget-client child) gadget))
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-radio-box))
-  (with-slots (orientation) sheet
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-radio-box))
+  
+  (with-accessors ((orientation silica::gadget-orientation)) sheet
     (values 'tk::xm-radio-box
 	    (list :orientation orientation))))
 
@@ -789,13 +538,14 @@
 ;; it
 
 (defclass motif-frame-pane (mirrored-sheet-mixin
-			sheet-single-child-mixin
-			sheet-permanently-enabled-mixin
-			silica::pane
-			ask-widget-for-size-mixin)
-	   ())
+			    sheet-single-child-mixin
+			    sheet-permanently-enabled-mixin
+			    silica::pane
+			    ask-widget-for-size-mixin)
+	  ())
 
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-frame-pane))
+(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
+						     (sheet motif-frame-pane))
   (values 'tk::xm-frame nil))
 	  
 	  
diff --git a/tk-silica/xm-graphics.lisp b/tk-silica/xm-graphics.lisp
index 8452b833..eea98f86 100644
--- a/tk-silica/xm-graphics.lisp
+++ b/tk-silica/xm-graphics.lisp
@@ -18,498 +18,20 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-graphics.cl,v 1.2 92/01/02 15:09:46 cer Exp Locker: cer $
+;; $fiHeader: xm-graphics.cl,v 1.3 92/01/06 20:44:02 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
+;; Motif specific
+;;; Is there any need for this??
 
 (defmethod make-medium ((port motif-port) sheet)
   (make-instance 'motif-medium
 		 :port port
 		 :sheet sheet))
 
-(defclass motif-medium (medium)
-  ((foreground-gcontext :reader medium-foreground-gcontext :initform nil)
-   (background-gcontext :reader medium-background-gcontext :initform nil)
-   (flipping-gcontext :reader medium-flipping-gcontext :initform nil)
-   (ink-table :initform (make-hash-table))))
+(defclass motif-medium (xt-medium) 
+	  ())
 
+;; End of the motif specific code
 
-
-(defmethod engraft-medium :after (medium (port motif-port) sheet)
-  (with-slots 
-      (foreground-gcontext background-gcontext flipping-gcontext) 
-      medium
-    (let ((drawable (tk::display-root-window (port-display port))))
-      (unless foreground-gcontext
-	(setf foreground-gcontext (tk::make-instance 'tk::gcontext :drawable drawable)))
-      (unless background-gcontext
-	(setf background-gcontext (tk::make-instance 'tk::gcontext
-						     :drawable drawable)))
-      (unless flipping-gcontext
-	(setf flipping-gcontext
-	  (tk::make-instance 'tk::gcontext 
-			     :function boole-xor
-			     :drawable drawable)))
-      (recompute-gcs medium))))
-
-(defmethod silica::degraft-medium :after (medium (port motif-port) sheet)
-  (declare (ignore sheet))
-  (with-slots 
-      (foreground-gcontext background-gcontext flipping-gcontext)
-      medium
-    (macrolet ((loose-gc (gc)
-		 `(when ,gc
-		    (tk::free-gcontext ,gc)
-		    (setf ,gc nil))))
-      (loose-gc foreground-gcontext)
-      (loose-gc background-gcontext)
-      (loose-gc flipping-gcontext))))
-
-(defun recompute-gcs (medium)
-  (with-slots 
-   (foreground-gcontext background-gcontext flipping-gcontext)
-   medium
-   (let ((foreground-pixel
-	  (clx-decode-color medium (medium-foreground medium)))
-	 (background-pixel
-	  (clx-decode-color medium (medium-background medium))))
-     (setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel
-	   (tk::gcontext-background foreground-gcontext) background-pixel
-	   (tk::gcontext-foreground background-gcontext) background-pixel
-	   (tk::gcontext-foreground flipping-gcontext)
-	   (logxor foreground-pixel background-pixel)))))
-      
-
-
-(defmethod (setf medium-background) :after (ink (medium motif-medium))
-  (recompute-gcs medium))
-
-(defmethod (setf medium-foreground) :after (ink (medium motif-medium))
-  (recompute-gcs medium))
-
-(defmethod (setf medium-ink) :after (ink (medium motif-medium))
-  (recompute-gcs medium))
-
-;;;  Below is stuff from clx-implementation
-
-(defgeneric clx-decode-ink (ink medium))
-
-(defmethod clx-decode-ink ((ink (eql +foreground+)) medium)
-  (slot-value medium 'foreground-gcontext))
-
-(defmethod clx-decode-ink ((ink (eql +background+)) medium)
-  (slot-value medium 'background-gcontext))
-
-(defmethod clx-decode-ink ((ink (eql +flipping-ink+)) stream)
-  (slot-value stream 'flipping-gcontext))
-
-(defmethod clx-decode-ink ((ink color) medium)
-  (let ((ink-table (slot-value medium 'ink-table)))
-    (or (gethash ink ink-table)
-	(setf (gethash ink ink-table)
-	      (let ((new-gc 
-		     (make-instance 'tk::gcontext
-				    :drawable (tk::display-root-window 
-					       (port-display (port medium))))))
-		(setf (tk::gcontext-foreground new-gc)
-		      (clx-decode-color medium ink))
-		new-gc)))))
-
-(defmethod clx-decode-ink ((ink contrasting-ink) stream)
-  (clx-decode-ink (make-color-for-contrasting-ink ink) stream))
-
-      
-
-(defmethod clx-decode-color ((medium motif-medium) (x (eql +foreground+)))
-  (with-slots (foreground-gcontext) medium
-    (tk::gcontext-foreground foreground-gcontext)))
-
-(defmethod clx-decode-color ((medium motif-medium) (x (eql +background+)))
-  (with-slots (background-gcontext) medium
-    (tk::gcontext-foreground background-gcontext)))
-
-
-(defmethod clx-decode-color ((stream motif-medium) (ink standard-opacity))
-  (if (> (slot-value ink 'clim-utils::value) 0.5)
-      (clx-decode-color stream +foreground+)
-    (clx-decode-color stream +background+)))
-
-(defmethod clx-decode-color ((medium motif-medium) (ink color))
-  (or (gethash ink (port-color-cache (port medium)))
-      (setf (gethash ink (port-color-cache (port medium)))
-	(multiple-value-bind
-	    (red green blue)
-	    (color-rgb ink)
-	  (tk::allocate-color
-	   (tk::default-colormap (port-display (port medium)))
-	   (make-instance 'tk::color
-			  :red (truncate (* 65356 red))
-			  :green (truncate (* 65356 green))
-			  :blue (truncate (* 65356 blue))))))))
-
-
-(defmethod clx-adjust-ink ((medium motif-medium) gc ink line-style x-origin y-origin)
-  ;; This is used to adjust for the line-style
-  (declare (ignore ink))
-
-  (let ((thickness (silica::line-style-thickness line-style)))
-    (if (< thickness 2)
-	(setq thickness 0))
-    (setf (tk::gcontext-line-width gc) (round thickness)))
-  
-  (setf (tk::gcontext-cap-style gc)
-    (ecase (silica::line-style-cap-shape line-style)
-      (:butt :butt)
-      (:square :projecting)
-      (:round :round)
-      (:no-end-point :not-last)))
-  
-  (setf (tk::gcontext-join-style gc)
-    (ecase (silica::line-style-joint-shape line-style)
-      ((:miter :none) :miter)
-      (:bevel :bevel)
-      (:round :round)))
-  
-  
-  (when (eq (tk::gcontext-fill-style gc) :tiled)
-    (setf (tk::gcontext-ts-x-origin gc) x-origin
-	  (tk::gcontext-ts-y-origin gc) y-origin))
-  
-  gc)
-
-(defmethod clx-decode-ink :around ((ink t) (medium motif-medium))
-  (let ((gc (call-next-method)))
-    #+ignore
-    (setf (tk::gcontext-clip-mask gc) 
-	  (compute-gcontext-clip-mask medium))
-    gc))
-
-(defmethod compute-gcontext-clip-mask (medium)
-  (with-bounding-rectangle* 
-   (minx miny maxx maxy)
-   (sheet-device-region (medium-sheet medium))
-   (list (truncate minx)
-	 (truncate miny)
-	 (truncate maxx)
-	 (truncate maxy))))
-      
-(defun devicize-point (transform x y)
-  (multiple-value-setq (x y)
-      (transform-point* transform x y))
-  (values (truncate x) (truncate y)))
-
-(defun devicize-distance (transform x y)
-  (multiple-value-setq (x y)
-      (transform-distance transform x y))
-  (values (truncate x) (truncate y)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defmethod port-draw-line* ((port motif-port)
-			    sheet
-			    medium
-			    x1 y1 x2 y2)
-  (let ((transform (compose-transformations
-		    (medium-transformation medium)
-		    (sheet-device-transformation sheet))))
-    (multiple-value-setq (x1 y1) (devicize-point transform x1 y1))
-    (multiple-value-setq (x2 y2) (devicize-point transform x2 y2)))
-  (tk::draw-line
-   (tk::widget-window (sheet-mirror sheet))
-   (clx-adjust-ink medium
-		   (clx-decode-ink (medium-ink medium) medium)
-		   (medium-ink medium)
-		   (medium-line-style medium)
-		   (min x1 x2)
-		   (min y1 y2))
-   x1
-   y1
-   x2
-   y2))
-
-
-(defmethod port-draw-rectangle* ((port motif-port)
-				 sheet
-				 medium
-				 x1 y1 x2 y2 filled)
-  (let ((transform (compose-transformations
-		    (medium-transformation medium)
-		    (sheet-device-transformation sheet))))
-    (if (rectilinear-transformation-p transform)
-	(progn
-	  (multiple-value-setq (x1 y1) (devicize-point transform x1 y1))
-	  (multiple-value-setq (x2 y2) (devicize-point transform x2 y2))
-	  (tk::draw-rectangle
-	   (tk::widget-window (sheet-mirror sheet))
-	   (clx-adjust-ink medium
-			   (clx-decode-ink (medium-ink medium) medium)
-			   (medium-ink medium)
-			   (medium-line-style medium)
-			   (min x1 x2)
-			   (min y1 y2))
-	   (min x1 x2)
-	   (min y1 y2)
-	   (abs (- x2 x1))
-	   (abs (- y2 y1))
-	   filled))
-      (port-draw-transformed-rectangle*
-       port sheet medium x1 y1 x2 y2 filled))))
-      
-
-
-
-(defmethod port-draw-text* ((port motif-port)
-			    sheet medium string-or-char x y start end align-x align-y
-			    towards-point towards-x towards-y
-			    transform-glyphs)
-  
-  (let ((transform (compose-transformations
-		    (medium-transformation medium)
-		    (sheet-device-transformation sheet)))
-	(font (realize-text-style port (medium-text-style medium))))
-    
-    (multiple-value-setq (x y) (devicize-point transform x y))
-    (when (typep string-or-char 'character)
-      (setq string-or-char (string string-or-char)))
-    
-    (ecase align-x
-      (:center (decf x (floor (silica::text-size 
-			       sheet
-			       string-or-char
-			       :text-style
-			       (medium-text-style medium)
-			       :start start
-			       :end end)
-			      2)))
-      (:left nil))
-
-    (ecase align-y
-      (:center (decf y (- (text-style-descent  (medium-text-style medium) medium)
-			  (floor (text-style-height  (medium-text-style medium) medium)
-				 2))))
-      (:base-line nil)
-      (:top 
-       (incf y (tk::font-ascent font))))
-
-    (let ((gc (clx-decode-ink (medium-ink medium) medium)))
-      (setf (tk::gcontext-font gc) font)
-      (tk::draw-string
-       (tk::widget-window (sheet-mirror sheet))
-       gc
-       x y
-       string-or-char
-       start end))))
-
-
-(defmethod silica::port-write-string-internal ((port motif-port)
-					       medium
-					       glyph-buffer 
-					       start 
-					       end 
-					       x-font 
-					       color 
-					       x
-					       y)
-  (unless (= start end)
-    (let* ((sheet (medium-sheet medium))
-	   (transform (compose-transformations
-		       (medium-transformation medium)
-		       (sheet-device-transformation sheet)))
-	   (window (tk::widget-window (sheet-mirror sheet) nil))
-	   (font x-font))
-    
-      ;; At one point we checked to see whether the widget is unrealized
-      ;; or not.  Can we draw on disabled sheets?
-    
-      (multiple-value-setq (x y) (devicize-point transform x y))
-    
-      (incf y (tk::font-ascent font))
-
-      (let ((gc (clx-decode-ink (medium-ink medium) medium)))
-	(setf (tk::gcontext-font gc) font)
-	(etypecase glyph-buffer
-	  ((simple-array (unsigned-byte 16))
-	   (x11::xdrawstring16
-	    (tk::display-handle (tk::object-display window))
-	    (tk::object-handle window)
-	    (tk::object-handle gc)
-	    x 
-	    y
-	    glyph-buffer
-	    (- end start))))))))
-
-
-(defmethod port-beep ((port motif-port) (sheet t))
-  (x11:xbell (tk::display-handle (port-display port)) 100))
-
-
-(defmethod silica::port-draw-ellipse* ((port motif-port)
-				       sheet
-				       medium
-				       center-x
-				       center-y
-				       radius-1-dx 
-				       radius-1-dy 
-				       radius-2-dx
-				       radius-2-dy 
-				       start-angle 
-				       end-angle 
-				       filled)
-  (let ((transform (compose-transformations
-		    (medium-transformation medium)
-		    (sheet-device-transformation sheet))))
-    (multiple-value-setq (center-x center-y) 
-      (devicize-point transform center-x center-y))
-    
-
-    (multiple-value-setq (radius-1-dx radius-1-dy) 
-      (devicize-distance transform  radius-1-dx radius-1-dy))
-    
-
-    (multiple-value-setq (radius-2-dx radius-2-dy) 
-      (devicize-distance transform radius-2-dx
-		       radius-2-dy))
-    
-    (tk::draw-ellipse
-     (tk::widget-window (sheet-mirror sheet))
-     (clx-adjust-ink medium
-		     (clx-decode-ink (medium-ink medium) medium)
-		     (medium-ink medium)
-		     (medium-line-style medium)
-		     (- center-x 
-			(if (zerop radius-1-dx)
-			    radius-2-dx
-			  radius-1-dx))
-		     (- center-y 
-			(if (zerop radius-1-dy)
-			    radius-2-dy
-			  radius-1-dy)))
-     center-x
-     center-y
-     radius-1-dx 
-     radius-1-dy 
-     radius-2-dx
-     radius-2-dy 
-     start-angle 
-     end-angle 
-     filled)))
-   
-(ff::def-c-type (xpoint-array :in-foreign-space) 2 x11::xpoint)
-  
-(defmethod silica::port-draw-polygon* ((port motif-port)
-				       sheet
-				       medium
-				       list-of-x-and-ys
-				       closed
-				       filled)
-  (let* ((transform (compose-transformations
-		     (medium-transformation medium)
-		     (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)))))
-	 (window (tk::widget-window (sheet-mirror sheet)))
-	 (minx most-positive-fixnum)
-	 (miny most-positive-fixnum))
-		 
-    (do ((ps list-of-x-and-ys (cddr ps))
-	 (i 0 (1+ i))
-	 r)
-	((null ps)
-	 (setq list-of-x-and-ys (nreverse r)))
-      (multiple-value-bind
-	  (x y)
-	  (devicize-point transform (car ps) (cadr ps))
-	(minf minx x)
-	(minf miny y)
-	(setf (xpoint-array-x points i) x
-	      (xpoint-array-y points i) y)))
-    
-    (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)))
-    
-    (if filled
-	(x11:xfillpolygon
-	 (tk::display-handle (tk::object-display window))
-	 (tk::object-handle window)
-	 (tk::object-handle (clx-adjust-ink medium
-					    (clx-decode-ink (medium-ink medium) medium)
-					    (medium-ink medium)
-					    (medium-line-style medium)
-					    minx
-					    miny))
-	 points
-	 npoints
-	 x11:complex
-	 x11:coordmodeorigin)
-      (x11:xdrawlines
-       (tk::display-handle (tk::object-display window))
-       (tk::object-handle window)
-       (tk::object-handle (clx-adjust-ink medium
-					  (clx-decode-ink (medium-ink medium) medium)
-					  (medium-ink medium)
-					  (medium-line-style medium)
-					  minx
-					  miny))
-       points
-       npoints
-       x11:coordmodeorigin))))
-
-
-(defmethod clx-decode-ink ((ink rectangular-tile) medium)
-  (multiple-value-bind (pattern width height)
-      (decode-rectangular-tile ink)
-    (clx-decode-pattern pattern medium width height t)))
-
-(defmethod clx-decode-ink ((ink pattern) medium)
-  (clx-decode-pattern ink medium))
-    
-(defmethod clx-decode-pattern ((pattern pattern) medium &optional width height tiled-p)    
-  (let ((ink-table (slot-value medium 'ink-table)))
-    (or  (gethash pattern ink-table)
-	 (setf (gethash pattern ink-table)
-	   (multiple-value-bind
-	       (array designs)
-	       (decode-pattern pattern)
-	     (let ((image-data (make-array (array-dimensions array))))
-	       (dotimes (w (array-dimension array 1))
-		 (dotimes (h (array-dimension array 0))
-		   (setf (aref image-data h w)
-		     (clx-decode-color medium 
-				       (elt designs (aref array h w))))))
-	       (let* ((pattern-height (array-dimension array 0))
-		      (pattern-width (array-dimension array 1))
-		      (image (make-instance 
-			      'tk::image
-			      :width pattern-width
-			      :height pattern-height
-			      :data image-data
-			      :depth 8 ;; hardwire
-			      ))
-		      (gc 
-		       (make-instance 'tk::gcontext
-				      :drawable (tk::display-root-window 
-						 (port-display (port
-								medium)))))
-		      (pixmap 
-		       (make-instance 'tk::pixmap
-				      :drawable (tk::display-root-window 
-						 (port-display (port
-								medium)))
-				    
-				      :width pattern-width
-				      :height pattern-height
-				      :depth 8)))
-		 (tk::put-image pixmap gc image :x 0 :y 0)
-		 (setf (tk::gcontext-tile gc) pixmap
-		       (tk::gcontext-fill-style gc) :tiled)
-		 gc)))))))
-		
-		
-	     
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 635f28a0..358e5b41 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,505 +18,27 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.cl,v 1.3 92/01/06 20:44:03 cer Exp Locker: cer $
+;; $fiHeader: xm-silica.cl,v 1.4 92/01/08 14:58:42 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
+;; Motif specific stuff
+
+(defclass motif-port (xt-port) 
+	  ())
 
 (defmethod find-port-type ((type (eql ':motif)))
   'motif-port)
 
-(defclass motif-port (port)
-  ((application-shell :reader port-application-shell)
-   (display :reader port-display)
-   (context :reader port-context)
-   ))
-  
-(defmethod initialize-instance :after ((port motif-port) &key server-path)
-  (destructuring-bind
-      (ignore &key display) server-path
-    (declare (ignore ignore))
-    (multiple-value-bind
-	(context display application-shell)
-	(initialize-motif-toolkit display)
-      (setf (slot-value port 'application-shell) application-shell
-	    (slot-value port 'context) context
-	    (slot-value port 'display) display)
-      (initialize-xlib-display-device port display))))
-
-(defvar *clx-font-families* '((:fix "*-courier-*")
-			      (:sans-serif "*-helvetica-*")
-			      (:serif "*-charter-*" "*-new century schoolbook-*"
-			       "*-times-*")))
-
-(defun disassemble-x-font-name (name)
-  (let ((cpos 0)
-	(tokens nil))
-    (loop
-      (let ((dpos (position #\- name :start cpos)))
-	(when (null dpos)
-	  (push (subseq name cpos) tokens)
-	  (return))
-	(push (if (= cpos dpos)
-		  nil
-		  (subseq name cpos dpos))
-	      tokens)
-	(setf cpos (1+ dpos))))
-    (reverse tokens)))
-
-
-(defvar *clx-fallback-font* "8x13"
-  "When non NIL and nothing better exists use this as the fallback font")
-
-(defmethod initialize-xlib-display-device (display-device display)
-  
-  (setf (silica::device-undefined-text-style display-device)
-    (silica::standardize-text-style display-device
-			    *standard-character-set*
-			    (make-text-style
-			     :stand-in-for-undefined-style :roman
-			     10)))
-  
-  (let* ()
-    (flet ((font->text-style (font family)
-	     (let* ((tokens (disassemble-x-font-name font))
-		    (italic (member (fifth tokens) '("i" "o") :test #'equalp))
-		    (bold (equalp (fourth tokens) "Bold"))
-		    (face (if italic
-			      (if bold '(:bold :italic) :italic)
-			    (if bold :bold :roman)))
-		    (designed-point-size (parse-integer (ninth tokens)))
-		    (designed-y-resolution (parse-integer (nth 10 tokens)))
-		    (point-size (float designed-point-size))
-		    (size (/ point-size 10)))
-	       (make-text-style family face size))))
-      (dolist (family-stuff *clx-font-families*)
-	(let ((family (car family-stuff)))
-	  (dolist (font-pattern (cdr family-stuff))
-	    (dolist (xfont (tk::list-font-names display font-pattern))
-	      (let ((text-style (font->text-style xfont family)))
-		;; prefer first font satisfying this text style, so
-		;; don't override if we've already defined one.
-		(unless (silica::text-style-mapping-exists-p
-			 display-device *standard-character-set* text-style t)
-		  (silica::add-text-style-mapping display-device *standard-character-set*
-					  text-style xfont)))))
-	  ;; Now build the logical size alist for the family
-	  
-	  
-	  ))
-      
-      (let (temp)
-	(cond ((setq temp
-		 (dolist (family *clx-font-families*)
-		   (when (silica::text-style-mapping-exists-p display-device 
-						      *standard-character-set*
-						      `(,(car family) :roman 10))
-		     (return (make-text-style (car family) :roman 10)))))
-	       (silica::add-text-style-mapping display-device *standard-character-set*
-				       (silica::device-undefined-text-style display-device)
-				       #+ignore *undefined-text-style*
-				       temp))
-
-	      ;; Perhaps we should look for some other conveniently sized
-	      ;; fonts.
-	
-	      (*clx-fallback-font*
-	       (silica::add-text-style-mapping display-device 
-				       *standard-character-set*
-				       (silica::device-undefined-text-style display-device)
-				       #+ignore *undefined-text-style*
-				       (make-instance 'tk::font 
-						      :display display
-						       :name *clx-fallback-font*)))
-	
-	;;; Perhaps we should just grab the first font we can find.
-	
-	      (t
-	       (error "Unable to determine default font")))))))
-
-(defparameter *clx-logical-size-alist*
-	      '((:tiny       6)
-		(:very-small 8)
-		(:small	     10)
-		(:normal     12)
-		(:large	     14)
-		(:very-large 18)
-		(:huge	     24)))
-
-(defmethod silica::standardize-text-style ((display-device motif-port) character-set style)
-  (silica::standardize-text-style-1
-   display-device style character-set *clx-logical-size-alist*))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmethod silica::destroy-mirror ((port motif-port) sheet)
-  (tk::destroy-widget (sheet-direct-mirror sheet)))
-
-(defmethod realize-mirror ((port motif-port) sheet)
-  (multiple-value-bind
-      (class initargs)
-      (find-widget-class-and-initargs-for-sheet port sheet)
-    (let ((widget (apply #'make-instance class
-			 :parent (find-widget-parent port sheet)
-			 :managed (sheet-enabled-p sheet)
-			 initargs)))
-      (add-sheet-callbacks port sheet widget)
-      widget)))
-
-(defmethod add-sheet-callbacks ((port motif-port) sheet (widget t))
-  (declare (ignore sheet)))
-
-(defmethod sheet-mirror-event-handler (widget event sheet)
-  (multiple-value-bind
-      (same-p root child root-x root-y native-x native-y mask)
-      (tk::query-pointer (tk::widget-window widget))
-    (declare (ignore same-p root child root-x root-y))
-    (let ((modifiers (logand #16rff mask))
-	  (button (ash mask -8)))
-      (distribute-event
-       (port sheet)
-       (ecase (tk::event-type event)
-	 (:leave-notify
-	  (make-instance 'pointer-exit-event
-			 :native-x native-x
-			 :native-y native-y
-			 :button (x-button->silica-button button)
-			 :modifiers modifiers
-			 :sheet sheet))
-	 (:enter-notify
-	  (make-instance 'pointer-enter-event
-			 :native-x native-x
-			 :native-y native-y
-			 :button (x-button->silica-button button)
-			 :modifiers modifiers
-			 :sheet sheet))
-	 (:motion-notify
-	  (make-instance 'pointer-motion-event
-			 :native-x native-x
-			 :native-y native-y
-			 :button (x-button->silica-button button)
-			 :modifiers modifiers
-			 :sheet sheet)))))))
-
-(defun x-button->silica-button (button)
-  (ecase button
-    (0 nil)
-    (4 
-     (warn "got an event 4")
-     silica::+pointer-right-button+)
-    (#.x11::button3 silica::+pointer-right-button+)
-    (#.x11::button2 silica::+pointer-middle-button+)
-    (#.x11::button1 silica::+pointer-left-button+)))
-
-(defmethod sheet-mirror-resized-callback (widget window event sheet)
-  (declare (ignore widget window event))
-  (dispatch-event
-   sheet
-   (let ((r (mirror-region (port sheet) sheet)))
-     (make-instance 'window-configuration-event
-		    :native-region r
-		    :region (untransform-region
-			     (sheet-native-transformation
-			      sheet)
-			     r)
-		    :sheet sheet))))
-
-#+ignore
-(mirror-region-updated (port sheet) sheet)
-
-(defmethod sheet-mirror-exposed-callback (widget window event sheet)
-  (declare (ignore widget window))
-  (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
-     sheet
-     (make-instance 'window-repaint-event
-		    :native-region (make-rectangle* minx miny maxx maxy)
-		    :region (untransform-region
-			     (sheet-native-transformation sheet)
-			     (make-rectangle* minx miny maxx maxy))
-		    :sheet sheet))))
-
-(defmethod sheet-mirror-input-callback (widget window event sheet)
-  (declare (ignore widget window))
-
-  (ecase (tk::event-type event)
-    (:key-press
-     (distribute-event
-      (port sheet)
-      (multiple-value-bind
-	  (ignore character keysym)
-	  (tk::lookup-string event)
-	(declare (ignore ignore))
-	(make-instance 'key-press-event
-		       :key-name keysym
-		       :character (and (= (length character) 1)
-				       (aref character 0))
-		       :sheet sheet
-		       :modifiers (x11::xkeyevent-state event)))))
-    
-    (:key-release
-     (distribute-event
-      (port sheet)
-      (multiple-value-bind
-	  (ignore character keysym)
-	  (tk::lookup-string event)
-	(declare (ignore ignore))
-	(make-instance 'key-release-event
-		       :key-name keysym
-		       :character (and (= (length character) 1)
-				       (aref character 0))
-		       :sheet sheet
-		       :modifiers (x11::xkeyevent-state event)))))
-    
-    (:button-press
-     (distribute-event
-      (port sheet)
-      (make-instance 'pointer-press-event
-		     :sheet sheet
-		     :x :??
-		     :y :??
-		     :modifiers (x11::xkeyevent-state event)
-		     :button (x-button->silica-button 
-			      (x11::xbuttonevent-button event))
-		     :native-x (x11::xbuttonevent-x event)
-		     :native-y (x11::xbuttonevent-y event))))
-    (:button-release
-     (distribute-event
-      (port sheet)
-      (make-instance 'pointer-release-event
-		     :sheet sheet
-		     :x :??
-		     :y :??
-		     :modifiers (x11::xkeyevent-state event)
-		     :button (x-button->silica-button 
-			      (x11::xbuttonevent-button event))
-		     :native-x (x11::xbuttonevent-x event)
-		     :native-y (x11::xbuttonevent-y event))))))
-
-(defmethod find-widget-class-and-initargs-for-sheet (port (sheet sheet))
-  (declare (ignore port))
-  (values 'xm-drawing-area (list :resize-policy :grow)))
-
-(defmethod find-widget-class-and-initargs-for-sheet :around (port (sheet sheet))
-  (declare (ignore port))
-  (multiple-value-bind
-      (class initargs)
-      (call-next-method)
-    (setq initargs (set-mirror-geometry sheet initargs))
-    (values class initargs)))
-
-
-(defmethod set-mirror-geometry (sheet initargs)
-  (unless (getf initargs :x)
-    (multiple-value-bind
-	(left top right bottom)
-	(sheet-actual-native-edges sheet)
-      (setf (getf initargs :x) left
-	    (getf initargs :y) top
-	    (getf initargs :width) (- right left)
-	    (getf initargs :height) (- bottom top))))
-  initargs)
-
-;; If we are creating a top level sheet then we have to create a shell
-;; for it
-
-(defmethod find-widget-parent (port sheet)
-  (let ((ma (sheet-mirrored-ancestor sheet)))
-    (if (graftp ma)
-	(multiple-value-bind
-	    (class initargs)
-	    (find-shell-class-and-initargs port sheet)
-	  (apply #'make-instance class
-		 :parent (port-application-shell port)
-		 initargs))
-      (sheet-mirror ma))))
-
-(defmethod find-shell-class-and-initargs (port sheet)
-  (values 'top-level-shell 
-	  ;; Need this so that an interactive pane can have children
-	  ;; but still accept the focus
-	  '(:keyboard-focus-policy :pointer)))
-
-(defmethod enable-mirror (port sheet)
-  (declare (ignore port))
-  (let ((mirror (sheet-mirror sheet)))
-    (typecase (widget-parent mirror)
-      (null)
-      (top-level-shell
-       ;; this is a nasty hack just to make sure that the child is managed.
-       ;; top-level-sheets are created unmanaged because they are
-       ;; disabled to we have to do not!
-       (manage-child mirror)
-       (popup (widget-parent mirror)))
-      (t
-       (manage-child mirror)))))
-
-(defmethod disable-mirror (port sheet)
-  (declare (ignore port))
-  (let ((mirror (sheet-mirror sheet)))
-    (when mirror
-      (typecase (widget-parent mirror)
-	(null)
-	(top-level-shell
-	 (tk::popdown (widget-parent mirror)))
-	(t
-	 (tk::unmanage-child mirror))))))
-
-(defmethod realize-graft ((port motif-port) graft)
-  ;; Set the width etc etc
-  (setf (sheet-direct-mirror graft) (port-application-shell port))
-  ;; Mess with the region
-  ;; Mess with the native transformation
-  )
-
-(defmethod mirror-region* ((port motif-port) sheet)
-  (when (sheet-mirror sheet)
-    (multiple-value-bind
-	(x y width height)
-	(get-values (sheet-mirror sheet) :x :y :width :height)
-      (values x y 
-	      (+ x width)
-	      (+ y height)))))
-
-(defmethod mirror-region ((port motif-port) sheet)
-  (multiple-value-call #'make-rectangle*
-    (mirror-region* port sheet)))
-
-(defmethod mirror-inside-region* ((port motif-port) sheet)
-  (multiple-value-bind
-      (minx miny maxx maxy)
-      (mirror-region* port sheet)
-    (values 0 0 (- maxx minx) (- maxy miny))))
-
-(defmethod mirror-native-edges* ((port motif-port) sheet)
-  (let* ((mirror (sheet-direct-mirror sheet)))
-    (multiple-value-bind
-	(x y width height)
-	(get-values mirror :x :y :width :height)
-      (values x y (+ x width) (+ y height)))))
-
-(defmethod mirror-inside-edges* ((port motif-port) sheet)
-  (multiple-value-bind
-      (a b c d)
-      (mirror-native-edges* port sheet)
-    (values 0 0 (- c a) (- d b))))
-
-(defmethod set-sheet-mirror-edges* ((port motif-port) sheet 
-				    target-left target-top
-				    target-right target-bottom)
-  (let ((w (- target-right  target-left))
-	(h (- target-bottom target-top)))
-    (tk::set-values (sheet-direct-mirror sheet)
-		    :x target-left  
-		    :y target-top
-		    :width w
-		    :height h)
-    (multiple-value-bind
-	(nx ny nw nh)
-	(tk::get-values (sheet-direct-mirror sheet) :x :y :width
-			:height)
-      (when (or (/= target-left nx)
-		(/= target-top ny)
-		(/= w nw)
-		(/= h nh))
-	(warn "Geo set fail, ~S, ~S,~S"
-	      sheet
-	       (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))
-
-
-(defmethod port-force-output ((port motif-port))
-  nil)
-
-
-(defmethod port-glyph-for-character ((port motif-port)
-					     character
-					     appearance 
-					     &optional
-					     our-font)
-  (let* ((index (char-int character))
-	 (x-font (or our-font
-		   (realize-text-style port appearance)))
-	 (escapement-x (tk::char-width x-font index))
-	 (escapement-y 0)
-	 (origin-x 0)
-	 (origin-y (tk::font-ascent x-font))
-	 (bb-x escapement-x)
-	 (bb-y (+ origin-y (tk::font-descent x-font))))
-    (when (zerop escapement-x) (break))
-    (values index x-font escapement-x escapement-y
-	    origin-x origin-y bb-x bb-y)))
-
-(defmethod silica::text-size (medium string &key text-style start end)
-  (when (characterp string)
-    (setq string (string string)
-	  start 0
-	  end nil))
-  (unless start (setq start 0))
-  (unless end (setq end (length string)))
-  (clim::stream-string-output-size medium string
-			     :start start :end end :text-style text-style))
-  
-
-  
-(defmethod realize-text-style (port font)
-  (silica::text-style-mapping port nil font nil))
-
-
-
-(defmethod text-style-mapping :around ((device motif-port)
-				       character-set 
-				       text-style 
-				       etc)
-  (declare (ignore etc))
-  (let ((font (call-next-method)))
-    (when (or (stringp font) (symbolp font))
-      (let* ((font-name (string font)))
-	(setf font (make-instance 'tk::font 
-				    :display (port-display device)
-				    :name font-name))
-	(add-text-style-mapping
-	  device character-set (parse-text-style text-style) font)))
-    font))
-
-
-(defmethod silica::text-style-width ((text-style text-style) medium)
-  (tk::font-width (realize-text-style (port medium) text-style)))
-
-(defmethod text-style-ascent ((text-style text-style) medium)
-  (tk::font-ascent (realize-text-style (port medium) text-style)))
-					
-(defmethod text-style-descent ((text-style text-style) medium)
-  (tk::font-descent (realize-text-style (port medium) text-style)))
-					
-(defmethod text-style-height ((text-style text-style) medium)
-  (+ (text-style-ascent text-style medium)
-     (text-style-descent text-style medium)))
-
-(ff::defforeign 'xtsetkeyboardfocus
-    :entry-point "_XtSetKeyboardFocus")
-
 (ff:defforeign 'xmprocesstraversal
     :entry-point "_XmProcessTraversal")
 
 (defmethod port-note-cursor-change ((port motif-port)
-					  cursor
-					  stream
-					  type
-					  old
-					  new)
+				    cursor
+				    stream
+				    type
+				    old
+				    new)
   (declare (ignore old type cursor))
   (call-next-method)
   (when new
@@ -526,15 +48,4 @@
 			(tk::object-handle (sheet-mirror stream))
 			(tk::object-handle (sheet-mirror stream))))
   (setf (silica::port-keyboard-focus port) 
-      (and new stream)))
-
-(defun sheet-top-level-mirror (stream)
-  (let ((last-mirror nil))
-    (loop
-      (when (graftp stream) (return last-mirror))
-      (when (sheet-direct-mirror stream) 
-	(setq last-mirror stream))
-      (setq stream (sheet-parent stream)))))
-
-(defmethod clim::stream-set-input-focus (stream)
-  nil)
+    (and new stream)))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index d9f063bc..09a42d2c 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,9 +20,9 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
-
+;; $fiHeader: xt-silica.cl,v 1.1 92/01/15 16:16:15 cer Exp Locker: cer $
 
+(in-package :xm-silica)
 
 (defclass xt-port (port)
 	  ((application-shell :reader port-application-shell)
diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp
index ead8205d..a7996def 100644
--- a/tk/callbacks.lisp
+++ b/tk/callbacks.lisp
@@ -20,13 +20,19 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: callbacks.cl,v 1.3 92/01/02 15:08:35 cer Exp Locker: cer $
 
 (in-package :tk)
 
 (defforeign 'add_callback
     :entry-point "_XtAddCallback")
 
+(defforeign 'xt_has_callbacks
+    :entry-point "_XtHasCallbacks")
+
+(defun has-callbacks-p (w name)
+  (not (zerop (xt_has_callbacks (object-handle w) name))))
+
 (defun-c-callable callback-handler ((widget :unsigned-long)
 				    (client-data :unsigned-long)
 				    (call-data :unsigned-long))
@@ -69,14 +75,15 @@
 (defun new-callback-id ()
   (incf *callback-ids*))
 
+(defun process-callback-alist-component (x)
+  (destructuring-bind (name &optional type) x
+    (list (lispify-tk-name name :package :keyword)
+	  name
+	  nil;; malloc cache
+	  type)))
+
 (defparameter *callback-name-alist* 
-    (mapcar #'(lambda (x)
-		(destructuring-bind (name &optional type) x
-		  (list (lispify-tk-name name :package :keyword)
-		    name
-		    nil;; malloc cache
-		    type
-		    )))
+    (mapcar #'process-callback-alist-component
 	  '(
 	    ("activateCallback" :activate)
 	    ("armCallback")           
@@ -117,6 +124,10 @@
 	    ("destroyCallback")         
 	    ("gainPrimaryCallback")     
 	    ("losePrimaryCallback")
+
+	    ;; OpenLook Callbacks
+	    ("sliderMoved" slider-moved)
+	    
 	    )))
 
 (defun convert-callback-name (x)
diff --git a/tk/defsys.lisp b/tk/defsys.lisp
index c5ca1272..f8646c35 100644
--- a/tk/defsys.lisp
+++ b/tk/defsys.lisp
@@ -20,21 +20,16 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: defsys.cl,v 1.2 92/01/02 15:08:37 cer Exp Locker: cer $
+;; $fiHeader: defsys.cl,v 1.3 92/01/06 20:43:43 cer Exp Locker: cer $
 
-
-(defsys::defsystem :xm-tk
-  (:default-pathname (frob-pathname "tk"))
+(defsys::defsystem :basic-tk
+    (:default-pathname (frob-pathname "tk"))
 
   (|pkg|)
   (|foreign-obj|)
   (|macros|)
   
-  ;;; Do the foreign loads
-  
-  (|load-xm|)
-  
-  ;; Clos<->xlib interface
+  ;; Xlib stuff
   
   (|xlib|)
   (|font|)
@@ -53,33 +48,27 @@
   (|resources|)
   (|event|)
   (|callbacks|)
-  (|convenience|)
+  )
 
+(defsys::defsystem :xm-tk
+    (:default-pathname (frob-pathname "tk"))
+  (|load-xm|)
   (|xm-init|)
   (|xm-widgets|)
   (|xm-font-list|)
   (|xm-protocols|)
-  
+  (|convenience|)
   (|examples|)
   )
 
-#+this-is-totally-out-of-date
+
+(defsys::defsystem :hi-tk
+    (:default-pathname (frob-pathname "tk"))
+  (|make-widget|))
+
 (defsys::defsystem :ol-tk
     (:default-pathname (frob-pathname "tk"))
-  (|pkg|)
-  (|foreign-obj|)
   (|load-ol|)
-  (|xlib|)
-  (|xtk|)
-  (|make-classes|)
-  (|foreign|)
-  (|widget|)
-  (|resources|)
-  (|event|)
-  (|callbacks|)
   (|ol-init|)
-  (|graphics|)
-  (|font|)
-  (|gcontext|)
-  (|ol-examples|)
-  )
+  (|ol-callbacks|)
+  (|ol-examples|))
diff --git a/tk/examples.lisp b/tk/examples.lisp
index e16f1022..cd1c200b 100644
--- a/tk/examples.lisp
+++ b/tk/examples.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: examples.cl,v 1.3 92/01/02 15:08:39 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -47,17 +47,6 @@
   (add-callback da :input-callback 'da-button-press-handler :input)
   (popup app4))
 
-(defun setup (hostspec)
-  (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)))
-
-(defun initialize-motif-toolkit (hostspec)
-  (setup hostspec)
-  (values context display app))
-
 (defvar *bitmaps* (quote ("background" "25_foreground" "50_foreground" "75_foreground" 
 			  "horizontal" "vertical" "slant_right" "slant_left"
 			  "1x1" "2x2" "black" "boxes" "cntr_ptr" "cntr_ptrmsk"
diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp
index d5612936..61d5736f 100644
--- a/tk/foreign-obj.lisp
+++ b/tk/foreign-obj.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign-obj.cl,v 1.2 92/01/02 15:08:42 cer Exp Locker: cer $
+;; $fiHeader: foreign-obj.cl,v 1.3 92/01/06 20:43:44 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -88,5 +88,11 @@
 		    initargs)))
 	  ((typep x class) x)
 	  (t
-	   (error "~s has the wrong class: ~s"
-		  x class)))))
+	   (cerror "Make a new one"
+		   "~s has the wrong class: ~s"
+		   x class)
+	   (setf (gethash handle table)
+	     (apply #'make-instance 
+		    class 
+		    :handle handle
+		    initargs))))))
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index 84c77942..086c5680 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: load-ol.cl,v 1.2 92/01/02 15:08:48 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -28,24 +28,106 @@
 make ucl_xtras='/usr/tech/cer/stuff/clim-2.0/ol-classes.o /usr/tech/cer/stuff/clim-2.0/lib/libXol.a /usr/tech/cer/stuff/clim-2.0/lib/libXt.a /usr/tech/cer/stuff/clim-2.0/lib/libX11.a' ucl
 |#
 
-(flet ((foundp (entry-point)
-	       (let ((x (make-array 1 :initial-contents
-				    (list (ff:convert-to-lang
-					   entry-point))))
-		     (y 
-		 
-		      (make-array 1 :element-type '(unsigned-byte 32))))
-		 (zerop (ff:get-entry-points x y)))))
-  (unless (foundp "insert_classes")
-    #+ingnore
-	(mapc #'foreign-functions:remove-entry-point 
-	      '("__unpack_quadruple" 
-		"__prod_b10000" 
-		"__carry_out_b10000" 
-		"__prod_65536_b10000"))
-	(load "classes.o" 
-	      :foreign-files 
-	      '("/vapor/usr/tech/cer/stuff/clim-2.0/lib/libXol.a"
-		"/vapor/usr/tech/cer/stuff/clim-2.0/lib/libXt.a"
-		"/vapor/usr/tech/cer/stuff/clim-2.0/lib/libX11.a") 
-	      :print t)))
+(eval-when (compile load eval)
+  (defparameter *openlook-classes* '(
+				     ;; Base classes
+				     "_constraintWidgetClass"
+				     "_objectClass"
+				     "_wmShellWidgetClass"
+				     "_vendorShellWidgetClass"
+				     "_coreWidgetClass"
+				     "_shellWidgetClass"
+				     "_compositeWidgetClass"
+				     "_applicationShellWidgetClass"
+				     "_overrideShellWidgetClass"
+				     "_topLevelShellWidgetClass"
+				     "_transientShellWidgetClass"
+
+				     ;; OpenLook specific classes
+				     ;; Some of these are both gadgets
+				     ;; and widget and I think the
+				     ;; names are the same!
+				     
+				     "_abbrevMenuButtonWidgetClass"
+				     "_abbrevStackWidgetClass"
+				     "_arrowWidgetClass"
+				     "_baseWindowShellWidgetClass"
+				     "_bulletinBoardWidgetClass"
+				     "_buttonWidgetClass"
+				     "_buttonGadgetClass"
+				     "_buttonStackWidgetClass"
+
+				     ;;"_buttonStackGadgetClass"
+
+				     "_captionWidgetClass"
+				     "_checkBoxWidgetClass"
+				     "_controlAreaWidgetClass"
+				     "_eventObjClass"
+				     "_exclusivesWidgetClass"
+				     "_flatCheckBoxWidgetClass"
+				     "_flatExclusivesWidgetClass"
+				     "_flatNonexclusivesWidgetClass"
+				     "_flatWidgetClass"
+				     "_footerPanelWidgetClass"
+				     "_formWidgetClass"
+				     "_helpWidgetClass"
+				     "_listPaneWidgetClass"
+				     "_magWidgetClass"
+				     "_managerWidgetClass"
+				     "_menuShellWidgetClass"
+				     "_menuButtonWidgetClass"
+
+				     ;;"_menuButtonGadgetClass"
+
+				     "_nonexclusivesWidgetClass"
+				     "_noticeShellWidgetClass"
+				     "_oblongButtonWidgetClass"
+				     ;; "_oblongButtonGadgetClass"
+				     "_popupWindowShellWidgetClass"
+				     "_primitiveWidgetClass"
+				     "_pushpinWidgetClass"
+				     "_rectButtonWidgetClass"
+				     "_scrollbarWidgetClass"
+				     "_scrolledWindowWidgetClass"
+				     "_scrollingListWidgetClass"
+				     "_sliderWidgetClass"
+				     "_staticTextWidgetClass"
+				     "_stubWidgetClass"
+				     "_textWidgetClass"
+				     
+				     ;;; This two seem to be broken!
+				     ;; "_textEditWidgetClass"
+				     ;;"_textPaneWidgetClass"
+				     
+				     "_compositeWidgetClass"
+				     "_overrideShellWidgetClass"
+				     "_shellWidgetClass"
+				     "_topLevelShellWidgetClass"
+				     "_widgetClass"
+				     "_widgetClassRec"
+				     "_drawAreaWidgetClass"
+				     )))
+
+(defun load-ol (&optional (what *openlook-classes*))
+  (setq what (remove-if #'ff::get-entry-point `(,@what)))
+  (when what
+    (mapc #'foreign-functions:remove-entry-point 
+	  '("__unpack_quadruple" 
+	    "__prod_b10000" 
+	    "__unpacked_to_decimal"
+	    "__carry_out_b10000" 
+	    "__prod_65536_b10000"))
+    (load ""
+	  :unreferenced-lib-names 
+	  what
+	  :foreign-files 
+	  '("/usr/openwin-3.0/lib/libXol.a"
+	    "/usr/motif/usr/lib/libXt.a"
+	    "/usr/motif/usr/lib/libX11.a"
+	    ;; Hopefully
+	    ;;"/usr/openwin-3.0/lib/libXt.a"
+	    ;; "/usr/openwin-3.0/lib/libX11.a"
+	    )
+	  :print t)))
+
+(load-ol)
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index 140e07d5..b65d8695 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: load-xm.cl,v 1.2 92/01/02 15:08:49 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -80,36 +80,26 @@ make ucl_xtras='/usr/tech/cer/stuff/clim-2.0/xm-classes.o /usr/motif/usr/lib/lib
 				     "_transientShellWidgetClass"
 				     )))
 
-(flet ((foundp (entry-point)
-	       (let ((x (make-array 1 :initial-contents
-				    (list (ff:convert-to-lang
-					   entry-point))))
-		     (y 
-		 
-		      (make-array 1 :element-type '(unsigned-byte 32))))
-		 (zerop (ff:get-entry-points x y)))))
-      (unless (foundp "insert_classes")
-	(mapc #'foreign-functions:remove-entry-point 
-	      '("__unpack_quadruple" 
-		"__prod_b10000" 
-		"__carry_out_b10000" 
-		"__prod_65536_b10000"))
-	(load "classes.o" 
-	      :unreferenced-lib-names `(
-					"_XCopyGC"
-					,@*motif-classes*
-					)
-	      :foreign-files 
-	      '("/usr/motif/usr/lib/libXm.a"
-		"/usr/motif/usr/lib/libXt.a"
-		"/usr/motif/usr/lib/libX11.a") 
-	      :print t)))
+(defun load-from-xm (&optional (what *motif-classes*))
+  (setq what (remove-if #'ff::get-entry-point
+			`(
+			  "_XCopyGC"
+			  ,@what
+			  )))
+  (when what
+    #+ignore
+    (mapc #'foreign-functions:remove-entry-point 
+	  '("__unpack_quadruple" 
+	    "__prod_b10000" 
+	    "__carry_out_b10000" 
+	    "__prod_65536_b10000"))
+    (load "" 
+	  :unreferenced-lib-names what
+	  :foreign-files 
+	  '("/usr/motif/usr/lib/libXm.a"
+	    "/usr/motif/usr/lib/libXt.a"
+	    "/usr/motif/usr/lib/libX11.a") 
+	  :print t)))
+
+(load-from-xm)
 
-(defun load-from-xm (unref)
-  (load ""
-	:unreferenced-lib-names (if (listp unref) unref (list unref))
-	:foreign-files 
-	'("/usr/motif/usr/lib/libXm.a"
-	  "/usr/motif/usr/lib/libXt.a"
-	  "/usr/motif/usr/lib/libX11.a") 
-	:print t))
diff --git a/tk/macros.lisp b/tk/macros.lisp
index 91edebb4..104801fa 100644
--- a/tk/macros.lisp
+++ b/tk/macros.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: macros.cl,v 1.2 92/01/02 15:08:51 cer Exp Locker: cer $
+;; $fiHeader: macros.cl,v 1.3 92/01/08 14:58:16 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -31,12 +31,13 @@
       `(progn ,@body)
     (destructuring-bind
 	((var value) &rest more-bindings) bindings
-      `(let ((,var (or (pop *temp-with-ref-par*)
-		       (make-array 1 :element-type '(unsigned-byte
-						     32)))))
-	 (declare (type (simple-array (unsigned-byte 32) (1)) ,var))
-	 (setf (aref ,var 0) ,value)
-	 (multiple-value-prog1
-	     (with-ref-par ,more-bindings ,@body)
-	   (push ,var *temp-with-ref-par*))))))
-
+      (let ((val (gensym)))
+	`(let ((,val ,value)
+	       (,var (or (pop *temp-with-ref-par*)
+			 (make-array 1 :element-type '(unsigned-byte
+						       32)))))
+	   (declare (type (simple-array (unsigned-byte 32) (1)) ,var))
+	   (setf (aref ,var 0) ,val)
+	   (multiple-value-prog1
+	       (with-ref-par ,more-bindings ,@body)
+	     (push ,var *temp-with-ref-par*)))))))
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index ccc260a5..62d2e435 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.cl,v 1.3 92/01/06 20:43:47 cer Exp Locker: cer $
+;; $fiHeader: make-classes.cl,v 1.4 92/01/08 14:58:18 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -33,20 +33,11 @@
       (error "Cannot find the entry-point for: ~S" x))
     (aref xx 0)))
 
-(defvar *class-table-addr*
-  (get-entry-point-value "_classtable"))
-
-
 (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))
 
-(defun nth-class (n)
-  (class-array *class-table-addr* n))
-
-;;; (char*-to-string (widget-struct-name (nth-class 0)))
-
 (defun get-resource-list-internal (class fn resource-class)
   (let ((x (make-array 1 :element-type '(unsigned-byte 32)))
 	(y (make-array 1 :element-type '(unsigned-byte 32))))
@@ -175,6 +166,9 @@
   (dolist (r (class-direct-resources class))
     (let* ((rname (resource-name r))
 	   (name (intern (format nil "~A-~A" 'widget rname))))
+      (setq name (case name
+		   (widget-window 'widget-stub-window)
+		   (t name)))
       (add-method
        (ensure-generic-function name)
        (make-instance 'clos::standard-method
@@ -201,7 +195,12 @@
 (defun widget-class-name (h)
   (char*-to-string (xtk-class-name h)))
 
-(defun lispify-class-name (x) (lispify-tk-name x))
+(defun lispify-class-name (x) 
+  (let ((name (lispify-tk-name x)))
+    (case name
+      ;; Openlook
+      (list 'ol-list)
+      (t name))))
   
 (defun lispify-tk-name (string &key 
 			       (start 0)
@@ -247,6 +246,13 @@
   (warn "toolkit warning: ~a" (char*-to-string message)))
 
 
+(defun add-resource-to-class (class resource)
+  (clos::map-over-subclasses
+   #'(lambda (c)
+       (push
+	resource
+	(slot-value c 'resources)))
+   class))
 
 #|
 (make-widget class parent . resources)
diff --git a/tk/make-widget.lisp b/tk/make-widget.lisp
index 5c45d7d9..52ce89a4 100644
--- a/tk/make-widget.lisp
+++ b/tk/make-widget.lisp
@@ -20,7 +20,9 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: make-widget.cl,v 1.1 92/01/14 20:37:55 cer Exp Locker: cer $
+
+(in-package :tk)
 
 (defgeneric make-widget (widget &key)
   ;;; returns the handle of a widget
diff --git a/tk/ol-examples.lisp b/tk/ol-examples.lisp
index e441ccd7..2195799d 100644
--- a/tk/ol-examples.lisp
+++ b/tk/ol-examples.lisp
@@ -20,20 +20,77 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: ol-examples.cl,v 1.2 92/01/02 15:08:54 cer Exp Locker: cer $
 
 (in-package :tk)
 
-(defun example-1 ()
-  (let (shell)
-    
-(setq shell (create-popup-shell "foo" 'base-window-shell old-shell))
-(setq cp (create-managed-widget 'control "fio" shell))
-(setq bs (create-managed-widget 
-	  'menu-button "foo" cp 
-	  :label "foo"
-	  :font
-	  "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
-
-				
-    (popup shell)))
+(defun simple-ol-example ()
+  (setq shell (make-instance 'base-window-shell :parent app))
+  (setq control (make-instance 'control :parent shell
+			       :layout-type :fixedcols
+			       ))
+  (setq button (make-instance 'menu-button :parent control
+			      :label "foo"
+			      :font
+			      "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
+
+  (setq menu (tk::get-values button :menu-pane))
+
+  (setq b1 (make-instance 'oblong-button :parent menu
+			  :label "bar"
+			  :font
+			  "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
+
+
+  (setq b2 (make-instance 'oblong-button :parent menu
+			  :label "baz"
+			  :font
+			  "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
+
+  (setq slider (make-instance 'slider
+			      :orientation :horizontal
+			      :height 100
+			      :parent control))
+  
+  (setq scrollbar (make-instance 'scrollbar
+				 :orientation :horizontal
+				 :height 100
+				 :parent control))
+  
+  (setq list-pane (make-instance 'list-pane
+				 :parent control
+				 ))
+  
+  (setq ab-menu (make-instance 'abbrev-menu-button
+			       :parent control
+			       ))
+  
+  (setq menu1 (tk::get-values ab-menu :menu-pane))
+  
+  (setq b3 (make-instance 'oblong-button :parent menu1
+			  :label "Lisp"
+			  :font
+			  "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
+
+
+  (setq b4 (make-instance 'oblong-button :parent menu1
+			  :label "Fortran"
+			  :font
+			  "-adobe-courier-medium-r-normal--12-120-75-75-m-70-iso8859-1"))
+  
+  (setq stext (make-instance 'static-text 
+			     :string "heooo"
+			     :parent control))
+  
+  (set-values ab-menu :preview-widget stext)
+
+  
+  )
+  
+  
+				 
+
+
+(defun simple-ol-example-2 ()
+  (setq shell (make-instance 'base-window-shell :parent app))
+  (setq da (make-instance 'draw-area :parent shell)))
diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp
index dddb01c5..40e70ee5 100644
--- a/tk/ol-init.lisp
+++ b/tk/ol-init.lisp
@@ -20,26 +20,15 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: ol-init.cl,v 1.2 92/01/02 15:08:56 cer Exp Locker: cer $
 
 
 (in-package :tk)
 
-(defforeign 'ol_initialize :entry-point "_OlInitialize")
-
-(defun ol-initialize (&key (shell-name "foo")
-			   (application-class "foo")
-			   )
-  (with-ref-par ((argc 0)
-		 (argv 0))
-		(ol_initialize
-		 (string-to-char* shell-name)
-		 (string-to-char* application-class)
-		 0 ;; options
-		 0;; num-options
-		 argc ;; argc
-		 argv ;; argv
-		 )))
+(defforeign 'ol_toolkit_initialize :entry-point "_OlToolkitInitialize")
+
+(defun ol-initialize ()
+  (ol_toolkit_initialize))
 
 (defun-c-callable ol-error-handler ((message :unsigned-long))
   (error "toolkit error: ~A"
@@ -50,38 +39,81 @@
   (warn "toolkit error: ~A"
 	(char*-to-string message)))
 
+(defun-c-callable ol-error-va-handler ((message :unsigned-long))
+  (error "toolkit error: ~A"
+	 (char*-to-string message)))
+
+
+(defun-c-callable ol-warning-va-handler ((message :unsigned-long))
+  (warn "toolkit error: ~A"
+	(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))
-
-(setq shell (ol-initialize))
-
-(defvar *done* nil)
-(defvar *n-classes*)
-
-(unless *done*
-  (setq *n-classes* (insert_classes))
-  (make-classes *n-classes*)
-  (setq *done* t))
-
-
-(setq shell (intern-widget shell (widget-class-of shell)))
-
-(defforeign 'xt_display :entry-point "_XtDisplay")
-(defforeign 'xt_display_to_application_context
-    :entry-point "_XtDisplayToApplicationContext")
-
-(setf (slot-value shell 'display)
-      (let* ((d (xt_display (object-handle shell)))
-	     (c (xt_display_to_application_context d)))
-	(intern-widget d 'display 
-		       :display d
-		       :context 
-		       (make-instance 'application-context :context c))))
+(ol_set_va_display_error_msg_handler (register-function 'ol-error-va-handler))
+
+
+(ol-initialize)
+(toolkit-initialize)
+
+(defvar *ol-done* nil)
+
+(unless *ol-done*
+  (make-classes *openlook-classes*)
+  (setq *ol-done* t))
+
+(defmethod make-widget ((w event) 
+			&rest args &key parent (managed t) (name "") &allow-other-keys)
+  (remf :managed args)
+  (remf :name args)
+  (remf :parent args)
+  (let ((class (class-of w)))
+    (if managed
+	(apply #'create-managed-widget name class parent args)
+      (apply #'create-widget name class parent args))))
+
+(add-resource-to-class (find-class 'menu-button)
+			   (make-instance 'resource
+					  :name :menu-pane
+					  :type 'widget
+					  :original-name 
+					  (string-to-char*
+					   "menuPane")))
+
+(add-resource-to-class (find-class 'abbrev-menu-button)
+		       (make-instance 'resource
+				      :name :menu-pane
+				      :type 'widget
+				      :original-name 
+				      (string-to-char*
+				       "menuPane")))
+
+
+;(setq shell (intern-widget shell (widget-class-of shell)))
+;
+;(defforeign 'xt_display :entry-point "_XtDisplay")
+;(defforeign 'xt_display_to_application_context
+;    :entry-point "_XtDisplayToApplicationContext")
+;
+;(setf (slot-value shell 'display)
+;      (let* ((d (xt_display (object-handle shell)))
+;	     (c (xt_display_to_application_context d)))
+;	(intern-widget d 'display 
+;		       :display d
+;		       :context 
+;		       (make-instance 'application-context :context c))))
     
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 1c578b0f..f45c7be0 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.cl,v 1.3 92/01/06 20:43:48 cer Exp Locker: cer $
+;; $fiHeader: resources.cl,v 1.4 92/01/08 14:58:20 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -54,7 +54,7 @@
        value)
       ((null args)
        (make-array (length new-args)
-		   :element-type '(unsigned-byte 32)
+		   :element-type '(signed-byte 32)
 		   :initial-contents (nreverse new-args)))
     (setq keyword (pop args)
 	  value (pop args))
@@ -99,7 +99,7 @@
 	(push (resource-original-name resource) arglist)
 	(push (make-x-arglist) arglist)))
     
-    (setq arglist (coerce (nreverse arglist) '(vector (unsigned-byte 32))))
+    (setq arglist (coerce (nreverse arglist) '(vector (signed-byte 32))))
     (get_values (object-handle widget)
 		arglist
 		(truncate (length arglist) 2))
@@ -200,8 +200,11 @@
 					  :system-modal))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value)
-  (object-handle (load-query-font (widget-display parent) 
-				  value)))
+  (object-handle 
+   (make-instance 'font
+		  :display (widget-display parent)
+		  :name value)))
+
 
 (defmethod convert-resource-in ((parent t) (type (eql 'string)) value)
   (unless (zerop value)
@@ -298,4 +301,201 @@
 
 
 (defmethod convert-resource-in ((widget t) (type (eql 'widget)) x)
-  (intern-widget x))
+  (intern-widget x :display (widget-display widget)))
+
+(defmethod convert-resource-out ((widget t) (type (eql 'widget)) x)
+  (object-handle x))
+
+;; Could not think of anywhere better!
+
+
+(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)))
+
+(defun initialize-motif-toolkit (hostspec)
+  (setup hostspec)
+  (values context display app))
+
+
+;;; ol resource
+
+(defmethod convert-resource-out ((parent t) (type (eql 'position)) value)
+  value)
+
+(defmethod convert-resource-in ((parent t) (type (eql 'position)) value)
+  (ash value -16))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value)
+  value)
+
+(defmethod convert-resource-in ((parent t) (type (eql 'dimension))
+				value)
+  (ash value -16))
+
+;; from OpenLook.h
+
+(defvar *ol-defines* '(
+		       (:absent-pair		0)
+		       (:all			1)
+		       (:always		2)
+		       (:atom-help		3)
+		       (:both			4)
+		       (:bottom		5)
+		       (:buttonstack		6)
+		       (:center		7)
+		       (:class-help		8)
+		       (:columns		9)
+		       (:copy-mask-value	10)
+		       (:copy-size		11)
+		       (:copy-source-value	12)
+		       (:current		13)
+		       (:default-pair		14)
+		       (:disk-source		15)
+		       (:display-form		16)
+		       (:down			17)
+		       (:existing-source	18)
+		       (:fixedcols		19)
+		       (:fixedheight		20)
+		       (:fixedrows		21)
+		       (:fixedwidth		22)
+		       (:flat-button		23)
+		       (:flat-checkbox	24)
+		       (:flat-container	25)
+		       (:flat-exclusives	26)
+		       (:flat-help		27)
+		       (:flat-nonexclusives	28)
+		       (:halfstack		29)
+		       (:horizontal		30)
+		       (:image		31)
+		       (:in			32)
+		       (:indirect-source	33)
+		       (:label		34)
+		       (:left			35)
+		       (:mask-pair		36)
+		       (:maximize		37)
+		       (:millimeters		38)
+		       (:minimize		39)
+		       (:never		40)
+		       (:next			41)
+		       (:none			42)
+		       (:nonebottom		43)
+		       (:noneleft		44)
+		       (:noneright		45)
+		       (:nonetop		46)
+		       (:notices		47)
+		       (:no-virtual-mapping	48)
+		       (:oblong		49)
+		       (:out			50)
+		       (:override-pair	51)
+		       (:pixels		52)
+		       (:points		53)
+		       (:popup		54)
+		       (:previous		55)
+		       (:prog-defined-source	56)
+		       (:rectbutton		57)
+		       (:right		58)
+		       (:rows			59)
+		       (:source-form		60)
+		       (:source-pair		61)
+		       (:stayup		62)
+		       (:string		63)
+		       (:string-source	64)
+		       (:text-append		65)
+		       (:text-edit		66)
+		       (:text-read		67)
+		       (:top			68)
+		       (:transparent-source	69)
+		       (:vertical		70)
+		       (:virtual-button	71)
+		       (:virtual-key		72)
+		       (:widget-help		73)
+		       (:window-help		74)
+		       (:wrap-any		75)
+		       (:wrap-white-space	76)
+		       (:continuous		77)
+		       (:granularity		78)
+		       (:release		79)
+		       (:tickmark		80)
+		       (:percent		81)
+		       (:slidervalue		82)
+		       (:wt-base		83)
+		       (:wt-cmd		84)
+		       (:wt-notice		85)
+		       (:wt-help		86)
+		       (:wt-other		87)
+		       (:success		88)
+		       (:duplicate-key	89)
+		       (:duplicatekey		89)
+		       (:bad-key		90)
+		       (:menu-full		91)
+		       (:menu-limited		92)
+		       (:menu-cancel		93)
+		       (:selectkey		94)
+		       (:menukey		95)
+		       (:menudefault		96)
+		       (:menudefaultkey	97)
+		       (:hsbmenu		98)
+		       (:vsbmenu		99)
+		       (:adjustkey		100)
+		       (:nextapp		101)
+		       (:nextwindow		102)
+		       (:prevapp		103)
+		       (:prevwindow		104)
+		       (:windowmenu		105)
+		       (:workspacemenu	106)
+		       (:defaultaction	108)
+		       (:drag			109)
+		       (:drop			110)
+		       (:togglepushpin	111)
+		       (:pageleft		112)
+		       (:pageright		113)
+		       (:scrollbottom		114)
+		       (:scrolltop		115)
+		       (:multiright		116)
+		       (:multileft		117)
+		       (:multidown		118)
+		       (:multiup		119)
+		       (:immediate		120)
+		       (:moveup		121)
+		       (:movedown		122)
+		       (:moveright		123)
+		       (:moveleft		124)
+		       (:click-to-type	125)
+		       (:realestate		126)
+		       (:underline		127)
+		       (:highlight		128)
+		       (:inactive		129)
+		       (:display		130)
+		       (:proc			131)
+		       (:size-proc		132)
+		       (:draw-proc		133)
+		       (:pinned-menu		134)
+		       (:press-drag-menu	135)
+		       (:stayup-menu		136)
+		       (:pointer		137)
+		       (:inputfocus		138)
+		       (:quit			142)
+		       (:destroy		143)
+		       (:dismiss		144)
+		       (:pre			145)
+		       (:post			146)
+		       (:grow-off     	147)
+		       (:grow-horizontal      148)
+		       (:grow-vertical        149)
+		       (:grow-both    	150)
+		       ))
+
+(defmethod convert-resource-in (parent (type (eql 'ol-define)) value)
+  (setq value (ash value -16))
+  (or (car (find value *ol-defines* :key #'second))
+      (call-next-method)))
+
+
+(defmethod convert-resource-out (parent (type (eql 'ol-define)) value)
+  (or (second (find value *ol-defines* :key #'first))
+      (call-next-method)))
+  
diff --git a/tk/widget.lisp b/tk/widget.lisp
index 625ded1e..5d613fc6 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.cl,v 1.5 92/01/06 20:43:49 cer Exp Locker: cer $
+;; $fiHeader: widget.cl,v 1.6 92/01/08 14:58:23 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -143,13 +143,6 @@
   (let* ((window-id (xt_window (object-handle widget))))
     (make-clx-window-from-id display window-id)))
 
-#+xlib
-(defun make-clx-window-from-id (display window-id)
-  (or (xlib::lookup-resource-id display window-id)
-      (let ((x-window (xlib::make-window :id window-id :display display)))
-	(xlib::save-id display window-id x-window)
-	x-window)))
-
 (defun widget-class-of (x)
   (intern-widget-class
    (xtk-widget-widget-class x)))
@@ -178,10 +171,13 @@
 (defforeign 'xt_parent 
     :entry-point "_XtParent")
 
-(defun intern-widget (widget)
-  (intern-object-address 
-   widget 
-   (widget-class-of widget)))
+(defun intern-widget (widget &rest args)
+  (and (not (zerop widget))
+       (apply
+	#'intern-object-address 
+	widget 
+	(widget-class-of widget)
+	args)))
 
 (defmethod widget-parent (widget)
   (let ((x (xt_parent (object-handle widget))))
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index 9bb8b48a..64ddfadb 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -20,23 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: xm-widgets.cl,v 1.2 92/01/02 15:09:04 cer Exp Locker: cer $
 
 (in-package :tk)
 
-(defgeneric make-widget (widget &key)
-  ;;; returns the handle of a widget
-  )
-
-(defmethod make-widget ((w core) &rest args &key parent (managed t) (name "") &allow-other-keys)
-  (remf :managed args)
-  (remf :name args)
-  (remf :parent args)
-  (let ((class (class-of w)))
-    (if managed
-	(apply #'create-managed-widget name class parent args)
-      (apply #'create-widget name class parent args))))
-
 (defmethod make-widget ((w xm-gadget) 
 			&rest args &key parent (managed t) (name "") &allow-other-keys)
   (remf :managed args)
@@ -47,15 +34,6 @@
 	(apply #'create-managed-widget name class parent args)
       (apply #'create-widget name class parent args))))
 
-
-(defmethod make-widget ((w shell) &rest args &key parent (name "") &allow-other-keys)
-  (error "shells not made this way"))
-
-(defmethod make-widget ((w top-level-shell) &rest args &key parent (name "") &allow-other-keys)
-  (remf :parent args)
-  (remf :name args)
-  (apply #'create-popup-shell name (class-of w) parent args))
-
 (defmethod make-widget ((w xm-dialog-shell) &rest args &key parent (name "") &allow-other-keys)
   (remf :parent args)
   (remf :name args)
@@ -69,14 +47,6 @@
 (defforeign 'xm_main_window_set_area :entry-point
   "_XmMainWindowSetAreas")
 
-(defun add-resource-to-class (class resource)
-  (clos::map-over-subclasses
-   #'(lambda (c)
-       (push
-	resource
-	(slot-value c 'resources)))
-   class))
-
 (tk::add-resource-to-class (find-class 'vendor-shell)
 			   (make-instance 'resource
 					  :name :delete-response
diff --git a/tk/xtk.lisp b/tk/xtk.lisp
index bfb02b6d..646b0e0f 100644
--- a/tk/xtk.lisp
+++ b/tk/xtk.lisp
@@ -20,18 +20,61 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xtk.cl,v 1.2 92/01/02 15:09:05 cer Exp Locker: cer $
+;; $fiHeader: xtk.cl,v 1.3 92/01/06 20:43:51 cer Exp Locker: cer $
 
 (in-package :tk)
 
 (def-c-typedef :cardinal :unsigned-int)
+(def-c-typedef xt-proc * :unsigned-long)
+(def-c-typedef action-list * :char)
+(def-c-typedef resource-list * :char)
+(def-c-typedef xrm-quark :int)
+(def-c-typedef xrm-quark-list * :int)
+(def-c-typedef boolean :unsigned-long)
+(def-c-typedef xrm-class  xrm-quark)
+(def-c-typedef xt-enum   :long)
+(def-c-typedef xt-version-type :long)
+
+(def-c-type (xrm-resource :in-foreign-space) :struct
+	    (name xrm-quark)
+	    (class xrm-quark)
+	    (type xrm-quark)
+	    (size :cardinal)
+	    (offset :long)
+	    (default-type xrm-quark)
+	    (default-addr * :char))
+
+(def-c-type (xrm-resource-array :in-foreign-space) 1 xrm-resource)
 
 (def-c-type (xtk-class :in-foreign-space) :struct
-  (superclass :long)
-  (name * :char)
-  (widget-size :cardinal)
-  (class-part-initialize * :unsigned-long)
-  (inited :unsigned-long))
+	    (superclass :long)
+	    (name * :char)
+	    (widget-size :cardinal)
+	    (class-initialize xt-proc)
+	    (class-part-initialize xt-proc)
+	    (inited xt-enum)
+	    (initialize xt-proc)
+	    (initialize-hook xt-proc)
+	    (realize xt-proc)
+	    (actions action-list)
+	    (num-actions :cardinal)
+	    (resources resource-list)
+	    (num-resources :cardinal)
+	    (xrm-class xrm-class)
+	    (compress-motion boolean)
+	    (compress-exposure xt-enum)
+	    (compress-enter-leave boolean)
+	    (visible-interest boolean)
+	    (destroy xt-proc)
+	    (resize xt-proc)
+	    (expose xt-proc)
+	    (set-values xt-proc)
+	    (set-values-hook xt-proc)
+	    (set-values-almost xt-proc)
+	    (get-values-hook xt-proc)
+	    (accept-focus xt-proc)
+	    (version xt-version-type)
+	    (callback-private * :char))
 
 (def-c-type (x-resource :in-foreign-space) :struct
   (name * :char)
@@ -43,6 +86,24 @@
   (default-addr * :char)
   )
 
+;; Horrible internal stuff
+
+(defforeign 'quark_to_string
+    :entry-point "_XrmQuarkToString")
+    
+(def-c-type (xt-offset-rec :in-foreign-space) :struct
+	    (next * :char)
+	    (name xrm-quark)
+	    (offset :int))
+
+(defun import-offset-list (x)
+  (let ((r nil))
+    (do ((x x (xt-offset-rec-next x)))
+	((zerop x)
+	 (nreverse r))
+      (push (list (xt-offset-rec-name x)
+		  (xt-offset-rec-offset x)) r))))
+
 (def-c-type (xtk-widget :in-foreign-space) :struct
   (self :unsigned-long)
   (widget-class :unsigned-long)
-- 
GitLab