Skip to content
Snippets Groups Projects
Commit 3003bf05 authored by cer's avatar cer
Browse files

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
parent 83192daf
No related branches found
No related tags found
No related merge requests found
;;; -*- 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))
......@@ -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)
......
......@@ -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
......
;;; -*- 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))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment