summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/boot-9.scm14
-rw-r--r--module/ice-9/debugger.scm8
-rwxr-xr-xmodule/ice-9/debugging/traps.scm26
-rw-r--r--module/ice-9/stack-catch.scm2
-rw-r--r--module/system/repl/repl.scm52
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