(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 (label-pass instructions address)
  (cond
   [(null? instructions) '()]
   [(label? (car instructions))
    (acons (car instructions) address (label-pass (cdr instructions) address))]
   [(variable? (car instructions))
    (acons (cadar instructions) address (label-pass (cdr instructions) (+ address 4)))]
   [else
    (label-pass (cdr instructions) (if (eq? (caar instructions) 'push)
                                       (+ address 5)
                                       (+ address 1)))]))

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

(define (assembly-pass seq labels)
  (cond
   [(null? seq) '()]
   [(label? (car seq)) (assembly-pass (cdr seq) labels)]
   [(variable? (car seq))
    (write-word (caddar seq))
    (assembly-pass (cdr seq) labels)]
   [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)))))
      (assembly-pass (cdr seq) labels))]))

(define (assemble instructions port)
  (define labels (label-pass instructions 1))
  (with-output-to-port port (lambda () (assembly-pass instructions labels)))
  labels)