(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")))))