[mcclim-cvs] CVS mcclim

[thenriksen]

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

Modified Files:
	dead-keys.lisp stream-input.lisp 
Log Message:
Removed some code duplication in dead key handling.


--- /project/mcclim/cvsroot/mcclim/dead-keys.lisp	2008/05/01 06:48:23	1.2
+++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp	2008/05/01 07:48:45	1.3
@@ -117,13 +117,12 @@
 (defmacro merging-dead-keys ((gesture state) &body body)
   "Accumulate dead keys and subsequent characters. `Gesture'
 should be a symbol bound to either a gesture or an input
-event. When it has been determined that a sequence of `gesture's
-either does or doesn't result in a full gesture, `body' will be
-evaluated with `gesture' bound to that gesture. `State' must be a
-place, initially NIL, that will contain the state of dead-key
-handling, enabling asynchronous use of the macro."
+event. `Body' will be evaluated either with the `gesture' binding
+unchanged, or with `gesture' bound to the result of merging
+preceding dead keys. `State' must be a place, initially NIL, that
+will contain the state of dead-key handling, enabling
+asynchronous use of the macro."
   `(flet ((invoke-body (,gesture)
-            (setf ,state *dead-key-table*)
             , at body))
      (when (null ,state)
        (setf ,state *dead-key-table*))
@@ -141,7 +140,10 @@
                          (characterp ,gesture))
                      (setf ,state *dead-key-table*))))
              (character
+              (setf ,state *dead-key-table*)
               (invoke-body value))
              (hash-table
-              (setf ,state value))))
-         (invoke-body ,gesture))))
+              (setf ,state value)
+              (invoke-body value))))
+         (progn (setf ,state *dead-key-table*)
+                (invoke-body ,gesture)))))
--- /project/mcclim/cvsroot/mcclim/stream-input.lisp	2008/04/30 21:27:48	1.52
+++ /project/mcclim/cvsroot/mcclim/stream-input.lisp	2008/05/01 07:48:45	1.53
@@ -146,37 +146,23 @@
     (handler-case
         (loop with start-time = (get-internal-real-time)
               with end-time = start-time
-              for gesture = (call-next-method stream
-                             :timeout (when timeout
-                                        (- timeout (/ (- end-time start-time)
-                                                      internal-time-units-per-second)))
-                             :peek-p peek-p
-                             :input-wait-test input-wait-test
-                             :input-wait-handler input-wait-handler
-                             :pointer-button-press-handler
-                             pointer-button-press-handler)
-              do (setf end-time (get-internal-real-time)
-                       last-deadie-gesture gesture
-                       last-state state)
-              do (if (typep gesture '(or keyboard-event character))
-                     (let ((value (gethash (if (characterp gesture)
-                                               gesture
-                                               (keyboard-event-key-name gesture))
-                                           state)))
-                       (etypecase value
-                         (null
-                          (cond ((eq state *dead-key-table*)
-                                 (return gesture))
-                                ((or (and (typep gesture 'keyboard-event)
-                                          (keyboard-event-character gesture))
-                                     (characterp gesture))
-                                 (setf state *dead-key-table*))))
-                         (character
-                          (setf state *dead-key-table*)
-                          (return value))
-                         (hash-table
-                          (return (setf state value)))))
-                     (return gesture)))
+              do (multiple-value-bind (gesture reason)
+                     (call-next-method stream
+                      :timeout (when timeout
+                                 (- timeout (/ (- end-time start-time)
+                                               internal-time-units-per-second)))
+                      :peek-p peek-p
+                      :input-wait-test input-wait-test
+                      :input-wait-handler input-wait-handler
+                      :pointer-button-press-handler
+                      pointer-button-press-handler)
+                   (when (null gesture)
+                     (return (values nil reason)))
+                   (setf end-time (get-internal-real-time)
+                         last-deadie-gesture gesture
+                         last-state state)
+                   (merging-dead-keys (gesture state)
+                     (return gesture))))
       ;; Policy decision: an abort cancels the current composition.
       (abort-gesture (c)
         (setf state *dead-key-table*)