Project restructuring to support the new direction

scmvm/assembler.scm

@@ -1,88 +0,0 @@
-(define-module (scmvm 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)