/[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.3 - (hide annotations) (vendor branch)
Sat Nov 9 03:05:39 1991 UTC (22 years, 5 months ago) by wlott
Changes since 1.2.1.2: +2 -2 lines
Changed BASE-CHARACTER to BASE-CHAR.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2.1.2 ;;; 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 wlott 1.2.1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/kbdmac.lisp,v 1.2.1.3 1991/11/09 03:05:39 wlott Exp $")
11 ram 1.2.1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
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 ram 1.2 (in-package "HEMLOCK")
21    
22 ram 1.1 ;;; 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 ram 1.2 (get-key-event *editor-input*))
71 ram 1.1
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 ram 1.2 (lastc *last-key-event-typed*))
101 ram 1.1 (save-kbdmac-input
102     (let ((*invoke-hook* *old-invoke-hook*))
103     (funcall fun arg))
104 ram 1.2 (kbdmac-emit `(set *last-key-event-typed* ,lastc))
105 ram 1.1 (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 ram 1.2 (defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t))
114 ram 1.1
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 ram 1.2 (defun key-vector-to-string (key-vector)
121 wlott 1.2.1.3 (let ((string (make-array (length key-vector) :element-type 'base-char)))
122 ram 1.2 (dotimes (i (length key-vector) string)
123     (setf (aref string i) (key-event-char (aref key-vector i))))))
124    
125 ram 1.1 (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 ram 1.2 (vector-push-extend *last-key-event-typed* *kbdmac-text*))))
134 ram 1.1 (:finish
135 ram 1.2 (if (> (length *kbdmac-text*) 1)
136 ram 1.1 (kbdmac-emit `(insert-string-at-point
137 ram 1.2 ,(key-vector-to-string *kbdmac-text*)))
138     (kbdmac-emit `(insert-character-at-point
139     ,(key-event-char (aref *kbdmac-text* 0))))))))
140 ram 1.1 ;;;
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 ram 1.2 (with-output-to-string (s) (print-pretty-key key s))
356 ram 1.1 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 ram 1.2 (print-pretty-key key s))
376 ram 1.1 ,(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 ram 1.2 (print-pretty-key key s)))
386 ram 1.1 :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 ram 1.2 :bind key-event)
452 ram 1.1 (: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 ram 1.2 (unget-key-event key-event *editor-input*)
472 ram 1.1 (throw 'exit-kbdmac nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5