+(defun edmacro-format-keys (macro &optional verbose)
+ (setq macro (edmacro-fix-menu-commands macro))
+ (let* ((maps (append (current-minor-mode-maps)
+ (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))
+ (mdigs (nthcdr 13 pkeys))
+ (maxkey (if edmacro-eight-bits 255 127))
+ (case-fold-search nil)
+ (res-words '("NUL" "TAB" "LFD" "RET" "ESC" "SPC" "DEL" "REM"))
+ (rest-mac (vconcat macro [end-macro]))
+ (res "")
+ (len 0)
+ (one-line (eq verbose 1)))
+ (if one-line (setq verbose nil))
+ (when (stringp macro)
+ (loop for i below (length macro) do
+ (when (>= (aref rest-mac i) 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 (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-" (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))
+ (while (eq (aref rest-mac i) ?\C-u)
+ (incf i))
+ (and (not (memq (aref rest-mac i) pkeys))
+ (prog1 (loop repeat i concat "C-u ")
+ (callf edmacro-subseq rest-mac i)))))
+ (and (eq (aref rest-mac 0) ?\C-u)
+ (eq (key-binding [?\C-u]) 'universal-argument)
+ (let ((i 1))
+ (when (eq (aref rest-mac i) ?-)
+ (incf i))
+ (while (memq (aref rest-mac i)
+ '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
+ (incf i))
+ (and (not (memq (aref rest-mac i) pkeys))
+ (prog1 (concat "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 (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 (edmacro-subseq rest-mac 0 tlen)
+ fkey (lookup-key function-key-map tkey))
+ (loop for map in maps
+ for b = (lookup-key map fkey)
+ when (and (not (integerp b)) b)
+ do (setq bind-len tlen key tkey)
+ and return b
+ finally do (setq fkey nil)))))
+ (first (aref key 0))
+ (text (loop for i from bind-len below (length rest-mac)
+ for ch = (aref rest-mac i)
+ while (and (integerp ch)
+ (> ch 32) (< ch maxkey) (/= ch 92)
+ (eq (key-binding (char-to-string ch))
+ 'self-insert-command)
+ (or (> i (- (length rest-mac) 2))
+ (not (eq ch (aref rest-mac (+ i 1))))
+ (not (eq ch (aref rest-mac (+ i 2))))))
+ finally return i))
+ desc)
+ (if (stringp bind) (setq bind nil))
+ (cond ((and (eq bind 'self-insert-command) (not prefix)
+ (> text 1) (integerp first)
+ (> first 32) (<= first maxkey) (/= first 92)
+ (progn
+ (if (> text 30) (setq text 30))
+ (setq desc (concat (edmacro-subseq rest-mac 0 text)))
+ (when (string-match "^[ACHMsS]-." desc)
+ (setq text 2)
+ (callf substring desc 0 2))
+ (not (string-match
+ "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*."
+ desc))))
+ (when (or (string-match "^\\^.$" desc)
+ (member desc res-words))
+ (setq desc (mapconcat 'char-to-string desc " ")))
+ (when verbose
+ (setq bind (format "%s * %d" bind text)))
+ (setq bind-len text))
+ ((and (eq bind 'execute-extended-command)
+ (> text bind-len)
+ (memq (aref rest-mac text) '(return 13))
+ (progn
+ (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))
+ (setq bind-len (1+ text)))
+ (t
+ (setq desc (mapconcat
+ (function
+ (lambda (ch)
+ (cond
+ ((integerp ch)
+ (concat
+ (loop for pf across "ACHMsS"
+ 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)
+ (case ch2
+ (0 "NUL") (9 "TAB") (10 "LFD")
+ (13 "RET") (27 "ESC") (32 "SPC")
+ (t
+ (format "C-%c"
+ (+ (if (<= ch2 26) 96 64)
+ ch2)))))
+ ((= ch2 127) "DEL")
+ ((<= ch2 maxkey) (char-to-string ch2))
+ (t (format "\\%o" ch2))))))
+ ((symbolp ch)
+ (format "<%s>" ch))
+ (t
+ (error "Unrecognized item in macro: %s" ch)))))
+ (or fkey key) " "))))
+ (if prefix (setq desc (concat prefix desc)))
+ (unless (string-match " " desc)
+ (let ((times 1) (pos bind-len))
+ (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 (edmacro-subseq rest-mac bind-len))
+ (if verbose
+ (progn
+ (unless (equal res "") (callf concat res "\n"))
+ (callf concat res desc)
+ (when (and bind (or (stringp bind) (symbolp bind)))
+ (callf concat res
+ (make-string (max (- 3 (/ (length desc) 8)) 1) 9)
+ ";; " (if (stringp bind) bind (symbol-name bind))))
+ (setq len 0))
+ (if (and (> (+ len (length desc) 2) 72) (not one-line))
+ (progn
+ (callf concat res "\n ")
+ (setq len 1))
+ (unless (equal res "")
+ (callf concat res " ")
+ (incf len)))
+ (callf concat res desc)
+ (incf len (length desc)))))
+ res))
+
+(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)
+ (cl-push (cl-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-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 (edmacro-subseq macro 0 i)
+ (vector 'menu-bar (car ev))
+ (edmacro-subseq macro (1+ i))))
+ (incf i))
+ ;; It would be nice to do pop-up menus, too, but not enough
+ ;; info is recorded in macros to make this possible.
+ (t
+ (error "Macros with mouse clicks are not %s"
+ "supported by this command"))))
+ (incf i))))
+ macro)
+\f
+;;; Parsing a human-readable keyboard macro.
+
+(defun edmacro-parse-keys (string &optional need-vector)
+ (let ((case-fold-search nil)
+ (pos 0)
+ (res []))
+ (while (and (< pos (length string))
+ (string-match "[^ \t\n\f]+" string pos))
+ (let ((word (substring string (match-beginning 0) (match-end 0)))
+ (key nil)
+ (times 1))
+ (setq pos (match-end 0))
+ (when (string-match "\\([0-9]+\\)\\*." word)
+ (setq times (string-to-int (substring word 0 (match-end 1))))
+ (setq word (substring word (1+ (match-end 1)))))
+ (cond ((string-match "^<<.+>>$" word)
+ (setq key (vconcat (if (eq (key-binding [?\M-x])
+ 'execute-extended-command)
+ [?\M-x]
+ (or (car (where-is-internal
+ 'execute-extended-command))
+ [?\M-x]))
+ (substring word 2 -2) "\r")))
+ ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word)
+ (progn
+ (setq word (concat (substring word (match-beginning 1)
+ (match-end 1))
+ (substring word (match-beginning 3)
+ (match-end 3))))
+ (not (string-match
+ "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$"
+ word))))
+ (setq key (list (intern word))))
+ ((or (equal word "REM") (string-match "^;;" word))
+ (setq pos (string-match "$" string pos)))
+ (t
+ (let ((orig-word word) (prefix 0) (bits 0))
+ (while (string-match "^[ACHMsS]-." word)
+ (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 ?\C-\^@)
+ (incf prefix)
+ (callf substring word 1))
+ (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r")
+ ("LFD" . "\n") ("TAB" . "\t")
+ ("ESC" . "\e") ("SPC" . " ")
+ ("DEL" . "\177")))))
+ (when found (setq word (cdr found))))
+ (when (string-match "^\\\\[0-7]+$" word)
+ (loop for ch across word
+ for n = 0 then (+ (* n 8) ch -48)
+ finally do (setq word (vector n))))
+ (cond ((= bits 0)
+ (setq key 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 ?\C-\^@) 0) (stringp word)
+ (string-match "[@-_.a-z?]" word))
+ (setq key (list (+ bits (- ?\C-\^@)
+ (if (equal word "?") 127
+ (logand (aref word 0) 31))))))
+ (t
+ (setq key (list (+ bits (aref word 0)))))))))
+ (when key
+ (loop repeat times do (callf vconcat res key)))))
+ (when (and (>= (length res) 4)
+ (eq (aref res 0) ?\C-x)
+ (eq (aref res 1) ?\()
+ (eq (aref res (- (length res) 2)) ?\C-x)
+ (eq (aref res (- (length res) 1)) ?\)))
+ (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 ?\M-\^@))))
+ (and (>= ch2 0) (<= ch2 127))))))
+ (concat (loop for ch across res
+ collect (if (= (logand ch ?\M-\^@) 0)
+ ch (+ ch 128))))
+ res)))
+\f
+;;; 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)