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

We can't actually change how exports are set, we can only change how they're

Browse Source 
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
This commit is contained in:
Stevie Strickland 2009-02-28 19:46:47 +00:00
parent d5ee6c6813
commit b58c5881c6
3 changed files with 36 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -31,24 +31,22 @@
#,name) #,name)
#,stx)))]) #,stx)))])
(if ctc (if ctc
#`(cons #`(λ ()
(λ () (let* ([old-v
(let* ([old-v #,(if sig-ctc
#,(if sig-ctc #`(let ([old-v/c (#,vref)])
#`(let ([old-v/c ((car #,vref))]) (cons #,(wrap-with-proj
(cons #,(wrap-with-proj ctc
ctc (with-syntax ([sig-ctc-stx
(with-syntax ([sig-ctc-stx (syntax-property sig-ctc
(syntax-property sig-ctc 'inferred-name
'inferred-name var)])
var)]) #`(contract sig-ctc-stx (car old-v/c)
#`(contract sig-ctc-stx (car old-v/c) (cdr old-v/c) #,pos
(cdr old-v/c) #,pos #,(id->contract-src-info var))))
#,(id->contract-src-info var)))) #,neg))
#,neg)) (wrap-with-proj ctc #`(#,vref)))])
(wrap-with-proj ctc #`((car #,vref))))]) old-v))
old-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)])

4
collects/mzlib/private/unit-utils.ss
View File

@ -46,10 +46,10 @@
(λ (v stx) (λ (v stx)
(if c (if c
(with-syntax ([c-stx (syntax-property c 'inferred-name v)]) (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 (contract c-stx (car v/c) (cdr v/c) #,blame
#,(id->contract-src-info v)))) #,(id->contract-src-info v))))
#`((car #,stx))))]) #`(#,stx)))])
#`[#,i #`[#,i
(make-set!-transformer (make-set!-transformer
(λ (stx) (λ (stx)

50
collects/mzlib/unit.ss
View File

@ -461,12 +461,12 @@
(if ctc (if ctc
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax) (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) (contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var)))))) #,(id->contract-src-info var))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax ((car #,loc)))))) (quote-syntax (#,loc)))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
@ -546,10 +546,7 @@
(list (cons 'dept depr) ...) (list (cons 'dept depr) ...)
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda () (lambda ()
(let ([eloc (let ([loc (box undefined)]) (let ([eloc (box undefined)] ... ...)
(cons
(λ () (unbox loc))
(λ (v) (set-box! loc v))))] ... ...)
(values (values
(lambda (import-table) (lambda (import-table)
(let-values ([(iloc ...) (let-values ([(iloc ...)
@ -576,7 +573,7 @@
(eloc ... ...) (eloc ... ...)
(ectc ... ...) (ectc ... ...)
. body))))) . body)))))
(unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))) (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...)))))))
import-tagged-sigids import-tagged-sigids
export-tagged-sigids export-tagged-sigids
dep-tagged-sigids)))))) dep-tagged-sigids))))))
@ -723,12 +720,10 @@
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
#,(id->contract-src-info id)) #,(id->contract-src-info id))
((cdr #,export-loc) (set-box! #,export-loc
(let ([#,id #,tmp]) (cons #,tmp (current-contract-region)))))
(cons #,id (current-contract-region))))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
((cdr #,export-loc) (set-box! #,export-loc #,tmp)))
(let ([#,id #,tmp]) #,id))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(define-syntax #,id (define-syntax #,id
(make-id-mapper (quote-syntax #,tmp)))))))] (make-id-mapper (quote-syntax #,tmp)))))))]
@ -796,25 +791,16 @@
'inferred-name var) 'inferred-name var)
ctc)]) ctc)])
(if (or target-ctc ctc) (if (or target-ctc ctc)
#`(cons #`(λ ()
(λ () (let ([old-v #,(if ctc
(let ([old-v #,(if ctc #`(let ([old-v/c (#,vref)])
#`(let ([old-v/c ((car #,vref))]) (contract ctc-stx (car old-v/c)
(contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region)
(cdr old-v/c) (current-contract-region) #,(id->contract-src-info var)))
#,(id->contract-src-info var))) #`(#,vref))])
#`((car #,vref)))]) #,(if target-ctc
#,(if target-ctc #'(cons old-v (current-contract-region))
#'(cons old-v (current-contract-region)) #'old-v)))
#'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)))))
vref)))) vref))))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
@ -1277,7 +1263,7 @@
(define rename-bindings (define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference))) (get-member-bindings def-table os #'(#%variable-reference)))
(map (λ (tb i v c) (map (λ (tb i v c)
#`(let ([v/c ((car #,tb))]) #`(let ([v/c (#,tb)])
#,(if c #,(if c
(with-syntax ([ctc-stx (with-syntax ([ctc-stx
(syntax-property (syntax-property