Move define-keymap and defvar-keymap to keymap.el

These functions deal with the "new" keymap binding interface, so they
belong in keymap.el rather than in subr.el.
* lisp/subr.el (define-keymap--compile, define-keymap)
(defvar-keymap): Move from here ...
* lisp/keymap.el (define-keymap--compile, define-keymap)
(defvar-keymap): ... to here.

1 files changed, 133 insertions, 0 deletions

diff --git a/lisp/keymap.el b/lisp/keymap.el
index a60efe18e14..6feb91a60be 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -452,6 +452,139 @@ If MESSAGE (and interactively), message the result."
       (message "%s is bound to %s globally" keys def))
     def))
 
+
+;;; define-keymap and defvar-keymap
+
+(defun define-keymap--compile (form &rest args)
+  ;; This compiler macro is only there for compile-time
+  ;; error-checking; it does not change the call in any way.
+  (while (and args
+              (keywordp (car args))
+              (not (eq (car args) :menu)))
+    (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
+      (byte-compile-warn "Invalid keyword: %s" (car args)))
+    (setq args (cdr args))
+    (when (null args)
+      (byte-compile-warn "Uneven number of keywords in %S" form))
+    (setq args (cdr args)))
+  ;; Bindings.
+  (while args
+    (let ((key (pop args)))
+      (when (and (stringp key) (not (key-valid-p key)))
+        (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
+    (when (null args)
+      (byte-compile-warn "Uneven number of key bindings in %S" form))
+    (setq args (cdr args)))
+  form)
+
+(defun define-keymap (&rest definitions)
+  "Create a new keymap and define KEY/DEFINITION pairs as key bindings.
+The new keymap is returned.
+
+Options can be given as keywords before the KEY/DEFINITION
+pairs.  Available keywords are:
+
+:full      If non-nil, create a chartable alist (see `make-keymap').
+             If nil (i.e., the default), create a sparse keymap (see
+             `make-sparse-keymap').
+
+:suppress  If non-nil, the keymap will be suppressed (see `suppress-keymap').
+             If `nodigits', treat digits like other chars.
+
+:parent    If non-nil, this should be a keymap to use as the parent
+             (see `set-keymap-parent').
+
+:keymap    If non-nil, instead of creating a new keymap, the given keymap
+             will be destructively modified instead.
+
+:name      If non-nil, this should be a string to use as the menu for
+             the keymap in case you use it as a menu with `x-popup-menu'.
+
+:prefix    If non-nil, this should be a symbol to be used as a prefix
+             command (see `define-prefix-command').  If this is the case,
+             this symbol is returned instead of the map itself.
+
+KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'.  KEY can
+also be the special symbol `:menu', in which case DEFINITION
+should be a MENU form as accepted by `easy-menu-define'.
+
+\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
+  (declare (indent defun)
+           (compiler-macro define-keymap--compile))
+  (let (full suppress parent name prefix keymap)
+    ;; Handle keywords.
+    (while (and definitions
+                (keywordp (car definitions))
+                (not (eq (car definitions) :menu)))
+      (let ((keyword (pop definitions)))
+        (unless definitions
+          (error "Missing keyword value for %s" keyword))
+        (let ((value (pop definitions)))
+          (pcase keyword
+            (:full (setq full value))
+            (:keymap (setq keymap value))
+            (:parent (setq parent value))
+            (:suppress (setq suppress value))
+            (:name (setq name value))
+            (:prefix (setq prefix value))
+            (_ (error "Invalid keyword: %s" keyword))))))
+
+    (when (and prefix
+               (or full parent suppress keymap))
+      (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords"))
+
+    (when (and keymap full)
+      (error "Invalid combination: :keymap with :full"))
+
+    (let ((keymap (cond
+                   (keymap keymap)
+                   (prefix (define-prefix-command prefix nil name))
+                   (full (make-keymap name))
+                   (t (make-sparse-keymap name)))))
+      (when suppress
+        (suppress-keymap keymap (eq suppress 'nodigits)))
+      (when parent
+        (set-keymap-parent keymap parent))
+
+      ;; Do the bindings.
+      (while definitions
+        (let ((key (pop definitions)))
+          (unless definitions
+            (error "Uneven number of key/definition pairs"))
+          (let ((def (pop definitions)))
+            (if (eq key :menu)
+                (easy-menu-define nil keymap "" def)
+              (keymap-set keymap key def)))))
+      keymap)))
+
+(defmacro defvar-keymap (variable-name &rest defs)
+  "Define VARIABLE-NAME as a variable with a keymap definition.
+See `define-keymap' for an explanation of the keywords and KEY/DEFINITION.
+
+In addition to the keywords accepted by `define-keymap', this
+macro also accepts a `:doc' keyword, which (if present) is used
+as the variable documentation string.
+
+\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)"
+  (declare (indent 1))
+  (let ((opts nil)
+        doc)
+    (while (and defs
+                (keywordp (car defs))
+                (not (eq (car defs) :menu)))
+      (let ((keyword (pop defs)))
+        (unless defs
+          (error "Uneven number of keywords"))
+        (if (eq keyword :doc)
+            (setq doc (pop defs))
+          (push keyword opts)
+          (push (pop defs) opts))))
+    (unless (zerop (% (length defs) 2))
+      (error "Uneven number of key/definition pairs: %s" defs))
+    `(defvar ,variable-name
+       (define-keymap ,@(nreverse opts) ,@defs)
+       ,@(and doc (list doc)))))
+
 (provide 'keymap)
 
 ;;; keymap.el ends here