mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

Do not enter the debugger if the thrown key is in `pass-keys'

Browse source 
* module/system/repl/error-handling.scm (call-with-error-handling):
  Do _not_ enter the debugger if the thrown key is in `pass-keys'.
  Previously, for example, (throw 'quit) entered the debugger when run
  from the REPL, despite the fact that 'quit is in `pass-keys'.
This commit is contained in:
Mark H Weaver 2011-03-22 11:11:53 -04:00
parent 190d4b0d93
commit 8099352769
1 changed files with 22 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -122,27 +122,28 @@
(case on-error (case on-error
((debug) ((debug)
(lambda (key . args) (lambda (key . args)
(let* ((tag (and (pair? (fluid-ref %stacks)) (if (not (memq key pass-keys))
(cdar (fluid-ref %stacks)))) (let* ((tag (and (pair? (fluid-ref %stacks))
(stack (narrow-stack->vector (cdar (fluid-ref %stacks))))
(make-stack #t) (stack (narrow-stack->vector
;; Cut three frames from the top of the stack: (make-stack #t)
;; make-stack, this one, and the throw handler. ;; Cut three frames from the top of the stack:
3 ;; make-stack, this one, and the throw handler.
;; Narrow the end of the stack to the most recent 3
;; start-stack. ;; Narrow the end of the stack to the most recent
tag ;; start-stack.
;; And one more frame, because %start-stack invoking tag
;; the start-stack thunk has its own frame too. ;; And one more frame, because %start-stack invoking
0 (and tag 1))) ;; the start-stack thunk has its own frame too.
(error-msg (error-string stack key args)) 0 (and tag 1)))
(debug (make-debug stack 0 error-msg #f))) (error-msg (error-string stack key args))
(with-saved-ports (debug (make-debug stack 0 error-msg #f)))
(lambda () (with-saved-ports
(format #t "~a~%" error-msg) (lambda ()
(format #t "Entering a new prompt. ") (format #t "~a~%" error-msg)
(format #t "Type `,bt' for a backtrace or `,q' to continue.\n") (format #t "Entering a new prompt. ")
((@ (system repl repl) start-repl) #:debug debug)))))) (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
((@ (system repl repl) start-repl) #:debug debug)))))))
((report) ((report)
(lambda (key . args) (lambda (key . args)
(if (not (memq key pass-keys)) (if (not (memq key pass-keys))