diff options
author | Andy Wingo <wingo@pobox.com> | 2010-07-10 12:21:50 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-07-10 12:21:50 +0200 |
commit | 5273854080c0536563ca1538716a1e18dfde187b (patch) | |
tree | 260d25c331504b94c29b5aac6a44160ed205b33d | |
parent | dc3b2661183786587350b19b97aefeec556cc54e (diff) | |
download | guile-5273854080c0536563ca1538716a1e18dfde187b.tar.gz |
finally, backtraces only showing frames for the computation
* module/system/repl/repl.scm (run-repl): Run the thunk in a stack in a
prompt, similar to the default prompt. Gives proper backtraces.
* module/system/repl/error-handling.scm (call-with-error-handling):
Narrow one more outer frame, for the %start-stack thunk invocation.
* module/ice-9/boot-9.scm (%start-stack): Reindent.
-rw-r--r-- | module/ice-9/boot-9.scm | 2 | ||||
-rw-r--r-- | module/system/repl/error-handling.scm | 22 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 8 |
3 files changed, 21 insertions, 11 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f8b3eb064..e7ef9235a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1056,7 +1056,7 @@ If there is no handler at all, Guile prints an error and then exits." (or (fluid-ref %stacks) '())))) (thunk))) (lambda (k . args) - (%start-stack tag (lambda () (apply k args))))))) + (%start-stack tag (lambda () (apply k args))))))) (define-syntax start-stack (syntax-rules () ((_ tag exp) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index d7d43bd71..28b542830 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -88,15 +88,19 @@ (format #t " or `,q' to return to the old prompt.\n") (let ((debug (make-debug - (narrow-stack->vector - stack - ;; 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. - (and (pair? (fluid-ref %stacks)) - (cdar (fluid-ref %stacks)))) + (let ((tag (and (pair? (fluid-ref %stacks)) + (cdar (fluid-ref %stacks))))) + (narrow-stack->vector + stack + ;; 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))) 0))) ((@ (system repl repl) start-repl) #:debug debug))))))) ((pass) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index fba67764f..21998ba5d 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -106,6 +106,12 @@ (abort)))))) (define (run-repl repl) + (define (with-stack-and-prompt thunk) + (call-with-prompt (default-prompt-tag) + (lambda () (start-stack #t (thunk))) + (lambda (k proc) + (with-stack-and-prompt (lambda () (proc k)))))) + (% (with-fluids ((*repl-stack* (cons repl (or (fluid-ref *repl-stack*) '())))) (if (null? (cdr (fluid-ref *repl-stack*))) @@ -140,7 +146,7 @@ (repl-parse repl exp)))))) (run-hook before-eval-hook exp) (with-error-handling - (start-stack #t (% (thunk))))) + (with-stack-and-prompt thunk))) (lambda (k) (values)))) (lambda l (for-each (lambda (v) |