|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
;; This file:
;; http://anggtwu.net/elisp/2025-advice.el.html
;; http://anggtwu.net/elisp/2025-advice.el
;; (find-angg "elisp/2025-advice.el")
;; Author: Eduardo Ochs <eduardoochs@gmail.com>
;;
;; (load (buffer-file-name))
;; (defun e () (interactive) (find-angg "elisp/2025-advice.el"))
;; (find-efunction 'advice-add)
;; (defun deepo (n) (if (zerop n) 0 (list (deepo (1- n)))))
;; (let ((print-level 20)) (cl-print-object (deepo 40) (current-buffer)))
;; (let ((print-level 20)) (find-clprintobject (deepo 40)))
;; (find-clprintobject (deepo 40))
;; See: (find-es "emacs" "dash-threading")
;; (find-eev "eev-blinks.el" "find-clprin1")
;; https://lists.gnu.org/archive/html/help-gnu-emacs/2025-01/msg00101.html
;; (find-angg "elisp/2024dec09-fristed.el")
;; (find-elnode "Index" "* cl-type-of:")
;; (find-elinks-elisp (cl-loop for c in (ee-all-classes) collect `(find-etypedescr ',c)))
;; (find-efunction 'find-eaproposf)
;; (find-kla-intro "8. `cl-loop'")
;; (find-clnode "For Clauses" "for VAR being the symbols [of OBARRAY]")
(defun ee-all-classes ()
(ee-sort-symbols
(cl-loop for sym being the symbols
when (cl-find-class sym)
collect sym)))
(defun adt-insert (&rest args) (insert (format "\n;; --> %S" args)))
(defun adt-1 (o) (adt-insert ':1 o) (list 'adt-1 o))
(defun adt-2 (o) (adt-insert ':2 o) (list 'adt-2 o))
(defun adt-3 (o) (adt-insert ':3 o) (list 'adt-3 o))
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
(setq adt-o (symbol-function 'adt-2))
;; (find-2a nil '(find-clprin1ind o))
(setq my-all-classes
(cl-loop for sym being the symbols
when (cl-find-class sym)
collect sym))
;; -> (flycheck-error lisp-indent-state ...)
;; (find-clprin1ind o)
;; Orig: (find-efile "emacs-lisp/nadvice.el" "(cl-defmethod cl-print-object")
;; Test: (find-2a nil '(find-clprin1ind adt-o))
(cl-defmethod cl-print-object ((object advice) stream)
(cl-assert (advice--p object))
(princ "#f(advice :car " stream)
(cl-print-object (advice--car object) stream)
(princ " :how• " stream)
(cl-print-object (advice--how object) stream)
(princ " :cdr " stream)
(cl-print-object (advice--cdr object) stream)
(let ((props (advice--props object)))
(princ " :props " stream)
(cl-print-object props stream))
(princ ")" stream))
;; Orig: (find-efunctiondescr 'cl-print-object "advice" "nadvice.")
;; (find-etype-links 'advice)
;; (find-efile "emacs-lisp/nadvice.el" "(cl-defmethod cl-print-object")
(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))
(cl-defmethod cl-print-object ((object advice) stream)
(cl-assert (advice--p object))
(princ "#f(advice :car " stream)
(cl-print-object (advice--car object) stream)
(princ " :how " stream)
(princ (advice--how object) stream)
(princ " :cdr " stream)
(cl-print-object (advice--cdr object) stream)
(let ((props (advice--props object)))
(when props
(princ " " stream)
(cl-print-object props stream)))
(princ ")" stream))
;; (find-clprin1ind o)
(advice--how object)
(advice--how o)
;;
(defun adt-insert (&rest args) (insert (format "\n;; --> %S" args)))
(defun adt-1 (o) (adt-insert ':1 o) (list 'adt-1 o))
(defun adt-2 (o) (adt-insert ':2 o) (list 'adt-2 o))
(defun adt-3 (o) (adt-insert ':3 o) (list 'adt-3 o))
(adt-2 20)
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
(adt-2 20)
(advice-remove 'adt-2 'adt-1)
(advice-remove 'adt-2 'adt-3)
(adt-2 20)
(setq o (symbol-function 'adt-2))
(cl-prin1-to-string o)
(find-clprin1 o)
(defun adt-insert (&rest args) (insert (format "\n;; --> %S" args)))
(defun adt-1 (o) (adt-insert ':1 o) (list 'adt-1 o))
(defun adt-2 (o) (adt-insert ':2 o) (list 'adt-2 o))
(defun adt-3 (o) (adt-insert ':3 o) (list 'adt-3 o))
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
(setq o (symbol-function 'adt-2))
(cl-prin1-to-string o)
;; --> #f(advice adt-3 :after #f(advice adt-1 :before (lambda (o) (adt-insert ':2 o) (list 'adt-2 o))))
;; See: (find-efile "emacs-lisp/nadvice.el" "(oclosure-define (advice")
;; (find-efunction 'find-eppma)
;;
(find-eppma '
(oclosure-define (advice
(:predicate advice--p)
(:copier advice--cons (cdr))
(:copier advice--copy (car cdr how props)))
car cdr how props)
)
(find-eppma '
(cl--define-built-in-type closure (function)
"Abstract type of functions represented by a vector-like object.
You can access the object's internals with `aref'.
The fields are used as follows:
0 [args] Argument list (either a list or an integer)
1 [code] Either a byte-code string or a list of Lisp forms
2 [constants] Either vector of constants or a lexical environment
3 [stackdepth] Maximum amount of stack depth used by the byte-code
4 [docstring] The documentation, or a reference to it
5 [iform] The interactive form (if present)")
)
(find-eppma '
(defun foo (o) "Docstring" (interactive) 42)
)
(advice--car (symbol-function 'adt-2))
(cl-prin1-to-string (symbol-function 'adt-2))
(oclosure-type (symbol-function 'adt-2))
(cl-describe-type 'advice)
(cl-describe-type 'oclosure-accessor)
(setq o2 (oclosure--copy oclosure--accessor-prototype nil 'advice 'car 0))
(oclosure-type o2)
(cl-describe-type 'oclosure-accessor)
(find-epp o2)
(find-clprin1 o2)
(cl-type-of o2)
(find-estruct o2)
(find-eppma '
(oclosure-define accessor
"OClosure function to access a specific slot of an object."
type slot)
)
:•
kl
(find-eaproposf "closure-")
(oclosure--p o)
(advice--p o)
(setq ee-nl nil)
(setq ee-nl '(!))
(setq ee-nl :nl)
(defun ee-advice-expand (o)
(if (advice--p o)
(let* ((car (advice--car o))
(cdr (advice--cdr o))
(how (advice--how o))
(props (advice--props o)))
`((:how ,how) ,@ee-nl
(:props ,props) ,@ee-nl
(:car ,car) ,@ee-nl
(:cdr ,(ee-advice-expand cdr))))
(ee-closure-to-lambda o)))
(find-estring (ee-S (ee-advice-expand o)))
:❗
:nl
;; (setq str "(defun foo ()\n(interactive)\n42)")
;; (ee-indent-as-elisp str)
;; (find-estring-elisp (ee-indent-as-elisp str))
(defun ee-indent-as-elisp (str)
(with-temp-buffer
(emacs-lisp-mode)
(insert str)
(indent-region (point-min) (point-max))
(ee-no-properties (buffer-substring (point-min) (point-max)))))
;; Skel: (find-let*-macro-links "indent" "o" "s1 s2 s3 s4")
(defmacro ee-let*-macro-indent (o &rest code)
"An internal function used by `find-indent-links'."
`(let* ((o ,o)
(s1 (ee-S o))
(s2 (replace-regexp-in-string "!" "\n" s1))
(s3 (replace-regexp-in-string " +" " " s2))
(s4 (replace-regexp-in-string "\n +" "\n" s3))
(s5 (replace-regexp-in-string " +\n" "\n" s4))
(s6 (ee-indent-as-elisp s5)))
,@code))
(ee-let*-macro-indent (ee-advice-expand o) (find-estring-elisp s4))
(ee-let*-macro-indent (ee-advice-expand o) (find-estring-elisp s6))
(cl-type-of o)
(mark-whole-buffer
(find-eaproposf "with-.*buffer")
(find-eaproposf "buffer")
prin1-to-string
(find-eppp (ee-advice-expand o))
(find-epp (ee-advice-expand o))
(find-eppp (ee-advice-expand (symbol-function 'adt-2)))
((:how :after)
(:props nil)
(:car adt-3)
(:cdr ((:how :before)
(:props nil)
(:car adt-1)
(:cdr (lambda (o) (adt-insert ':2 o) (list 'adt-2 o))))))
cdr how props
# (find-efunction 'advice--cd*r)
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
;; (find-hfunction 'adt-2)
;; (find-hfunction 'adt-3)
;; (find-hfunction 'eek)
(find-efunctionpp 'adt-2)
(find-efunctionpp 'adt-3)
(adt-2)
(cl-loop for (a b) in '((1 2) (3 4))
collect a)
(cl-loop for (a b . rest) on (symbol-plist symbol)
collect (list a b)))
(defun ee-plist-to-conses (plist)
(cl-loop for (a b . rest) on plist by 'cddr
collect (list a b)))
;; Test: (find-epp (ee-symbol-plist 'adt-2))
;; See: (find-kla-intro "8. `cl-loop'" "by 'cddr")
(defun ee-symbol-plist (symbol)
(ee-sort-pairs
(cl-loop for (a b . rest) on (symbol-plist symbol) by 'cddr
collect (list a b))))
(cl-loop for (x y . rest) on '(a b c d e f) by 'cddr
collect (list x y rest))
(aref o 3)
(aref o 3)
o
(cl-type-of o)
;;
(advice--p o)
;; (find-eaproposf "advice")
(advice--car o)
(advice--cdr o)
(advice--how o)
(advice--props o)
(load "nadvice")
(--> "def" (concat "abc" it "ghi"))
;; (find-eaproposf "cl.*type")
;; (find-eaproposf "ee-symbol")
;; (find-eaproposf "byte-code-function")
(find-epp o)
;; (find-dashnode "Threading macros")
(--> "def" (concat "abc" it "ghi"))
;; (adt-2 20)
;; (advice-add 'adt-2 :before 'adt-1)
;; (advice-add 'adt-2 :after 'adt-3)
;; (adt-2 20)
;; (advice-remove 'adt-2 'adt-1)
;; (advice-remove 'adt-2 'adt-3)
;; (adt-2 20)
(defun adt-insert (&rest args) (insert (format "\n;; --> %S" args)))
(defun adt-1 (o) (adt-insert ':1 o) (list 'adt-1 o))
(defun adt-2 (o) (adt-insert ':2 o) (list 'adt-2 o))
(defun adt-3 (o) (adt-insert ':3 o) (list 'adt-3 o))
(adt-2 20)
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
(adt-2 20)
(advice-remove 'adt-2 'adt-1)
(advice-remove 'adt-2 'adt-3)
(adt-2 20)
(advice-add 'adt-2 :around 'adt-1)
(adt-2 20)
(advice-remove 'adt-2 'adt-3)
(defun adt-a (r) (adt-insert ':a o) o)
(advice-add 'adt-2 :after 'adt-3)
if we execute each line with our favorite variant of C-e C-x C-e -
including the lines in ";;"s, that I will treat as test in comments -
then the middle `(adt-2 20)' inserts this:
;; --> (:1 20)
;; --> (:2 20)
;; --> (:3 20)
then the `advice-remove's remove the advices, and the last `(adt-2 20)'
inserts just this:
;; --> (:2 20)
Question
========
How do I inspect the advices in `adt-2' _from Lisp_?
If I run this,
(advice-add 'adt-2 :before 'adt-1)
(advice-add 'adt-2 :after 'adt-3)
(describe-function 'adt-2)
the description includes these lines,
This function has :after advice: `adt-3'.
This function has :before advice: `adt-1'.
but I tried to single-step through `describe-function' and
`describe-function-1' with edebug, and I found that the lines
above were generated by this call:
(documentation 'adt-2 t)
but `documentation' is implemented in C, and
(symbol-function 'adt-2)
returns something whose format I don't understand...
Any hints?
Thanks in advance,
Eduardo Ochs
http://anggtwu.net/#eev
;; (adt-2 20)
;; (advice-add 'adt-2 :after 'adt-1)
;; (find-efunctionpp 'adt-2)
;; (find-efunctiondescr 'adt-2)
;; (find-efunctiondescr 'adt-2)
(defun find-efunction-eek (f keys)
(find-2a nil `(progn (find-efunction ',f '(eek ,keys))))
keys)
(defun find-edebug-yes (f) (find-efunction-eek f "C-u C-M-x"))
(defun find-edebug-no (f) (find-efunction-eek f "C-M-x"))
;; (find-edebug-yes 'describe-function)
;; (find-edebug-no 'describe-function)
;; (find-edebug-yes 'describe-function-1)
;; (find-edebug-no 'describe-function-1)
;; (find-edebug-yes 'documentation)
;; (find-edebug-no 'documentation)
;; (find-efunctiondescr 'adt-2)
;; (help-fns--analyze-function function)
;; help-fns--analyze-function
;; (documentation function t)
;; (documentation 'adt-2 t)
;; (advice-remove 'adt-2 'adt-1)
;; (find-efunctionpp 'adt-2)
The fields are used as follows:
0 [args] Argument list (either a list or an integer)
1 [code] Either a byte-code string or a list of Lisp forms
2 [constants] Either vector of constants or a lexical environment
3 [stackdepth] Maximum amount of stack depth used by the byte-code
4 [docstring] The documentation, or a reference to it
5 [iform] The interactive form (if present)" (#s(built-in-class function "Abstract supertype of function values." (#s(built-in-class atom "Abstract supertype of anything but cons cells." (#s(built-in-class t "Abstract supertype of everything." nil nil nil)) nil nil)) nil nil)) nil nil)) nil nil)
;; (find-efile "emacs-lisp/cl-preloaded.el" "(cl--define-built-in-type closure")
;; Local Variables:
;; coding: utf-8-unix
;; End: