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