X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/73b0cd50031a714347109169ceb8bacae338612a..c7c6d5cfc9ff335add6fbafdd8c5cb40523cf2fa:/lisp/edmacro.el diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 769d7fceb9..bb14015273 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -1,6 +1,6 @@ ;;; edmacro.el --- keyboard macro editor -;; Copyright (C) 1993-1994, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 2001-2014 Free Software Foundation, Inc. ;; Author: Dave Gillespie ;; Maintainer: Dave Gillespie @@ -61,24 +61,18 @@ ;; With a prefix argument, `edit-kbd-macro' will format the ;; macro in a more concise way that omits the comments. -;; This package requires GNU Emacs 19 or later, and daveg's CL -;; package 2.02 or later. (CL 2.02 comes standard starting with -;; Emacs 19.18.) This package does not work with Emacs 18 or -;; Lucid Emacs. - ;;; Code: - -(eval-when-compile - (require 'cl)) +(require 'cl-lib) (require 'kmacro) ;;; The user-level commands for editing macros. -;;;###autoload -(defvar edmacro-eight-bits nil - "*Non-nil if `edit-kbd-macro' should leave 8-bit characters intact. -Default nil means to write characters above \\177 in octal notation.") +(defcustom edmacro-eight-bits nil + "Non-nil if `edit-kbd-macro' should leave 8-bit characters intact. +Default nil means to write characters above \\177 in octal notation." + :type 'boolean + :group 'kmacro) (defvar edmacro-mode-map (let ((map (make-sparse-keymap))) @@ -229,7 +223,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) + (mac-counter nil) (mac-format nil) (top (point-min))) (goto-char top) (let ((case-fold-search nil)) @@ -244,7 +238,7 @@ or nil, use a compact 80-column format." (setq cmd (and (not (equal str "none")) (intern str))) (and (fboundp cmd) (not (arrayp (symbol-function cmd))) - (not (setq kmacro (get cmd 'kmacro))) + (not (get cmd 'kmacro)) (not (y-or-n-p (format "Command %s is already defined; %s" cmd "proceed? "))) @@ -323,17 +317,18 @@ or nil, use a compact 80-column format." mac)))) (if no-keys (when cmd - (loop for key in (where-is-internal cmd '(keymap)) do - (global-unset-key key))) + (cl-loop for key in (where-is-internal cmd '(keymap)) do + (global-unset-key key))) (when keys (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 - (if (and mac-counter mac-format) - (kmacro-lambda-form mac mac-counter mac-format) - mac)))))))))) + (cl-loop for key in keys do (global-unset-key key)) + (cl-loop for key in keys do + (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)) @@ -441,68 +436,69 @@ doubt, use whitespace." (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))))) + (cl-loop for i below (length macro) do + (when (>= (aref rest-mac i) 128) + (cl-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)) + (memq (key-binding (cl-subseq rest-mac 0 1)) '(digit-argument negative-argument)) (let ((i 1)) (while (memq (aref rest-mac i) (cdr mdigs)) - (incf i)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (vconcat "M-" (edmacro-subseq rest-mac 0 i) " ") - (callf edmacro-subseq rest-mac i))))) + (prog1 (vconcat "M-" (cl-subseq rest-mac 0 i) " ") + (cl-callf cl-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)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (loop repeat i concat "C-u ") - (callf edmacro-subseq rest-mac i))))) + (prog1 (cl-loop repeat i concat "C-u ") + (cl-callf cl-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)) + (cl-incf i)) (while (memq (aref rest-mac i) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (incf i)) + (cl-incf i)) (and (not (memq (aref rest-mac i) pkeys)) - (prog1 (vconcat "C-u " (edmacro-subseq rest-mac 1 i) " ") - (callf edmacro-subseq rest-mac i))))))) + (prog1 (vconcat "C-u " (cl-subseq rest-mac 1 i) " ") + (cl-callf cl-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)) + (cl-loop for map in maps + for b = (lookup-key map rest-mac) + when b collect b))) + (key (cl-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)) + (bind (or (cl-loop for map in maps for b = (lookup-key map key) + thereis (and (not (integerp b)) b)) (and (setq fkey (lookup-key local-function-key-map rest-mac)) - (setq tlen fkey tkey (edmacro-subseq rest-mac 0 tlen) + (setq tlen fkey tkey (cl-subseq rest-mac 0 tlen) fkey (lookup-key local-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))))) + (cl-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)) + (text + (cl-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) @@ -510,10 +506,10 @@ doubt, use whitespace." (> first 32) (<= first maxkey) (/= first 92) (progn (if (> text 30) (setq text 30)) - (setq desc (concat (edmacro-subseq rest-mac 0 text))) + (setq desc (concat (cl-subseq rest-mac 0 text))) (when (string-match "^[ACHMsS]-." desc) (setq text 2) - (callf substring desc 0 2)) + (cl-callf substring desc 0 2)) (not (string-match "^;;\\|^<.*>$\\|^\\\\[0-9]+$\\|^[0-9]+\\*." desc)))) @@ -527,7 +523,7 @@ doubt, use whitespace." (> text bind-len) (memq (aref rest-mac text) '(return 13)) (progn - (setq desc (concat (edmacro-subseq rest-mac bind-len text))) + (setq desc (concat (cl-subseq rest-mac bind-len text))) (commandp (intern-soft desc)))) (if (commandp (intern-soft desc)) (setq bind desc)) (setq desc (format "<<%s>>" desc)) @@ -539,17 +535,17 @@ doubt, use whitespace." (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)) + (cl-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 + (pcase ch2 (0 "NUL") (9 "TAB") (10 "LFD") (13 "RET") (27 "ESC") (32 "SPC") - (t + (_ (format "C-%c" (+ (if (<= ch2 26) 96 64) ch2))))) @@ -565,95 +561,43 @@ doubt, use whitespace." (setq desc (concat (edmacro-sanitize-for-string 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)) + (while (not (cl-mismatch rest-mac rest-mac + :start1 0 :end1 bind-len + :start2 pos :end2 (+ bind-len pos))) + (cl-incf times) + (cl-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)) + (setq rest-mac (cl-subseq rest-mac bind-len)) (if verbose (progn - (unless (equal res "") (callf concat res "\n")) - (callf concat res desc) + (unless (equal res "") (cl-callf concat res "\n")) + (cl-callf concat res desc) (when (and bind (or (stringp bind) (symbolp bind))) - (callf concat res + (cl-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 ") + (cl-callf concat res "\n ") (setq len 1)) (unless (equal res "") - (callf concat res " ") - (incf len))) - (callf concat res desc) - (incf len (length desc))))) + (cl-callf concat res " ") + (cl-incf len))) + (cl-callf concat res desc) + (cl-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. -\n(fn SEQ1 SEQ2 START1 END1 START2 END2)" - (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 SEQ 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 (logand (aref seq i) 128) - (setf (aref seq i) (logand (aref seq i) 127)))) + (cl-loop for i below (length seq) do + (when (logand (aref seq i) 128) + (setf (aref seq i) (logand (aref seq i) 127)))) seq) (defun edmacro-fix-menu-commands (macro &optional noerror) @@ -668,7 +612,7 @@ This function assumes that the events can be stored in a string." ((eq (car ev) 'switch-frame)) ((equal ev '(menu-bar)) (push 'menu-bar result)) - ((equal (cadadr ev) '(menu-bar)) + ((equal (cl-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. @@ -728,30 +672,31 @@ This function assumes that the events can be stored in a string." (t (let ((orig-word word) (prefix 0) (bits 0)) (while (string-match "^[ACHMsS]-." word) - (incf bits (cdr (assq (aref word 0) + (cl-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)) + (cl-incf prefix 2) + (cl-callf substring word 2)) (when (string-match "^\\^.$" word) - (incf bits ?\C-\^@) - (incf prefix) - (callf substring word 1)) + (cl-incf bits ?\C-\^@) + (cl-incf prefix) + (cl-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)))) + (cl-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)))) + (setq key (cl-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)) @@ -765,21 +710,21 @@ This function assumes that the events can be stored in a string." (t (setq key (list (+ bits (aref word 0))))))))) (when key - (loop repeat times do (callf vconcat res key))))) + (cl-loop repeat times do (cl-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))) + (setq res (cl-subseq res 2 -2))) (if (and (not need-vector) - (loop for ch across res - always (and (characterp 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)))) + (cl-loop for ch across res + always (and (characterp ch) + (let ((ch2 (logand ch (lognot ?\M-\^@)))) + (and (>= ch2 0) (<= ch2 127)))))) + (concat (cl-loop for ch across res + collect (if (= (logand ch ?\M-\^@) 0) + ch (+ ch 128)))) res))) (provide 'edmacro)