Add meta assembly commands for dealing with variables

asm/fib.scm

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

scmvm/assembler.scm

@@ -16,43 +16,64 @@
 (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 (variable? x))
+       (not (ref? x))
+       (not (set!? x))))
+(define (instruction-size inst)
+  (case (car inst)
+    [(push) 5]
+    [(ref set!) 6]
+    [else 1]))
 
-(define (find-labels inst-seq n)
+(define (label-pass instructions address)
   (cond
-   [(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)))]
+   [(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
-    (find-labels (cdr inst-seq) (if (eq? (caar inst-seq) 'push) (+ n 5) (+ n 1)))]))
+    (label-pass (cdr instructions) (+ address (instruction-size (car instructions))))]))
 
 (define (write-word word)
   (define bv (make-bytevector 4))
   (bytevector-s32-native-set! bv 0 word)
   (write-bytevector bv))
 
-(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)))]))))
+(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)))
   labels)

tests.scm

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