From 5574871ec74b037373f6ddd69460b923e23b9b76 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 18 Dec 2021 10:28:57 -0500 Subject: [PATCH] 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 d2c2114d139..6bd0d0c3283 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 8fc2986ab41..d86b71d48cc 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 4fafa1ac46d..cfc2bed8729 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 5114ddefba1..4773263872d 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 9c07606100b..b6802b3854f 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) -- 2.39.2