/[cmucl]/src/hemlock/interp.lisp
ViewVC logotype

Contents of /src/hemlock/interp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5