Commit | Line | Data |
---|---|---|
6be07c52 TTN |
1 | ;;; srfi-9.scm --- define-record-type |
2 | ||
361553b4 | 3 | ;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, |
36253519 | 4 | ;; 2013, 2014 Free Software Foundation, Inc. |
6be07c52 | 5 | ;; |
73be1d9e MV |
6 | ;; This library is free software; you can redistribute it and/or |
7 | ;; modify it under the terms of the GNU Lesser General Public | |
8 | ;; License as published by the Free Software Foundation; either | |
83ba2d37 | 9 | ;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
10 | ;; |
11 | ;; This library is distributed in the hope that it will be useful, | |
6be07c52 TTN |
12 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
73be1d9e MV |
14 | ;; Lesser General Public License for more details. |
15 | ;; | |
16 | ;; You should have received a copy of the GNU Lesser General Public | |
17 | ;; License along with this library; if not, write to the Free Software | |
92205699 | 18 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a6fd89a4 | 19 | |
e1633bf3 MG |
20 | ;;; Commentary: |
21 | ||
6be07c52 TTN |
22 | ;; This module exports the syntactic form `define-record-type', which |
23 | ;; is the means for creating record types defined in SRFI-9. | |
24 | ;; | |
25 | ;; The syntax of a record type definition is: | |
26 | ;; | |
27 | ;; <record type definition> | |
28 | ;; -> (define-record-type <type name> | |
29 | ;; (<constructor name> <field tag> ...) | |
30 | ;; <predicate name> | |
31 | ;; <field spec> ...) | |
32 | ;; | |
d9e36897 MW |
33 | ;; <field spec> -> (<field tag> <getter name>) |
34 | ;; -> (<field tag> <getter name> <setter name>) | |
6be07c52 TTN |
35 | ;; |
36 | ;; <field tag> -> <identifier> | |
37 | ;; <... name> -> <identifier> | |
38 | ;; | |
39 | ;; Usage example: | |
40 | ;; | |
41 | ;; guile> (use-modules (srfi srfi-9)) | |
42 | ;; guile> (define-record-type :foo (make-foo x) foo? | |
43 | ;; (x get-x) (y get-y set-y!)) | |
44 | ;; guile> (define f (make-foo 1)) | |
45 | ;; guile> f | |
46 | ;; #<:foo x: 1 y: #f> | |
47 | ;; guile> (get-x f) | |
48 | ;; 1 | |
49 | ;; guile> (set-y! f 2) | |
50 | ;; 2 | |
51 | ;; guile> (get-y f) | |
52 | ;; 2 | |
53 | ;; guile> f | |
54 | ;; #<:foo x: 1 y: 2> | |
55 | ;; guile> (foo? f) | |
56 | ;; #t | |
57 | ;; guile> (foo? 1) | |
58 | ;; #f | |
a6fd89a4 | 59 | |
e1633bf3 MG |
60 | ;;; Code: |
61 | ||
1a179b03 | 62 | (define-module (srfi srfi-9) |
09a8dc97 | 63 | #:use-module (srfi srfi-1) |
92fac8c0 | 64 | #:use-module (system base ck) |
09a8dc97 | 65 | #:export (define-record-type)) |
a6fd89a4 | 66 | |
1b2f40b9 MG |
67 | (cond-expand-provide (current-module) '(srfi-9)) |
68 | ||
756b1dfa LC |
69 | ;; Roll our own instead of using the public `define-inlinable'. This is |
70 | ;; because the public one has a different `make-procedure-name', so | |
71 | ;; using it would require users to recompile code that uses SRFI-9. See | |
72 | ;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>. | |
d9e36897 MW |
73 | ;; |
74 | ||
75 | (define-syntax-rule (define-inlinable (name formals ...) body ...) | |
76 | (define-tagged-inlinable () (name formals ...) body ...)) | |
77 | ||
78 | ;; 'define-tagged-inlinable' has an additional feature: it stores a map | |
79 | ;; of keys to values that can be retrieved at expansion time. This is | |
80 | ;; currently used to retrieve the rtd id, field index, and record copier | |
81 | ;; macro for an arbitrary getter. | |
82 | ||
83 | (define-syntax-rule (%%on-error err) err) | |
84 | ||
85 | (define %%type #f) ; a private syntax literal | |
92fac8c0 MW |
86 | (define-syntax getter-type |
87 | (syntax-rules (quote) | |
88 | ((_ s 'getter 'err) | |
89 | (getter (%%on-error err) %%type s)))) | |
756b1dfa | 90 | |
d9e36897 | 91 | (define %%index #f) ; a private syntax literal |
92fac8c0 MW |
92 | (define-syntax getter-index |
93 | (syntax-rules (quote) | |
94 | ((_ s 'getter 'err) | |
95 | (getter (%%on-error err) %%index s)))) | |
d9e36897 MW |
96 | |
97 | (define %%copier #f) ; a private syntax literal | |
92fac8c0 MW |
98 | (define-syntax getter-copier |
99 | (syntax-rules (quote) | |
100 | ((_ s 'getter 'err) | |
101 | (getter (%%on-error err) %%copier s)))) | |
d9e36897 MW |
102 | |
103 | (define-syntax define-tagged-inlinable | |
756b1dfa LC |
104 | (lambda (x) |
105 | (define (make-procedure-name name) | |
106 | (datum->syntax name | |
107 | (symbol-append '% (syntax->datum name) | |
108 | '-procedure))) | |
109 | ||
110 | (syntax-case x () | |
d9e36897 | 111 | ((_ ((key value) ...) (name formals ...) body ...) |
756b1dfa LC |
112 | (identifier? #'name) |
113 | (with-syntax ((proc-name (make-procedure-name #'name)) | |
114 | ((args ...) (generate-temporaries #'(formals ...)))) | |
115 | #`(begin | |
116 | (define (proc-name formals ...) | |
117 | body ...) | |
118 | (define-syntax name | |
119 | (lambda (x) | |
d9e36897 | 120 | (syntax-case x (%%on-error key ...) |
92fac8c0 | 121 | ((_ (%%on-error err) key s) #'(ck s 'value)) ... |
756b1dfa LC |
122 | ((_ args ...) |
123 | #'((lambda (formals ...) | |
124 | body ...) | |
125 | args ...)) | |
89ffbb1c MW |
126 | ((_ a (... ...)) |
127 | (syntax-violation 'name "Wrong number of arguments" x)) | |
756b1dfa LC |
128 | (_ |
129 | (identifier? x) | |
130 | #'proc-name)))))))))) | |
131 | ||
87616235 AW |
132 | (define (default-record-printer s p) |
133 | (display "#<" p) | |
134 | (display (record-type-name (record-type-descriptor s)) p) | |
135 | (let loop ((fields (record-type-fields (record-type-descriptor s))) | |
136 | (off 0)) | |
137 | (cond | |
138 | ((not (null? fields)) | |
139 | (display " " p) | |
140 | (display (car fields) p) | |
141 | (display ": " p) | |
142 | (write (struct-ref s off) p) | |
143 | (loop (cdr fields) (+ 1 off))))) | |
144 | (display ">" p)) | |
145 | ||
36253519 AW |
146 | (define-syntax-rule (throw-bad-struct s who) |
147 | (let ((s* s)) | |
148 | (throw 'wrong-type-arg who | |
149 | "Wrong type argument: ~S" (list s*) | |
150 | (list s*)))) | |
d9e36897 MW |
151 | |
152 | (define (make-copier-id type-name) | |
153 | (datum->syntax type-name | |
154 | (symbol-append '%% (syntax->datum type-name) | |
155 | '-set-fields))) | |
156 | ||
157 | (define-syntax %%set-fields | |
158 | (lambda (x) | |
159 | (syntax-case x () | |
160 | ((_ type-name (getter-id ...) check? s (getter expr) ...) | |
161 | (every identifier? #'(getter ...)) | |
162 | (let ((copier-name (syntax->datum (make-copier-id #'type-name))) | |
746065c9 AW |
163 | (getter+exprs #'((getter expr) ...)) |
164 | (nfields (length #'(getter-id ...)))) | |
d9e36897 MW |
165 | (define (lookup id default-expr) |
166 | (let ((results | |
167 | (filter (lambda (g+e) | |
168 | (free-identifier=? id (car g+e))) | |
169 | getter+exprs))) | |
170 | (case (length results) | |
171 | ((0) default-expr) | |
172 | ((1) (cadar results)) | |
173 | (else (syntax-violation | |
174 | copier-name "duplicate getter" x id))))) | |
175 | (for-each (lambda (id) | |
176 | (or (find (lambda (getter-id) | |
177 | (free-identifier=? id getter-id)) | |
178 | #'(getter-id ...)) | |
179 | (syntax-violation | |
180 | copier-name "unknown getter" x id))) | |
181 | #'(getter ...)) | |
182 | (with-syntax ((unsafe-expr | |
746065c9 AW |
183 | #`(let ((new (allocate-struct type-name #,nfields))) |
184 | #,@(map (lambda (getter index) | |
185 | #`(struct-set! | |
186 | new | |
187 | #,index | |
188 | #,(lookup getter | |
189 | #`(struct-ref s #,index)))) | |
190 | #'(getter-id ...) | |
191 | (iota nfields)) | |
192 | new))) | |
d9e36897 MW |
193 | (if (syntax->datum #'check?) |
194 | #`(if (eq? (struct-vtable s) type-name) | |
195 | unsafe-expr | |
196 | (throw-bad-struct | |
197 | s '#,(datum->syntax #'here copier-name))) | |
198 | #'unsafe-expr))))))) | |
199 | ||
200 | (define-syntax %define-record-type | |
09a8dc97 LC |
201 | (lambda (x) |
202 | (define (field-identifiers field-specs) | |
d9e36897 MW |
203 | (map (lambda (field-spec) |
204 | (syntax-case field-spec () | |
205 | ((name getter) #'name) | |
206 | ((name getter setter) #'name))) | |
207 | field-specs)) | |
208 | ||
209 | (define (getter-identifiers field-specs) | |
210 | (map (lambda (field-spec) | |
211 | (syntax-case field-spec () | |
212 | ((name getter) #'getter) | |
213 | ((name getter setter) #'getter))) | |
214 | field-specs)) | |
215 | ||
746065c9 | 216 | (define (constructor form type-name constructor-spec field-ids) |
09a8dc97 LC |
217 | (syntax-case constructor-spec () |
218 | ((ctor field ...) | |
d9e36897 | 219 | (every identifier? #'(field ...)) |
746065c9 AW |
220 | (let ((slots (map (lambda (field) |
221 | (or (list-index (lambda (x) | |
222 | (free-identifier=? x field)) | |
223 | field-ids) | |
224 | (syntax-violation | |
225 | (syntax-case form () | |
226 | ((macro . args) | |
227 | (syntax->datum #'macro))) | |
228 | "unknown field in constructor spec" | |
229 | form field))) | |
230 | #'(field ...)))) | |
30a700c8 | 231 | #`(define-inlinable #,constructor-spec |
746065c9 AW |
232 | (let ((s (allocate-struct #,type-name #,(length field-ids)))) |
233 | #,@(map (lambda (arg slot) | |
234 | #`(struct-set! s #,slot #,arg)) | |
235 | #'(field ...) slots) | |
236 | s)))))) | |
d9e36897 MW |
237 | |
238 | (define (getters type-name getter-ids copier-id) | |
239 | (map (lambda (getter index) | |
240 | #`(define-tagged-inlinable | |
241 | ((%%type #,type-name) | |
242 | (%%index #,index) | |
243 | (%%copier #,copier-id)) | |
244 | (#,getter s) | |
245 | (if (eq? (struct-vtable s) #,type-name) | |
246 | (struct-ref s #,index) | |
247 | (throw-bad-struct s '#,getter)))) | |
248 | getter-ids | |
249 | (iota (length getter-ids)))) | |
250 | ||
251 | (define (copier type-name getter-ids copier-id) | |
252 | #`(define-syntax-rule | |
253 | (#,copier-id check? s (getter expr) (... ...)) | |
254 | (%%set-fields #,type-name #,getter-ids | |
255 | check? s (getter expr) (... ...)))) | |
256 | ||
257 | (define (setters type-name field-specs) | |
258 | (filter-map (lambda (field-spec index) | |
259 | (syntax-case field-spec () | |
260 | ((name getter) #f) | |
261 | ((name getter setter) | |
262 | #`(define-inlinable (setter s val) | |
263 | (if (eq? (struct-vtable s) #,type-name) | |
264 | (struct-set! s #,index val) | |
265 | (throw-bad-struct s 'setter)))))) | |
266 | field-specs | |
267 | (iota (length field-specs)))) | |
268 | ||
269 | (define (functional-setters copier-id field-specs) | |
270 | (filter-map (lambda (field-spec index) | |
271 | (syntax-case field-spec () | |
272 | ((name getter) #f) | |
273 | ((name getter setter) | |
274 | #`(define-inlinable (setter s val) | |
275 | (#,copier-id #t s (getter val)))))) | |
276 | field-specs | |
277 | (iota (length field-specs)))) | |
278 | ||
279 | (define (record-layout immutable? count) | |
746065c9 AW |
280 | ;; Mutability is expressed on the record level; all structs in the |
281 | ;; future will be mutable. | |
282 | (string-concatenate (make-list count "pw"))) | |
09a8dc97 LC |
283 | |
284 | (syntax-case x () | |
f31a0762 | 285 | ((_ immutable? form type-name constructor-spec predicate-name |
d9e36897 | 286 | field-spec ...) |
f31a0762 MW |
287 | (let () |
288 | (define (syntax-error message subform) | |
289 | (syntax-violation (syntax-case #'form () | |
290 | ((macro . args) (syntax->datum #'macro))) | |
291 | message #'form subform)) | |
292 | (and (boolean? (syntax->datum #'immutable?)) | |
293 | (or (identifier? #'type-name) | |
294 | (syntax-error "expected type name" #'type-name)) | |
295 | (syntax-case #'constructor-spec () | |
296 | ((ctor args ...) | |
297 | (every identifier? #'(ctor args ...)) | |
298 | #t) | |
299 | (_ (syntax-error "invalid constructor spec" | |
300 | #'constructor-spec))) | |
301 | (or (identifier? #'predicate-name) | |
302 | (syntax-error "expected predicate name" #'predicate-name)) | |
303 | (every (lambda (spec) | |
304 | (syntax-case spec () | |
305 | ((field getter) #t) | |
306 | ((field getter setter) #t) | |
307 | (_ (syntax-error "invalid field spec" spec)))) | |
308 | #'(field-spec ...)))) | |
d9e36897 MW |
309 | (let* ((field-ids (field-identifiers #'(field-spec ...))) |
310 | (getter-ids (getter-identifiers #'(field-spec ...))) | |
311 | (field-count (length field-ids)) | |
312 | (immutable? (syntax->datum #'immutable?)) | |
313 | (layout (record-layout immutable? field-count)) | |
5ef102cc | 314 | (ctor-name (syntax-case #'constructor-spec () |
d9e36897 MW |
315 | ((ctor args ...) #'ctor))) |
316 | (copier-id (make-copier-id #'type-name))) | |
09a8dc97 | 317 | #`(begin |
746065c9 | 318 | #,(constructor #'form #'type-name #'constructor-spec field-ids) |
5ef102cc | 319 | |
09a8dc97 | 320 | (define type-name |
87616235 AW |
321 | (let ((rtd (make-struct/no-tail |
322 | record-type-vtable | |
323 | '#,(datum->syntax #'here (make-struct-layout layout)) | |
324 | default-record-printer | |
325 | 'type-name | |
d9e36897 | 326 | '#,field-ids))) |
87616235 | 327 | (set-struct-vtable-name! rtd 'type-name) |
5ef102cc | 328 | (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name) |
87616235 | 329 | rtd)) |
5ef102cc | 330 | |
fe258c43 | 331 | (define-inlinable (predicate-name obj) |
09a8dc97 LC |
332 | (and (struct? obj) |
333 | (eq? (struct-vtable obj) type-name))) | |
334 | ||
d9e36897 MW |
335 | #,@(getters #'type-name getter-ids copier-id) |
336 | #,(copier #'type-name getter-ids copier-id) | |
337 | #,@(if immutable? | |
338 | (functional-setters copier-id #'(field-spec ...)) | |
f31a0762 MW |
339 | (setters #'type-name #'(field-spec ...)))))) |
340 | ((_ immutable? form . rest) | |
341 | (syntax-violation | |
342 | (syntax-case #'form () | |
343 | ((macro . args) (syntax->datum #'macro))) | |
344 | "invalid record definition syntax" | |
345 | #'form))))) | |
d9e36897 MW |
346 | |
347 | (define-syntax-rule (define-record-type name ctor pred fields ...) | |
f31a0762 MW |
348 | (%define-record-type #f (define-record-type name ctor pred fields ...) |
349 | name ctor pred fields ...)) | |
6be07c52 TTN |
350 | |
351 | ;;; srfi-9.scm ends here |