(define-module (scmvm debugger)
  #:use-module (scmvm assembler)
  #:use-module (scmvm vm)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 control)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #: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-breakpoint-delete!
            debugger-continue))

(define-record-type <debugger>
  (make-debugger vm source breakpoints continuation)
  debugger?
  (vm debugger-vm)
  (source debugger-source)
  (breakpoints debugger-breakpoints)
  (continuation debugger-continuation debugger-continuation-set!))

(define (make-breakpoints labels)
  (define the-breakpoints '())
  (define (->index index/label)
    (if (number? index/label)
        index/label
        (assq-ref labels index/label)))
  (define-syntax-rule (ilambda (i) e ...)
    (lambda (v) (let ([i (->index v)]) e ...)))
  (match-lambda
    ['add
     (ilambda (i) (set! the-breakpoints (acons i #t the-breakpoints)))]
    ['delete
     (ilambda (i) (set! the-breakpoints (assq-remove! the-breakpoints i)))]
    ['enable
     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #t)))]
    ['disable
     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #f)))]
    ['ref
     (ilambda (i) (assq-ref the-breakpoints i))]))

(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
      (if (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger)))
          (debugger-continuation-set! the-debugger k)
          (k))))
  (define vm (make-vm #:debugger debug))
  (vm-load-program! vm prgm)
  (set! the-debugger (make-debugger vm source (make-breakpoints symbols) #f))
  (reset (run-vm vm))
  the-debugger)

(define (debugger-continue debugger)
  ((debugger-continuation debugger)))

(define (debugger-breakpoint-add! debugger breakpoint)
  (((debugger-breakpoints debugger) 'add) breakpoint))

(define (debugger-breakpoint-ref debugger breakpoint)
  (((debugger-breakpoints debugger) 'ref) breakpoint))

(define (debugger-breakpoint-enable! debugger breakpoint)
  (((debugger-breakpoints debugger) 'enable) breakpoint))

(define (debugger-breakpoint-disable! debugger breakpoint)
  (((debugger-breakpoints debugger) 'disable) breakpoint))

(define (debugger-breakpoint-delete! debugger breakpoint)
  (((debugger-breakpoints debugger) 'delete) breakpoint))