From c06530bb3931d950c5fefc564087eb24b85537e1 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Tue, 16 Jun 1992 19:11:15 +0000
Subject: [PATCH] jdimerge

---
 tk-silica/xt-graphics.lisp | 308 +++++++++++++++++++++++++------------
 tk-silica/xt-silica.lisp   |  21 ++-
 tk/convenience.lisp        |  60 ++++----
 tk/gcontext.lisp           | 119 ++++++++------
 tk/graphics.lisp           |  14 +-
 tk/make-classes.lisp       | 182 +++++++++++-----------
 tk/meta-tk.lisp            |  35 ++---
 tk/pkg.lisp                |  10 +-
 tk/resources.lisp          |  31 ++--
 tk/xlib.lisp               |  18 ++-
 utils/lisp-utilities.lisp  |  25 ++-
 11 files changed, 494 insertions(+), 329 deletions(-)

diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 20ff1569..a5357e21 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.25 92/06/03 18:19:11 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.26 92/06/16 15:02:24 cer Exp Locker: cer $
 
 (in-package :tk-silica)
 
@@ -466,6 +466,164 @@ and on color servers, unless using white or black")
 		  gc))))))))
 
 
+
+;; Line (& maybe eventually non-rectangular polygon) clipping
+
+;; We use 32000 instead of the more correct 32768 because some buggy X servers
+;; barf on numbers very close to 32768.
+
+(defmacro valid-point-p (x y)
+  `(and (excl:fixnump ,x) (excl:fixnump ,y)
+	(< (the fixnum ,x) 32000) (> (the fixnum ,x) -32000)
+	(< (the fixnum ,y) 32000) (> (the fixnum ,y) -32000)))
+
+;;
+;; Here we implement a simple version of the Cohen-Sutherland clipping
+;; algorithm.  Specifically, we only try to clip the line so that it will
+;; be legal to pass to X, we don't try to clip to window boundaries.
+;; In port-draw-line* we special case trivial accepts for speed.
+;;
+(defun clipper (x1 y1 x2 y2
+		&optional (xmin -32000) (xmax 32000) (ymin -32000) (ymax 32000))
+  (declare (optimize (speed 3) (safety 0))
+	   #+ignore
+	   (:explain :calls :types)
+	   (fixnum x1 y1 x2 y2 xmin xmax ymin ymax))
+  (macrolet ((outcodes (x y)
+	       `(+ (ash (if (minusp (- ymax ,y)) 1 0) 3)
+		   (ash (if (minusp (- ,y ymin)) 1 0) 2)
+		   (ash (if (minusp (- xmax ,x)) 1 0) 1)
+		   (if (minusp (- ,x xmin)) 1 0)))
+	     (rejectp (oc1 oc2) `(plusp (logand ,oc1 ,oc2)))
+	     (acceptp (oc1 oc2)
+	       `(and (zerop ,oc1) (zerop ,oc2))))
+    (let ((outcode1 0) (outcode2 0))
+      (declare (type (unsigned-byte 4) outcode1 outcode2))
+      (loop
+	(setq outcode1 (outcodes x1 y1)
+	      outcode2 (outcodes x2 y2))
+	#+ignore
+	(format excl:*initial-terminal-io* "oc1 = ~d, oc2 = ~d~%" outcode1 outcode2)
+	(if (rejectp outcode1 outcode2)
+	    (return-from clipper nil))
+	(if* (acceptp outcode1 outcode2)
+	   then (return)
+	   else ;; If P1 is inside window, exchange P1 and P2 to guarantee
+		;; that P1 is outside window.
+		(if (zerop outcode1)
+		    (psetq x1 x2
+			   y1 y2
+			   x2 x1
+			   y2 y1
+			   outcode1 outcode2
+			   outcode2 outcode1))
+		;; Now perform a subdivision; move P1 to the intersection point.
+		;; Use the formulas y=y1+slope*(x-x1), x=x1+(1/slope)*(y-y1).
+		(if* (logbitp 3 outcode1)
+		   then ;; Divide line at top of window.
+			(setq x1 (round (+ x1 (* (- x2 x1)
+						 (/ (- ymax y1) (- y2 y1))))))
+			(setq y1 ymax)
+		 elseif (logbitp 2 outcode1)
+		   then ;; Divide line at bottom of window.
+			(setq x1 (round (+ x1 (* (- x2 x1)
+						 (/ (- ymin y1) (- y2 y1))))))
+			(setq y1 ymin)
+		 elseif (logbitp 1 outcode1)
+		   then ;; Divide line at right of window.
+			(setq x1 xmax)
+			(setq y1 (round (+ y1 (* (- y2 y1)
+						 (/ (- xmax x1) (- x2 x1))))))
+		 elseif (logbitp 0 outcode1)
+		   then ;; Divide line at left of window.
+			(setq x1 xmin)
+			(setq y1 (round (+ y1 (* (- y2 y1)
+						 (/ (- xmin x1) (- x2 x1)))))))
+		))))
+  (values x1 y1 x2 y2))
+
+(defmacro clip-invalidate-line (x1 y1 x2 y2)
+  `(if (or (not (valid-point-p ,x1 ,y1))
+	   (not (valid-point-p ,x2 ,y2)))
+       (multiple-value-setq (,x1 ,y1 ,x2 ,y2)
+	 (clipper ,x1 ,y1 ,x2 ,y2))))
+
+(defmethod port-draw-line* ((port xt-port) sheet medium x1 y1 x2 y2)
+  (let ((drawable (medium-drawable medium)))
+    (when drawable
+      (let ((ink (medium-ink medium))
+	    (transform (sheet-device-transformation sheet)))
+	(convert-to-device-coordinates transform x1 y1 x2 y2)
+	(clip-invalidate-line x1 y1 x2 y2)
+	(tk::draw-line
+	 drawable
+	 (adjust-ink (decode-ink ink medium)
+		     medium
+		     (medium-line-style medium)
+		     (the fixnum (min (the fixnum x1) (the fixnum x2)))
+		     (the fixnum (min (the fixnum y1) (the fixnum y2))))
+	 x1 y1 x2 y2)))))
+
+;; Discarding of other illegal graphics
+
+#|
+
+(defmacro int16ify (int &optional check-type-string)
+  "Make int (a fixnum) into an xlib:int16; int must be a
+   place.  Call check-type if it isn't in bounds."
+  ;; These are ordered in expected frequency of usage
+  `(if* (and (>= ,int -32768) (< ,int 32768))
+      then
+	   nil
+      else
+	   (setf ,int (make-into-int16 ,int ,check-type-string))))
+
+(defmacro card16ify (int &optional check-type-string)
+  "Make int (a fixnum) into an xlib:card16; int must be a
+   place.  Call check-type if it isn't in bounds."
+  ;; These are ordered in expected frequency of usage
+  `(if* (and (>= ,int 0) (< ,int 65536))
+      then
+	   nil
+      else
+	   (setf ,int (make-into-card16 ,int ,check-type-string))))
+
+(defun make-into-int16 (object string)
+  ;; Now it must be too big to fit in an xlib:int16.
+  (cond (cw::*fix-up-illegal-graphics-p*
+	 (max -32767 (min 32766 object)))
+	(t
+	 (check-type object xlib:int16 string)
+	 object)))
+
+(defun make-into-card16 (object string)
+  ;; Now it must be too big to fit in an xlib:int16.
+  (cond (cw::*fix-up-illegal-graphics-p*
+	 (max 0 (min 65534 object)))
+	(t
+	 (check-type object xlib:card16 string)
+	 object)))
+
+|#
+
+(defvar *discard-illegal-graphics* t)
+
+(defmacro discard-illegal-coordinates (function-name &rest positions)
+  (assert (evenp (length positions)) (positions)
+    "There must be an even number of elements in ~S" positions)
+  (let ((forms nil))
+    (do ()
+	((null positions))
+      (let* ((x (pop positions))
+	     (y (pop positions)))
+	(push `(valid-point-p ,x ,y) forms)))
+    `(unless (and ,@forms)
+       (if* *discard-illegal-graphics*
+	  then (return-from ,function-name)
+	  else (error "Coordinate(s) out of (signed-byte 16) range")))))
+
+
+
 (defmethod port-draw-point* ((port xt-port) sheet medium x y)
   (let ((drawable (medium-drawable medium)))
     (when drawable
@@ -474,6 +632,7 @@ and on color servers, unless using white or black")
 	     (thickness (line-style-thickness line-style))
 	     (transform (sheet-device-transformation sheet)))
 	(convert-to-device-coordinates transform x y)
+	(discard-illegal-coordinates port-draw-point* x y)
 	(cond ((< thickness 1.5)
 	       (tk::draw-point
 		drawable
@@ -498,27 +657,9 @@ and on color servers, unless using white or black")
 		thickness 0 2pi
 		t)))))))
 
-(defmethod port-draw-line* ((port xt-port) sheet medium
-			    x1 y1 x2 y2)
-  (let ((drawable (medium-drawable medium)))
-    (when drawable
-      (let ((ink (medium-ink medium))
-	    (transform (sheet-device-transformation sheet)))
-	(convert-to-device-coordinates transform
-				       x1 y1 x2 y2)
-	(tk::draw-line
-	 drawable
-	 (adjust-ink (decode-ink ink medium)
-		     medium
-		     (medium-line-style medium)
-		     (the fixnum (min (the fixnum x1) (the fixnum x2)))
-		     (the fixnum (min (the fixnum y1) (the fixnum y2))))
-	 x1 y1 x2 y2)))))
 
 
 (defmethod port-draw-lines* ((port xt-port) sheet medium list-of-x-and-ys)
-  ;;-- We should decide which version to use.
-  ;;-- We also need to deal with line clipping.
   (let* ((transform (sheet-device-transformation sheet))
 	 (len (length list-of-x-and-ys))
 	 (npoints (/ len 4))
@@ -528,89 +669,46 @@ and on color servers, unless using white or black")
 	 (minx most-positive-fixnum)
 	 (miny most-positive-fixnum)
 	 ink)
-    (if (listp list-of-x-and-ys)
+    (macrolet ((stuff-line-guts (x1 y1 x2 y2)
+		 `(let ((x1 ,x1)
+			(y1 ,y1)
+			(x2 ,x2)
+			(y2 ,y2))
+		    (convert-to-device-coordinates transform x1 y1)
+		    (convert-to-device-coordinates transform x2 y2)
+		    (clip-invalidate-line x1 y1 x2 y2)
+		    (minf minx x1)
+		    (minf miny y1)
+		    (minf minx x2)
+		    (minf miny y2)
+		    (setf (tk::xsegment-array-x1 points i) x1
+			  (tk::xsegment-array-y1 points i) y1
+			  (tk::xsegment-array-x2 points i) x2
+			  (tk::xsegment-array-y2 points i) y2))))
+      (if (listp list-of-x-and-ys)
+	  (do ((ps list-of-x-and-ys)
+	       (i 0 (1+ i)))
+	      ((null ps))
+	    (declare (fixnum i))
+	    (stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps)))
 	(do ((ps list-of-x-and-ys)
-	     (i 0 (1+ i)))
-	    ((null ps))
-	  (declare (fixnum i))
-	  (let ((x (pop ps))
-		(y (pop  ps)))
-	    (convert-to-device-coordinates transform x y)
-	    (minf minx x)
-	    (minf miny y)
-	    (setf (tk::xsegment-array-x1 points i) x
-		  (tk::xsegment-array-y1 points i) y))
-	  (let ((x (pop ps))
-		(y (pop ps)))
-	    (convert-to-device-coordinates transform x y)
-	    (minf minx x)
-	    (minf miny y)
-	    (setf (tk::xsegment-array-x2 points i) x
-		  (tk::xsegment-array-y2 points i) y)))
-      (do ((ps list-of-x-and-ys)
-	   (j 0 (+ 2 j))
-	   (i 0 (+ i 4)))
-	  ((= j len))
-	(declare (fixnum i j))
-	(let ((x (aref ps j))
-	      (y (aref ps (1+ j))))
-	  (convert-to-device-coordinates transform x y)
-	  (minf minx x)
-	  (minf miny y)
-	  (setf (tk::xsegment-array-x1 points i) x
-		(tk::xsegment-array-y1 points i) y))
-	
-	(let ((x (aref ps (+ 2 j)))
-	      (y (aref ps (+ 3 j))))
-	  (convert-to-device-coordinates transform x y)
-	  (minf minx x)
-	  (minf miny y)
-	  (setf (tk::xsegment-array-x2 points i) x
-		(tk::xsegment-array-y2 points i) y))))
-    (setq ink 
-      (adjust-ink (decode-ink (medium-ink medium) medium) medium
-		  (medium-line-style medium)
-		  minx miny))
-    (when (medium-drawable medium)
-      (x11:xdrawsegments
+	     (j 0 (+ 2 j))
+	     (i 0 (+ i 4)))
+	    ((= j len))
+	  (declare (fixnum i j))
+	  (stuff-line-guts (aref ps j) (aref ps (1+ j)) (aref ps (+ 2 j)) (aref ps (+ 3 j)))))
+      (setq ink 
+	(adjust-ink (decode-ink (medium-ink medium) medium) medium
+		    (medium-line-style medium)
+		    minx miny))
+      (when (medium-drawable medium)
+	(x11:xdrawsegments
 	 (tk::object-display window)
 	 window
 	 ink
 	 points
-	 npoints)))
-  #+ignore
-  (let ((drawable (medium-drawable medium)))
-    (when drawable
-      (let* ((ink (medium-ink medium))
-	     (transform (sheet-device-transformation sheet))
-	     (gc 
-	      (adjust-ink (decode-ink ink medium)
-			  medium
-			  (medium-line-style medium)
-			  0 0))
-	     (len (length list-of-x-and-ys))
-	     (lines list-of-x-and-ys))
-	(if (arrayp lines)
-	    (do ((i 0 (+ 4 i)))
-		((= i len))
-	      (let ((x1 (aref lines i))
-		    (y1 (aref lines (1+ i)))
-		    (x2 (aref lines (+ 2 i)))
-		    (y2 (aref lines (+ 3 i))))
-		(convert-to-device-coordinates transform x1 y1 x2 y2)
-		(tk::draw-line
-		 drawable gc
-		 x1 y1 x2 y2)))
-	  (loop
-	    (when (null lines) (return nil))
-	    (let ((x1 (pop lines))
-		  (y1 (pop lines))
-		  (x2 (pop lines))
-		  (y2 (pop lines)))
-	      (convert-to-device-coordinates transform x1 y1 x2 y2)
-	      (tk::draw-line
-	       drawable gc
-	       x1 y1 x2 y2))))))))
+	 npoints)))))
+
 
 (defmethod port-draw-rectangle* ((port xt-port) sheet medium
 				 x1 y1 x2 y2 filled)
@@ -621,6 +719,13 @@ and on color servers, unless using white or black")
 	(cond ((rectilinear-transformation-p transform)
 	       (convert-to-device-coordinates transform
 					      x1 y1 x2 y2)
+	       ;; Clipping a rectangle is ridiculously easy.
+	       (unless (valid-point-p x1 y1)
+		 (setq x1 (min (max -32000 (the fixnum x1)) 32000))
+		 (setq y1 (min (max -32000 (the fixnum y1)) 32000)))
+	       (unless (valid-point-p x2 y2)
+		 (setq x2 (min (max -32000 (the fixnum x2)) 32000))
+		 (setq y2 (min (max -32000 (the fixnum y2)) 32000)))
 	       (let ((min-x (min (the fixnum x1) (the fixnum x2)))
 		     (min-y (min (the fixnum y1) (the fixnum y2))))
 		 (declare (fixnum min-x min-y))
@@ -659,6 +764,7 @@ and on color servers, unless using white or black")
 	  (let ((x (first ps))
 		(y (second ps)))
 	    (convert-to-device-coordinates transform x y)
+	    (discard-illegal-coordinates port-draw-polygon* x y)
 	    (minf minx x)
 	    (minf miny y)
 	    (setf (tk::xpoint-array-x points i) x
@@ -670,6 +776,7 @@ and on color servers, unless using white or black")
 	(let ((x (aref ps j))
 	      (y (aref ps (1+ j))))
 	  (convert-to-device-coordinates transform x y)
+	  (discard-illegal-coordinates port-draw-polygon* x y)
 	  (minf minx x)
 	  (minf miny y)
 	  (setf (tk::xpoint-array-x points i) x
@@ -705,6 +812,7 @@ and on color servers, unless using white or black")
 			       start-angle end-angle filled)
   (let ((transform (sheet-device-transformation sheet)))
     (convert-to-device-coordinates transform center-x center-y)
+    (discard-illegal-coordinates port-draw-ellipse* center-x center-y)
     (convert-to-device-distances transform 
       radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
     (when (medium-drawable medium)
@@ -731,6 +839,7 @@ and on color servers, unless using white or black")
 	 (font (text-style-mapping port (medium-text-style medium)))
 	 (ascent (tk::font-ascent font)))
     (convert-to-device-coordinates transform x y)
+    (discard-illegal-coordinates port-draw-text* x y)
     (when towards-x
       (convert-to-device-coordinates transform towards-x towards-y))
     (when (typep string-or-char 'character)
@@ -1091,6 +1200,11 @@ and on color servers, unless using white or black")
 	       (height (- from-bottom from-top))
 	       (copy-gc (port-copy-gc port)))
 	  (when (and from-drawable to-drawable)
+	    (if (port-safe-backing-store port)
+		;; Don't bother with no-expose events.
+		(return-from port-copy-area
+		  (tk::copy-area from-drawable copy-gc from-left from-top
+				 width height to-drawable to-left to-top)))
 	    (with-port-event-lock (port)
 	      (let ((seq-no 0))
 		(without-interrupts
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 538e96b3..36cbe6a2 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.29 92/05/26 14:33:35 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.30 92/06/16 15:02:26 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
@@ -30,6 +30,9 @@
      (context :reader port-context)     
      (copy-gc :initform nil)
      (opacities :initform nil)
+     ;; This next is true for servers like Suns, which (pretty much) always
+     ;; can safely copy-area without generating graphics-exposures.
+     (safe-backing-store :initform nil :accessor port-safe-backing-store)
      (event-lock :initform (clim-sys:make-lock "port event lock")
 		 :reader port-event-lock)
      (rotated-font-cache :initform nil :accessor port-rotated-font-cache))
@@ -90,6 +93,15 @@
 	(setf (slot-value port 'application-shell) application-shell
 	      (slot-value port 'context) context
 	      (slot-value port 'display) display)
+	(let* ((screen (x11:xdefaultscreenofdisplay display))
+	       (bs-p (not (zerop (x11::screen-backing-store screen))))
+	       (su-p (not (zerop (x11::screen-save-unders screen))))
+	       (vendor (ff:char*-to-string (x11::display-vendor display))))
+	  (if (and bs-p su-p
+		   ;; An amazing crock.  XXX
+		   (not (search "Network Computing Devices" vendor))
+		   (not (search "Tektronix" vendor)))
+	      (setf (slot-value port 'safe-backing-store) t)))
 	(initialize-xlib-port port display)))))
 
 (defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
@@ -311,9 +323,10 @@
 		(sheet-mirror-resized-callback
 		 widget nil event sheet)
 		nil)
-	       ;; This is handled by the expose callback.
-	       (:expose
-		nil)
+	       (:no-expose nil)
+	       (:graphics-expose
+		;; Tricky!
+		(setf (port-safe-backing-store (port sheet)) nil))
 	       (:expose
 		;; This gets called only for an XmBulletinBoard widget.
 		(sheet-mirror-exposed-callback
diff --git a/tk/convenience.lisp b/tk/convenience.lisp
index e0b61d4b..aa650dc8 100644
--- a/tk/convenience.lisp
+++ b/tk/convenience.lisp
@@ -20,39 +20,39 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: convenience.lisp,v 1.8 92/04/21 20:27:27 cer Exp Locker: cer $
+;; $fiHeader: convenience.lisp,v 1.9 92/04/28 09:24:58 cer Exp $
 
 (in-package :tk)
 
-					;
-(defmacro define-convenience-class (class superclasses entry-point)
-  (let ((c-function-name
-	 (intern (substitute #\_ #\- 
-			     (lispify-tk-name entry-point :package nil)))))
-    `(progn
-       (defforeign ',c-function-name :entry-point ,entry-point)
-       (defclass ,class ,superclasses
-		 ()
-	 (:metaclass xt-class))
-       (defmethod make-widget ((w ,class) &rest args &key (managed t)
-			       (name "") 
-			       parent &allow-other-keys)
-	 (remf :name args)
-	 (remf :parent args)
-	 (remf :managed args)
-	 (let* ((arglist (make-arglist-for-class
-			  (find-class ',class)
-			  parent
-			  args))
-		(o 
-		 (,c-function-name
-		  parent
-		  (string-to-char* name)
-		  arglist
-		  (truncate (length arglist) 2))))
-	   (when managed
-	     (xt_manage_child o))
-	   o)))))
+(eval-when (eval compile)
+  (defmacro define-convenience-class (class superclasses entry-point)
+    (let ((c-function-name
+	   (intern (substitute #\_ #\- 
+			       (lispify-tk-name entry-point :package nil)))))
+      `(progn
+	 (defforeign ',c-function-name :entry-point ,entry-point)
+	 (defclass ,class ,superclasses
+	   ()
+	   (:metaclass xt-class))
+	 (defmethod make-widget ((w ,class) &rest args &key (managed t)
+					    (name "") 
+					    parent &allow-other-keys)
+	   (remf :name args)
+	   (remf :parent args)
+	   (remf :managed args)
+	   (let* ((arglist (make-arglist-for-class
+			    (find-class ',class)
+			    parent
+			    args))
+		  (o 
+		   (,c-function-name
+		    parent
+		    (string-to-char* name)
+		    arglist
+		    (truncate (length arglist) 2))))
+	     (when managed
+	       (xt_manage_child o))
+	     o))))))
 
 (define-convenience-class xm-menu-bar (xm-row-column) "_XmCreateMenuBar")
 (define-convenience-class xm-pulldown-menu (xm-row-column) "_XmCreatePulldownMenu")
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index a69ebee6..755101d6 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.16 92/05/22 19:26:21 cer Exp Locker: cer $
+;; $fiHeader: gcontext.lisp,v 1.17 92/05/26 14:32:53 cer Exp $
 
 (in-package :tk)
 
@@ -91,7 +91,7 @@
 				   name)
 			   :x11)
 		  gc-values)
-	     (,encoder nv ,@args))
+	     (,encoder gc nv ,@args))
 	 
 	   (x11:xchangegc
 	    (object-display gc)
@@ -104,6 +104,7 @@
   (defmacro define-gc-reader (name decoder &rest args)
     `(defmethod ,(intern (format nil "~A-~A" 'gcontext name)) ((gc gcontext))
        (,decoder 
+	gc
 	(,(intern (format nil "~A~A" '_xgc-values- name) :x11)
 	 gc)
 	,@args)))
@@ -186,40 +187,42 @@
 ;(define-gc-accessor background  (encode-pixel decode-pixel))
 
 (defmethod gcontext-foreground ((gc gcontext))
-  (decode-pixel (x11::_xgc-values-foreground gc)))
+  (decode-pixel gc (x11::_xgc-values-foreground gc)))
 
 (defmethod gcontext-background ((gc gcontext))
-  (decode-pixel (x11::_xgc-values-background gc)))
+  (decode-pixel gc (x11::_xgc-values-background gc)))
 
 (defmethod (setf gcontext-foreground) (nv (gc gcontext))
   (x11:xsetforeground 
    (object-display gc)
    gc
-   (encode-pixel nv)))
+   (encode-pixel gc nv)))
 
 (defmethod (setf gcontext-background) (nv (gc gcontext))
   (x11:xsetbackground 
    (object-display gc)
    gc
-   (encode-pixel nv)))
+   (encode-pixel gc nv)))
 
 
 (define-gc-accessor line-width  (encode-card16 decode-card16))
   
 (defmethod gcontext-fill-style ((gc gcontext))
   (decode-fill-style
-   (x11::_xgc-values-fill-style gc)))
+   gc (x11::_xgc-values-fill-style gc)))
 
-(defun decode-fill-style (x)
-  (declare (optimize (speed 3) (safety 0)))
+(defun decode-fill-style (gc x)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (case x
     (0 :solid)
     (1 :tiled)
     (2 :stippled)
     (3 :opaque-stippled)))
 
-(defun encode-fill-style (x)
-  (declare (optimize (speed 3) (safety 0)))
+(defun encode-fill-style (gc x)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (ecase x
     (:solid 0)
     (:tiled 1)
@@ -230,14 +233,15 @@
   (x11:xsetfillstyle
    (object-display gc)
    gc
-   (encode-fill-style nv)))
+   (encode-fill-style gc nv)))
   
 
 (define-gc-accessor fill-rule (encode-enum decode-enum) '(:even-odd :winding))
 (define-gc-accessor tile  (encode-pixmap decode-pixmap))
 (define-gc-accessor stipple  (encode-pixmap decode-pixmap))
 
-(defun encode-pixmap (x)
+(defun encode-pixmap (gc x)
+  (declare (ignore gc))
   x)
 
 (define-gc-accessor ts-x-origin (encode-int16 decode-int16))
@@ -247,8 +251,9 @@
 (define-gc-accessor font (encode-font decode-font))
 (define-gc-accessor cap-style (encode-cap-style decode-cap-style))
 
-(defun encode-cap-style (x)
-  (declare (optimize (speed 3) (safety 0)))
+(defun encode-cap-style (gc x)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (ecase x
     (:not-last 0)
     (:butt 1)
@@ -257,8 +262,9 @@
 
 (define-gc-accessor join-style (encode-join-style decode-join-style))
 
-(defun encode-join-style (x)
-  (declare (optimize (speed 3) (safety 0)))
+(defun encode-join-style (gc x)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (ecase x
     (:miter 0)
     (:round 1)
@@ -285,13 +291,19 @@
 		#.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
 		#.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
 
-(defun encode-function (x) 
+(defun encode-function (gc x)
+  (declare (ignore gc))
   (or (position x *boole-vector*)
       (error "Cannot encode gc function: ~S" x)))
 
-(defun encode-card32 (x) x)
-(defun encode-card16 (x) x)
-(defun encode-enum (x y)
+(defun encode-card32 (gc x)
+  (declare (ignore gc))
+  x)
+(defun encode-card16 (gc x)
+  (declare (ignore gc))
+  x)
+(defun encode-enum (gc x y)
+  (declare (ignore gc))
   (or (position x y)
       (error "cannot find ~s in ~s" x y)))
 
@@ -302,9 +314,9 @@
    (object-display gc)
    gc
    line-width
-   (encode-line-style line-style)
-   (encode-cap-style cap-style)
-   (encode-join-style join-style)))
+   (encode-line-style gc line-style)
+   (encode-cap-style gc cap-style)
+   (encode-join-style gc join-style)))
 
 (defmethod (setf gcontext-clip-mask) ((nv (eql :none)) (gc gcontext))
   (x11:xsetclipmask
@@ -353,8 +365,9 @@
   
 (define-gc-accessor line-style  (encode-line-style decode-style))
 
-(defun encode-line-style (x)
-  (declare (optimize (speed 3) (safety 0)))
+(defun encode-line-style (gc x)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (ecase x
     (:solid 0)
     (:dash 1)
@@ -362,7 +375,7 @@
 
 (defmethod (setf gcontext-dashes) (nv (gc gcontext))
   (multiple-value-bind (n v)
-      (encode-dashes nv)
+      (encode-dashes gc nv)
     (x11:xsetdashes
      (object-display gc)
      gc
@@ -371,8 +384,9 @@
      n)))
 
 
-(defun encode-dashes (nv)
-  (declare (optimize (speed 3) (safety 0)))
+(defun encode-dashes (gc nv)
+  (declare (optimize (speed 3) (safety 0))
+	   (ignore gc))
   (let* ((n (length nv))
 	 (v (excl:make-static-array n :element-type '(unsigned-byte 8))))
     (declare (fixnum n)
@@ -391,10 +405,14 @@
     (values n v)))
   
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun encode-int16 (x) x)
+(defun encode-int16 (gc x)
+  (declare (ignore gc))
+  x)
 
 
-(defun encode-font (x) (x11:xfontstruct-fid x))
+(defun encode-font (gc x)
+  (declare (ignore gc))
+  (x11:xfontstruct-fid x))
 
 
 
@@ -402,10 +420,11 @@
 ;;; wrappers
 
 
-(defun decode-card16 (x) x)
+(defun decode-card16 (gc x)
+  (declare (ignore gc))
+  x)
 
-(defun decode-font (x) 
-  (declare (special gc))
+(defun decode-font (gc x)
   (if (= x #16rffffffff)
       (error "cannot decode font")
     (let* ((display (object-display gc))
@@ -413,21 +432,29 @@
       (or font
 	  (query-font display x)))))
 
-(defun decode-pixmap (x)
-  (declare (special gc))
+(defun decode-pixmap (gc x)
   (and (/= #16rffffffff x)
        (intern-object-xid
 	x
 	'pixmap
 	(object-display gc))))
 
-(defun decode-clip-mask (x) x)
-(defun decode-enum (x y)
+(defun decode-clip-mask (gc x)
+  (declare (ignore gc))
+  x)
+(defun decode-enum (gc x y)
+  (declare (ignore gc))
   (or (elt y x)
       (error "cannot find ~s in ~s" x y)))
-(defun decode-card32 (x) x)
-(defun decode-dashes (x) x)
-(defun decode-int16 (x) x)
+(defun decode-card32 (gc x)
+  (declare (ignore gc))
+  x)
+(defun decode-dashes (gc x)
+  (declare (ignore gc))
+  x)
+(defun decode-int16 (gc x)
+  (declare (ignore gc))
+  x)
 
 
 ;;;;;;;;;;;;;;;;;;;
@@ -482,11 +509,13 @@
 	       (print gc))
 |#
 
-(defun decode-pixel (x) x)
+(defun decode-pixel (gc x)
+  (declare (ignore gc))
+  x)
 
-(defmethod encode-pixel ((x integer))
+(defmethod encode-pixel (gc (x integer))
+  (declare (ignore gc))
   x)
 
-(defmethod encode-pixel ((x color))
-  (declare (special gc))
+(defmethod encode-pixel (gc (x color))
   (allocate-color (default-colormap (object-display gc) 0) x))
diff --git a/tk/graphics.lisp b/tk/graphics.lisp
index 24892bbb..213aeae2 100644
--- a/tk/graphics.lisp
+++ b/tk/graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: graphics.lisp,v 1.7 92/04/15 11:44:45 cer Exp $
+;; $fiHeader: graphics.lisp,v 1.8 92/05/13 17:10:18 cer Exp $
 
 (in-package :tk)
 
@@ -62,20 +62,22 @@
 		     filled)
   (multiple-value-bind (x-radius y-radius)
       (cond ((and (= radius-1-dx 0) (= radius-2-dy 0))
-	     (values (abs radius-2-dx) (abs radius-1-dy)))
+	     (values (round (abs radius-2-dx))
+		     (round (abs radius-1-dy))))
 	    ((and (= radius-2-dx 0) (= radius-1-dy 0))
-	     (values (abs radius-1-dx) (abs radius-2-dy)))
+	     (values (round (abs radius-1-dx))
+		     (round (abs radius-2-dy))))
 	    (t
 	     (let ((s-1 (+ (* radius-1-dx radius-1-dx) 
 			   (* radius-1-dy radius-1-dy)))
 		   (s-2 (+ (* radius-2-dx radius-2-dx) 
 			   (* radius-2-dy radius-2-dy))))
 	       (if (= s-1 s-2)
-		   (let ((r (truncate (sqrt s-1))))
+		   (let ((r (round (sqrt s-1))))
 		     (values r r))
 		 ;; Degrade to drawing a rectilinear ellipse
-		 (values (truncate (sqrt s-1)) 
-			 (truncate (sqrt s-2)))))))
+		 (values (round (sqrt s-1)) 
+			 (round (sqrt s-2)))))))
     (setq start-angle (round (* start-angle (/ (* 360 64) (* 2 pi)))))
     (setq end-angle (round (* end-angle (/ (* 360 64) (* 2 pi)))))
     (if (> end-angle start-angle)
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 3a7c6856..a7ad37ef 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.18 92/05/22 19:26:24 cer Exp Locker: cer $
+;; $fiHeader: make-classes.lisp,v 1.19 92/06/03 18:18:11 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -33,10 +33,74 @@
 (defun get-foreign-variable-value (x)
   (class-array (get-entry-point-value x) 0))
 
+;; This is only called to fill in the cache, so it can be (real) slow.
+(defun get-resource-internal (class fn resource-class resource-name)
+  (let ((x (make-array 1 :element-type '(unsigned-byte 32)))
+	(y (make-array 1 :element-type '(unsigned-byte 32))))
+    (funcall fn (class-handle class) x y)
+    (let ((resources (aref x 0))
+	  (n (aref y 0)))
+      (dotimes (i n)
+	(let* ((res (x-resource-list resources i))
+	       (original-name (x-resource-name res))
+	       (name (lispify-resource-name (char*-to-string original-name))))
+	  (if (equal name resource-name)
+	      (let ((*package* (find-package :tk)))
+		(return-from get-resource-internal
+		  (make-instance
+		      resource-class
+		    :original-name original-name
+		    :name name
+		    :class (lispify-resource-class 
+			    (char*-to-string (x-resource-class res)))
+		    :type (lispify-resource-type 
+			   (char*-to-string (x-resource-type res)))))))))))
+  #+ignore
+  (error "No resource named ~s found for class ~s" resource-name class)
+  ;; Error is actually caught in calling functions.
+  #-ignore
+  nil)
+
+(defmethod find-class-resource ((class xt-class) resource-name)
+  (declare (optimize (speed 3) (safety 0)))
+  (with-slots (cached-resources specially-hacked-resources) class
+    (let ((value (gethash resource-name cached-resources :not-found)))
+      (if (not (eq value :not-found))
+	  value				; Never had it, never will
+	(setf (gethash resource-name cached-resources)
+	  (if* (find resource-name specially-hacked-resources
+		     :key #'resource-name)
+	     thenret
+	     else (get-resource-internal class
+					 #'xt_get_resource_list
+					 'resource
+					 resource-name)))))))
+
+(defmethod find-class-constraint-resource ((class xt-class) resource-name)
+  (declare (optimize (speed 3) (safety 0)))
+  (with-slots (cached-constraint-resources) class
+    (let ((value (gethash resource-name cached-constraint-resources :not-found)))
+      (if (not (eq value :not-found))
+	  value				; Never had it, never will
+	(setf (gethash resource-name cached-constraint-resources)
+	  (get-resource-internal class
+				 #'xt_get_constraint_resource_list
+				 'constraint-resource
+				 resource-name))))))
+
+
+
+;; These next five aren't used except maybe by describe-widget.
+(defmethod class-resources ((class xt-class))
+  (get-resource-list class))
+
+(defmethod class-constraint-resources ((class xt-class))
+  (get-constraint-resource-list class))
+
 (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))))
-    (funcall fn class x y)
+    (funcall fn (class-handle class) x y)
     (let ((resources (aref x 0))
 	  (n (aref y 0))
 	  (r nil))
@@ -60,7 +124,7 @@
   (get-resource-list-internal class #'xt_get_constraint_resource_list
 			      'constraint-resource))
 
-
+
 
 (defclass xt-root-class (display-object)
   ((events :initform nil :accessor widget-event-handler-data)
@@ -88,103 +152,56 @@
 
 (defmethod print-object ((r basic-resource) s)
   (print-unreadable-object (r s :type t :identity nil)
-			   (format s "~A,~A " 
-				   (resource-name r)
-				   (resource-type r))))
+    (format s "~A,~A "
+	    (if (slot-boundp r 'name)
+		(resource-name r)
+	      "..UNBOUND..")
+	    (if (slot-boundp r 'type)
+		(resource-type r)
+	      "..UNBOUND.."))))
 
 (defun lispify-resource-name (x) (lispify-tk-name x :package :keyword))
 (defun lispify-resource-class (x) (lispify-tk-name x))
 (defun lispify-resource-type (x) (lispify-tk-name x))
 
-(defclass resource (basic-resource)
-	  ())
 
+(defclass resource (basic-resource)
+  ())
 
-			 
 (defclass constraint-resource (basic-resource)
-	  ())
+  ())
 
 
 (defun make-classes (classes)
-  (let ((direct-resources nil)
-	(all-resources nil))
-
-
-    (dolist (class-ep classes)
-      (let ((h (get-foreign-variable-value class-ep)))
-	(push (list h 
-		    class-ep
-		    (get-resource-list h)
-		    (get-constraint-resource-list h))
-	      direct-resources)))
-      
-    (setq direct-resources (nreverse direct-resources))
+  (let ((clist nil))
     
     (dolist (class-ep classes)
       (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep)
       (let ((h (get-foreign-variable-value class-ep)))
-	(xt_initialize_widget_class h)
-	(push (list h
-		    (get-resource-list h)
-		    (get-constraint-resource-list h))
-	      all-resources)))
+	(push (list h class-ep) clist)
+	(xt_initialize_widget_class h)))
+    (setq clist (nreverse clist))
 
-    (do ((directs direct-resources (cdr directs))
+    (do ((cs clist (cdr cs))
 	 r)
-	((null directs)
+	((null cs)
 	 (nreverse r))
-      (destructuring-bind
-       ((handle class-ep direct-resources direct-constraints) . ignore)
-       directs
-       (declare (ignore ignore))
-       (destructuring-bind
-	(handle all-resources all-constraints) 
-	(assoc handle all-resources)
+      (destructuring-bind (handle class-ep) (car cs)
 	(let ((class
 	       (clos::ensure-class
 		(lispify-class-name (widget-class-name handle))
 		:direct-superclasses (list (if (zerop (xt-class-superclass handle))
 					       'xt-root-class
-					     (lispify-class-name (widget-class-name
-								  (xt-class-superclass handle)))))
+					     (lispify-class-name
+					      (widget-class-name
+					       (xt-class-superclass handle)))))
 		:direct-slots nil
 		:metaclass 'xt-class
-		:direct-resources  direct-resources
-		:direct-constraints  direct-constraints
-		:resources all-resources
-		:constraints  all-constraints
 		:entry-point class-ep
-		:foreign-address  (get-foreign-variable-value class-ep))))
+		:foreign-address (get-foreign-variable-value class-ep))))
 	  (register-address class)
-	  (add-accessors-for-toolkit-class class)
-	  (push class r)))))))
-
+	  (push class r))))))
 
-(defun add-accessors-for-toolkit-class (class)
-  #+ignore
-  (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
-		      :lambda-list '(x)
-		      :qualifiers nil
-		      :specializers (list class)
-		      :function #'(lambda (x)
-				    (get-values x rname))))
-      (add-method
-       (ensure-generic-function `(setf ,name))
-       (make-instance 'clos::standard-method
-		      :lambda-list '(nv x)
-		      :qualifiers nil
-		      :specializers (list (find-class t) class)
-		      :function #'(lambda (nv x)
-				    (set-values x rname nv)
-				    nv))))))
 
 (defun define-toolkit-classes (&rest classes)
   (make-classes (remove-duplicates 
@@ -231,16 +248,6 @@
 	 package)
       string)))
 
-(defun collect-resource-types (c)
-  (let (ts)
-    (clos::map-over-subclasses
-     #'(lambda (class)
-	 (dolist (r (append (class-constraint-resources class) (class-resources class)))
-	   (pushnew (resource-type r) ts)))
-     c)
-    ts))
-
-
 
 (defun-c-callable toolkit-error-handler ((message :unsigned-long))
   (error "toolkit error: ~a" (char*-to-string message)))
@@ -249,15 +256,10 @@
   (let ((*error-output* excl:*initial-terminal-io*))
     (warn "toolkit warning: ~a" (char*-to-string message))))
 
-
+;; This is a terrible hack used to compensate for bugs/inconsistencies
+;; in the XM and OLIT toolkits.
 (defun add-resource-to-class (class resource)
   (clos::map-over-subclasses
    #'(lambda (c)
-       (push
-	resource
-	(slot-value c 'resources)))
+       (pushnew resource (slot-value c 'specially-hacked-resources)))
    class))
-
-#|
-(make-widget class parent . resources)
-|#
diff --git a/tk/meta-tk.lisp b/tk/meta-tk.lisp
index 533c86f3..f9e56b10 100644
--- a/tk/meta-tk.lisp
+++ b/tk/meta-tk.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: meta-tk.lisp,v 1.7 92/03/30 17:51:45 cer Exp $
+;; $fiHeader: meta-tk.lisp,v 1.8 92/05/13 17:10:23 cer Exp $
 
 
 (in-package :tk)
@@ -29,18 +29,15 @@
 (defclass xt-class (standard-class ff:foreign-pointer)
   ((entry-point :initarg :entry-point
 		:reader class-entry-point)
-   (resources :initform nil
-	      :initarg :resources
-	      :reader class-resources)
-   (constraint-resources :initform nil
-			 :initarg :constraints
-			 :reader class-constraint-resources)
-   (direct-resources :initform nil
-		     :initarg :direct-resources
-		     :reader class-direct-resources)
-   (constraint-resources :initform nil
-			 :initarg :direct-constraints
-			 :reader class-direct-constraint-resources)
+   ;; Resources are now looked up on the fly, and cached lazily one by one.
+   ;; Note that direct resources and direct constraint resources are no
+   ;; longer available, since initializing the XT widget class removes the
+   ;; ability to determine them lazily.
+   (cached-resources :initform (make-hash-table :test #'equal)
+		     :type hash-table)
+   (specially-hacked-resources :initform nil) ; See add-resource-to-class.
+   (cached-constraint-resources :initform (make-hash-table :test #'equal)
+		     :type hash-table)
    (get-values-cache :initform (make-hash-table :test #'equal)
 		     :type hash-table
 		     :reader class-get-values-cache)
@@ -53,15 +50,7 @@
     (clos::finalize-inheritance class))
   (dolist (c (clos::class-precedence-list class) 
 	    (error "Cannot get handle for class" class))
-    (when (typep c 'xt-class)
+    (when (and (typep c 'xt-class)
+	       (not (zerop (ff:foreign-pointer-address c))))
       (return c))))
 
-(defmethod clos::finalize-inheritance :after ((class xt-class))
-  (let ((super (car (clos::class-direct-superclasses class))))
-    (when (typep super 'xt-class)
-      (unless (slot-value class 'resources)
-	(setf (slot-value class 'resources)
-	  (slot-value super 'resources)))
-      (unless (slot-value class 'constraint-resources)
-	(setf (slot-value class 'constraint-resources)
-	  (slot-value super 'constraint-resources))))))
diff --git a/tk/pkg.lisp b/tk/pkg.lisp
index cbd9cce1..a73aec7a 100644
--- a/tk/pkg.lisp
+++ b/tk/pkg.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.8 92/04/21 20:27:39 cer Exp $
+;; $fiHeader: pkg.lisp,v 1.9 92/05/13 17:10:24 cer Exp $
 
 (defpackage :tk
   ;;-- No we really need
@@ -36,5 +36,13 @@
    #:top-level-shell
    #:popup
    #:manage-child
+   #:card32
+   #:card29
+   #:card24
+   #:card16
+   #:card8
+   #:int32
+   #:int16
+   #:int8
    ))
 
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 2f5d5b56..297e9ed9 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.22 92/05/22 19:26:30 cer Exp Locker: cer $
+;; $fiHeader: resources.lisp,v 1.23 92/06/16 15:01:07 cer Exp Locker: cer $
 
 (in-package :tk)
 
@@ -45,6 +45,7 @@
 (defconstant xm_string_default_char_set "")
 
 (defmethod convert-resource-in (class (type (eql 'xm-string)) value)
+  (declare (ignore class))
   (and (not (zerop value))
        (with-ref-par ((string 0))
 	 ;;--- I think we need to read the book about
@@ -263,16 +264,14 @@
 
 (defun fill-sv-cache (parent-class class resources)
   (let* ((len (length resources))
-	 (class-resources (class-resources class))
-	 (constraint-resources (and parent-class (class-constraint-resources parent-class)))
 	 (arglist (make-xt-arglist :number len))
 	 (rds nil)
 	 (constraint-resource-used nil)
 	 (i 0))
     (dolist (r resources)
-      (let ((resource (or (find r class-resources :key #'resource-name :test #'eq)
+      (let ((resource (or (find-class-resource class r)
 			  (psetq constraint-resource-used t)
-			  (find r constraint-resources :key #'resource-name :test #'eq))))
+			  (and parent-class (find-class-constraint-resource parent-class r)))))
 	(unless resource
 	  (error "No such resource ~S for widget of class ~S "
 		 r class))
@@ -328,9 +327,6 @@
 (defun make-arglist-for-class (class parent args)
   (declare (optimize (speed 3) (safety 0)))
   (do ((new-args nil)
-       (resources-1 (class-resources class))
-       (resources-2 (and parent (class-constraint-resources
-				    (class-of parent))))
        keyword
        value)
       ((null args)
@@ -339,8 +335,8 @@
 		   :initial-contents (nreverse new-args)))
     (setq keyword (pop args)
 	  value (pop args))
-    (let ((resource (or (find keyword resources-1 :key #'resource-name)
-			(find keyword resources-2 :key #'resource-name))))
+    (let ((resource (or (find-class-resource class keyword)
+			(find-class-constraint-resource class keyword))))
       (when resource
 	(push (resource-original-name resource) new-args)
 	(let ((type (resource-type resource)))
@@ -418,8 +414,6 @@
 (defun fill-gv-cache (parent-class class resources)
   (setq resources (copy-list resources)) ; So get-values can declare dynamic-extent
   (let* ((len (length resources))
-	 (class-resources (class-resources class))
-	 (constraint-resources (and parent-class (class-constraint-resources parent-class)))
 	 (arglist (make-xt-arglist :number len))
 	 (rds nil)
 	 (constraint-resource-used nil)
@@ -427,9 +421,10 @@
     (dotimes (j len)
       (setf (xt-arglist-value arglist j) (excl::malloc 8))) ; A crock...
     (dolist (r resources)
-      (let ((resource (or (find r class-resources :key #'resource-name :test #'eq)
+      (let ((resource (or (find-class-resource class r)
 			  (psetq constraint-resource-used t)
-			  (find r constraint-resources :key #'resource-name :test #'eq))))
+			  (and parent-class
+			       (find-class-constraint-resource parent-class r)))))
 	(unless resource
 	  (error "No such resource ~S for widget of class ~S "
 		 r class))
@@ -556,7 +551,7 @@
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value)
   (etypecase value
     (pixmap
-     (encode-pixmap value))))
+     (encode-pixmap nil value))))
 
 (defmethod convert-resource-out ((widget t) (type (eql 'widget)) x)
   x)
@@ -569,7 +564,7 @@
 
 
 
-(defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value)
+(defmethod convert-resource-out ((parent t) (type (eql 'xm-string-table)) value)
   (if value
       (do* ((n (length value))
 	    ;;--- Malloc alert
@@ -612,7 +607,7 @@
 
 ;;-- This is a problem cos we dont know the number of items
 
-(defmethod convert-resource-in (parent (type (eql 'xm-string-table)) value)
+(defmethod convert-resource-in ((parent t) (type (eql 'xm-string-table)) value)
   value)
 
 (defun convert-xm-string-table-in (parent table n)
@@ -621,7 +616,7 @@
       (push (convert-resource-in parent 'xm-string (x-arglist table i))
 	    r))))
 
-(defmethod convert-resource-out (parent (type (eql 'proc)) value)
+(defmethod convert-resource-out ((parent t) (type (eql 'proc)) value)
   (etypecase value
     ;;-- Should check to see if its registered
     (integer value)))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 964eda6f..f406e688 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,10 +20,26 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.18 92/05/22 19:26:33 cer Exp Locker: cer $
+;; $fiHeader: xlib.lisp,v 1.19 92/05/26 14:32:55 cer Exp $
 
 (in-package :tk)
 
+(deftype card32 () '(unsigned-byte 32))
+
+(deftype card29 () '(unsigned-byte 29))
+
+(deftype card24 () '(unsigned-byte 24))
+
+(deftype card16 () '(unsigned-byte 16))
+
+(deftype card8 () '(unsigned-byte 8))
+
+(deftype int32 () '(signed-byte 32))
+
+(deftype int16 () '(signed-byte 16))
+
+(deftype int8 () '(signed-byte 8))
+
 ;;; Pathetic clos interface to Xlib
 
 (defclass display-object (ff:foreign-pointer)
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index cb9b02c4..8e8d00dc 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: lisp-utilities.lisp,v 1.10 92/05/13 17:10:40 cer Exp $
+;; $fiHeader: lisp-utilities.lisp,v 1.11 92/05/26 14:33:02 cer Exp $
 
 (in-package :clim-utils)
 
@@ -153,18 +153,17 @@
 (defmacro convert-to-device-coordinates (transform &body positions)
   (assert (evenp (length positions)) (positions)
     "There must be an even number of elements in ~S" positions)
-  (let ((forms nil)
-	(nx (gensym))
-	(ny (gensym)))
+  (let ((forms nil))
     (loop
       (when (null positions)
 	(return `(progn ,@(nreverse forms))))
       (let* ((x (pop positions))
 	     (y (pop positions)))
-	(push `(multiple-value-bind (,nx ,ny) 
-		   (transform-position ,transform ,x ,y)
-		 (setq ,x (fix-coordinate ,nx)
-		       ,y (fix-coordinate ,ny)))
+	(push `(progn
+		 (multiple-value-setq (,x ,y) 
+		   (transform-position ,transform ,x ,y))
+		 (setq ,x (fix-coordinate ,x)
+		       ,y (fix-coordinate ,y)))
 	      forms)))))
 
 ;;
@@ -173,18 +172,16 @@
 (defmacro convert-to-device-distances (transform &body positions)
   (assert (evenp (length positions)) (positions)
 	  "There must be an even number of elements in ~S" positions)
-  (let ((forms nil)
-	(nx (gensym))
-	(ny (gensym)))
+  (let ((forms nil))
     (loop
       (when (null positions)
 	(return `(progn ,@(nreverse forms))))
       (let* ((x (pop positions))
 	     (y (pop positions)))
-	(push `(multiple-value-bind (,nx ,ny) 
+	(push `(multiple-value-bind (,x ,y) 
 		   (transform-distance ,transform ,x ,y)
-		 (setq ,x (fix-coordinate ,nx)
-		       ,y (fix-coordinate ,ny)))
+		 (setq ,x (fix-coordinate ,x)
+		       ,y (fix-coordinate ,y)))
 	      forms)))))
 
 
-- 
GitLab