69 lines
2.5 KiB
Scheme
69 lines
2.5 KiB
Scheme
(define-module (scmvm debugger)
|
|
#:use-module (scmvm assembler)
|
|
#:use-module (scmvm vm)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (ice-9 control)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 exceptions)
|
|
#:export ((make-debugger* . make-debugger)
|
|
debugger-vm
|
|
debugger-source
|
|
debugger-breakpoints debugger-breakpoints-set!
|
|
debugger-breakpoint-add! debugger-breakpoint-ref
|
|
debugger-breakpoint-enable! debugger-breakpoint-disable!
|
|
debugger-continue))
|
|
|
|
(define-record-type <debugger>
|
|
(make-debugger vm source breakpoints continuation)
|
|
debugger?
|
|
(vm debugger-vm)
|
|
(source debugger-source)
|
|
(breakpoints debugger-breakpoints debugger-breakpoints-set!)
|
|
(continuation debugger-continuation debugger-continuation-set!))
|
|
|
|
(define (make-debugger* source)
|
|
(define-values (prgm symbols)
|
|
(call-with-values open-bytevector-output-port
|
|
(lambda (port get-bv)
|
|
(define symbols (assemble source port))
|
|
(values (get-bv) symbols))))
|
|
(define the-debugger #f)
|
|
(define (debug)
|
|
(shift k
|
|
(debugger-continuation-set! the-debugger k)
|
|
(when (not (assq-ref (debugger-breakpoints the-debugger)
|
|
(vm-pc (debugger-vm the-debugger))))
|
|
(k))))
|
|
(define vm (make-vm #:debugger debug))
|
|
(vm-load-program! vm prgm)
|
|
(set! the-debugger (make-debugger vm source '((1 . #t)) #f))
|
|
(reset (run-vm vm))
|
|
the-debugger)
|
|
|
|
(define (debugger-continue debugger)
|
|
((debugger-continuation debugger)))
|
|
|
|
(define* (debugger-breakpoint-add! debugger breakpoint #:key (enabled? #f))
|
|
(debugger-breakpoints-set!
|
|
debugger
|
|
(assq-set! (debugger-breakpoints debugger) breakpoint enabled?)))
|
|
|
|
(define (debugger-breakpoint-ref debugger breakpoint)
|
|
(assq breakpoint (debugger-breakpoints debugger)))
|
|
|
|
(define (debugger-breakpoint-enable! debugger breakpoint)
|
|
(define breakpoints (debugger-breakpoints debugger))
|
|
(if (pair? (assq breakpoints breakpoint))
|
|
(assq-set! breakpoints breakpoint #t)
|
|
(raise-exception (make-exception
|
|
(make-error)
|
|
(make-exception-with-message "Cannot enable nonexistant breakpoint")))))
|
|
|
|
(define (debugger-breakpoint-disable! debugger breakpoint)
|
|
(define breakpoints (debugger-breakpoints debugger))
|
|
(if (pair? (assq breakpoints breakpoint))
|
|
(assq-set! breakpoints breakpoint #f)
|
|
(raise-exception (make-exception
|
|
(make-error)
|
|
(make-exception-with-message "Cannot disable nonexistant breakpoint")))))
|