(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-step debugger-continue))

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

(define* (make-breakpoints #:optional (convert identity))
  (define the-breakpoints (make-hash-table))
  (match-lambda
    [(or 'add 'enable) (lambda (key) (hashq-set! the-breakpoints (convert key) #t))]
    ['disable (lambda (key) (hashq-set! the-breakpoints (convert key) #f))]
    ['delete (lambda (key) (hashq-remove! the-breakpoints (convert key)))]
    ['ref (lambda (key) (hashq-ref the-breakpoints (convert key) #f))]))

(define (label-converter asm)
  (lambda (index/label)
    (if (number? index/label)
        index/label
        (car (hash-ref (assembler-labels asm) index/label)))))

(define (make-debugger* asm)
  (define prgm
    (call-with-values open-bytevector-output-port
      (lambda (port get-bv)
	(assembler-dump-program asm port)
	(get-bv))))
  (define the-debugger #f)
  (define (debug)
    (shift k
           (if (or (debugger-stepping? the-debugger)
                   (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger))))
               (debugger-continuation-set! the-debugger k)
               (k))))
  (define vm (make-vm (assembler-instruction-set asm) #:debugger debug))
  (vm-load-program! vm prgm)
  (set! the-debugger (make-debugger vm asm (make-breakpoints (label-converter asm)) #f #f))
  (debugger-breakpoint-add! the-debugger 1)
  (reset (run-vm vm))
  the-debugger)

(define (debugger-continue debugger)
  (debugger-stepping-set! debugger #f)
  ((debugger-continuation debugger)))

(define (debugger-step debugger)
  (debugger-stepping-set! debugger #t)
  ((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))