suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix struct-info related bug in provide/contract

Browse Source 
that John Clements pointed out on the Racket
mailing list
This commit is contained in:
Robby Findler 2012-02-24 13:10:12 -06:00
parent ca9e8d742f
commit 4eba0862cf
2 changed files with 58 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/racket/contract/private/provide.rkt
View File

@ -321,19 +321,20 @@
#f #f
(car (car pp)))))] (car (car pp)))))]
[struct-info (a:lookup-struct-info struct-name-position provide-stx)] [the-struct-info (a:lookup-struct-info struct-name-position provide-stx)]
[constructor-id (list-ref struct-info 1)] [constructor-id (list-ref the-struct-info 1)]
[predicate-id (list-ref struct-info 2)] [predicate-id (list-ref the-struct-info 2)]
[selector-ids (reverse (list-ref struct-info 3))] [selector-ids (reverse (list-ref the-struct-info 3))]
[type-is-only-constructor? (free-identifier=? constructor-id struct-name)] [type-is-only-constructor? (free-identifier=? constructor-id struct-name)]
[type-is-constructor? #t] ; I think there's no way to detect when the struct-name binding isn't a constructor [type-is-constructor? #t] ; I think there's no way to detect when the struct-name binding isn't a constructor
[chaperone-constructor-id (and constructor-id (car (generate-temporaries (list constructor-id))))]
[is-id-ok? [is-id-ok?
(λ (id i) (λ (id i)
(if (or (not parent-struct-count) (if (or (not parent-struct-count)
(parent-struct-count . <= . i)) (parent-struct-count . <= . i))
id id
#t))] #t))]
[mutator-ids (reverse (list-ref struct-info 4))] ;; (listof (union #f identifier)) [mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier))
[field-contract-ids (map (λ (field-name field-contract) [field-contract-ids (map (λ (field-name field-contract)
(if (a:known-good-contract? field-contract) (if (a:known-good-contract? field-contract)
field-contract field-contract
@ -483,11 +484,11 @@
[(constructor-code constructor-new-name) [(constructor-code constructor-new-name)
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
constructor-id struct-name chaperone-constructor-id struct-name
(build-constructor-contract stx (build-constructor-contract stx
field-contract-ids field-contract-ids
predicate-id) predicate-id)
#f constructor-id
#t #t
(not type-is-only-constructor?))] (not type-is-only-constructor?))]
@ -550,14 +551,20 @@
[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]
[(selector-ids ...) selector-ids]) [(selector-ids ...) selector-ids]
(syntax/loc stx [(constructor-args ...) (generate-temporaries selector-ids)])
(quasisyntax/loc stx
(begin (begin
struct-code struct-code
field-contract-id-definitions ... field-contract-id-definitions ...
selector-codes ... selector-codes ...
mutator-codes ... mutator-codes ...
predicate-code predicate-code
(define (#,chaperone-constructor-id constructor-args ...)
(chaperone-struct (#,constructor-id constructor-args ...)
struct-info
(λ (struct-type skipped?)
(values -struct:struct-name skipped?))))
constructor-code constructor-code
;; expanding out the body of the `make-pc-struct-type' function ;; expanding out the body of the `make-pc-struct-type' function
@ -695,8 +702,7 @@
[ex-id ex-id] [ex-id ex-id]
[ctrct (syntax-property ctrct 'inferred-name ex-id)] [ctrct (syntax-property ctrct 'inferred-name ex-id)]
[external-name (or user-rename-id id)] [external-name (or user-rename-id id)]
[reflect-external-name (or user-rename-id ex-id)] [reflect-external-name (or user-rename-id ex-id)])
[where-stx stx])
(with-syntax ([extra-test (with-syntax ([extra-test
(syntax-case #'ctrct (->) (syntax-case #'ctrct (->)
[(-> dom ... arg) [(-> dom ... arg)
@ -807,6 +813,28 @@
stx)])) stx)]))
(define (make-pc-struct-type struct-name struct:struct-name . ctcs) (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(chaperone-struct-type
struct:struct-name
(λ (a b c d e f g h) (values a b c d e f g h))
(λ (x) x)
(λ args
(let ([vals (let loop ([args args])
(cond
[(null? args) null]
[(null? (cdr args)) null]
[else (cons (car args) (loop (cdr args)))]))])
(apply values
(map (λ (ctc val)
(contract ctc
val
'not-enough-info-for-blame
'not-enough-info-for-blame
'#f
(build-source-location #f)))
ctcs
vals)))))
#;
(let-values ([(struct:struct-name _make _pred _get _set) (let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type struct-name (make-struct-type struct-name
struct:struct-name struct:struct-name
@ -833,4 +861,4 @@
(build-source-location #f))) (build-source-location #f)))
ctcs ctcs
vals)))))]) vals)))))])
struct:struct-name)) (values struct:struct-name _make)))

18
collects/tests/racket/contract-test.rktl
View File

@ -11712,6 +11712,24 @@ so that propagation occurs.
(eval '(require 'provide/contract37-n))) (eval '(require 'provide/contract37-n)))
"provide/contract37-n") "provide/contract37-n")
(test/spec-passed/result
'provide/contract38
'(begin
(eval
'(module provide/contract38-a racket
(define-struct s () #:transparent)
(provide/contract [struct s ()])))
(eval
'(module provide/contract38-b racket
(require 'provide/contract38-a)
(define a-struct (make-s))
(define-values (type _) (struct-info a-struct))
(provide the-answer)
(define the-answer (eq? type struct:s))))
(dynamic-require ''provide/contract38-b 'the-answer))
#t)
(contract-error-test (contract-error-test
'contract-error-test8 'contract-error-test8