added struct/derived, tests, and doc updates
This commit is contained in:
Tommy McHugh
Sam Tobin-Hochstadt
parent
58cfb6654a
commit
fc258725ba
|
|
@ -351,15 +351,45 @@ preferred.
|
|||
(posn-y (make-posn 1 2))
|
||||
]}
|
||||
|
||||
@defform*[((struct/derived (id . rest-form)
|
||||
id (field ...) struct-option ...)
|
||||
(struct/derived (id . rest-form)
|
||||
id super-id (field ...) struct-option ...))]{
|
||||
|
||||
The same as @racket[struct], but with an extra @racket[(id
|
||||
. rest-form)] sub-form that is treated as the overall form for
|
||||
syntax-error reporting and otherwise ignored. The only constraint on
|
||||
the sub-form for error reporting is that it starts with @racket[id].
|
||||
The @racket[struct/derived] form is intended for use by macros
|
||||
that expand to @racket[struct].
|
||||
|
||||
@examples[
|
||||
#:eval posn-eval
|
||||
(eval:no-prompt
|
||||
(define-syntax (fruit-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (seeds color) . rest))])))
|
||||
|
||||
(fruit-struct apple)
|
||||
(apple-seeds (apple 12 "red"))
|
||||
(fruit-struct apple #:mutable)
|
||||
(set-apple-seeds! (apple 12 "red") 8)
|
||||
(code:comment "this next line will cause an error due to a bad keyword")
|
||||
(eval:error (fruit-struct apple #:bad-option))
|
||||
]
|
||||
@history[#:added "7.5.0.16"]}
|
||||
|
||||
@defform[(define-struct/derived (id . rest-form)
|
||||
id-maybe-super (field ...) struct-option ...)]{
|
||||
|
||||
The same as @racket[define-struct], but with an extra @racket[(id
|
||||
. rest-form)] sub-form that is treated as the overall form for
|
||||
syntax-error reporting and otherwise ignored. The only constraint on
|
||||
the sub-form for error reporting is that it starts with @racket[id].
|
||||
The @racket[define-struct/derived] form is intended for use by macros
|
||||
Like @racket[struct/derived], except that the syntax for supplying a
|
||||
@racket[super-id] is different, and a @racket[_constructor-id] that
|
||||
has a @racketidfont{make-} prefix on @racket[id] is implicitly
|
||||
supplied via @racket[#:extra-constructor-name] if neither
|
||||
@racket[#:extra-constructor-name] nor @racket[#:constructor-name] is
|
||||
provided. The @racket[define-struct/derived] form is intended for use by macros
|
||||
that expand to @racket[define-struct].
|
||||
|
||||
@examples[
|
||||
|
|
@ -377,7 +407,9 @@ that expand to @racket[define-struct].
|
|||
(set-posn-x! (make-posn 1 2) 0)
|
||||
(code:comment "this next line will cause an error due to a bad keyword")
|
||||
(eval:error (define-xy-struct posn #:bad-option))
|
||||
]}
|
||||
]
|
||||
@history[#:changed "7.5.0.16" @elem{Moved main description to @racket[struct/derived]
|
||||
and replaced with differences.}]}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
(load-relative "unsafe.rktl")
|
||||
(load-relative "object.rktl")
|
||||
(load-relative "struct.rktl")
|
||||
(load-relative "struct-derived.rktl")
|
||||
(load-relative "thread.rktl")
|
||||
(load-relative "logger.rktl")
|
||||
(load-relative "sync.rktl")
|
||||
|
|
|
|||
539
pkgs/racket-test-core/tests/racket/struct-derived.rktl
Normal file
539
pkgs/racket-test-core/tests/racket/struct-derived.rktl
Normal file
|
|
@ -0,0 +1,539 @@
|
|||
(load-relative "loadtest.rktl")
|
||||
|
||||
(Section 'struct-derived)
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
;; Check that struct/derived can be instantiated
|
||||
(test (void) (lambda ()
|
||||
(new-struct foobar (buzz bazz))
|
||||
(void)))
|
||||
|
||||
;; Confirm struct define-values exist
|
||||
(let ()
|
||||
(new-struct foobar (buzz bazz))
|
||||
(test #t procedure? foobar)
|
||||
(test #t struct-type? struct:foobar)
|
||||
(test #t procedure? foobar?)
|
||||
(test #t procedure? foobar-buzz)
|
||||
(test #t procedure? foobar-bazz))
|
||||
|
||||
;; Confirm struct define-values work
|
||||
(let ()
|
||||
(new-struct foobar (buzz bazz bizz))
|
||||
(test #t foobar? (foobar 1 2 3))
|
||||
(let ([val (foobar 1 2 3)])
|
||||
(test 1 foobar-buzz val)
|
||||
(test 2 foobar-bazz val)
|
||||
(test 3 foobar-bizz val)))
|
||||
|
||||
;; Confirm make-struct not available
|
||||
(let ()
|
||||
(new-struct foobar (buzz bazz))
|
||||
(err/rt-test (make-foobar 0 1))))
|
||||
(void)))
|
||||
|
||||
;;; ------------------
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
;; Check that parent-child relationship can be instantiated
|
||||
(test (void) (lambda ()
|
||||
(struct foobar (buzz bazz))
|
||||
(new-struct barfoo foobar (bizz))
|
||||
(void)))
|
||||
;; Confirm struct define-values exist
|
||||
(let ()
|
||||
(struct barfoo (buzz bazz))
|
||||
(new-struct foobar barfoo (bizz))
|
||||
(test #t procedure? foobar)
|
||||
(test #t struct-type? struct:foobar)
|
||||
(test #t procedure? foobar?)
|
||||
(test #t procedure? foobar-bizz))
|
||||
|
||||
;; Confirm struct define-values work
|
||||
(let ()
|
||||
(struct barfoo (buzz bazz))
|
||||
(new-struct foobar barfoo (bizz))
|
||||
(test #t foobar? (foobar 1 2 3))
|
||||
|
||||
(let ([val (foobar 1 2 3)])
|
||||
(test 1 barfoo-buzz val)
|
||||
(test 2 barfoo-bazz val)
|
||||
(test 3 foobar-bizz val))))
|
||||
(void)))
|
||||
|
||||
;; Confirm both forms of constructor-name work
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name extra (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) #:constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
barfoo
|
||||
(buzz bazz bizz))
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar (buzz bazz bizz) #:constructor-name barfoo)
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name extra parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) #:constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
barfoo
|
||||
zap
|
||||
(buzz))
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz)
|
||||
#:constructor-name barfoo)
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
;; Confirm both forms of extra-constructor-name work
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name extra (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) #:extra-constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
barfoo
|
||||
(buzz bazz bizz))
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar (buzz bazz bizz) #:extra-constructor-name barfoo)
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))
|
||||
(test #t (lambda ()
|
||||
(foobar? (foobar 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name extra parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) #:extra-constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
barfoo
|
||||
zap
|
||||
(buzz))
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))
|
||||
(test #t (lambda ()
|
||||
(foobar? (foobar 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz)
|
||||
#:extra-constructor-name barfoo)
|
||||
(test #t (lambda ()
|
||||
(foobar? (barfoo 0 1 2))))
|
||||
(test #t (lambda ()
|
||||
(foobar? (foobar 0 1 2))))))
|
||||
(void)))
|
||||
|
||||
;; Confirm both forms of mutable work
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) #:mutable . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
(buzz bazz bizz))
|
||||
(test 0 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
(buzz bazz bizz)
|
||||
#:mutable)
|
||||
(test 0 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) #:mutable . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz))
|
||||
(test 2 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz)
|
||||
#:mutable)
|
||||
|
||||
(test 2 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (foobar 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
;; Check multiple params work
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name extra (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) #:mutable #:extra-constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
barfoo
|
||||
(buzz bazz bizz))
|
||||
(test #t foobar? (barfoo 0 1 2))
|
||||
(test 0 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
(buzz bazz bizz)
|
||||
#:mutable
|
||||
#:extra-constructor-name barfoo)
|
||||
(test #t foobar? (barfoo 0 1 2))
|
||||
(test 0 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent extra (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) #:mutable #:extra-constructor-name extra . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
barfoo
|
||||
(buzz))
|
||||
|
||||
(test #t foobar? (barfoo 0 1 2))
|
||||
(test 2 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz)
|
||||
#:mutable
|
||||
#:extra-constructor-name barfoo)
|
||||
(test #t foobar? (barfoo 0 1 2))
|
||||
(test 2 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(foobar-buzz val))))
|
||||
(test (void) (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3))))
|
||||
(test 3 (lambda ()
|
||||
(let ([val (barfoo 0 1 2)])
|
||||
(set-foobar-buzz! val 3)
|
||||
(foobar-buzz val))))))
|
||||
(void)))
|
||||
|
||||
|
||||
;; Confirm both forms of omit-define-values work
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) #:omit-define-values . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
(buzz bazz bizz))
|
||||
(test (void) (lambda ()
|
||||
(define foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define struct:foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar? 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar-buzz 1)
|
||||
(void)))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(new-struct foobar
|
||||
(buzz bazz bizz)
|
||||
#:omit-define-values)
|
||||
(test (void) (lambda ()
|
||||
(define foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define struct:foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar? 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar-buzz 1)
|
||||
(void)))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) #:omit-define-values . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz))
|
||||
(test (void) (lambda ()
|
||||
(define foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define struct:foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar? 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar-buzz 1)
|
||||
(void)))))
|
||||
(void)))
|
||||
|
||||
(test (void) (lambda ()
|
||||
(let ()
|
||||
(define-syntax (new-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(ds name parent (fields ...) . rest)
|
||||
(with-syntax ([orig stx])
|
||||
#'(struct/derived orig name parent (fields ...) . rest))]))
|
||||
|
||||
(let ()
|
||||
(struct zap (zip zup))
|
||||
(new-struct foobar
|
||||
zap
|
||||
(buzz)
|
||||
#:omit-define-values)
|
||||
(test (void) (lambda ()
|
||||
(define foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define struct:foobar 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar? 1)
|
||||
(void)))
|
||||
(test (void) (lambda ()
|
||||
(define foobar-buzz 1)
|
||||
(void)))))
|
||||
(void)))
|
||||
|
||||
;;; ------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -14,6 +14,7 @@
|
|||
|
||||
(#%provide define-struct*
|
||||
define-struct/derived
|
||||
struct/derived
|
||||
struct-field-index
|
||||
struct-copy
|
||||
(for-syntax
|
||||
|
|
@ -817,6 +818,53 @@
|
|||
#f
|
||||
"bad syntax"
|
||||
stx)]))
|
||||
|
||||
(define-syntax (struct/derived stx)
|
||||
(define (config-has-name? config)
|
||||
(cond
|
||||
[(syntax? config) (config-has-name? (syntax-e config))]
|
||||
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
|
||||
(eq? (syntax-e (car config)) '#:extra-constructor-name)
|
||||
(config-has-name? (cdr config)))]
|
||||
[else #f]))
|
||||
(syntax-case stx ()
|
||||
[(_ orig id super-id (fields ...) config ...)
|
||||
(and (identifier? #'id)
|
||||
(identifier? #'super-id))
|
||||
(if (not (config-has-name? #'(config ...)))
|
||||
(syntax/loc stx
|
||||
(define-struct/derived orig
|
||||
(id super-id)
|
||||
(fields ...)
|
||||
#:constructor-name id
|
||||
config ...))
|
||||
(syntax/loc stx
|
||||
(define-struct/derived orig
|
||||
(id super-id)
|
||||
(fields ...)
|
||||
config ...)))]
|
||||
[(_ orig id (fields ...) config ...)
|
||||
(identifier? #'id)
|
||||
(if (not (config-has-name? #'(config ...)))
|
||||
(syntax/loc stx
|
||||
(define-struct/derived orig
|
||||
id
|
||||
(fields ...)
|
||||
#:constructor-name id
|
||||
config ...))
|
||||
(syntax/loc stx
|
||||
(define-struct/derived orig
|
||||
id
|
||||
(fields ...)
|
||||
config ...)))]
|
||||
[(_ orig id . rest)
|
||||
(identifier? #'id)
|
||||
(syntax/loc stx
|
||||
(define-struct/derived orig id . rest))]
|
||||
[(_ thing . _) (raise-syntax-error #f
|
||||
"expected an identifier for the structure type name"
|
||||
stx
|
||||
#'thing)]))
|
||||
|
||||
(define-syntax (struct-copy stx)
|
||||
(if (not (eq? (syntax-local-context) 'expression))
|
||||
|
|
|
|||
|
|
@ -244,6 +244,7 @@
|
|||
procedure-reduce-keyword-arity-mask
|
||||
(rename define-struct* define-struct)
|
||||
define-struct/derived
|
||||
struct/derived
|
||||
struct-field-index
|
||||
struct-copy
|
||||
double-flonum?
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user