added struct/derived, tests, and doc updates

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
+Like @racket[struct/derived], except that the syntax for supplying a
-. rest-form)] sub-form that is treated as the overall form for
+@racket[super-id] is different, and a @racket[_constructor-id] that
-syntax-error reporting and otherwise ignored.  The only constraint on
+has a @racketidfont{make-} prefix on @racket[id] is implicitly
-the sub-form for error reporting is that it starts with @racket[id].
+supplied via @racket[#:extra-constructor-name] if neither
-The @racket[define-struct/derived] form is intended for use by macros
+@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.}]}
 
 @; ----------------------------------------
 

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")

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)

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))

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?