diff options
-rw-r--r-- | module/ice-9/boot-9.scm | 14 | ||||
-rw-r--r-- | module/ice-9/debugger.scm | 8 | ||||
-rwxr-xr-x | module/ice-9/debugging/traps.scm | 26 | ||||
-rw-r--r-- | module/ice-9/stack-catch.scm | 2 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 52 |
5 files changed, 47 insertions, 55 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index be67560dd..0cf83e6d6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2323,12 +2323,12 @@ module '(ice-9 q) '(make-q q-length))}." (define (set-repl-prompt! v) (set! scm-repl-prompt v)) -(define (default-lazy-handler key . args) - (save-stack lazy-handler-dispatch) +(define (default-pre-unwind-handler key . args) + (save-stack pre-unwind-handler-dispatch) (apply throw key args)) -(define (lazy-handler-dispatch key . args) - (apply default-lazy-handler key args)) +(define (pre-unwind-handler-dispatch key . args) + (apply default-pre-unwind-handler key args)) (define abort-hook (make-hook)) @@ -2405,15 +2405,15 @@ module '(ice-9 q) '(make-q q-length))}." (else (apply bad-throw key args))))))) - ;; Note that having just `lazy-handler-dispatch' + ;; Note that having just `pre-unwind-handler-dispatch' ;; here is connected with the mechanism that ;; produces a nice backtrace upon error. If, for ;; example, this is replaced with (lambda args - ;; (apply lazy-handler-dispatch args)), the stack + ;; (apply pre-unwind-handler-dispatch args)), the stack ;; cutting (in save-stack) goes wrong and ends up ;; saving no stack at all, so there is no ;; backtrace. - lazy-handler-dispatch))) + pre-unwind-handler-dispatch))) (if next (loop next) status))) (set! set-batch-mode?! (lambda (arg) diff --git a/module/ice-9/debugger.scm b/module/ice-9/debugger.scm index 0ad014881..3dddd9030 100644 --- a/module/ice-9/debugger.scm +++ b/module/ice-9/debugger.scm @@ -131,16 +131,16 @@ Indicates that the debugger should display an introductory message. (define (debug-on-error syms) "Enable or disable debug on error." - (set! lazy-handler-dispatch + (set! pre-unwind-handler-dispatch (if syms (lambda (key . args) (if (memq key syms) (begin - (debug-stack (make-stack #t lazy-handler-dispatch) + (debug-stack (make-stack #t pre-unwind-handler-dispatch) #:with-introduction #:continuable) (throw 'abort key))) - (apply default-lazy-handler key args)) - default-lazy-handler))) + (apply default-pre-unwind-handler key args)) + default-pre-unwind-handler))) ;;; (ice-9 debugger) ends here. diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm index 080d7bc31..ae1673688 100755 --- a/module/ice-9/debugging/traps.scm +++ b/module/ice-9/debugging/traps.scm @@ -59,7 +59,7 @@ trap-ordering behaviour-ordering throw->trap-context - on-lazy-handler-dispatch + on-pre-unwind-handler-dispatch ;; Interface for authors of new <trap> subclasses. <trap-context> <trap> @@ -467,14 +467,14 @@ it twice." ;;; same code for certain events that are trap-like, but not actually ;;; traps in the sense of the calls made by libguile's evaluator. -;;; The main example of this is when an error is signalled. Guile -;;; doesn't yet have a 100% reliable way of hooking into errors, but -;;; in practice most errors go through a lazy-catch whose handler is -;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn -;;; calls default-lazy-handler. So we can present most errors as -;;; pseudo-traps by modifying default-lazy-handler. +;;; The main example of this is when an error is signalled. Guile +;;; doesn't yet have a 100% reliable way of hooking into errors, but in +;;; practice most errors go through a catch whose pre-unwind handler is +;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in +;;; turn calls default-pre-unwind-handler. So we can present most errors +;;; as pseudo-traps by modifying default-pre-unwind-handler. -(define default-default-lazy-handler default-lazy-handler) +(define default-default-pre-unwind-handler default-pre-unwind-handler) (define (throw->trap-context key args . stack-args) (let ((ctx (make <trap-context> @@ -489,16 +489,16 @@ it twice." (apply make-stack #t stack-args)))) ctx)) -(define (on-lazy-handler-dispatch behaviour . ignored-keys) - (set! default-lazy-handler +(define (on-pre-unwind-handler-dispatch behaviour . ignored-keys) + (set! default-pre-unwind-handler (if behaviour (lambda (key . args) (or (memq key ignored-keys) (behaviour (throw->trap-context key args - lazy-handler-dispatch))) - (apply default-default-lazy-handler key args)) - default-default-lazy-handler))) + pre-unwind-handler-dispatch))) + (apply default-default-pre-unwind-handler key args)) + default-default-pre-unwind-handler))) ;;; {Trap Classes} diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm index 81faca063..2f4b3d145 100644 --- a/module/ice-9/stack-catch.scm +++ b/module/ice-9/stack-catch.scm @@ -40,4 +40,4 @@ this call to @code{catch}." (catch key thunk handler - lazy-handler-dispatch)) + pre-unwind-handler-dispatch)) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 379b52647..60659f9db 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -51,11 +51,6 @@ (with-fluid* current-reader (meta-reader lread) (lambda () (repl-reader (lambda () (repl-prompt repl))))))) -(define (default-pre-unwind-handler key . args) - (save-stack default-pre-unwind-handler) - (vm-save-stack (the-vm)) - (apply throw key args)) - (define (default-catch-handler . args) (pmatch args ((quit . _) @@ -66,8 +61,6 @@ (apply format #t msg args) (newline)) ((,key ,subr ,msg ,args . ,rest) - (vm-backtrace (the-vm)) - (newline) (let ((cep (current-error-port))) (cond ((not (stack? (fluid-ref the-last-stack)))) ((memq 'backtrace (debug-options-interface)) @@ -93,43 +86,42 @@ (define (call-with-backtrace thunk) (catch #t - thunk + (lambda () (%start-stack #t thunk)) default-catch-handler - default-pre-unwind-handler)) + pre-unwind-handler-dispatch)) + +(define-macro (with-backtrace form) + `(call-with-backtrace (lambda () ,form))) (define (start-repl lang) (let ((repl (make-repl lang)) (status #f)) (repl-welcome repl) (let prompt-loop () - (let ((exp (call-with-backtrace - (lambda () (prompting-meta-read repl))))) + (let ((exp (with-backtrace (prompting-meta-read repl)))) (cond ((eqv? exp (if #f #f))) ; read error, pass ((eq? exp meta-command-token) - (call-with-backtrace - (lambda () - (meta-command repl (read-line))))) + (with-backtrace (meta-command repl (read-line)))) ((eof-object? exp) (newline) (set! status '())) (else - (call-with-backtrace - (lambda () - (catch 'quit - (lambda () - (call-with-values (lambda () - (run-hook before-eval-hook exp) - (start-stack repl-eval - (repl-eval repl - (repl-parse repl exp)))) - (lambda l - (for-each (lambda (v) - (run-hook before-print-hook v) - (repl-print repl v)) - l)))) - (lambda (k . args) - (set! status args))))))) + (with-backtrace + (catch 'quit + (lambda () + (call-with-values + (lambda () + (run-hook before-eval-hook exp) + (start-stack #t + (repl-eval repl (repl-parse repl exp)))) + (lambda l + (for-each (lambda (v) + (run-hook before-print-hook v) + (repl-print repl v)) + l)))) + (lambda (k . args) + (set! status args)))))) (or status (begin (next-char #f) ;; consume trailing whitespace |