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

Contents of /src/hemlock/kbdmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Feb 11 21:53:14 1994 UTC (20 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.2: +9 -6 lines
Copy new_compiler branch to trunk.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/kbdmac.lisp,v 1.3 1994/02/11 21:53:14 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the implementation of keyboard macros for
15 ;;; Hemlock. In itself it contains nothing particularly gross or
16 ;;; implementation dependant, but it uses some hooks in the stream
17 ;;; system and other stuff.
18 ;;;
19
20 (in-package "HEMLOCK")
21
22 ;;; We have "Keyboard Macro Transforms" that help in making a keyboard
23 ;;; macro. What they do is turn the sequence of commands into equivalent
24 ;;; lisp code. They operate under the following principles:
25 ;;;
26 ;;; They are passed two arguments:
27 ;;; 1] The command invoked.
28 ;;; 2] A keyword, either :invoke, :start or :finish
29 ;;;
30 ;;; If the keyword is :invoke, then the transform is expected to
31 ;;; invoke the command and do whatever is necessary to make the same
32 ;;; thing happen again when the macro is invoked. The method does this
33 ;;; by pushing forms on the list *current-kbdmac* and characters to
34 ;;; simulate input of on *kbdmac-input*. *current-kbdmac* is kept
35 ;;; in reverse order. Each form must be a function call, and none
36 ;;; of the arguments are evaluated. If the transform is unwound,
37 ;;; presumably due to an error in the invoked command, then nothing
38 ;;; should be done at invocation time.
39 ;;;
40 ;;; If the keyword is :finish, then nothing need be done. This
41 ;;; is to facilitate compaction of repetitions of the same command
42 ;;; into one call. The transform is called with :finish when a run
43 ;;; is broken. Similarly, the transform is called with :start
44 ;;; before the first occurrence in a run.
45
46 (defvar *kbdmac-transcript* (make-array 100 :fill-pointer 0 :adjustable t)
47 "The thing we bind *input-transcript* to during keyboard macro definition.")
48
49 (defvar *kbdmac-input* (make-array 100 :fill-pointer 0 :adjustable t)
50 "Place where we stick input that will need to be simulated during keyboard
51 macro execution.")
52
53 (defvar *current-kbdmac* () "Body of keyboard macro we are building.")
54
55 (defvar *kbdmac-transforms* (make-hash-table :test #'eq)
56 "Hashtable of function that know how to do things.")
57
58 (defvar *old-invoke-hook* () "Bound to *invoke-hook* by kbdmac-command-loop.")
59
60 (defmacro define-kbdmac-transform (command function)
61 `(setf (gethash (getstring ,command *command-names*)
62 *kbdmac-transforms*)
63 ,function))
64
65 (defmacro kbdmac-emit (form)
66 `(push ,form *current-kbdmac*))
67
68 (defun trash-character ()
69 "Throw away a character on *editor-input*."
70 (get-key-event *editor-input*))
71
72 ;;; Save-Kbdmac-Input -- Internal
73 ;;;
74 ;;; Pushes any input read within the body on *kbdmac-input* so that
75 ;;; it is read again at macro invocation time. It uses the (input-waiting)
76 ;;; function which is a non-standard hook into the stream system.
77 ;;;
78 (defmacro save-kbdmac-input (&body forms)
79 (let ((slen (gensym)))
80 `(let ((,slen (- (length *kbdmac-transcript*) (if (input-waiting) 1 0))))
81 (multiple-value-prog1
82 (progn ,@forms)
83 (do ((i ,slen (1+ i))
84 (elen (length *kbdmac-transcript*)))
85 ((= i elen)
86 (when (input-waiting)
87 (kbdmac-emit '(trash-character))))
88 (vector-push-extend (aref *kbdmac-transcript* i)
89 *kbdmac-input*))))))
90
91 ;;;; The default transform
92 ;;;
93 ;;; This transform is called when none is defined for a command.
94 ;;;
95 (defun default-kbdmac-transform (command key)
96 (case key
97 (:invoke
98 (let ((fun (command-function command))
99 (arg (prefix-argument))
100 (lastc *last-key-event-typed*))
101 (save-kbdmac-input
102 (let ((*invoke-hook* *old-invoke-hook*))
103 (funcall fun arg))
104 (kbdmac-emit `(set *last-key-event-typed* ,lastc))
105 (kbdmac-emit `(,fun ,arg)))))))
106
107 ;;;; Self insert transform:
108 ;;;
109 ;;; For self insert we accumulate the text in a string and then
110 ;;; insert it all at once.
111 ;;;
112
113 (defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t))
114
115 (defun insert-string-at-point (string)
116 (insert-string (buffer-point (current-buffer)) string))
117 (defun insert-character-at-point (character)
118 (insert-character (buffer-point (current-buffer)) character))
119
120 (defun key-vector-to-string (key-vector)
121 (let ((string (make-array (length key-vector) :element-type 'base-char)))
122 (dotimes (i (length key-vector) string)
123 (setf (aref string i) (key-event-char (aref key-vector i))))))
124
125 (defun self-insert-kbdmac-transform (command key)
126 (case key
127 (:start
128 (setf (fill-pointer *kbdmac-text*) 0))
129 (:invoke
130 (let ((p (or (prefix-argument) 1)))
131 (funcall (command-function command) p)
132 (dotimes (i p)
133 (vector-push-extend *last-key-event-typed* *kbdmac-text*))))
134 (:finish
135 (if (> (length *kbdmac-text*) 1)
136 (kbdmac-emit `(insert-string-at-point
137 ,(key-vector-to-string *kbdmac-text*)))
138 (kbdmac-emit `(insert-character-at-point
139 ,(key-event-char (aref *kbdmac-text* 0))))))))
140 ;;;
141 (define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform)
142 (define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform)
143
144 ;;;; Do-Nothing transform:
145 ;;;
146 ;;; These are useful for prefix-argument setting commands, since they have
147 ;;; no semantics at macro-time.
148 ;;;
149 (defun do-nothing-kbdmac-transform (command key)
150 (case key
151 (:invoke
152 (funcall (command-function command) (prefix-argument)))))
153 ;;;
154 (define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform)
155 (define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform)
156 (define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform)
157
158 ;;;; Multiplicative transform
159 ;;;
160 ;;; Repititions of many commands can be turned into a call with an
161 ;;; argument.
162 ;;;
163 (defvar *kbdmac-count* 0
164 "The number of occurrences we have counted of a given command.")
165
166 (defun multiplicative-kbdmac-transform (command key)
167 (case key
168 (:start
169 (setq *kbdmac-count* 0))
170 (:invoke
171 (let ((p (or (prefix-argument) 1)))
172 (funcall (command-function command) p)
173 (incf *kbdmac-count* p)))
174 (:finish
175 (kbdmac-emit `(,(command-function command) ,*kbdmac-count*)))))
176 ;;;
177 (define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform)
178 (define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform)
179 (define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform)
180 (define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform)
181 (define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform)
182 (define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform)
183 (define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform)
184 (define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform)
185 (define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform)
186 (define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform)
187 (define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform)
188 (define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform)
189 (define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform)
190 (define-kbdmac-transform "Delete Next Character"
191 #'multiplicative-kbdmac-transform)
192 (define-kbdmac-transform "Delete Previous Character"
193 #'multiplicative-kbdmac-transform)
194 (define-kbdmac-transform "Delete Previous Character Expanding Tabs"
195 #'multiplicative-kbdmac-transform)
196 (define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform)
197 (define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform)
198
199
200 ;;;; Vanilla transform
201 ;;;
202 ;;; These commands neither read input nor look at random silly variables.
203 ;;;
204 (defun vanilla-kbdmac-transform (command key)
205 (case key
206 (:invoke
207 (let ((fun (command-function command))
208 (p (prefix-argument)))
209 (funcall fun p)
210 (kbdmac-emit `(,fun ,p))))))
211 ;;;
212 (define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform)
213 (define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform)
214 (define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform)
215 (define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform)
216 (define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform)
217 (define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform)
218 (define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform)
219 (define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform)
220
221 ;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop.
222
223 ;;; Kbdmac-Command-Loop -- Internal
224 ;;;
225 ;;; Bind *invoke-hook* to call kbdmac transforms.
226 ;;;
227 (defun kbdmac-command-loop ()
228 (let* ((last-transform nil)
229 (last-command nil)
230 (last-ctype nil)
231 (*old-invoke-hook* *invoke-hook*)
232 (*invoke-hook*
233 #'(lambda (res p)
234 (declare (ignore p))
235 (when (and (not (eq last-command res)) last-transform)
236 (funcall last-transform last-command :finish))
237 (if (last-command-type)
238 (setq last-ctype t)
239 (when last-ctype
240 (kbdmac-emit '(clear-command-type))
241 (setq last-ctype nil)))
242 (setq last-transform
243 (gethash res *kbdmac-transforms* #'default-kbdmac-transform))
244 (unless (eq last-command res)
245 (funcall last-transform res :start))
246 (funcall last-transform res :invoke)
247 (setq last-command res))))
248 (declare (special *invoke-hook*))
249 (setf (last-command-type) nil)
250 (recursive-edit nil)))
251
252 (defun clear-command-type ()
253 (setf (last-command-type) nil))
254
255
256 (defvar *defining-a-keyboard-macro* ())
257 (defvar *kbdmac-stream* (make-kbdmac-stream))
258 (defvar *in-a-keyboard-macro* ()
259 "True if we are currently executing a keyboard macro.")
260
261 ;;; Interactive -- Public
262 ;;;
263 ;;; See whether we are in a keyboard macro.
264 ;;;
265 (defun interactive ()
266 "Return true if we are in a command invoked by the user.
267 This is primarily useful for commands which want to know
268 whether do something when an error happens, or just signal
269 an Editor-Error."
270 (not *in-a-keyboard-macro*))
271
272 (defvar *kbdmac-done* ()
273 "Setting this causes the keyboard macro being executed to terminate
274 after the current iteration.")
275
276 (defvar *kbdmac-dont-ask* ()
277 "Setting this inhibits \"Keyboard Macro Query\"'s querying.")
278
279 ;;; Make-Kbdmac -- Internal
280 ;;;
281 ;;; This guy grabs the stuff lying around in *current-kbdmac* and
282 ;;; whatnot and makes a lexical closure that can be used as the
283 ;;; definition of a command. The prefix argument is a repitition
284 ;;; count.
285 ;;;
286 (defun make-kbdmac ()
287 (let ((code (nreverse *current-kbdmac*))
288 (input (copy-seq *kbdmac-input*)))
289 (if (zerop (length input))
290 #'(lambda (p)
291 (let ((*in-a-keyboard-macro* t)
292 (*kbdmac-done* nil)
293 (*kbdmac-dont-ask* nil))
294 (setf (last-command-type) nil)
295 (catch 'exit-kbdmac
296 (dotimes (i (or p 1))
297 (catch 'abort-kbdmac-iteration
298 (dolist (form code)
299 (apply (car form) (cdr form))))
300 (when *kbdmac-done* (return nil))))))
301 #'(lambda (p)
302 (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream)))
303 (*kbdmac-stream* nil)
304 (*editor-input* stream)
305 (*in-a-keyboard-macro* t)
306 (*kbdmac-done* nil)
307 (*kbdmac-dont-ask* nil))
308 (setf (last-command-type) nil)
309 (catch 'exit-kbdmac
310 (dotimes (i (or p 1))
311 (setq stream (modify-kbdmac-stream stream input))
312 (catch 'abort-kbdmac-iteration
313 (dolist (form code)
314 (apply (car form) (cdr form))))
315 (when *kbdmac-done* (return nil)))))))))
316
317
318
319 ;;;; Commands.
320
321 (defmode "Def" :major-p nil)
322
323 (defcommand "Define Keyboard Macro" (p)
324 "Define a keyboard macro."
325 "Define a keyboard macro."
326 (declare (ignore p))
327 (when *defining-a-keyboard-macro*
328 (editor-error "Already defining a keyboard macro."))
329 (define-keyboard-macro))
330
331 (defhvar "Define Keyboard Macro Key Confirm"
332 "When set, \"Define Keyboard Macro Key\" asks for confirmation before
333 clobbering an existing key binding."
334 :value t)
335
336 (defcommand "Define Keyboard Macro Key" (p)
337 "Prompts for a key before going into a mode for defining keyboard macros.
338 The macro definition is bound to the key. IF the key is already bound,
339 this asks for confirmation before clobbering the binding."
340 "Prompts for a key before going into a mode for defining keyboard macros.
341 The macro definition is bound to the key. IF the key is already bound,
342 this asks for confirmation before clobbering the binding."
343 (declare (ignore p))
344 (when *defining-a-keyboard-macro*
345 (editor-error "Already defining a keyboard macro."))
346 (multiple-value-bind (key kind where)
347 (get-keyboard-macro-key)
348 (when key
349 (setf (buffer-minor-mode (current-buffer) "Def") t)
350 (let ((name (format nil "Keyboard Macro ~S" (gensym))))
351 (make-command name "This is a user-defined keyboard macro."
352 (define-keyboard-macro))
353 (bind-key name key kind where)
354 (message "~A bound to ~A."
355 (with-output-to-string (s) (print-pretty-key key s))
356 name)))))
357
358 ;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it
359 ;;; if it is already bound to a command, or it is a :prefix. This returns nil
360 ;;; if the user "aborts", otherwise it returns the key and location (kind
361 ;;; where) of the binding.
362 ;;;
363 (defun get-keyboard-macro-key ()
364 (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: "
365 :must-exist nil)))
366 (multiple-value-bind (kind where)
367 (prompt-for-place "Kind of binding: "
368 "The kind of binding to make.")
369 (let* ((cmd (get-command key kind where)))
370 (cond ((not cmd) (values key kind where))
371 ((commandp cmd)
372 (if (prompt-for-y-or-n
373 :prompt `("~A is bound to ~A. Rebind it? "
374 ,(with-output-to-string (s)
375 (print-pretty-key key s))
376 ,(command-name cmd))
377 :default nil)
378 (values key kind where)
379 nil))
380 ((eq cmd :prefix)
381 (if (prompt-for-y-or-n
382 :prompt `("~A is a prefix for more than one command. ~
383 Clobber it? "
384 ,(with-output-to-string (s)
385 (print-pretty-key key s)))
386 :default nil)
387 (values key kind where)
388 nil)))))))
389
390 ;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function
391 ;;; for the "Last Keyboard Macro" command. This returns the new function.
392 ;;;
393 (defun define-keyboard-macro ()
394 (setf (buffer-minor-mode (current-buffer) "Def") t)
395 (unwind-protect
396 (let* ((in *kbdmac-transcript*)
397 (*input-transcript* in)
398 (*defining-a-keyboard-macro* t))
399 (setf (fill-pointer in) 0)
400 (setf (fill-pointer *kbdmac-input*) 0)
401 (setq *current-kbdmac* ())
402 (catch 'punt-kbdmac
403 (kbdmac-command-loop))
404 (setf (command-function (getstring "Last Keyboard Macro" *command-names*))
405 (make-kbdmac)))
406 (setf (buffer-minor-mode (current-buffer) "Def") nil)))
407
408
409 (defcommand "End Keyboard Macro" (p)
410 "End the definition of a keyboard macro."
411 "End the definition of a keyboard macro."
412 (declare (ignore p))
413 (unless *defining-a-keyboard-macro*
414 (editor-error "Not defining a keyboard macro."))
415 (throw 'punt-kbdmac ()))
416 ;;;
417 (define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform)
418
419
420 (defcommand "Last Keyboard Macro" (p)
421 "Execute the last keyboard macro defined.
422 With prefix argument execute it that many times."
423 "Execute the last keyboard macro P times."
424 (declare (ignore p))
425 (editor-error "No keyboard macro defined."))
426
427 (defcommand "Name Keyboard Macro" (p &optional name)
428 "Name the \"Last Keyboard Macro\".
429 The last defined keboard macro is made into a named command."
430 "Make the \"Last Keyboard Macro\" a named command."
431 (declare (ignore p))
432 (unless name
433 (setq name (prompt-for-string
434 :prompt "Macro name: "
435 :help "String name of command to make from keyboard macro.")))
436 (make-command
437 name "This is a named keyboard macro."
438 (command-function (getstring "Last Keyboard Macro" *command-names*))))
439
440 (defcommand "Keyboard Macro Query" (p)
441 "Keyboard macro conditional.
442 During the execution of a keyboard macro, this command prompts for
443 a single character command, similar to those of \"Query Replace\"."
444 "Prompt for action during keyboard macro execution."
445 (declare (ignore p))
446 (unless (or (interactive) *kbdmac-dont-ask*)
447 (let ((*editor-input* *real-editor-input*))
448 (command-case (:prompt "Keyboard Macro Query: "
449 :help "Type one of these characters to say what to do:"
450 :change-window nil
451 :bind key-event)
452 (:exit
453 "Exit this keyboard macro immediately."
454 (throw 'exit-kbdmac nil))
455 (:yes
456 "Proceed with this iteration of the keyboard macro.")
457 (:no
458 "Don't do this iteration of the keyboard macro, but continue to the next."
459 (throw 'abort-kbdmac-iteration nil))
460 (:do-all
461 "Do all remaining repetitions of the keyboard macro without prompting."
462 (setq *kbdmac-dont-ask* t))
463 (:do-once
464 "Do this iteration of the keyboard macro and then exit."
465 (setq *kbdmac-done* t))
466 (:recursive-edit
467 "Do a recursive edit, then ask again."
468 (do-recursive-edit)
469 (reprompt))
470 (t
471 (unget-key-event key-event *editor-input*)
472 (throw 'exit-kbdmac nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5