216 lines
11 KiB
Scheme
216 lines
11 KiB
Scheme
|
|
(module unit scheme/base
|
|
(require mzlib/unit
|
|
scheme/contract
|
|
(for-syntax scheme/base
|
|
syntax/struct))
|
|
(provide (except-out (all-from-out mzlib/unit)
|
|
struct struct/ctc)
|
|
(rename-out [struct* struct]
|
|
[struct/ctc* struct/ctc]))
|
|
|
|
;; Replacement `struct' signature form:
|
|
(define-signature-form (struct* stx)
|
|
(syntax-case stx ()
|
|
((_ name (field ...) opt ...)
|
|
(begin
|
|
(unless (identifier? #'name)
|
|
(raise-syntax-error #f
|
|
"expected an identifier to name the structure type"
|
|
stx
|
|
#'name))
|
|
(for-each (lambda (field)
|
|
(unless (identifier? field)
|
|
(syntax-case field ()
|
|
[(id #:mutable)
|
|
(identifier? #'id)
|
|
'ok]
|
|
[_
|
|
(raise-syntax-error #f
|
|
"bad field specification"
|
|
stx
|
|
field)])))
|
|
(syntax->list #'(field ...)))
|
|
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
|
|
(let loop ([opts (syntax->list #'(opt ...))]
|
|
[no-ctr? #f]
|
|
[mutable? #f]
|
|
[no-stx? #f]
|
|
[no-rt? #f])
|
|
(if (null? opts)
|
|
(values no-ctr? mutable? no-stx? no-rt?)
|
|
(let ([opt (car opts)])
|
|
(case (syntax-e opt)
|
|
[(#:omit-constructor)
|
|
(if no-ctr?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
|
|
[(#:mutable)
|
|
(if mutable?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
|
|
[(#:omit-define-syntaxes)
|
|
(if no-stx?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
|
|
[(#:omit-define-values)
|
|
(if no-rt?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
|
|
[else
|
|
(raise-syntax-error #f
|
|
(string-append
|
|
"expected a keyword to specify option: "
|
|
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
|
stx
|
|
opt)]))))])
|
|
(cons
|
|
#`(define-syntaxes (name)
|
|
#,(build-struct-expand-info
|
|
#'name (syntax->list #'(field ...))
|
|
#f (not mutable?)
|
|
#f '(#f) '(#f)
|
|
#:omit-constructor? no-ctr?))
|
|
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
|
|
#f (not mutable?))])
|
|
(if no-ctr?
|
|
(cons (car names) (cddr names))
|
|
names))))))
|
|
((_ name fields opt ...)
|
|
(raise-syntax-error #f
|
|
"bad syntax; expected a parenthesized sequence of fields"
|
|
stx
|
|
#'fields))
|
|
((_ name)
|
|
(raise-syntax-error #f
|
|
"bad syntax; missing fields"
|
|
stx))
|
|
((_)
|
|
(raise-syntax-error #f
|
|
"missing name and fields"
|
|
stx))))
|
|
|
|
;; Replacement struct/ctc form
|
|
(define-signature-form (struct/ctc* stx)
|
|
(syntax-case stx ()
|
|
((_ name ([field ctc] ...) opt ...)
|
|
(begin
|
|
(unless (identifier? #'name)
|
|
(raise-syntax-error #f
|
|
"expected an identifier to name the structure type"
|
|
stx
|
|
#'name))
|
|
(for-each (lambda (field)
|
|
(unless (identifier? field)
|
|
(syntax-case field ()
|
|
[(id #:mutable)
|
|
(identifier? #'id)
|
|
'ok]
|
|
[_
|
|
(raise-syntax-error #f
|
|
"bad field specification"
|
|
stx
|
|
field)])))
|
|
(syntax->list #'(field ...)))
|
|
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
|
|
(let loop ([opts (syntax->list #'(opt ...))]
|
|
[no-ctr? #f]
|
|
[mutable? #f]
|
|
[no-stx? #f]
|
|
[no-rt? #f])
|
|
(if (null? opts)
|
|
(values no-ctr? mutable? no-stx? no-rt?)
|
|
(let ([opt (car opts)])
|
|
(case (syntax-e opt)
|
|
[(#:omit-constructor)
|
|
(if no-ctr?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
|
|
[(#:mutable)
|
|
(if mutable?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
|
|
[(#:omit-define-syntaxes)
|
|
(if no-stx?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
|
|
[(#:omit-define-values)
|
|
(if no-rt?
|
|
(raise-syntax-error #f
|
|
"redundant option"
|
|
stx
|
|
opt)
|
|
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
|
|
[else
|
|
(raise-syntax-error #f
|
|
(string-append
|
|
"expected a keyword to specify option: "
|
|
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
|
stx
|
|
opt)]))))])
|
|
(define (add-contracts l)
|
|
(let* ([pred (caddr l)]
|
|
[ctor-ctc #`(-> ctc ... #,pred)]
|
|
[pred-ctc #'(-> any/c boolean?)]
|
|
[field-ctcs
|
|
(apply append
|
|
(map (λ (f c)
|
|
(cons #`(-> #,pred #,c)
|
|
(if (and (not mutable?)
|
|
(not (pair? (syntax-e f))))
|
|
null
|
|
#`(-> #,pred #,c void?))))
|
|
(syntax->list #'(field ...))
|
|
(syntax->list #'(ctc ...))))])
|
|
(list* (car l)
|
|
(list (cadr l) ctor-ctc)
|
|
(list pred pred-ctc)
|
|
(map list (cdddr l) field-ctcs))))
|
|
(cons
|
|
#`(define-syntaxes (name)
|
|
#,(build-struct-expand-info
|
|
#'name (syntax->list #'(field ...))
|
|
#f (not mutable?)
|
|
#f '(#f) '(#f)
|
|
#:omit-constructor? no-ctr?))
|
|
(let* ([names (add-contracts
|
|
(build-struct-names #'name (syntax->list #'(field ...))
|
|
#f (not mutable?)))]
|
|
[cpairs (cons 'contracted
|
|
(if no-ctr? (cddr names) (cdr names)))])
|
|
(list (car names) cpairs))))))
|
|
((_ name fields opt ...)
|
|
(raise-syntax-error #f
|
|
"bad syntax; expected a parenthesized sequence of fields"
|
|
stx
|
|
#'fields))
|
|
((_ name)
|
|
(raise-syntax-error #f
|
|
"bad syntax; missing fields"
|
|
stx))
|
|
((_)
|
|
(raise-syntax-error #f
|
|
"missing name and fields"
|
|
stx)))))
|