diff --git a/scmvm/language/common.scm b/scmvm/language/common.scm deleted file mode 100644 index 9ca23f5..0000000 --- a/scmvm/language/common.scm +++ /dev/null @@ -1,67 +0,0 @@ -(define-module (scmvm language common) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-9) - #:use-module (rnrs bytevectors) - #:export ( - (make-assembler* . make-assembler) - assembler? - assembler-labels - assembler-pos - assembler-buf - assembler-pos-set! - assembler-buf-set! - assembler-label-add-reference - assembler-label-add-value - write-byte - write-word - emit-label - finalize-references)) - -(define (make-label) (cons #f '())) - -(define-record-type - (make-assembler pos buf labels) - assembler? - (pos assembler-pos assembler-pos-set!) - (buf assembler-buf assembler-buf-set!) - (labels assembler-labels)) - -(define (make-assembler*) - (make-assembler 0 (make-bytevector 1024) (make-hash-table))) - -(define (assembler-buf-grow! asm) - (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))]) - (bytevector-copy! (assembler-buf asm) 0 buf 0 (bytevector-length (assembler-buf asm))) - (assembler-buf-set! asm buf))) - -(define* (write-word word asm #:optional (pos (assembler-pos asm))) - (when (> (+ pos 4) (bytevector-length (assembler-buf asm))) - (assembler-buf-grow! asm)) - (bytevector-u32-native-set! (assembler-buf asm) pos word)) - -(define* (write-byte byte asm #:optional (pos (assembler-pos asm))) - (when (> (+ pos 1) (bytevector-length (assembler-buf asm))) - (assembler-buf-grow! asm)) - (bytevector-u8-set! (assembler-buf asm) pos byte)) - -(define (assembler-label-add-reference asm name addr) - (when (not (hash-ref (assembler-labels asm) name)) - (hash-set! (assembler-labels asm) name (make-label))) - (let ([label (hash-ref (assembler-labels asm) name)]) - (set-cdr! label (cons addr (cdr label))))) - -(define (assembler-label-add-value asm name val) - (when (not (hash-ref (assembler-labels asm) name)) - (hash-set! (assembler-labels asm) name (make-label))) - ;; 1+ to fudge for null pointers - (set-car! (hash-ref (assembler-labels asm) name) (1+ val))) - -(define (finalize-references asm) - (define (install-location _name label) - (for-each - (cute write-word (car label) asm <>) - (cdr label))) - (hash-for-each install-location (assembler-labels asm))) - -(define (emit-label asm name) - (assembler-label-add-value asm name (assembler-pos asm)))