source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/kbdmac.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.9 KB
Line 
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;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
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(in-package :hemlock)
19
20;;; 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  (get-key-event *editor-input*))
69
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           (lastc *last-key-event-typed*))
99       (save-kbdmac-input
100         (let ((*invoke-hook* *old-invoke-hook*))
101           (funcall fun arg))
102         (kbdmac-emit `(set *last-key-event-typed* ,lastc))
103         (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(defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t))
112
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(defun key-vector-to-string (key-vector)
119  (let ((string (make-array (length key-vector) :element-type 'base-char)))
120    (dotimes (i (length key-vector) string)
121      (setf (aref string i) (hemlock-ext:key-event-char (aref key-vector i))))))
122
123(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         (vector-push-extend *last-key-event-typed* *kbdmac-text*))))
132    (:finish
133     (if (> (length *kbdmac-text*) 1)
134         (kbdmac-emit `(insert-string-at-point
135                        ,(key-vector-to-string *kbdmac-text*)))
136         (kbdmac-emit `(insert-character-at-point
137                        ,(hemlock-ext:key-event-char (aref *kbdmac-text* 0))))))))
138;;;
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* #+later (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                 (with-output-to-string (s) (hemlock-ext:print-pretty-key key s))
354                 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                                 (hemlock-ext:print-pretty-key key s))
374                              ,(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                                 (hemlock-ext:print-pretty-key key s)))
384                    :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                     :bind key-event)
450        (: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         (unget-key-event key-event *editor-input*)
470         (throw 'exit-kbdmac nil))))))
Note: See TracBrowser for help on using the repository browser.