Skip to content

Commit

Permalink
Fix racket#1399: fix struct-copy bugs by exploiting struct-info
Browse files Browse the repository at this point in the history 
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
(racket#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.
  • Loading branch information
@sorawee
sorawee committed Apr 23, 2020
1 parent f27dbb7 commit d9ef39f
Show file tree
Hide file tree
Showing 3 changed files with 201 additions and 156 deletions.
19 changes: 11 additions & 8 deletions pkgs/racket-doc/scribblings/reference/struct.scrbl
View file
Expand Up @@ -412,8 +412,9 @@ by @racket[make-struct-type-property], @racket[#f] otherwise.}
((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
Expand All @@ -424,12 +425,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.

Expand Down Expand Up @@ -815,6 +815,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))
Expand Down
24 changes: 24 additions & 0 deletions pkgs/racket-test-core/tests/racket/struct.rktl
View file
Expand Up @@ -1101,6 +1101,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))
Expand Down
314 changes: 166 additions & 148 deletions racket/collects/racket/private/define-struct.rkt
View file
Expand Up @@ -817,154 +817,172 @@
"bad syntax"
stx)]))

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

0 comments on commit d9ef39f

Please sign in to comment.