Add assembler

scmvm/assembler.scm

@@ -0,0 +1,49 @@
+(define-module (scmvm assembler)
+  #:use-module (srfi srfi-1)
+  #:use-module (scmvm vm)
+  #:use-module (rnrs bytevectors)
+  #: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 (instruction-size inst)
+  (case (instruction-type (lookup-instruction inst))
+    [(i j) 5]
+    [(o)   1]))
+
+(define instruction? pair?)
+(define label? (compose not instruction?))
+
+(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))]
+   [else
+    (find-labels (cdr inst-seq) (+ n (instruction-size (caar inst-seq))))]))
+
+(define (write-word word)
+  (define bv (make-bytevector 4))
+  (bytevector-s32-native-set! bv 0 word)
+  (write-bytevector bv))
+
+(define (assemble inst-seq)
+  (define labels (find-labels inst-seq 0))
+  (let loop ([seq inst-seq])
+    (cond
+     [(null? seq) '()]
+     [(label? (car seq)) (loop (cdr seq))]
+     [else
+      (let* [(inst (car seq))
+             (inst-obj (lookup-instruction (car inst)))]
+        (write-u8 (instruction-code inst-obj))
+        (case (instruction-type inst-obj)
+          [(i) (write-word (cadr inst))]
+          [(j) (write-word (assq-ref labels (cadr inst)))])
+        (loop (cdr seq)))])))