mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
breakpoints from recursive prompts work
* module/system/vm/traps.scm (new-disabled-trap): Don't manipulate the VM trace level in the enable and disable handlers. Unfortunately, this makes traps not work unless you enable hooks, but given that vm_dispatch_hook has to set trace-level to 0, there needs to be an object with a broader view of what traps are enabled. That object is the hook state. * module/system/vm/trap-state.scm (trap-state->trace-level): New procedure. (with-default-trap-handler): Add an optional trap-state argument. Now makes sure that the vm-trace-level is set appropriately during the execution of the thunk, allowing for breakpoints from recursive prompts.
This commit is contained in:
parent
194865d2f7
commit
65bce23759
2 changed files with 19 additions and 6 deletions
|
@ -22,6 +22,7 @@
|
|||
|
||||
(define-module (system vm trap-state)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:use-module (system vm vm)
|
||||
#:use-module (system vm traps)
|
||||
#:export (list-traps
|
||||
|
@ -37,10 +38,6 @@
|
|||
|
||||
(define %default-trap-handler (make-fluid))
|
||||
|
||||
(define (with-default-trap-handler handler thunk)
|
||||
(with-fluids ((%default-trap-handler handler))
|
||||
(thunk)))
|
||||
|
||||
(define (default-trap-handler frame idx trap-name)
|
||||
(let ((default-handler (fluid-ref %default-trap-handler)))
|
||||
(if default-handler
|
||||
|
@ -87,6 +84,14 @@
|
|||
(define (remove-trap-wrapper! trap-state wrapper)
|
||||
(delq wrapper (trap-state-wrappers trap-state)))
|
||||
|
||||
(define (trap-state->trace-level trap-state)
|
||||
(fold (lambda (wrapper level)
|
||||
(if (trap-wrapper-enabled? wrapper)
|
||||
(1+ level)
|
||||
level))
|
||||
0
|
||||
(trap-state-wrappers trap-state)))
|
||||
|
||||
(define (wrapper-at-index trap-state idx)
|
||||
(let lp ((wrappers (trap-state-wrappers trap-state)))
|
||||
(cond
|
||||
|
@ -135,6 +140,16 @@
|
|||
;;; API
|
||||
;;;
|
||||
|
||||
(define* (with-default-trap-handler handler thunk
|
||||
#:optional (trap-state (the-trap-state)))
|
||||
(with-fluids ((%default-trap-handler handler))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state)))
|
||||
thunk
|
||||
(lambda ()
|
||||
(set-vm-trace-level! (the-vm) 0)))))
|
||||
|
||||
(define* (list-traps #:optional (trap-state (the-trap-state)))
|
||||
(map (lambda (wrapper)
|
||||
(cons (trap-wrapper-index wrapper)
|
||||
|
|
|
@ -87,14 +87,12 @@
|
|||
(define* (enable-trap #:optional frame)
|
||||
(if enabled? (error "trap already enabled"))
|
||||
(enable frame)
|
||||
(set-vm-trace-level! vm (1+ (vm-trace-level vm)))
|
||||
(set! enabled? #t)
|
||||
disable-trap)
|
||||
|
||||
(define* (disable-trap #:optional frame)
|
||||
(if disabled? (error "trap already disabled"))
|
||||
(disable frame)
|
||||
(set-vm-trace-level! vm (1- (vm-trace-level vm)))
|
||||
(set! disabled? #t)
|
||||
enable-trap)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue