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

Okay, after some deep thought, I think I finally have a mental model for

Browse Source 
exactly what unit/c is doing here that's appropriate for fixing this
section of code.  ASCII art diagrams for the win!

This also shows how a unit/c contract addition differs from the use
of unit/new-import-export to switch sigs, which means that I'll likely
not be able to unify as much of the guts of the two as I'd like.  Schade.

svn: r13605
This commit is contained in:
Stevie Strickland 2009-02-15 09:59:51 +00:00
parent 85e38ec26a
commit e453483b09
1 changed files with 71 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,11 +12,49 @@
(provide (for-syntax unit/c/core) unit/c) (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?) (define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name) (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
(define def-table (make-bound-identifier-mapping)) (define def-table (make-bound-identifier-mapping))
(define (convert-reference vref ctc sig-ctc rename-bindings) (define (convert-reference var vref ctc sig-ctc rename-bindings)
(let ([wrap-with-proj (let ([wrap-with-proj
(λ (ctc stx) (λ (ctc stx)
;; If contract coersion ends up being a large overhead, we can ;; If contract coersion ends up being a large overhead, we can
@ -31,21 +69,33 @@
#,stx)))]) #,stx)))])
(if ctc (if ctc
#`(cons #`(cons
(λ () #,(if import?
#`(car #,vref)
#`(λ ()
(let* ([old-v (let* ([old-v
#,(if sig-ctc #,(if sig-ctc
#`(let ([old-v/c ((car #,vref))]) #`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj ctc #'(car old-v/c)) (cons #,(wrap-with-proj
(cdr old-v/c))) ctc
#`(contract #,sig-ctc (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var)))
#,neg))
(wrap-with-proj ctc #`((car #,vref))))]) (wrap-with-proj ctc #`((car #,vref))))])
old-v)) old-v)))
(λ (v) #,(if import?
#`(λ (v)
(let* ([new-v (let* ([new-v
#,(if sig-ctc #,(if sig-ctc
#`(cons #,(wrap-with-proj ctc #'(car v)) #`(cons #,(wrap-with-proj
(cdr v)) ctc
#`(contract #,sig-ctc (car v)
(cdr v) #,neg
#,(id->contract-src-info var)))
#,pos)
(wrap-with-proj ctc #'v))]) (wrap-with-proj ctc #'v))])
((cdr #,vref) new-v)))) ((cdr #,vref) new-v)))
#`(cdr #,vref)))
vref))) vref)))
(for ([tagged-info (in-list import-tagged-infos)] (for ([tagged-info (in-list import-tagged-infos)]
[sig (in-list import-sigs)]) [sig (in-list import-sigs)])
@ -61,16 +111,13 @@
(get-member-bindings def-table target-sig pos)]) (get-member-bindings def-table target-sig pos)])
(for/list ([target-int/ext-name (in-list (car target-sig))] (for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))]) [sig-ctc (in-list (cadddr target-sig))])
(let* ([vref (let* ([var (car target-int/ext-name)]
(bound-identifier-mapping-get [vref
def-table (bound-identifier-mapping-get def-table var)]
(car target-int/ext-name))]
[ctc [ctc
(bound-identifier-mapping-get (bound-identifier-mapping-get
ctc-table ctc-table var (λ () #f))])
(car target-int/ext-name) (convert-reference var vref ctc sig-ctc rename-bindings))))))
(λ () #f))])
(convert-reference vref ctc sig-ctc rename-bindings))))))
(((export-keys ...) ...) (((export-keys ...) ...)
(map tagged-info->keys import-tagged-infos))) (map tagged-info->keys import-tagged-infos)))
#'(unit-export ((export-keys ...) #'(unit-export ((export-keys ...)