diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm index ca557c7..fac8fec 100644 --- a/scmvm/assembler.scm +++ b/scmvm/assembler.scm @@ -20,39 +20,41 @@ (and (not (label? x)) (not (variable? x)))) -(define (find-labels inst-seq n) +(define (label-pass instructions address) (cond - [(null? inst-seq) '()] - [(label? (car inst-seq)) - (acons (car inst-seq) n (find-labels (cdr inst-seq) n))] - [(variable? (car inst-seq)) - (acons (cadar inst-seq) n (find-labels (cdr inst-seq) (+ n 4)))] + [(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 - (find-labels (cdr inst-seq) (if (eq? (caar inst-seq) 'push) (+ n 5) (+ n 1)))])) + (label-pass (cdr instructions) (if (eq? (caar instructions) 'push) + (+ address 5) + (+ address 1)))])) (define (write-word word) (define bv (make-bytevector 4)) (bytevector-s32-native-set! bv 0 word) (write-bytevector bv)) -(define (assemble inst-seq port) - (define labels (find-labels inst-seq 1)) - (with-output-to-port port - (lambda () - (let loop ([seq inst-seq]) - (cond - [(null? seq) '()] - [(label? (car seq)) (loop (cdr seq))] - [(variable? (car seq)) - (write-word (caddar seq)) - (loop (cdr seq))] - [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))))) - (loop (cdr seq)))])))) +(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)] + [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)