(define-module (scmvm assembler) #:use-module (srfi srfi-1) #:use-module (scmvm vm) #:use-module (rnrs bytevectors) #: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) (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)))])))