(define-module (scmvm language common)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-9)
  #:use-module (rnrs bytevectors)
  #:export (<assembler>
	    (make-assembler* . make-assembler)
	    assembler?
	    assembler-labels
	    assembler-pos
	    assembler-buf
	    assembler-pos-set!
	    assembler-buf-set!
	    assembler-label-add-reference
	    assembler-label-add-value
	    write-byte
	    write-word
	    emit-label
	    finalize-references))

(define (make-label) (cons #f '()))

(define-record-type <assembler>
  (make-assembler pos buf labels)
  assembler?
  (pos assembler-pos assembler-pos-set!)
  (buf assembler-buf assembler-buf-set!)
  (labels assembler-labels))

(define (make-assembler*)
  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))

(define (assembler-buf-grow! asm)
  (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))])
    (bytevector-copy! (assembler-buf asm) 0 buf 0 (bytevector-length (assembler-buf asm)))
    (assembler-buf-set! asm buf)))

(define* (write-word word asm #:optional (pos (assembler-pos asm)))
  (when (> (+ pos 4) (bytevector-length (assembler-buf asm)))
    (assembler-buf-grow! asm))
  (bytevector-u32-native-set! (assembler-buf asm) pos word))

(define* (write-byte byte asm #:optional (pos (assembler-pos asm)))
  (when (> (+ pos 1) (bytevector-length (assembler-buf asm)))
    (assembler-buf-grow! asm))
  (bytevector-u8-set! (assembler-buf asm) pos byte))

(define (assembler-label-add-reference asm name addr)
  (when (not (hash-ref (assembler-labels asm) name))
    (hash-set! (assembler-labels asm) name (make-label)))
  (let ([label (hash-ref (assembler-labels asm) name)])
    (set-cdr! label (cons addr (cdr label)))))

(define (assembler-label-add-value asm name val)
  (when (not (hash-ref (assembler-labels asm) name))
    (hash-set! (assembler-labels asm) name (make-label)))
  ;; 1+ to fudge for null pointers
  (set-car! (hash-ref (assembler-labels asm) name) (1+ val)))

(define (finalize-references asm)
  (define (install-location _name label)
    (for-each
     (cute write-word (car label) asm <>)
     (cdr label)))
  (hash-for-each install-location (assembler-labels asm)))

(define (emit-label asm name)
  (assembler-label-add-value asm name (assembler-pos asm)))