use #lang and reindent
svn: r15919
This commit is contained in:
Eli Barzilay
parent
6806f21118
commit
efaec81861
|
|
@ -1,344 +1,343 @@
|
|||
|
||||
;; NOTE: datatypes are currently transparent, for the sake of EoPL's
|
||||
;; use of `equal?'
|
||||
|
||||
(module datatype mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/pconvert-prop)
|
||||
(require-for-syntax "private/utils.ss")
|
||||
(require mzlib/pconvert-prop)
|
||||
(require-for-syntax "private/utils.ss")
|
||||
|
||||
(define-syntax define-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name pred-name
|
||||
(variant-name (field-name field-pred) ...)
|
||||
...)
|
||||
(let ([variant-names (syntax->list (syntax (variant-name ...)))])
|
||||
;; More syntax checks...
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the datatype name"
|
||||
stx (syntax name)))
|
||||
(unless (identifier? (syntax pred-name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the predicate name"
|
||||
stx (syntax pred-name)))
|
||||
(for-each (lambda (vt fields)
|
||||
(unless (identifier? vt)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"expected an identifier for the variant name"
|
||||
stx vt))
|
||||
(for-each (lambda (field)
|
||||
(unless (identifier? field)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"expected an identifier for the field name"
|
||||
stx field)))
|
||||
(syntax->list fields)))
|
||||
variant-names
|
||||
(syntax->list (syntax ((field-name ...) ...))))
|
||||
;; Count the fields for each variant:
|
||||
(with-syntax ([(variant-field-count ...)
|
||||
(map (lambda (n)
|
||||
(datum->syntax-object (quote-syntax here) n #f))
|
||||
(map length
|
||||
(map
|
||||
syntax->list
|
||||
(syntax->list
|
||||
(syntax ((field-name ...) ...))))))]
|
||||
[(variant? ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a?" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-accessor ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a-accessor" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-mutator ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(make-variant ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(struct:variant ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(make-variant-name ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e vn)))))
|
||||
variant-names)])
|
||||
(syntax
|
||||
(begin
|
||||
(define-syntax name
|
||||
;; Note: we're back to the transformer environment, here.
|
||||
;; Also, this isn't a transformer function, so any direct
|
||||
;; use of the name will trigger a syntax error. The name
|
||||
;; can be found by `syntax-local-value', though.
|
||||
(let ([cert (syntax-local-certifier #t)])
|
||||
(make-dt (cert (syntax pred-name))
|
||||
(list
|
||||
(make-vt (cert (syntax variant-name))
|
||||
(cert (syntax variant?))
|
||||
(cert (syntax variant-accessor))
|
||||
variant-field-count)
|
||||
...))))
|
||||
;; Bind the predicate and selector functions:
|
||||
(define-values (pred-name
|
||||
variant-name ...
|
||||
variant? ...
|
||||
variant-accessor ...)
|
||||
;; Create a new structure for the datatype (using the
|
||||
;; datatype name in `struct', so it prints nicely).
|
||||
(let-values ([(struct:x make-x x? acc mut)
|
||||
(make-struct-type 'name #f 0 0 #f null (make-inspector))])
|
||||
(let-values ([(struct:variant make-variant variant?
|
||||
variant-accessor variant-mutator)
|
||||
(make-struct-type 'variant-name struct:x variant-field-count 0
|
||||
#f
|
||||
`((,prop:print-convert-constructor-name . variant-name))
|
||||
(make-inspector))]
|
||||
...)
|
||||
;; User-available functions:
|
||||
(values
|
||||
x? ;; The datatype predicate
|
||||
;; Create the constructor functions:
|
||||
(let ([vname (quote variant-name)])
|
||||
(let ([variant-name
|
||||
(lambda (field-name ...)
|
||||
(unless (field-pred field-name)
|
||||
(error vname
|
||||
"bad value for ~a field: ~e"
|
||||
(quote field-name)
|
||||
field-name))
|
||||
...
|
||||
(make-variant field-name ...))])
|
||||
variant-name))
|
||||
...
|
||||
variant? ...
|
||||
variant-accessor ...))))
|
||||
;; Compatibility bindings
|
||||
(define-values (make-variant-name ...) (values variant-name ...))))))]
|
||||
[(_ name pred-name variant ...)
|
||||
;; Must be a bad variant...
|
||||
(for-each (lambda (variant)
|
||||
(syntax-case variant ()
|
||||
[(variant-name field ...)
|
||||
(let ([name (syntax variant-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the variant name"
|
||||
stx
|
||||
name))
|
||||
;; Must be a bad field:
|
||||
(for-each (lambda (field)
|
||||
(syntax-case field ()
|
||||
[(field-name field-pred)
|
||||
(let ([name (syntax field-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the field name"
|
||||
stx
|
||||
name)))]
|
||||
[_else
|
||||
(define-syntax define-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name pred-name
|
||||
(variant-name (field-name field-pred) ...)
|
||||
...)
|
||||
(let ([variant-names (syntax->list (syntax (variant-name ...)))])
|
||||
;; More syntax checks...
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the datatype name"
|
||||
stx (syntax name)))
|
||||
(unless (identifier? (syntax pred-name))
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the predicate name"
|
||||
stx (syntax pred-name)))
|
||||
(for-each (lambda (vt fields)
|
||||
(unless (identifier? vt)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"expected an identifier for the variant name"
|
||||
stx vt))
|
||||
(for-each (lambda (field)
|
||||
(unless (identifier? field)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"expected an identifier for the field name"
|
||||
stx field)))
|
||||
(syntax->list fields)))
|
||||
variant-names
|
||||
(syntax->list (syntax ((field-name ...) ...))))
|
||||
;; Count the fields for each variant:
|
||||
(with-syntax ([(variant-field-count ...)
|
||||
(map (lambda (n)
|
||||
(datum->syntax-object (quote-syntax here) n #f))
|
||||
(map length
|
||||
(map
|
||||
syntax->list
|
||||
(syntax->list
|
||||
(syntax ((field-name ...) ...))))))]
|
||||
[(variant? ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a?" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-accessor ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a-accessor" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-mutator ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(make-variant ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(struct:variant ...)
|
||||
(generate-temporaries variant-names)]
|
||||
[(make-variant-name ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
vn
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e vn)))))
|
||||
variant-names)])
|
||||
(syntax
|
||||
(begin
|
||||
(define-syntax name
|
||||
;; Note: we're back to the transformer environment, here.
|
||||
;; Also, this isn't a transformer function, so any direct
|
||||
;; use of the name will trigger a syntax error. The name
|
||||
;; can be found by `syntax-local-value', though.
|
||||
(let ([cert (syntax-local-certifier #t)])
|
||||
(make-dt (cert (syntax pred-name))
|
||||
(list
|
||||
(make-vt (cert (syntax variant-name))
|
||||
(cert (syntax variant?))
|
||||
(cert (syntax variant-accessor))
|
||||
variant-field-count)
|
||||
...))))
|
||||
;; Bind the predicate and selector functions:
|
||||
(define-values (pred-name
|
||||
variant-name ...
|
||||
variant? ...
|
||||
variant-accessor ...)
|
||||
;; Create a new structure for the datatype (using the
|
||||
;; datatype name in `struct', so it prints nicely).
|
||||
(let-values ([(struct:x make-x x? acc mut)
|
||||
(make-struct-type 'name #f 0 0 #f null (make-inspector))])
|
||||
(let-values ([(struct:variant make-variant variant?
|
||||
variant-accessor variant-mutator)
|
||||
(make-struct-type 'variant-name struct:x variant-field-count 0
|
||||
#f
|
||||
`((,prop:print-convert-constructor-name . variant-name))
|
||||
(make-inspector))]
|
||||
...)
|
||||
;; User-available functions:
|
||||
(values
|
||||
x? ;; The datatype predicate
|
||||
;; Create the constructor functions:
|
||||
(let ([vname (quote variant-name)])
|
||||
(let ([variant-name
|
||||
(lambda (field-name ...)
|
||||
(unless (field-pred field-name)
|
||||
(error vname
|
||||
"bad value for ~a field: ~e"
|
||||
(quote field-name)
|
||||
field-name))
|
||||
...
|
||||
(make-variant field-name ...))])
|
||||
variant-name))
|
||||
...
|
||||
variant? ...
|
||||
variant-accessor ...))))
|
||||
;; Compatibility bindings
|
||||
(define-values (make-variant-name ...) (values variant-name ...))))))]
|
||||
[(_ name pred-name variant ...)
|
||||
;; Must be a bad variant...
|
||||
(for-each (lambda (variant)
|
||||
(syntax-case variant ()
|
||||
[(variant-name field ...)
|
||||
(let ([name (syntax variant-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the variant name"
|
||||
stx
|
||||
name))
|
||||
;; Must be a bad field:
|
||||
(for-each (lambda (field)
|
||||
(syntax-case field ()
|
||||
[(field-name field-pred)
|
||||
(let ([name (syntax field-name)])
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for the field name"
|
||||
stx
|
||||
name)))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a field name followed by a predicate expression, all in parentheses"
|
||||
stx
|
||||
field)]))
|
||||
(syntax->list (syntax (field ...)))))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a variant name followed by a sequence of field declarations, all in parentheses"
|
||||
stx
|
||||
variant)]))
|
||||
(syntax->list (syntax (variant ...))))]
|
||||
[(_ name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"missing predicate name and variant clauses"
|
||||
stx)])))
|
||||
|
||||
(define-syntax cases
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ datatype expr
|
||||
clause
|
||||
...)
|
||||
;; Get datatype information:
|
||||
(let ([dt (and (identifier? (syntax datatype))
|
||||
(syntax-local-value (syntax datatype) (lambda () #f)))])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"not a datatype name"
|
||||
stx
|
||||
(syntax datatype)))
|
||||
|
||||
;; Parse clauses:
|
||||
(let-values ([(vts field-idss bodys else-body)
|
||||
(let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null])
|
||||
(cond
|
||||
[(null? clauses)
|
||||
(values null null null #f)]
|
||||
[else
|
||||
(let ([clause (car clauses)])
|
||||
(syntax-case* clause (else)
|
||||
(lambda (a b)
|
||||
(and (eq? (syntax-e b) 'else)
|
||||
(not (identifier-binding b))))
|
||||
[(variant (field-id ...) body0 body1 ...)
|
||||
(let* ([variant (syntax variant)]
|
||||
[vt
|
||||
(ormap (lambda (dtv)
|
||||
(let ([vt-name (vt-name-stx dtv)])
|
||||
(and (module-identifier=? variant vt-name)
|
||||
dtv)))
|
||||
(dt-variants dt))]
|
||||
[orig-variant (and vt (vt-name-stx vt))])
|
||||
(unless orig-variant
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a variant of `~a'"
|
||||
(syntax-object->datum (syntax datatype)))
|
||||
stx
|
||||
variant))
|
||||
|
||||
(let ([field-ids (syntax->list (syntax (field-id ...)))])
|
||||
(for-each (lambda (fid)
|
||||
(unless (identifier? fid)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a field"
|
||||
stx
|
||||
fid)))
|
||||
field-ids)
|
||||
(let ([dtv (variant-assq variant (dt-variants dt))])
|
||||
(unless (= (length field-ids)
|
||||
(vt-field-count dtv))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a field name followed by a predicate expression, all in parentheses"
|
||||
(format
|
||||
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
|
||||
(syntax-object->datum variant)
|
||||
(syntax-object->datum (syntax datatype))
|
||||
(vt-field-count dtv)
|
||||
(length field-ids))
|
||||
stx
|
||||
field)]))
|
||||
(syntax->list (syntax (field ...)))))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a variant name followed by a sequence of field declarations, all in parentheses"
|
||||
stx
|
||||
variant)]))
|
||||
(syntax->list (syntax (variant ...))))]
|
||||
[(_ name)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"missing predicate name and variant clauses"
|
||||
stx)])))
|
||||
|
||||
(define-syntax cases
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ datatype expr
|
||||
clause
|
||||
...)
|
||||
;; Get datatype information:
|
||||
(let ([dt (and (identifier? (syntax datatype))
|
||||
(syntax-local-value (syntax datatype) (lambda () #f)))])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
'cases
|
||||
"not a datatype name"
|
||||
stx
|
||||
(syntax datatype)))
|
||||
|
||||
;; Parse clauses:
|
||||
(let-values ([(vts field-idss bodys else-body)
|
||||
(let loop ([clauses (syntax->list (syntax (clause ...)))][saw-cases null])
|
||||
(cond
|
||||
[(null? clauses)
|
||||
(values null null null #f)]
|
||||
[else
|
||||
(let ([clause (car clauses)])
|
||||
(syntax-case* clause (else) (lambda (a b)
|
||||
(and (eq? (syntax-e b) 'else)
|
||||
(not (identifier-binding b))))
|
||||
[(variant (field-id ...) body0 body1 ...)
|
||||
(let* ([variant (syntax variant)]
|
||||
[vt
|
||||
(ormap (lambda (dtv)
|
||||
(let ([vt-name (vt-name-stx dtv)])
|
||||
(and (module-identifier=? variant vt-name)
|
||||
dtv)))
|
||||
(dt-variants dt))]
|
||||
[orig-variant (and vt (vt-name-stx vt))])
|
||||
(unless orig-variant
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a variant of `~a'"
|
||||
(syntax-object->datum (syntax datatype)))
|
||||
stx
|
||||
variant))
|
||||
clause)))
|
||||
|
||||
(let ([field-ids (syntax->list (syntax (field-id ...)))])
|
||||
(for-each (lambda (fid)
|
||||
(unless (identifier? fid)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for a field"
|
||||
stx
|
||||
fid)))
|
||||
field-ids)
|
||||
(let ([dtv (variant-assq variant (dt-variants dt))])
|
||||
(unless (= (length field-ids)
|
||||
(vt-field-count dtv))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format
|
||||
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
|
||||
(syntax-object->datum variant)
|
||||
(syntax-object->datum (syntax datatype))
|
||||
(vt-field-count dtv)
|
||||
(length field-ids))
|
||||
stx
|
||||
clause)))
|
||||
;; Check for duplicate local field ids:
|
||||
(let ([dup (check-duplicate-identifier field-ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate field identifier"
|
||||
stx
|
||||
dup)))
|
||||
|
||||
;; Check for duplicate local field ids:
|
||||
(let ([dup (check-duplicate-identifier field-ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate field identifier"
|
||||
stx
|
||||
dup)))
|
||||
;; Check for redundant case:
|
||||
(when (memq orig-variant saw-cases)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate case"
|
||||
stx
|
||||
clause))
|
||||
|
||||
;; Check for redundant case:
|
||||
(when (memq orig-variant saw-cases)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate case"
|
||||
stx
|
||||
clause))
|
||||
|
||||
;; This clause is ok:
|
||||
(let-values ([(vts idss bodys else)
|
||||
(loop (cdr clauses) (cons orig-variant saw-cases))])
|
||||
(values (cons vt vts)
|
||||
(cons field-ids idss)
|
||||
(cons (syntax (begin body0 body1 ...)) bodys)
|
||||
else))))]
|
||||
[(else body0 body1 ...)
|
||||
(begin
|
||||
(unless (null? (cdr clauses))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"else clause must be last"
|
||||
stx
|
||||
clause))
|
||||
(values null null null (syntax (begin body0 body1 ...))))]
|
||||
[_else (raise-syntax-error
|
||||
#f
|
||||
"bad clause"
|
||||
stx
|
||||
clause)]))]))])
|
||||
|
||||
;; Missing any variants?
|
||||
(unless (or else-body
|
||||
(= (length vts) (length (dt-variants dt))))
|
||||
(let* ([here (map vt-name-stx vts)]
|
||||
[missing (let loop ([l (dt-variants dt)])
|
||||
(cond
|
||||
[(null? l) ""]
|
||||
[(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here)
|
||||
(loop (cdr l))]
|
||||
[else
|
||||
(format " ~a~a"
|
||||
(syntax-e (vt-name-stx (car l)))
|
||||
(loop (cdr l)))]))])
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "missing cases for the following variants:~a" missing)
|
||||
stx)))
|
||||
|
||||
;; Create the result:
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(variant? ...) (map vt-predicate-stx vts)]
|
||||
[((field-extraction ...) ...)
|
||||
(map (lambda (vt)
|
||||
(with-syntax ([accessor (vt-accessor-stx vt)])
|
||||
(let loop ([n 0])
|
||||
(if (= n (vt-field-count vt))
|
||||
null
|
||||
(cons (with-syntax ([n n])
|
||||
(syntax (accessor v n)))
|
||||
(loop (add1 n)))))))
|
||||
vts)]
|
||||
[((field-id ...) ...) field-idss]
|
||||
[(body ...) bodys]
|
||||
[else-body (or else-body
|
||||
(syntax
|
||||
(error 'cases "no variant case matched")))])
|
||||
(syntax
|
||||
(let ([v expr])
|
||||
(if (not (pred v))
|
||||
(error 'cases "not a ~a: ~s"
|
||||
(quote datatype) v)
|
||||
(cond
|
||||
[(variant? v)
|
||||
(let ([field-id field-extraction] ...)
|
||||
body)]
|
||||
...
|
||||
[else else-body])))))))])))
|
||||
|
||||
(define-syntax provide-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ datatype)
|
||||
(let ([dt (syntax-local-value (syntax datatype) (lambda () #f))])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a datatype name"
|
||||
stx
|
||||
(syntax datatype)))
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(orig-variant ...)
|
||||
(map vt-name-stx (dt-variants dt))])
|
||||
(syntax
|
||||
(provide datatype
|
||||
pred
|
||||
orig-variant ...))))])))
|
||||
;; This clause is ok:
|
||||
(let-values ([(vts idss bodys else)
|
||||
(loop (cdr clauses) (cons orig-variant saw-cases))])
|
||||
(values (cons vt vts)
|
||||
(cons field-ids idss)
|
||||
(cons (syntax (begin body0 body1 ...)) bodys)
|
||||
else))))]
|
||||
[(else body0 body1 ...)
|
||||
(begin
|
||||
(unless (null? (cdr clauses))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"else clause must be last"
|
||||
stx
|
||||
clause))
|
||||
(values null null null (syntax (begin body0 body1 ...))))]
|
||||
[_else (raise-syntax-error
|
||||
#f
|
||||
"bad clause"
|
||||
stx
|
||||
clause)]))]))])
|
||||
|
||||
(provide define-datatype cases provide-datatype))
|
||||
;; Missing any variants?
|
||||
(unless (or else-body
|
||||
(= (length vts) (length (dt-variants dt))))
|
||||
(let* ([here (map vt-name-stx vts)]
|
||||
[missing (let loop ([l (dt-variants dt)])
|
||||
(cond
|
||||
[(null? l) ""]
|
||||
[(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here)
|
||||
(loop (cdr l))]
|
||||
[else
|
||||
(format " ~a~a"
|
||||
(syntax-e (vt-name-stx (car l)))
|
||||
(loop (cdr l)))]))])
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "missing cases for the following variants:~a" missing)
|
||||
stx)))
|
||||
|
||||
;; Create the result:
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(variant? ...) (map vt-predicate-stx vts)]
|
||||
[((field-extraction ...) ...)
|
||||
(map (lambda (vt)
|
||||
(with-syntax ([accessor (vt-accessor-stx vt)])
|
||||
(let loop ([n 0])
|
||||
(if (= n (vt-field-count vt))
|
||||
null
|
||||
(cons (with-syntax ([n n])
|
||||
(syntax (accessor v n)))
|
||||
(loop (add1 n)))))))
|
||||
vts)]
|
||||
[((field-id ...) ...) field-idss]
|
||||
[(body ...) bodys]
|
||||
[else-body (or else-body
|
||||
(syntax
|
||||
(error 'cases "no variant case matched")))])
|
||||
(syntax
|
||||
(let ([v expr])
|
||||
(if (not (pred v))
|
||||
(error 'cases "not a ~a: ~s" (quote datatype) v)
|
||||
(cond
|
||||
[(variant? v)
|
||||
(let ([field-id field-extraction] ...)
|
||||
body)]
|
||||
...
|
||||
[else else-body])))))))])))
|
||||
|
||||
(define-syntax provide-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ datatype)
|
||||
(let ([dt (syntax-local-value (syntax datatype) (lambda () #f))])
|
||||
(unless (dt? dt)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a datatype name"
|
||||
stx
|
||||
(syntax datatype)))
|
||||
(with-syntax ([pred (dt-pred-stx dt)]
|
||||
[(orig-variant ...)
|
||||
(map vt-name-stx (dt-variants dt))])
|
||||
(syntax
|
||||
(provide datatype
|
||||
pred
|
||||
orig-variant ...))))])))
|
||||
|
||||
(provide define-datatype cases provide-datatype)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user