suzanne.soy/racket
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
This commit is contained in:
Stevie Strickland 2009-01-29 07:19:23 +00:00
parent b86e4473f0
commit 2f323578de
2 changed files with 75 additions and 15 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)))

44
collects/tests/units/test-unit-contracts.ss
View File

@ -195,3 +195,47 @@
(f 3)) (f 3))
(test-runtime-error exn:fail:contract? "top-level misuses f" (test-runtime-error exn:fail:contract? "top-level misuses f"
(f #t))) (f #t)))
;; eventually we can hopefully fix this so these are allowed, but for right
;; now, test that they fail during unit/new-import-export
(define-signature sig7 (x))
(define-signature sig8 ((contracted [x number?])))
(define-unit unit12
(import sig7)
(export)
x)
(define-unit unit13
(import sig8)
(export)
x)
(define-unit unit14
(import)
(export sig8)
(define x 3))
(define-unit unit15
(import)
(export sig7)
(define x 3))
(test-syntax-error "not contracted in old import -> contracted in new"
(unit/new-import-export
(import sig8)
(export)
(() unit12 sig7)))
(test-syntax-error "contracted in old import -> not contracted in new"
(unit/new-import-export
(import sig7)
(export)
(() unit13 sig8)))
(test-syntax-error "not contracted in old export -> contracted in new"
(unit/new-import-export
(import)
(export sig8)
((sig7) unit14)))
(test-syntax-error "contracted in old export -> not contracted in new"
(unit/new-import-export
(import)
(export sig7)
((sig8) unit15)))