; Tracer (define *tracing* '()) (define (%remove f) (define (R l) (cond ((null? l) l) ((eq? f (caar l)) (cdr l)) (else (cons (car l) (R (cdr l)))))) (set! *tracing* (R *tracing*))) (define (writeln p . l) (for-each (lambda (e) (display e p) (display " " p)) l) (newline p)) (define tracer (let ((depth 0) (p (open-append-file "Trace"))) (lambda (f n) (lambda args (writeln p depth ">" (cons n args)) (let ((old-depth depth)) (set! depth (+ depth 1)) (let ((res (apply f args))) (set! depth old-depth) (writeln p depth n "<" res) res)))))) (macro (trace f) (let ((f (cadr f))) (if (assq f *tracing*) (error (string-append "Already tracing " (object->string f))) `(let ((of ,f) (tf (tracer , f ',f))) (set! *tracing* (cons (cons ',f of) *tracing*)) (set! ,f tf))))) (macro (untrace f) (let ((f (cadr f))) (let ((of (assq f *tracing*))) (%remove f) (if of `(set! ,f ,(cdr of)) (error (string-append "Not tracing " (object->string f)))))))