X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/8f1204db34c0e8380f1eb81c9202520511744be3..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/edmacro.el diff --git a/lisp/edmacro.el b/lisp/edmacro.el index ebf67b6185..0db09d7eeb 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -20,8 +20,9 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: @@ -31,7 +32,7 @@ ;; in a special buffer. It prompts you to type a key sequence, ;; which should be one of: ;; -;; * RET or `C-x e' (call-last-kbd-macro), to edit the most +;; * RET or `C-x e' (call-last-kbd-macro), to edit the most ;; recently defined keyboard macro. ;; ;; * `M-x' followed by a command name, to edit a named command @@ -69,11 +70,12 @@ ;;; Code: -(require 'cl) +(eval-when-compile + (require 'cl)) -;;; The user-level commands for editing macros. +(require 'kmacro) -;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro) +;;; The user-level commands for editing macros. ;;;###autoload (defvar edmacro-eight-bits nil @@ -86,6 +88,10 @@ Default nil means to write characters above \\177 in octal notation.") (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit) (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key)) +(defvar edmacro-store-hook) +(defvar edmacro-finish-hook) +(defvar edmacro-original-buffer) + ;;;###autoload (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook) "Edit a keyboard macro. @@ -97,30 +103,44 @@ With a prefix argument, format the macro in a more concise way." (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP") (when keys (let ((cmd (if (arrayp keys) (key-binding keys) keys)) - (mac nil)) + (mac nil) (mac-counter nil) (mac-format nil) + kmacro) (cond (store-hook (setq mac keys) (setq cmd nil)) - ((or (eq cmd 'call-last-kbd-macro) + ((or (memq cmd '(call-last-kbd-macro kmacro-call-macro + kmacro-end-or-call-macro kmacro-end-and-call-macro)) (member keys '("\r" [return]))) (or last-kbd-macro (y-or-n-p "No keyboard macro defined. Create one? ") (keyboard-quit)) (setq mac (or last-kbd-macro "")) + (setq keys nil) (setq cmd 'last-kbd-macro)) ((eq cmd 'execute-extended-command) (setq cmd (read-command "Name of keyboard macro to edit: ")) + (if (string-equal cmd "") + (error "No command name given")) + (setq keys nil) (setq mac (symbol-function cmd))) - ((eq cmd 'view-lossage) + ((memq cmd '(view-lossage electric-view-lossage)) (setq mac (recent-keys)) + (setq keys nil) (setq cmd 'last-kbd-macro)) + ((null cmd) + (error "Key sequence %s is not defined" (key-description keys))) ((symbolp cmd) (setq mac (symbol-function cmd))) (t (setq mac cmd) (setq cmd nil))) + (when (setq kmacro (kmacro-extract-lambda mac)) + (setq mac (car kmacro) + mac-counter (nth 1 kmacro) + mac-format (nth 2 kmacro))) (unless (arrayp mac) - (error "Not a keyboard macro: %s" cmd)) + (error "Key sequence %s is not a keyboard macro" + (key-description keys))) (message "Formatting keyboard macro...") (let* ((oldbuf (current-buffer)) (mmac (edmacro-fix-menu-commands mac)) @@ -143,11 +163,15 @@ With a prefix argument, format the macro in a more concise way." (insert ";; Original keys: " fmt "\n") (unless store-hook (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n") - (let ((keys (where-is-internal (or cmd mac) '(keymap)))) - (if keys - (while keys - (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n")) - (insert "Key: none\n")))) + (let ((gkeys (where-is-internal (or cmd mac) '(keymap)))) + (if (and keys (not (member keys gkeys))) + (setq gkeys (cons keys gkeys))) + (if gkeys + (while gkeys + (insert "Key: " (edmacro-format-keys (pop gkeys) 1) "\n")) + (insert "Key: none\n"))) + (when (and mac-counter mac-format) + (insert (format "Counter: %d\nFormat: \"%s\"\n" mac-counter mac-format)))) (insert "\nMacro:\n\n") (save-excursion (insert fmtv "\n")) @@ -207,6 +231,7 @@ or nil, use a compact 80-column format." "This command is valid only in buffers created by `edit-kbd-macro'")) (run-hooks 'edmacro-finish-hook) (let ((cmd nil) (keys nil) (no-keys nil) + (mac-counter nil) (mac-format nil) (kmacro nil) (top (point-min))) (goto-char top) (let ((case-fold-search nil)) @@ -218,9 +243,10 @@ or nil, use a compact 80-column format." (let ((str (buffer-substring (match-beginning 1) (match-end 1)))) (unless (equal str "") - (setq cmd (and (not (equalp str "none")) + (setq cmd (and (not (equal str "none")) (intern str))) (and (fboundp cmd) (not (arrayp (symbol-function cmd))) + (not (setq kmacro (get cmd 'kmacro))) (not (y-or-n-p (format "Command %s is already defined; %s" cmd "proceed? "))) @@ -233,11 +259,12 @@ or nil, use a compact 80-column format." (buffer-substring (match-beginning 1) (match-end 1))))) (unless (equal key "") - (if (equalp key "none") + (if (equal key "none") (setq no-keys t) (push key keys) (let ((b (key-binding key))) (and b (commandp b) (not (arrayp b)) + (not (kmacro-extract-lambda b)) (or (not (fboundp b)) (not (arrayp (symbol-function b)))) (not (y-or-n-p @@ -246,6 +273,22 @@ or nil, use a compact 80-column format." "proceed? "))) (keyboard-quit)))))) t) + ((looking-at "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$") + (when edmacro-store-hook + (error "\"Counter\" line not allowed in this context")) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (unless (equal str "") + (setq mac-counter (string-to-int str)))) + t) + ((looking-at "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$") + (when edmacro-store-hook + (error "\"Format\" line not allowed in this context")) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (unless (equal str "") + (setq mac-format str))) + t) ((looking-at "Macro:[ \t\n]*") (goto-char (match-end 0)) nil) @@ -275,7 +318,10 @@ or nil, use a compact 80-column format." (when cmd (if (= (length mac) 0) (fmakunbound cmd) - (fset cmd mac))) + (fset cmd + (if (and mac-counter mac-format) + (kmacro-lambda-form mac mac-counter mac-format) + mac)))) (if no-keys (when cmd (loop for key in (where-is-internal cmd '(keymap)) do @@ -284,7 +330,11 @@ or nil, use a compact 80-column format." (if (= (length mac) 0) (loop for key in keys do (global-unset-key key)) (loop for key in keys do - (global-set-key key (or cmd mac))))))))) + (global-set-key key + (or cmd + (if (and mac-counter mac-format) + (kmacro-lambda-form mac mac-counter mac-format) + mac)))))))))) (kill-buffer buf) (when (buffer-name obuf) (switch-to-buffer obuf)) @@ -379,7 +429,9 @@ doubt, use whitespace." (defun edmacro-format-keys (macro &optional verbose) (setq macro (edmacro-fix-menu-commands macro)) (let* ((maps (append (current-minor-mode-maps) - (list (current-local-map) (current-global-map)))) + (if (current-local-map) + (list (current-local-map))) + (list (current-global-map)))) (pkeys '(end-macro ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?\C-u ?\M-- ?\M-0 ?\M-1 ?\M-2 ?\M-3 ?\M-4 ?\M-5 ?\M-6 ?\M-7 ?\M-8 ?\M-9)) @@ -395,19 +447,19 @@ doubt, use whitespace." (when (stringp macro) (loop for i below (length macro) do (when (>= (aref rest-mac i) 128) - (incf (aref rest-mac i) (- (lsh 1 23) 128))))) + (incf (aref rest-mac i) (- ?\M-\^@ 128))))) (while (not (eq (aref rest-mac 0) 'end-macro)) (let* ((prefix (or (and (integerp (aref rest-mac 0)) (memq (aref rest-mac 0) mdigs) - (memq (key-binding (subseq rest-mac 0 1)) + (memq (key-binding (edmacro-subseq rest-mac 0 1)) '(digit-argument negative-argument)) (let ((i 1)) (while (memq (aref rest-mac i) (cdr mdigs)) (incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (concat "M-" (subseq rest-mac 0 i) " ") - (callf subseq rest-mac i))))) + (prog1 (vconcat "M-" (edmacro-subseq rest-mac 0 i) " ") + (callf edmacro-subseq rest-mac i))))) (and (eq (aref rest-mac 0) ?\C-u) (eq (key-binding [?\C-u]) 'universal-argument) (let ((i 1)) @@ -415,7 +467,7 @@ doubt, use whitespace." (incf i)) (and (not (memq (aref rest-mac i) pkeys)) (prog1 (loop repeat i concat "C-u ") - (callf subseq rest-mac i))))) + (callf edmacro-subseq rest-mac i))))) (and (eq (aref rest-mac 0) ?\C-u) (eq (key-binding [?\C-u]) 'universal-argument) (let ((i 1)) @@ -425,18 +477,18 @@ doubt, use whitespace." '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) (incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (concat "C-u " (subseq rest-mac 1 i) " ") - (callf subseq rest-mac i))))))) + (prog1 (vconcat "C-u " (edmacro-subseq rest-mac 1 i) " ") + (callf edmacro-subseq rest-mac i))))))) (bind-len (apply 'max 1 (loop for map in maps for b = (lookup-key map rest-mac) when b collect b))) - (key (subseq rest-mac 0 bind-len)) + (key (edmacro-subseq rest-mac 0 bind-len)) (fkey nil) tlen tkey (bind (or (loop for map in maps for b = (lookup-key map key) thereis (and (not (integerp b)) b)) (and (setq fkey (lookup-key function-key-map rest-mac)) - (setq tlen fkey tkey (subseq rest-mac 0 tlen) + (setq tlen fkey tkey (edmacro-subseq rest-mac 0 tlen) fkey (lookup-key function-key-map tkey)) (loop for map in maps for b = (lookup-key map fkey) @@ -462,7 +514,7 @@ doubt, use whitespace." (> first 32) (<= first maxkey) (/= first 92) (progn (if (> text 30) (setq text 30)) - (setq desc (concat (subseq rest-mac 0 text))) + (setq desc (concat (edmacro-subseq rest-mac 0 text))) (when (string-match "^[ACHMsS]-." desc) (setq text 2) (callf substring desc 0 2)) @@ -479,7 +531,7 @@ doubt, use whitespace." (> text bind-len) (memq (aref rest-mac text) '(return 13)) (progn - (setq desc (concat (subseq rest-mac bind-len text))) + (setq desc (concat (edmacro-subseq rest-mac bind-len text))) (commandp (intern-soft desc)))) (if (commandp (intern-soft desc)) (setq bind desc)) (setq desc (format "<<%s>>" desc)) @@ -492,8 +544,9 @@ doubt, use whitespace." ((integerp ch) (concat (loop for pf across "ACHMsS" - for bit in '(18 22 20 23 19 21) - when (/= (logand ch (lsh 1 bit)) 0) + for bit in '(?\A-\^@ ?\C-\^@ ?\H-\^@ + ?\M-\^@ ?\s-\^@ ?\S-\^@) + when (/= (logand ch bit) 0) concat (format "%c-" pf)) (let ((ch2 (logand ch (1- (lsh 1 18))))) (cond ((<= ch2 32) @@ -512,18 +565,18 @@ doubt, use whitespace." (t (error "Unrecognized item in macro: %s" ch))))) (or fkey key) " ")))) - (if prefix (setq desc (concat prefix desc))) + (if prefix + (setq desc (concat (edmacro-sanitize-for-string prefix) desc))) (unless (string-match " " desc) (let ((times 1) (pos bind-len)) - (while (not (mismatch rest-mac rest-mac - :end1 bind-len :start2 pos - :end2 (+ bind-len pos))) + (while (not (edmacro-mismatch rest-mac rest-mac + 0 bind-len pos (+ bind-len pos))) (incf times) (incf pos bind-len)) (when (> times 1) (setq desc (format "%d*%s" times desc)) (setq bind-len (* bind-len times))))) - (setq rest-mac (subseq rest-mac bind-len)) + (setq rest-mac (edmacro-subseq rest-mac bind-len)) (if verbose (progn (unless (equal res "") (callf concat res "\n")) @@ -544,23 +597,92 @@ doubt, use whitespace." (incf len (length desc))))) res)) -(defun edmacro-fix-menu-commands (macro) - (when (vectorp macro) - (let ((i 0) ev) - (while (< i (length macro)) - (when (consp (setq ev (aref macro i))) - (cond ((equal (cadadr ev) '(menu-bar)) - (setq macro (vconcat (subseq macro 0 i) - (vector 'menu-bar (car ev)) - (subseq macro (1+ i)))) - (incf i)) +(defun edmacro-mismatch (cl-seq1 cl-seq2 cl-start1 cl-end1 cl-start2 cl-end2) + "Compare SEQ1 with SEQ2, return index of first mismatching element. +Return nil if the sequences match. If one sequence is a prefix of the +other, the return value indicates the end of the shorted sequence." + (let (cl-test cl-test-not cl-key cl-from-end) + (or cl-end1 (setq cl-end1 (length cl-seq1))) + (or cl-end2 (setq cl-end2 (length cl-seq2))) + (if cl-from-end + (progn + (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) + (cl-check-match (elt cl-seq1 (1- cl-end1)) + (elt cl-seq2 (1- cl-end2)))) + (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) + (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) + (1- cl-end1))) + (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) + (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) + (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) + (cl-check-match (if cl-p1 (car cl-p1) + (aref cl-seq1 cl-start1)) + (if cl-p2 (car cl-p2) + (aref cl-seq2 cl-start2)))) + (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) + cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) + (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) + cl-start1))))) + +(defun edmacro-subseq (seq start &optional end) + "Return the subsequence of SEQ from START to END. +If END is omitted, it defaults to the length of the sequence. +If START or END is negative, it counts from the end." + (if (stringp seq) (substring seq start end) + (let (len) + (and end (< end 0) (setq end (+ end (setq len (length seq))))) + (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) + (cond ((listp seq) + (if (> start 0) (setq seq (nthcdr start seq))) + (if end + (let ((res nil)) + (while (>= (setq end (1- end)) start) + (push (pop seq) res)) + (nreverse res)) + (copy-sequence seq))) + (t + (or end (setq end (or len (length seq)))) + (let ((res (make-vector (max (- end start) 0) nil)) + (i 0)) + (while (< start end) + (aset res i (aref seq start)) + (setq i (1+ i) start (1+ start))) + res)))))) + +(defun edmacro-sanitize-for-string (seq) + "Convert a key sequence vector into a string. +The string represents the same events; Meta is indicated by bit 7. +This function assumes that the events can be stored in a string." + (setq seq (copy-sequence seq)) + (loop for i below (length seq) do + (when (< (aref seq i) 0) + (setf (aref seq i) (logand (aref seq i) 127)))) + seq) + +(defun edmacro-fix-menu-commands (macro &optional noerror) + (if (vectorp macro) + (let (result) + ;; Make a list of the elements. + (setq macro (append macro nil)) + (dolist (ev macro) + (cond ((atom ev) + (push ev result)) + ((eq (car ev) 'help-echo)) + ((equal ev '(menu-bar)) + (push 'menu-bar result)) + ((equal (cadadr ev) '(menu-bar)) + (push (vector 'menu-bar (car ev)) result)) ;; It would be nice to do pop-up menus, too, but not enough ;; info is recorded in macros to make this possible. + (noerror + ;; Just ignore mouse events. + nil) (t (error "Macros with mouse clicks are not %s" "supported by this command")))) - (incf i)))) - macro) + ;; Reverse them again and make them back into a vector. + (vconcat (nreverse result))) + macro)) ;;; Parsing a human-readable keyboard macro. @@ -600,14 +722,14 @@ doubt, use whitespace." (t (let ((orig-word word) (prefix 0) (bits 0)) (while (string-match "^[ACHMsS]-." word) - (incf bits (lsh 1 (cdr (assq (aref word 0) - '((?A . 18) (?C . 22) - (?H . 20) (?M . 23) - (?s . 19) (?S . 21)))))) + (incf bits (cdr (assq (aref word 0) + '((?A . ?\A-\^@) (?C . ?\C-\^@) + (?H . ?\H-\^@) (?M . ?\M-\^@) + (?s . ?\s-\^@) (?S . ?\S-\^@))))) (incf prefix 2) (callf substring word 2)) (when (string-match "^\\^.$" word) - (incf bits (lsh 1 22)) + (incf bits ?\C-\^@) (incf prefix) (callf substring word 1)) (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") @@ -621,17 +743,19 @@ doubt, use whitespace." finally do (setq word (vector n)))) (cond ((= bits 0) (setq key word)) - ((and (= bits (lsh 1 23)) (stringp word) + ((and (= bits ?\M-\^@) (stringp word) (string-match "^-?[0-9]+$" word)) (setq key (loop for x across word collect (+ x bits)))) ((/= (length word) 1) (error "%s must prefix a single character, not %s" (substring orig-word 0 prefix) word)) - ((and (/= (logand bits (lsh 1 22)) 0) (stringp word) - (string-match "[@-_.a-z?]" word)) - (setq key (list (+ bits (- (lsh 1 22)) - (if (equal word "?") 127 - (logand (aref word 0) 31)))))) + ((and (/= (logand bits ?\C-\^@) 0) (stringp word) + ;; We used to accept . and ? here, + ;; but . is simply wrong, + ;; and C-? is not used (we use DEL instead). + (string-match "[@-_a-z]" word)) + (setq key (list (+ bits (- ?\C-\^@) + (logand (aref word 0) 31))))) (t (setq key (list (+ bits (aref word 0))))))))) (when key @@ -641,53 +765,18 @@ doubt, use whitespace." (eq (aref res 1) ?\() (eq (aref res (- (length res) 2)) ?\C-x) (eq (aref res (- (length res) 1)) ?\))) - (setq res (subseq res 2 -2))) + (setq res (edmacro-subseq res 2 -2))) (if (and (not need-vector) (loop for ch across res - always (and (integerp ch) - (let ((ch2 (logand ch (lognot (lsh 1 23))))) + always (and (char-valid-p ch) + (let ((ch2 (logand ch (lognot ?\M-\^@)))) (and (>= ch2 0) (<= ch2 127)))))) (concat (loop for ch across res - collect (if (= (logand ch (lsh 1 23)) 0) + collect (if (= (logand ch ?\M-\^@) 0) ch (+ ch 128)))) res))) - -;;; The following probably ought to go in macros.el: - -;;;###autoload -(defun insert-kbd-macro (macroname &optional keys) - "Insert in buffer the definition of kbd macro NAME, as Lisp code. -Optional second arg KEYS means also record the keys it is on -\(this is the prefix argument, when calling interactively). - -This Lisp code will, when executed, define the kbd macro with the same -definition it has now. If you say to record the keys, the Lisp code -will also rebind those keys to the macro. Only global key bindings -are recorded since executing this Lisp code always makes global -bindings. - -To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', -use this command, and then save the file." - (interactive "CInsert kbd macro (name): \nP") - (let (definition) - (if (string= (symbol-name macroname) "") - (progn - (setq definition (format-kbd-macro)) - (insert "(setq last-kbd-macro")) - (setq definition (format-kbd-macro macroname)) - (insert (format "(defalias '%s" macroname))) - (if (> (length definition) 50) - (insert " (read-kbd-macro\n") - (insert "\n (read-kbd-macro ")) - (prin1 definition (current-buffer)) - (insert "))\n") - (if keys - (let ((keys (where-is-internal macroname '(keymap)))) - (while keys - (insert (format "(global-set-key %S '%s)\n" (car keys) macroname)) - (setq keys (cdr keys))))))) (provide 'edmacro) +;;; arch-tag: 726807b4-3ae6-49de-b0ae-b9590973e0d7 ;;; edmacro.el ends here -