;; as this one), so we have to do it by hand!
(push (purecopy '(nadvice 1 0)) package--builtin-versions)
+(fcr-defstruct (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 ,(fcr-lambda advice ((where :around)) (&rest args)
+ (apply car cdr args)))
+ (:before ,(fcr-lambda advice ((where :before)) (&rest args)
+ (apply car args) (apply cdr args)))
+ (:after ,(fcr-lambda advice ((where :after)) (&rest args)
+ (apply cdr args) (apply car args)))
+ (:override ,(fcr-lambda advice ((where :override)) (&rest args)
+ (apply car args)))
+ (:after-until ,(fcr-lambda advice ((where :after-until)) (&rest args)
+ (or (apply cdr args) (apply car args))))
+ (:after-while ,(fcr-lambda advice ((where :after-while)) (&rest args)
+ (and (apply cdr args) (apply car args))))
+ (:before-until ,(fcr-lambda advice ((where :before-until)) (&rest args)
+ (or (apply car args) (apply cdr args))))
+ (:before-while ,(fcr-lambda advice ((where :before-while)) (&rest args)
+ (and (apply car args) (apply cdr args))))
+ (:filter-args ,(fcr-lambda advice ((where :filter-args)) (&rest args)
+ (apply cdr (funcall cdr args))))
+ (:filter-return ,(fcr-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 FCR) where FCR 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 (fcr-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
;; "[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)
`(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'."
(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))
(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)
(princ msg)))))
\f
-(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
(`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")
"[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")
\f
(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)
projects / emacs.git / commitdiff