nadvice.el: Use OClosures

* lisp/emacs-lisp/nadvice.el (advice): New OClosure type.
(advice--how-alist): Make it hold prototype OClosures rather
than bytecode strings.
(advice--bytecodes): Delete var.
(advice--where): Make it an obsolete alias of new `advice--how`.
(oclosure-interactive-form, cl-print-object) <advice>: New methods.
(advice--make-1): Delete function.
(advice--make): Use `advice-copy` and `advice-cons`.
(advice--tweak): Use `advice-cons`.
(add-function, advice-add): Rename `where` arg to `how`.

* lisp/emacs-lisp/cl-print.el (cl-print-object) <:extra "nadvice">:
Remove now-redundant ad-hoc method.

* test/lisp/emacs-lisp/nadvice-tests.el (advice-test-print): New test.

lisp/emacs-lisp/cl-print.el

@@ -221,27 +221,6 @@ into a button whose action shows the function's disassembly.")
                             'byte-code-function object)))))
   (princ ")" stream))
 
-;; This belongs in nadvice.el, of course, but some load-ordering issues make it
-;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
-;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
-;; can't use cl-defmethod.
-(cl-defmethod cl-print-object :extra "nadvice"
-              ((object compiled-function) stream)
-  (if (not (advice--p object))
-      (cl-call-next-method)
-    (princ "#f(advice-wrapper " stream)
-    (when (fboundp 'advice--how)
-      (princ (advice--how object) stream)
-      (princ " " stream))
-    (cl-print-object (advice--cdr object) stream)
-    (princ " " stream)
-    (cl-print-object (advice--car object) stream)
-    (let ((props (advice--props object)))
-      (when props
-        (princ " " stream)
-        (cl-print-object props stream)))
-    (princ ")" stream)))
-
 ;; This belongs in oclosure.el, of course, but some load-ordering issues make it
 ;; complicated.
 (cl-defmethod cl-print-object ((object accessor) stream)

lisp/emacs-lisp/nadvice.el

@@ -42,36 +42,37 @@
 ;; as this one), so we have to do it by hand!
 (push (purecopy '(nadvice 1 0)) package--builtin-versions)
 
+(oclosure-define (advice
+                  (:predicate advice--p)
+                  (:copier advice--cons (cdr))
+                  (:copier advice--copy (car cdr how props)))
+  car cdr how props)
+
 ;;;; Lightweight advice/hook
 (defvar advice--how-alist
-  '((:around "\300\301\302\003#\207" 5)
+  `((:around ,(oclosure-lambda (advice (how :around)) (&rest args)
-    (:before "\300\301\002\"\210\300\302\002\"\207" 4)
+                (apply car cdr args)))
-    (:after "\300\302\002\"\300\301\003\"\210\207" 5)
+    (:before ,(oclosure-lambda (advice (how :before)) (&rest args)
-    (:override "\300\301\002\"\207" 4)
+                (apply car args) (apply cdr args)))
-    (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
+    (:after ,(oclosure-lambda (advice (how :after)) (&rest args)
-    (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
+               (apply cdr args) (apply car args)))
-    (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
+    (:override ,(oclosure-lambda (advice (how :override)) (&rest args)
-    (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
+                  (apply car args)))
-    (:filter-args "\300\302\301\003!\"\207" 5)
+    (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args)
-    (:filter-return "\301\300\302\003\"!\207" 5))
+                     (or (apply cdr args) (apply car args))))
+    (:after-while ,(oclosure-lambda (advice (how :after-while)) (&rest args)
+                     (and (apply cdr args) (apply car args))))
+    (:before-until ,(oclosure-lambda (advice (how :before-until)) (&rest args)
+                      (or (apply car args) (apply cdr args))))
+    (:before-while ,(oclosure-lambda (advice (how :before-while)) (&rest args)
+                      (and (apply car args) (apply cdr args))))
+    (:filter-args ,(oclosure-lambda (advice (how :filter-args)) (&rest args)
+                     (apply cdr (funcall car args))))
+    (:filter-return ,(oclosure-lambda (advice (how :filter-return)) (&rest args)
+                       (funcall car (apply cdr args)))))
   "List of descriptions of how to add a function.
-Each element has the form (HOW BYTECODE STACK) where:
+Each element has the form (HOW OCL) where HOW is a keyword and
-  HOW is a keyword indicating where the function is added.
+OCL is a \"prototype\" function of type `advice'.")
-  BYTECODE is the corresponding byte-code that will be used.
-  STACK is the amount of stack space needed by the byte-code.")
-
-(defvar advice--bytecodes (mapcar #'cadr advice--how-alist))
-
-(defun advice--p (object)
-  (and (byte-code-function-p object)
-       (eq 128 (aref object 0))
-       (memq (length object) '(5 6))
-       (memq (aref object 1) advice--bytecodes)
-       (eq #'apply (aref (aref object 2) 0))))
-
-(defsubst advice--car   (f) (aref (aref f 2) 1))
-(defsubst advice--cdr   (f) (aref (aref f 2) 2))
-(defsubst advice--props (f) (aref (aref f 2) 3))
 
 (defun advice--cd*r (f)
   (while (advice--p f)
@@ -79,12 +80,6 @@ Each element has the form (HOW BYTECODE STACK) where:
   f)
 
 (define-obsolete-function-alias 'advice--where #'advice--how "29.1")
-(defun advice--how (f)
-  (let ((bytecode (aref f 1))
-        (how nil))
-    (dolist (elem advice--how-alist)
-      (if (eq bytecode (cadr elem)) (setq how (car elem))))
-    how))
 
 (defun advice--make-single-doc (flist function macrop)
   (let ((how (advice--how flist)))
@@ -181,17 +176,26 @@ Each element has the form (HOW BYTECODE STACK) where:
         `(funcall ',fspec ',(cadr ifm))
       (cadr (or iff ifm)))))
 
-(defun advice--make-1 (byte-code stack-depth function main props)
+
-  "Build a function value that adds FUNCTION to MAIN."
+(cl-defmethod oclosure-interactive-form ((ad advice) &optional _)
-  (let ((adv-sig (gethash main advertised-signature-table))
+  (let ((car (advice--car ad))
-        (advice
+        (cdr (advice--cdr ad)))
-         (apply #'make-byte-code 128 byte-code
+    (when (or (commandp car) (commandp cdr))
-                (vector #'apply function main props) stack-depth nil
+      `(interactive ,(advice--make-interactive-form car cdr)))))
-                (and (or (commandp function) (commandp main))
+
-                     (list (advice--make-interactive-form
+(cl-defmethod cl-print-object ((object advice) stream)
-                            function main))))))
+  (cl-assert (advice--p object))
-    (when adv-sig (puthash advice adv-sig advertised-signature-table))
+  (princ "#f(advice " stream)
-    advice))
+  (cl-print-object (advice--car object) stream)
+  (princ " " stream)
+  (princ (advice--how object) stream)
+  (princ " " stream)
+  (cl-print-object (advice--cdr object) stream)
+  (let ((props (advice--props object)))
+    (when props
+      (princ " " stream)
+      (cl-print-object props stream)))
+  (princ ")" stream))
 
 (defun advice--make (how function main props)
   "Build a function value that adds FUNCTION to MAIN at HOW.
@@ -202,12 +206,11 @@ HOW is a symbol to select an entry in `advice--how-alist'."
     (if (and md (> fd md))
         ;; `function' should go deeper.
         (let ((rest (advice--make how function (advice--cdr main) props)))
-          (advice--make-1 (aref main 1) (aref main 3)
+          (advice--cons main rest))
-                          (advice--car main) rest (advice--props main)))
+      (let ((proto (assq how advice--how-alist)))
-      (let ((desc (assq how advice--how-alist)))
+        (unless proto (error "Unknown add-function location `%S'" how))
-        (unless desc (error "Unknown add-function location `%S'" how))
+        (advice--copy (cadr proto)
-        (advice--make-1 (nth 1 desc) (nth 2 desc)
+                      function main how props)))))
-                        function main props)))))
 
 (defun advice--member-p (function use-name definition)
   (let ((found nil))
@@ -233,8 +236,7 @@ HOW is a symbol to select an entry in `advice--how-alist'."
         (if val (car val)
           (let ((nrest (advice--tweak rest tweaker)))
             (if (eq rest nrest) flist
-              (advice--make-1 (aref flist 1) (aref flist 3)
+              (advice--cons flist nrest))))))))
-                              first nrest props))))))))
 
 ;;;###autoload
 (defun advice--remove-function (flist function)
@@ -286,7 +288,7 @@ different, but `function-equal' will hopefully ignore those differences.")
   ;; :before-until is like add-hook on run-hook-with-args-until-success.
   ;; Same with :after-* but for (add-hook ... 'append).
   "Add a piece of advice on the function stored at PLACE.
-FUNCTION describes the code to add.  HOW describes where to add it.
+FUNCTION describes the code to add.  HOW describes how to add it.
 HOW can be explained by showing the resulting new function, as the
 result of combining FUNCTION and the previous value of PLACE, which we
 call OLDFUN here:

test/lisp/emacs-lisp/nadvice-tests.el

@@ -204,6 +204,15 @@ function being an around advice."
     (remove-function (var sm-test10) sm-advice)
     (should (equal (funcall sm-test10 5) 15))))
 
+(ert-deftest advice-test-print ()
+  (let ((x (list 'cdr)))
+    (add-function :after (car x) 'car)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice car :after cdr)"))
+    (add-function :before (car x) 'first)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice first :before #f(advice car :after cdr))"))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: