90 lines
2.7 KiB
Scheme
90 lines
2.7 KiB
Scheme
|
|
||
|
|
(let ()
|
||
|
|
(define k* '())
|
||
|
|
|
||
|
|
(define display-prefix
|
||
|
|
(lambda (ls t)
|
||
|
|
(unless (null? ls)
|
||
|
|
(display (if t "|" " "))
|
||
|
|
(display-prefix (cdr ls) (not t)))))
|
||
|
|
|
||
|
|
(define display-trace
|
||
|
|
(lambda (k* v)
|
||
|
|
(display-prefix k* #t)
|
||
|
|
(write v)
|
||
|
|
(newline)))
|
||
|
|
|
||
|
|
(define make-traced-procedure
|
||
|
|
(lambda (name proc)
|
||
|
|
(lambda args
|
||
|
|
(call/cf
|
||
|
|
(lambda (f)
|
||
|
|
(cond
|
||
|
|
[(memq f k*) =>
|
||
|
|
(lambda (ls)
|
||
|
|
(display-trace ls (cons name args))
|
||
|
|
(apply proc args))]
|
||
|
|
[else
|
||
|
|
(display-trace (cons 1 k*) (cons name args))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda () (set! k* (cons f k*)))
|
||
|
|
(lambda ()
|
||
|
|
(let ([v
|
||
|
|
(call/cf
|
||
|
|
(lambda (nf)
|
||
|
|
(set! f nf)
|
||
|
|
(set-car! k* nf)
|
||
|
|
(apply proc args)))])
|
||
|
|
(display-trace k* v)
|
||
|
|
v))
|
||
|
|
(lambda () (set! k* (cdr k*))))]))))))
|
||
|
|
|
||
|
|
(define traced-symbols '())
|
||
|
|
|
||
|
|
(define trace-symbol!
|
||
|
|
(lambda (s)
|
||
|
|
(cond
|
||
|
|
[(assq s traced-symbols) =>
|
||
|
|
(lambda (pr)
|
||
|
|
(let ([a (cdr pr)] [v (top-level-value s)])
|
||
|
|
(unless (eq? (cdr a) v)
|
||
|
|
(unless (procedure? v)
|
||
|
|
(error 'trace
|
||
|
|
"the top-level value of ~s is ~s (not a procedure)"
|
||
|
|
s v))
|
||
|
|
(let ([p (make-traced-procedure s v)])
|
||
|
|
(set-car! a v)
|
||
|
|
(set-cdr! a p)
|
||
|
|
(set-top-level-value! s p)))))]
|
||
|
|
[else
|
||
|
|
(unless (top-level-bound? s)
|
||
|
|
(error 'trace "~s is unbound" s))
|
||
|
|
(let ([v (top-level-value s)])
|
||
|
|
(unless (procedure? v)
|
||
|
|
(error 'trace "the top-level value of ~s is ~s (not a procedure)"
|
||
|
|
s v))
|
||
|
|
(let ([p (make-traced-procedure s v)])
|
||
|
|
(set! traced-symbols
|
||
|
|
(cons (cons s (cons v p)) traced-symbols))
|
||
|
|
(set-top-level-value! s p)))])))
|
||
|
|
|
||
|
|
(define untrace-symbol!
|
||
|
|
(lambda (s)
|
||
|
|
(define loop
|
||
|
|
(lambda (ls)
|
||
|
|
(cond
|
||
|
|
[(null? ls) '()]
|
||
|
|
[(eq? s (caar ls))
|
||
|
|
(let ([a (cdar ls)])
|
||
|
|
(when (eq? (cdr a) (top-level-value s))
|
||
|
|
(set-top-level-value! s (car a)))
|
||
|
|
(cdr ls))]
|
||
|
|
[else (cons (car ls) (loop (cdr ls)))])))
|
||
|
|
(set! traced-symbols (loop traced-symbols))))
|
||
|
|
|
||
|
|
(primitive-set! 'make-traced-procedure make-traced-procedure)
|
||
|
|
(primitive-set! 'trace-symbol! trace-symbol!)
|
||
|
|
(primitive-set! 'untrace-symbol! untrace-symbol!))
|
||
|
|
|
||
|
|
|