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

Cleanups.

Browse Source 
svn: r13884
This commit is contained in:
Stevie Strickland 2009-02-28 20:34:06 +00:00
parent 754bd0a84d
commit 837906b783
2 changed files with 27 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -32,42 +32,35 @@
#,stx)))]) #,stx)))])
(if ctc (if ctc
#`(λ () #`(λ ()
(let* ([old-v
#,(if sig-ctc #,(if sig-ctc
#`(let ([old-v/c (#,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) #`(let ([old-v/c (#,vref)])
(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 #`(#,vref))))
old-v))
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)])
(let ([v #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))]) (let ([v #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info)))])
(for ([int/ext-name (in-list (car sig))] (for ([int/ext-name (in-list (car sig))]
[index (in-list (build-list (length (car sig)) values))]) [index (in-list (build-list (length (car sig)) values))])
(bound-identifier-mapping-put! def-table (bound-identifier-mapping-put! def-table (car int/ext-name)
(car int/ext-name)
#`(vector-ref #,v #,index))))) #`(vector-ref #,v #,index)))))
(with-syntax ((((eloc ...) ...) (with-syntax ((((eloc ...) ...)
(for/list ([target-sig import-sigs]) (for/list ([target-sig import-sigs])
(let ([rename-bindings (let ([rename-bindings (get-member-bindings def-table target-sig pos)])
(get-member-bindings def-table target-sig pos)])
(for/list ([target-int/ext-name (in-list (car target-sig))] (for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))]) [sig-ctc (in-list (cadddr target-sig))])
(let* ([var (car target-int/ext-name)] (let* ([var (car target-int/ext-name)]
[vref [vref (bound-identifier-mapping-get def-table var)]
(bound-identifier-mapping-get def-table var)] [ctc (bound-identifier-mapping-get ctc-table var (λ () #f))])
[ctc
(bound-identifier-mapping-get
ctc-table var (λ () #f))])
(convert-reference var vref ctc sig-ctc rename-bindings)))))) (convert-reference var vref ctc sig-ctc rename-bindings))))))
(((export-keys ...) ...) (((export-keys ...) ...)
(map tagged-info->keys import-tagged-infos))) (map tagged-info->keys import-tagged-infos)))

10
collects/mzlib/unit.ss
View File

@ -1263,16 +1263,16 @@
(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 (#,tb)]) (if c
#,(if c
(with-syntax ([ctc-stx (with-syntax ([ctc-stx
(syntax-property (syntax-property
#`(letrec-syntax #,rename-bindings #,c) #`(letrec-syntax #,rename-bindings #,c)
'inferred-name v)]) 'inferred-name v)])
#`(contract ctc-stx (car v/c) (cdr v/c) #`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v))) #,(id->contract-src-info v))))
#'v/c))) #`(#,tb)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))