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
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees
; A hash table for writing images. Objects to be written out are saved in
; the table.
; This needs to be here because the Pre-Scheme compiler does not currently
; support polymorphic data types (so the table cannot be polymorphic, so
; we need to have this before we can define tables).
(define-record-type image-location :image-location
(really-make-image-location new-descriptor next)
(new-descriptor integer image-location-new-descriptor set-image-location-new-descriptor!)
(next integer image-location-next set-image-location-next!))
(define (make-image-location new-descriptor)
(really-make-image-location new-descriptor 0))
;----------------------------------------------------------------
(define-record-type table :table
(really-make-table keys values count size)
(keys (^ integer) table-keys set-table-keys!)
(values (^ image-location) table-values set-table-values!)
(count integer table-count set-table-count!)
(size integer table-size set-table-size!))
(define initial-table-size (shift-left 1 12))
; MAKE-VECTOR uses the initial value only to determine the type of the vector.
; It doesn't do the fill (which is really dumb).
(define (make-table)
(let ((keys (make-vector (+ initial-table-size 1) 0)))
(vector+length-fill! keys (+ initial-table-size 1) 0)
(really-make-table keys
(make-vector initial-table-size (null-pointer))
0
initial-table-size)))
(define (deallocate-table table)
(let ((keys (table-keys table))
(values (table-values table)))
(do ((i 0 (+ i 1)))
((= i (table-size table)))
(if (not (= (vector-ref keys i) 0))
(deallocate (vector-ref values i))))
(deallocate keys)
(deallocate values)
(deallocate table)))
; The if we run out of memory we mark the table as unusable. The image-writing
; code does the same.
(define (table-okay? table)
(< 0 (table-size table)))
(define (break-table! table)
(set-table-size! table 0))
; Assumes SIZE is a power of two.
; I have no idea how effective this hash function is.
(define (hash key size)
(bitwise-and (bitwise-xor key
(bitwise-xor (shift-left key 1)
(arithmetic-shift-right key 10)))
(- size 1)))
; Double the size of the table.
(define (table-grow table)
(let ((new-size (* (table-size table) 2))
(old-size (table-size table))
(old-keys (table-keys table))
(old-values (table-values table)))
(let ((new-keys (make-vector (+ new-size 1) 0))
(new-values (make-vector new-size (null-pointer))))
(cond ((or (null-pointer? new-keys)
(null-pointer? new-values))
(if (not (null-pointer? new-keys))
(deallocate new-keys))
(if (not (null-pointer? new-values))
(deallocate new-values))
(break-table! table))
(else
(set-table-keys! table new-keys)
(set-table-values! table new-values)
(set-table-size! table new-size)
(set-table-count! table 0)
(vector+length-fill! new-keys ; MAKE-VECTOR doesn't fill
(+ new-size 1)
0)
(do ((i 0 (+ i 1)))
((= i old-size))
(let ((key (vector-ref old-keys i)))
(if (not (= key 0))
(table-insert! new-size
new-keys
new-values
key
(vector-ref old-values i)))))
(deallocate old-keys)
(deallocate old-values))))))
(define (table-insert! size keys values key value)
(let loop ((i (hash key size)))
(cond ((not (= (vector-ref keys i) 0))
(loop (+ i 1)))
((= i size)
(loop 0))
(else
(vector-set! keys i key)
(vector-set! values i value)))))
(define (table-find table key found not-found)
(let ((start (hash key (table-size table)))
(keys (table-keys table)))
(let loop ((i start))
(let ((next (vector-ref keys i)))
(cond ((= key next)
(found i))
((not (= next 0))
(loop (+ i 1)))
((= i (table-size table))
(loop 0))
(else
(not-found i)))))))
(define (table-set! table key value)
(if (table-okay? table)
(table-find table
key
(lambda (i)
; A. this should not happen
; B. if it were to, who would delete the old value?
(vector-set! (table-values table) i value))
(lambda (i)
(vector-set! (table-keys table) i key)
(vector-set! (table-values table) i value)
(set-table-count! table (+ (table-count table) 1))
(if (= (table-count table)
(quotient (table-size table) 3))
(table-grow table))
(unspecific)))
(unspecific)))
(define (table-ref table key)
(if (table-okay? table)
(table-find table
key
(lambda (i)
(vector-ref (table-values table) i))
(lambda (i)
(null-pointer)))
(null-pointer)))
|
