asm/fib.scm

@@ -1,5 +1,6 @@
   (variable result 0)
-  (ref result)
+  (push result)
+  (@)
   (push fib)
   (call)
   (push cleanup)
@@ -30,5 +31,6 @@ recur
   (nip)
   (return)
 cleanup
-  (set! result)
+  (push result)
+  (!)
   (bye)

scmvm/assembler.scm

@@ -16,64 +16,43 @@
 (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]))
+       (not (variable? x))))
 
-(define (label-pass instructions address)
+(define (find-labels inst-seq n)
   (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)))]
+   [(null? inst-seq) '()]
+   [(label? (car inst-seq))
+    (acons (car inst-seq) n (find-labels (cdr inst-seq) n))]
+   [(variable? (car inst-seq))
+    (acons (cadar inst-seq) n (find-labels (cdr inst-seq) (+ n 4)))]
    [else
-    (label-pass (cdr instructions) (+ address (instruction-size (car instructions))))]))
+    (find-labels (cdr inst-seq) (if (eq? (caar inst-seq) 'push) (+ n 5) (+ n 1)))]))
 
 (define (write-word word)
   (define bv (make-bytevector 4))
   (bytevector-s32-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))
-            (write-word (assq-ref labels (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)))
+(define (assemble inst-seq port)
+  (define labels (find-labels inst-seq 1))
+  (with-output-to-port port
+    (lambda ()
+      (let loop ([seq inst-seq])
+        (cond
+         [(null? seq) '()]
+         [(label? (car seq)) (loop (cdr seq))]
+         [(variable? (car seq))
+          (write-word (caddar seq))
+          (loop (cdr seq))]
+         [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))
+                  (write-word (assq-ref labels (cadr inst)))))
+            (loop (cdr seq)))]))))
   labels)

tests.scm

@@ -18,7 +18,8 @@
 
 (define fib-program-asm
   '(  (variable result 0)
-      (ref result)
+      (push result)
+      (@)
       (push fib)
       (call)
       (push cleanup)
@@ -49,7 +50,8 @@
       (nip)
       (return)
     cleanup
-      (set! result)
+      (push result)
+      (!)
       (bye)))
 
 (define adder-program-bytecode