record-case definition is moved to libcompile.ss and the file is

deleted.
This commit is contained in:
Abdulaziz Ghuloum 2006-12-17 02:18:11 +03:00
parent 52acb437e8
commit ac5ac00bab
3 changed files with 22 additions and 35 deletions

Binary file not shown.

View File

@ -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")

View File

@ -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))])))