From 52b5f1864f32a6186da416c8e0b677f59b488d5d Mon Sep 17 00:00:00 2001 From: Sorawee Porncharoenwase Date: Sun, 16 Jun 2019 13:07:21 -0700 Subject: [PATCH] Fix #1399: fix struct-copy bugs by exploiting struct-info This PR fixes four bugs: 1. Accessors are required at use-site in order to use `struct-copy`. This PR removes that requirement since the information is already available in struct-info. The following program used to fail prior the PR but will now pass. ``` (module a racket (provide a) (struct a (b))) (require 'a) (struct-copy a (a 1) [b 2]) ``` 2. `struct-copy` fails if the structure type transformer binding is renamed (#1399). The following program used to fail prior the PR but will now pass. ``` (module struct racket/base (provide (struct-out point)) (struct point (x y) #:transparent)) (require (rename-in 'struct [point point2d])) (struct-copy point2d (point2d 1 2) [x 3]) ``` 3. With supertype, it's possible to construct colliding accessors, causing `struct-copy` to update an incorrect field. The following program produced incorrect outputs prior this PR but will now be correct. ``` (module a racket (provide a) (struct a (b-c) #:transparent)) (require 'a) (struct a-b a (c) #:transparent) (struct-copy a-b (a-b 1 2) [b-c #:parent a 10]) ;; before the PR: (a-b 1 10), after the PR: (a-b 10 2) (struct-copy a-b (a-b 1 2) [c 10]) ;; before the PR: (a-b 1 10), after the PR: (a-b 1 10) ``` 4. Similar to 3., prior this commit, it's possible to refer to a bogus field name when supertype is present. The following program doesn't result in a syntax error which is wrong. This commit fixes that. ``` (module a racket/base (provide (all-defined-out)) (struct a (b-c) #:transparent)) (require 'a) (struct a-b a (d) #:transparent) (struct-copy a-b (a-b 1 2) [c 10]) ``` The key idea is that the actual struct name (if the struct is created via `struct` or `define-struct`) can be extracted from the name of struct predicate. The actual field names then can be precisely extracted from accessors. Note that struct-infos that are created manually by `make-struct-info` didn't work with `struct-copy`. This PR didn't attempt to fix that because it requires a significant change that would not be backward compatible with the current struct info. --- .../scribblings/reference/struct.scrbl | 19 +- .../racket-test-core/tests/racket/struct.rktl | 24 ++ .../collects/racket/private/define-struct.rkt | 314 +++++++++--------- 3 files changed, 201 insertions(+), 156 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/struct.scrbl b/pkgs/racket-doc/scribblings/reference/struct.scrbl index 1ea4b87763..34b48d6c56 100644 --- a/pkgs/racket-doc/scribblings/reference/struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/struct.scrbl @@ -426,8 +426,9 @@ Returns @racket[#t] if @racket[v] is a predicate procedure produced by ((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 +Creates a new instance of the structure type @racket[id] (which is defined via a +@seclink["define-struct"]{structure type defining form} such as @racket[struct]) +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]. If @racket[#:parent] is specified, the @racket[parent-id] must be bound to a parent @@ -438,12 +439,11 @@ 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] -(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 -@racket[field-id]s must be distinct. The order of the +Each @racket[field-id] must correspond to a @racket[field-id] in +the @seclink["define-struct"]{structure type defining forms} of @racket[id] +(or @racket[parent-id], if present). The accessor bindings determined by different +@racket[field-id]s under the same @racket[id] (or @racket[parent-id], if present) +must be distinct. The order of the @racket[field-id]s need not match the order of the corresponding fields in the structure type. @@ -829,6 +829,9 @@ specified through a transformer binding to such a value.} Encapsulates a thunk that returns structure-type information in list form. Note that accessors are listed in reverse order, as mentioned in @secref{structinfo}.} +Note that the field names are not well-defined for struct-type informations +that are created with this method, so it is likely not going to work well +with forms like @racket[struct-copy] and @racket[struct*]. @(struct-eval '(require (for-syntax racket/base))) @(struct-eval '(require racket/match)) diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index bd65d80bf0..dd46464b10 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -1117,6 +1117,30 @@ (syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11]))) +(module test-struct-rename racket/base + (provide (rename-out [point point2d])) + (struct point (x y) #:transparent)) + +(let () + (local-require 'test-struct-rename) + (test (point2d 3 2) 'struct-copy1 (struct-copy point2d (point2d 1 2) [x 3]))) + +(module test-struct-parent racket/base + (provide a) + (struct a (b-c) #:transparent)) + +(let () + (local-require 'test-struct-parent) + (struct a-b a (c) #:transparent) + + (test (a-b 10 2) 'struct-copy1 (struct-copy a-b (a-b 1 2) [b-c #:parent a 10])) + (test (a-b 1 10) 'struct-copy2 (struct-copy a-b (a-b 1 2) [c 10]))) + +(let () + (local-require 'test-struct-parent) + (struct a-b a (d) #:transparent) + (syntax-test #'(struct-copy a-b (a-b 1 2) [c 10]))) + (test #t prefab-key? 'apple) (test #f prefab-key? '#(apple)) (test #t prefab-key? '(apple 4)) diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index b86ee0ee45..1dcc4adfbf 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -872,154 +872,172 @@ stx #'thing)])) + ;; findf :: (a -> boolean?) -> (listof a) -> (or/c a #f) + (define-for-syntax (findf f xs) + (cond + [(null? xs) #f] + [else (define e (car xs)) + (if (f e) e (findf f (cdr xs)))])) + + ;; take :: (listof a) -> number? -> (listof a) + (define-for-syntax (take xs n) + (cond + [(= n 0) '()] + [(null? xs) xs] + [else (cons (car xs) (take (cdr xs) (sub1 n)))])) + + ;; modified from racket/collects/racket/contract/private/provide.rkt + (define-for-syntax (predicate->struct-name orig-stx stx) + (cond + [(regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx))) => cadr] + [else + (raise-syntax-error + #f + "unable to cope with a struct type whose predicate doesn't end with `?'" + orig-stx)])) + + (define-for-syntax (find-accessor the-struct-info fld stx) + (define accessors (list-ref the-struct-info 3)) + (define parent (list-ref the-struct-info 5)) + (define num-fields (length accessors)) + (define num-super-fields + (if (identifier? parent) (length (cadddr (id->struct-info parent stx))) 0)) + (define num-own-fields (- num-fields num-super-fields)) + (define own-accessors (take accessors num-own-fields)) + (define struct-name (predicate->struct-name stx (list-ref the-struct-info 2))) + (define accessor-name (string->symbol (format "~a-~a" struct-name (syntax-e fld)))) + (or (findf (λ (a) (eq? accessor-name (syntax-e a))) own-accessors) + (raise-syntax-error + #f "accessor name not associated with the given structure type" + stx fld))) + + (define-for-syntax (id->struct-info id stx) + (define the-struct-info (syntax-local-value id (lambda () #f))) + (unless (struct-info? the-struct-info) + (raise-syntax-error #f "identifier is not bound to a structure type" stx id)) + (extract-struct-info the-struct-info)) + + (define-for-syntax (struct-copy-core stx) + (with-syntax ([(form-name info struct-expr field+val ...) stx]) + (define ans (syntax->list #'(field+val ...))) + ;; Check syntax: + (unless (identifier? #'info) + (raise-syntax-error #f "not an identifier for structure type" stx #'info)) + + (for-each (lambda (an) + (syntax-case an () + [(field val) + (unless (identifier? #'field) + (raise-syntax-error #f + "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 + (string-append + "bad syntax;\n" + " expected a field update of the form ( )\n" + " or ( #:parent )") + stx + an)])) + ans) + + (define the-struct-info (id->struct-info #'info stx)) + (define construct (cadr the-struct-info)) + (define pred (caddr the-struct-info)) + (define accessors (cadddr the-struct-info)) + (define parent (list-ref the-struct-info 5)) + + (define (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))))]))) + + (define new-fields + (map (lambda (an) + (syntax-case an () + [(field expr) + (list (find-accessor the-struct-info #'field stx) + #'expr + (car (generate-temporaries (list #'field))))] + [(field #:parent id expr) + (begin + (ensure-really-parent #'id) + (list (find-accessor (id->struct-info #'id stx) #'field stx) + #'expr + (car (generate-temporaries (list #'field)))))])) + ans)) + + ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f) + (define (new-binding-for f) + (ormap (lambda (new-field) + (and (free-identifier=? (car new-field) f) + (caddr new-field))) + 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)) + + (define dests (map car 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-argument-error 'form-name + #,(format "~a?" (syntax-e #'info)) + the-struct))))) + (define-syntax (struct-copy stx) (if (not (eq? (syntax-local-context) 'expression)) (quasisyntax/loc stx (#%expression #,stx)) - (syntax-case stx () - [(form-name info struct-expr field+val ...) - (let ([ans (syntax->list #'(field+val ...))]) - ;; Check syntax: - (unless (identifier? #'info) - (raise-syntax-error #f "not an identifier for structure type" stx #'info)) - (for-each (lambda (an) - (syntax-case an () - [(field val) - (unless (identifier? #'field) - (raise-syntax-error #f - "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 - (string-append - "bad syntax;\n" - " expected a field update of the form ( )\n" - " or ( #:parent )") - stx - an)])) - ans) - (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))]) - - (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))))) - - ;; 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-argument-error 'form-name - #,(format "~a?" (syntax-e #'info)) - the-struct)))))))])))) + (struct-copy-core stx))))