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

Fix handling of imports in unit contracts.

Browse Source 
svn: r13864
This commit is contained in:
Stevie Strickland 2009-02-27 01:02:27 +00:00
parent 502427ee44
commit c221f41695
1 changed files with 17 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
collects/mzlib/private/unit-contract.ss
View File

@ -13,44 +13,6 @@
(provide (for-syntax unit/c/core) unit/c)
#|
We want to think of the contract as sitting between the outside world
and the unit in question. In the case where the signature in question
is contracted, we have:
pos unit/c neg
|
--- |
| | |
<---- | i | <-----|------ (v, o)
| | |
--- |
| | |
(v, u) ----> | e | ------|----->
| | |
--- |
|
So for an import, we start out with (v, o) coming in when the
import is being set. We need to first check the contract
(sig-ctc, o, neg), to make sure what's coming in appropriately
satisfies that contract (since it already has given us the
positive blame for the value incoming). Then we need to check
(ctc, neg, pos) (i.e. apply the projection with the blame
"switched"). That leaves pos as the appropriate thing to pack
with the value for the sig-ctc check inside the unit. When
the unit pulls it out (which isn't affected by the unit/c
contract combinator), it'll have the correct party to blame as
far as it knows.
For an export, we start on the other side, so we don't need to do
anything to the setting function as the unit will handle that. So for
the accessing function, we need to grab what's in the box,
check (sig-ctc, u, pos), then check (ctc, pos, neg) via projection
application, then last, but not least, return the resulting value
packed with the neg blame.
|#
(define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
(define def-table (make-bound-identifier-mapping))
@ -70,41 +32,23 @@ packed with the neg blame.
#,stx)))])
(if ctc
#`(cons
#,(if import?
#`(car #,vref)
#`(λ ()
(let* ([old-v
#,(if sig-ctc
#`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var))))
#,neg))
(wrap-with-proj ctc #`((car #,vref))))])
old-v)))
#,(if import?
#`(λ (v)
(let* ([new-v
#,(if sig-ctc
#`(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car v)
(cdr v) #,neg
#,(id->contract-src-info var))))
#,pos)
(wrap-with-proj ctc #'v))])
((cdr #,vref) new-v)))
#`(cdr #,vref)))
(λ ()
(let* ([old-v
#,(if sig-ctc
#`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj
ctc
(with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var))))
#,neg))
(wrap-with-proj ctc #`((car #,vref))))])
old-v))
(cdr #,vref))
vref)))
(for ([tagged-info (in-list import-tagged-infos)]
[sig (in-list import-sigs)])