(define transcript-on #f) (define transcript-off #f) (let ((*transcript-stack* '())) (define (trans-on filename) (let ((trans (open-output-file filename)) (inp (current-input-port)) (outp (current-output-port)) (errp (current-error-port))) (define (clone-port port) (make-soft-port (vector (and (output-port? port) (lambda (c) (write-char c port) (write-char c trans))) (and (output-port? port) (lambda (s) (display s port) (display s trans))) (and (output-port? port) (lambda () (force-output port) (force-output trans))) (and (input-port? port) (lambda () (let ((c (read-char port))) (write-char c trans) c))) (lambda () (close-port port))) (if (input-port? port) (if (output-port? port) "r+" "r") "w"))) (set! *transcript-stack* (cons (list trans (current-input-port) (current-output-port) (current-error-port)) *transcript-stack*)) (set-current-input-port (clone-port inp)) (set-current-output-port (clone-port outp)) (set-current-error-port (clone-port errp)))) (define (trans-off) (cond ((pair? *transcript-stack*) (apply (lambda (trans inp outp errp) (close-port trans) (set-current-input-port inp) (set-current-output-port outp) (set-current-error-port errp)) (car *transcript-stack*)) (set! *transcript-stack* (cdr *transcript-stack*))) (else (error "No transcript active")))) (set! transcript-on trans-on) (set! transcript-off trans-off)) (provide 'transcript)