[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)
- branch scratch/oclosure created (now de320e2003), Stefan Monnier, 2021/12/31
- scratch/oclosure 5574871ec7 09/25: nadvice.el: Use OClosures rather than handmade bytecodes,
Stefan Monnier <=
- scratch/oclosure f11349ed20 03/25: * lisp/emacs-lisp/cl-generic.el: Use OClosure for `cl-next-method-p`, Stefan Monnier, 2021/12/31
- scratch/oclosure 230617c90c 16/25: lisp/emacs-lisp/oclosure.el: Signal errors for invalid code, Stefan Monnier, 2021/12/31
- scratch/oclosure e052bb2770 04/25: * lisp/kmacro.el: Use OClosure instead of messing with internals, Stefan Monnier, 2021/12/31
- scratch/oclosure ae493f3513 01/25: OClosure: Hybrids between functions and defstructs, Stefan Monnier, 2021/12/31
- scratch/oclosure ae0bfc4f75 05/25: * lisp/loadup.el (oclosure): Load before `nadvice`, Stefan Monnier, 2021/12/31
- scratch/oclosure afa68def26 11/25: cl-print.el: Dispatch on `advice` type, Stefan Monnier, 2021/12/31
- scratch/oclosure fe5457ff75 19/25: oclosure.el (oclosure-lambda): Change calling convention, Stefan Monnier, 2021/12/31
- scratch/oclosure d93b0ad4d4 06/25: (interactive-form, function-docstring): New generic functions, Stefan Monnier, 2021/12/31
- scratch/oclosure a444d85977 08/25: Fix bootstrap problems and various misc issues found along the way, Stefan Monnier, 2021/12/31
- scratch/oclosure f44ee8cd53 17/25: oclosure.el (accessor): New type, Stefan Monnier, 2021/12/31