source: project/release/3/advice/advice.scm @ 7842

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

merged with mainline rev. 7838

File size: 3.6 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  ;; chicken's closure representation ensures that the advice object
58  ;; is part of the advisor closure, but we must avoid boxing,
59  ;; so no assignment to a2 is allowed.
60  (let* ((a (find-advice proc 'advise))
61         (a2 (or a (make-advice #f '() '() '()) ) ) )
62    (unless a
63      (advice-old-set! a2 (mutate-procedure proc (make-advisor a2))))
64    (case mode
65      ((before) 
66       (advice-before-set! a2 (alist-cons id h (advice-before a2))) )
67      ((after)
68       (advice-after-set! a2 (append (advice-after a2) (list (cons id h)))))
69      ((around)
70       (advice-around-set! a2 (alist-cons id h (advice-around a2))))
71      (else (error 'advise "invalid advice mode" mode)))
72    id) )
73
74(define (unadvise proc #!optional id mode)
75  (let ((a (or (find-advice proc 'unadvise)
76               (error 'unadvise "procedure is not advised" proc))))
77    (cond (id
78           (let* ((ba (advice-before a))
79                  (ae (and (or (not mode) (eq? mode 'before))
80                           (assq id ba)) ) )
81             (if ae 
82                 (advice-before-set! a (delete! ae ba))
83                 (let* ((aa (advice-after a))
84                        (ae (and (or (not mode) (eq? mode 'after))
85                                 (assq id aa)) ) )
86                   (if ae
87                       (advice-after-set! a (delete! ae aa))
88                       (let* ((ao (advice-around a))
89                              (ae (and (or (not mode) (eq? mode 'around))
90                                       (assq id ao)) ) )
91                         (if ae
92                             (advice-around-set! a (delete ae ao)) 
93                             (error 'unadvise "no such advice" id proc mode) ) ) ) ) ) ) )
94          ((memq mode '(#f around before after))
95           (when (or (not mode) (eq? mode 'before))
96             (advice-before-set! a '()))
97           (when (or (not mode) (eq? mode 'after))
98             (advice-after-set! a '()))
99           (when (or (not mode) (eq? mode 'around))
100             (advice-around-set! a '())) )
101          (else (error 'unadvise "invalid advice mode" mode)) )
102    (when (and (null? (advice-before a))
103               (null? (advice-after a))
104               (null? (advice-around a)) )
105      (mutate-procedure proc (constantly (advice-old a))) )
106    (void) ) )
Note: See TracBrowser for help on using the repository browser.