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

Re-do projections for struct fields in chaperone handlers.

Browse Source 
If the selector is itself a chaperone, then doing the access once
will mean that the saved result is not `chaperone-of?` the result
of doing the access a second time, at least in some cases (such as
when the accessor uses vector contracts).

Thanks to Neil T for initial spotting, and to Robby for actually
finding the bug and suggesting the fix.
This commit is contained in:
Sam Tobin-Hochstadt 2015-02-11 19:02:43 -05:00
parent 0e563c6ab3
commit d3b018b7cb
2 changed files with 46 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
pkgs/racket-test/tests/racket/contract/struct-dc.rkt
View File

@ -178,6 +178,38 @@
(and (exn:fail:contract:blame? x) (and (exn:fail:contract:blame? x)
(regexp-match #rx"promised: foo?" (exn-message x))))) (regexp-match #rx"promised: foo?" (exn-message x)))))
(test/spec-passed/result
'struct/c-contract-accessor
'(begin
(require (for-syntax racket/base))
(let ()
(struct d (vec))
(define dx-vec (contract (-> (struct/c d (vectorof any/c)) any) d-vec 'pos 'neg))
(define-syntax dx (list #'struct:d #'d #'d? (list #'dx-vec) (list #f) #f))
(struct gds dx ())
(define gd (contract (struct/c gds (vectorof any/c)) (gds (vector 1)) 'pos 'neg))
(vector-ref (d-vec gd) 0)))
1)
(test/spec-passed
'struct/c-simple-contract-accessor
'(let ()
(struct x (v))
(define val1 (x (λ (e) e)))
(define val2
(chaperone-struct
val1 x-v (λ (f v) (chaperone-procedure v (λ (a) a)))))
(x-v (contract (struct/c x (any/c . -> . any/c)) val1 'y 'n))
(x-v (contract (struct/c x (any/c . -> . any/c)) val2 'y 'n))
(x-v (contract (struct/dc x [v (any/c . -> . any/c)]) val1 'y 'n))
(x-v (contract (struct/dc x [v (any/c . -> . any/c)]) val2 'y 'n))
(x-v (contract (struct/dc x [v () (any/c . -> . any/c)]) val1 'y 'n))
(x-v (contract (struct/dc x [v () (any/c . -> . any/c)]) val2 'y 'n))))
; ;
; ;

32
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -349,15 +349,13 @@
(reverse (invariant-fields subcontract)))) (reverse (invariant-fields subcontract))))
(values chaperone-args impersonate-args)] (values chaperone-args impersonate-args)]
[(immutable? subcontract) [(immutable? subcontract)
(define projd (define (chk fld v) (with-continuation-mark
(with-continuation-mark
contract-continuation-mark-key blame contract-continuation-mark-key blame
(proj (sel v)))) (proj v)))
(chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? (indep-ctc subcontract)) (values (if (flat-contract? (indep-ctc subcontract))
chaperone-args chaperone-args
(list* sel (list* sel chk chaperone-args))
(λ (fld v) projd)
chaperone-args))
impersonate-args)] impersonate-args)]
[(lazy-immutable? subcontract) [(lazy-immutable? subcontract)
(values (list* sel (values (list* sel
@ -397,15 +395,13 @@
(define proj (dep-ctc-blame-proj blame)) (define proj (dep-ctc-blame-proj blame))
(cond (cond
[(dep-immutable? subcontract) [(dep-immutable? subcontract)
(define projd (proj (sel v))) (define (chk fld v) (with-continuation-mark
contract-continuation-mark-key blame
(proj v)))
(chk #f (sel v)) ;; check the field contract immediately
(values (if (flat-contract? dep-ctc) (values (if (flat-contract? dep-ctc)
chaperone-args chaperone-args
(list* sel (list* sel chk chaperone-args))
(λ (fld v)
(with-continuation-mark
contract-continuation-mark-key blame
projd))
chaperone-args))
impersonate-args)] impersonate-args)]
[(dep-lazy-immutable? subcontract) [(dep-lazy-immutable? subcontract)
(values (list* sel (values (list* sel
@ -1350,12 +1346,10 @@
(cache-λ (strct #,sub-val) (cache-λ (strct #,sub-val)
#,this-body-code)]) #,this-body-code)])
proc-name) proc-name)
#`(let ([answer (let ([#,sub-val #`(let ([proc-name (λ (strct #,sub-val) #,this-body-code)])
(#,sel-id ;; check the field contract immediately
#,(opt/info-val opt/info))]) (proc-name #f (#,sel-id #,(opt/info-val opt/info)))
#,this-body-code)]) proc-name)))))
(let ([proc-name (λ (strct fld) answer)])
proc-name))))))
(define this-fo-code (define this-fo-code
(and (and (optres-flat this-optres) (and (and (optres-flat this-optres)