Moving kbd to subr.el

[Stefan Kangas <stefankangas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 752 bytes --]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> No, skimming that, it's much simpler than I imagined.  Rewriting that
> and plonking it into subr.el would be nice.  I mean, I think we should
> do that anyway, so that we can use `kbd' everywhere.

I've attached a quick proof-of-concept of moving the kbd implementation
to subr.el.  With this, all the tests I have assembled so far pass and
this bootstraps.  It was mostly just a case of ripping out the calls to
cl-lib functions.

If this is something we want to do, I can finish this patch up.  To
begin with, I'd want to look it all over for correctness and add more
tests (ideas welcome).  I guess it would also make sense to just change
`read-kbd-macro' to call kbd, instead of the other way around.

[-- Attachment #2: 0001-Move-read-kbd-macro-implementation-to-key-in-subr.el.patch --]
[-- Type: text/x-diff, Size: 7876 bytes --]

From aa35959c77e7b2de8f53c5c200057040a8b1aa57 Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefan@marxist.se>
Date: Wed, 13 Oct 2021 01:40:14 +0200
Subject: [PATCH] Move read-kbd-macro implementation to key in subr.el

---
 lisp/subr.el            | 102 +++++++++++++++++++++++++++++++++++++++-
 test/lisp/subr-tests.el |  29 +++++++++++-
 2 files changed, 128 insertions(+), 3 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 805c14eae3..5522d46401 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -937,7 +937,107 @@ kbd
   ;; the calling convention of `kbd'.
   (declare (pure t) (side-effect-free t))
   ;; A pure function is expected to preserve the match data.
-  (save-match-data (read-kbd-macro keys)))
+  (save-match-data
+    (let ((case-fold-search nil)
+          (len (length keys)) ; We won't alter keys in the loop below.
+          (pos 0)
+          (res []))
+      (while (and (< pos len)
+                  (string-match "[^ \t\n\f]+" keys pos))
+        (let* ((word-beg (match-beginning 0))
+               (word-end (match-end 0))
+               (word (substring keys word-beg len))
+               (times 1)
+               key)
+          ;; Try to catch events of the form "<as df>".
+          (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word)
+              (setq word (match-string 0 word)
+                    pos (+ word-beg (match-end 0)))
+            (setq word (substring keys word-beg word-end)
+                  pos word-end))
+          (when (string-match "\\([0-9]+\\)\\*." word)
+            (setq times (string-to-number (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 (match-string 1 word)
+                                           (match-string 3 word)))
+                        (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 "$" keys pos)))
+                (t
+                 (let ((orig-word word) (prefix 0) (bits 0))
+                   (while (string-match "^[ACHMsS]-." word)
+                     (setq bits (+ bits (cdr (assq (aref word 0)
+                                                   '((?A . ?\A-\^@) (?C . ?\C-\^@)
+                                                     (?H . ?\H-\^@) (?M . ?\M-\^@)
+                                                     (?s . ?\s-\^@) (?S . ?\S-\^@))))))
+                     (setq prefix (+ prefix 2))
+                     (setq word (substring word 2)))
+                   (when (string-match "^\\^.$" word)
+                     (setq bits (+ bits ?\C-\^@))
+                     (setq prefix (1+ prefix))
+                     (setq word (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)
+                     (let ((n 0))
+                       (dolist (ch (cdr (string-to-list word)))
+                         (setq n (+ (* n 8) ch -48)))
+                       (setq word (vector n))))
+                   (cond ((= bits 0)
+                          (setq key word))
+                         ((and (= bits ?\M-\^@) (stringp word)
+                               (string-match "^-?[0-9]+$" word))
+                          (setq key (mapcar (lambda (x) (+ x bits))
+                                            (append word nil))))
+                         ((/= (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)
+                               ;; 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
+            (dolist (_ (number-sequence 1 times))
+              (setq res (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 (apply #'vector (reverse (cdr (cdr (reverse (cdr (cdr (append res nil))))))))))
+      (if (let ((ret t))
+            (dolist (ch (append res nil))
+              (unless (and (characterp ch)
+                           (let ((ch2 (logand ch (lognot ?\M-\^@))))
+                             (and (>= ch2 0) (<= ch2 127))))
+                (setq ret nil)))
+            ret)
+          (concat (mapcar (lambda (ch)
+                            (if (= (logand ch ?\M-\^@) 0)
+                                ch (+ ch 128)))
+                          (append res nil)))
+        res))))
 
 (defun undefined ()
   "Beep to tell the user this binding is undefined."
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 32c0bc3ed3..7a89456037 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -87,13 +87,38 @@ subr-test-kbd
   (should (equal (kbd "f") "f"))
   (should (equal (kbd "<f1>") [f1]))
   (should (equal (kbd "RET") "\C-m"))
-  (should (equal (kbd "C-x a") "\C-xa"))
+
+  ;; Modifiers.
+  (should (equal (kbd "C-x a") "\^Xa"))
+  (should (equal (kbd "M-x a") [134217848 97]))
+  (should (equal (kbd "H-x a") [16777336 97]))
+  (should (equal (kbd "s-x a") [8388728 97]))
+  (should (equal (kbd "S-x a") [33554552 97]))
+
+  ;; Special characters.
+  (should (equal (kbd "NUL") "\0"))
+  (should (equal (kbd "LFD") "\n"))
+  (should (equal (kbd "ESC") "\e"))
+  (should (equal (kbd "SPC") "\s"))
+  (should (equal (kbd "DEL") "\^?"))
+  (should (equal (kbd "TAB") "\t"))
+
+  ;; With numbers.
+  (should (equal (kbd "\\000") "\0"))
+  (should (equal (kbd "C-x \\150") "\C-xh"))
+
   ;; Check that kbd handles both new and old style key descriptions
   ;; (bug#45536).
   (should (equal (kbd "s-<return>") [s-return]))
   (should (equal (kbd "<s-return>") [s-return]))
   (should (equal (kbd "C-M-<return>") [C-M-return]))
-  (should (equal (kbd "<C-M-return>") [C-M-return])))
+  (should (equal (kbd "<C-M-return>") [C-M-return]))
+
+  ;; Error.
+  (should-error (kbd "C-xx"))
+
+  ;; These should be equivalent:
+  (should (equal (kbd "\C-xf") (kbd "C-x f"))))
 
 (ert-deftest subr-test-define-prefix-command ()
   (define-prefix-command 'foo-prefix-map)
-- 
2.30.2