105 lines
5.0 KiB
Scheme
105 lines
5.0 KiB
Scheme
|
|
(module unit scheme/base
|
|
(require mzlib/unit
|
|
(for-syntax scheme/base
|
|
syntax/struct))
|
|
(provide (except-out (all-from-out mzlib/unit)
|
|
struct)
|
|
(rename-out [struct* struct]))
|
|
|
|
;; Replacement `struct' signature form:
|
|
(define-signature-form (struct* stx)
|
|
(syntax-case stx ()
|
|
((_ name (field ...) opt ...)
|
|
(let ([omit-selectors #f]
|
|
[omit-setters #f]
|
|
[omit-constructor #f]
|
|
[omit-type #f])
|
|
(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)))))
|