80 lines
2.5 KiB
Scheme
80 lines
2.5 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 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-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)))
|
|
labels)
|