master f30625943e 4/5: nadvice.el: Use OClosures

[Stefan Monnier]

branch: master
commit f30625943edefbd88ebf84acbc254ed88db27beb
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    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           |  21 -------
 lisp/emacs-lisp/nadvice.el            | 108 +++++++++++++++++-----------------
 test/lisp/emacs-lisp/nadvice-tests.el |   9 +++
 3 files changed, 64 insertions(+), 74 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 457ef506bc..30d7e6525a 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/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)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index be6eafd1b6..efc345c62c 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/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)
-    (:before "\300\301\002\"\210\300\302\002\"\207" 4)
-    (:after "\300\302\002\"\300\301\003\"\210\207" 5)
-    (:override "\300\301\002\"\207" 4)
-    (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4)
-    (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4)
-    (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4)
-    (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4)
-    (:filter-args "\300\302\301\003!\"\207" 5)
-    (:filter-return "\301\300\302\003\"!\207" 5))
+  `((:around ,(oclosure-lambda (advice (how :around)) (&rest args)
+                (apply car cdr args)))
+    (:before ,(oclosure-lambda (advice (how :before)) (&rest args)
+                (apply car args) (apply cdr args)))
+    (:after ,(oclosure-lambda (advice (how :after)) (&rest args)
+               (apply cdr args) (apply car args)))
+    (:override ,(oclosure-lambda (advice (how :override)) (&rest args)
+                  (apply car args)))
+    (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args)
+                     (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:
-  HOW is a keyword indicating where the function is added.
-  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))
+Each element has the form (HOW OCL) where HOW is a keyword and
+OCL is a \"prototype\" function of type `advice'.")
 
 (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."
-  (let ((adv-sig (gethash main advertised-signature-table))
-        (advice
-         (apply #'make-byte-code 128 byte-code
-                (vector #'apply function main props) stack-depth nil
-                (and (or (commandp function) (commandp main))
-                     (list (advice--make-interactive-form
-                            function main))))))
-    (when adv-sig (puthash advice adv-sig advertised-signature-table))
-    advice))
+
+(cl-defmethod oclosure-interactive-form ((ad advice) &optional _)
+  (let ((car (advice--car ad))
+        (cdr (advice--cdr ad)))
+    (when (or (commandp car) (commandp cdr))
+      `(interactive ,(advice--make-interactive-form car cdr)))))
+
+(cl-defmethod cl-print-object ((object advice) stream)
+  (cl-assert (advice--p object))
+  (princ "#f(advice " stream)
+  (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--car main) rest (advice--props main)))
-      (let ((desc (assq how advice--how-alist)))
-        (unless desc (error "Unknown add-function location `%S'" how))
-        (advice--make-1 (nth 1 desc) (nth 2 desc)
-                        function main props)))))
+          (advice--cons main rest))
+      (let ((proto (assq how advice--how-alist)))
+        (unless proto (error "Unknown add-function location `%S'" how))
+        (advice--copy (cadr proto)
+                      function main how 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)
-                              first nrest props))))))))
+              (advice--cons flist nrest))))))))
 
 ;;;###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:
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el 
b/test/lisp/emacs-lisp/nadvice-tests.el
index 1185bee447..a675986b90 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/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: