Changeset 553

Timestamp:

Feb 21, 2004, 5:16:38 PM (21 years ago)

Author:

Gary Byers

Message:

Process single events.

File:

• trunk/ccl/hemlock/src/interp.lisp (modified) (2 diffs)

trunk/ccl/hemlock/src/interp.lisp

@@ -17 +17 @@
 
 (in-package :hemlock-internals)
+
+(defstruct command-interpreter-info
+  (current-command (make-array 10 :fill-pointer 0 :adjustable t))
+  (current-translation (make-array 10 :fill-pointer 0 :adjustable t))
+  (last-command-type nil)
+  (command-type-set nil)
+  (prefix-argument nil)
+  (prefix-argument-supplied nil)
+  frame
+  )
+
 
 (defun %print-hcommand (obj stream depth)
@@ -419 +430 @@
 
 
+(defun interpret-key-event (key-event info)
+  (setf (command-interpreter-info-prefix-argument info) nil)
+  (let* ((*last-key-event-typed* key-event)
+         (cmd (command-interpreter-info-current-command info))
+         (trans (command-interpreter-info-current-translation info)))
+    (vector-push-extend key-event cmd)
+    (setf (fill-pointer trans) 0)
+    (multiple-value-bind (trans-result prefix-p)
+                             (translate-key cmd trans)
+      (format t "~& trans-result = ~s, prefix-p = ~s" trans-result prefix-p)
+          (multiple-value-bind (res t-bindings)
+                               (get-current-binding trans-result)
+            (etypecase res
+              (command 
+               (let ((punt t))
+                 (format t "~& key-event = ~s, res = ~s, t-bindings = ~s, prefix = ~s"
+                         key-event
+                         res t-bindings
+                         (command-interpreter-info-prefix-argument info))
+                 (catch 'command-loop-catcher
+                   (dolist (c t-bindings)
+                     (funcall *invoke-hook* c (command-interpreter-info-prefix-argument info)))
+                   (funcall *invoke-hook* res (command-interpreter-info-prefix-argument info))
+                   (setf punt nil))
+                 (when punt (invoke-hook hemlock::command-abort-hook)))
+               (if (command-interpreter-info-command-type-set info)
+                 (setf (command-interpreter-info-command-type-set info) nil)
+                 (setf (command-interpreter-info-last-command-type info) nil))
+               (if (command-interpreter-info-prefix-argument-supplied info)
+                   (setf (command-interpreter-info-prefix-argument-supplied info) nil)
+                   (setf (command-interpreter-info-prefix-argument info) nil))
+               (setf (fill-pointer cmd) 0))
+              (null
+               (unless prefix-p
+                 (beep)
+                 (setf (command-interpreter-info-prefix-argument info) nil)
+                 (setf (fill-pointer cmd) 0)))
+              (hash-table))))))    
+    
 ;;; %COMMAND-LOOP  --  Internal
 ;;;