/[slib]/slib/record.scm
ViewVC logotype

Contents of /slib/record.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations) (download)
Fri Dec 26 04:56:11 2003 UTC (20 years, 4 months ago) by uid65785
Branch: MAIN
CVS Tags: slib-3b2, slib-3b3, slib-3b1, slib-3b6, slib-3b7, slib-3b4, slib-3b5, slib3a5, slib3a4, slib3a3, slib3a2, slib-3c1, HEAD
Changes since 1.6: +1 -0 lines
Added (require 'rev4-optional-procedures) for vector-fill! and
vector->list.

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 ))

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26