Commit c31afdbd authored by Richard M. Stallman's avatar Richard M. Stallman
Browse files

Load cl only during compilation.

(edmacro-mismatch, edmacro-subseq): New functions.
Use them instead of mismatch and subseq.
parent 539fbabb
...@@ -69,7 +69,8 @@ ...@@ -69,7 +69,8 @@
;;; Code: ;;; Code:
(require 'cl) (eval-when-compile
(require 'cl))
;;; The user-level commands for editing macros. ;;; The user-level commands for editing macros.
...@@ -221,7 +222,7 @@ or nil, use a compact 80-column format." ...@@ -221,7 +222,7 @@ or nil, use a compact 80-column format."
(let ((str (buffer-substring (match-beginning 1) (let ((str (buffer-substring (match-beginning 1)
(match-end 1)))) (match-end 1))))
(unless (equal str "") (unless (equal str "")
(setq cmd (and (not (equalp str "none")) (setq cmd (and (not (equal str "none"))
(intern str))) (intern str)))
(and (fboundp cmd) (not (arrayp (symbol-function cmd))) (and (fboundp cmd) (not (arrayp (symbol-function cmd)))
(not (y-or-n-p (not (y-or-n-p
...@@ -236,7 +237,7 @@ or nil, use a compact 80-column format." ...@@ -236,7 +237,7 @@ or nil, use a compact 80-column format."
(buffer-substring (match-beginning 1) (buffer-substring (match-beginning 1)
(match-end 1))))) (match-end 1)))))
(unless (equal key "") (unless (equal key "")
(if (equalp key "none") (if (equal key "none")
(setq no-keys t) (setq no-keys t)
(push key keys) (push key keys)
(let ((b (key-binding key))) (let ((b (key-binding key)))
...@@ -405,14 +406,14 @@ doubt, use whitespace." ...@@ -405,14 +406,14 @@ doubt, use whitespace."
(let* ((prefix (let* ((prefix
(or (and (integerp (aref rest-mac 0)) (or (and (integerp (aref rest-mac 0))
(memq (aref rest-mac 0) mdigs) (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)) '(digit-argument negative-argument))
(let ((i 1)) (let ((i 1))
(while (memq (aref rest-mac i) (cdr mdigs)) (while (memq (aref rest-mac i) (cdr mdigs))
(incf i)) (incf i))
(and (not (memq (aref rest-mac i) pkeys)) (and (not (memq (aref rest-mac i) pkeys))
(prog1 (concat "M-" (subseq rest-mac 0 i) " ") (prog1 (concat "M-" (edmacro-subseq rest-mac 0 i) " ")
(callf subseq rest-mac i))))) (callf edmacro-subseq rest-mac i)))))
(and (eq (aref rest-mac 0) ?\C-u) (and (eq (aref rest-mac 0) ?\C-u)
(eq (key-binding [?\C-u]) 'universal-argument) (eq (key-binding [?\C-u]) 'universal-argument)
(let ((i 1)) (let ((i 1))
...@@ -420,7 +421,7 @@ doubt, use whitespace." ...@@ -420,7 +421,7 @@ doubt, use whitespace."
(incf i)) (incf i))
(and (not (memq (aref rest-mac i) pkeys)) (and (not (memq (aref rest-mac i) pkeys))
(prog1 (loop repeat i concat "C-u ") (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) (and (eq (aref rest-mac 0) ?\C-u)
(eq (key-binding [?\C-u]) 'universal-argument) (eq (key-binding [?\C-u]) 'universal-argument)
(let ((i 1)) (let ((i 1))
...@@ -430,18 +431,18 @@ doubt, use whitespace." ...@@ -430,18 +431,18 @@ doubt, use whitespace."
'(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
(incf i)) (incf i))
(and (not (memq (aref rest-mac i) pkeys)) (and (not (memq (aref rest-mac i) pkeys))
(prog1 (concat "C-u " (subseq rest-mac 1 i) " ") (prog1 (concat "C-u " (edmacro-subseq rest-mac 1 i) " ")
(callf subseq rest-mac i))))))) (callf edmacro-subseq rest-mac i)))))))
(bind-len (apply 'max 1 (bind-len (apply 'max 1
(loop for map in maps (loop for map in maps
for b = (lookup-key map rest-mac) for b = (lookup-key map rest-mac)
when b collect b))) when b collect b)))
(key (subseq rest-mac 0 bind-len)) (key (edmacro-subseq rest-mac 0 bind-len))
(fkey nil) tlen tkey (fkey nil) tlen tkey
(bind (or (loop for map in maps for b = (lookup-key map key) (bind (or (loop for map in maps for b = (lookup-key map key)
thereis (and (not (integerp b)) b)) thereis (and (not (integerp b)) b))
(and (setq fkey (lookup-key function-key-map rest-mac)) (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)) fkey (lookup-key function-key-map tkey))
(loop for map in maps (loop for map in maps
for b = (lookup-key map fkey) for b = (lookup-key map fkey)
...@@ -467,7 +468,7 @@ doubt, use whitespace." ...@@ -467,7 +468,7 @@ doubt, use whitespace."
(> first 32) (<= first maxkey) (/= first 92) (> first 32) (<= first maxkey) (/= first 92)
(progn (progn
(if (> text 30) (setq text 30)) (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) (when (string-match "^[ACHMsS]-." desc)
(setq text 2) (setq text 2)
(callf substring desc 0 2)) (callf substring desc 0 2))
...@@ -484,7 +485,7 @@ doubt, use whitespace." ...@@ -484,7 +485,7 @@ doubt, use whitespace."
(> text bind-len) (> text bind-len)
(memq (aref rest-mac text) '(return 13)) (memq (aref rest-mac text) '(return 13))
(progn (progn
(setq desc (concat (subseq rest-mac bind-len text))) (setq desc (concat (edmacro-subseq rest-mac bind-len text)))
(commandp (intern-soft desc)))) (commandp (intern-soft desc))))
(if (commandp (intern-soft desc)) (setq bind desc)) (if (commandp (intern-soft desc)) (setq bind desc))
(setq desc (format "<<%s>>" desc)) (setq desc (format "<<%s>>" desc))
...@@ -521,15 +522,14 @@ doubt, use whitespace." ...@@ -521,15 +522,14 @@ doubt, use whitespace."
(if prefix (setq desc (concat prefix desc))) (if prefix (setq desc (concat prefix desc)))
(unless (string-match " " desc) (unless (string-match " " desc)
(let ((times 1) (pos bind-len)) (let ((times 1) (pos bind-len))
(while (not (mismatch rest-mac rest-mac (while (not (edmacro-mismatch rest-mac rest-mac
:end1 bind-len :start2 pos 0 bind-len pos (+ bind-len pos)))
:end2 (+ bind-len pos)))
(incf times) (incf times)
(incf pos bind-len)) (incf pos bind-len))
(when (> times 1) (when (> times 1)
(setq desc (format "%d*%s" times desc)) (setq desc (format "%d*%s" times desc))
(setq bind-len (* bind-len times))))) (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 (if verbose
(progn (progn
(unless (equal res "") (callf concat res "\n")) (unless (equal res "") (callf concat res "\n"))
...@@ -550,15 +550,67 @@ doubt, use whitespace." ...@@ -550,15 +550,67 @@ doubt, use whitespace."
(incf len (length desc))))) (incf len (length desc)))))
res)) 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) (defun edmacro-fix-menu-commands (macro)
(when (vectorp macro) (when (vectorp macro)
(let ((i 0) ev) (let ((i 0) ev)
(while (< i (length macro)) (while (< i (length macro))
(when (consp (setq ev (aref macro i))) (when (consp (setq ev (aref macro i)))
(cond ((equal (cadadr ev) '(menu-bar)) (cond ((equal (cadadr ev) '(menu-bar))
(setq macro (vconcat (subseq macro 0 i) (setq macro (vconcat (edmacro-subseq macro 0 i)
(vector 'menu-bar (car ev)) (vector 'menu-bar (car ev))
(subseq macro (1+ i)))) (edmacro-subseq macro (1+ i))))
(incf i)) (incf i))
;; It would be nice to do pop-up menus, too, but not enough ;; It would be nice to do pop-up menus, too, but not enough
;; info is recorded in macros to make this possible. ;; info is recorded in macros to make this possible.
...@@ -647,7 +699,7 @@ doubt, use whitespace." ...@@ -647,7 +699,7 @@ doubt, use whitespace."
(eq (aref res 1) ?\() (eq (aref res 1) ?\()
(eq (aref res (- (length res) 2)) ?\C-x) (eq (aref res (- (length res) 2)) ?\C-x)
(eq (aref res (- (length res) 1)) ?\))) (eq (aref res (- (length res) 1)) ?\)))
(setq res (subseq res 2 -2))) (setq res (edmacro-subseq res 2 -2)))
(if (and (not need-vector) (if (and (not need-vector)
(loop for ch across res (loop for ch across res
always (and (integerp ch) always (and (integerp ch)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment