[mcclim-cvs] CVS mcclim
tmoore
tmoore at common-lisp.net
Mon Mar 20 08:15:27 UTC 2006
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv14553
Modified Files:
builtin-commands.lisp commands.lisp mcclim.asd
presentation-defs.lisp presentations.lisp system.lisp
Log Message:
Made the command-table-inherit-from slot of command tables setf-able,
as per the Franz manual.
Changed the default documentation of presentation translators from the
presentation object to the name of the translator. If this is too
controversial I will back it out.
Force the tester of drag-and-drop translators to be definitive;
otherwise serious weirdness ensues.
Added the functional geometry explorer of Frank Buss and Rainer
Joswig, who graciously agreed to it being included, as an application.
--- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/15 15:38:38 1.21
+++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/20 08:15:26 1.22
@@ -301,6 +301,12 @@
;; We don't want activation gestures like :return causing an eof
;; while reading a form. Also, we don't want spaces within forms or
;; strings causing a premature return either!
+ ;; XXX This loses when rescanning (possibly in other contexts too) an
+ ;; activated input buffer (e.g., reading an expression from the accept
+ ;; method for OR where the previous readers have already given
+ ;; up). We should call *sys-read-preserving-whitespace* and handle the
+ ;; munching of whitespace ourselves according to the
+ ;; PRESERVE-WHITESPACE parameter. Fix after .9.2.2.
(with-delimiter-gestures (nil :override t)
(with-activation-gestures (nil :override t)
(setq object (funcall (if preserve-whitespace
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/15 15:38:39 1.59
+++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/20 08:15:26 1.60
@@ -84,7 +84,15 @@
(defmethod print-object ((table standard-command-table) stream)
(print-unreadable-object (table stream :identity t :type t)
(format stream "~S" (command-table-name table))))
-
+
+;;; Franz user manual says that this slot is setf-able
+(defgeneric (setf command-table-inherit-from) (inherit-from table))
+
+(defmethod (setf command-table-inherit-from)
+ (inherit (table standard-command-table))
+ (invalidate-translator-caches)
+ (setf (slot-value table 'inherit-from) inherit))
+
(defparameter *command-tables* (make-hash-table :test #'eq))
(define-condition command-table-error (error)
--- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 22:56:54 1.10
+++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/20 08:15:26 1.11
@@ -56,7 +56,7 @@
(defclass requireable-system (asdf:system)
())
(defmethod asdf:perform ((op asdf:load-op) (system requireable-system))
- (require (intern (slot-value system 'asdf::name) "KEYWORD")))
+ (require (intern (slot-value system 'asdf::name) :keyword)))
(defmethod asdf::traverse ((op asdf:load-op) (system requireable-system))
(list (cons op system)))
(defsystem :clx
--- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/15 15:38:39 1.53
+++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/20 08:15:26 1.54
@@ -2073,6 +2073,7 @@
`(progn
(define-presentation-translator ,name
(,from-type ,to-type ,command-table
+ :tester-definitive t
, at args
, at pointer-doc
:feedback #',feedback :highlighting #',highlighting
--- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 22:56:54 1.75
+++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/20 08:15:26 1.76
@@ -1228,6 +1228,9 @@
:writer (setf presentation-translators-cache)
:initform (make-hash-table :test #'equal))))
+(defun invalidate-translator-caches ()
+ (incf *current-translator-cache-generation*))
+
(defmethod presentation-translators-cache ((table translator-table))
(with-slots ((cache presentation-translators-cache)
(generation translator-cache-generation))
@@ -1269,10 +1272,11 @@
(remove old
(gethash (presentation-type-name (from-type old))
simple-type-translators))))
- (incf *current-translator-cache-generation*)
+ (invalidate-translator-caches)
(setf (gethash (name translator) translators) translator)
(push translator
- (gethash (from-type translator) simple-type-translators)))))
+ (gethash (from-type translator) simple-type-translators))
+ translator)))
(defun make-translator-fun (args body)
(multiple-value-bind (ll ignore)
@@ -1301,7 +1305,7 @@
(gesture :select)
(tester 'default-translator-tester testerp)
(tester-definitive (if testerp nil t))
- (documentation nil)
+ (documentation nil documentationp)
(pointer-documentation nil pointer-documentation-p)
(menu t)
(priority 0)
@@ -1335,7 +1339,10 @@
(cdr tester)))
:tester-definitive ',tester-definitive
:documentation #',(make-documentation-fun
- documentation)
+ (if documentationp
+ documentation
+ (command-name-from-symbol
+ name)))
,@(when pointer-documentation-p
`(:pointer-documentation
#',(make-documentation-fun
@@ -1350,7 +1357,7 @@
(name (from-type to-type command-table &key
(gesture :select)
(tester 'default-translator-tester)
- (documentation nil)
+ (documentation nil documentationp)
(pointer-documentation nil pointer-documentation-p)
(menu t)
(priority 0))
@@ -1373,7 +1380,10 @@
`#',(make-translator-fun (car tester)
(cdr tester)))
:tester-definitive t
- :documentation #',(make-documentation-fun documentation)
+ :documentation #',(make-documentation-fun (if documentationp
+ documentation
+ (command-name-from-symbol
+ name)))
,@(when pointer-documentation-p
`(:pointer-documentation
#',(make-documentation-fun pointer-documentation)))
--- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 22:56:54 1.115
+++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/20 08:15:26 1.116
@@ -267,7 +267,6 @@
(clim-defsystem (:clim-listener :depends-on (:clim #+clx :clim-looks #+sbcl :sb-posix))
"Experimental/xpm"
"Apps/Listener/package"
- "Apps/Listener/hotfixes"
"Apps/Listener/util"
"Apps/Listener/icons.lisp"
"Apps/Listener/file-types"
More information about the Mcclim-cvs
mailing list