mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 06:41:13 +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)
|
(define-module (system vm trap-state)
|
||||||
#:use-module (system base syntax)
|
#:use-module (system base syntax)
|
||||||
|
#:use-module ((srfi srfi-1) #:select (fold))
|
||||||
#:use-module (system vm vm)
|
#:use-module (system vm vm)
|
||||||
#:use-module (system vm traps)
|
#:use-module (system vm traps)
|
||||||
#:export (list-traps
|
#:export (list-traps
|
||||||
|
@ -37,10 +38,6 @@
|
||||||
|
|
||||||
(define %default-trap-handler (make-fluid))
|
(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)
|
(define (default-trap-handler frame idx trap-name)
|
||||||
(let ((default-handler (fluid-ref %default-trap-handler)))
|
(let ((default-handler (fluid-ref %default-trap-handler)))
|
||||||
(if default-handler
|
(if default-handler
|
||||||
|
@ -87,6 +84,14 @@
|
||||||
(define (remove-trap-wrapper! trap-state wrapper)
|
(define (remove-trap-wrapper! trap-state wrapper)
|
||||||
(delq wrapper (trap-state-wrappers trap-state)))
|
(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)
|
(define (wrapper-at-index trap-state idx)
|
||||||
(let lp ((wrappers (trap-state-wrappers trap-state)))
|
(let lp ((wrappers (trap-state-wrappers trap-state)))
|
||||||
(cond
|
(cond
|
||||||
|
@ -135,6 +140,16 @@
|
||||||
;;; API
|
;;; 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)))
|
(define* (list-traps #:optional (trap-state (the-trap-state)))
|
||||||
(map (lambda (wrapper)
|
(map (lambda (wrapper)
|
||||||
(cons (trap-wrapper-index wrapper)
|
(cons (trap-wrapper-index wrapper)
|
||||||
|
|
|
@ -87,14 +87,12 @@
|
||||||
(define* (enable-trap #:optional frame)
|
(define* (enable-trap #:optional frame)
|
||||||
(if enabled? (error "trap already enabled"))
|
(if enabled? (error "trap already enabled"))
|
||||||
(enable frame)
|
(enable frame)
|
||||||
(set-vm-trace-level! vm (1+ (vm-trace-level vm)))
|
|
||||||
(set! enabled? #t)
|
(set! enabled? #t)
|
||||||
disable-trap)
|
disable-trap)
|
||||||
|
|
||||||
(define* (disable-trap #:optional frame)
|
(define* (disable-trap #:optional frame)
|
||||||
(if disabled? (error "trap already disabled"))
|
(if disabled? (error "trap already disabled"))
|
||||||
(disable frame)
|
(disable frame)
|
||||||
(set-vm-trace-level! vm (1- (vm-trace-level vm)))
|
|
||||||
(set! disabled? #t)
|
(set! disabled? #t)
|
||||||
enable-trap)
|
enable-trap)
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue