From 4c1a898c3557fceaab280791454d6930e868ce0e Mon Sep 17 00:00:00 2001
From: colin <colin>
Date: Thu, 8 Apr 1993 13:19:27 +0000
Subject: [PATCH] Makefile.generic - added stub-*.c files to list of files to
 be rm'd with make clean

clim/frames.lisp
- :command-menu now back to old style clim1 pane (clim2rfe230)
- :menu-bar produces toolkit menu bar panes (clim2rfe230)
- fixed bug in find-applicable-translators-for-documentation
  (clim2bug409)

silica/gadgets.lisp
- menu-bar now inherits from oriented-gadget-mixin (clim2rfe230)

test/test-suite.lisp
- added tests for clipping with rectangle-sets

tk/gcontext.lisp
- (setf gcontext-clip-mask) can now take a list of rectangles

tk-silica/xm-frames.lisp
- frame-manger-contruct-menu now handles row-wise, n-columns and
  n-rows (clim2bug401)

tk-silica/xt-graphics.lisp
- a bunch of changes to make rectangle sets work as clipping regions
  (clim2bug346)
- pattern and tile decoding unified. transparent patterns are now
  limited to two colors (as tiles used to be).

tk-silica/xt-silica.lisp
- fixed up minor problem with hp's scalable fonts.

utils/region-arithmetic.lisp
- removed bounding-rectangle from list of superclasses of
  standard-rectangle-set (list includes region-set which itself
  inherits from bounding-rectangle)
---
 Makefile.generic           |   5 +-
 clim/frames.lisp           |  32 ++-
 silica/gadgets.lisp        |   3 +-
 test/test-suite.lisp       |  52 +++-
 tk-silica/ol-frames.lisp   |   7 +-
 tk-silica/xm-frames.lisp   |  22 +-
 tk-silica/xt-frames.lisp   |  12 +-
 tk-silica/xt-graphics.lisp | 514 +++++++++++++------------------------
 tk-silica/xt-silica.lisp   |  28 +-
 9 files changed, 300 insertions(+), 375 deletions(-)

diff --git a/Makefile.generic b/Makefile.generic
index 805584e6..22b1e505 100644
--- a/Makefile.generic
+++ b/Makefile.generic
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.generic,v 1.6 93/04/02 18:40:38 cer Exp $
+# $fiHeader: Makefile.generic,v 1.7 93/04/07 09:06:22 cer Exp $
 #
 #  Makefile.generic for CLIM 2.0
 #
@@ -196,7 +196,8 @@ cleanobjs:
 
 clean:
 	find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \
-	  $(CLIMOBJS) stub-motif.o stub-olit.o slim slim-small
+	  $(CLIMOBJS) stub-motif.o stub-olit.o stub-xt.o stub-x.o \
+	  stub-motif.c stub-olit.c stub-xt.c stub-x.c slim slim-small
 
 
 cheapclean:
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 6c905610..4221af72 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.62 93/03/31 10:38:34 cer Exp $
+;; $fiHeader: frames.lisp,v 1.63 93/04/02 13:36:00 cer Exp $
 
 (in-package :clim-internals)
 
@@ -395,13 +395,19 @@
      :end-of-page-action :allow 
      :end-of-line-action :allow))
 
-(define-pane-type :command-menu (&rest options &key command-table)
+(define-pane-type :command-menu (&rest options)
   (declare (non-dynamic-extent options))
-  (with-keywords-removed (options options '(:command-table))
-    `(make-pane 'menu-bar 
-		,@options
-		:command-table ,(or command-table
-				    `(frame-command-table frame)))))
+  `(make-clim-stream-pane
+     :type 'command-menu-pane
+     ,@options
+     :display-function `(display-command-menu :command-table ,(frame-command-table frame))
+     :incremental-redisplay t
+     :display-after-commands t
+     :text-style *command-table-menu-text-style*
+     :scroll-bars nil
+     :width :compute :height :compute
+     :end-of-page-action :allow 
+     :end-of-line-action :allow))
 
 
 (define-pane-type :interactor (&rest options &key (scroll-bars :vertical))
@@ -482,9 +488,13 @@
   (declare (non-dynamic-extent options))
   `(make-pane 'option-pane ,@options))
 
-(define-pane-type menu-bar (&rest options)
+(define-pane-type :menu-bar (&rest options &key command-table)
   (declare (non-dynamic-extent options))
-  `(make-pane 'menu-bar ,@options))
+  (with-keywords-removed (options options '(:command-table))
+    `(make-pane 'menu-bar 
+		,@options
+		:command-table ,(or command-table
+				    `(frame-command-table frame)))))
 
 
 (defmethod find-or-make-pane-named ((frame standard-application-frame) name)
@@ -1520,9 +1530,7 @@
 			(button-translator (intern symbol))
 			(button-presentation (fintern "~A-~A" symbol 'presentation))
 			(button-context (fintern "~A-~A" symbol 'context)))
-		   `(when (and (or (null ,button-translator)
-				   (> (presentation-translator-priority ,translator)
-				      (presentation-translator-priority ,button-translator)))
+		   `(when (and (null ,button-translator)
 			       (button-and-modifier-state-matches-gesture-name-p
 				 (button-index ,button) modifier-state
 				 (presentation-translator-gesture-name ,translator)))
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index 0347a878..80b08781 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.47 93/03/19 09:44:44 cer Exp $
+;; $fiHeader: gadgets.lisp,v 1.48 93/03/31 10:39:36 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -333,6 +333,7 @@
 
 ;;; Menu bar
 (defclass menu-bar (pane
+		    oriented-gadget-mixin
 		    sheet-with-resources-mixin)
     ((command-table :initarg :command-table :initform nil
 		    :accessor menu-bar-command-table)))
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 05089735..5bc8dd99 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.58 93/04/07 09:07:12 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.59 93/04/07 17:23:55 cer Exp $
 
 (in-package :clim-user)
 
@@ -231,6 +231,20 @@ What about environment issue?
 			    :line-thickness size))))))))
 
 
+(defparameter *chess-board-clip-region*
+    (let ((region +nowhere+)
+	  (cell 80)
+	  (grid 8))
+      (dotimes (i grid)
+	(dotimes (j grid)
+	  (when (eq (evenp i) (evenp j))
+	    (setq region 
+	      (region-union
+	       (make-bounding-rectangle
+		(* i cell) (* j cell) (* (1+ i) cell) (* (1+ j) cell))
+	       region)))))
+      region))
+
 (defparameter *gettysburg-address*
 	      "
 Fourscore and seven years ago our forefathers
@@ -770,10 +784,38 @@ people, shall not perish from the earth.
 				filename 
 				:designs
 				(list +background-ink+ +foreground-ink+))))
-		  (draw-rectangle* stream 0 0 (pattern-width pattern) (pattern-height pattern) :ink pattern))
+		  (draw-rectangle* stream 0 0 
+				   (pattern-width pattern)
+				   (pattern-height pattern)
+				   :ink pattern))
+	      (write-string "not found" stream))))))))
+
+#+allegro
+(define-test (clipped-image-test graphics) (stream)
+  "Test clipping of images"
+  (formatting-table (stream)
+    (dolist (name '("woman" "escherknot" "tie_fighter" "mensetmanus"))
+      (formatting-row (stream)
+	(formatting-cell (stream)
+	  (write-string name stream))
+	(formatting-cell (stream)
+	  (let ((filename (format nil "/usr/include/X11/bitmaps/~A" name)))
+	    (if (probe-file filename)
+		(let ((pattern (make-pattern-from-bitmap-file
+				filename 
+				:designs
+				(list +background-ink+ +foreground-ink+))))
+		  (with-drawing-options (stream :clipping-region 
+						*chess-board-clip-region*)
+		    (draw-rectangle* stream 0 0 
+				     (pattern-width pattern)
+				     (pattern-height pattern) 
+				     :ink pattern)))
 	      (write-string "not found" stream))))))))
 
 
+
+
 (define-test (draw-some-bezier-curves graphics) (stream)
   "Draw bezier curve"
   (let ((points (list 0 0 100 300 300 300 400 0 200 200 150 30 0 0)))
@@ -2419,7 +2461,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 (define-benchmark (clipped-line-drawing :iterations 10) (stream)
   "Draw lines through a clipping region"
-  (with-drawing-options (stream :clipping-region (make-bounding-rectangle 50 50 250 250))
+  (with-drawing-options (stream :clipping-region *chess-board-clip-region*)
     (line-drawing-kernel stream 50)))
 
 (defun shape-drawing-kernel (stream n-shapes filled-p &key (clear t))
@@ -2484,7 +2526,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 (define-benchmark (clipped-shape-drawing :iterations 5) (stream)
   "Draw shapes through a clipping region"
-  (with-drawing-options (stream :clipping-region (make-bounding-rectangle 50 50 250 250))
+  (with-drawing-options (stream :clipping-region *chess-board-clip-region*)
     (shape-drawing-kernel stream 10 nil)))
 
 ;;; Text benchmarks
@@ -2525,7 +2567,7 @@ Luke Luck licks the lakes Luke's duck likes."))
 
 (define-benchmark (clipped-text-output :iterations 3) (stream)
   "Draw lines through a clipping region"
-  (with-drawing-options (stream :clipping-region (make-bounding-rectangle 50 50 250 250))
+  (with-drawing-options (stream :clipping-region *chess-board-clip-region*)
     (repeat 5
       (write-string "Four" stream)
       (write-string " score and " stream)
diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp
index ed424354..0cff1dc5 100644
--- a/tk-silica/ol-frames.lisp
+++ b/tk-silica/ol-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-frames.lisp,v 1.21 93/03/19 09:46:52 cer Exp $
+;; $fiHeader: ol-frames.lisp,v 1.22 93/03/31 10:40:10 cer Exp $
 
 
 (in-package :xm-silica)
@@ -59,7 +59,10 @@
 	    associated-window
 	    text-style
 	    label
-	    gesture)
+	    gesture
+	    row-wise
+	    n-columns
+	    n-rows)
   (declare (ignore gesture))
   (let* (value-returned 
 	 return-value
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index c2885d5a..18c4447a 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.51 93/03/31 10:40:17 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.52 93/04/02 13:37:20 cer Exp $
 
 (in-package :xm-silica)
 
@@ -65,7 +65,7 @@
       (values 'xt::xm-row-column 
 	      ;;--- It makes sense to be able to specify the orientation
 	      ;;--- of the command menu
-	      (list :orientation :horizontal))
+	      (list :orientation (gadget-orientation sheet)))
     (values 
      'tk::xm-menu-bar 
      ;;---- This seems important but why
@@ -333,7 +333,12 @@
 	    associated-window
 	    text-style
 	    label
-	    gesture)
+	    gesture
+	    row-wise
+	    n-columns
+	    n-rows)
+  (when row-wise
+    (rotatef n-rows n-columns))
   (let* (value-returned 
 	 return-value
 	 (simplep (and (null printer)
@@ -350,6 +355,17 @@
 					   (#.+pointer-middle-button+ "<Btn2Down>")
 					   (#.+pointer-right-button+ "<Btn3Down>")
 					   (t "<Btn3Down>"))
+			      :orientation (if row-wise 
+					       :horizontal
+					     :vertical)
+			      :packing :column
+			      :num-columns 
+			      (or n-columns
+				  (and n-rows
+				       (ceiling (length items) n-rows))
+				  (if row-wise 
+				      (length items)
+				    1))
 			      :managed nil))
 	 (font (and text-style (text-style-mapping port text-style)))
 	 (font-list (and (or label simplep) font (list :font-list (list font)))))
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index ddf172b3..a4311266 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.30 93/03/31 10:40:25 cer Exp $
+;; $fiHeader: xt-frames.lisp,v 1.31 93/04/02 13:37:33 cer Exp $
 
 
 (in-package :xm-silica)
@@ -105,7 +105,10 @@
 		 (id-test 'equal)
 		 (cache-value items)
 		 (cache-test #'equal)
-		 (gesture :select))
+		 (gesture :select)
+		 row-wise
+		 n-columns
+		 n-rows)
   (declare (ignore keys))      
   (declare (values value chosen-item gesture))
   (let ((port (port framem))
@@ -135,7 +138,10 @@
 				      associated-window
 				      text-style
 				      label
-				      gesture))
+				      gesture
+				      row-wise
+				      n-columns
+				      n-rows))
       (when cache
 	(push (list unique-id cache-value menu closure) 
 	      (frame-manager-menu-cache framem))))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 19a4f23b..7acbbabd 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,34 +20,34 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.68 93/04/02 13:37:36 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.69 93/04/07 09:07:27 cer Exp $
 
 (in-package :tk-silica)
 
 (defclass ink-gcontext (tk::gcontext)
-  ((last-medium-clip-mask :initform nil :fixed-index 2)
+  ((last-device-clip-region :initform nil :fixed-index 2)
    (last-line-style :initform nil :fixed-index 3)
    (shift-tile-origin :initform nil :fixed-index 4)
-   (ink-clip-mask :initform nil :fixed-index 5)))
+   (ink-clip-region :initform nil :fixed-index 5)))
 
-(defmacro ink-gcontext-last-line-style (gcontext)
+(defmacro ink-gcontext-last-device-clip-region (gcontext)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					'last-line-style)))
-(defsetf ink-gcontext-last-line-style (gcontext) (value)
+					'last-device-clip-region)))
+(defsetf ink-gcontext-last-device-clip-region (gcontext) (value)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					      'last-line-style)
+					      'last-device-clip-region)
        ,value)))
 
-(defmacro ink-gcontext-last-medium-clip-mask (gcontext)
+(defmacro ink-gcontext-last-line-style (gcontext)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					'last-medium-clip-mask)))
-(defsetf ink-gcontext-last-medium-clip-mask (gcontext) (value)
+					'last-line-style)))
+(defsetf ink-gcontext-last-line-style (gcontext) (value)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					      'last-medium-clip-mask)
+					      'last-line-style)
        ,value)))
 
 (defmacro ink-gcontext-shift-tile-origin (gcontext)
@@ -60,21 +60,21 @@
 					      'shift-tile-origin)
        ,value)))
 
-(defmacro ink-gcontext-ink-clip-mask (gcontext)
+(defmacro ink-gcontext-ink-clip-region (gcontext)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					'ink-clip-mask)))
-(defsetf ink-gcontext-ink-clip-mask (gcontext) (value)
+					'ink-clip-region)))
+(defsetf ink-gcontext-ink-clip-region (gcontext) (value)
   `(locally (declare (optimize (speed 3) (safety 0)))
      (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
-					      'ink-clip-mask)
+					      'ink-clip-region)
        ,value)))
 
 (defclass xt-medium (basic-medium)
   ((drawable :initform nil)
    (ink-table :initform (make-hash-table :test #'equal))
    (indirect-inks :initform nil)
-   (clip-mask :initform nil)))
+   (device-clip-region :initform nil)))
 
 (defmethod make-medium ((port xt-port) sheet)
   (make-instance 'xt-medium
@@ -258,46 +258,33 @@
 
 
 ;;
-;; Clip mask is invalidated when:
+;; medium's device clip region is invalidated when:
 ;;   1. medium's sheet's device region changes
 ;;   2. medium's clipping region changes
 ;;   3. medium's sheet's device transformation changes
 
-(defmethod medium-clip-mask ((medium xt-medium))
-  (with-slots (sheet clip-mask) medium
-    (or clip-mask
-	(setf clip-mask
+(defun medium-device-clip-region (medium)
+  (with-slots (sheet device-clip-region) medium
+    (or device-clip-region
+	(setf device-clip-region
 	  (let ((dr (sheet-device-region sheet))
 		(mcr (medium-clipping-region medium)))
-	    (unless (eq mcr +everywhere+)
-	      (setq mcr (transform-region (sheet-device-transformation sheet) mcr))
-	      (setq dr (region-intersection dr (bounding-rectangle mcr))))
-	    (cond ((eq dr +everywhere+)
-		   :none)
-		  ((eq dr +nowhere+)
-		   :nowhere)
-		  #+ignore
-		  ((typep dr 'clim-utils:standard-rectangle-set)
-		   ;;-- Do something more complicated
-		   )
-		  (t
-		   (with-bounding-rectangle* (left top right bottom) dr
-		     (list (fix-coordinate left) (fix-coordinate top) 
-			   (fix-coordinate (- right left))
-			   (fix-coordinate (- bottom top)))))))))))
+	    (region-intersection 
+	     dr 
+	     (transform-region (sheet-device-transformation sheet) mcr)))))))
 
 (defmethod (setf medium-clipping-region) :after (cr (medium xt-medium))
   (declare (ignore cr))
-  (with-slots (clip-mask) medium
-    (setf clip-mask nil)))
+  (with-slots (device-clip-region) medium
+    (setf device-clip-region nil)))
 
 (defmethod invalidate-cached-regions :after ((medium xt-medium))
-  (with-slots (clip-mask) medium
-    (setf clip-mask nil)))
+  (with-slots (device-clip-region) medium
+    (setf device-clip-region nil)))
 
 (defmethod invalidate-cached-transformations :after ((medium xt-medium))
-  (with-slots (clip-mask) medium
-    (setf clip-mask nil)))
+  (with-slots (device-clip-region) medium
+    (setf device-clip-region nil)))
 
 
 
@@ -311,12 +298,12 @@
   (tk::widget-window mirror nil))
 
 (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet)
-  (with-slots (indirect-inks drawable clip-mask)
+  (with-slots (indirect-inks drawable device-clip-region)
       medium
     (let ((palette (medium-palette medium)))
       (with-slots (white-pixel black-pixel)
 	  palette
-	(setf indirect-inks nil clip-mask nil)
+	(setf indirect-inks nil device-clip-region nil)
 	(setf (medium-sheet medium) sheet)
 	(when (and drawable
 		   (not (eq (port-display port)
@@ -389,114 +376,79 @@
 
 (defvar *default-dashes* '(4 4))
 
-(defun adjust-ink (gc medium line-style x-origin y-origin)
-  (unless (eq (ink-gcontext-last-line-style gc) line-style)
-    (let* ((dashes (line-style-dashes line-style))
-	   (gc-line-style (if dashes :dash :solid)))
-	
-      (tk::set-line-attributes 
-       gc
-       (let ((thickness (line-style-thickness line-style)))
-	 (ecase (line-style-unit line-style)
-	   (:normal)
-	   (:point
-	    (setq thickness (* (graft-pixels-per-point (graft medium))
-			       thickness))))
-	 (when (< thickness 2)
-	   (setq thickness 0))
-	 (setq thickness (the fixnum (round thickness)))
-	 thickness)
-       gc-line-style
-       (ecase (line-style-cap-shape line-style)
-	 (:butt :butt)
-	 (:square :projecting)
-	 (:round :round)
-	 (:no-end-point :not-last))
-       (ecase (line-style-joint-shape line-style)
-	 ((:miter :none) :miter)
-	 (:bevel :bevel)
-	 (:round :round)))
-    
-      (when (eq gc-line-style :dash)
-	(setf (tk::gcontext-dashes gc)
-	  (if (excl::sequencep dashes) dashes *default-dashes*))
-	;; The following isn't really right, but it's better than nothing.
-	(setf (tk::gcontext-dash-offset gc) (1- y-origin))))
-    (setf (ink-gcontext-last-line-style gc) line-style))
-
-  (let ((ink-clip-mask (ink-gcontext-ink-clip-mask gc))
-	(medium-clip-mask (medium-clip-mask medium))
-	(last-clip-mask (ink-gcontext-last-medium-clip-mask gc)))
-    (multiple-value-bind (clip-mask x-origin y-origin)
-	(adjust-clip-mask medium ink-clip-mask medium-clip-mask x-origin y-origin)
-      (unless (eq last-clip-mask clip-mask)
-	(when (and (not (eq last-clip-mask ink-clip-mask))
-		   (typep last-clip-mask 'tk::pixmap))
-	  (tk::destroy-pixmap last-clip-mask))
-	(setf (tk::gcontext-clip-mask gc) clip-mask
-	      (ink-gcontext-last-medium-clip-mask gc) clip-mask))
-      (when x-origin
-	(setf (tk::gcontext-clip-x-origin gc) x-origin
-	      (tk::gcontext-clip-y-origin gc) y-origin))))
-      
+(defun adjust-ink (gc medium x-origin y-origin)
+  
+  ;; line style
+  (let ((line-style (medium-line-style medium)))
+    (unless (eq (ink-gcontext-last-line-style gc) 
+		line-style)
+      (let* ((dashes (line-style-dashes line-style))
+	     (gc-line-style (if dashes :dash :solid)))
+	(tk::set-line-attributes 
+	 gc
+	 (let ((thickness (line-style-thickness line-style)))
+	   (ecase (line-style-unit line-style)
+	     (:normal)
+	     (:point
+	      (setq thickness (* (graft-pixels-per-point (graft medium))
+				 thickness))))
+	   (if (< thickness 2)
+	       0
+	     (the fixnum (round thickness))))
+	 gc-line-style
+	 (ecase (line-style-cap-shape line-style)
+	   (:butt :butt)
+	   (:square :projecting)
+	   (:round :round)
+	   (:no-end-point :not-last))
+	 (ecase (line-style-joint-shape line-style)
+	   ((:miter :none) :miter)
+	   (:bevel :bevel)
+	   (:round :round)))
+	(when (eq gc-line-style :dash)
+	  (setf (tk::gcontext-dashes gc)
+	    (if (excl::sequencep dashes) dashes *default-dashes*))
+	  ;; The following isn't really right, but it's better than nothing.
+	  (setf (tk::gcontext-dash-offset gc) (1- y-origin))))
+      (setf (ink-gcontext-last-line-style gc) line-style)))
+
+  ;; clip mask
+  (let ((device-clip-region (medium-device-clip-region medium))
+	(ink-clip-region (ink-gcontext-ink-clip-region gc)))
+    (when ink-clip-region
+      (setq device-clip-region 
+	(region-intersection (transform-region
+			      (make-translation-transformation x-origin y-origin)
+			      ink-clip-region)
+			     device-clip-region)))
+    (unless (eq (ink-gcontext-last-device-clip-region gc)
+		device-clip-region)
+      (setf (tk::gcontext-clip-mask gc)
+	(macrolet ((region-rectangle (region)
+		     `(with-bounding-rectangle* (left top right bottom) ,region
+		        (list (fix-coordinate left) (fix-coordinate top) 
+			      (fix-coordinate (- right left))
+			      (fix-coordinate (- bottom top))))))
+	  (etypecase device-clip-region
+	    (everywhere :none)
+	    (nowhere nil)
+	    (standard-rectangle-set
+	     (let ((regions (region-set-regions device-clip-region))
+		   (rectangles nil))
+	       (dolist (region regions)
+		 (push (region-rectangle region) rectangles))
+	       rectangles))
+	    (standard-bounding-rectangle
+	     (list (region-rectangle device-clip-region))))))
+      (setf (ink-gcontext-last-device-clip-region gc) device-clip-region)))
+
+  ;; tile and stipple origin
   (when (ink-gcontext-shift-tile-origin gc)
     (setf (tk::gcontext-ts-x-origin gc) x-origin
 	  (tk::gcontext-ts-y-origin gc) y-origin))
   gc)
 
-(defun adjust-clip-mask (medium ink-clip-mask medium-clip-mask x-origin y-origin)
-  (if ink-clip-mask
-      (cond 
-       ((eq medium-clip-mask :nowhere) :nowhere)
-       ((eq medium-clip-mask :none) 
-	  (values ink-clip-mask x-origin y-origin))
-       (t
-	;; all subsequent co-ordinates are relative to x,y-origin
-	(let ((ink-pixmap-p (typep ink-clip-mask 'tk::pixmap))
-	      (medium-x (- (first medium-clip-mask) x-origin))
-	      (medium-y (- (second medium-clip-mask) y-origin))
-	      (medium-width (third medium-clip-mask))
-	      (medium-height (fourth medium-clip-mask))
-	      ink-x ink-y ink-width ink-height)
-	  (if ink-pixmap-p
-	      (setq ink-x 0 ink-y 0
-		    ink-width (tk::pixmap-width ink-clip-mask)
-		    ink-height (tk::pixmap-height ink-clip-mask))
-	    (setq ink-x (first ink-clip-mask)
-		  ink-y (second ink-clip-mask)
-		  ink-width (third ink-clip-mask)
-		  ink-height (fourth ink-clip-mask)))
-	  #+ignore (format excl:*initial-terminal-io* "~&ink:~d,~d,~d,~d"
-			   ink-x ink-y ink-width ink-height)
-	  #+ignore (format excl:*initial-terminal-io* "~&medium:~d,~d,~d,~d"
-			   medium-x medium-y medium-width medium-height)
-	  (let* ((x (max ink-x medium-x))
-		 (width (- (min (+ ink-x ink-width)
-				(+ medium-x medium-width))
-			   x))
-		 (y (max ink-y medium-y))
-		 (height (- (min (+ ink-y ink-height)
-				 (+ medium-y medium-height))
-			    y)))
-	    (if (or (<= width 0) (<= height 0))
-		:nowhere
-	      (if (and (= width ink-width) (= height ink-height))
-		  (values ink-clip-mask x-origin y-origin)
-		(if ink-pixmap-p
-		    (let* ((clip-pixmap (make-instance 'tk::pixmap
-						       :drawable ink-clip-mask
-						       :width width
-						       :height height
-						       :depth 1))
-			   (port (port (medium-sheet medium))))
-		      (stream-bitblt-support (port-copy-gc-depth-1 port)
-					     ink-clip-mask x y
-					     clip-pixmap 0 0
-					     width height)
-		      (values clip-pixmap (+ x-origin x) (+ y-origin y)))
-		  (values (list x y width height) x-origin y-origin))))))))
-    medium-clip-mask))
-
+  
 ;;; decode ink
 
 (defgeneric decode-ink (ink medium))
@@ -608,185 +560,90 @@
   (decode-ink-1 (decode-contrasting-ink ink medium) medium))
 
 (defmethod decode-ink-1 ((pattern pattern) (medium xt-medium)) 
+  (decode-pattern-ink pattern medium))
+    
+(defmethod decode-ink-1 ((ink rectangular-tile) (medium xt-medium))
+  (multiple-value-bind (pattern width height)
+      (decode-rectangular-tile ink)
+    (declare (ignore width height))
+    (decode-pattern-ink pattern medium t)))
+      
+(defun decode-pattern-ink (pattern medium &optional tile-p)
   (multiple-value-bind (array designs)
       (decode-pattern pattern)
     (let* ((height (array-dimension array 0))
-	   (width (array-dimension array 1))
+	   (width (array-dimension array 0))
 	   (image-data (make-array (list height width)))
-	   (clip-image-data (make-array (list height width)
-					:initial-element 1))
 	   (design-pixels (make-array (length designs)))
-	   (transparent-p nil))
-	(declare (simple-vector design-pixels))
-
-	;; Cache the decoded designs from the pattern
-	(dotimes (n (length designs))
-	  (let ((design (elt designs n)))
-	    (if (eql design +nowhere+)
-		(setf transparent-p t)
-	      (setf (svref design-pixels n)
-		(decode-color design medium)))))
-	
-	(dotimes (w width)
-	  (dotimes (h height)
-	    (let ((pixel (svref design-pixels (aref array h w))))
-	      (setf (aref image-data h w)
-		(or pixel
-		    (setf (aref clip-image-data h w) 0))))))
-	(let* ((port (port (medium-sheet medium)))
-	       (drawable (or (slot-value medium 'drawable)
-			     (tk::display-root-window (port-display port))))
-	       (depth (tk::drawable-depth drawable))
-	       (image (make-instance 'tk::image
-				    :width width
-				    :height height
-				    :data image-data
-				    :depth depth))
-	       (clip-image (and transparent-p
-				(make-instance 'tk::image
-					       :width width
-					       :height height
-					       :data clip-image-data
-					       :depth 1)))
-	       (gc (make-instance 'ink-gcontext :drawable drawable))
-	       (pixmap (make-instance 'tk::pixmap
-				      :drawable drawable
-				      :width width
-				      :height height
-				      :depth depth))
-	       (clip-mask (if transparent-p
-			      (make-instance 'tk::pixmap
-					     :drawable drawable
-					     :width width
-					     :height height
-					     :depth 1)
-			    (list 0 0 width height))))
-	  (tk::put-image pixmap gc image)
-	  (when transparent-p
-	    (tk::put-image clip-mask 
+	   (two-color-p (eql (length designs) 2))
+	   two-color-fg
+	   two-color-bg)
+      (declare (simple-vector design-pixels))
+
+      ;; Cache the decoded designs from the pattern
+      (dotimes (n (length designs))
+	(let ((design (elt designs n)))
+	  (if (eql design +nowhere+)
+	      (unless two-color-p
+		(error "Transparent pattern ~S has more than two designs" pattern))
+	    (setf (svref design-pixels n)
+	      (decode-color design medium)))))
+
+      (when two-color-p
+	(setq two-color-bg (svref design-pixels 0)
+	      two-color-fg (svref design-pixels 1))
+	;; make sure that any transparent design is the bg
+	(when (null (svref design-pixels 1))
+	  (rotatef two-color-bg two-color-fg)))
+	    
+      (dotimes (w width)
+	(dotimes (h height)
+	  (let ((pixel (svref design-pixels (aref array h w))))
+	    (setf (aref image-data h w)
+	      (if two-color-p
+		  (if (eq pixel two-color-bg)
+		      0
+		    1)
+		pixel)))))
+
+      (let* ((port (port (medium-sheet medium)))
+	     (drawable (or (slot-value medium 'drawable)
+			   (tk::display-root-window
+			    (port-display port)))) 
+	     (depth (if two-color-p
+			1
+		      (tk::drawable-depth drawable)))
+	     (image (make-instance 'tk::image
+				   :width width
+				   :height height
+				   :data image-data
+				   :depth depth))
+	     (gc (make-instance 'ink-gcontext :drawable drawable))
+	     (pixmap 
+	      (make-instance 'tk::pixmap
+			     :drawable drawable
+			     :width width
+			     :height height
+			     :depth depth)))
+	(tk::put-image pixmap 
+		       (if two-color-p
 			   (port-copy-gc-depth-1 port)
-			   clip-image))
+			 gc) 
+		       image)
+	(if two-color-p
+	    (setf (tk::gcontext-stipple gc) pixmap
+		  (tk::gcontext-fill-style gc) (if two-color-bg
+						   :opaque-stippled
+						 :stippled)
+		  (tk::gcontext-foreground gc) (or two-color-fg 0)
+		  (tk::gcontext-background gc) (or two-color-bg 0))
 	  (setf (tk::gcontext-tile gc) pixmap
-		(tk::gcontext-fill-style gc) :tiled
-		(ink-gcontext-ink-clip-mask gc) clip-mask
-		(ink-gcontext-shift-tile-origin gc) t)
-	  gc))))
-
-;;---the following extends a pattern for tiling by making it
-;;transparent. This causes problems in the test-suite. This is more
-;;correct with regards to the spec but maybe the spec is "wrong" on
-;;this one
-#+ignore 
-(defun decode-extended-pattern (pattern width height)
-  (multiple-value-bind (array designs)
-      (decode-pattern pattern)
-    (if (and (= (array-dimension array 0) height)
-	     (= (array-dimension array 1) width))
-	(values array designs)
-      (let* ((transparent (position +nowhere+ designs))
-	     (extended-designs 
-	      (if transparent
-		  designs
-		(progn
-		  (setq transparent (length designs))
-		  (concatenate 'vector designs (vector +nowhere+)))))
-	     (extended-array (make-array (list height width))))
-	(dotimes (w width)
-	  (dotimes (h height)
-	    (setf (aref extended-array h w)
-	      (if (array-in-bounds-p array h w)
-		  (aref array h w)
-		transparent))))
-	(values extended-array extended-designs)))))
-
-;; for the moment we use this one which replicates the pattern
-(defun decode-extended-pattern (pattern width height)
-  (multiple-value-bind (array designs)
-      (decode-pattern pattern)
-    (let ((pattern-height (array-dimension array 0))
-	  (pattern-width (array-dimension array 1)))
-      (if (or (< pattern-height height)
-	      (< pattern-width width))
-	  (let* ((extended-array (make-array (list height width))))
-	    (dotimes (w width)
-	      (dotimes (h height)
-		(setf (aref extended-array h w)
-		  (aref array (mod h pattern-height) (mod w pattern-width)))))
-	    (values extended-array designs))
-	(values array designs)))))
-	    
-(defmethod decode-ink-1 ((ink rectangular-tile) (medium xt-medium))
-  (multiple-value-bind (pattern width height)
-      (decode-rectangular-tile ink)
-    (multiple-value-bind (array designs)
-	(decode-extended-pattern pattern width height)
-      (let* ((image-data (make-array (list height width)))
-	     (design-pixels (make-array (length designs)))
-	     (two-color-p (= (length designs) 2)) 
-	     two-color-fg two-color-bg)
-	(declare (simple-vector design-pixels))
-
-	;; Cache the decoded designs from the pattern
-	(dotimes (n (length designs))
-	  (let ((design (elt designs n)))
-	    (if (eql design +nowhere+)
-		(unless two-color-p
-		  (error "Transparent tiled pattern ~S has more than two designs"
-			 pattern))
-	      (setf (svref design-pixels n)
-		(decode-color design medium)))))
-		
-	(when two-color-p
-	  (setq two-color-bg (svref design-pixels 0)
-		two-color-fg (svref design-pixels 1))
-	  ;; make sure that any transparent design is the bg
-	  (when (null (svref design-pixels 1))
-	    (rotatef two-color-bg two-color-fg)))
-	    
-	(dotimes (w width)
-	  (dotimes (h height)
-	    (let ((pixel (svref design-pixels (aref array h w))))
-	      (setf (aref image-data h w)
-		(if two-color-p
-		    (if (eq pixel two-color-bg)
-			0
-		      1)
-		  pixel)))))
-
-	(let* ((port (port (medium-sheet medium)))
-	       (drawable (or (slot-value medium 'drawable)
-			     (tk::display-root-window
-			      (port-display port)))) 
-	       (depth (if two-color-p
-			  1
-			(tk::drawable-depth drawable)))
-	       (image (make-instance 'tk::image
-				     :width width
-				     :height height
-				     :data image-data
-				     :depth depth))
-	       (gc (make-instance 'ink-gcontext :drawable drawable))
-	       (pixmap 
-		(make-instance 'tk::pixmap
-			       :drawable drawable
-			       :width width
-			       :height height
-			       :depth depth)))
-	  (tk::put-image pixmap 
-			 (if two-color-p
-			     (port-copy-gc-depth-1 port)
-			   gc) 
-			 image)
-	  (if two-color-p
-	      (setf (tk::gcontext-stipple gc) pixmap
-		    (tk::gcontext-fill-style gc) (if two-color-bg
-						     :opaque-stippled
-						   :stippled)
-		    (tk::gcontext-foreground gc) (or two-color-fg 0)
-		    (tk::gcontext-background gc) (or two-color-bg 0))
-	    (setf (tk::gcontext-tile gc) pixmap
-		  (tk::gcontext-fill-style gc) :tiled))
-	  gc)))))
+		(tk::gcontext-fill-style gc) :tiled))
+	(unless tile-p
+	  (setf (ink-gcontext-shift-tile-origin gc) t
+		(ink-gcontext-ink-clip-region gc) 
+		(make-bounding-rectangle 0 0 width height)))
+	gc))))
 
 ;;; decode color
 
@@ -1069,7 +926,6 @@
 		drawable
 		(adjust-ink (decode-ink ink medium)
 			    medium
-			    line-style
 			    x y)
 		x y))
 	      (t
@@ -1078,7 +934,6 @@
 		drawable
 		(adjust-ink (decode-ink ink medium)
 			    medium
-			    line-style
 			    (the fixnum (- (the fixnum x) (the fixnum thickness)))
 			    (the fixnum (- (the fixnum y) (the fixnum thickness))))
 		x y 
@@ -1129,7 +984,6 @@
 		      drawable
 		      (adjust-ink (decode-ink ink medium)
 				  medium
-				  line-style
 				  minx miny)
 		      points
 		      j
@@ -1157,7 +1011,6 @@
 		      drawable
 		      (adjust-ink (decode-ink ink medium)
 				  medium
-				  line-style
 				  minx
 				  miny)
 		      points
@@ -1176,7 +1029,6 @@
 	 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)))))
@@ -1225,7 +1077,6 @@
 			       (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))
 	  (x11:xdrawsegments
 	   (tk::object-display drawable)
@@ -1257,7 +1108,6 @@
 	   drawable
 	   (adjust-ink (decode-ink ink medium)
 		       medium
-		       (medium-line-style medium)
 		       min-x min-y)
 	   min-x min-y
 	   (fast-abs (the fixnum (- (the fixnum x2) (the fixnum x1))))
@@ -1311,7 +1161,6 @@
 	   drawable
 	   (adjust-ink (decode-ink ink medium)
 		       medium
-		       (medium-line-style medium)
 		       overall-min-x overall-min-y)
 	   rects
 	   nrects
@@ -1364,7 +1213,6 @@
 		(tk::xpoint-array-y points (- npoints 1)) (tk::xpoint-array-y points 0)))
 	(setq ink 
 	  (adjust-ink (decode-ink (medium-ink medium) medium) medium
-		      (medium-line-style medium)
 		      minx miny))
 	(if filled
 	    (x11:xfillpolygon
@@ -1406,7 +1254,6 @@
 	  drawable
 	  (adjust-ink (decode-ink (medium-ink medium) medium)
 		      medium
-		      (medium-line-style medium)
 		      (- center-x 
 			 (abs (if (zerop radius-1-dx) radius-2-dx radius-1-dx)))
 		      (- center-y 
@@ -1464,7 +1311,6 @@
         (let ((gc (adjust-ink
 		   (decode-ink (medium-ink medium) medium)
 		   medium
-		   (medium-line-style medium)
 		   x 
 		   (- y ascent))))
 	  (setf (tk::gcontext-font gc) font)
@@ -1550,8 +1396,8 @@
 
 
 	  #+ignore (setf (tk::gcontext-clip-mask gcontext) pixmap)
-	  #+ignore (setf (ink-gcontext-last-medium-clip-mask gcontext) nil)
-	  
+	  #+ignore (setf (ink-gcontext-last-device-clip-region gcontext) nil)
+
 	  (unless start (setq start 0))
 	  (unless end (setq end (length string)))
 	  
@@ -1587,7 +1433,7 @@
 		  (3 (values (- x ascent) (- y pixmap-height))))
 		    
 	      (setf (tk::gcontext-clip-mask gcontext) string-pixmap)
-	      (setf (ink-gcontext-last-medium-clip-mask gcontext) nil)
+	      (setf (ink-gcontext-last-device-clip-region gcontext) nil)
 	      (setf (tk::gcontext-clip-x-origin gcontext) dst-x
 		    (tk::gcontext-clip-y-origin gcontext) dst-y)
 	      (tk::draw-rectangle drawable gcontext
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 2da8f4bc..a536e1f8 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.75 93/04/02 13:37:41 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.76 93/04/07 09:07:31 cer Exp $
 
 (in-package :xm-silica)
 
@@ -147,13 +147,13 @@
 	       '(:static-color :true-color :pseudo-color :direct-color))
        t))
 
-(defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
-			     (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*")
+(defvar *xt-font-families* '((:fix "-*-courier-*-*-*-*-*-*-*-*-*-*-*-*")
+			     (:sans-serif "-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*")
 			     (:serif 
 			      ;; This causes problems on OpenWindows 3.0!
-			      ;; "*-*-charter-*-*-*-*-*-*-*-*-*-*-*-*"
-			      "*-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*"
-			      "*-*-times-*-*-*-*-*-*-*-*-*-*-*-*")))
+			      ;; "-*-charter-*-*-*-*-*-*-*-*-*-*-*-*"
+			      "-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*"
+			      "-*-times-*-*-*-*-*-*-*-*-*-*-*-*")))
 
 (defun disassemble-x-font-name (name)
   (let ((cpos 0)
@@ -189,7 +189,7 @@
 			      (if bold '(:bold :italic) :italic)
 			    (if bold :bold :roman)))
 		    (designed-point-size (parse-integer (ninth tokens)))
-		    (designed-y-resolution (parse-integer (nth 10 tokens)))
+		    (designed-y-resolution (parse-integer (nth 11 tokens)))
 		    (point-size (* (float designed-point-size)
 				   (/ designed-y-resolution
 				      screen-pixels-per-inch)))
@@ -199,12 +199,14 @@
 	(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 (text-style-mapping-exists-p
-			 port text-style *standard-character-set* t)
-		  (setf (text-style-mapping port text-style) xfont)))))
+	      ;; this hack overcomes a bug with hp's scalable fonts
+	      (unless (find #\* xfont)
+		(let ((text-style (font->text-style xfont family)))
+		  ;; prefer first font satisfying this text style, so
+		  ;; don't override if we've already defined one.
+		  (unless (text-style-mapping-exists-p
+			   port text-style *standard-character-set* t)
+		    (setf (text-style-mapping port text-style) xfont))))))
 	  ;; Now build the logical size alist for the family
 	  ))
       (let (temp)
-- 
GitLab