TODO: use exception-stack in other error handlers
TODO: print-exception variant for exception objects
TODO: test cases for other kinds of errors
* module/ice-9/exceptions.scm (&stack): New exception type.
(convert-guile-exception): Capture the stack when creating an exception.
* module/system/repl/error-handling.scm (call-with-error-handling): Use
the exception stack if available.
* test-suite/Makefile.am (SCM_TESTS): Add sample code.
* test-suite/tests/exceptions.test ("exception location"): New tests.
* test-suite/tests/exceptions/error.scm:
* test-suite/tests/exceptions/error-with-throw-handler-1.scm:
* test-suite/tests/exceptions/error-with-throw-handler-2.scm:
* test-suite/tests/exceptions/error-with-throw-handler-3.scm:
Sample code for exception location tests.
---
module/ice-9/exceptions.scm | 8 +-
module/system/repl/error-handling.scm | 153 ++++++++++--------
test-suite/Makefile.am | 5 +
test-suite/tests/exceptions.test | 48 +++++-
.../exceptions/error-with-throw-handler-1.scm | 6 +
.../exceptions/error-with-throw-handler-2.scm | 11 ++
.../exceptions/error-with-throw-handler-3.scm | 16 ++
test-suite/tests/exceptions/error.scm | 1 +
8 files changed, 183 insertions(+), 65 deletions(-)
create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-1.scm
create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-2.scm
create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-3.scm
create mode 100644 test-suite/tests/exceptions/error.scm
diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index 143e7aa3e..207c79e2a 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -48,6 +48,7 @@
make-exception-with-message
exception-with-message?
exception-message
+ exception-stack
&warning
make-warning
@@ -154,6 +155,10 @@
make-exception-with-origin exception-with-origin?
(origin exception-origin))
+(define-exception-type &stack &exception
+ make-exception-with-stack exception-with-stack?
+ (stack exception-stack))
+
(define-exception-type-procedures &non-continuable &programming-error
make-non-continuable-error
non-continuable-error?)
@@ -198,7 +203,8 @@
(let ((converter (assv-ref guile-exception-converters key)))
(make-exception (or (and converter (converter key args))
(default-guile-exception-converter key args))
- (make-exception-with-kind-and-args key args))))
+ (make-exception-with-kind-and-args key args)
+ (make-exception-with-stack (make-stack #t 4)))))
(define (raise-continuable obj)
(raise-exception obj #:continuable? #t))
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 8d5a8a5f0..e2a2458c0 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -23,6 +23,7 @@
#:use-module (system base pmatch)
#:use-module (system vm trap-state)
#:use-module (system repl debug)
+ #:use-module (ice-9 exceptions)
#:use-module (ice-9 format)
#:export (call-with-error-handling
with-error-handling))
@@ -101,83 +102,109 @@
(run-hook after-error-hook)
(force-output err))))
- (catch #t
- (lambda ()
- (with-default-trap-handler le-trap-handler
- (lambda () (%start-stack #t thunk))))
-
+ (define post-error-handler
(case post-error
((report)
- (lambda (key . args)
- (if (memq key pass-keys)
- (apply throw key args)
- (begin
- (report-error key args)
- (if #f #f)))))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (when (memq key pass-keys)
+ (raise-exception exn))
+ (report-error key args)
+ (if #f #f))))
((catch)
- (lambda (key . args)
- (when (memq key pass-keys)
- (apply throw key args))
- (when (memq key report-keys)
- (report-error key args))
- (if #f #f)))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (when (memq key pass-keys)
+ (raise-exception exn))
+ (when (memq key report-keys)
+ (report-error key args))
+ (if #f #f))))
(else
(if (procedure? post-error)
- (lambda (k . args)
- (apply (if (memq k pass-keys) throw post-error) k args))
- (error "Unknown post-error strategy" post-error))))
-
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (when (memq key pass-keys)
+ (raise-exception exn))
+ (apply post-error key args)))
+ (error "Unknown post-error strategy" post-error)))))
+
+ (define on-error-handler
(case on-error
((debug)
- (lambda (key . args)
- (if (not (memq key pass-keys))
- (let* ((tag (and (pair? (fluid-ref %stacks))
- (cdr (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)))
- (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)))))))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdr (fluid-ref %stacks))))
+ (stack (or (exception-stack exn)
+ ;; Cut three frames from the top of the
stack:
+ ;; make-stack, this one, and the throw
handler.
+ (make-stack #t 3)))
+ (stack (narrow-stack->vector
+ stack
+ ;; Narrow the end of the stack to the most
recent
+ ;; start-stack.
+ 0 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)))
+ (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)
- (unless (memq key pass-keys)
- (report-error key args))
- (if #f #f)))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (unless (memq key pass-keys)
+ (report-error key args))
+ (if #f #f))))
((backtrace)
- (lambda (key . args)
- (if (not (memq key pass-keys))
- (let* ((tag (and (pair? (fluid-ref %stacks))
- (cdr (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)))
- (report-error key args)
- (if #f #f)))))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdr (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)))
+ (report-error key args)
+ (if #f #f))))))
((pass)
- (lambda (key . args)
+ (lambda (exn)
;; fall through to rethrow
#t))
(else
(if (procedure? on-error)
- (lambda (k . args)
- (apply (if (memq k pass-keys) throw on-error) k args))
- (error "Unknown on-error strategy" on-error)))))))
+ (lambda (exn)
+ (let ((key (exception-kind exn))
+ (args (exception-args exn)))
+ (when (memq k pass-keys)
+ (raise-exception exn))
+ (apply on-error key args)))
+ (error "Unknown on-error strategy" on-error)))))
+
+ (with-exception-handler post-error-handler
+ (lambda ()
+ (with-exception-handler
+ (lambda (exn)
+ (on-error-handler exn)
+ (raise-exception exn))
+ (lambda ()
+ (with-default-trap-handler le-trap-handler
+ (lambda () (%start-stack #t thunk))))))
+ #:unwind? #t)))
(define-syntax-rule (with-error-handling form)
(call-with-error-handling (lambda () form)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 35f264195..fb44e2841 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -54,6 +54,11 @@ SCM_TESTS = tests/00-initial-env.test \
tests/eval.test \
tests/eval-string.test \
tests/exceptions.test \
+ tests/exceptions.test \
+ tests/exceptions/error.scm \
+ tests/exceptions/error-with-throw-handler-1.scm \
+ tests/exceptions/error-with-throw-handler-2.scm \
+ tests/exceptions/error-with-throw-handler-3.scm \
tests/fdes-finalizers.test \
tests/filesys.test \
tests/fluids.test \
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index 291e10e26..66b7cfbdb 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -17,7 +17,8 @@
(define-module (test-suite exceptions)
- #:use-module (test-suite lib))
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 exceptions))
(define-syntax-parameter push
(lambda (stx)
@@ -392,3 +393,48 @@
(let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
(thunk2 (catch* 'bar (lambda () (thunk1)))))
(thunk2))))
+
+(with-test-prefix "exception location"
+ (define (test-file filename)
+ (string-append
+ (dirname (current-filename)) "/" filename))
+
+ (define (try-load filename)
+ (with-exception-handler values
+ (lambda ()
+ (load filename)
+ #f) ;; success is failure
+ #:unwind? #t))
+
+ (define (check-location expected)
+ (lambda (exn)
+ (pk exn)
+ (let* ((key (exception-kind exn))
+ (args (exception-args exn))
+ (stack (exception-stack exn))
+ (frame (and stack (stack-ref stack 0)))
+ (message (call-with-output-string
+ (lambda (port)
+ (print-exception port frame key args)))))
+ ;; (when stack
+ ;; (display-backtrace stack (current-warning-port)))
+ ;; (format (current-warning-port)
+ ;; "\n;;; message: ~s\n;;; expected: ~s\n\n"
+ ;; message expected)
+ (number? (string-contains message expected)))))
+
+ (pass-if "error"
+ (and=> (try-load (test-file "exceptions/error.scm"))
+ (check-location "exceptions/error.scm:1")))
+
+ (pass-if "error with one throw handler"
+ (and=> (try-load (test-file "exceptions/error-with-throw-handler-1.scm"))
+ (check-location "exceptions/error-with-throw-handler-1.scm:3")))
+
+ (pass-if "error with two throw handlers"
+ (and=> (try-load (test-file "exceptions/error-with-throw-handler-2.scm"))
+ (check-location "exceptions/error-with-throw-handler-2.scm:5")))
+
+ (pass-if "error with three throw handlers"
+ (and=> (try-load (test-file "exceptions/error-with-throw-handler-3.scm"))
+ (check-location "exceptions/error-with-throw-handler-3.scm:7"))))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-1.scm
b/test-suite/tests/exceptions/error-with-throw-handler-1.scm
new file mode 100644
index 000000000..4acaa7256
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-1.scm
@@ -0,0 +1,6 @@
+(with-throw-handler 'foo
+ (lambda ()
+ (error "whoops!"))
+ (lambda ()
+ ;; unused
+ (values)))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-2.scm
b/test-suite/tests/exceptions/error-with-throw-handler-2.scm
new file mode 100644
index 000000000..8dc04c081
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-2.scm
@@ -0,0 +1,11 @@
+(with-throw-handler 'bar
+ (lambda ()
+ (with-throw-handler 'foo
+ (lambda ()
+ (error "whoops!"))
+ (lambda ()
+ ;; unused
+ (values))))
+ (lambda ()
+ ;; unused
+ (values)))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-3.scm
b/test-suite/tests/exceptions/error-with-throw-handler-3.scm
new file mode 100644
index 000000000..62c8b033b
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-3.scm
@@ -0,0 +1,16 @@
+(with-throw-handler 'baz
+ (lambda ()
+ (with-throw-handler 'bar
+ (lambda ()
+ (with-throw-handler 'foo
+ (lambda ()
+ (error "whoops!"))
+ (lambda ()
+ ;; unused
+ (values))))
+ (lambda ()
+ ;; unused
+ (values))))
+ (lambda ()
+ ;; unused
+ (values)))
diff --git a/test-suite/tests/exceptions/error.scm
b/test-suite/tests/exceptions/error.scm
new file mode 100644
index 000000000..7ba405341
--- /dev/null
+++ b/test-suite/tests/exceptions/error.scm
@@ -0,0 +1 @@
+(error "whoops!")
--
2.38.0
