Fix contract-out for struct
- A part of contract-out's code generation for struct assumes that there's no parent struct and uses the provided struct name for everything. This causes duplicate definitions when there are duplicate field names where one is in a child struct and another is in a parent struct. This PR fixes the problem. - Disallow multiple #:omit-constructor - Deprecate super-id. This information is unnecessary since we can extract it from static struct information already. Attempting to check that super-id is well-formed is error-prone due to how the super struct type could be contracted which shields us from detecting that they are indeed the super type. - Utilize static struct field name information, and provide the information when exporting a struct. This PR is largely based on #732. Fixes: #3266, #3269, #3271, and #3272
This commit is contained in:
Sorawee Porncharoenwase
Robby Findler
parent
b9770f6869
commit
ee773b2835
|
|
@ -1838,7 +1838,7 @@ earlier fields.}}
|
||||||
(code:line)
|
(code:line)
|
||||||
(code:line #:unprotected-submodule submodule-name)]
|
(code:line #:unprotected-submodule submodule-name)]
|
||||||
[contract-out-item
|
[contract-out-item
|
||||||
(struct id/super ((id contract-expr) ...)
|
(struct id/ignored ((id contract-expr) ...)
|
||||||
struct-option)
|
struct-option)
|
||||||
(rename orig-id id contract-expr)
|
(rename orig-id id contract-expr)
|
||||||
(id contract-expr)
|
(id contract-expr)
|
||||||
|
|
@ -1847,8 +1847,8 @@ earlier fields.}}
|
||||||
(code:line #:∀ poly-variables)
|
(code:line #:∀ poly-variables)
|
||||||
(code:line #:forall poly-variables)]
|
(code:line #:forall poly-variables)]
|
||||||
[poly-variables id (id ...)]
|
[poly-variables id (id ...)]
|
||||||
[id/super id
|
[id/ignored id
|
||||||
(id super-id)]
|
(id ignored-id)]
|
||||||
[struct-option (code:line)
|
[struct-option (code:line)
|
||||||
#:omit-constructor])]{
|
#:omit-constructor])]{
|
||||||
|
|
||||||
|
|
@ -1876,13 +1876,8 @@ first variable (the internal name) with the name specified by the
|
||||||
second variable (the external name).
|
second variable (the external name).
|
||||||
|
|
||||||
The @racket[struct] form of @racket[contract-out]
|
The @racket[struct] form of @racket[contract-out]
|
||||||
provides a structure-type definition, and each field has a contract
|
provides a structure-type definition @racket[id], and each field has a contract
|
||||||
that dictates the contents of the fields. The structure-type
|
that dictates the contents of the fields. Unlike a @racket[struct]
|
||||||
definition must appear before the @racket[provide] clause within the
|
|
||||||
enclosing module. If the structure type has a parent, the second
|
|
||||||
@racket[struct] form (above) must be used, with the first name
|
|
||||||
referring to the structure type to export and the second name
|
|
||||||
referring to the parent structure type. Unlike a @racket[struct]
|
|
||||||
definition, however, all of the fields (and their contracts) must be
|
definition, however, all of the fields (and their contracts) must be
|
||||||
listed. The contract on the fields that the sub-struct shares with its
|
listed. The contract on the fields that the sub-struct shares with its
|
||||||
parent are only used in the contract for the sub-struct's constructor, and
|
parent are only used in the contract for the sub-struct's constructor, and
|
||||||
|
|
@ -1890,7 +1885,10 @@ the selector or mutators for the super-struct are not provided. The
|
||||||
exported structure-type name always doubles as a constructor, even if
|
exported structure-type name always doubles as a constructor, even if
|
||||||
the original structure-type name does not act as a constructor.
|
the original structure-type name does not act as a constructor.
|
||||||
If the @racket[#:omit-constructor] option is present, the constructor
|
If the @racket[#:omit-constructor] option is present, the constructor
|
||||||
is not provided.
|
is not provided. The second form of @racket[id/ignored], which has both
|
||||||
|
@racket[id] and @racket[ignored-id], is deprecated and allowed
|
||||||
|
in the grammar only for backward compatability, where @racket[ignored-id] is ignored.
|
||||||
|
The first form should be used instead.
|
||||||
|
|
||||||
Note that if the struct is created with @racket[serializable-struct]
|
Note that if the struct is created with @racket[serializable-struct]
|
||||||
or @racket[define-serializable-struct], @racket[contract-out] does not
|
or @racket[define-serializable-struct], @racket[contract-out] does not
|
||||||
|
|
@ -1918,7 +1916,8 @@ is bound to vectors of two elements, the exported identifier and a
|
||||||
syntax object for the expression that produces the contract controlling
|
syntax object for the expression that produces the contract controlling
|
||||||
the export.
|
the export.
|
||||||
|
|
||||||
@history[#:changed "7.3.0.3" @list{Added @racket[#:unprotected-submodule].}]
|
@history[#:changed "7.3.0.3" @list{Added @racket[#:unprotected-submodule].}
|
||||||
|
#:changed "7.7.0.9" @list{Deprecated @racket[ignored-id].}]
|
||||||
}
|
}
|
||||||
|
|
||||||
@defform[(recontract-out id ...)]{
|
@defform[(recontract-out id ...)]{
|
||||||
|
|
|
||||||
|
|
@ -1296,21 +1296,22 @@
|
||||||
(require 'provide/contract70-b racket/contract/base)
|
(require 'provide/contract70-b racket/contract/base)
|
||||||
(void stream stream? stream-x stream-y set-stream-y!)))))
|
(void stream stream? stream-x stream-y set-stream-y!)))))
|
||||||
|
|
||||||
(contract-error-test
|
(test/spec-passed/result
|
||||||
'provide/contract-struct-out
|
'provide/contract-struct-out
|
||||||
#'(begin
|
#'(begin
|
||||||
(eval '(module pos racket/base
|
(eval '(module test-ignore-super-position racket/base
|
||||||
(require racket/contract)
|
(require racket/contract)
|
||||||
(provide
|
(provide
|
||||||
(contract-out
|
(contract-out
|
||||||
[struct (b not-a) ()])
|
[struct (b not-a) ()]))
|
||||||
|
|
||||||
|
(struct a ())
|
||||||
|
(struct b a ())))
|
||||||
|
(eval '(require 'test-ignore-super-position))
|
||||||
|
(eval '(b? (b))))
|
||||||
|
#t)
|
||||||
|
|
||||||
|
|
||||||
(struct a ())
|
|
||||||
(struct b a ())))))
|
|
||||||
(λ (x)
|
|
||||||
(and (exn:fail:syntax? x)
|
|
||||||
(regexp-match #rx"^contract-out: expected a struct name"
|
|
||||||
(exn-message x)))))
|
|
||||||
|
|
||||||
(contract-error-test
|
(contract-error-test
|
||||||
'contract-error-test8
|
'contract-error-test8
|
||||||
|
|
@ -1788,5 +1789,76 @@
|
||||||
[x (>/c 5)]))
|
[x (>/c 5)]))
|
||||||
(define x 6)))))
|
(define x 6)))))
|
||||||
(list '(>/c 5)))
|
(list '(>/c 5)))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'struct-field-name-computed-correctly
|
||||||
|
'(begin
|
||||||
|
(eval '(module first racket
|
||||||
|
(provide (contract-out (struct foo ([x any/c])))
|
||||||
|
(contract-out (struct (bar foo) ([x any/c]))))
|
||||||
|
(struct foo (x))
|
||||||
|
(struct bar foo ())))
|
||||||
|
(eval '(module second racket
|
||||||
|
(require 'first)
|
||||||
|
(provide (contract-out (struct foo ([x any/c])))
|
||||||
|
(contract-out (struct (bar foo) ([x any/c]))))))
|
||||||
|
(eval '(module third racket
|
||||||
|
(require 'second)
|
||||||
|
(provide (contract-out (struct foo ([x any/c])))
|
||||||
|
(contract-out (struct (bar foo) ([x any/c]))))))
|
||||||
|
(eval '(require 'third))
|
||||||
|
(eval '(foo-x (bar 1))))
|
||||||
|
1)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'provide/contract-struct-out-id-generation
|
||||||
|
'(begin
|
||||||
|
(eval '(module provide/contract-struct-out-id-generation racket
|
||||||
|
(struct foo (x))
|
||||||
|
(struct bar foo (x))
|
||||||
|
(provide (contract-out (struct foo ([x any/c]))
|
||||||
|
(struct (bar foo) ([x any/c] [x any/c]))))))
|
||||||
|
(eval '(require 'provide/contract-struct-out-id-generation))
|
||||||
|
(eval '(let ([val (bar 1 2)])
|
||||||
|
(list (foo-x val) (bar-x val)))))
|
||||||
|
(list 1 2))
|
||||||
|
|
||||||
|
(contract-error-test
|
||||||
|
'provide/contract-struct-out-omit-constructor
|
||||||
|
#'(begin
|
||||||
|
(eval '(module provide/contract-struct-out-omit-constructor racket/base
|
||||||
|
(require racket/contract)
|
||||||
|
(provide
|
||||||
|
(contract-out
|
||||||
|
[struct a () #:omit-constructor #:omit-constructor]))
|
||||||
|
|
||||||
|
(struct a ()))))
|
||||||
|
(λ (x)
|
||||||
|
(and (exn:fail:syntax? x)
|
||||||
|
(regexp-match #rx"malformed struct option" (exn-message x)))))
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'provide/contract-struct-out-super-struct-omitted
|
||||||
|
'(begin
|
||||||
|
(eval '(module provide/contract-struct-out-super-struct-omitted racket
|
||||||
|
(struct foo (x))
|
||||||
|
(struct bar foo (y))
|
||||||
|
(provide (contract-out (struct bar ([x any/c] [y any/c]))))))
|
||||||
|
(eval '(require 'provide/contract-struct-out-super-struct-omitted))
|
||||||
|
(eval '(let ([val (bar 1 2)])
|
||||||
|
(bar-y val))))
|
||||||
|
2)
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'provide/contract-struct-out-static-field-name
|
||||||
|
'(begin
|
||||||
|
(eval '(module provide/contract-struct-out-static-field-name racket
|
||||||
|
(struct foo (x))
|
||||||
|
(provide (contract-out (struct foo ([x any/c]))))))
|
||||||
|
(eval '(require 'provide/contract-struct-out-static-field-name
|
||||||
|
(for-syntax racket/struct-info racket/base)))
|
||||||
|
(eval '(define-syntax (extract-field-names stx)
|
||||||
|
#`'#,(struct-field-info-list (syntax-local-value #'foo))))
|
||||||
|
(eval '(extract-field-names)))
|
||||||
|
(list 'x))
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -21,7 +21,7 @@
|
||||||
(define (update-loc stx loc)
|
(define (update-loc stx loc)
|
||||||
(datum->syntax stx (syntax-e stx) loc))
|
(datum->syntax stx (syntax-e stx) loc))
|
||||||
|
|
||||||
;; lookup-struct-info : syntax -> (union #f struct-info?)
|
;; lookup-struct-info : syntax -> struct-info?
|
||||||
(define (lookup-struct-info stx provide-stx)
|
(define (lookup-struct-info stx provide-stx)
|
||||||
(define id (syntax-case stx ()
|
(define id (syntax-case stx ()
|
||||||
[(a b) (syntax a)]
|
[(a b) (syntax a)]
|
||||||
|
|
|
||||||
|
|
@ -15,6 +15,7 @@
|
||||||
|
|
||||||
(require (for-syntax racket/base
|
(require (for-syntax racket/base
|
||||||
racket/list
|
racket/list
|
||||||
|
racket/string
|
||||||
racket/struct-info
|
racket/struct-info
|
||||||
setup/path-to-relative
|
setup/path-to-relative
|
||||||
"application-arity-checking.rkt"
|
"application-arity-checking.rkt"
|
||||||
|
|
@ -63,25 +64,51 @@
|
||||||
;; Return the original struct name associated with the argument, or #f if
|
;; Return the original struct name associated with the argument, or #f if
|
||||||
;; the input is not an indirect struct info.
|
;; the input is not an indirect struct info.
|
||||||
(define-values-for-syntax [make-contract-out-redirect-struct-info
|
(define-values-for-syntax [make-contract-out-redirect-struct-info
|
||||||
|
make-contract-out-redirect/field-struct-info
|
||||||
make-applicable-contract-out-redirect-struct-info
|
make-applicable-contract-out-redirect-struct-info
|
||||||
|
make-applicable-contract-out-redirect/field-struct-info
|
||||||
undo-contract-out-redirect]
|
undo-contract-out-redirect]
|
||||||
(let-values ([(struct:r make-r r? r-ref r-set!)
|
(let ()
|
||||||
(make-struct-type
|
(define-values (struct:r make-r r? r-ref r-set!)
|
||||||
'contract-out-redirect-struct-info struct:struct-info
|
(make-struct-type
|
||||||
1 0 #f
|
'contract-out-redirect-struct-info struct:struct-info
|
||||||
'()
|
1 0 #f
|
||||||
(current-inspector) #f '(0))])
|
'()
|
||||||
(letrec-values ([(struct:app-r make-app-r app-r? app-r-ref app-r-set!)
|
(current-inspector) #f '(0)))
|
||||||
(make-struct-type
|
|
||||||
'applicable-contract-out-redirect-struct-info struct:r
|
(define-values (struct:r/field make-r/field r/field? r/field-ref r/field-set!)
|
||||||
1 0 #f
|
(make-struct-type
|
||||||
(list (cons prop:procedure
|
'contract-out-redirect/field-struct-info struct:r
|
||||||
(lambda (v stx)
|
1 0 #f
|
||||||
(self-ctor-transformer ((app-r-ref v 0)) stx))))
|
(list (cons prop:struct-field-info
|
||||||
(current-inspector) #f '(0))])
|
(lambda (rec)
|
||||||
(define (undo-contract-out-redirect v)
|
(r/field-ref rec 0))))))
|
||||||
(and (r? v) ((r-ref v 0))))
|
|
||||||
(values make-r make-app-r undo-contract-out-redirect))))
|
(define-values (struct:app-r make-app-r app-r? app-r-ref app-r-set!)
|
||||||
|
(make-struct-type
|
||||||
|
'applicable-contract-out-redirect-struct-info struct:r
|
||||||
|
1 0 #f
|
||||||
|
(list (cons prop:procedure
|
||||||
|
(lambda (v stx)
|
||||||
|
(self-ctor-transformer ((app-r-ref v 0)) stx))))
|
||||||
|
(current-inspector) #f '(0)))
|
||||||
|
|
||||||
|
(define-values (struct:app-r/field
|
||||||
|
make-app-r/field
|
||||||
|
app-r/field?
|
||||||
|
app-r/field-ref
|
||||||
|
app-r/field-set!)
|
||||||
|
(make-struct-type
|
||||||
|
'applicable-contract-out-redirect/field-struct-info struct:app-r
|
||||||
|
1 0 #f
|
||||||
|
(list (cons prop:struct-field-info
|
||||||
|
(lambda (rec)
|
||||||
|
(app-r/field-ref rec 0))))))
|
||||||
|
|
||||||
|
(define (undo-contract-out-redirect v)
|
||||||
|
(and (r? v) ((r-ref v 0))))
|
||||||
|
|
||||||
|
(values make-r make-r/field make-app-r make-app-r/field undo-contract-out-redirect)))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
|
|
||||||
|
|
@ -651,6 +678,10 @@
|
||||||
"malformed struct option"
|
"malformed struct option"
|
||||||
provide-stx
|
provide-stx
|
||||||
option)))
|
option)))
|
||||||
|
(unless (<= (length (syntax->list #'(options ...))) 1)
|
||||||
|
(raise-syntax-error who
|
||||||
|
"malformed struct option"
|
||||||
|
provide-stx))
|
||||||
(add-to-dups-table #'struct-name)
|
(add-to-dups-table #'struct-name)
|
||||||
(define omit-constructor?
|
(define omit-constructor?
|
||||||
(member '#:omit-constructor (map syntax-e (syntax->list #'(options ...)))))
|
(member '#:omit-constructor (map syntax-e (syntax->list #'(options ...)))))
|
||||||
|
|
@ -731,7 +762,7 @@
|
||||||
(and (identifier? (syntax name))
|
(and (identifier? (syntax name))
|
||||||
(identifier? (syntax super)))
|
(identifier? (syntax super)))
|
||||||
#t]
|
#t]
|
||||||
[else #f])))
|
[_ #f])))
|
||||||
|
|
||||||
;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
|
;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
|
||||||
;; constructs the code for a struct clause
|
;; constructs the code for a struct clause
|
||||||
|
|
@ -741,23 +772,9 @@
|
||||||
(let* ([struct-name (syntax-case struct-name-position ()
|
(let* ([struct-name (syntax-case struct-name-position ()
|
||||||
[(a b) (syntax a)]
|
[(a b) (syntax a)]
|
||||||
[else struct-name-position])]
|
[else struct-name-position])]
|
||||||
[super-id (syntax-case struct-name-position ()
|
|
||||||
[(a b) (syntax b)]
|
|
||||||
[else #t])]
|
|
||||||
|
|
||||||
|
|
||||||
[all-parent-struct-count/names
|
|
||||||
(get-field-counts/struct-names struct-name provide-stx)]
|
|
||||||
[_ (and (syntax? super-id)
|
|
||||||
(a:lookup-struct-info super-id provide-stx))] ;; for the error check
|
|
||||||
[parent-struct-count (if (null? all-parent-struct-count/names)
|
|
||||||
#f
|
|
||||||
(let ([pp (cdr all-parent-struct-count/names)])
|
|
||||||
(if (null? pp)
|
|
||||||
#f
|
|
||||||
(car (car pp)))))]
|
|
||||||
|
|
||||||
[the-struct-info (a:lookup-struct-info struct-name-position provide-stx)]
|
[the-struct-info (a:lookup-struct-info struct-name-position provide-stx)]
|
||||||
|
[true-field-names (and (struct-field-info? the-struct-info)
|
||||||
|
(struct-field-info-list the-struct-info))]
|
||||||
[orig-struct-name
|
[orig-struct-name
|
||||||
(or (undo-contract-out-redirect the-struct-info)
|
(or (undo-contract-out-redirect the-struct-info)
|
||||||
struct-name)]
|
struct-name)]
|
||||||
|
|
@ -767,7 +784,24 @@
|
||||||
[predicate-id (list-ref the-struct-info-list 2)]
|
[predicate-id (list-ref the-struct-info-list 2)]
|
||||||
[orig-predicate-id (list-ref orig-struct-info-list 2)]
|
[orig-predicate-id (list-ref orig-struct-info-list 2)]
|
||||||
[selector-ids (reverse (list-ref the-struct-info-list 3))]
|
[selector-ids (reverse (list-ref the-struct-info-list 3))]
|
||||||
|
[_ (when (and (not (null? selector-ids))
|
||||||
|
(not (last selector-ids)))
|
||||||
|
(raise-syntax-error
|
||||||
|
who
|
||||||
|
(format "cannot determine the number of fields in struct")
|
||||||
|
provide-stx
|
||||||
|
struct-name))]
|
||||||
[orig-selector-ids (reverse (list-ref orig-struct-info-list 3))]
|
[orig-selector-ids (reverse (list-ref orig-struct-info-list 3))]
|
||||||
|
[super-id (list-ref the-struct-info-list 5)]
|
||||||
|
[parent-struct-count (cond
|
||||||
|
[(boolean? super-id) #f]
|
||||||
|
[else (length
|
||||||
|
(list-ref
|
||||||
|
(extract-struct-info
|
||||||
|
(a:lookup-struct-info
|
||||||
|
super-id
|
||||||
|
provide-stx))
|
||||||
|
3))])]
|
||||||
[type-is-only-constructor? (free-identifier=? constructor-id struct-name)]
|
[type-is-only-constructor? (free-identifier=? constructor-id struct-name)]
|
||||||
; I think there's no way to detect when the struct-name binding isn't a constructor
|
; I think there's no way to detect when the struct-name binding isn't a constructor
|
||||||
[type-is-constructor? #t]
|
[type-is-constructor? #t]
|
||||||
|
|
@ -781,13 +815,7 @@
|
||||||
#t))]
|
#t))]
|
||||||
[mutator-ids (reverse (list-ref the-struct-info-list 4))] ;; (listof (union #f identifier))
|
[mutator-ids (reverse (list-ref the-struct-info-list 4))] ;; (listof (union #f identifier))
|
||||||
[orig-mutator-ids (reverse (list-ref orig-struct-info-list 4))]
|
[orig-mutator-ids (reverse (list-ref orig-struct-info-list 4))]
|
||||||
[field-contract-ids (map (λ (field-name field-contract)
|
|
||||||
(mangled-id-scope
|
|
||||||
(a:mangle-id "provide/contract-field-contract"
|
|
||||||
field-name
|
|
||||||
struct-name)))
|
|
||||||
field-names
|
|
||||||
field-contracts)]
|
|
||||||
[struct:struct-name
|
[struct:struct-name
|
||||||
(or (list-ref the-struct-info-list 0)
|
(or (list-ref the-struct-info-list 0)
|
||||||
(datum->syntax
|
(datum->syntax
|
||||||
|
|
@ -832,60 +860,43 @@
|
||||||
selector-ids))))
|
selector-ids))))
|
||||||
|
|
||||||
(unless (equal? (length selector-ids)
|
(unless (equal? (length selector-ids)
|
||||||
(length field-contract-ids))
|
(length field-names))
|
||||||
(raise-syntax-error who
|
(raise-syntax-error who
|
||||||
(format "found ~a field~a in struct, but ~a contract~a"
|
(format "found ~a field~a in struct, but ~a contract~a"
|
||||||
(length selector-ids)
|
(length selector-ids)
|
||||||
(if (= 1 (length selector-ids)) "" "s")
|
(if (= 1 (length selector-ids)) "" "s")
|
||||||
(length field-contract-ids)
|
(length field-names)
|
||||||
(if (= 1 (length field-contract-ids)) "" "s"))
|
(if (= 1 (length field-names)) "" "s"))
|
||||||
provide-stx
|
provide-stx
|
||||||
struct-name))
|
struct-name))
|
||||||
|
|
||||||
;; make sure the field names are right.
|
;; make sure the field names are right.
|
||||||
(let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)])
|
(define all-field+struct-names
|
||||||
(cond
|
(extract-field+struct-names the-struct-info struct-name provide-stx))
|
||||||
[(null? c) null]
|
(for ([field+struct-name (in-list all-field+struct-names)]
|
||||||
[(null? (cdr c)) c]
|
[field-name (in-list (reverse field-names))])
|
||||||
[else (cons (- (car c) (cadr c))
|
(define field-name-should-be (car field+struct-name))
|
||||||
(loop (cdr c)))]))]
|
(define field-name-is (syntax-e field-name))
|
||||||
[names (map cdr all-parent-struct-count/names)]
|
(unless (equal? field-name-should-be field-name-is)
|
||||||
[predicate-name (format "~a" (syntax-e predicate-id))])
|
(raise-syntax-error who
|
||||||
(let loop ([count (car relative-counts)]
|
(format "expected field name to be ~a, but found ~a"
|
||||||
[name (car names)]
|
field-name-should-be
|
||||||
[counts (cdr relative-counts)]
|
field-name-is)
|
||||||
[names (cdr names)]
|
provide-stx
|
||||||
[selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x)))
|
field-name)))
|
||||||
selector-ids))]
|
|
||||||
[field-names (reverse field-names)])
|
(define (make-identifier sym)
|
||||||
(cond
|
(datum->syntax #f sym))
|
||||||
[(or (null? selector-strs) (null? field-names))
|
|
||||||
(void)]
|
(define field-contract-ids
|
||||||
[(zero? count)
|
(for/list ([field+struct-name (in-list all-field+struct-names)])
|
||||||
(loop (car counts) (car names) (cdr counts) (cdr names)
|
(mangled-id-scope
|
||||||
selector-strs
|
(a:mangle-id "provide/contract-field-contract"
|
||||||
field-names)]
|
(make-identifier (car field+struct-name))
|
||||||
[else
|
(make-identifier (cdr field+struct-name))
|
||||||
(let* ([selector-str (car selector-strs)]
|
(make-identifier 'for)
|
||||||
[field-name (car field-names)]
|
struct-name))))
|
||||||
[field-name-should-be
|
|
||||||
(substring selector-str
|
|
||||||
(+ (string-length name) 1)
|
|
||||||
(string-length selector-str))]
|
|
||||||
[field-name-is (format "~a" (syntax-e field-name))])
|
|
||||||
(unless (equal? field-name-should-be field-name-is)
|
|
||||||
(raise-syntax-error who
|
|
||||||
(format "expected field name to be ~a, but found ~a"
|
|
||||||
field-name-should-be
|
|
||||||
field-name-is)
|
|
||||||
provide-stx
|
|
||||||
field-name))
|
|
||||||
(loop (- count 1)
|
|
||||||
name
|
|
||||||
counts
|
|
||||||
names
|
|
||||||
(cdr selector-strs)
|
|
||||||
(cdr field-names)))])))
|
|
||||||
(with-syntax ([((selector-codes selector-new-names) ...)
|
(with-syntax ([((selector-codes selector-new-names) ...)
|
||||||
(for/list ([selector-id (in-list selector-ids)]
|
(for/list ([selector-id (in-list selector-ids)]
|
||||||
[orig-selector-id (in-list orig-selector-ids)]
|
[orig-selector-id (in-list orig-selector-ids)]
|
||||||
|
|
@ -987,6 +998,14 @@
|
||||||
[(a b) #'(quote-syntax b)]
|
[(a b) #'(quote-syntax b)]
|
||||||
[else #f])))]
|
[else #f])))]
|
||||||
[(exported-selector-ids ...) (reverse selector-ids)])
|
[(exported-selector-ids ...) (reverse selector-ids)])
|
||||||
|
(define mk
|
||||||
|
(if (and type-is-constructor? (not omit-constructor?))
|
||||||
|
(if true-field-names
|
||||||
|
#'make-applicable-contract-out-redirect/field-struct-info
|
||||||
|
#'make-applicable-contract-out-redirect-struct-info)
|
||||||
|
(if true-field-names
|
||||||
|
#'make-contract-out-redirect/field-struct-info
|
||||||
|
#'make-contract-out-redirect-struct-info)))
|
||||||
(define proc
|
(define proc
|
||||||
#`(λ ()
|
#`(λ ()
|
||||||
(list (quote-syntax -struct:struct-name)
|
(list (quote-syntax -struct:struct-name)
|
||||||
|
|
@ -998,20 +1017,22 @@
|
||||||
(quote-syntax rev-selector-old-names) ...)
|
(quote-syntax rev-selector-old-names) ...)
|
||||||
(list rev-mutator-id-info ...)
|
(list rev-mutator-id-info ...)
|
||||||
super-id)))
|
super-id)))
|
||||||
|
(define the-constructor
|
||||||
|
(if (and type-is-constructor? (not omit-constructor?))
|
||||||
|
#'((lambda () (quote-syntax constructor-new-name)))
|
||||||
|
#'()))
|
||||||
|
(define the-field-names
|
||||||
|
(if true-field-names
|
||||||
|
#`('#,true-field-names)
|
||||||
|
#'()))
|
||||||
#`(begin
|
#`(begin
|
||||||
(provide (rename-out [id-rename struct-name]))
|
(provide (rename-out [id-rename struct-name]))
|
||||||
(define-syntax id-rename
|
(define-syntax id-rename
|
||||||
#,(if (and type-is-constructor? (not omit-constructor?))
|
(#,mk
|
||||||
#`(make-applicable-contract-out-redirect-struct-info
|
#,proc
|
||||||
#,proc
|
(lambda () (quote-syntax orig-struct-name))
|
||||||
(lambda ()
|
#,@the-constructor
|
||||||
(quote-syntax orig-struct-name))
|
#,@the-field-names))))]
|
||||||
(lambda ()
|
|
||||||
(quote-syntax constructor-new-name)))
|
|
||||||
#`(make-contract-out-redirect-struct-info
|
|
||||||
#,proc
|
|
||||||
(lambda ()
|
|
||||||
(quote-syntax orig-struct-name)))))))]
|
|
||||||
[struct:struct-name struct:struct-name]
|
[struct:struct-name struct:struct-name]
|
||||||
[-struct:struct-name -struct:struct-name]
|
[-struct:struct-name -struct:struct-name]
|
||||||
[struct-name struct-name]
|
[struct-name struct-name]
|
||||||
|
|
@ -1064,41 +1085,77 @@
|
||||||
(loop (cdr l1)
|
(loop (cdr l1)
|
||||||
(+ i 1)))])))
|
(+ i 1)))])))
|
||||||
|
|
||||||
;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol))
|
|
||||||
;; returns a list of numbers corresponding to the numbers of fields for each parent struct
|
|
||||||
(define (get-field-counts/struct-names struct-name provide-stx)
|
|
||||||
(let loop ([parent-info-id struct-name]
|
|
||||||
[orig-struct? #t])
|
|
||||||
(let ([parent-info
|
|
||||||
(and (identifier? parent-info-id)
|
|
||||||
(extract-struct-info (a:lookup-struct-info parent-info-id provide-stx)))])
|
|
||||||
(cond
|
|
||||||
[(boolean? parent-info) null]
|
|
||||||
[else
|
|
||||||
(let ([fields (list-ref parent-info 3)]
|
|
||||||
[predicate (list-ref parent-info 2)])
|
|
||||||
(cond
|
|
||||||
[(and (not (null? fields))
|
|
||||||
(not (last fields)))
|
|
||||||
(raise-syntax-error
|
|
||||||
who
|
|
||||||
(format "cannot determine the number of fields in ~astruct"
|
|
||||||
(if orig-struct? "" "parent "))
|
|
||||||
provide-stx
|
|
||||||
struct-name)]
|
|
||||||
[else
|
|
||||||
(cons (cons (length fields) (predicate->struct-name provide-stx predicate))
|
|
||||||
(loop (list-ref parent-info 5) #f))]))]))))
|
|
||||||
|
|
||||||
(define (predicate->struct-name orig-stx stx)
|
(define (predicate->struct-name orig-stx stx)
|
||||||
(and stx
|
(if stx
|
||||||
(let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
|
(let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
|
||||||
(cond
|
(cond
|
||||||
[m (cadr m)]
|
[m (cadr m)]
|
||||||
[else (raise-syntax-error
|
[else (raise-syntax-error
|
||||||
who
|
who
|
||||||
"unable to cope with a struct supertype whose predicate doesn't end with `?'"
|
"unable to cope with a struct supertype whose predicate doesn't end with `?'"
|
||||||
orig-stx)]))))
|
orig-stx)]))
|
||||||
|
(raise-syntax-error
|
||||||
|
who
|
||||||
|
"unable to cope with a struct whose predicate is unknown"
|
||||||
|
orig-stx)))
|
||||||
|
|
||||||
|
;; get-field-names/no-field-info :: string?
|
||||||
|
;; (listof identifier?)
|
||||||
|
;; (or/c identifier? boolean?)
|
||||||
|
;; syntax?
|
||||||
|
;; syntax?
|
||||||
|
;; ->
|
||||||
|
;; (listof symbol?)
|
||||||
|
;; attempts to extract field names from accessors
|
||||||
|
(define (get-field-names/no-field-info struct-name
|
||||||
|
accessors
|
||||||
|
super-info
|
||||||
|
orig-struct-name-stx
|
||||||
|
provide-stx)
|
||||||
|
(define own-accessors
|
||||||
|
(cond
|
||||||
|
[(boolean? super-info) accessors]
|
||||||
|
[else
|
||||||
|
(define parent-accessors
|
||||||
|
(list-ref (extract-struct-info (a:lookup-struct-info super-info provide-stx)) 3))
|
||||||
|
(drop-right accessors (length parent-accessors))]))
|
||||||
|
(for/list ([accessor (in-list own-accessors)])
|
||||||
|
(define accessor-str (symbol->string (syntax-e accessor)))
|
||||||
|
(unless (string-prefix? accessor-str (string-append struct-name "-"))
|
||||||
|
(raise-syntax-error
|
||||||
|
who
|
||||||
|
(format "unexpected accessor name ~a should start with ~a-"
|
||||||
|
accessor-str struct-name)
|
||||||
|
provide-stx
|
||||||
|
orig-struct-name-stx))
|
||||||
|
(string->symbol (substring accessor-str (add1 (string-length struct-name))))))
|
||||||
|
|
||||||
|
;; extract-field+struct-names : struct-info? syntax? syntax? -> (listof (cons/c symbol? symbol?))
|
||||||
|
;; returns a list of pair of field name and the struct name the field belongs to
|
||||||
|
(define (extract-field+struct-names the-struct-info orig-struct-name-stx provide-stx)
|
||||||
|
(define struct-info-list (extract-struct-info the-struct-info))
|
||||||
|
(define predicate (list-ref struct-info-list 2))
|
||||||
|
(define accessors (list-ref struct-info-list 3))
|
||||||
|
(define super-info (list-ref struct-info-list 5))
|
||||||
|
(define struct-name (predicate->struct-name provide-stx predicate))
|
||||||
|
(define immediate-field-names
|
||||||
|
(if (struct-field-info? the-struct-info)
|
||||||
|
(struct-field-info-list the-struct-info)
|
||||||
|
(get-field-names/no-field-info struct-name
|
||||||
|
accessors
|
||||||
|
super-info
|
||||||
|
orig-struct-name-stx
|
||||||
|
provide-stx)))
|
||||||
|
(define immediate-field+struct-names
|
||||||
|
(for/list ([fld (in-list immediate-field-names)])
|
||||||
|
(cons fld (string->symbol struct-name))))
|
||||||
|
(cond
|
||||||
|
[(boolean? super-info) immediate-field+struct-names]
|
||||||
|
[else (append immediate-field+struct-names
|
||||||
|
(extract-field+struct-names
|
||||||
|
(a:lookup-struct-info super-info provide-stx)
|
||||||
|
orig-struct-name-stx
|
||||||
|
provide-stx))]))
|
||||||
|
|
||||||
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
|
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
|
||||||
(define (build-constructor-contract stx field-contract-ids predicate-id)
|
(define (build-constructor-contract stx field-contract-ids predicate-id)
|
||||||
|
|
@ -1183,37 +1240,41 @@
|
||||||
#f))]
|
#f))]
|
||||||
[_ (values (syntax->list (syntax (p/c-ele ...))) #f)]))
|
[_ (values (syntax->list (syntax (p/c-ele ...))) #f)]))
|
||||||
(define struct-id-mapping (make-free-identifier-mapping))
|
(define struct-id-mapping (make-free-identifier-mapping))
|
||||||
(define (add-struct-clause-to-struct-id-mapping a parent flds/stx)
|
(define (add-struct-clause-to-struct-id-mapping a flds/stx)
|
||||||
(define flds (syntax->list flds/stx))
|
(define flds (syntax->list flds/stx))
|
||||||
|
(define compile-time-info (syntax-local-value a (λ () #f)))
|
||||||
(when (and (identifier? a)
|
(when (and (identifier? a)
|
||||||
(struct-info? (syntax-local-value a (λ () #f)))
|
(struct-info? compile-time-info))
|
||||||
(or (not parent)
|
(define parent
|
||||||
(and (identifier? parent)
|
(let ([parent (list-ref (extract-struct-info compile-time-info) 5)])
|
||||||
(struct-info? (syntax-local-value parent (λ () #f)))))
|
(if (boolean? parent) #f parent)))
|
||||||
flds
|
(when (and (or (not parent)
|
||||||
(andmap identifier? flds))
|
(and (identifier? parent)
|
||||||
(free-identifier-mapping-put!
|
(struct-info? (syntax-local-value parent (λ () #f)))))
|
||||||
struct-id-mapping
|
flds
|
||||||
a
|
(andmap identifier? flds))
|
||||||
(mangled-id-scope
|
(free-identifier-mapping-put!
|
||||||
(a:mangle-id "provide/contract-struct-expansion-info-id"
|
struct-id-mapping
|
||||||
a)))
|
a
|
||||||
(define parent-selectors
|
(mangled-id-scope
|
||||||
(if parent
|
(a:mangle-id "provide/contract-struct-expansion-info-id"
|
||||||
(let ([parent-selectors (list-ref (extract-struct-info (syntax-local-value parent))
|
a)))
|
||||||
3)])
|
(define parent-selectors
|
||||||
(length parent-selectors))
|
(if parent
|
||||||
0))
|
(let ([parent-selectors (list-ref (extract-struct-info (syntax-local-value parent))
|
||||||
;; this test will fail when the syntax is bad; we catch syntax errors elsewhere
|
3)])
|
||||||
(when (< parent-selectors (length flds))
|
(length parent-selectors))
|
||||||
(for ([f (in-list (list-tail flds parent-selectors))])
|
0))
|
||||||
(define selector-id (datum->syntax
|
;; this test will fail when the syntax is bad; we catch syntax errors elsewhere
|
||||||
a
|
(when (< parent-selectors (length flds))
|
||||||
(string->symbol (format "~a-~a" (syntax-e a) (syntax-e f)))))
|
(for ([f (in-list (list-tail flds parent-selectors))])
|
||||||
(free-identifier-mapping-put!
|
(define selector-id (datum->syntax
|
||||||
struct-id-mapping
|
a
|
||||||
selector-id
|
(string->symbol (format "~a-~a" (syntax-e a) (syntax-e f)))))
|
||||||
(id-for-one-id #f #f selector-id))))))
|
(free-identifier-mapping-put!
|
||||||
|
struct-id-mapping
|
||||||
|
selector-id
|
||||||
|
(id-for-one-id #f #f selector-id)))))))
|
||||||
(parameterize ([current-unprotected-submodule-name unprotected-submodule-name])
|
(parameterize ([current-unprotected-submodule-name unprotected-submodule-name])
|
||||||
(cond
|
(cond
|
||||||
[just-check-errors?
|
[just-check-errors?
|
||||||
|
|
@ -1224,9 +1285,9 @@
|
||||||
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||||
[(struct a ((fld ctc) ...) options ...)
|
[(struct a ((fld ctc) ...) options ...)
|
||||||
(identifier? #'a)
|
(identifier? #'a)
|
||||||
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
|
(add-struct-clause-to-struct-id-mapping #'a #'(fld ...))]
|
||||||
[(struct (a b) ((fld ctc) ...) options ...)
|
[(struct (a b) ((fld ctc) ...) options ...)
|
||||||
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
|
(add-struct-clause-to-struct-id-mapping #'a #'(fld ...))]
|
||||||
[_ (void)]))
|
[_ (void)]))
|
||||||
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
|
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
|
||||||
[pos-module-source-id pos-module-source-id])
|
[pos-module-source-id pos-module-source-id])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user