source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/interp.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.7 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                            (let* ((doc (buffer-document *current-buffer*)))
469                              (unwind-protect
470                                   (progn
471                                     (when doc (hi::document-begin-editing doc))
472                                     (dolist (c t-bindings)
473                                       (funcall *invoke-hook* c *prefix-argument*))
474                                     (funcall *invoke-hook* res *prefix-argument*)
475                                     (setf punt nil))
476                                (when doc (hi::document-end-editing doc)))))
477                          (when punt (invoke-hook hemlock::command-abort-hook)))
478                        (if *command-type-set*
479                          (setq *command-type-set* nil)
480                          (setq *last-command-type* nil))
481                        (if *prefix-argument-supplied*
482                          (setq *prefix-argument-supplied* nil)
483                          (setq *prefix-argument* nil))
484                        (setf (fill-pointer cmd) 0))
485                       (null
486                        (unless prefix-p
487                          (beep)
488                          (setq *prefix-argument* nil)
489                          (setf (fill-pointer cmd) 0)))
490                       (hash-table)))))
491            (free-temporary-objects temporary-object-pool)))))))
492
493
494
495
496   
497
498
499
500;;; EXIT-HEMLOCK  --  Public
501;;;
502(defun exit-hemlock (&optional (value t))
503  "Exit from ED, returning the specified value."
504  (throw 'hemlock-exit value))
Note: See TracBrowser for help on using the repository browser.