(define-module (scmvm language assembly)
  #:use-module (scmvm vm)
  #:use-module (scmvm assembler)
  #:use-module (srfi srfi-1)
  #:use-module ((scheme base) #:select (write-bytevector))
  #:export (assemble assemble-instructions))

(define *aliases*
  '((if . branch)))

(define (or-alias inst)
  (or (assq-ref *aliases* inst) inst))

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

(define label? (negate pair?))
(define (variable? x)
  (and (pair? x) (eq? (car x) 'variable)))
(define (ref? x)
  (and (pair? x) (eq? (car x) 'ref)))
(define (set!? x)
  (and (pair? x) (eq? (car x) 'set!)))
(define (push? x)
  (and (pair? x) (eq? (car x) 'push)))

(define (emit-push asm v)
  (emit-instruction asm 'push)
  (if (number? v)
      (emit-literal asm v)
      (emit-reference asm v)))

(define (assemble-instructions asm inst-seq)
  (when (pair? inst-seq)
    (cond
     [(label? (car inst-seq))
      (emit-label asm (car inst-seq))]
     [(variable? (car inst-seq))
      (emit-label asm (second (car inst-seq)))
      (emit-literal asm (third (car inst-seq)))]
     [(ref? (car inst-seq))
      (emit-push asm (second (car inst-seq)))
      (emit-instruction asm '@)]
     [(set!? (car inst-seq))
      (emit-push asm (second (car inst-seq)))
      (emit-instruction asm '!)]
     [(push? (car inst-seq))
      (emit-push asm (second (car inst-seq)))]
     [else
      (emit-instruction asm (instruction-name (lookup-instruction (first (car inst-seq)))))])
    (assemble-instructions asm (cdr inst-seq))))

(define (assemble instructions port)
  (define asm (make-assembler))
  (assemble-instructions asm instructions)
  (finalize-references asm)
  (assembler-dump-program asm port))