├── cl-advice.asd ├── cl-advice-tests.asd ├── package.lisp ├── tests.lisp ├── README.org ├── LICENSE └── cl-advice.lisp /cl-advice.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-advice.asd 2 | 3 | (asdf:defsystem #:cl-advice 4 | :description "Portable advice for Common Lisp" 5 | :author "szos at posteo dot net" 6 | :license "LGPL" 7 | :version "1.1.1" 8 | :serial t 9 | :depends-on (#:closer-mop) 10 | :components ((:file "package") 11 | (:file "cl-advice")) 12 | :in-order-to ((asdf:test-op (asdf:test-op :cl-advice-tests)))) 13 | -------------------------------------------------------------------------------- /cl-advice-tests.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-advice-tests.asd 2 | 3 | (asdf:defsystem #:cl-advice-tests 4 | :description "Tests for cl-advice" 5 | :author "szos at posteo dot net" 6 | :license "LGPL" 7 | :version "0.0.1" 8 | :serial t 9 | :depends-on (#:cl-advice #:fiveam) 10 | :components ((:file "tests")) 11 | :perform (asdf:test-op (op c) 12 | (uiop:symbol-call :cl-advice-tests :run-tests))) 13 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:cl-advice 4 | (:use #:cl) 5 | (:export #:advisable-function-p 6 | #:make-advisable 7 | #:make-unadvisable 8 | #:ensure-advisable-function 9 | #:ensure-unadvisable-function 10 | #:with-implicit-conversion 11 | #:with-unadvisable-function 12 | 13 | #:advisable-lambda 14 | #:defun-advisable 15 | 16 | #:*allow-implicit-conversion* 17 | 18 | #:define-advisory-functions 19 | #:add-advice 20 | #:replace-advice 21 | #:list-advice 22 | #:remove-advice 23 | #:remove-nth-advice 24 | 25 | #:implicit-conversion-to-advisable-function 26 | #:circular-advice-dependency)) 27 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-advice-tests 2 | (:use :cl :fiveam) 3 | (:import-from :cl-advice 4 | #:defun-advisable 5 | #:advisable-function-p 6 | #:make-advisable 7 | #:make-unadvisable 8 | #:add-advice 9 | #:remove-advice 10 | #:replace-advice) 11 | (:export :run-tests)) 12 | 13 | (in-package :cl-advice-tests) 14 | 15 | (defun run-tests () 16 | (fiveam:run! 'cl-advice-test-suite)) 17 | 18 | (def-suite* cl-advice-test-suite) 19 | 20 | (defun foutput (fun &rest args) 21 | (with-output-to-string (*standard-output*) 22 | (apply fun args))) 23 | 24 | (defun-advisable advisable-main () 25 | (format t "main.")) 26 | 27 | (defun main () 28 | (format t "main.")) 29 | 30 | (defun before () 31 | (format t "before.")) 32 | 33 | (defun after () 34 | (format t "after.")) 35 | 36 | (defun around (next) 37 | (format t "begin.") 38 | (funcall next) 39 | (format t "end.")) 40 | 41 | (defun before1 () 42 | (format t "before1.")) 43 | 44 | (def-test advice-tests () 45 | (is (string= (foutput 'advisable-main) "main.") "Advisable function") 46 | (is (advisable-function-p (symbol-function 'advisable-main)) "Is advisable") 47 | 48 | (is (string= (foutput 'main) "main.") "Without advice") 49 | (is (not (advisable-function-p (symbol-function 'main))) "Not advisable") 50 | 51 | (signals cl-advice:implicit-conversion-to-advisable-function 52 | (cl-advice:with-implicit-conversion (:disallowed) 53 | (add-advice :before 'main 'before)) 54 | "Add advice to non advisable fails") 55 | 56 | (make-advisable 'main) 57 | (is (advisable-function-p (symbol-function 'main)) "Is advisable") 58 | 59 | (is (string= (foutput 'main) "main.") "Eval after advisable") 60 | 61 | (add-advice :before 'main 'before) 62 | 63 | (is (string= (foutput 'main) "before.main.") "Before advice") 64 | 65 | (add-advice :before 'main 'before1) 66 | (is (string= (foutput 'main) "before1.before.main.") "Add before advice again") 67 | 68 | (replace-advice :before 'main 'before1 'before) 69 | (is (string= (foutput 'main) "before.before.main.") "Replace before advice") 70 | 71 | (remove-advice :before 'main 'before) 72 | (remove-advice :before 'main 'before1) 73 | 74 | (is (string= (foutput 'main) "main.") "After remove :before advice") 75 | 76 | (add-advice :after 'main 'after) 77 | (is (string= (foutput 'main) "main.after.") "After advice") 78 | 79 | (remove-advice :after 'main 'after) 80 | (is (string= (foutput 'main) "main.") "After remove :after advice") 81 | 82 | (add-advice :around 'main 'around) 83 | (is (string= (foutput 'main) "begin.main.end.") "Around advice") 84 | 85 | (remove-advice :around 'main 'around) 86 | (is (string= (foutput 'main) "main.") "After remove :around advice") 87 | 88 | ;; all advices 89 | (add-advice :before 'main 'before) 90 | (add-advice :after 'main 'after) 91 | (add-advice :around 'main 'around) 92 | 93 | (is (string= (foutput 'main) "before.begin.main.end.after.") "All advices") 94 | 95 | (make-unadvisable 'main) 96 | 97 | (is (string= (foutput 'main) "main.") "After make-unadvisable") 98 | (is (not (advisable-function-p (symbol-function 'main)))) 99 | ) 100 | 101 | (defun main-args (x y) 102 | (format t "main~a." (list x y))) 103 | 104 | (defun before-args (x y) 105 | (format t "before~a." (list x y))) 106 | 107 | (defun after-args (x y) 108 | (format t "after~a." (list x y))) 109 | 110 | (defun around-args (next x y) 111 | (format t "begin~a." (list x y)) 112 | (funcall next x y) 113 | (format t "end.")) 114 | 115 | (defun before1-args (x y) 116 | (format t "before1~a." (list x y))) 117 | 118 | 119 | (def-test advice-args-tests () 120 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "Without advice") 121 | (is (not (advisable-function-p (symbol-function 'main-args))) "Not advisable") 122 | 123 | (signals cl-advice:implicit-conversion-to-advisable-function 124 | (cl-advice:with-implicit-conversion (:disallowed) 125 | (add-advice :before 'main-args 'before-args)) 126 | "Add advice to non advisable fails") 127 | 128 | (make-advisable 'main-args) 129 | (is (advisable-function-p (symbol-function 'main-args)) "Is advisable") 130 | 131 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "Eval after advisable") 132 | 133 | (add-advice :before 'main-args 'before-args) 134 | 135 | (is (string= (foutput 'main-args 'x 'y) "before(X Y).main(X Y).") "Before advice") 136 | 137 | (add-advice :before 'main-args 'before1-args) 138 | (is (string= (foutput 'main-args 'x 'y) "before1(X Y).before(X Y).main(X Y).") "Add before advice again") 139 | 140 | (replace-advice :before 'main-args 'before1-args 'before-args) 141 | (is (string= (foutput 'main-args 'x 'y) "before(X Y).before(X Y).main(X Y).") "Replace before advice") 142 | 143 | (remove-advice :before 'main-args 'before-args) 144 | (remove-advice :before 'main-args 'before1-args) 145 | 146 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "After remove :before advice") 147 | 148 | (add-advice :after 'main-args 'after-args) 149 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).after(X Y).") "After advice") 150 | 151 | (remove-advice :after 'main-args 'after-args) 152 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "After remove :after advice") 153 | 154 | (add-advice :around 'main-args 'around-args) 155 | (is (string= (foutput 'main-args 'x 'y) "begin(X Y).main(X Y).end.") "Around advice") 156 | 157 | (remove-advice :around 'main-args 'around-args) 158 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "After remove :around advice") 159 | 160 | ;; all advices 161 | (add-advice :before 'main-args 'before-args) 162 | (add-advice :after 'main-args 'after-args) 163 | (add-advice :around 'main-args 'around-args) 164 | 165 | (is (string= (foutput 'main-args 'x 'y) "before(X Y).begin(X Y).main(X Y).end.after(X Y).") "All advices") 166 | 167 | (make-unadvisable 'main-args) 168 | 169 | (is (string= (foutput 'main-args 'x 'y) "main(X Y).") "After make-unadvisable") 170 | (is (not (advisable-function-p (symbol-function 'main-args))))) 171 | 172 | (defun values-main (a b) 173 | (values a b)) 174 | 175 | (defun values-before (a b) 176 | (format t "Before(~A ~A)" a b)) 177 | 178 | (defun values-after (a b) 179 | (format t "After(~A ~A)" a b)) 180 | 181 | (defun values-around (next a b) 182 | (multiple-value-list (funcall next a b))) 183 | 184 | (def-test advice-multiple-values () 185 | (is (string= (foutput 'values-main 'a 'b) "") "Without advice") 186 | (is (equal (multiple-value-list (values-main 'a 'b)) (list 'a 'b)) 187 | "Check unadvised return value") 188 | 189 | (make-advisable 'values-main :arguments '(a b)) 190 | 191 | (is (advisable-function-p #'values-main) "Is advisable") 192 | 193 | (add-advice :around 'values-main 'values-around) 194 | 195 | (is (equal (values-main 'a 'b) (list 'a 'b)) 196 | "Around advice modifies return value") 197 | 198 | (add-advice :before 'values-main 'values-before) 199 | (add-advice :after 'values-main 'values-after) 200 | 201 | 202 | (is (string= (foutput 'values-main 'a 'b) "Before(A B)After(A B)") 203 | "Eval after adding before/after advice") 204 | 205 | (make-unadvisable 'values-main) 206 | 207 | (is (not (advisable-function-p #'values-main)) "Is unadvisable")) 208 | 209 | (defun circular-a () 210 | (format t "circular-a.")) 211 | 212 | (defun circular-b () 213 | (format t "circular-b.")) 214 | 215 | (defun circular-c () 216 | (format t "circular-c.")) 217 | 218 | (defun circular-d () 219 | (format t "circular-d.")) 220 | 221 | (def-test advice-circular-dependency-test () 222 | (mapc #'(lambda (f) 223 | (make-advisable f :arguments '())) 224 | '(circular-a circular-b circular-c circular-d)) 225 | 226 | (add-advice :before 'circular-a 'circular-b) 227 | (add-advice :before 'circular-b 'circular-c) 228 | (add-advice :before 'circular-c 'circular-d) 229 | (signals cl-advice:circular-advice-dependency 230 | (add-advice :before 'circular-d 'circular-a)) 231 | (signals cl-advice:circular-advice-dependency 232 | (add-advice :around 'circular-d 'circular-a)) 233 | (signals cl-advice:circular-advice-dependency 234 | (add-advice :after 'circular-d 'circular-a)) 235 | (mapc #'(lambda (f) 236 | (make-unadvisable f)) 237 | '(circular-a circular-b circular-c circular-d))) 238 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: CL-ADVICE 2 | 3 | A lightweight and portable system for advising functions in Common Lisp. 4 | 5 | * Description 6 | ~CL-ADVICE~ implements a new function type which carries with it slots for 7 | before, around, and after advice. Functions can be defined as advisable, 8 | existing functions not within a locked package can be converted to advisable 9 | functions, and advisable functions can be converted to regular functions. 10 | 11 | ** Types of Advice 12 | Pieces of advice are functions which get called before, after, or around the 13 | main function. Generally speaking, its a good idea to define advice functions 14 | as named functions and add it as a symbol and not a function object. This 15 | makes removing advice easier, and allows the advised function to use the new 16 | definition should the advice function be recompiled. Additionally, while 17 | installing anonymous functions as advice is allowed, removing anonymous 18 | function advice requires knowing where in the advice list it lies, or holding 19 | a reference to the anonymous function object. 20 | *** Before and After Advice 21 | Before and After advice must have an argument list that is compatible with 22 | the main function. Two argument lists are considered compatible if they can 23 | both be applied to the same arguments. These advice functions are looped 24 | through and called in order. 25 | *** Around Advice 26 | Around advice must take the next function to be called as its first 27 | argument, and all following arguments must be compatible with the main 28 | functions argument list. Around advice is unique in that it has control over 29 | whether or not the next function will be called. The next function may be 30 | the main function, or the next piece of around advice. 31 | 32 | * Usage 33 | This system is used primarily through the functions ~make-advisable~, 34 | ~defun-advisable~, ~add-advice~, ~replace-advice~, and ~remove-advice~. For 35 | more information, see the docstrings of the functions and macros exported in 36 | =package.lisp=. 37 | 38 | ** Making Functions Advisable 39 | When making functions advisable, the original function object is wrapped in a 40 | funcallable object which has a dispatch function as its main function. This 41 | conversion is done through the function ~make-advisable~. By default, 42 | functions are converted to be advisable implicitly, through the function 43 | ~ensure-advisable-function~. This is controlled by the dynamic variable 44 | ~*allow-implicit-conversion*~, and can be enabled or disabled for a body of 45 | code through the macro ~with-implicit-conversion~. If conversion 46 | 47 | *** ~MAKE-ADVISABLE~ 48 | This function creates an advisable function object and, if the function to 49 | make advisable is a symbol, rebinds the symbol-function to this new 50 | function. In addition it defines a dispatcher function for the advisable 51 | function object. 52 | 53 | When defining the dispatch function all care will be taken to preserve the 54 | original argument list, however this isnt guaranteed. The function 55 | ~make-advisable~ has a compiler macro defined for it which will define the 56 | dispatcher function with correct arguments if they are provided. However a 57 | compiler macro may not always be called. For this reason the argument 58 | ~force-use-arguments~ is provided which forces generation of a dispach 59 | function with the correct argument list by using ~eval~. 60 | 61 | ** Redefining functions 62 | The macro ~defun-advisable~ copies existing advice if and only if the 63 | function has the same argument list (as compared by ~equal~). 64 | 65 | ** Example: ~TRACE~ 66 | We can implement ~trace~ in terms of ~:around~ advice like so: 67 | #+BEGIN_SRC lisp 68 | (defpackage :tracer 69 | (:use :cl :cl-advice)) 70 | 71 | (in-package :tracer) 72 | 73 | (defun make-simple-tracer (&optional (sym 'unknown-function)) 74 | (let ((inc 0)) 75 | (lambda (next-fn &rest args) 76 | (let ((string (make-string inc :initial-element #\space))) 77 | (format t "~&~A~A: Calling ~A with arguments ~A~%" 78 | string inc sym args) 79 | (incf inc) 80 | (let ((result (apply next-fn args))) 81 | (decf inc) 82 | (format t "~&~A~A: ~A returned ~A~%" 83 | string inc sym result) 84 | result))))) 85 | 86 | (defun-advisable fib (n) 87 | (if (< n 2) 88 | n 89 | (+ (fib (- n 1)) (fib (- n 2))))) 90 | 91 | (add-advice :around 'fib (make-simple-tracer 'fib)) 92 | #+END_SRC 93 | 94 | The result of this is that when ~fib~ is called, the following will be 95 | printed to standard output: 96 | #+BEGIN_SRC lisp 97 | TRACER> (fib 1) 98 | 0: Calling FIB with arguments (1) 99 | 0: FIB returned 1 100 | 1 101 | TRACER> (fib 5) 102 | 0: Calling FIB with arguments (5) 103 | 1: Calling FIB with arguments (4) 104 | 2: Calling FIB with arguments (3) 105 | 3: Calling FIB with arguments (2) 106 | 4: Calling FIB with arguments (1) 107 | 4: FIB returned 1 108 | 4: Calling FIB with arguments (0) 109 | 4: FIB returned 0 110 | 3: FIB returned 1 111 | 3: Calling FIB with arguments (1) 112 | 3: FIB returned 1 113 | 2: FIB returned 2 114 | 2: Calling FIB with arguments (2) 115 | 3: Calling FIB with arguments (1) 116 | 3: FIB returned 1 117 | 3: Calling FIB with arguments (0) 118 | 3: FIB returned 0 119 | 2: FIB returned 1 120 | 1: FIB returned 3 121 | 1: Calling FIB with arguments (3) 122 | 2: Calling FIB with arguments (2) 123 | 3: Calling FIB with arguments (1) 124 | 3: FIB returned 1 125 | 3: Calling FIB with arguments (0) 126 | 3: FIB returned 0 127 | 2: FIB returned 1 128 | 2: Calling FIB with arguments (1) 129 | 2: FIB returned 1 130 | 1: FIB returned 2 131 | 0: FIB returned 5 132 | 5 (3 bits, #x5, #o5, #b101) 133 | #+END_SRC 134 | 135 | * Documentation 136 | 137 | ** Function ~ADVISABLE-FUNCTION-P~ 138 | *advisable-function-p* /function/ 139 | 140 | Returns T if /function/ is an advisable function. 141 | 142 | - Arguments and Values 143 | - /function/ - a object 144 | 145 | ** Function ~MAKE-ADVISABLE~ 146 | *make-advisable* /symbol/ &key /arguments force-use-arguments/ 147 | 148 | Converts a function to an advisable function. If /symbol/ is a symbol, then 149 | the function denoted by it is converted and the ~symbol-function~ of /symbol/ 150 | is set to the new advisable function. If /symbol/ is a function object it is 151 | converted to an advisable function and returned. 152 | 153 | When /arguments/ is provided and the call is being compiled, a compiler macro 154 | will generate a dispatcher function with this argument list. If the call is 155 | not being compiled or the compiler macro is not triggered then a generic 156 | dispatcher argument list is used. 157 | 158 | When /force-use-arguments/ is T and the compiler macro is not triggered, 159 | ~eval~ is used to generate a dispatcher function that uses /arguments/ for 160 | its argument list. 161 | 162 | - Arguments and Values 163 | - /symbol/ - a symbol denoting a function or a function object 164 | - /arguments/ - the argument list of /symbol/ 165 | - /force-use-arguments/ - When T force the usage of /arguments/ for the 166 | advisable function dispatcher function. 167 | 168 | ** Function ~MAKE-UNADVISABLE~ 169 | *make-unadvisable* /symbol/ 170 | 171 | Convert an advisable function to be unadvisable. If /symbol/ is a symbol then 172 | the function referred to by /symbol/ is converted to be unadvisable and 173 | /symbol/ has its ~symbol-function~ rebound to this function. If /symbol/ is a 174 | function object the unadvisable function is returned. 175 | 176 | - Arguments and Values 177 | - /symbol/ - a symbol or function to convert to be unadvisable 178 | 179 | ** Function ~ENSURE-ADVISABLE-FUNCTION~ 180 | *ensure-advisable-function* /symbol/ &optional /arguments force-use-arguments/ 181 | 182 | Returns an advisable function or signals an error. If /symbol/ denotes an 183 | unadvisable function and ~*allow-implicit-conversion*~ is T then /symbol/ is 184 | converted via ~make-advisable~. If ~*allow-implicit-conversion*~ is NIL, then 185 | an error of type ~implicit-conversion-to-advisable-function~ is signalled 186 | with two restarts established around it. These restarts are ~allow-conversion~, 187 | which converts the function, and ~return-value~, which takes a value to 188 | return. When called interactively the return-value restart reads and 189 | evaluates a value from the user. 190 | 191 | When implicitly converting a function to be advisable, /arguments/ and 192 | /force-use-arguments/ are passed to ~make-advisable~. 193 | 194 | - Arguments and Values 195 | - /symbol/ - a symbol or function object 196 | - /arguments/ - a argument list 197 | - /force-use-arguments/ - a true or false value 198 | 199 | ** Function ~ENSURE-UNADVISABLE-FUNCTION~ 200 | *ensure-unadvisable-function* /symbol/ 201 | 202 | Calls ~make-unadvisable~ on /symbol/ and return an unadvisable function. 203 | 204 | - Arguments and Values 205 | - /symbol/ - a symbol or function object 206 | 207 | ** Macro ~WITH-IMPLICIT-CONVERSION~ 208 | *with-implicit-conversion* (/allow-or-not/ &optional /abort-on-implicit-conversion return-on-abort/) &body /body/ 209 | 210 | Binds the variable ~*allow-implicit-conversion*~ to T or NIL based upon 211 | whether /allow-or-not/ is ~eql~ to ~:allowed~, where /allow-or-not/ is 212 | evaluated at runtime. If /abort-on-implicit-conversion/ is true (at 213 | macroexpansion time) then if ~implicit-conversion-to-advisable-function~ is 214 | signalled then control leaves /body/ immediately, and /return-on-abort/ is 215 | returned. 216 | 217 | ** Macro ~ADVISABLE-LAMBDA~ 218 | *advisable-lambda* /argslist/ &body /body/ 219 | 220 | Functions the same as ~lambda~, but returns an advisable function object. 221 | 222 | - Arguments and Values 223 | - /argslist/ - a function argument list 224 | - /body/ - A function body 225 | 226 | ** Macro ~DEFUN-ADVISABLE~ 227 | *defun-advisable* /name argslist/ &body /body/ 228 | 229 | Functions the same as ~defun~ but defines an advisable function. 230 | 231 | - Arguments and Values 232 | - /name/ - an unquoted symbol denoting the name for the function 233 | - /argslist/ - a function argument list 234 | - /body/ - A function body 235 | 236 | ** Dynamic Variable ~*ALLOW-IMPLICIT-CONVERSION*~ 237 | Variable with the default value of T. When T, allow 238 | ~ensure-advisable-function~ to implicitly convert unadvisable functions to be 239 | advisable. When NIL, signal an error when attempting to implicitly convert an 240 | unadvisable function. 241 | 242 | ** Function ~ADD-ADVICE~ 243 | *add-advice* /where function advice-function/ &key /allow-duplicates test from-end/ 244 | 245 | Advise /function/ with /advice-function/. If /allow-duplicates/ is NIL, test 246 | for duplicates using /test/. 247 | 248 | - Arguments and Values 249 | - /where/ - a keyword denoting the kind of advice /advice-function/ 250 | is. Must be one of ~:before~, ~:after~, or ~:around~. 251 | - /function/ - a symbol or function object 252 | - /advice-function/ - the advice function to install. 253 | - /allow-duplicates/ - a true or false value. When true duplicate advice is 254 | allowed. 255 | - /test/ - a function to compare pieces of advice. Used when 256 | /allow-duplicates/ is NIL 257 | - /from-end/ - Determines where to add the advice in its appropriate advice 258 | list. When T add the advice at the end of the advice list, when NIL add 259 | it at the beginning. 260 | 261 | ** Function ~REPLACE-ADVICE~ 262 | *replace-advice* /where function old-advice new-advice/ &key /test if-not-found/ 263 | 264 | Replace a piece of advice. 265 | 266 | - Arguments and Values 267 | - /where/ - a symbol denoting the type of advice to replace, one of 268 | ~:before~, ~:around~, or ~:after~ 269 | - /function/ - the function to replace the advice for 270 | - /old-advice/ - the advice to replace 271 | - /new-advice/ - the advice to replace /old-advice/ with 272 | - /test/ - a function to compare advice 273 | - /if-not-found/ - A keyword denoting what to do if /old-advice/ isnt 274 | found. Must be one of ~:prepend~, ~:append~, or NIL. 275 | 276 | ** Function ~LIST-ADVICE~ 277 | *list-advice* /fn/ &key /type print/ 278 | 279 | Lists advice for /fn/. 280 | 281 | - Arguments and Values 282 | - /fn/ - a function to print advice for 283 | - /type/ - a keyword denoting what kind of advice to list. Must be one of 284 | ~:all~, ~:before~, ~:around~, or ~:after~. 285 | - /print/ - when true print all advice to standard output. 286 | 287 | ** Function ~REMOVE-ADVICE~ 288 | *remove-advice* /type fn advice/ &key /test/ 289 | 290 | Remove /advice/ from /fn/. 291 | 292 | - Arguments and Values 293 | - /type/ - a keyword denoting which advice list to remove /advice/ 294 | from. Must be one of ~:before~, ~:around~, or ~:after~. 295 | - /fn/ - a symbol or function object 296 | - /advice/ - the piece of advice to remove. Must be a symbol, function, or 297 | the keyword ~:all~. 298 | - /test/ - a function to compare pieces of advice 299 | 300 | ** Function ~REMOVE-NTH-ADVICE~ 301 | *remove-nth-advice* /type fn nth/ 302 | 303 | Remove the /nth/ element of advice from /type/ advice list for /fn/. 304 | 305 | - Arguments and Values 306 | - /type/ - a keyword denoting which advice list to remove the /nth/ 307 | from. Must be one of ~:before~, ~:after~, or ~:around~. 308 | - /fn/ - the function to remove the advice from 309 | - /nth/ - the element to remove 310 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | [This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | 460 | How to Apply These Terms to Your New Libraries 461 | 462 | If you develop a new library, and you want it to be of the greatest 463 | possible use to the public, we recommend making it free software that 464 | everyone can redistribute and change. You can do so by permitting 465 | redistribution under these terms (or, alternatively, under the terms of the 466 | ordinary General Public License). 467 | 468 | To apply these terms, attach the following notices to the library. It is 469 | safest to attach them to the start of each source file to most effectively 470 | convey the exclusion of warranty; and each file should have at least the 471 | "copyright" line and a pointer to where the full notice is found. 472 | 473 | 474 | Copyright (C) 475 | 476 | This library is free software; you can redistribute it and/or 477 | modify it under the terms of the GNU Lesser General Public 478 | License as published by the Free Software Foundation; either 479 | version 2.1 of the License, or (at your option) any later version. 480 | 481 | This library is distributed in the hope that it will be useful, 482 | but WITHOUT ANY WARRANTY; without even the implied warranty of 483 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 484 | Lesser General Public License for more details. 485 | 486 | You should have received a copy of the GNU Lesser General Public 487 | License along with this library; if not, write to the Free Software 488 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 489 | USA 490 | 491 | Also add information on how to contact you by electronic and paper mail. 492 | 493 | You should also get your employer (if you work as a programmer) or your 494 | school, if any, to sign a "copyright disclaimer" for the library, if 495 | necessary. Here is a sample; alter the names: 496 | 497 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 498 | library `Frob' (a library for tweaking knobs) written by James Random 499 | Hacker. 500 | 501 | , 1 April 1990 502 | Ty Coon, President of Vice 503 | 504 | That's all there is to it! 505 | -------------------------------------------------------------------------------- /cl-advice.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cl-advice.lisp 2 | 3 | (in-package #:cl-advice) 4 | 5 | ;;;;;;;;;;;;;; 6 | ;;; Macros ;;; 7 | ;;;;;;;;;;;;;; 8 | 9 | (defmacro when-let1 ((var form) &body body) 10 | `(let ((,var ,form)) 11 | (when ,var 12 | ,@body))) 13 | 14 | (defmacro with-gensyms (syms &body body) 15 | `(let ,(mapcar (lambda (sym) 16 | `(,sym (gensym ,(symbol-name sym)))) 17 | syms) 18 | ,@body)) 19 | 20 | ;;;;;;;;;;;;;;; 21 | ;;; Utility ;;; 22 | ;;;;;;;;;;;;;;; 23 | 24 | (eval-when (:compile-toplevel :load-toplevel :execute) 25 | (defun argument-list-to-apply-list (argslist) 26 | "This function is for use a macroexpansion time. It takes an ordinary lambda 27 | list and parses it into code to generate a list suitable for use with apply" 28 | ;; This is ugly, and uses recursion - CL spec does not specify TCO. 29 | (labels ((mkword (symbol) (intern (symbol-name symbol) :keyword)) 30 | (parse-&optional (args accum) 31 | (typecase (car args) 32 | ((member &rest &key &aux) 33 | (case (car args) 34 | (&rest (reverse (cons (cadr args) accum))) 35 | (&key (parse-&key (cdr args) accum)) 36 | (&aux (reverse accum)))) 37 | (cons 38 | (case (length (car args)) 39 | ((1 2) (parse-&optional (cdr args) 40 | (cons (list 'list (caar args)) 41 | accum))) 42 | (3 (reverse (cons (list 'when (caddar args) 43 | (cons 'append 44 | (cons (list 'list (caar args)) 45 | (parse-&optional (cdr args) nil)))) 46 | accum))))) 47 | (null (reverse accum)) 48 | (symbol (parse-&optional (cdr args) 49 | (cons (list 'list (car args)) 50 | accum))))) 51 | (parse-&key (args accum) 52 | (typecase (car args) 53 | ((or null (member &aux)) (reverse accum)) 54 | (cons (case (length (car args)) 55 | ((1 2) 56 | (parse-&key (cdr args) 57 | (cons (list 'list (mkword (caar args)) 58 | (caar args)) 59 | accum))) 60 | (3 61 | (parse-&key (cdr args) 62 | (cons (list 'when (caddar args) 63 | (list 'list (mkword (caar args)) 64 | (caar args))) 65 | accum))))) 66 | (symbol (parse-&key (cdr args) 67 | (cons (list 'list (mkword (car args)) 68 | (car args)) 69 | accum))))) 70 | (parse (args accum) 71 | (case (car args) 72 | (&optional (parse-&optional (cdr args) accum)) 73 | (&rest (reverse (cons (cadr args) accum))) 74 | (&key (parse-&key (cdr args) accum)) 75 | (&aux (reverse accum)) 76 | (otherwise 77 | (if (and (symbolp (car args)) 78 | (not (null (car args)))) 79 | (parse (cdr args) (cons (list 'list (car args)) accum)) 80 | (reverse accum)))))) 81 | (cons 'append (parse argslist nil)))) 82 | 83 | (defun generate-ignore-declarations (argument-list) 84 | (labels ((collect-aux (arglist accum) 85 | (if (null arglist) 86 | accum 87 | (let ((arg (car arglist))) 88 | (if (atom arg) 89 | (collect-aux (cdr arglist) (cons arg accum)) 90 | (collect-aux (cdr arglist) (cons (car arg) accum)))))) 91 | (collect-keys (arglist accum) 92 | (if (null arglist) 93 | accum 94 | (let ((arg (car arglist))) 95 | (cond ((atom arg) 96 | (case arg 97 | (&aux (collect-aux (cddr arglist) accum)) 98 | (&allow-other-keys (collect-aux (cddr arglist) accum)) 99 | (t (collect-keys (cdr arglist) (cons arg accum))))) 100 | ((cddr arg) 101 | (collect-keys (cdr arglist) 102 | (cons (car arg) 103 | (cons (caddr arg) 104 | accum)))) 105 | (t (collect-keys (cdr arglist) 106 | (cons (car arg) accum))))))) 107 | (collect-after-rest (arglist) 108 | (let ((arg (car arglist))) 109 | (case arg 110 | (&key (collect-keys (cdr arglist) nil)) 111 | (&aux (collect-aux (cdr arglist) nil)) 112 | (otherwise nil)))) 113 | (parse (arglist) 114 | (let ((rest (member '&rest arglist))) 115 | (when rest 116 | (collect-after-rest (cddr rest)))))) 117 | (unless (eql argument-list :not-provided) 118 | (let ((ignoring (parse argument-list))) 119 | (when ignoring 120 | `((declare (ignore ,@ignoring))))))))) 121 | 122 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 123 | ;;; The Advisable Function Class ;;; 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | 126 | (defclass advisable-function () 127 | ((arglist :initarg :arguments 128 | :accessor advisable-function-arguments) 129 | (main :accessor advisable-function-main) 130 | (before :initarg :before 131 | :accessor advisable-function-before 132 | :initform nil) 133 | (around :initarg :around 134 | :accessor advisable-function-around 135 | :initform nil) 136 | (after :initarg :after 137 | :accessor advisable-function-after 138 | :initform nil)) 139 | (:metaclass c2mop:funcallable-standard-class)) 140 | 141 | (define-condition advisable-function-initialization-error (error) 142 | ((advisable-function :initarg :advisable-function 143 | :reader 144 | advisable-function-initialization-error-advisable-function) 145 | (main-function :initarg :function 146 | :reader advisable-function-initialization-error-function)) 147 | (:report 148 | (lambda (c s) 149 | (format s 150 | "Expected a normal function when initializing object ~A, but got ~A" 151 | (advisable-function-initialization-error-advisable-function c) 152 | (advisable-function-initialization-error-function c))))) 153 | 154 | ;; Define a documentation method for advisable function objects which returns 155 | ;; the documentation of all functions except the dispatcher 156 | (macrolet 157 | ((document-advisable-function (obj) 158 | `(labels ((document-function (fn) 159 | (documentation fn 'function)) 160 | (write-adv (s fnlist) 161 | (if fnlist 162 | (progn 163 | (terpri s) 164 | (mapcar (lambda (fn) 165 | (format s "~A~%~A~&~%" 166 | fn (document-function fn))) 167 | fnlist)) 168 | (progn 169 | (write-string " No Advice" s) 170 | (terpri s))))) 171 | (with-output-to-string (s) 172 | (write-string (or (document-function (advisable-function-main ,obj)) 173 | "No documentation for main function") 174 | s) 175 | (format s "~&~%[FROM CL-ADVICE] This function is advised with the following advice:~%~%") 176 | (write-string "[BEFORE]" s) 177 | (write-adv s (advisable-function-before ,obj)) 178 | (write-string "[AROUND]" s) 179 | (write-adv s (advisable-function-around ,obj)) 180 | (write-string "[AFTER] " s) 181 | (write-adv s (advisable-function-after ,obj)))))) 182 | (defmethod cl:documentation ((obj advisable-function) (doctype (eql t))) 183 | (document-advisable-function obj)) 184 | (defmethod cl:documentation ((obj advisable-function) (doctype (eql 'function))) 185 | (document-advisable-function obj))) 186 | 187 | (defmethod initialize-instance :around 188 | ((obj advisable-function) &key main &allow-other-keys) 189 | "Normalize the function being advised to be a function object" 190 | (let ((normalized-main (typecase main 191 | (symbol (symbol-function main)) 192 | (otherwise main)))) 193 | (if (and (functionp normalized-main) 194 | (not (typep normalized-main 'advisable-function))) 195 | (progn 196 | (setf (slot-value obj 'main) normalized-main) 197 | (call-next-method)) 198 | (error 'advisable-function-initialization-error 199 | :function main 200 | :advisable-function obj)))) 201 | 202 | (defmethod initialize-instance :after 203 | ((obj advisable-function) 204 | &key dispatcher-generator force-accurate-dispatcher-arglist &allow-other-keys) 205 | "Set the funcallable instance function. 206 | 207 | If DISPATCHER-GENERATOR is provided it must be a function of arity one which 208 | will be passed the advisable function object and must return a dispatcher 209 | function. 210 | 211 | Otherwise if FORCE-ACCURATE-DISPATCHER-ARGLIST is T and arguments were provided, 212 | then EVAL is used to generate a dispatcher function with the correct argument 213 | list. 214 | 215 | Otherwise a generic dispatcher is used which takes a rest argument." 216 | (c2mop:set-funcallable-instance-function 217 | obj 218 | (cond (dispatcher-generator 219 | (funcall dispatcher-generator obj)) 220 | ((and force-accurate-dispatcher-arglist 221 | (not (eql (advisable-function-arguments obj) :not-provided))) 222 | (eval `(lambda ,(advisable-function-arguments obj) 223 | "Advisable function dispatcher" 224 | ,@(generate-ignore-declarations 225 | (advisable-function-arguments obj)) 226 | (let ((fixed ,(argument-list-to-apply-list 227 | (advisable-function-arguments obj)))) 228 | (apply-before ,obj fixed) 229 | (multiple-value-prog1 (apply-around ,obj fixed) 230 | (apply-after ,obj fixed)))))) 231 | (t (lambda (&rest arguments) 232 | "Advisable function dispatcher" 233 | (apply-before obj arguments) 234 | (multiple-value-prog1 (apply-around obj arguments) 235 | (apply-after obj arguments))))))) 236 | 237 | (defun advisable-function-p (object) 238 | "Check if OBJECT is an advisable function" 239 | (typep object 'advisable-function)) 240 | 241 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | ;;; Advice Calling Logic ;;; 243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 244 | 245 | (defun generate-around-caller (function-list) 246 | (lambda (&rest args) 247 | (if (cdr function-list) 248 | (apply (car function-list) 249 | (cons (generate-around-caller (cdr function-list)) 250 | args)) 251 | (apply (car function-list) args)))) 252 | 253 | (defun apply-before (obj args) 254 | (loop for fn in (advisable-function-before obj) 255 | do (apply fn args))) 256 | 257 | (defun apply-around (obj args) 258 | (apply (generate-around-caller 259 | (append (advisable-function-around obj) 260 | (list (advisable-function-main obj)))) 261 | args)) 262 | 263 | (defun apply-after (obj args) 264 | (loop for fn in (advisable-function-after obj) 265 | do (apply fn args))) 266 | 267 | (defun make-advisable (symbol &key (arguments :not-provided args-provided-p) 268 | force-use-arguments) 269 | "Make the function denoted by SYMBOL an advisable function. 270 | 271 | If SYMBOL is a function argument return the advisable function generated for 272 | it. If SYMBOL is a symbol set the symbol function of SYMBOL to the advisable 273 | function generated. 274 | 275 | If ARGUMENTS is provided it must be the argument list of the function being 276 | advised. When compiling this argument list will be used by the dispatching 277 | function. Otherwise if FORCE-USE-ARGUMENTS is T then eval will be used to 278 | generate the dispatcher function. Otherwise the dispatcher function will have a 279 | single &REST argument." 280 | (check-type symbol (or symbol function)) 281 | (let ((fn (make-instance 'advisable-function 282 | :main symbol 283 | :arguments arguments 284 | :force-accurate-dispatcher-arglist 285 | (and args-provided-p force-use-arguments)))) 286 | (if (and (typep symbol 'symbol) fn) 287 | (restart-case (setf (symbol-function symbol) fn) 288 | (abort () 289 | :report (lambda (s) 290 | (format s "Abort conversion of ~A to be advisable" 291 | symbol)) 292 | fn)) 293 | fn))) 294 | 295 | (define-compiler-macro make-advisable 296 | (&whole whole symbol &key arguments force-use-arguments) 297 | (declare (ignore force-use-arguments)) 298 | (if (atom arguments) 299 | whole 300 | `(let ((fn (make-instance 301 | 'advisable-function 302 | :main ,symbol 303 | :arguments ,arguments 304 | :dispatcher-generator 305 | (lambda (obj) 306 | (lambda ,(cadr arguments) 307 | ,(format nil "Advisable function dispatcher for ~A" symbol) 308 | ,@(generate-ignore-declarations (cadr arguments)) 309 | (let ((fixed ,(argument-list-to-apply-list 310 | (cadr arguments)))) 311 | (apply-before obj fixed) 312 | (multiple-value-prog1 (apply-around obj fixed) 313 | (apply-after obj fixed)))))))) 314 | (if (and (typep ,symbol 'symbol) fn) 315 | (restart-case (setf (symbol-function ,symbol) fn) 316 | (abort () 317 | :report (lambda (s) 318 | (format s "Abort conversion of ~A to be advisable" 319 | ,symbol)) 320 | fn)) 321 | fn)))) 322 | 323 | (define-condition not-an-advisable-function (error) 324 | ((fn :initarg :function :reader not-an-advisable-function-function)) 325 | (:report 326 | (lambda (c s) 327 | (format s "~A is not an advisable function" 328 | (not-an-advisable-function-function c))))) 329 | 330 | (defun make-unadvisable (symbol) 331 | "Make SYMBOL unadvisable if it is an advisable function. 332 | 333 | When SYMBOL is a function object return the main function of the advisable 334 | function object. When SYMBOL is a symbol set the symbol function of SYMBOL to 335 | the main function of the advisable function object." 336 | (check-type symbol (or symbol function)) 337 | (let ((fn (typecase symbol 338 | (symbol (symbol-function symbol)) 339 | (function symbol)))) 340 | (if (typep fn 'advisable-function) 341 | (if (symbolp symbol) 342 | (setf (symbol-function symbol) 343 | (advisable-function-main fn)) 344 | (advisable-function-main fn)) 345 | (restart-case (error 'not-an-advisable-function :function symbol) 346 | (continue () fn))))) 347 | 348 | (defun call-with-unadvisable-function (function-symbol thunk 349 | &key (restore-with-changes t)) 350 | "Implement WITH-ADVISABLE-FUNCTIONs logic. FUNCTION-SYMBOL has its symbol 351 | function bound to the main function of the advisable function object that 352 | FUNCTION-SYMBOL currently refers to. Then THUNK is called, and finally the 353 | original advisable function is restored. If FUNCTION-SYMBOL names an unadvisable 354 | function then thunk is called." 355 | (check-type function-symbol symbol) 356 | (let* ((function (symbol-function function-symbol)) 357 | (fn (when (advisable-function-p function) 358 | (advisable-function-main function)))) 359 | (if fn 360 | (progn (setf (symbol-function function-symbol) fn) 361 | (unwind-protect (funcall thunk) 362 | (when restore-with-changes 363 | (setf (advisable-function-main function) 364 | (symbol-function function-symbol))) 365 | (setf (symbol-function function-symbol) function))) 366 | (funcall thunk)))) 367 | 368 | (defmacro with-unadvisable-function 369 | ((function-symbol &key (restore-with-changes t rwcpp)) &body body) 370 | "Evaluate BODY in a context where the symbol function of FUNCTION-SYMBOL is 371 | bound to the main function of the advisable function. The intended use of this 372 | macro is for when access to the main function is needed, but it is undesireable 373 | to unadvise the function in question, for example when defining methods for a 374 | generic function which has had advice installed. 375 | 376 | When FUNCTION-SYMBOL names an advisable function then the main function (the 377 | advised function) is aquired and the symbol-function of FUNCTION-SYMBOL is bound 378 | to it. BODY is then evaluated. The evaluation is body is protected with cleanup 379 | forms which restore the symbol-function of FUNCTION-SYMBOL to refer to the 380 | advisable function object. When RESTORE-WITH-CHANGES is T then the main function 381 | of the advisable function object (ie the function being advised) is set to the 382 | current symbol-function of FUNCTION-SYMBOL. 383 | 384 | When FUNCTION-SYMBOL names an unadvisable function, then BODY is evaluated. 385 | 386 | When FUNCTION-SYMBOL is not fbound, a continuable error of type unbound-function 387 | is signaled. In addition to the continue restart, a restart named 388 | BIND-SYMBOL-FUNCTION is established which will read and evaluate a form, and set 389 | the symbol-function of FUNCTION-SYMBOL to this form, before re-attempting to 390 | evaluate BODY within the context described above." 391 | (with-gensyms (local-fn bind-restart-fn tag) 392 | `(flet ((,local-fn () 393 | ,@body)) 394 | (declare (dynamic-extent #',local-fn)) 395 | (tagbody 396 | ,tag 397 | (if (fboundp ',function-symbol) 398 | (call-with-unadvisable-function ',function-symbol #',local-fn 399 | :restore-with-changes 400 | ,restore-with-changes) 401 | ,(let ((form-print 402 | (concatenate 'string 403 | (format nil "(WITH-UNADVISABLE-FUNCTION (~S" 404 | function-symbol) 405 | (format nil "~A) ...)" 406 | (if rwcpp 407 | (format nil 408 | " :RESTORE-WITH-CHANGES ~S" 409 | restore-with-changes) 410 | ""))))) 411 | `(restart-case 412 | (cerror 413 | ,(format nil 414 | "Continue without evaluating the body of ~A" 415 | form-print) 416 | 'undefined-function :name ',function-symbol) 417 | (bind-symbol-function (,bind-restart-fn) 418 | :report ,(format nil 419 | "Set the symbol-function of ~A to a function and evaluate the body of ~A" 420 | function-symbol 421 | form-print) 422 | :interactive (lambda () 423 | (format *query-io* "Enter a form to be evaluated") 424 | (list (eval (read *query-io*)))) 425 | (setf (symbol-function ',function-symbol) ,bind-restart-fn) 426 | (go ,tag))))))))) 427 | 428 | (defun copy-advice (fn1 fn2) 429 | "DESTRUCTIVELY Copy all advice from FN1 to FN2" 430 | (setf (advisable-function-before fn2) (advisable-function-before fn1) 431 | (advisable-function-around fn2) (advisable-function-around fn1) 432 | (advisable-function-after fn2) (advisable-function-after fn1))) 433 | 434 | (defmacro advisable-lambda (argslist &body body) 435 | (with-gensyms (fobj fixed) 436 | `(make-instance 'advisable-function 437 | :main #'(lambda ,argslist ,@body) 438 | :arguments ',argslist 439 | :dispatcher-generator 440 | #'(lambda (,fobj) 441 | #'(lambda ,argslist 442 | ,(format nil "Advisable function dispatcher") 443 | ,@(generate-ignore-declarations argslist) 444 | (let ((,fixed ,(argument-list-to-apply-list argslist))) 445 | (apply-before ,fobj ,fixed) 446 | (multiple-value-prog1 (apply-around ,fobj ,fixed) 447 | (apply-after ,fobj ,fixed)))))))) 448 | 449 | (defmacro defun-advisable (name argslist &body body) 450 | "Define a function as an advisable function - works the same as DEFUN." 451 | (with-gensyms (oldfn) 452 | `(let ((,oldfn (handler-case (symbol-function ',name) 453 | (undefined-function () nil)))) 454 | (defun ,name ,argslist ,@body) 455 | (make-advisable ',name :arguments ',argslist) 456 | (when (and ,oldfn 457 | (not (eql (advisable-function-arguments ,oldfn) :not-provided)) 458 | (equal (advisable-function-arguments ,oldfn) ',argslist)) 459 | (copy-advice ,oldfn (symbol-function ',name)))))) 460 | 461 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; 462 | ;;; Implicit Conversion ;;; 463 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; 464 | 465 | (defvar *allow-implicit-conversion* t 466 | "Controls whether variables can implicitly be converted to advisable 467 | functions. When NIL implicit conversion signals an error.") 468 | 469 | (define-condition implicit-conversion-to-advisable-function (error) 470 | ((function-being-converted :initarg :function :reader function-being-converted)) 471 | (:report 472 | (lambda (c s) 473 | (format s "~A is being implicitly converted to an advisable function" 474 | (function-being-converted c))))) 475 | 476 | (defun ensure-advisable-function (symbol &optional arguments force-use-arguments) 477 | (check-type symbol (or symbol function)) 478 | (let ((fn (if (symbolp symbol) 479 | (symbol-function symbol) 480 | symbol))) 481 | (flet ((convert () 482 | (make-advisable symbol 483 | :arguments arguments 484 | :force-use-arguments force-use-arguments))) 485 | (cond ((advisable-function-p fn) 486 | fn) 487 | (*allow-implicit-conversion* 488 | (convert)) 489 | (t (restart-case (error 'implicit-conversion-to-advisable-function 490 | :function symbol) 491 | (allow-conversion () 492 | (convert)) 493 | (return-value (value) 494 | :report (lambda (stream) 495 | (format stream 496 | "Provide a value to return from ensure-advisable-function")) 497 | :interactive (lambda () 498 | (format *query-io* "Enter a value: ") 499 | (multiple-value-list (eval (read)))) 500 | :test (lambda (condition) 501 | (typep condition 502 | 'implicit-conversion-to-advisable-function)) 503 | (return-from ensure-advisable-function value)))))))) 504 | 505 | (defun ensure-unadvisable-function (symbol) 506 | (handler-bind ((not-an-advisable-function 507 | (lambda (c) 508 | (let ((r (find-restart 'continue c))) 509 | (when r 510 | (invoke-restart r)))))) 511 | (make-unadvisable symbol))) 512 | 513 | (defmacro with-implicit-conversion 514 | ((allow-or-not &optional abort-on-implicit-conversion return-on-abort) 515 | &body body) 516 | "Allow or disallow implicit conversions to advisable functions. 517 | 518 | If ALLOWED-OR-NOT is :allowed then conversions are allowed, otherwise they are 519 | disallowed. 520 | 521 | If ABORT-ON-IMPLICIT-CONVERSION is T, a handler is established for implicit 522 | conversion errors which immediately returns RETURN-ON-ABORT." 523 | (with-gensyms (blockname c) 524 | `(let ((*allow-implicit-conversion* (eql ,allow-or-not :allowed))) 525 | ,@(if abort-on-implicit-conversion 526 | `((block ,blockname 527 | (handler-bind ((implicit-conversion-to-advisable-function 528 | (lambda (,c) 529 | (declare (ignore ,c)) 530 | (return-from ,blockname ,return-on-abort)))) 531 | (locally ,@body)))) 532 | body)))) 533 | 534 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 535 | ;;; Adding and Removing Advice ;;; 536 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 537 | 538 | (define-condition circular-advice-dependency (error) 539 | ((f1 :initarg :function :reader circular-advice-function) 540 | (f2 :initarg :advice :reader circular-advice-advice)) 541 | (:report 542 | (lambda (c s) 543 | (format s "Circular advice detected between ~A and ~A. 544 | 545 | ~A is a piece of advice for ~A, 546 | either directly or through one of its pieces of advice." 547 | (circular-advice-function c) 548 | (circular-advice-advice c) 549 | (circular-advice-function c) 550 | (circular-advice-advice c))))) 551 | 552 | (defun circular-advice-p (function advice-fn &key (test 'eql)) 553 | "check if theres a circular dependency between FUNCTION and ADVICE-FN." 554 | (let ((normalized-function (if (symbolp function) 555 | (symbol-function function) 556 | function)) 557 | (normalized-advice-fn (if (symbolp advice-fn) 558 | (symbol-function advice-fn) 559 | advice-fn))) 560 | (labels ((compare (f adv where) 561 | (let ((normalized-f (if (symbolp f) 562 | (symbol-function f) 563 | f))) 564 | (when (funcall test normalized-f normalized-function) 565 | (restart-case 566 | (error 'circular-advice-dependency :function function 567 | :advice advice-fn) 568 | (remove-advice () 569 | :report (lambda (s) 570 | (format s "Remove ~A from ~A's ~A advice list and continue advice installation" 571 | f adv where)) 572 | (remove-advice where adv f)))) 573 | (when (advisable-function-p normalized-f) 574 | (circularp normalized-f)))) 575 | (circularp (adv) 576 | (when (advisable-function-p adv) 577 | (mapc #'(lambda (f) 578 | (compare f adv :before)) 579 | (advisable-function-before adv)) 580 | (mapc #'(lambda (f) 581 | (compare f adv :around)) 582 | (advisable-function-around adv)) 583 | (mapc #'(lambda (f) 584 | (compare f adv :after)) 585 | (advisable-function-after adv))))) 586 | (circularp normalized-advice-fn)))) 587 | 588 | (macrolet ((define-add-advice (how) 589 | (let ((accessor 590 | (cond ((string= how "before") 'advisable-function-before) 591 | ((string= how "around") 'advisable-function-around) 592 | ((string= how "after") 'advisable-function-after)))) 593 | `(defun ,(intern (string-upcase (format nil "add-advice-~A" how)) 594 | (find-package :cl-advice)) 595 | (function advice-fn &key allow-duplicates (test 'eql) from-end) 596 | (let* ((advise (ensure-advisable-function function)) 597 | (list (,accessor advise)) 598 | (loc (member advice-fn list :test test))) 599 | (unless (symbolp advice-fn) 600 | (warn "advising ~A with an anonymous function" function)) 601 | (let ((last (last list))) 602 | (if loc 603 | (if allow-duplicates 604 | (if (and from-end last) 605 | (setf (cdr last) (list advice-fn)) 606 | (push advice-fn (,accessor advise))) 607 | (setf (car loc) advice-fn)) 608 | (if (and from-end last) 609 | (setf (cdr last) (list advice-fn)) 610 | (push advice-fn (,accessor advise)))) 611 | advice-fn)))))) 612 | (define-add-advice "before") 613 | (define-add-advice "around") 614 | (define-add-advice "after")) 615 | 616 | (defun add-advice (where function advice-function &key allow-duplicates (test 'eql) 617 | from-end) 618 | "Add ADVICE-FUNCTION to FUNCTION. WHERE must be one of :before, :around, or 619 | :after. If ALLOW-DUPLICATES is true, advice will be added regardless. TEST is used 620 | to check if ADVICE-FUNCTION is already present. When FROM-END is true, advice will 621 | be appended instead of prepended." 622 | (restart-case (circular-advice-p function advice-function) 623 | (abort () 624 | :report (lambda (s) 625 | (format s "Abort installation of ~A advice ~A in function ~A" 626 | where advice-function function)) 627 | :test (lambda (c) 628 | (typep c 'circular-advice-dependency)) 629 | (return-from add-advice (values))) 630 | (continue () 631 | :report (lambda (s) 632 | (format s "Advise ~A with ~A despite circular dependency" 633 | function advice-function)) 634 | :test (lambda (c) (typep c 'circular-advice-dependency)) 635 | nil)) 636 | (apply (ccase where 637 | ((:before) 'add-advice-before) 638 | ((:around) 'add-advice-around) 639 | ((:after) 'add-advice-after)) 640 | (list function advice-function 641 | :allow-duplicates allow-duplicates 642 | :test test 643 | :from-end from-end))) 644 | 645 | (macrolet ((define-replace-advice (how) 646 | (let ((accessor (cond ((string= how "before") 647 | 'advisable-function-before) 648 | ((string= how "around") 649 | 'advisable-function-around) 650 | ((string= how "after") 651 | 'advisable-function-after)))) 652 | `(defun ,(intern (string-upcase (format nil "replace-advice-~A" how)) 653 | (find-package :cl-advice)) 654 | (function old-advice new-advice test if-not-found &key errorp) 655 | (let* ((advise (ensure-advisable-function function)) 656 | (loc (member old-advice (,accessor advise) :test test))) 657 | (cond (loc 658 | (setf (car loc) new-advice)) 659 | ((eql if-not-found :prepend) 660 | (push new-advice (,accessor advise))) 661 | ((eql if-not-found :append) 662 | (setf (,accessor advise) 663 | (append (,accessor advise) (list new-advice)))) 664 | (errorp 665 | (cerror "Ignore advice replacement" 666 | "Advice ~A not present in ~A advice for function ~A" 667 | old-advice ,how function)) 668 | (t nil))))))) 669 | (define-replace-advice "before") 670 | (define-replace-advice "around") 671 | (define-replace-advice "after")) 672 | 673 | (defun replace-advice (where function old-advice new-advice 674 | &key (test 'eql) (if-not-found :prepend) errorp) 675 | "Replace OLD-ADVICE with NEW-ADVICE in the advice list for FUNCTION denoted by 676 | WHERE. TEST is used to find OLD-ADVICE. IF-NOT-FOUND dictates what to do in the 677 | event OLD-ADVICE is not present. It may be one of :prepend, :append, or nil." 678 | (apply (ccase where 679 | ((:before) 'replace-advice-before) 680 | ((:around) 'replace-advice-around) 681 | ((:after) 'replace-advice-after)) 682 | (list function old-advice new-advice test if-not-found :errorp errorp))) 683 | 684 | (defmacro define-advisory-functions ((to-advise &key (next-arg 'next)) args &body advice) 685 | "Define advisable functions and add them to TO-ADVISE. 686 | 687 | TO-ADVISE is a symbol denoting the function to advise. 688 | NEXT-ARG is the argument prepended to the argument list of around functions. 689 | ARGS is the argument list of TO-ADVISE, or a compatible argument list. 690 | 691 | BODY is a set of specifications for advice functions. A specification is a list 692 | of the shape (type forms*). 693 | 694 | Type is either a keyword or a list. If it is a list it must conform to one of 695 | two shapes: (keyword name &rest keyargs) or (keyword &rest keyargs). The 696 | keyword must be one of :AROUND :BEFORE or :AFTER. If the name is a keyword then 697 | the second shape is assumed. Otherwise the first shape is assumed. The keyargs 698 | are passed to add-advice. If a name is given, then a function is defined using 699 | defun, otherwise an anonymous function is used. 700 | 701 | forms* is a set of forms comprising a function body whose argument list is ARGS, 702 | or if it is around advice, the argument list is created by (cons NEXT-ARG ARGS). 703 | 704 | Example: 705 | 706 | (defun foo (bar) 707 | (print bar)) 708 | 709 | (define-advisory-functions (foo :next-arg fn) (bar) 710 | (:before 711 | (format t \"~&before FOO, passed ~A~&\" bar)) 712 | (:around 713 | (format t \"~&around foo~&\") 714 | (funcall fn bar) 715 | (format t \"~&around foo~&\")) 716 | ((:after foo-after) 717 | (format t \"~&after foo, was passed ~A~&\" bar))) 718 | 719 | expands into 720 | 721 | (progn 722 | (apply 'add-advice 723 | (list :before 'foo 724 | (lambda (bar) (format t \"~&before FOO, passed ~A~&\" bar)))) 725 | (apply 'add-advice 726 | (list :around 'foo 727 | (lambda (fn bar) 728 | (format t \"~&around foo~&\") 729 | (funcall fn bar) 730 | (format t \"~&around foo~&\")))) 731 | (progn 732 | (defun foo-after (bar) (format t \"~&after foo, was passed ~A~&\" bar)) 733 | (apply 'add-advice (list :after 'foo 'foo-after)))) 734 | " 735 | `(progn 736 | ,@(loop for (type . body) in advice 737 | for argslist = (if (eq (if (listp type) (car type) type) :around) 738 | (cons next-arg args) 739 | args) 740 | collect (cond ((symbolp type) 741 | `(apply 'add-advice 742 | (list ,type ',to-advise 743 | (lambda ,argslist ,@body)))) 744 | ((keywordp (cadr type)) 745 | (destructuring-bind (where &rest rest) type 746 | `(apply 'add-advice (list ,where ',to-advise 747 | (lambda ,argslist 748 | ,@body) 749 | ,@rest)))) 750 | (t (destructuring-bind (where name &rest rest) type 751 | `(progn (defun ,name ,argslist ,@body) 752 | (apply 'add-advice 753 | (list ,where ',to-advise ',name ,@rest))))))))) 754 | 755 | (defun list-advice (fn &key (type :all) print) 756 | "List advice for FN, of type TYPE. When PRINT is true, advice will be printed to 757 | standard output." 758 | (when-let1 (obj (ensure-advisable-function fn)) 759 | (if (eql type :all) 760 | (let ((before (advisable-function-before obj)) 761 | (around (advisable-function-around obj)) 762 | (after (advisable-function-after obj))) 763 | (when print 764 | (format t 765 | "BEFORE:~%~{~T~S~^~%~}~%AROUND:~%~{~T~S~^~%~}~%AFTER:~%~{~T~S~^~%~}" 766 | before around after)) 767 | (values before around after)) 768 | (let ((fns (case type 769 | ((:before) 770 | (advisable-function-before obj)) 771 | ((:around) 772 | (advisable-function-around obj)) 773 | ((:after) 774 | (advisable-function-after obj)) 775 | (otherwise (error "Unknown advice type ~S" type))))) 776 | (when print 777 | (format t "~{~S~^~%~}" fns)) 778 | fns)))) 779 | 780 | (defun remove-advice-all (fn) 781 | (when-let1 (obj (ensure-advisable-function fn)) 782 | (setf (advisable-function-before obj) nil 783 | (advisable-function-around obj) nil 784 | (advisable-function-after obj) nil))) 785 | 786 | (defun remove-nth (list nth) 787 | (loop for el in list 788 | for x from 0 789 | unless (= x nth) 790 | collect el)) 791 | 792 | (macrolet ((generate-remove-nth (type) 793 | (let ((accessor (case type 794 | (:before 'advisable-function-before) 795 | (:around 'advisable-function-around) 796 | (:after 'advisable-function-after)))) 797 | `(defun ,(intern (concatenate 'string "REMOVE-NTH-ADVICE-" 798 | (symbol-name type))) 799 | (fn nth) 800 | (when-let1 (obj (ensure-advisable-function fn)) 801 | (setf (,accessor obj) (remove-nth (,accessor obj) nth))))))) 802 | (generate-remove-nth :before) 803 | (generate-remove-nth :around) 804 | (generate-remove-nth :after)) 805 | 806 | (defun remove-nth-advice (type fn nth) 807 | "Remove NTH advice advice from FNs advice list of type TYPE." 808 | (apply (ccase type 809 | ((:before) 'remove-nth-advice-before) 810 | ((:around) 'remove-nth-advice-around) 811 | ((:after) 'remove-nth-advice-after)) 812 | fn nth)) 813 | 814 | (macrolet ((generate-remove-advice (type checker) 815 | ;; generate remove-*-advice-if/-not functions 816 | (let ((accessor (case type 817 | (:before '(advisable-function-before fn)) 818 | (:around '(advisable-function-around fn)) 819 | (:after '(advisable-function-after fn))))) 820 | `(defun ,(intern (concatenate 'string "REMOVE-" (symbol-name type) 821 | (case checker 822 | (when "-ADVICE-IF-NOT") 823 | (unless "-ADVICE-IF")))) 824 | (predicate function from-end start end) 825 | (declare (type number start) 826 | (type (or number null) end) 827 | (type function predicate)) 828 | (when-let1 (fn (ensure-advisable-function function)) 829 | (do ((counter start (+ counter 1)) 830 | (accumulator nil) 831 | (list (nthcdr start (if from-end 832 | (reverse ,accessor) 833 | ,accessor)) 834 | (cdr list))) 835 | ((or (not list) (and end (= counter end))) 836 | (setf ,accessor (reverse accumulator))) 837 | (,checker (funcall predicate (car list)) 838 | (push (car list) accumulator))))))) 839 | (gen-wrap (suffix) 840 | ;; generate remove-advice-if/-not functions 841 | (flet ((generate-remove-call (where) 842 | (intern (concatenate 'string "REMOVE-" (symbol-name where) 843 | "-ADVICE-" (symbol-name suffix))))) 844 | `(defun ,(intern (concatenate 'string "REMOVE-ADVICE-" 845 | (symbol-name suffix))) 846 | (predicate type function &key from-end (start 0) end) 847 | (case type 848 | (:before (,(generate-remove-call 'before) 849 | predicate function from-end start end)) 850 | (:around (,(generate-remove-call 'around) 851 | predicate function from-end start end)) 852 | (:after (,(generate-remove-call 'after) 853 | predicate function from-end start end))))))) 854 | (generate-remove-advice :before when) 855 | (generate-remove-advice :around when) 856 | (generate-remove-advice :after when) 857 | (generate-remove-advice :before unless) 858 | (generate-remove-advice :around unless) 859 | (generate-remove-advice :after unless) 860 | (gen-wrap if) 861 | (gen-wrap if-not)) 862 | 863 | (defun remove-advice (type fn advice &key (test 'eql)) 864 | (remove-advice-if (lambda (f) 865 | (if (eql advice :all) 866 | t 867 | (funcall test f advice))) 868 | type fn)) 869 | --------------------------------------------------------------------------------