emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

scratch/oclosure 5574871ec7 09/25: nadvice.el: Use OClosures rather than


From: Stefan Monnier
Subject: scratch/oclosure 5574871ec7 09/25: nadvice.el: Use OClosures rather than handmade bytecodes
Date: Fri, 31 Dec 2021 15:40:57 -0500 (EST)

branch: scratch/oclosure
commit 5574871ec74b037373f6ddd69460b923e23b9b76
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    nadvice.el: Use OClosures rather than handmade bytecodes
    
    * lisp/emacs-lisp/nadvice.el (advice): New OClosure type.
    (advice--where-alist): Use OClosures.
    (advice--car, advice--cdr, advice--props, advice--where):
    Delete functions, now defined for us by `oclosure-define`.
    (advice--p): Rewrite.
    (advice--make-1): Delete function.
    (advice--make, advice--tweak): Use `advice--copy` instead.
    
    * lisp/emacs-lisp/oclosure.el (oclosure--fix-type): Don't use 
`documentation` to
    avoid bootstrap problems.
    (oclosure-type): Return nil on non-function objects.
    
    * lisp/help.el (help--docstring-quote, help-add-fundoc-usage)
    (help--make-usage, help--make-usage-docstring): Move to `subr.el`.
    
    * lisp/subr.el (docstring--quote, docstring-add-fundoc-usage)
    (docstring--make-usage, docstring--make-usage-docstring): New names for
    functions moved from `help.el` for bootstrap reasons.
    
    * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Use the new names.
---
 lisp/emacs-lisp/cl-macs.el  |  4 +--
 lisp/emacs-lisp/nadvice.el  | 88 ++++++++++++++++++---------------------------
 lisp/emacs-lisp/oclosure.el |  9 +++--
 lisp/help.el                | 52 ++++-----------------------
 lisp/subr.el                | 49 +++++++++++++++++++++++++
 5 files changed, 99 insertions(+), 103 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index d2c2114d13..6bd0d0c328 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -309,11 +309,11 @@ FORM is of the form (ARGS . BODY)."
                       ;; apparently harmless computation, so it should not
                       ;; touch the match-data.
                       (save-match-data
-                        (cons (help-add-fundoc-usage
+                        (cons (docstring-add-fundoc-usage
                                (if (stringp (car header)) (pop header))
                                ;; Be careful with make-symbol and (back)quote,
                                ;; see bug#12884.
-                               (help--docstring-quote
+                               (docstring--quote
                                 (let ((print-gensym nil) (print-quoted t)
                                       (print-escape-newlines t))
                                   (format "%S" (cons 'fn (cl--make-usage-args
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 8fc2986ab4..d86b71d48c 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -42,49 +42,45 @@
 ;; as this one), so we have to do it by hand!
 (push (purecopy '(nadvice 1 0)) package--builtin-versions)
 
+(oclosure-define (advice
+                (:copier advice--copy))
+  car cdr where props)
+
 ;;;; Lightweight advice/hook
 (defvar advice--where-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 ((where :around)) (&rest args)
+                (apply car cdr args)))
+    (:before ,(oclosure-lambda advice ((where :before)) (&rest args)
+                (apply car args) (apply cdr args)))
+    (:after ,(oclosure-lambda advice ((where :after)) (&rest args)
+               (apply cdr args) (apply car args)))
+    (:override ,(oclosure-lambda advice ((where :override)) (&rest args)
+                  (apply car args)))
+    (:after-until ,(oclosure-lambda advice ((where :after-until)) (&rest args)
+                     (or (apply cdr args) (apply car args))))
+    (:after-while ,(oclosure-lambda advice ((where :after-while)) (&rest args)
+                     (and (apply cdr args) (apply car args))))
+    (:before-until ,(oclosure-lambda advice ((where :before-until)) (&rest 
args)
+                     (or (apply car args) (apply cdr args))))
+    (:before-while ,(oclosure-lambda advice ((where :before-while)) (&rest 
args)
+                     (and (apply car args) (apply cdr args))))
+    (:filter-args ,(oclosure-lambda advice ((where :filter-args)) (&rest args)
+                     (apply cdr (funcall cdr args))))
+    (:filter-return ,(oclosure-lambda advice ((where :filter-return)) (&rest 
args)
+                       (funcall car (apply cdr args)))))
   "List of descriptions of how to add a function.
-Each element has the form (WHERE BYTECODE STACK) where:
-  WHERE 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--where-alist))
+Each element has the form (WHERE OCL) where OCL is a \"prototype\"
+function of type `advice'.")
 
 (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))
+  ;; (eq (oclosure-type object) 'advice)
+  (cl-typep object 'advice))
 
 (defun advice--cd*r (f)
   (while (advice--p f)
     (setq f (advice--cdr f)))
   f)
 
-(defun advice--where (f)
-  (let ((bytecode (aref f 1))
-        (where nil))
-    (dolist (elem advice--where-alist)
-      (if (eq bytecode (cadr elem)) (setq where (car elem))))
-    where))
-
 (defun advice--make-single-doc (flist function macrop)
   (let ((where (advice--where flist)))
     (concat
@@ -137,7 +133,7 @@ Each element has the form (WHERE BYTECODE STACK) where:
                         ;; "[Arg list not available until function
                         ;; definition is loaded]", bug#21299
                         (if (stringp arglist) t
-                          (help--make-usage-docstring function arglist)))
+                          (docstring--make-usage-docstring function arglist)))
                     (setq origdoc (cdr usage)) (car usage)))
       (help-add-fundoc-usage (concat origdoc
                                      (if (string-suffix-p "\n" origdoc)
@@ -180,18 +176,6 @@ Each element has the form (WHERE 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))
-
 (defun advice--make (where function main props)
   "Build a function value that adds FUNCTION to MAIN at WHERE.
 WHERE is a symbol to select an entry in `advice--where-alist'."
@@ -201,12 +185,11 @@ WHERE is a symbol to select an entry in 
`advice--where-alist'."
     (if (and md (> fd md))
         ;; `function' should go deeper.
         (let ((rest (advice--make where function (advice--cdr main) props)))
-          (advice--make-1 (aref main 1) (aref main 3)
-                          (advice--car main) rest (advice--props main)))
-      (let ((desc (assq where advice--where-alist)))
-        (unless desc (error "Unknown add-function location `%S'" where))
-        (advice--make-1 (nth 1 desc) (nth 2 desc)
-                        function main props)))))
+          (advice--copy main :cdr rest))
+      (let ((proto (assq where advice--where-alist)))
+        (unless proto (error "Unknown add-function location `%S'" where))
+        (advice--copy (cadr proto)
+                      :car function :cdr main :where where :props props)))))
 
 (defun advice--member-p (function use-name definition)
   (let ((found nil))
@@ -232,8 +215,7 @@ WHERE is a symbol to select an entry in 
`advice--where-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--copy flist :cdr nrest))))))))
 
 ;;;###autoload
 (defun advice--remove-function (flist function)
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 4fafa1ac46..cfc2bed872 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -243,7 +243,8 @@
     ;; stuff it into the environment part of the closure with a special
     ;; marker so we can distinguish this entry from actual variables.
     (cl-assert (eq 'closure (car-safe oclosure)))
-    (let ((typename (documentation oclosure 'raw)))
+    (let ((typename (nth 3 oclosure))) ;; The "docstring".
+      (cl-assert (stringp typename))
       (push (cons :type (intern typename))
             (cadr oclosure))
       oclosure)))
@@ -277,8 +278,10 @@
       (let ((type (and (> (length oclosure) 4) (aref oclosure 4))))
         (if (symbolp type) type))
     (and (eq 'closure (car-safe oclosure))
-         (eq :type (caar (cadr oclosure)))
-         (cdar (cadr oclosure)))))
+         (let* ((env (car-safe (cdr oclosure)))
+                (first-var (car-safe env)))
+           (and (eq :type (car-safe first-var))
+                (cdr first-var))))))
 
 (provide 'oclosure)
 ;;; oclosure.el ends here
diff --git a/lisp/help.el b/lisp/help.el
index 5114ddefba..4773263872 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1944,10 +1944,8 @@ Most of this is done by `help-window-setup', which see."
          (princ msg)))))
 
 
-(defun help--docstring-quote (string)
-  "Return a doc string that represents STRING.
-The result, when formatted by `substitute-command-keys', should equal STRING."
-  (replace-regexp-in-string "['\\`‘’]" "\\\\=\\&" string))
+(define-obsolete-function-alias 'help--docstring-quote
+  #'docstring--quote "29.1")
 
 ;; The following functions used to be in help-fns.el, which is not preloaded.
 ;; But for various reasons, they are more widely needed, so they were
@@ -1987,24 +1985,7 @@ When SECTION is \\='usage or \\='doc, return only that 
part."
       (`usage usage)
       (`doc doc))))
 
-(defun help-add-fundoc-usage (docstring arglist)
-  "Add the usage info to DOCSTRING.
-If DOCSTRING already has a usage info, then just return it unchanged.
-The usage info is built from ARGLIST.  DOCSTRING can be nil.
-ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
-  (unless (stringp docstring) (setq docstring ""))
-  (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
-          (eq arglist t))
-      docstring
-    (concat docstring
-           (if (string-match "\n?\n\\'" docstring)
-               (if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
-             "\n\n")
-           (if (stringp arglist)
-                (if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
-                    (concat "(fn" (match-string 1 arglist) ")")
-                  (error "Unrecognized usage format"))
-             (help--make-usage-docstring 'fn arglist)))))
+(defalias 'help-add-fundoc-usage #'docstring-add-fundoc-usage)
 
 (declare-function subr-native-lambda-list "data.c")
 
@@ -2061,32 +2042,13 @@ the same names as used in the original source code, 
when possible."
     "[Arg list not available until function definition is loaded.]")
    (t t)))
 
-(defun help--make-usage (function arglist)
-  (cons (if (symbolp function) function 'anonymous)
-       (mapcar (lambda (arg)
-                 (cond
-                   ;; Parameter name.
-                   ((symbolp arg)
-                   (let ((name (symbol-name arg)))
-                     (cond
-                       ((string-match "\\`&" name) arg)
-                       ((string-match "\\`_." name)
-                        (intern (upcase (substring name 1))))
-                       (t (intern (upcase name))))))
-                   ;; Parameter with a default value (from
-                   ;; cl-defgeneric etc).
-                   ((and (consp arg)
-                         (symbolp (car arg)))
-                    (cons (intern (upcase (symbol-name (car arg)))) (cdr arg)))
-                   ;; Something else.
-                   (t arg)))
-               arglist)))
+(define-obsolete-function-alias 'help--make-usage
+  #'docstring--make-usage "29.1")
 
 (define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1")
 
-(defun help--make-usage-docstring (fn arglist)
-  (let ((print-escape-newlines t))
-    (help--docstring-quote (format "%S" (help--make-usage fn arglist)))))
+(define-obsolete-function-alias 'help--make-usage-docstring
+  #'docstring--make-usage-docstring "29.1")
 
 
 
diff --git a/lisp/subr.el b/lisp/subr.el
index 9c07606100..b6802b3854 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -6510,6 +6510,55 @@ sentence (see Info node `(elisp) Documentation Tips')."
     (error "Unable to fill string containing newline: %S" string))
   (internal--fill-string-single-line (apply #'format string objects)))
 
+(defun docstring--quote (string)
+  "Return a doc string that represents STRING.
+The result, when formatted by `substitute-command-keys', should equal STRING."
+  (replace-regexp-in-string "['\\`‘’]" "\\\\=\\&" string))
+
+(defun docstring-add-fundoc-usage (docstring arglist)
+  "Add the usage info to DOCSTRING.
+If DOCSTRING already has a usage info, then just return it unchanged.
+The usage info is built from ARGLIST.  DOCSTRING can be nil.
+ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
+  (unless (stringp docstring) (setq docstring ""))
+  (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)
+          (eq arglist t))
+      docstring
+    (concat docstring
+           (if (string-match "\n?\n\\'" docstring)
+               (if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
+             "\n\n")
+           (if (stringp arglist)
+                (if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
+                    (concat "(fn" (match-string 1 arglist) ")")
+                  (error "Unrecognized usage format"))
+             (docstring--make-usage-docstring 'fn arglist)))))
+
+(defun docstring--make-usage (function arglist)
+  (cons (if (symbolp function) function 'anonymous)
+       (mapcar (lambda (arg)
+                 (cond
+                   ;; Parameter name.
+                   ((symbolp arg)
+                   (let ((name (symbol-name arg)))
+                     (cond
+                       ((string-match "\\`&" name) arg)
+                       ((string-match "\\`_." name)
+                        (intern (upcase (substring name 1))))
+                       (t (intern (upcase name))))))
+                   ;; Parameter with a default value (from
+                   ;; cl-defgeneric etc).
+                   ((and (consp arg)
+                         (symbolp (car arg)))
+                    (cons (intern (upcase (symbol-name (car arg)))) (cdr arg)))
+                   ;; Something else.
+                   (t arg)))
+               arglist)))
+
+(defun docstring--make-usage-docstring (fn arglist)
+  (let ((print-escape-newlines t))
+    (docstring--quote (format "%S" (docstring--make-usage fn arglist)))))
+
 (defun json-available-p ()
   "Return non-nil if Emacs has libjansson support."
   (and (fboundp 'json-serialize)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]