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.
This commit is contained in:
Sorawee Porncharoenwase
Sam Tobin-Hochstadt
parent
219f9c0846
commit
52b5f1864f
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 (<field-id> <expr>)\n"
|
||||
" or (<field-id> #:parent <parent-id> <expr>)")
|
||||
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 (<field-id> <expr>)\n"
|
||||
" or (<field-id> #:parent <parent-id> <expr>)")
|
||||
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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user