From 3003bf0552e02661e615d06d4c2dd3d4253fa331 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Mon, 8 Feb 1993 15:58:26 +0000
Subject: [PATCH] clim/accept-values.lisp		Added right-margin,
 bottom-margin as keywords to 			
 invoke-accepting-values clim/command.lisp		Removed NIL test from
 map-over-command-table-menu-items clim/db-stream.lisp	
 make-clim-stream-pane passes background to all 			
 the sheets it makes. clim/frames.lisp		Changed error message, added
 command-callback function clim/menus.lisp			Added gesture
 argument to menu-choose clim/noting-progress.lisp	Started fixing
 clim/output-protocol.lisp climtoys/coverage.lisp		Added
 generic-functions-with-no-methods function climtoys/test-clim.lisp	
 Added etst for tf107 and tf100 demo/navfun.lisp
 postscript/postscript-medium.lisp		font-map now grows when needed
 postscript/postscript-port.lisp	Removed limit on 30 fonts.
 silica/db-border.lisp		Fix pane, repaints on size change
 silica/db-box.lisp		Added bulletin board (incomplete)
 silica/framem.lisp		graft of frame-manager is not find-graft
 silica/gadgets.lisp		Added word-wrap to text editor, and 	
 		row-column-gadget mixin silica/mirror.lisp	
 Removed cruft silica/pixmaps.lisp		Check to see whether sheet can
 have medium silica/port.lisp		Removed cruft and added graft methods
 silica/sheet.lisp		Removed cruft and added sheet methods
 test/chess.lisp			Reference correct directory
 test/test.lisp			Added tests tk/event.lisp		
 Event handler tracks catches errors inside wait-function tk/make-classes.lisp
 	xt_initialize_widget_class is called when we 			
 need to access class rather than at build time. 			
 Means we can work with regular libraries. tk/xlib.lisp			Event
 handler tracks catches errors inside wait-function tk-silica/ol-gadgets.lisp
 	Word wrap for text editor tk-silica/xm-frames.lisp		Fixed
 separator in menus and gesture in menus tk-silica/xm-gadgets.lisp	
 word wrap in text editor tk-silica/xt-frames.lisp		gesture inmenu
 tk-silica/xt-gadgets.lisp		Removed multiple calls to
 with-sheet-medium tk-silica/xt-pixmaps.lisp		Implemented
 deallocate-pixmap tk-silica/xt-silica.lisp		Destroy-port does
 harmless stuff utils/clos.lisp		Fixed name in setf* defgeneric
 utils/packages.lisp		Fixed Exports

---
 silica/port.lisp | 31 ++++++++++++++++---------------
 test/chess.lisp  |  6 +++---
 tk/event.lisp    | 24 ++++++++++++++----------
 utils/clos.lisp  |  4 ++--
 4 files changed, 35 insertions(+), 30 deletions(-)

diff --git a/silica/port.lisp b/silica/port.lisp
index 0325abf8..3369dad4 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.28 92/12/14 15:03:36 cer Exp $
+;; $fiHeader: port.lisp,v 1.29 92/12/16 16:49:39 cer Exp $
 
 (in-package :silica)
 
@@ -146,16 +146,13 @@
 			   :condition condition
 			   :sheet sheet)))))
 
-
-(defgeneric add-watcher (port watcher))
-(defgeneric remove-watcher (port watcher))
-(defgeneric reset-watcher (watcher how))
-
-
 ;;;;;;;;;;;;;;;;
 
 (define-protocol-class graft (sheet))
 
+(defgeneric graft-orientation (graft))
+(defgeneric graft-units (graft))
+
 (defclass standard-graft 
 	  (mirrored-sheet-mixin
 	   sheet-multiple-child-mixin
@@ -172,6 +169,18 @@
      (mm-height :reader graft-mm-height)
      (pixels-per-point :reader graft-pixels-per-point)))
 
+(defgeneric graft-pixels-per-millimeter (graft))
+
+(defmethod graft-pixels-per-millimeter ((graft standard-graft))
+  (with-slots (mm-width pixel-width) graft
+    (/ pixel-width mm-width)))
+
+(defgeneric graft-pixels-per-inch (graft))
+
+(defmethod graft-pixels-per-inch ((graft standard-graft))
+  (with-slots (mm-width pixel-width) graft
+    (* 25.4 (/ pixel-width mm-width))))
+
 (defun find-graft (&key (server-path *default-server-path*)
 			(port (find-port :server-path server-path))
 			(orientation :default)
@@ -257,11 +266,3 @@
 
 (defmethod graft ((object t)) nil)
 
-
-(defgeneric graft-orientation (graft))
-(defgeneric graft-units (graft))
-(defgeneric graft-width (graft))
-(defgeneric graft-height (graft))
-(defgeneric graft-pixels-per-millimeter (graft))
-(defgeneric graft-pixels-per-inch (graft))
-
diff --git a/test/chess.lisp b/test/chess.lisp
index 2daef264..6286707e 100644
--- a/test/chess.lisp
+++ b/test/chess.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: chess.lisp,v 1.8 92/09/08 10:35:02 cer Exp $
+;; $fiHeader: chess.lisp,v 1.9 92/09/24 09:39:40 cer Exp $
 
 
 (in-package :clim-user)
@@ -169,7 +169,7 @@
 		    (push (list key
 				(xm-silica::make-pattern-from-file
 				  (format nil
-				      "~~/stuff/gnuchess/Xchess/~a.bitmap" 
+				      "~/3rd/gnuchess/Xchess/~a.bitmap" 
 				    which)
 				  (list (if square +black+ +white+)
 					(ecase color
@@ -204,7 +204,7 @@
 (defun create-chess-subprocess ()
   (multiple-value-bind (stream something pid)
       (excl::run-shell-command 
-	"~/stuff/gnuchess/gnuchessr" 
+	"~/3rd/gnuchess/gnuchessr" 
 	:wait nil 
 	:error-output :output
 	:input :stream :output :stream)
diff --git a/tk/event.lisp b/tk/event.lisp
index 4fc117ae..897d5617 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.14 92/09/30 11:44:33 cer Exp $
+;; $fiHeader: event.lisp,v 1.15 92/11/20 08:46:06 cer Exp $
 
 (in-package :tk)
 
@@ -46,19 +46,23 @@
 
 
 (defun wait-for-event (context &key timeout wait-function)
-  (let ((mask 0)
-	(fds (mapcar #'(lambda (display)
-			 (x11::display-fd display))
-		     (application-context-displays context)))
-	(reason nil))
+  (let* ((mask 0)
+	 (fds (mapcar #'(lambda (display)
+			  (x11::display-fd display))
+		      (application-context-displays context)))
+	 result
+	 (reason nil))
     (declare (fixnum mask))
     
     (flet ((wait-function (fd)
 	     (declare (ignore fd))
-	     (or (plusp (setq mask (xt_app_pending context)))
-		 (and wait-function
-		      (funcall wait-function)
-		      (setq reason :wait)))))
+	     (let ((*inside-event-wait-function* fds))
+	       (setq result
+		 (catch *inside-event-wait-function*
+		   (or (plusp (setq mask (xt_app_pending context)))
+		       (and wait-function
+			    (funcall wait-function)
+			    (setq reason :wait))))))))
       (let* ((interval (xt_app_interval_next_timer context))
 	     (new-timeout (if (plusp interval)
 			      (if (and timeout
diff --git a/utils/clos.lisp b/utils/clos.lisp
index 077d7830..ed6bd947 100644
--- a/utils/clos.lisp
+++ b/utils/clos.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clos.lisp,v 1.8 92/11/06 19:04:58 cer Exp $
+;; $fiHeader: clos.lisp,v 1.9 92/12/01 09:47:28 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -268,7 +268,7 @@
 	 (accessor-arg (first (last lambda-list)))
 	 (setf-function-name (make-setf*-function-name accessor-name)))
     `(define-group ,function-spec defgeneric*
-       (defgeneric ,function-spec ,lambda-list ,@options)
+       (defgeneric ,(make-setf*-function-name accessor-name) ,lambda-list ,@options)
        ,(expand-defsetf-for-defmethod* accessor-name accessor-arg
 				       lambda-list setf-function-name))))
 
-- 
GitLab