diff --git a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl index 137cb4f1f7..7b9ef67e28 100644 --- a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl @@ -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.}]} @; ---------------------------------------- diff --git a/pkgs/racket-test-core/tests/racket/core-tests.rktl b/pkgs/racket-test-core/tests/racket/core-tests.rktl index 9af4f6e2b2..9d09d3edbf 100644 --- a/pkgs/racket-test-core/tests/racket/core-tests.rktl +++ b/pkgs/racket-test-core/tests/racket/core-tests.rktl @@ -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") diff --git a/pkgs/racket-test-core/tests/racket/struct-derived.rktl b/pkgs/racket-test-core/tests/racket/struct-derived.rktl new file mode 100644 index 0000000000..31933c2322 --- /dev/null +++ b/pkgs/racket-test-core/tests/racket/struct-derived.rktl @@ -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) diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index 4f545a70b4..938c2ae1c8 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -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)) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 38a6827df8..3d297182cf 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -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?