ikarus/src/ikarus.trace.ss

134 lines
3.6 KiB
Scheme
Raw Normal View History

2006-11-23 19:44:29 -05:00
2007-04-29 20:55:51 -04:00
(library (ikarus trace)
(export make-traced-procedure trace-symbol! untrace-symbol!)
(import (ikarus))
2007-04-29 20:55:51 -04:00
2006-11-23 19:44:29 -05:00
(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 ()
2006-12-05 15:08:00 -05:00
(call-with-values
(lambda ()
(call/cf
(lambda (nf)
(set! f nf)
(set-car! k* nf)
(apply proc args))))
(lambda v*
(display-prefix k* #t)
(unless (null? v*)
(write (car v*))
(let f ([v* (cdr v*)])
(cond
[(null? v*) (newline)]
[else
(write-char #\space)
(write (car v*))
(f (cdr v*))])))
(apply values v*))))
2006-11-23 19:44:29 -05:00
(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 (symbol-value s)])
2006-11-23 19:44:29 -05:00
(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-symbol-value! s p)))))]
2006-11-23 19:44:29 -05:00
[else
(unless (symbol-bound? s)
2006-11-23 19:44:29 -05:00
(error 'trace "~s is unbound" s))
(let ([v (symbol-value s)])
2006-11-23 19:44:29 -05:00
(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-symbol-value! s p)))])))
2006-11-23 19:44:29 -05:00
(define untrace-symbol!
(lambda (s)
(define loop
(lambda (ls)
(cond
[(null? ls) '()]
[(eq? s (caar ls))
(let ([a (cdar ls)])
(when (eq? (cdr a) (symbol-value s))
(set-symbol-value! s (car a)))
2006-11-23 19:44:29 -05:00
(cdr ls))]
[else (cons (car ls) (loop (cdr ls)))])))
(set! traced-symbols (loop traced-symbols))))
)
2006-11-23 19:44:29 -05:00
2006-12-05 13:28:23 -05:00
#!eof
Try:
(trace-define fact
(lambda (n)
(if (zero? n)
1
(* n (fact (sub1 n))))))
(fact 5)
(trace-define (fact n m)
(cond
[(zero? n) m]
[else (fact (sub1 n) (* n m))]))
(fact 5 1)
(trace-define (fact n m k)
(cond
[(zero? n) (k m)]
[else (begin (fact (sub1 n) (* n m) k) 0)]))
(call/cc
(lambda (k)
(fact 6 1
(trace-lambda escape (v) (k v)))))
(trace-define (infinite-loop n)
(infinite-loop (add1 n)))
(infinite-loop 0)