record-case definition is moved to libcompile.ss and the file is
deleted.
This commit is contained in:
parent
52acb437e8
commit
ac5ac00bab
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -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")
|
||||
|
||||
|
|
|
@ -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))])))
|
Loading…
Reference in New Issue