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

Disallow unit/new-import-export if contracts are involved. This is not

Browse Source 
planned to be permanent, but until I've figured out how to implement the
fix, just say no.

svn: r13311

original commit: 2f323578def1504977a1238d3d5c5fbfece9cd1e
This commit is contained in:
Stevie Strickland 2009-01-29 07:19:23 +00:00
parent 8f3c97eab8
commit 122b049167
1 changed files with 30 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/mzlib/unit.ss
View File

@ -762,19 +762,27 @@
(define v (define v
#`(hash-table-get #,table-stx #,(car (tagged-info->keys tagged-info)))) #`(hash-table-get #,table-stx #,(car (tagged-info->keys tagged-info))))
(for-each (for-each
(lambda (int/ext-name index) (lambda (int/ext-name index ctc)
(bound-identifier-mapping-put! def-table (bound-identifier-mapping-put! def-table
(car int/ext-name) (car int/ext-name)
#`(vector-ref #,v #,index))) (cons #`(vector-ref #,v #,index) ctc)))
(car sig) (car sig)
(iota (length (car sig))))) (iota (length (car sig)))
(cadddr sig)))
import-tagged-infos import-tagged-infos
import-sigs) import-sigs)
(with-syntax ((((eloc ...) ...) (with-syntax ((((eloc ...) ...)
(map (map
(lambda (target-sig) (lambda (target-sig)
(map (map
(lambda (target-int/ext-name) (lambda (target-int/ext-name target-ctc)
(when target-ctc
(raise-stx-err
(format (if import?
"identifier ~a is contracted in old imports"
"identifier ~a is contracted in new exports")
(syntax-e (car target-int/ext-name)))))
(let ([vref/ctc
(bound-identifier-mapping-get (bound-identifier-mapping-get
def-table def-table
(car target-int/ext-name) (car target-int/ext-name)
@ -782,9 +790,17 @@
(raise-stx-err (raise-stx-err
(format (if import? (format (if import?
"identifier ~a is not present in new imports" "identifier ~a is not present in new imports"
"identifier ~a is not present in old export") "identifier ~a is not present in old exports")
(syntax-e (car target-int/ext-name))))))) (syntax-e (car target-int/ext-name))))))])
(car target-sig))) (when (cdr vref/ctc)
(raise-stx-err
(format (if import?
"identifier ~a is contracted in new imports"
"identifier ~a is contracted in old exports")
(syntax-e (car target-int/ext-name)))))
(car vref/ctc)))
(car target-sig)
(cadddr target-sig)))
target-import-sigs)) target-import-sigs))
(((export-keys ...) ...) (((export-keys ...) ...)
(map tagged-info->keys target-import-tagged-infos))) (map tagged-info->keys target-import-tagged-infos)))