Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

struct-copy uses struct-info to determine field accessors rather than break hygiene. #403

Closed
wants to merge 1 commit into from

3 participants

@ianj

Closes bug all/13969

@ianj

The way I match field name with accessor identifier feels a bit heavy-handed, but I don't know a better way to do it. Review?

@samth
Collaborator

This seems like an improvement on the current awfulness of struct-copy, although it isn't a full solution. @mflatt, any thoughts?

@rfindler
Collaborator
@samth
Collaborator
@rfindler
Collaborator
@samth
Collaborator

@mflatt any thoughts on this?

@ianj is this ready to merge? Did you look at checked-struct-info?

@ianj
@samth
Collaborator

Does that mean you don't think we should merge this?

@ianj
@samth samth closed this
@samth
Collaborator

Ok, I closed this.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Aug 16, 2013
  1. @ianj

    struct-copy uses struct-info to determine field accessors rather than…

    ianj authored
    … break hygiene.
    
    Closes all/13969
This page is out of date. Refresh to see the latest.
View
15 pkgs/racket-pkgs/racket-test/tests/racket/struct.rktl
@@ -1067,6 +1067,21 @@
(syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11])))
+(begin-for-syntax
+ (struct S (info) #:property prop:struct-info (λ (s) (S-info s))))
+(let ()
+ (struct a-container (x) #:transparent)
+ (define-syntax a (S (extract-struct-info (syntax-local-value #'a-container))))
+ (struct b a (y) #:transparent)
+
+ (test (a-container 0)
+ 'struct-copy3
+ (struct-copy a (a-container 4) [x 0]))
+
+ (test (b 0 1)
+ 'struct-copy3
+ (struct-copy b (b 2 1) [x #:parent a 0])))
+
(test #t prefab-key? 'apple)
(test #f prefab-key? '#(apple))
(test #t prefab-key? '(apple 4))
View
56 racket/collects/racket/private/define-struct.rkt
@@ -794,20 +794,19 @@
stx
an)]))
ans)
+ (define info-v (syntax-local-value #'info (lambda () #f)))
+ (unless (struct-info? info-v)
+ (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
+ (define info-list (extract-struct-info info-v))
(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))))])
-
+ (values (cadr info-list)
+ (caddr info-list)
+ (cadddr info-list)
+ (list-ref info-list 5))])
(let* ([ensure-really-parent
(λ (id)
- (let loop ([parent parent])
- (cond
+ (let loop ([parent parent])
+ (cond
[(eq? parent #t)
(raise-syntax-error #f "identifier not bound to a parent struct" stx id)]
[(not parent)
@@ -819,27 +818,38 @@
(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
(let ([v (extract-struct-info v)])
(loop (list-ref v 5))))])))]
+ [get-accessor
+ (λ (struct-info field)
+ ;; Since we don't have the field/accessor relationship represented in struct-info,
+ ;; we assume that if the accessor ends in (format "-~a" (syntax-e field)), then
+ ;; it is the accessor we mean to get.
+ (define accessors (cadddr struct-info))
+ (define field-suffix (format "-~a" (syntax-e field)))
+ (define suffix-length (string-length field-suffix))
+ (let loop ([accessors accessors])
+ (if (null? accessors)
+ (raise-syntax-error #f "field not present in struct" stx field)
+ (let* ([accessor (car accessors)]
+ [accessor-str (symbol->string (syntax-e accessor))]
+ [accessor-len (string-length accessor-str)])
+ (cond
+ [(or (< accessor-len suffix-length)
+ (not (string=? field-suffix
+ (substring accessor-str (- accessor-len suffix-length)))))
+ (loop (cdr accessors))]
+ [else accessor])))))]
[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)
+ (list (get-accessor info-list #'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)
+ (list (get-accessor (extract-struct-info (syntax-local-value parent))
+ #'field)
#'expr
(car (generate-temporaries (list #'field)))))]))
ans)]
Something went wrong with that request. Please try again.