scsh-0.6/scheme/prescheme/memory.scm

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.


; An implementation of Pre-Scheme's memory interface that can detect some
; stray reads and writes.  It has numerous limitiations:
;    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).
;
; Memory is represented as a vector of byte-vectors, with each byte-vector
; representing a 16-megabyte page.  Allocations are always made on page
; boundaries, so the byte-vectors only need be as large as the allocated
; areas.  Pages are never re-used.
;
; (Scheme 48 still calls byte-vectors code-vectors.)


; Addresses are distinct from integers.

(define-record-type address :address
  (make-address index)
  address?
  (index address-index))
  
(define-record-discloser :address
  (lambda (addr) (list 'address (address-index addr))))

; We add 100000000 to addresses to make them

(define address-offset 100000000)

(define (address->integer addr)
  (+ (address-index addr) address-offset))

(define (integer->address int)
  (make-address (- int address-offset)))

(define (address+ address integer)
  (make-address (+ (address-index address) integer)))

(define (address- address integer)
  (make-address (- (address-index address) integer)))

(define (address-binop op)
  (lambda (address1 address2)
    (op (address-index address1) (address-index address2))))

(define address-difference (address-binop -))
(define address= (address-binop =))
(define address< (address-binop <))
(define address<= (address-binop <=))
(define address> (address-binop >))
(define address>= (address-binop >=))

(define null-address (make-address -1))

(define (null-address? address)
  (address= address null-address))

; Memory

(define *memory* (make-vector 16 #f))    ; vector of pages
(define log-max-size 24)                 ; log of page size
(define address-shift (- log-max-size))  ; turns addresses into page indices

(define max-size (arithmetic-shift 1 log-max-size))  ; page size

(define address-mask                     ; mask to get address within page
  (- (arithmetic-shift 1 log-max-size) 1))

(define *next-index* 0)                  ; next available page

(define (reinitialize-memory)
  (set! *memory* (make-vector 16 #f))
  (set! *next-index* 0))

; Extend the page vector if necessary, and then make a page of the
; appropriate size.

(define (allocate-memory size)
  (cond ((> size max-size)
	 -1)  ; error result
	(else
	 (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))
	   (make-address (arithmetic-shift index log-max-size))))))

; Turning an address into a page or page index

(define (address->vector address)
  (vector-ref *memory* (arithmetic-shift address address-shift)))

(define (address->vector-index address)
  (bitwise-and address address-mask))

; Throw away the page containing ADDRESS, which must be the first address in
; that page, 

(define (deallocate-memory address)
  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index address)))
      (if (and vector (= byte-address 0))
	  (vector-set! *memory* (arithmetic-shift address address-shift) #f)
	  (error "bad deallocation address" address)))))

; Various ways of accessing memory

(define (unsigned-byte-ref address)
  (let ((address (address-index address)))
    (code-vector-ref (address->vector address)
		     (address->vector-index 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)
  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index 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)
  (let ((address (address-index address)))
    (code-vector-set! (address->vector address)
		      (address->vector-index address)
		      (bitwise-and 255 value))))
	    
(define (word-set! address value)
  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index 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)))))

; Block I/O procedures.

(define (write-block port address count)
  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index address)))
      (do ((i 0 (+ i 1)))
	  ((>= i count))
	(write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
		    port))
      (enum errors no-errors))))

(define (read-block port address count)
  (let ((address (address-index address)))
    (cond ((not (char-ready? port))
	   (values 0 #f (enum errors no-errors)))
	  ((eof-object? (s-peek-char port))
	   (values 0 #t (enum errors no-errors)))
	  (else
	   (let ((vector (address->vector address))
		 (byte-address (address->vector-index address)))
	     (let loop ((i 0))
	       (if (or (= i count)
		       (not (char-ready? port)))
		   (values i #f (enum errors no-errors))
		   (let ((c (s-read-char port)))
		     (cond ((eof-object? c)
			    (values i #f (enum errors no-errors)))
			   (else
			    (code-vector-set! vector
					      (+ i byte-address)
					      (char->ascii c))
			    (loop (+ i 1))))))))))))

(define (copy-memory! from to count)
  (let ((from (address-index from))
	(to (address-index to)))
    (let ((from-vector (address->vector from))
	  (from-address (address->vector-index from))
	  (to-vector (address->vector to))
	  (to-address (address->vector-index to)))
      (do ((i 0 (+ i 1)))
	  ((>= i count))
	(code-vector-set! to-vector
			  (+ i to-address)
			  (code-vector-ref from-vector
					   (+ i from-address)))))))

(define (memory-equal? from to count)
  (let ((from (address-index from))
	(to (address-index to)))
    (let ((from-vector (address->vector from))
	  (from-address (address->vector-index from))
	  (to-vector (address->vector to))
	  (to-address (address->vector-index to)))
      (let loop ((i 0))
	(cond ((>= i count)
	       #t)
	      ((= (code-vector-ref to-vector (+ i to-address))
		  (code-vector-ref from-vector (+ i from-address)))
	       (loop (+ i 1)))
	      (else
	       #f))))))

; Turn the LENGTH bytes starting from ADDRESS into a string.

(define (char-pointer->string address length)
  (let ((address (address-index address)))
    (let ((vector (address->vector address))
	  (byte-address (address->vector-index address))
	  (string (make-string length)))
      (do ((i 0 (+ i 1)))
	  ((= i length))
	(string-set! string
		     i
		     (ascii->char (code-vector-ref vector (+ byte-address i)))))
      string)))

; Turn the bytes from ADDRESS to the next nul (byte equal to 0) into a
; string.  This is a trivial operation in C.

(define (char-pointer->nul-terminated-string address)
  (let ((index (address-index address)))
    (let ((vector (address->vector index))
	  (byte-address (address->vector-index index)))
      (char-pointer->string address (index-of-first-nul vector byte-address)))))
  
(define (index-of-first-nul vector address)
  (let loop ((i address))
    (cond ((= i (code-vector-length vector))
	   (error "CHAR-POINTER->STRING called on pointer with no nul termination"))
	  ((= 0 (code-vector-ref vector i))
	   (- i address))
	  (else
	   (loop (+ i 1))))))