ikarus/lib/record-case.ss

26 lines
984 B
Scheme
Raw Normal View History

2006-11-23 19:33:45 -05:00
(define-syntax record-case
(lambda (x)
(define (enumerate fld* i)
(syntax-case fld* ()
2006-12-05 15:08:00 -05:00
[() #'()]
[(x . x*)
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
#'(i . i*))]))
2006-11-23 19:33:45 -05:00
(define (generate-body ctxt cls*)
(syntax-case cls* (else)
2006-12-05 15:08:00 -05:00
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v #'x))]
[([else b b* ...]) #'(begin b b* ...)]
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
(with-syntax ([altern (generate-body ctxt #'rest)]
[(id* ...) (enumerate #'(rec-field* ...) 0)]
[rtd #'(type-descriptor rec-name)])
#'(if ($record/rtd? v rtd)
(let ([rec-field* ($record-ref v id*)] ...)
b b* ...)
altern))]))
2006-11-23 19:33:45 -05:00
(syntax-case x ()
2006-12-05 15:08:00 -05:00
[(_ expr cls* ...)
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
#'(let ([v expr]) body))])))