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)
#,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)])

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

@ -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)

50
collects/mzlib/unit.ss
View File

@ -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