Common Lisp hack to rename some videos
[clinton/scratch.git] / define-record.scm
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