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

Contents of /src/hemlock/kbdmac.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5