scratch/fcr 463e621: * lisp/kmacro.el: Use FCR instead of messing with internals

[Stefan Monnier]

branch: scratch/fcr
commit 463e621c29c9e236e538a2b4e9be1da2976c9c7e
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/kmacro.el: Use FCR instead of messing with internals
    
    * test/lisp/progmodes/elisp-mode-tests.el
    (xref-elisp-generic-co-located-default): Silence warnings.
    
    * test/lisp/kmacro-tests.el (kmacro-tests--cl-print): New test.
    
    * lisp/kmacro.el (kmacro-function): New FCR type.
    (kmacro-lambda-form): Use it.
    (kmacro-extract-lambda, kmacro-p): Simplify/rewrite accordingly.
    (cl-print-object): New method.
    
    * lisp/emacs-lisp/fcr.el (fcr-make): Keep interactive specs before the
    function's code.
    
    * lisp/edmacro.el (edmacro-finish-edit): Prefer `kmacro-p`.
---
 lisp/edmacro.el                         |  2 +-
 lisp/emacs-lisp/fcr.el                  |  8 +++++
 lisp/kmacro.el                          | 60 +++++++++++++++++++--------------
 test/lisp/kmacro-tests.el               |  5 +++
 test/lisp/progmodes/elisp-mode-tests.el |  5 ++-
 5 files changed, 53 insertions(+), 27 deletions(-)

diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 29900a9..be92cd0 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -260,7 +260,7 @@ or nil, use a compact 80-column format."
                          (push key keys)
                          (let ((b (key-binding key)))
                            (and b (commandp b) (not (arrayp b))
-                                (not (kmacro-extract-lambda b))
+                                (not (kmacro-p b))
                                 (or (not (fboundp b))
                                     (not (or (arrayp (symbol-function b))
                                              (get b 'kmacro))))
diff --git a/lisp/emacs-lisp/fcr.el b/lisp/emacs-lisp/fcr.el
index 112fdbd..dd9687b 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -143,6 +143,7 @@
            parent-names))
          (slotdescs (append
                      parent-slots
+                     ;; FIXME: Catch duplicate slot names.
                      (mapcar (lambda (field)
                                (cl--make-slot-descriptor field nil nil
                                                          '((:read-only . t))))
@@ -190,6 +191,7 @@
   ;; FIXME: Provide the fields in the order specified by `type'.
   (let* ((class (cl--find-class type))
          (slots (fcr--class-slots class))
+         (prebody '())
          (slotbinds (nreverse
                      (mapcar (lambda (slot)
                                (list (cl--slot-descriptor-name slot)))
@@ -208,6 +210,11 @@
                              (setcdr bind (list temp))
                              (cons temp (cdr field)))))))
                      fields)))
+    ;; FIXME: Since we use the docstring internally to store the
+    ;; type we can't handle actual docstrings.  We could fix this by adding
+    ;; a docstring slot to FCRs.
+    (while (memq (car-safe (car-safe body)) '(interactive declare))
+      (push (pop body) prebody))
     ;; FIXME: Optimize temps away when they're provided in the right order!
     ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left
     ;; uninitialized"!
@@ -221,6 +228,7 @@
          (fcr--fix-type
           (lambda ,args
             (:documentation ',type)
+            ,@prebody
             ;; Add dummy code which accesses the field's vars to make sure
             ;; they're captured in the closure.
             (if t nil ,@(mapcar #'car fields))
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 3f492a8..211f0ab 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -811,6 +811,10 @@ If kbd macro currently being defined end it before 
activating it."
 ;; letters and digits, provided that we inhibit the keymap while
 ;; executing the macro later on (but that's controversial...)
 
+(fcr-defstruct kmacro-function
+  "Function form of keyboard macros."
+  mac)
+
 ;;;###autoload
 (defun kmacro-lambda-form (mac &optional counter format)
   "Create lambda form for macro bound to symbol or key."
@@ -819,34 +823,40 @@ If kbd macro currently being defined end it before 
activating it."
   ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT).
   ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit',
   ;; while the second is used from within this file.
-  (let ((mac (if counter (list mac counter format) mac)))
-    ;; FIXME: This should be a "funcallable struct"!
-    (lambda (&optional arg)
-      "Keyboard macro."
-      ;; We put an "unused prompt" as a special marker so
-      ;; `kmacro-extract-lambda' can see it's "one of us".
-      (interactive "pkmacro")
-      (if (eq arg 'kmacro--extract-lambda)
-          (cons 'kmacro--extract-lambda mac)
-        (kmacro-exec-ring-item mac arg)))))
+  (fcr-make kmacro-function ((mac (if counter (list mac counter format) mac)))
+            (&optional arg)
+    (interactive "p")
+    (kmacro-exec-ring-item mac arg)))
 
 (defun kmacro-extract-lambda (mac)
   "Extract kmacro from a kmacro lambda form."
-  (let ((mac (cond
-              ((eq (car-safe mac) 'lambda)
-               (let ((e (assoc 'kmacro-exec-ring-item mac)))
-                 (car-safe (cdr-safe (car-safe (cdr-safe e))))))
-              ((and (functionp mac)
-                    (equal (interactive-form mac) '(interactive "pkmacro")))
-               (let ((r (funcall mac 'kmacro--extract-lambda)))
-                 (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r)))))))
-    (and (consp mac)
-         (= (length mac) 3)
-         (arrayp (car mac))
-         mac)))
-
-(defalias 'kmacro-p #'kmacro-extract-lambda
-  "Return non-nil if MAC is a kmacro keyboard macro.")
+  (when (kmacro-p mac)
+    (let ((mac (kmacro-function--mac mac)))
+      (and (consp mac)
+           (= (length mac) 3)
+           (arrayp (car mac))
+           mac))))
+
+(defun kmacro-p (x)
+  "Return non-nil if MAC is a kmacro keyboard macro."
+  (cl-typep x 'kmacro-function))
+
+(cl-defmethod cl-print-object ((object kmacro-function) stream)
+  (princ "#<kmacro " stream)
+  (require 'macros)
+  (declare-function macros--insert-vector-macro "macros" (definition))
+  (pcase-let ((`(,vecdef ,counter ,format)
+               (kmacro-extract-lambda object)))
+    (princ
+     (with-temp-buffer
+       (macros--insert-vector-macro vecdef)
+       (buffer-string))
+     stream)
+    (princ " " stream)
+    (prin1 counter stream)
+    (princ " " stream)
+    (prin1 format stream)
+    (princ ">" stream)))
 
 (defun kmacro-bind-to-key (_arg)
   "When not defining or executing a macro, offer to bind last macro to a key.
diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el
index ecd3d5f..51108e0 100644
--- a/test/lisp/kmacro-tests.el
+++ b/test/lisp/kmacro-tests.el
@@ -825,6 +825,11 @@ This is a regression for item 7 in Bug#24991."
                                 :macro-result "x")
     (kmacro-tests-simulate-command '(beginning-of-line))))
 
+(ert-deftest kmacro-tests--cl-print ()
+  (should (equal (cl-prin1-to-string
+                  (kmacro-lambda-form [?a ?b backspace backspace] 0 "%d"))
+                 "#<kmacro [?a ?b backspace backspace] 0 \"%d\">")))
+
 (cl-defun kmacro-tests-run-step-edit
     (macro &key events sequences result macro-result)
   "Set up and run a test of `kmacro-step-edit-macro'.
diff --git a/test/lisp/progmodes/elisp-mode-tests.el 
b/test/lisp/progmodes/elisp-mode-tests.el
index 9dc5e8c..b6161c3 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -449,12 +449,15 @@ to (xref-elisp-test-descr-to-target xref)."
   ;; dispatching code.
   )
 
-(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2)
+(cl-defgeneric xref-elisp-generic-co-located-default (_arg1 _arg2)
   "Doc string generic co-located-default."
   "co-located default")
 
 (cl-defmethod xref-elisp-generic-co-located-default ((this 
xref-elisp-root-type) arg2)
   "Doc string generic co-located-default xref-elisp-root-type."
+  ;; The test needs the above line to contain "this" and "arg2"
+  ;; without underscores, so we silence the warning with `ignore'.
+  (ignore this arg2)
   "non-default for co-located-default")
 
 (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2)