Commit | Line | Data |
---|---|---|
2f97b84f CE |
1 | (define-syntax define-record |
2 | (lambda (e) | |
3 | (syntax-case e () | |
4 | ((_ name field0 field1 ...) | |
5 | (with-syntax ((%fields | |
6 | (map (lambda (f) | |
7 | (syntax-case f () | |
8 | ((fname) (syntax (field fname #f))) | |
9 | ((fname default) (syntax (field fname default))) | |
10 | (fname (syntax (field fname #f))))) | |
11 | (syntax (field0 field1 ...))))) | |
12 | (syntax | |
13 | (define-record* name | |
14 | %fields))))))) | |
15 | ||
16 | (define-syntax define-record* | |
17 | (lambda (e) | |
18 | (letrec ((make-name (lambda args | |
19 | (datum->syntax e | |
20 | (string->symbol | |
21 | (apply string-append | |
22 | (map (lambda (a) | |
23 | (if (string? a) | |
24 | a | |
25 | (symbol->string | |
26 | (syntax->datum a)))) | |
27 | args))))))) | |
28 | (syntax-case e (field) | |
29 | ((_ name ((field field-name default) ...)) | |
30 | #`(begin (define* (#,(make-name "make-" (syntax name)) | |
31 | #:optional (field-name default) ...) | |
32 | (vector 'name field-name ...)) | |
33 | #,@(let ((idx 0)) | |
34 | (map (lambda (fname) | |
35 | (set! idx (1+ idx)) | |
36 | #`(begin (define (#,(make-name (syntax name) | |
37 | ":" | |
38 | fname) | |
39 | rec) | |
40 | (vector-ref rec #,idx)) | |
41 | (define (#,(make-name "set-" | |
42 | (syntax name) | |
43 | ":" | |
44 | fname) | |
45 | rec val) | |
46 | (vector-set! rec #,idx val)))) | |
47 | (syntax (field-name ...)))))))))) | |
48 |