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

Contents of /src/hemlock/interp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 13 15:49:53 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/interp.lisp,v 1.5 2001/03/13 15:49:53 pw Rel $")
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 (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 ;;; 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
39
40 ;;; 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 ;;;
43 (defun get-table-entry (table key)
44 (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
51 ;;; 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 ;;;
55 (defun set-table-entry (table key val)
56 (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
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 (defvar *key-translations* (make-hash-table))
76 (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 (defun translate-key (key &optional (result (make-array (length key)
88 :fill-pointer 0
89 :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 (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 (let ((entry (get-table-entry *key-translations* temp)))
106 (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 (dotimes (i (length temp))
124 (vector-push-extend (aref temp i) result))
125 (values result (not (zerop (length temp))))))
126
127
128 ;;; KEY-TRANSLATION -- Public.
129 ;;;
130 (defun key-translation (key)
131 "Return the key translation for Key, or NIL if there is none. If Key is a
132 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 (let ((entry (get-table-entry *key-translations* (crunch-key key))))
138 (etypecase entry
139 (hash-table :prefix)
140 ((or simple-vector null) entry)
141 (integer
142 (cons :bits (ext:key-event-bits-modifiers entry))))))
143
144 ;;; %SET-KEY-TRANSLATION -- Internal
145 ;;;
146 (defun %set-key-translation (key new-value)
147 (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 (set-table-entry *key-translations* (crunch-key key) entry)
152 new-value))
153 ;;;
154 (defsetf key-translation %set-key-translation
155 "Set the key translation for a key. If set to null, deletes any
156 translation.")
157
158
159
160 ;;;; Interface Utility Functions:
161
162 (defvar *global-command-table* (make-hash-table)
163 "The command table for global key bindings.")
164
165 ;;; GET-RIGHT-TABLE -- Internal
166 ;;;
167 ;;; Return a hash-table depending on "kind" and checking for errors.
168 ;;;
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 ;;; CRUNCH-KEY -- Internal.
187 ;;;
188 ;;; Take a key in one of the various specifications and turn it into the
189 ;;; standard one: a simple-vector of characters.
190 ;;;
191 (defun crunch-key (key)
192 (typecase key
193 (ext:key-event (vector key))
194 ((or list vector) ;List thrown in gratuitously.
195 (when (zerop (length key))
196 (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 (coerce key 'simple-vector))
200 (t
201 (error "Key ~S is not a key-event or sequence of key-events." key))))
202
203
204
205 ;;;; Exported Primitives:
206
207 (declaim (special *command-names*))
208
209 ;;; BIND-KEY -- Public.
210 ;;;
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 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 (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 "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 (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 ;;; GET-COMMAND -- Public.
264 ;;;
265 (defun get-command (key &optional (kind :global) where)
266 "Return the command object for the command bound to key somewhere.
267 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 (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 (hash-table :prefix)))))
280
281 (defvar *map-bindings-key* (make-array 5 :adjustable t :fill-pointer 0))
282
283 ;;; MAP-BINDINGS -- Public.
284 ;;;
285 (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
297 ;;; MAKE-COMMAND -- Public.
298 ;;;
299 ;;; 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 ;;;
302 (defun make-command (name documentation function)
303 "Create a new Hemlock command with Name and Documentation which is
304 implemented by calling the function-value of the symbol Function"
305 (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 ;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public.
317 ;;;
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 ;;; COMMAND-BINDINGS -- Public.
332 ;;;
333 ;;; Check that all the supposed bindings really exists. Bindings which
334 ;;; 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 all the places where Command is bound."
341 (check-type command command)
342 (let (result)
343 (declare (list result))
344 (dolist (place (command-%bindings command))
345 (let ((table (case (cadr place)
346 (: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 (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
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 "Return the current value of prefix argument. This can be set with SETF."
391 *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 (unless (listen-editor-input *editor-input*)
445 (clear-echo-area)
446 (dotimes (i (length cmd))
447 (ext:print-pretty-key (aref cmd i) *echo-area-stream*)
448 (write-char #\space *echo-area-stream*)))))
449 (vector-push-extend (get-key-event *editor-input*) cmd)
450 (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 (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
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