diff --git a/src/ikarus.boot b/src/ikarus.boot index 6b59112..989910e 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libcompile.ss b/src/libcompile.ss index 0eedac1..5e28349 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -13,18 +13,30 @@ (let () -(define-syntax cond-expand +(define-syntax record-case (lambda (x) + (define (enumerate fld* i) + (syntax-case fld* () + [() #'()] + [(x . x*) + (with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))]) + #'(i . i*))])) + (define (generate-body ctxt cls*) + (syntax-case cls* (else) + [() (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))])) (syntax-case x () - [(_ test conseq altern) - (if (eval (syntax-object->datum #'test)) - #'conseq - #'altern)]))) - -(cond-expand (eq? "" "") - (include "record-case.chez.ss") - (include "record-case.ss")) - + [(_ expr cls* ...) + (with-syntax ([body (generate-body #'_ #'(cls* ...))]) + #'(let ([v expr]) body))]))) (include "set-operations.ss") diff --git a/src/record-case.ss b/src/record-case.ss deleted file mode 100644 index 64a23c5..0000000 --- a/src/record-case.ss +++ /dev/null @@ -1,25 +0,0 @@ - -(define-syntax record-case - (lambda (x) - (define (enumerate fld* i) - (syntax-case fld* () - [() #'()] - [(x . x*) - (with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))]) - #'(i . i*))])) - (define (generate-body ctxt cls*) - (syntax-case cls* (else) - [() (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))])) - (syntax-case x () - [(_ expr cls* ...) - (with-syntax ([body (generate-body #'_ #'(cls* ...))]) - #'(let ([v expr]) body))])))