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

Make a table of the original imports these came from for easy lookup. This

Browse Source 
way we can actually bind only the identifiers which were in the original
signature over the contract.

svn: r13567
This commit is contained in:
Stevie Strickland 2009-02-14 02:33:15 +00:00
parent 50af2b09f7
commit dba74f8f15
1 changed files with 9 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/mzlib/unit.ss
View File

@ -661,11 +661,7 @@
target-import-sigs) target-import-sigs)
(define def-table (make-bound-identifier-mapping)) (define def-table (make-bound-identifier-mapping))
(define ctc-table (make-bound-identifier-mapping)) (define ctc-table (make-bound-identifier-mapping))
(define sig-of-all-import-sigs (define sig-table (make-bound-identifier-mapping))
(list (apply append (map car import-sigs))
(apply append (map cadr import-sigs))
(apply append (map caddr import-sigs))
(apply append (map cadddr import-sigs))))
(for-each (for-each
(lambda (tagged-info sig) (lambda (tagged-info sig)
(define v (define v
@ -677,7 +673,10 @@
#`(vector-ref #,v #,index)) #`(vector-ref #,v #,index))
(bound-identifier-mapping-put! ctc-table (bound-identifier-mapping-put! ctc-table
(car int/ext-name) (car int/ext-name)
ctc)) ctc)
(bound-identifier-mapping-put! sig-table
(car int/ext-name)
sig))
(car sig) (car sig)
(iota (length (car sig))) (iota (length (car sig)))
(cadddr sig))) (cadddr sig)))
@ -686,10 +685,6 @@
(with-syntax ((((eloc ...) ...) (with-syntax ((((eloc ...) ...)
(map (map
(lambda (target-sig) (lambda (target-sig)
(define rename-bindings
(get-member-bindings def-table
sig-of-all-import-sigs
#'(current-contract-region)))
(map (map
(lambda (target-int/ext-name target-ctc) (lambda (target-int/ext-name target-ctc)
(let* ([var (car target-int/ext-name)] (let* ([var (car target-int/ext-name)]
@ -703,7 +698,10 @@
"identifier ~a is not present in new imports" "identifier ~a is not present in new imports"
"identifier ~a is not present in old exports") "identifier ~a is not present in old exports")
(syntax-e (car target-int/ext-name))))))] (syntax-e (car target-int/ext-name))))))]
[ctc (bound-identifier-mapping-get ctc-table var)]) [ctc (bound-identifier-mapping-get ctc-table var)]
[rename-bindings (get-member-bindings def-table
(bound-identifier-mapping-get sig-table var)
#'(current-contract-region))])
(if (or target-ctc ctc) (if (or target-ctc ctc)
#`(cons #`(cons
(λ () (λ ()