summaryrefslogtreecommitdiff
path: root/module/system/repl/error-handling.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/repl/error-handling.scm')
-rw-r--r--module/system/repl/error-handling.scm71
1 files changed, 50 insertions, 21 deletions
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index d41dea643..c6c64cc73 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -122,27 +122,56 @@
(case on-error
((debug)
(lambda (key . args)
- (let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
- (stack (narrow-stack->vector
- (make-stack #t)
- ;; Cut three frames from the top of the stack:
- ;; make-stack, this one, and the throw handler.
- 3
- ;; Narrow the end of the stack to the most recent
- ;; start-stack.
- tag
- ;; And one more frame, because %start-stack invoking
- ;; the start-stack thunk has its own frame too.
- 0 (and tag 1)))
- (error-msg (error-string stack key args))
- (debug (make-debug stack 0 error-msg #f)))
- (with-saved-ports
- (lambda ()
- (format #t "~a~%" error-msg)
- (format #t "Entering a new prompt. ")
- (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
- ((@ (system repl repl) start-repl) #:debug debug))))))
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (stack (narrow-stack->vector
+ (make-stack #t)
+ ;; Cut three frames from the top of the stack:
+ ;; make-stack, this one, and the throw handler.
+ 3
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ tag
+ ;; And one more frame, because %start-stack invoking
+ ;; the start-stack thunk has its own frame too.
+ 0 (and tag 1)))
+ (error-msg (error-string stack key args))
+ (debug (make-debug stack 0 error-msg #f)))
+ (with-saved-ports
+ (lambda ()
+ (format #t "~a~%" error-msg)
+ (format #t "Entering a new prompt. ")
+ (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+ ((@ (system repl repl) start-repl) #:debug debug)))))))
+ ((report)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (begin
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
+ ((backtrace)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (frames (narrow-stack->vector
+ (make-stack #t)
+ ;; Narrow as above, for the debugging case.
+ 3 tag 0 (and tag 1))))
+ (with-saved-ports
+ (lambda ()
+ (print-frames frames)
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
((pass)
(lambda (key . args)
;; fall through to rethrow