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

Contents of /src/hemlock/kbdmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5