source: trunk/ccl/hemlock/src/interp.lisp @ 863

Last change on this file since 863 was 863, checked in by gb, 17 years ago

Don't be quite so eager to clear the echo area, especially when it's the
current buffer.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.4 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Written by Rob MacLachlan and Blaine Burks.
13;;;
14;;; This file contains the routines which define hemlock commands and
15;;; the command interpreter.
16;;;
17
18(in-package :hemlock-internals)
19
20
21
22
23(defun %print-hcommand (obj stream depth)
24  (declare (ignore depth))
25  (write-string "#<Hemlock Command \"" stream)
26  (write-string (command-name obj) stream)
27  (write-string "\">" stream))
28
29
30
31;;;; Key Tables:
32;;;
33;;;    A key table provides a way to translate a sequence of characters to some
34;;; lisp object.  It is currently represented by a tree of hash-tables, where
35;;; each level is a hashing from a key to either another hash-table or a value.
36
37
38;;; GET-TABLE-ENTRY returns the value at the end of a series of hashings.  For
39;;; our purposes it is presently used to look up commands and key-translations.
40;;;
41(defun get-table-entry (table key)
42  (let ((foo nil))
43    (dotimes (i (length key) foo)
44      (let ((key-event (aref key i)))
45        (setf foo (gethash key-event table))
46        (unless (hash-table-p foo) (return foo))
47        (setf table foo)))))
48
49;;; SET-TABLE-ENTRY sets the entry for key in table to val, creating new
50;;; tables as needed.  If val is nil, then use REMHASH to remove this element
51;;; from the hash-table.
52;;;
53(defun set-table-entry (table key val)
54  (dotimes (i (1- (length key)))
55    (let* ((key-event (aref key i))
56           (foo (gethash key-event table)))
57      (if (hash-table-p foo)
58          (setf table foo)
59          (let ((new-table (make-hash-table)))
60            (setf (gethash key-event table) new-table)
61            (setf table new-table)))))
62  (if (null val)
63      (remhash (aref key (1- (length key))) table)
64      (setf (gethash (aref key (1- (length key))) table) val)))
65
66
67;;;; Key Translation:
68;;;
69;;;    Key translations are maintained using a key table.  If a value is an
70;;; integer, then it is prefix bits to be OR'ed with the next character.  If it
71;;; is a key, then we translate to that key.
72
73(defvar *key-translations* (make-hash-table))
74(defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
75
76
77;;; TRANSLATE-KEY  --  Internal
78;;;
79;;;    This is used internally to do key translations when we want the
80;;; canonical representation for Key.  Result, if supplied, is an adjustable
81;;; vector with a fill pointer.  We compute the output in this vector.  If the
82;;; key ends in the prefix of a translation, we just return that part
83;;; untranslated and return the second value true.
84;;;
85(defun translate-key (key &optional (result (make-array (length key)
86                                                        :fill-pointer 0
87                                                        :adjustable t)))
88  (let ((key-len (length key))
89        (temp *translate-key-temp*)
90        (start 0)
91        (try-pos 0)
92        (prefix 0))
93    (setf (fill-pointer temp) 0)
94    (setf (fill-pointer result) 0)
95    (loop
96      (when (= try-pos key-len) (return))
97      (let ((key-event (aref key try-pos)))
98        (vector-push-extend
99         (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event)
100                                               prefix))
101         temp)
102        (setf prefix 0))
103      (let ((entry (get-table-entry *key-translations* temp)))
104        (cond ((hash-table-p entry)
105               (incf try-pos))
106              (t
107               (etypecase entry
108                 (null
109                  (vector-push-extend (aref temp 0) result)
110                  (incf start))
111                 (simple-vector
112                  (dotimes (i (length entry))
113                    (vector-push-extend (aref entry i) result))
114                  (setf start (1+ try-pos)))
115                 (integer
116                  (setf start (1+ try-pos))
117                  (when (= start key-len) (return))
118                  (setf prefix (logior entry prefix))))
119               (setq try-pos start)
120               (setf (fill-pointer temp) 0)))))
121    (dotimes (i (length temp))
122      (vector-push-extend (aref temp i) result))
123    (values result (not (zerop (length temp))))))
124
125
126;;; KEY-TRANSLATION -- Public.
127;;;
128(defun key-translation (key)
129  "Return the key translation for Key, or NIL if there is none.  If Key is a
130   prefix of a translation, then :Prefix is returned.  Whenever Key appears as a
131   subsequence of a key argument to the binding manipulation functions, that
132   portion will be replaced with the translation.  A key translation may also be
133   a list (:Bits {Bit-Name}*).  In this case, the named bits will be set in the
134   next character in the key being translated."
135  (let ((entry (get-table-entry *key-translations* (crunch-key key))))
136    (etypecase entry
137      (hash-table :prefix)
138      ((or simple-vector null) entry)
139      (integer
140       (cons :bits (hemlock-ext:key-event-bits-modifiers entry))))))
141
142;;; %SET-KEY-TRANSLATION  --  Internal
143;;;
144(defun %set-key-translation (key new-value)
145  (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits))
146                      (apply #'hemlock-ext:make-key-event-bits (cdr new-value)))
147                     (new-value (crunch-key new-value))
148                     (t new-value))))
149    (set-table-entry *key-translations* (crunch-key key) entry)
150    new-value))
151;;;
152(defsetf key-translation %set-key-translation
153  "Set the key translation for a key.  If set to null, deletes any
154  translation.")
155
156
157
158;;;; Interface Utility Functions:
159
160(defvar *global-command-table* (make-hash-table)
161  "The command table for global key bindings.")
162
163;;; GET-RIGHT-TABLE  --  Internal
164;;;
165;;;    Return a hash-table depending on "kind" and checking for errors.
166;;;
167(defun get-right-table (kind where)
168  (case kind
169     (:global
170      (when where
171        (error "Where argument ~S is meaningless for :global bindings."
172               where))
173      *global-command-table*)
174     (:mode (let ((mode (getstring where *mode-names*)))
175              (unless mode
176                (error "~S is not a defined mode." where))
177              (mode-object-bindings mode)))
178     (:buffer (unless (bufferp where)
179                (error "~S is not a buffer." where))
180              (buffer-bindings where))
181     (t (error "~S is not a valid binding type." kind))))
182
183
184;;; CRUNCH-KEY  --  Internal.
185;;;
186;;; Take a key in one of the various specifications and turn it into the
187;;; standard one: a simple-vector of characters.
188;;;
189(defun crunch-key (key)
190  (typecase key
191    (hemlock-ext:key-event (vector key))
192    ((or list vector) ;List thrown in gratuitously.
193     (when (zerop (length key))
194       (error "A zero length key is illegal."))
195     (unless (every #'hemlock-ext:key-event-p key)
196       (error "A Key ~S must contain only key-events." key))
197     (coerce key 'simple-vector))
198    (t
199     (error "Key ~S is not a key-event or sequence of key-events." key))))
200
201
202
203;;;; Exported Primitives:
204
205(declaim (special *command-names*))
206
207;;; BIND-KEY  --  Public.
208;;;
209(defun bind-key (name key &optional (kind :global) where)
210  "Bind a Hemlock command to some key somewhere.  Name is the string name
211   of a Hemlock command, Key is either a key-event or a vector of key-events.
212   Kind is one of :Global, :Mode or :Buffer, and where is the mode name or
213   buffer concerned.  Kind defaults to :Global."
214  ;;(with-simple-restart (continue "Go on, ignoring binding attempt."))
215  (handler-bind ((error
216                  #'(lambda (condition)
217                      (format *error-output*
218                              "~&Error while trying to bind key ~A: ~A~%"
219                              key condition)
220                      (return-from bind-key nil))))
221                (let ((cmd (getstring name *command-names*))
222                      (table (get-right-table kind where))
223                      (key (copy-seq (translate-key (crunch-key key)))))
224                  (cond (cmd
225                         (set-table-entry table key cmd)
226                         (push (list key kind where) (command-%bindings cmd))
227                         cmd)
228                        (t
229                         (error "~S is not a defined command." name))))))
230
231
232;;; DELETE-KEY-BINDING  --  Public
233;;;
234;;;    Stick NIL in the key table specified.
235;;;
236(defun delete-key-binding (key &optional (kind :global) where)
237  "Remove a Hemlock key binding somewhere.  Key is either a key-event or a
238   vector of key-events.  Kind is one of :Global, :Mode or :Buffer, andl where
239   is the mode name or buffer concerned.  Kind defaults to :Global."
240  (set-table-entry (get-right-table kind where)
241                   (translate-key (crunch-key key))
242                   nil))
243
244
245;;; GET-CURRENT-BINDING  --  Internal
246;;;
247;;;    Look up a key in the current environment.
248;;;
249(defun get-current-binding (key)
250  (let ((res (get-table-entry (buffer-bindings *current-buffer*) key)))
251    (cond
252     (res (values res nil))
253     (t
254      (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode))
255           (t-bindings ()))
256          ((null mode)
257           (values (get-table-entry *global-command-table* key)
258                   (nreverse t-bindings)))
259        (declare (list t-bindings))
260        (let ((res (get-table-entry (mode-object-bindings (car mode)) key)))
261          (when res
262            (if (mode-object-transparent-p (car mode))
263                (push res t-bindings)
264                (return (values res (nreverse t-bindings)))))))))))
265
266
267;;; GET-COMMAND -- Public.
268;;;
269(defun get-command (key &optional (kind :global) where)
270  "Return the command object for the command bound to key somewhere.
271   If key is not bound, return nil.  Key is either a key-event or a vector of
272   key-events.  If key is a prefix of a key-binding, then return :prefix.
273   Kind is one of :global, :mode or :buffer, and where is the mode name or
274   buffer concerned.  Kind defaults to :Global."
275  (multiple-value-bind (key prefix-p)
276                       (translate-key (crunch-key key))
277    (let ((entry (if (eq kind :current)
278                     (get-current-binding key)
279                     (get-table-entry (get-right-table kind where) key))))
280      (etypecase entry
281        (null (if prefix-p :prefix nil))
282        (command entry)
283        (hash-table :prefix)))))
284
285(defvar *map-bindings-key* (make-array 5 :adjustable t :fill-pointer 0))
286
287;;; MAP-BINDINGS -- Public.
288;;;
289(defun map-bindings (function kind &optional where)
290  "Map function over the bindings in some place.  The function is passed the
291   key and the command to which it is bound."
292  (labels ((mapping-fun (hash-key hash-value)
293             (vector-push-extend hash-key *map-bindings-key*)
294             (etypecase hash-value
295               (command (funcall function *map-bindings-key* hash-value))
296               (hash-table (maphash #'mapping-fun hash-value)))
297             (decf (fill-pointer *map-bindings-key*))))
298    (setf (fill-pointer *map-bindings-key*) 0)
299    (maphash #'mapping-fun (get-right-table kind where))))
300
301;;; MAKE-COMMAND -- Public.
302;;;
303;;; If the command is already defined, then alter the command object;
304;;; otherwise, make a new command object and enter it into the *command-names*.
305;;;
306(defun make-command (name documentation function)
307  "Create a new Hemlock command with Name and Documentation which is
308   implemented by calling the function-value of the symbol Function"
309  (let ((entry (getstring name *command-names*)))
310    (cond
311     (entry
312      (setf (command-name entry) name)
313      (setf (command-documentation entry) documentation)
314      (setf (command-function entry) function))
315     (t
316      (setf (getstring name *command-names*)
317            (internal-make-command name documentation function))))))
318
319
320;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public.
321;;;
322(defun command-name (command)
323  "Returns the string which is the name of Command."
324  (command-%name command))
325;;;
326(defun %set-command-name (command new-name)
327  (check-type command command)
328  (check-type new-name string)
329  (setq new-name (coerce new-name 'simple-string))
330  (delete-string (command-%name command) *command-names*)
331  (setf (getstring new-name *command-names*) command)
332  (setf (command-%name command) new-name))
333
334
335;;; COMMAND-BINDINGS -- Public.
336;;;
337;;; Check that all the supposed bindings really exists.  Bindings which
338;;; were once made may have been overwritten.  It is easier to filter
339;;; out bogus bindings here than to catch all the cases that can make a
340;;; binding go away.
341;;;
342(defun command-bindings (command)
343  "Return a list of lists of the form (key kind where) describing
344   all the places where Command is bound."
345  (check-type command command)
346  (let (result)
347    (declare (list result))
348    (dolist (place (command-%bindings command))
349      (let ((table (case (cadr place)
350                   (:global *global-command-table*)
351                   (:mode
352                    (let ((m (getstring (caddr place) *mode-names*)))
353                      (when m (mode-object-bindings m))))
354                   (t
355                    (when (member (caddr place) *buffer-list*)
356                      (buffer-bindings (caddr place)))))))
357        (when (and table
358                   (eq (get-table-entry table (car place)) command)
359                   (not (member place result :test #'equalp)))
360          (push place result))))
361    result))
362
363
364(defvar *last-command-type* ()
365  "The command-type of the last command invoked.")
366(defvar *command-type-set* ()
367  "True if the last command set the command-type.")
368
369;;; LAST-COMMAND-TYPE  --  Public
370;;;
371;;;
372(defun last-command-type ()
373  "Return the command-type of the last command invoked.
374  If no command-type has been set then return NIL.  Setting this with
375  Setf sets the value for the next command."
376  *last-command-type*)
377
378;;; %SET-LAST-COMMAND-TYPE  --  Internal
379;;;
380;;;    Set the flag so we know not to clear the command-type.
381;;;
382(defun %set-last-command-type (type)
383  (setq *last-command-type* type *command-type-set* t))
384
385
386(defvar *prefix-argument* nil "The prefix argument or NIL.")
387(defvar *prefix-argument-supplied* nil
388  "Should be set by functions which supply a prefix argument.")
389
390;;; PREFIX-ARGUMENT  --  Public
391;;;
392;;;
393(defun prefix-argument ()
394  "Return the current value of prefix argument.  This can be set with SETF."
395  *prefix-argument*)
396
397;;; %SET-PREFIX-ARGUMENT  --  Internal
398;;;
399(defun %set-prefix-argument (argument)
400  "Set the prefix argument for the next command to Argument."
401  (unless (or (null argument) (integerp argument))
402    (error "Prefix argument ~S is neither an integer nor Nil." argument))
403  (setq *prefix-argument* argument  *prefix-argument-supplied* t))
404
405;;;; The Command Loop:
406
407;;; Buffers we use to read and translate keys.
408;;;
409(defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t))
410(defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
411
412(defvar *invoke-hook* #'(lambda (command p)
413                          (funcall (command-function command) p))
414  "This function is called by the command interpreter when it wants to invoke a
415  command.  The arguments are the command to invoke and the prefix argument.
416  The default value just calls the Command-Function with the prefix argument.")
417
418
419
420   
421;;; %COMMAND-LOOP  --  Internal
422;;;
423;;;    Read commands from the terminal and execute them, forever.
424;;;
425(defun %command-loop ()
426  (let  ((cmd *current-command*)
427         (trans *current-translation*)
428         (*last-command-type* nil)
429         (*command-type-set* nil)
430         (*prefix-argument* nil)
431         (*prefix-argument-supplied* nil))
432    (declare (special *last-command-type* *command-type-set*
433                      *prefix-argument* *prefix-argument-supplied*))
434    (setf (fill-pointer cmd) 0)
435    (handler-bind
436        ;; Bind this outside the invocation loop to save consing.
437        ((editor-error #'(lambda (condx)
438                           (beep)
439                           (let ((string (editor-error-format-string condx)))
440                             (when string
441                               (apply #'message string
442                                      (editor-error-format-arguments condx)))
443                             (throw 'command-loop-catcher nil)))))
444      (loop
445        (let* ((temporary-object-pool (allocate-temporary-object-pool)))
446          (unwind-protect
447               (progn
448                 (unless (eq *current-buffer* *echo-area-buffer*)
449                   (unless (or (zerop (length cmd))
450                               (not (value hemlock::key-echo-delay)))
451                     (editor-sleep (value hemlock::key-echo-delay))
452                     (unless (listen-editor-input *editor-input*)
453                       (clear-echo-area)
454                       (dotimes (i (length cmd))
455                         (hemlock-ext:print-pretty-key (aref cmd i) *echo-area-stream*)
456                         (write-char #\space *echo-area-stream*)))))
457                 (vector-push-extend (get-key-event *editor-input*) cmd)
458                 (multiple-value-bind (trans-result prefix-p)
459                     (translate-key cmd trans)
460                   (multiple-value-bind (res t-bindings)
461                       (get-current-binding trans-result)
462                     (etypecase res
463                       (command 
464                        (let ((punt t))
465                          (unless (eq *current-buffer* *echo-area-buffer*)
466                            (clear-echo-area))
467                          (catch 'command-loop-catcher
468                            (dolist (c t-bindings)
469                              (funcall *invoke-hook* c *prefix-argument*))
470                            (funcall *invoke-hook* res *prefix-argument*)
471                            (setf punt nil))
472                          (when punt (invoke-hook hemlock::command-abort-hook)))
473                        (if *command-type-set*
474                          (setq *command-type-set* nil)
475                          (setq *last-command-type* nil))
476                        (if *prefix-argument-supplied*
477                          (setq *prefix-argument-supplied* nil)
478                          (setq *prefix-argument* nil))
479                        (setf (fill-pointer cmd) 0))
480                       (null
481                        (unless prefix-p
482                          (beep)
483                          (setq *prefix-argument* nil)
484                          (setf (fill-pointer cmd) 0)))
485                       (hash-table)))))
486            (free-temporary-objects temporary-object-pool)))))))
487
488
489
490
491   
492
493
494
495;;; EXIT-HEMLOCK  --  Public
496;;;
497(defun exit-hemlock (&optional (value t))
498  "Exit from ED, returning the specified value."
499  (throw 'hemlock-exit value))
Note: See TracBrowser for help on using the repository browser.