From c221f41695dc302e5047a0f869c5184485e23c81 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 27 Feb 2009 01:02:27 +0000 Subject: [PATCH] Fix handling of imports in unit contracts. svn: r13864 --- collects/mzlib/private/unit-contract.ss | 90 +++++-------------------- 1 file changed, 17 insertions(+), 73 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 7289ad41fe..41eeaf7e08 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -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)])