source: project/advice/advice.scm @ 7823

Last change on this file since 7823 was 7823, checked in by felix winkelmann, 13 years ago

initial import

File size: 3.4 KB
Line 
1;;;; advice.scm
2
3
4(use srfi-1)
5
6#;(declare
7  (export advise unadvise) )
8
9
10(define-record advice old before after around)
11
12(define (mutate-procedure old proc)
13  (unless (##core#check (procedure? old))
14    (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
15  (let* ((n (##sys#size old))
16         (words (##core#inline "C_words" n))
17         (y (##core#inline "C_copy_block" old (make-vector words))) )
18    (##sys#become! (list (cons old (proc y))))
19    y) )
20
21(define (find-advice proc loc)
22  (unless (procedure? proc) 
23    (error loc "not bad argument type - not a procedure" proc) )
24  (let ((len (##sys#size proc)))
25    (let loop ((i 1))
26      (cond ((fx>= i len) #f)
27            ((advice? (##sys#slot proc i))
28             (##sys#slot proc i) )
29            (else (loop (fx+ i 1)))))))
30
31(define (((make-advisor a) o) . args)
32  (for-each (lambda (ba) ((cdr ba) args)) (advice-before a))
33  (let ((ao (advice-around a))
34        (aa (advice-after a)) )
35    (if (null? ao)
36        (if (null? aa)
37            (apply o args)
38            (let ((results (receive (apply o args))))
39              (for-each (lambda (aa) ((cdr aa) results)) aa)
40              (apply values results) ) )
41        ;; this should actually be constructed on changing the around list and not
42        ;; at runtime ...
43        (let ((run 
44               (let loop ((ao (advice-around a)))
45                 (let ((r (cdr ao)))
46                   (if (null? r)
47                       (lambda args ((cdar ao) o args))
48                       (let ((next (loop (cdr ao))))
49                         (lambda args ((cdar ao) next args)) ) ) ) ) ) )
50          (if (null? aa)
51              (apply run args)
52              (let ((results (receive (apply run args))))
53                (for-each (lambda (aa) ((cdr aa) results)) aa) 
54                (apply values results) ) ) ) ) ) )
55
56(define (advise mode proc h #!optional (id (gensym)))
57  (let* ((a (find-advice proc 'advise))
58         (a2 (or a (make-advice #f '() '() '()) ) ) )
59    (unless a
60      (advice-old-set! a2 (mutate-procedure proc (make-advisor a2))))
61    (case mode
62      ((before) 
63       (advice-before-set! a2 (alist-cons id h (advice-before a2))) )
64      ((after)
65       (advice-after-set! a2 (append (advice-after a2) (list (cons id h)))))
66      ((around)
67       (advice-around-set! a2 (alist-cons id h (advice-around a2))))
68      (else (error 'advise "invalid advice mode" mode)))
69    id) )
70
71(define (unadvise proc #!optional id mode)
72  (let ((a (or (find-advice proc 'unadvise)
73               (error 'unadvise "procedure is not advised" proc))))
74    (cond (id
75           (let* ((ba (advice-before a))
76                  (ae (and (or (not mode) (eq? mode 'before))
77                           (assq id ba)) ) )
78             (if ae 
79                 (advice-before-set! a (delete! ae ba))
80                 (let* ((aa (advice-after a))
81                        (ae (and (or (not mode) (eq? mode 'after))
82                                 (assq id aa)) ) )
83                   (if ae
84                       (advice-after-set! a (delete! ae aa))
85                       (let* ((ao (advice-around a))
86                              (ae (and (or (not mode) (eq? mode 'around))
87                                       (assq id ao)) ) )
88                         (if ae
89                             (advice-around-set! a (delete ae ao)) 
90                             (error 'unadvise "no such advice" id proc mode) ) ) ) ) ) ) )
91          ((memq mode '(#f around before after))
92           (when (or (not mode) (eq? mode 'before))
93             (advice-before-set! a '()))
94           (when (or (not mode) (eq? mode 'after))
95             (advice-after-set! a '()))
96           (when (or (not mode) (eq? mode 'around))
97             (advice-around-set! a '())) )
98          (else (error 'unadvise "invalid advice mode" mode)) )
99    (when (and (null? (advice-before a))
100               (null? (advice-after a))
101               (null? (advice-around a)) )
102      (mutate-procedure proc (constantly (advice-old a))) )
103    (void) ) )
Note: See TracBrowser for help on using the repository browser.