1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
; Copyright (c) 1993-2008 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 25) ; 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)
null-address) ; 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 (- bytes-per-cell 1))))
(error "unaligned address error" address)
(do ((byte-offset 0 (+ byte-offset 1))
(shift-offset (- bits-per-cell bits-per-byte)
(- shift-offset bits-per-byte))
(word 0
(+ word
(arithmetic-shift ((if (= 0 byte-offset)
signed-code-vector-ref
code-vector-ref)
vector
(+ byte-address byte-offset))
shift-offset))))
((or (>= byte-offset bytes-per-cell) (< shift-offset 0))
word))))))
(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))
(do ((byte-offset 0 (+ byte-offset 1))
(shift-offset (- bits-per-cell bits-per-byte)
(- shift-offset bits-per-byte)))
((or (>= byte-offset bytes-per-cell) (< shift-offset 0)))
(code-vector-set! vector
(+ byte-address byte-offset)
(bitwise-and 255
(arithmetic-shift value
(- shift-offset))))))))
; With the right access to the flonum bits we could actually make these
; work. Something to do later.
(define (flonum-ref address)
(if #t ; work around type checker bug
(error "call to FLONUM-REF" address)))
(define (flonum-set! address value)
(if #t ; work around type checker bug
(error "call to FLONUM-SET!" address 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-byte (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 (byte-ready? port))
(values 0 #f (enum errors no-errors)))
((eof-object? (peek-byte 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 (byte-ready? port)))
(values i #f (enum errors no-errors))
(let ((b (read-byte port)))
(cond ((eof-object? b)
(values i #f (enum errors no-errors)))
(else
(code-vector-set! vector
(+ i byte-address)
b)
(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)))
(if (>= from-address to-address)
(do ((i 0 (+ i 1)))
((>= i count))
(code-vector-set! to-vector
(+ i to-address)
(code-vector-ref from-vector
(+ i from-address))))
(do ((i (- count 1) (- i 1)))
((negative? i))
(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))))))
|
