(define *debugger-level* (make-dynamic 0))
(define (*system-error-handler* parent-frame name culprit message) (define (real-error-handler) (format #t "~L(Type '?' for help in using the debugger.)~L~%" "i" "I") (dynamic-bind ((*debugger-level* (+ (dynamic-ref *debugger-level*) 1))) (let loop ((current-frame parent-frame)) (format #t "~LDebug ~S>~L " "b" (dynamic-ref *debugger-level*) "B") (let* ((input (read)) (command (if (eof-object? input) (quote :q) input))) (define (print-frame-name frame) (format #t "~L~S~L~%" "f" (frame-name frame) "F")) (define (print-variables env indent) (when (environment-parent env) (walk-environment (lambda (name value) (format #t "~L~A~S: ~S~L~%" "f" indent name value "F")) env))) (define (protected-eval expr env) (call-with-current-continuation (lambda (k) (dynamic-bind ((*top-level-continuation* k)) (eval expr env))))) (case command ((?) (display "Type a command or an expression to be evaluated in the top-level environment.  The following commands are available:\012\012  ?\011Prints this message.\012  :bt\011Print a backtrace.\012  :fr\011Prints variables in current frame.\012  :fr*\011Same as :fr, but includes nested scopes.\012  :f\011Moves on to the next outer continuation frame.\012  :b\011Moves back to the previous continuation frame.\012  :r\011Resumes the computation with a value provided by the user.\012  :q\011Aborts to top level.\012") (loop current-frame)) ((:bt) (change-looks "f") (let inner ((frame parent-frame)) (unless (not frame) (format #t "~A~S~%" (if (eq? frame current-frame) "=> " "   ") (frame-name frame)) (inner (frame-link frame)))) (change-looks "F") (loop current-frame)) ((:fr) (print-frame-name current-frame) (newline) (print-variables (frame-environment current-frame) "    ") (newline) (loop current-frame)) ((:fr*) (print-frame-name current-frame) (newline) (let inner ((env (frame-environment current-frame)) (indent "    ")) (when env (print-variables env indent) (inner (environment-parent env) (string-append indent "    ")))) (newline) (loop current-frame)) ((:f) (let ((new-frame (frame-link current-frame))) (cond ((not new-frame) (format #t "No next frame.~%") (loop current-frame)) (else (print-frame-name new-frame) (loop new-frame))))) ((:b) (cond ((eq? current-frame parent-frame) (format #t "No previous frame.~%") (loop current-frame)) (else (let inner ((frame parent-frame)) (cond ((eq? (frame-link frame) current-frame) (print-frame-name frame) (loop frame)) (else (inner (frame-link frame)))))))) ((:r) (format #t "Returning a value to ~S.~%" (frame-name parent-frame)) (format #t "The following expression will be evaluated in the top-level environment.~%") (format #t "~%Expression to supply value (CR to abort resumption): ") (let loop ((char (read-char))) (unless (char=? char #\Newline) (loop (read-char)))) (let ((char (read-char))) (cond ((char=? char #\Newline) (loop current-frame)) (else (unread-char char) (protected-eval (read) user))))) ((:q) ((dynamic-ref *top-level-continuation*) "Back to top level")) (else (format #t "~L~S~L~%" "i" (protected-eval command user) "I") (loop current-frame))))))) (format #t "~%~LError~L in ~L~S~L:~L ~A~L~%" "zi" "Z" "If" name "F" "i" message "I") (format #t "~L      ~S~L~%~%" "f" culprit "F") (if (null? parent-frame) ((dynamic-ref *top-level-continuation*) "Back to top level") (real-error-handler)))
(define *top-level-continuation* (make-dynamic #f))
(call/cc (lambda (k) (dynamic-set! *top-level-continuation* k)))