suzanne.soy/compatibility
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

original commit: b58c5881c645ae2cb248252922cb13b3e5c3c7b5
This commit is contained in:
Stevie Strickland 2009-02-28 19:46:47 +00:00
parent 74dad6d8d4
commit 87b0915ce1
1 changed files with 18 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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