scsh-0.5/vm/ps-memory.scm

117 lines
3.7 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; Scheme implementation of Pre-Scheme memory primitives
; For now, allocations are always on page boundaries.
; No more than 16 megabytes can be allocated at once.
; More than 32 or 64 or so allocations result in addresses being bignums
; (dealloctions have no effect on this).
(define *memory* (make-vector 16 #f))
(define log-max-size 24)
(define max-size (arithmetic-shift 1 log-max-size))
(define address-mask
(- (arithmetic-shift 1 log-max-size) 1))
(define *next-index* 0)
(define null-pointer? not)
(define (reinitialize-memory)
(set! *memory* (make-vector 16 #f))
(set! *next-index* 0))
(define (allocate-memory size)
(if (> size max-size)
(error "cannot allocate this much memory at once" size))
(if (>= *next-index* (vector-length *memory*))
(let ((new (make-vector (* 2 (vector-length *memory*)))))
(do ((i 0 (+ i 1)))
((>= i (vector-length *memory*)))
(vector-set! new i (vector-ref *memory* i)))
(set! *memory* new)))
(let ((index *next-index*))
(set! *next-index* (+ *next-index* 1))
(vector-set! *memory* index (make-code-vector size 0))
(arithmetic-shift index log-max-size)))
(define (decode-address address)
(let ((high (arithmetic-shift address (- 0 log-max-size)))
(low (bitwise-and address address-mask)))
(values (vector-ref *memory* high) low)))
(define (deallocate-memory address)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(if (and vector (= byte-address 0))
(vector-set! *memory* (arithmetic-shift address (- 0 log-max-size)) #f)
(error "bad deallocation address" address)))))
(define (unsigned-byte-ref address)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(code-vector-ref vector byte-address))))
(define (signed-code-vector-ref bvec i)
(let ((x (code-vector-ref bvec i)))
(if (< x 128)
x
(bitwise-ior x -128))))
(define (word-ref address)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(if (not (= 0 (bitwise-and byte-address 3)))
(error "unaligned address error" address)
(+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
(+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2)) 8)
(code-vector-ref vector (+ byte-address 3))))))))
(define (unsigned-byte-set! address value)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(code-vector-set! vector byte-address (bitwise-and 255 value)))))
(define (word-set! address value)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(if (not (= 0 (bitwise-and byte-address 3)))
(error "unaligned address error" address))
(code-vector-set! vector byte-address
(bitwise-and 255 (arithmetic-shift value -24)))
(code-vector-set! vector (+ byte-address 1)
(bitwise-and 255 (arithmetic-shift value -16)))
(code-vector-set! vector (+ byte-address 2)
(bitwise-and 255 (arithmetic-shift value -8)))
(code-vector-set! vector (+ byte-address 3)
(bitwise-and 255 value)))))
(define (write-block port address count)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(do ((i 0 (+ i 1)))
((>= i count))
(write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
port)))))
(define (read-block port address count)
(call-with-values
(lambda () (decode-address address))
(lambda (vector byte-address)
(do ((i 0 (+ i 1)))
((>= i count))
(code-vector-set! vector
(+ i byte-address)
(char->ascii (read-char port)))))))