1 |
; "record.scm" record data types |
2 |
; Written by David Carlton, carlton@husc.harvard.edu. |
3 |
; Re-Written by Aubrey Jaffer, agj @ alum.mit.edu, 1996, 1997 |
4 |
; |
5 |
; This code is in the public domain. |
6 |
|
7 |
; Implements `record' data structures for Scheme. Using only the |
8 |
; opacity of procedures, makes record datatypes and |
9 |
; record-type-descriptors disjoint from R4RS types and each other, and |
10 |
; prevents forgery and corruption (modification without using |
11 |
; RECORD-MODIFIER) of records. |
12 |
|
13 |
;;2001-07-24 Aubrey Jaffer <agj@alum.mit.edu> |
14 |
;; changed identifiers containing VECTOR to VECT or VCT. |
15 |
|
16 |
(require 'common-list-functions) |
17 |
(require 'rev4-optional-procedures) |
18 |
|
19 |
(define vector? vector?) |
20 |
(define vector-ref vector-ref) |
21 |
(define vector-set! vector-set!) |
22 |
(define vector-fill! vector-fill!) |
23 |
(define vector->list vector->list) |
24 |
(define display display) |
25 |
(define write write) |
26 |
;@ |
27 |
(define record-modifier #f) |
28 |
(define record-accessor #f) |
29 |
(define record-constructor #f) |
30 |
(define record-predicate #f) |
31 |
(define make-record-type #f) |
32 |
|
33 |
(let (;; protect CL functions against redefinition. |
34 |
(has-duplicates? has-duplicates?) |
35 |
(notevery notevery) |
36 |
(position position) |
37 |
|
38 |
;; Need to close these to keep magic-cookie hidden. |
39 |
(make-vect make-vector) |
40 |
(vect vector) |
41 |
|
42 |
;; We have to wrap these to keep magic-cookie hidden. |
43 |
(vect? vector?) |
44 |
(vect-ref vector-ref) |
45 |
(vect->list vector->list) |
46 |
(disp display) |
47 |
(wri write) |
48 |
|
49 |
;; Need to wrap these to protect record data from being corrupted. |
50 |
(vect-set! vector-set!) |
51 |
(vect-fill! vector-fill!) |
52 |
|
53 |
(nvt "of non-vector type") |
54 |
) |
55 |
(letrec |
56 |
(;; Tag to identify rtd's. (A record is identified by the rtd |
57 |
;; that begins it.) |
58 |
(magic-cookie (cons 'rtd '())) |
59 |
(rtd? (lambda (object) |
60 |
(and (vect? object) |
61 |
(not (= (vector-length object) 0)) |
62 |
(eq? (rtd-tag object) magic-cookie)))) |
63 |
(rec? (lambda (obj) |
64 |
(and (vect? obj) |
65 |
(>= (vector-length obj) 1) |
66 |
(or (eq? magic-cookie (rec-rtd obj)) |
67 |
(rtd? (rec-rtd obj)))))) |
68 |
|
69 |
(vec:error |
70 |
(lambda (proc-name msg obj) |
71 |
(slib:error proc-name msg |
72 |
(cond ((rtd? obj) 'rtd) |
73 |
((rec? obj) (rtd-name (rec-rtd obj))) |
74 |
(else obj))))) |
75 |
|
76 |
;; Internal accessor functions. No error checking. |
77 |
(rtd-tag (lambda (x) (vect-ref x 0))) |
78 |
(rtd-name (lambda (rtd) (if (vect? rtd) (vect-ref rtd 1) "rtd"))) |
79 |
(rtd-fields (lambda (rtd) (vect-ref rtd 3))) |
80 |
;; rtd-vfields is padded out to the length of the vector, which is 1 |
81 |
;; more than the number of fields |
82 |
(rtd-vfields (lambda (rtd) (cons #f (rtd-fields rtd)))) |
83 |
;; rtd-length is the length of the vector. |
84 |
(rtd-length (lambda (rtd) (vect-ref rtd 4))) |
85 |
|
86 |
(rec-rtd (lambda (x) (vect-ref x 0))) |
87 |
(rec-disp-str |
88 |
(lambda (x) |
89 |
(let ((name (rtd-name (rec-rtd x)))) |
90 |
(string-append |
91 |
"#<" (if (symbol? name) (symbol->string name) name) ">")))) |
92 |
|
93 |
(make-rec-type |
94 |
(lambda (type-name field-names) |
95 |
(if (not (or (symbol? type-name) (string? type-name))) |
96 |
(slib:error 'make-record-type "non-string type-name argument." |
97 |
type-name)) |
98 |
(if (or (and (list? field-names) (has-duplicates? field-names)) |
99 |
(notevery symbol? field-names)) |
100 |
(slib:error 'make-record-type "illegal field-names argument." |
101 |
field-names)) |
102 |
(let* ((augmented-length (+ 1 (length field-names))) |
103 |
(rtd (vect magic-cookie |
104 |
type-name |
105 |
'() |
106 |
field-names |
107 |
augmented-length |
108 |
#f |
109 |
#f))) |
110 |
(vect-set! rtd 5 |
111 |
(lambda (x) |
112 |
(and (vect? x) |
113 |
(= (vector-length x) augmented-length) |
114 |
(eq? (rec-rtd x) rtd)))) |
115 |
(vect-set! rtd 6 |
116 |
(lambda (x) |
117 |
(and (vect? x) |
118 |
(>= (vector-length x) augmented-length) |
119 |
(eq? (rec-rtd x) rtd) |
120 |
#t))) |
121 |
rtd))) |
122 |
|
123 |
(rec-predicate |
124 |
(lambda (rtd) |
125 |
(if (not (rtd? rtd)) |
126 |
(slib:error 'record-predicate "invalid argument." rtd)) |
127 |
(vect-ref rtd 5))) |
128 |
|
129 |
(rec-constructor |
130 |
(lambda (rtd . field-names) |
131 |
(if (not (rtd? rtd)) |
132 |
(slib:error 'record-constructor "illegal rtd argument." rtd)) |
133 |
(if (or (null? field-names) |
134 |
(equal? field-names (rtd-fields rtd))) |
135 |
(let ((rec-length (- (rtd-length rtd) 1))) |
136 |
(lambda elts |
137 |
(if (= (length elts) rec-length) #t |
138 |
(slib:error 'record-constructor |
139 |
(rtd-name rtd) |
140 |
"wrong number of arguments.")) |
141 |
(apply vect rtd elts))) |
142 |
(let ((rec-vfields (rtd-vfields rtd)) |
143 |
(corrected-rec-length (rtd-length rtd)) |
144 |
(field-names (car field-names))) |
145 |
(if (or (and (list? field-names) (has-duplicates? field-names)) |
146 |
(notevery (lambda (x) (memq x rec-vfields)) |
147 |
field-names)) |
148 |
(slib:error |
149 |
'record-constructor "invalid field-names argument." |
150 |
(cdr rec-vfields))) |
151 |
(let ((field-length (length field-names)) |
152 |
(offsets |
153 |
(map (lambda (field) (position field rec-vfields)) |
154 |
field-names))) |
155 |
(lambda elts |
156 |
(if (= (length elts) field-length) #t |
157 |
(slib:error 'record-constructor |
158 |
(rtd-name rtd) |
159 |
"wrong number of arguments.")) |
160 |
(let ((result (make-vect corrected-rec-length))) |
161 |
(vect-set! result 0 rtd) |
162 |
(for-each (lambda (offset elt) |
163 |
(vect-set! result offset elt)) |
164 |
offsets |
165 |
elts) |
166 |
result))))))) |
167 |
|
168 |
(rec-accessor |
169 |
(lambda (rtd field-name) |
170 |
(if (not (rtd? rtd)) |
171 |
(slib:error 'record-accessor "invalid rtd argument." rtd)) |
172 |
(let ((index (position field-name (rtd-vfields rtd))) |
173 |
(augmented-length (rtd-length rtd))) |
174 |
(if (not index) |
175 |
(slib:error 'record-accessor "invalid field-name argument." |
176 |
field-name)) |
177 |
(lambda (x) |
178 |
(if (and (vect? x) |
179 |
(>= (vector-length x) augmented-length) |
180 |
(eq? rtd (rec-rtd x))) |
181 |
#t |
182 |
(slib:error 'record-accessor "wrong record type." x "not" rtd)) |
183 |
(vect-ref x index))))) |
184 |
|
185 |
(rec-modifier |
186 |
(lambda (rtd field-name) |
187 |
(if (not (rtd? rtd)) |
188 |
(slib:error 'record-modifier "invalid rtd argument." rtd)) |
189 |
(let ((index (position field-name (rtd-vfields rtd))) |
190 |
(augmented-length (rtd-length rtd))) |
191 |
(if (not index) |
192 |
(slib:error 'record-modifier "invalid field-name argument." |
193 |
field-name)) |
194 |
(lambda (x y) |
195 |
(if (and (vect? x) |
196 |
(>= (vector-length x) augmented-length) |
197 |
(eq? rtd (rec-rtd x))) |
198 |
#t |
199 |
(slib:error 'record-modifier "wrong record type." x "not" rtd)) |
200 |
(vect-set! x index y))))) |
201 |
) |
202 |
(set! vector? (lambda (obj) (and (vect? obj) (not (rec? obj))))) |
203 |
(set! vector-ref |
204 |
(lambda (vct k) |
205 |
(cond ((rec? vct) |
206 |
(vec:error 'vector-ref nvt vct)) |
207 |
(else (vect-ref vct k))))) |
208 |
(set! vector->list |
209 |
(lambda (vct) |
210 |
(cond ((rec? vct) |
211 |
(vec:error 'vector->list nvt vct)) |
212 |
(else (vect->list vct))))) |
213 |
(set! vector-set! |
214 |
(lambda (vct k obj) |
215 |
(cond ((rec? vct) (vec:error 'vector-set! nvt vct)) |
216 |
(else (vect-set! vct k obj))))) |
217 |
(set! vector-fill! |
218 |
(lambda (vct fill) |
219 |
(cond ((rec? vct) |
220 |
(vec:error 'vector-fill! nvt vct)) |
221 |
(else (vect-fill! vct fill))))) |
222 |
(set! display |
223 |
(lambda (obj . opt) |
224 |
(apply disp (if (rec? obj) (rec-disp-str obj) obj) opt))) |
225 |
(set! write |
226 |
(lambda (obj . opt) |
227 |
(if (rec? obj) |
228 |
(apply disp (rec-disp-str obj) opt) |
229 |
(apply wri obj opt)))) |
230 |
(set! record-modifier rec-modifier) |
231 |
(set! record-accessor rec-accessor) |
232 |
(set! record-constructor rec-constructor) |
233 |
(set! record-predicate rec-predicate) |
234 |
(set! make-record-type make-rec-type) |
235 |
)) |