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

44
collects/mzlib/unit.ss
View File

@ -762,29 +762,45 @@
(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)
(bound-identifier-mapping-get (when target-ctc
def-table (raise-stx-err
(car target-int/ext-name) (format (if import?
(lambda () "identifier ~a is contracted in old imports"
(raise-stx-err "identifier ~a is contracted in new exports")
(format (if import? (syntax-e (car target-int/ext-name)))))
"identifier ~a is not present in new imports" (let ([vref/ctc
"identifier ~a is not present in old export") (bound-identifier-mapping-get
(syntax-e (car target-int/ext-name))))))) def-table
(car target-sig))) (car target-int/ext-name)
(lambda ()
(raise-stx-err
(format (if import?
"identifier ~a is not present in new imports"
"identifier ~a is not present in old exports")
(syntax-e (car target-int/ext-name))))))])
(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)))