summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-07-10 12:21:50 +0200
committerAndy Wingo <wingo@pobox.com>2010-07-10 12:21:50 +0200
commit5273854080c0536563ca1538716a1e18dfde187b (patch)
tree260d25c331504b94c29b5aac6a44160ed205b33d
parentdc3b2661183786587350b19b97aefeec556cc54e (diff)
downloadguile-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.scm2
-rw-r--r--module/system/repl/error-handling.scm22
-rw-r--r--module/system/repl/repl.scm8
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)