Move further code to common, rename to assembler (last restructure I promise)

scmvm/language/assembler.scm

@@ -1,69 +0,0 @@
-(define-module (scmvm language assembler)
-  #:use-module (scmvm vm)
-  #:use-module (scmvm language common)
-  #:use-module (srfi srfi-1)
-  #:use-module ((scheme base) #:select (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 (emit-instruction asm inst)
-  (let ([inst-object (lookup-instruction (car inst))])
-    (write-byte (instruction-code inst-object) asm)
-    (assembler-pos-set! asm (+ (assembler-pos asm) 1))
-    (when (not (null? (cdr inst)))
-      (if (number? (cadr inst))
-	  (write-word (cadr inst) asm)
-	  (begin
-	    (write-word 0 asm)
-	    (assembler-label-add-reference asm (cadr inst) (assembler-pos asm))))
-      (assembler-pos-set! asm (+ (assembler-pos asm) 4)))))
-
-(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)))
-      (write-word (third (car inst-seq)) asm)
-      (assembler-pos-set! asm (+ (assembler-pos asm) 4))]
-     [(ref? (car inst-seq))
-      (emit-instruction asm `(push ,(second (car inst-seq))))
-      (emit-instruction asm '(@))]
-     [(set!? (car inst-seq))
-      (emit-instruction asm `(push ,(second (car inst-seq))))
-      (emit-instruction asm '(!))]
-     [else
-      (emit-instruction asm (car inst-seq))])
-    (assemble-instructions asm (cdr inst-seq))))
-
-(define (assemble instructions port)
-  (define asm (make-assembler))
-  (assemble-instructions asm instructions)
-  (finalize-references asm)
-  (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm))
-  asm)

scmvm/language/assembly.scm

@@ -0,0 +1,60 @@
+(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))