From b58c5881c645ae2cb248252922cb13b3e5c3c7b5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 28 Feb 2009 19:46:47 +0000 Subject: [PATCH] We can't actually change how exports are set, we can only change how they're retrieved, so having each export be a cons of an accessor/mutator pair is misleading. Remove the mutator, just have the unit set-box! the box directly, and just export the accessor. svn: r13882 --- collects/mzlib/private/unit-contract.ss | 34 ++++++++--------- collects/mzlib/private/unit-utils.ss | 4 +- collects/mzlib/unit.ss | 50 +++++++++---------------- 3 files changed, 36 insertions(+), 52 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 41eeaf7e08..1112d118b7 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -31,24 +31,22 @@ #,name) #,stx)))]) (if ctc - #`(cons - (λ () - (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)) + #`(λ () + (let* ([old-v + #,(if sig-ctc + #`(let ([old-v/c (#,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 #`(#,vref)))]) + old-v)) vref))) (for ([tagged-info (in-list import-tagged-infos)] [sig (in-list import-sigs)]) diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss index baf6a35cb1..e63bcb29ba 100644 --- a/collects/mzlib/private/unit-utils.ss +++ b/collects/mzlib/private/unit-utils.ss @@ -46,10 +46,10 @@ (λ (v stx) (if c (with-syntax ([c-stx (syntax-property c 'inferred-name v)]) - #`(let ([v/c ((car #,stx))]) + #`(let ([v/c (#,stx)]) (contract c-stx (car v/c) (cdr v/c) #,blame #,(id->contract-src-info v)))) - #`((car #,stx))))]) + #`(#,stx)))]) #`[#,i (make-set!-transformer (λ (stx) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 546e8a033e..fd12908703 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -461,12 +461,12 @@ (if ctc (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c ((car #,loc))]) + (quote-syntax (let ([v/c (#,loc)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) #,(id->contract-src-info var)))))) (quasisyntax/loc (error-syntax) - (quote-syntax ((car #,loc)))))) + (quote-syntax (#,loc))))) ;; build-unit : syntax-object -> ;; (values syntax-object (listof identifier) (listof identifier)) @@ -546,10 +546,7 @@ (list (cons 'dept depr) ...) (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) (lambda () - (let ([eloc (let ([loc (box undefined)]) - (cons - (λ () (unbox loc)) - (λ (v) (set-box! loc v))))] ... ...) + (let ([eloc (box undefined)] ... ...) (values (lambda (import-table) (let-values ([(iloc ...) @@ -576,7 +573,7 @@ (eloc ... ...) (ectc ... ...) . body))))) - (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))) + (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) import-tagged-sigids export-tagged-sigids dep-tagged-sigids)))))) @@ -723,12 +720,10 @@ (current-contract-region) 'cant-happen #,(id->contract-src-info id)) - ((cdr #,export-loc) - (let ([#,id #,tmp]) - (cons #,id (current-contract-region)))))) + (set-box! #,export-loc + (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr - ((cdr #,export-loc) - (let ([#,id #,tmp]) #,id)))) + (set-box! #,export-loc #,tmp))) (quasisyntax/loc defn-or-expr (define-syntax #,id (make-id-mapper (quote-syntax #,tmp)))))))] @@ -796,25 +791,16 @@ 'inferred-name var) ctc)]) (if (or target-ctc ctc) - #`(cons - (λ () - (let ([old-v #,(if ctc - #`(let ([old-v/c ((car #,vref))]) - (contract ctc-stx (car old-v/c) - (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) - #`((car #,vref)))]) - #,(if target-ctc - #'(cons old-v (current-contract-region)) - #'old-v))) - (λ (v) (let ([new-v #,(if ctc - #`(contract ctc-stx (car v) - (current-contract-region) (cdr v) - #,(id->contract-src-info var)) - #'v)]) - #,(if target-ctc - #`((cdr #,vref) (cons new-v (current-contract-region))) - #`((cdr #,vref) new-v))))) + #`(λ () + (let ([old-v #,(if ctc + #`(let ([old-v/c (#,vref)]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var))) + #`(#,vref))]) + #,(if target-ctc + #'(cons old-v (current-contract-region)) + #'old-v))) vref)))) (car target-sig) (cadddr target-sig))) @@ -1277,7 +1263,7 @@ (define rename-bindings (get-member-bindings def-table os #'(#%variable-reference))) (map (λ (tb i v c) - #`(let ([v/c ((car #,tb))]) + #`(let ([v/c (#,tb)]) #,(if c (with-syntax ([ctc-stx (syntax-property