dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make assembler take a port

Browse Source
This commit is contained in:
Dane Johnson 2025-01-07 10:50:23 -06:00
parent e252e8eb19
commit f8a868bb23
2 changed files with 19 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
scmvm/assembler.scm
View File

@ -2,6 +2,7 @@
#: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))
@ -33,17 +34,19 @@
(bytevector-s32-native-set! bv 0 word)
(write-bytevector bv))
(define (assemble inst-seq)
(define labels (find-labels inst-seq 0))
(let loop ([seq inst-seq])
(cond
[(null? seq) '()]
[(label? (car seq)) (loop (cdr seq))]
[else
(let* [(inst (car seq))
(inst-obj (lookup-instruction (car inst)))]
(write-u8 (instruction-code inst-obj))
(case (instruction-type inst-obj)
[(i) (write-word (cadr inst))]
[(j) (write-word (assq-ref labels (cadr inst)))])
(loop (cdr seq)))])))
(define (assemble inst-seq port)
(with-output-to-port port
(lambda ()
(define labels (find-labels inst-seq 0))
(let loop ([seq inst-seq])
(cond
[(null? seq) '()]
[(label? (car seq)) (loop (cdr seq))]
[else
(let* [(inst (car seq))
(inst-obj (lookup-instruction (car inst)))]
(write-u8 (instruction-code inst-obj))
(case (instruction-type inst-obj)
[(i) (write-word (cadr inst))]
[(j) (write-word (assq-ref labels (cadr inst)))])
(loop (cdr seq)))])))))

4
tests.scm
View File

@ -102,11 +102,11 @@
(define-test-suite "assembler"
(define-test "adder"
(define out (open-output-bytevector))
(with-output-to-port out (lambda () (assemble adder-program-asm)))
(assemble adder-program-asm out)
(assert-equal adder-program-bytecode (get-output-bytevector out)))
(define-test "fib"
(define out (open-output-bytevector))
(with-output-to-port out (lambda () (assemble fib-program-asm)))
(assemble fib-program-asm out)
(assert-equal fib-program-bytecode (get-output-bytevector out))))
(define-test-suite "vm"