53 lines
1.6 KiB
Scheme
53 lines
1.6 KiB
Scheme
(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 (lookup-instruction inst)
|
|
(define inst-obj (assq inst *instruction-set*))
|
|
(if inst-obj
|
|
inst-obj
|
|
(error (format #f "could not find instruction ~a" inst))))
|
|
|
|
(define (instruction-size inst)
|
|
(case (instruction-type (lookup-instruction inst))
|
|
[(i j) 5]
|
|
[(o) 1]))
|
|
|
|
(define instruction? pair?)
|
|
(define label? (compose not instruction?))
|
|
|
|
(define (find-labels inst-seq n)
|
|
(cond
|
|
[(null? inst-seq) '()]
|
|
[(label? (car inst-seq))
|
|
(acons (car inst-seq) n (find-labels (cdr inst-seq) n))]
|
|
[else
|
|
(find-labels (cdr inst-seq) (+ n (instruction-size (caar inst-seq))))]))
|
|
|
|
(define (write-word word)
|
|
(define bv (make-bytevector 4))
|
|
(bytevector-s32-native-set! bv 0 word)
|
|
(write-bytevector bv))
|
|
|
|
(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)))])))))
|