diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index 1569f0c882..e865869601 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -654,94 +654,134 @@ "not an identifier for field name" stx #'field))] + [(field #:parent p val) + (unless (identifier? #'field) + (raise-syntax-error #f + "not an identifier for field name" + stx + #'field)) + (unless (identifier? #'p) + (raise-syntax-error #f + "not an identifier for parent struct name" + stx + #'field))] [_ (raise-syntax-error #f - "expected a field update of the form ( )" + "expected a field update of the form ( ) or ( #:parent )" stx an)])) ans) - - (let ([new-fields - (map (lambda (an) - (syntax-case an () - [(field expr) - (list (datum->syntax #'field - (string->symbol - (format "~a-~a" - (syntax-e #'info) - (syntax-e #'field))) - #'field) - #'expr - (car (generate-temporaries (list #'field))))])) - ans)]) - - ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f) - (let ([new-binding-for - (lambda (f) - (ormap (lambda (new-field) - (and (free-identifier=? (car new-field) f) - (caddr new-field))) - new-fields))]) + (let-values ([(construct pred accessors parent) + (let ([v (syntax-local-value #'info (lambda () #f))]) + (unless (struct-info? v) + (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info)) + (let ([v (extract-struct-info v)]) + (values (cadr v) + (caddr v) + (cadddr v) + (list-ref v 5))))]) + + (let* ([ensure-really-parent + (λ (id) + (let loop ([parent parent]) + (cond + [(eq? parent #t) + (raise-syntax-error #f "identifier not bound to a parent struct" stx id)] + [(not parent) + (raise-syntax-error #f "parent struct information not known" stx id)] + [(free-identifier=? id parent) (void)] + [else + (let ([v (syntax-local-value parent (lambda () #f))]) + (unless (struct-info? v) + (raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?) + (let ([v (extract-struct-info v)]) + (loop (list-ref v 5))))])))] + [new-fields + (map (lambda (an) + (syntax-case an () + [(field expr) + (list (datum->syntax #'field + (string->symbol + (format "~a-~a" + (syntax-e #'info) + (syntax-e #'field))) + #'field) + #'expr + (car (generate-temporaries (list #'field))))] + [(field #:parent id expr) + (begin + (ensure-really-parent #'id) + (list (datum->syntax #'field + (string->symbol + (format "~a-~a" + (syntax-e #'id) + (syntax-e #'field))) + #'field) + #'expr + (car (generate-temporaries (list #'field)))))])) + ans)] + + ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f) + [new-binding-for + (lambda (f) + (ormap (lambda (new-field) + (and (free-identifier=? (car new-field) f) + (caddr new-field))) + new-fields))]) - (let-values ([(construct pred accessors) - (let ([v (syntax-local-value #'info (lambda () #f))]) - (unless (struct-info? v) - (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info)) - (let ([v (extract-struct-info v)]) - (values (cadr v) - (caddr v) - (cadddr v))))]) - (unless construct - (raise-syntax-error #f - "constructor not statically known for structure type" - stx - #'info)) - (unless pred - (raise-syntax-error #f - "predicate not statically known for structure type" - stx - #'info)) - (unless (andmap values accessors) - (raise-syntax-error #f - "not all accessors are statically known for structure type" - stx - #'info)) - (let ([dests - (map (lambda (new-field) - (or (ormap (lambda (f2) - (and f2 - (free-identifier=? (car new-field) f2) - f2)) - accessors) - (raise-syntax-error #f - "accessor name not associated with the given structure type" - stx - (car new-field)))) - new-fields)]) - ;; Check for duplicates using dests, not as, because mod=? as might not be id=? - (let ((dupe (check-duplicate-identifier dests))) - (when dupe - (raise-syntax-error #f - "duplicate field assignment" - stx - ;; Map back to an original field: - (ormap (lambda (nf) - (and nf - (free-identifier=? dupe (car nf)) - (car nf))) - (reverse new-fields))))) + (unless construct + (raise-syntax-error #f + "constructor not statically known for structure type" + stx + #'info)) + (unless pred + (raise-syntax-error #f + "predicate not statically known for structure type" + stx + #'info)) + (unless (andmap values accessors) + (raise-syntax-error #f + "not all accessors are statically known for structure type" + stx + #'info)) - ;; the actual result - #`(let ((the-struct struct-expr)) - (if (#,pred the-struct) - (let #,(map (lambda (new-field) - #`[#,(caddr new-field) #,(cadr new-field)]) - new-fields) - (#,construct - #,@(map - (lambda (field) (or (new-binding-for field) - #`(#,field the-struct))) - (reverse accessors)))) - (raise-type-error 'form-name - #,(format "~a" (syntax-e #'info)) - the-struct))))))))])))) + + (let ([dests + (map (lambda (new-field) + (or (ormap (lambda (f2) + (and f2 + (free-identifier=? (car new-field) f2) + f2)) + accessors) + (raise-syntax-error #f + "accessor name not associated with the given structure type" + stx + (car new-field)))) + new-fields)]) + ;; Check for duplicates using dests, not as, because mod=? as might not be id=? + (let ((dupe (check-duplicate-identifier dests))) + (when dupe + (raise-syntax-error #f + "duplicate field assignment" + stx + ;; Map back to an original field: + (ormap (lambda (nf) + (and nf + (free-identifier=? dupe (car nf)) + (car nf))) + (reverse new-fields))))) + + ;; the actual result + #`(let ((the-struct struct-expr)) + (if (#,pred the-struct) + (let #,(map (lambda (new-field) + #`[#,(caddr new-field) #,(cadr new-field)]) + new-fields) + (#,construct + #,@(map + (lambda (field) (or (new-binding-for field) + #`(#,field the-struct))) + (reverse accessors)))) + (raise-type-error 'form-name + #,(format "~a" (syntax-e #'info)) + the-struct)))))))])))) diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 90f18e611a..63bbc09ae1 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -388,19 +388,24 @@ by @racket[make-struct-type-property], @racket[#f] otherwise.} @;------------------------------------------------------------------------ @section[#:tag "struct-copy"]{Copying and Updating Structures} -@defform[(struct-copy id struct-expr [field-id expr] ...)]{ +@defform/subs[(struct-copy id struct-expr fld-id ...) + ((fld-id [field-id expr] + [field-id #:parent parent-id expr]))]{ Creates a new instance of the structure type @racket[id] with the same field values as the structure produced by @racket[struct-expr], except that the value of each supplied @racket[field-id] is instead -determined by the corresponding @racket[expr]. +determined by the corresponding @racket[expr]. If @racket[#:parent] +is specified, the @racket[parent-id] must be bound to a parent +structure type of @racket[id]. The @racket[id] must have a @tech{transformer binding} that encapsulates information about a structure type (i.e., like the initial identifier bound by @racket[struct]), and the binding must supply a constructor, a predicate, and all field accessors. -Each @racket[field-id] is combined with @racket[id] to form +Each @racket[field-id] is combined with @racket[id] +(or @racket[parent-id], if present) to form @racket[id]@racketidfont{-}@racket[field-id] (using the lexical context of @racket[field-id]), which must be one of the accessor bindings in @racket[id]. The accessor bindings determined by different diff --git a/collects/tests/racket/struct.rktl b/collects/tests/racket/struct.rktl index fd65ec7a31..3ecb1a5d0f 100644 --- a/collects/tests/racket/struct.rktl +++ b/collects/tests/racket/struct.rktl @@ -1005,4 +1005,60 @@ ;; ---------------------------------------- +(let () + (struct s (a b)) + (struct t s (c)) + (struct u t (d)) + (test 11 + 'struct-copy1 + (t-c (struct-copy t (t 1 2 3) [c 11]))) + (test 11 + 'struct-copy2 + (s-a (struct-copy t (t 1 2 3) [a #:parent s 11]))) + (test 11 + 'struct-copy2 + (s-a (struct-copy u (u 1 2 3 4) [a #:parent s 11]))) + + (syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11]))) + +(let () + (struct s (a b) #:transparent) + (struct t s (c) #:transparent) + (struct u t (d) #:transparent) + (test (t 1 2 11) + 'struct-copy1 + (struct-copy t (t 1 2 3) [c 11])) + (test (t 11 2 3) + 'struct-copy2 + (struct-copy t (t 1 2 3) [a #:parent s 11])) + (test (s 11 2) + 'struct-copy2 + (struct-copy s (t 1 2 3) [a 11])) + (test (u 11 2 3 4) + 'struct-copy2 + (struct-copy u (u 1 2 3 4) [a #:parent s 11])) + + (syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11]))) + +(let () + (struct s (a b) #:prefab) + (struct t s (c) #:prefab) + (struct u t (d) #:prefab) + (test (t 1 2 11) + 'struct-copy1 + (struct-copy t (t 1 2 3) [c 11])) + (test (t 11 2 3) + 'struct-copy2 + (struct-copy t (t 1 2 3) [a #:parent s 11])) + (test (s 11 2) + 'struct-copy2 + (struct-copy s (t 1 2 3) [a 11])) + (test (u 11 2 3 4) + 'struct-copy2 + (struct-copy u (u 1 2 3 4) [a #:parent s 11])) + + (syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11]))) + +;; ---------------------------------------- + (report-errs)