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 ,@args ,@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"