(define-module (scmvm assembler)
  #:use-module (srfi srfi-1)
  #:use-module (scmvm vm)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module ((scheme base)
                #:select (write-u8 write-bytevector))
  #:export (assemble))

(define (lookup-instruction inst)
  (define inst-obj (assq inst *instruction-set*))
  (if inst-obj
      inst-obj
      (error (format #f "could not find instruction ~a" inst))))

(define label? (compose not pair?))
(define (variable? x)
  (and (pair? x) (eq? (car x) 'variable)))
(define (instruction? x)
  (and (not (label? x))
       (not (variable? x))))

(define (find-labels inst-seq n)
  (cond
   [(null? inst-seq) '()]
   [(label? (car inst-seq))
    (acons (car inst-seq) n (find-labels (cdr inst-seq) n))]
   [(variable? (car inst-seq))
    (acons (cadar inst-seq) n (find-labels (cdr inst-seq) (+ n 4)))]
   [else
    (find-labels (cdr inst-seq) (if (eq? (caar inst-seq) 'push) (+ n 5) (+ n 1)))]))

(define (write-word word)
  (define bv (make-bytevector 4))
  (bytevector-s32-native-set! bv 0 word)
  (write-bytevector bv))

(define (assemble inst-seq port)
  (define labels (find-labels inst-seq 1))
  (with-output-to-port port
    (lambda ()
      (let loop ([seq inst-seq])
        (cond
         [(null? seq) '()]
         [(label? (car seq)) (loop (cdr seq))]
         [(variable? (car seq))
          (write-word (caddar seq))
          (loop (cdr seq))]
         [else
          (let* [(inst (car seq))
                 (inst-obj (lookup-instruction (car inst)))]
            (write-u8 (instruction-code inst-obj))
            (when (eq? (car inst) 'push)
              (if (number? (cadr inst))
                  (write-word (cadr inst))
                  (write-word (assq-ref labels (cadr inst)))))
            (loop (cdr seq)))]))))
  labels)