Project restructuring to support the new direction

scmvm/language/assembler.scm

@@ -0,0 +1,88 @@
+(define-module (scmvm language 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 *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? (compose not 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 (instruction? x)
+  (and (not (label? x))
+       (not (variable? x))
+       (not (ref? x))
+       (not (set!? x))))
+(define (instruction-size inst)
+  (case (car inst)
+    [(push) 5]
+    [(ref set!) 6]
+    [else 1]))
+
+(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) (+ address (instruction-size (car instructions))))]))
+
+(define (write-word word)
+  (define bv (make-bytevector 4))
+  (bytevector-u32-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)]
+   [(ref? (car seq))
+    (write-u8 (cadr (lookup-instruction 'push)))
+    (write-word (assq-ref labels (cadar seq)))
+    (write-u8 (cadr (lookup-instruction '@)))
+    (assembly-pass (cdr seq) labels)]
+   [(set!? (car seq))
+    (write-u8 (cadr (lookup-instruction 'push)))
+    (write-word (assq-ref labels (cadar seq)))
+    (write-u8 (cadr (lookup-instruction '!)))
+    (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))
+            (let ([address (assq-ref labels (cadr inst))])
+              (if address
+                  (write-word (assq-ref labels (cadr inst)))
+                  (error (format #f "Could not find label ~a" (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)