[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv26552/ESA

Modified Files:
	esa.lisp packages.lisp 
Log Message:
Changed how self-insert gestures work in Drei a bit.


--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2008/01/29 22:59:30	1.18
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2008/02/03 08:38:26	1.19
@@ -459,6 +459,19 @@
   (:method ((command-processor command-processor))
     (null (overriding-handler command-processor))))
 
+(defgeneric command-for-unbound-gestures (thing gestures)
+  (:documentation "Called when `gestures' is input by the user
+and there is no associated command in the current command
+table. The function should return either a (possibly incomplete)
+command or NIL. In the latter case (which is handled by a default
+method), the gestures will be treated as actual unbound
+gestures. `Thing' is something that might be interested in
+commands, at the beginning usually a command processor, but it
+can call the function for other objects it knows in order to get
+their opinion. `Gestures' is a list of gestures.")
+  (:method (thing gestures)
+    nil))
+
 (defclass instant-macro-execution-mixin ()
   ()
   (:documentation "Subclasses of this class will immediately
@@ -637,38 +650,43 @@
   (multiple-value-bind (prefix-arg prefix-p gestures)
       (process-gestures-for-numeric-argument
        (accumulated-gestures command-processor))
-    (cond ((null gestures)
-           t)
-          (t
-           (let* ((command-table (command-table command-processor))
-                  (item (find-gestures-with-inheritance gestures command-table)))
-             (cond 
-               ((not item)
-                (setf (accumulated-gestures command-processor) nil)
-                (error 'unbound-gesture-sequence :gestures gestures))
-               ((eq (command-menu-item-type item) :command)
-                (let ((command (command-menu-item-value item))
-                      (*current-gesture* (first (last gestures))))
-                  (unless (consp command)
-                    (setf command (list command)))
-                  ;; Call `*partial-command-parser*' to handle numeric
-                  ;; argument.
-                  (unwind-protect (setq command
-                                        (funcall
-                                         *partial-command-parser*
-                                         (command-table command-processor)
-                                         *standard-input* command 0 (when prefix-p
-                                                                      prefix-arg)))
-                    ;; If we are macrorecording, store whatever the user
-                    ;; did to invoke this command.
-                    (when (recordingp command-processor)
-                      (setf (recorded-keys command-processor)
-                            (append (accumulated-gestures command-processor)
-                                    (recorded-keys command-processor))))
-                    (setf (accumulated-gestures command-processor) nil))
-                  (funcall (command-executor command-processor) command-processor command)
-                  nil))
-               (t t)))))))
+    (flet ((commandp (object)
+             (or (listp object) (symbolp object))))
+      (cond ((null gestures)
+             t)
+            (t
+             (let* ((command-table (command-table command-processor))
+                    (item (or (find-gestures-with-inheritance gestures command-table)
+                              (command-for-unbound-gestures command-processor gestures))))
+               (cond 
+                 ((not item)
+                  (setf (accumulated-gestures command-processor) nil)
+                  (error 'unbound-gesture-sequence :gestures gestures))
+                 ((or (commandp item) ; c-f-u-g does not return a menu-item.
+                      (eq (command-menu-item-type item) :command))
+                  (let ((command (if (commandp item) item
+                                     (command-menu-item-value item)))
+                        (*current-gesture* (first (last gestures))))
+                    (unless (consp command)
+                      (setf command (list command)))
+                    ;; Call `*partial-command-parser*' to handle numeric
+                    ;; argument.
+                    (unwind-protect (setq command
+                                          (funcall
+                                           *partial-command-parser*
+                                           (command-table command-processor)
+                                           *standard-input* command 0 (when prefix-p
+                                                                        prefix-arg)))
+                      ;; If we are macrorecording, store whatever the user
+                      ;; did to invoke this command.
+                      (when (recordingp command-processor)
+                        (setf (recorded-keys command-processor)
+                              (append (accumulated-gestures command-processor)
+                                      (recorded-keys command-processor))))
+                      (setf (accumulated-gestures command-processor) nil))
+                    (funcall (command-executor command-processor) command-processor command)
+                    nil))
+                 (t t))))))))
 
 (defmethod process-gesture :around ((command-processor command-processor) gesture)
   (with-accessors ((overriding-handler overriding-handler)) command-processor
--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2008/02/02 19:03:35	1.16
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2008/02/03 08:38:26	1.17
@@ -79,6 +79,7 @@
            #:command-processor #:instant-macro-execution-mixin
            #:asynchronous-command-processor #:command-loop-command-processor
            #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command
+           #:command-for-unbound-gestures
            #:*extended-command-prompt*
            #:define-esa-top-level #:esa-top-level #:simple-command-loop
            #:convert-to-gesture #:gesture-name