mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-13 15:10:34 +02:00
Code Activity

finally, backtraces only showing frames for the computation

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-07-10 12:21:50 +02:00
parent dc3b266118
commit 5273854080
3 changed files with 21 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/ice-9/boot-9.scm
View file

@ -1056,7 +1056,7 @@ If there is no handler at all, Guile prints an error and then exits."
(or (fluid-ref %stacks) '())))) (or (fluid-ref %stacks) '()))))
(thunk))) (thunk)))
(lambda (k . args) (lambda (k . args)
(%start-stack tag (lambda () (apply k args))))))) (%start-stack tag (lambda () (apply k args)))))))
(define-syntax start-stack (define-syntax start-stack
(syntax-rules () (syntax-rules ()
((_ tag exp) ((_ tag exp)

22
module/system/repl/error-handling.scm
View file

@ -88,15 +88,19 @@
(format #t " or `,q' to return to the old prompt.\n") (format #t " or `,q' to return to the old prompt.\n")
(let ((debug (let ((debug
(make-debug (make-debug
(narrow-stack->vector (let ((tag (and (pair? (fluid-ref %stacks))
stack (cdar (fluid-ref %stacks)))))
;; Cut three frames from the top of the stack: (narrow-stack->vector
;; make-stack, this one, and the throw handler. stack
3 ;; Cut three frames from the top of the stack:
;; Narrow the end of the stack to the most recent ;; make-stack, this one, and the throw handler.
;; start-stack. 3
(and (pair? (fluid-ref %stacks)) ;; Narrow the end of the stack to the most recent
(cdar (fluid-ref %stacks)))) ;; 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))) 0)))
((@ (system repl repl) start-repl) #:debug debug))))))) ((@ (system repl repl) start-repl) #:debug debug)))))))
((pass) ((pass)

8
module/system/repl/repl.scm
View file

@ -106,6 +106,12 @@
(abort)))))) (abort))))))
(define (run-repl repl) (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* (% (with-fluids ((*repl-stack*
(cons repl (or (fluid-ref *repl-stack*) '())))) (cons repl (or (fluid-ref *repl-stack*) '()))))
(if (null? (cdr (fluid-ref *repl-stack*))) (if (null? (cdr (fluid-ref *repl-stack*)))
@ -140,7 +146,7 @@
(repl-parse repl exp)))))) (repl-parse repl exp))))))
(run-hook before-eval-hook exp) (run-hook before-eval-hook exp)
(with-error-handling (with-error-handling
(start-stack #t (% (thunk))))) (with-stack-and-prompt thunk)))
(lambda (k) (values)))) (lambda (k) (values))))
(lambda l (lambda l
(for-each (lambda (v) (for-each (lambda (v)