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

Only apply a single contract wrapping to a value contracted through unit

Browse Source 
exporting/importing.  Also add some more unit contract tests.

svn: r13203
This commit is contained in:
Stevie Strickland 2009-01-18 10:38:52 +00:00
parent 5f08629bcd
commit e1d5ced45e
3 changed files with 58 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mzlib/private/unit-compiletime.ss
View File

@ -45,8 +45,8 @@
(cons (reverse requires) l))))))) (cons (reverse requires) l)))))))
;; (make-var-info bool bool identifier (or #f (syntax-object -> syntax-object))) ;; (make-var-info bool bool identifier (U #f syntax-object))
(define-struct var-info (syntax? [exported? #:mutable] id [add-ctc #:mutable])) (define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
(define-syntax define-struct/proc (define-syntax define-struct/proc
(syntax-rules () (syntax-rules ()

35
collects/mzlib/unit.ss
View File

@ -472,9 +472,10 @@
(define-for-syntax (make-import-unboxing var loc ctc) (define-for-syntax (make-import-unboxing var loc ctc)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen (quote-syntax (let ([v/c (unbox #,loc)])
(contract #,ctc (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var)))) #,(id->contract-src-info var)))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc))))) (quote-syntax (unbox #,loc)))))
@ -688,11 +689,7 @@
(raise-stx-err "cannot export syntax from a unit" name)) (raise-stx-err "cannot export syntax from a unit" name))
(set-var-info-exported?! v loc) (set-var-info-exported?! v loc)
(when (pair? (syntax-e ctc)) (when (pair? (syntax-e ctc))
(set-var-info-add-ctc! (set-var-info-ctc! v (cdr (syntax-e ctc))))))
v
(λ (e)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-contract-region)
'cant-happen #,(id->contract-src-info e)))))))
(syntax->list (localify #'evars def-ctx)) (syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs) (syntax->list #'elocs)
(syntax->list #'ectcs)) (syntax->list #'ectcs))
@ -726,11 +723,20 @@
[(var-info-exported? var-info) [(var-info-exported? var-info)
=> =>
(λ (export-loc) (λ (export-loc)
(let ([add-ctc (var-info-add-ctc var-info)]) (let ([ctc (var-info-ctc var-info)])
(list (quasisyntax/loc defn-or-expr (list (if ctc
(quasisyntax/loc defn-or-expr
(begin
(contract #,ctc #,tmp
(current-contract-region)
'cant-happen
#,(id->contract-src-info id))
(set-box! #,export-loc (set-box! #,export-loc
(let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) (let ([#,id #,tmp])
#,id))) (cons #,id (current-contract-region))))))
(quasisyntax/loc defn-or-expr
(set-box! #,export-loc
(let ([#,id #,tmp]) #,id))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(define-syntax #,id (define-syntax #,id
(make-id-mapper (quote-syntax #,tmp)))))))] (make-id-mapper (quote-syntax #,tmp)))))))]
@ -1216,9 +1222,10 @@
(map (map
(lambda (i v c) (lambda (i v c)
(if c (if c
#`(contract #,c (unbox (vector-ref #,ov #,i)) #`(let ([v/c (unbox (vector-ref #,ov #,i))])
'cant-happen (current-contract-region) (contract #,c (car v/c) (cdr v/c)
#,(id->contract-src-info v)) (current-contract-region)
#,(id->contract-src-info v)))
#`(unbox (vector-ref #,ov #,i)))) #`(unbox (vector-ref #,ov #,i))))
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))

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

@ -162,3 +162,36 @@
(test-runtime-error exn:fail:contract? "top-level misuses f" (test-runtime-error exn:fail:contract? "top-level misuses f"
(f #t)) (f #t))
(define-unit unit10
(import sig1 sig2) (export)
(if (zero? x)
(f 3)
(f #t)))
(let ()
(define x 0)
(define f (lambda (x) #t))
(test-runtime-error exn:fail:contract? "top-level (via anonymous unit) provides improper f"
(invoke-unit unit10 (import sig1 sig2))))
(let ()
(define x 1)
(define f values)
(test-runtime-error exn:fail:contract? "unit10 misuses f from top-level"
(invoke-unit unit10 (import sig1 sig2))))
;; testing that contracts from extended signatures are checked properly
(define-unit unit11
(import) (export sig3)
(define (f n) #t)
(define (g n) 3))
(let ()
(define-values/invoke-unit unit11
(import)
(export sig3))
(test-runtime-error exn:fail:contract? "unit11 provides improper f"
(f 3))
(test-runtime-error exn:fail:contract? "top-level misuses f"
(f #t)))