7d22b05e7c
if the blame or objects involved change, we'll get an error instead of having to manually detect it. svn: r13886
864 lines
22 KiB
Scheme
864 lines
22 KiB
Scheme
(require "test-harness.ss"
|
|
scheme/unit
|
|
scheme/contract)
|
|
|
|
(define temp-unit-blame #rx"(unit temp[0-9]*)")
|
|
(define top-level "top-level")
|
|
|
|
(define (get-blame msg)
|
|
(cond
|
|
[(regexp-match #rx"(^| )(.*) broke" msg)
|
|
=>
|
|
(λ (x) (caddr x))]
|
|
[else (error 'test-contract-error
|
|
(format "no blame in error message: \"~a\"" msg))]))
|
|
|
|
(define (get-obj msg)
|
|
(cond
|
|
[(regexp-match #rx"(^| )on (.*);" msg)
|
|
=>
|
|
(λ (x) (caddr x))]
|
|
[else (error 'test-contract-error
|
|
(format "no object in error message: \"~a\"" msg))]))
|
|
|
|
(define (get-ctc-err msg)
|
|
(cond
|
|
[(regexp-match #rx";[ ]*(.*)" msg)
|
|
=>
|
|
(λ (x) (cadr x))]
|
|
[else (error 'test-contract-error
|
|
(format "no specific error in message: \"~a\"" msg))]))
|
|
|
|
(define-syntax test-contract-error
|
|
(syntax-rules ()
|
|
((_ blame obj err expr)
|
|
(with-handlers ((exn:fail:contract?
|
|
(lambda (exn)
|
|
(let ([exn-blame (get-blame (exn-message exn))]
|
|
[exn-obj (get-obj (exn-message exn))])
|
|
(cond
|
|
[(and (string? blame)
|
|
(not (equal? blame exn-blame)))
|
|
(error 'test-contract-error "expected blame ~a, got ~a"
|
|
blame exn-blame)]
|
|
[(and (regexp? blame)
|
|
(not (regexp-match blame exn-blame)))
|
|
(error 'test-contract-error "expected blame ~a, got ~a"
|
|
blame exn-blame)]
|
|
[(not (equal? obj exn-obj))
|
|
(error 'test-contract-error "expected object ~a, got ~a"
|
|
obj exn-obj)]
|
|
[else
|
|
(printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n"
|
|
err obj exn-blame (get-ctc-err (exn-message exn)))])))))
|
|
expr
|
|
(error 'test-contract-error
|
|
"expected contract error \"~a\" on ~a, got none"
|
|
err 'expr)))))
|
|
|
|
(define-signature sig1
|
|
((contracted [x number?])))
|
|
(define-signature sig2
|
|
((contracted [f (-> number? number?)])))
|
|
(define-signature sig3 extends sig2
|
|
((contracted [g (-> number? boolean?)])))
|
|
(define-signature sig4
|
|
((contracted [a number?] [b (-> boolean? number?)])))
|
|
(define-signature sig5
|
|
((contracted [c string?])
|
|
(contracted [d symbol?])))
|
|
|
|
(define-unit unit1
|
|
(import)
|
|
(export sig1)
|
|
(define x #f))
|
|
|
|
(define-unit unit2
|
|
(import sig1)
|
|
(export sig2)
|
|
(define (f n) x))
|
|
|
|
(define-unit unit3
|
|
(import sig3 sig4)
|
|
(export)
|
|
|
|
(b (g a)))
|
|
|
|
(define-unit unit4
|
|
(import sig3 sig4)
|
|
(export)
|
|
|
|
(g (b a)))
|
|
|
|
(define-unit unit5
|
|
(import)
|
|
(export sig5)
|
|
|
|
(define-values (c d) (values "foo" 3)))
|
|
|
|
(test-syntax-error "misuse of contracted"
|
|
contracted)
|
|
(test-syntax-error "invalid forms after contracted in signature"
|
|
(define-signature x ((contracted x y))))
|
|
(test-syntax-error "identifier not first part of pair after contracted in signature"
|
|
(define-signature x ((contracted [(-> number? number?) x]))))
|
|
|
|
(test-syntax-error "f not defined in unit exporting sig3"
|
|
(unit (import) (export sig3 sig4)
|
|
(define a #t)
|
|
(define g zero?)
|
|
(define (b t) (if t 3 0))))
|
|
|
|
(test-contract-error "(unit unit1)" "x" "not a number"
|
|
(invoke-unit unit1))
|
|
|
|
(test-contract-error "(unit unit1)" "x" "not a number"
|
|
(invoke-unit (compound-unit (import) (export)
|
|
(link (((S1 : sig1)) unit1)
|
|
(() unit2 S1)))))
|
|
(test-contract-error temp-unit-blame "a" "not a number"
|
|
(invoke-unit (compound-unit (import) (export)
|
|
(link (((S3 : sig3) (S4 : sig4))
|
|
(unit (import) (export sig3 sig4)
|
|
(define a #t)
|
|
(define f add1)
|
|
(define g zero?)
|
|
(define (b t) (if t 3 0))))
|
|
(() unit3 S3 S4)))))
|
|
|
|
(test-contract-error temp-unit-blame "g" "not a boolean"
|
|
(invoke-unit (compound-unit (import) (export)
|
|
(link (((S3 : sig3) (S4 : sig4))
|
|
(unit (import) (export sig3 sig4)
|
|
(define a 3)
|
|
(define f add1)
|
|
(define g values)
|
|
(define (b t) (if t 3 0))))
|
|
(() unit3 S3 S4)))))
|
|
|
|
(test-contract-error "(unit unit4)" "b" "not a boolean"
|
|
(invoke-unit (compound-unit (import) (export)
|
|
(link (((S3 : sig3) (S4 : sig4))
|
|
(unit (import) (export sig3 sig4)
|
|
(define a 3)
|
|
(define f add1)
|
|
(define g zero?)
|
|
(define (b t) (if t 3 0))))
|
|
(() unit4 S3 S4)))))
|
|
|
|
(test-contract-error "(unit unit5)" "d" "not a symbol"
|
|
(invoke-unit unit5))
|
|
|
|
(define-unit unit6
|
|
(import)
|
|
(export sig1)
|
|
(define-unit unit6-1
|
|
(import)
|
|
(export sig1)
|
|
(define x 3))
|
|
(define-values/invoke-unit unit6-1
|
|
(import)
|
|
(export sig1)))
|
|
|
|
(invoke-unit unit6)
|
|
|
|
(define-signature sig6
|
|
((contracted [x boolean?])))
|
|
|
|
(define-unit unit7
|
|
(import)
|
|
(export sig6)
|
|
(define-unit unit7-1
|
|
(import)
|
|
(export sig1)
|
|
(define x 3))
|
|
(define-values/invoke-unit unit7-1
|
|
(import)
|
|
(export sig1)))
|
|
|
|
(test-contract-error "(unit unit7)" "x" "not a boolean"
|
|
(invoke-unit unit7))
|
|
|
|
(define-unit unit8
|
|
(import)
|
|
(export)
|
|
(define-unit unit8-1
|
|
(import)
|
|
(export sig2)
|
|
(define f values))
|
|
(define-values/invoke-unit unit8-1
|
|
(import)
|
|
(export sig2))
|
|
(f #t))
|
|
|
|
(test-contract-error "(unit unit8)" "f" "not a number"
|
|
(invoke-unit unit8))
|
|
|
|
(define-unit unit9
|
|
(import)
|
|
(export)
|
|
(define-unit unit9-1
|
|
(import)
|
|
(export sig2)
|
|
(define f zero?))
|
|
(define-values/invoke-unit unit9-1
|
|
(import)
|
|
(export sig2))
|
|
(f 3))
|
|
|
|
(test-contract-error "(unit unit9-1)" "f" "not a number"
|
|
(invoke-unit unit9))
|
|
|
|
(define-values/invoke-unit
|
|
(unit
|
|
(import) (export sig2)
|
|
(define f values))
|
|
(import)
|
|
(export sig2))
|
|
|
|
(test-contract-error top-level "f" "not a number"
|
|
(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-contract-error "(unit u)" "f" "not a number"
|
|
(invoke-unit unit10 (import sig1 sig2))))
|
|
|
|
(let ()
|
|
(define x 1)
|
|
(define f values)
|
|
(test-contract-error "(unit unit10)" "f" "not a number"
|
|
(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-contract-error "(unit unit11)" "f" "not a number"
|
|
(f 3))
|
|
(test-contract-error top-level "f" "not a number"
|
|
(f #t)))
|
|
|
|
;; unit/new-import-export tests
|
|
|
|
(define-signature sig7 (f))
|
|
(define-signature sig8 ((contracted [f (-> number? number?)])))
|
|
(define-signature sig9 ((contracted [f (-> number? number?)])))
|
|
|
|
;; All units that play nicely
|
|
(define-unit unit12
|
|
(import sig7)
|
|
(export)
|
|
(f 3))
|
|
(define-unit unit13
|
|
(import sig8)
|
|
(export)
|
|
(f 3))
|
|
(define-unit unit14
|
|
(import)
|
|
(export sig7)
|
|
(define f (λ (n) 3)))
|
|
(define-unit unit15
|
|
(import)
|
|
(export sig8)
|
|
(define f (λ (n) 3)))
|
|
|
|
;; All units that don't play nicely (or won't after converted)
|
|
(define-unit unit16
|
|
(import sig7)
|
|
(export)
|
|
(f #t))
|
|
(define-unit unit17
|
|
(import sig8)
|
|
(export)
|
|
(f #t))
|
|
(define-unit unit18
|
|
(import)
|
|
(export sig7)
|
|
(define f (λ (n) #t)))
|
|
(define-unit unit19
|
|
(import)
|
|
(export sig8)
|
|
(define f (λ (n) #t)))
|
|
|
|
;; Converting units without internal contract violations
|
|
|
|
;; uncontracted import -> contracted import
|
|
(define-unit/new-import-export unit20
|
|
(import sig8)
|
|
(export)
|
|
(() unit12 sig7))
|
|
(let ()
|
|
(define-compound-unit unit21
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit15]
|
|
[() unit20 S]))
|
|
(invoke-unit unit21))
|
|
(let ()
|
|
(define-compound-unit unit22
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit19]
|
|
[() unit20 S]))
|
|
(test-contract-error "(unit unit19)" "f" "not a number"
|
|
(invoke-unit unit22)))
|
|
|
|
;; contracted import -> uncontracted import
|
|
(define-unit/new-import-export unit23
|
|
(import sig7)
|
|
(export)
|
|
(() unit13 sig8))
|
|
(let ()
|
|
(define-compound-unit unit24
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit14]
|
|
[() unit23 S]))
|
|
(invoke-unit unit24))
|
|
(let ()
|
|
(define-compound-unit unit25
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit18]
|
|
[() unit23 S]))
|
|
(test-contract-error "(unit unit23)" "f" "not a number"
|
|
(invoke-unit unit25)))
|
|
|
|
;; contracted import -> contracted import
|
|
(define-unit/new-import-export unit26
|
|
(import sig9)
|
|
(export)
|
|
(() unit13 sig8))
|
|
(let ()
|
|
(define-unit unit27-1
|
|
(import)
|
|
(export sig9)
|
|
(define (f n) 3))
|
|
(define-compound-unit unit27-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit27-1]
|
|
[() unit26 S]))
|
|
(invoke-unit unit27-2))
|
|
(let ()
|
|
(define-unit unit28-1
|
|
(import)
|
|
(export sig9)
|
|
(define (f n) #f))
|
|
(define-compound-unit unit28-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit28-1]
|
|
[() unit26 S]))
|
|
(test-contract-error "(unit unit28-1)" "f" "not a number"
|
|
(invoke-unit unit28-2)))
|
|
|
|
;; uncontracted export -> contracted export
|
|
(define-unit/new-import-export unit29
|
|
(import)
|
|
(export sig8)
|
|
((sig7) unit14))
|
|
(let ()
|
|
(define-compound-unit unit30
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit29]
|
|
[() unit13 S]))
|
|
(invoke-unit unit30))
|
|
(let ()
|
|
(define-compound-unit unit31
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit29]
|
|
[() unit17 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit31)))
|
|
|
|
;; contracted export -> uncontracted export
|
|
(define-unit/new-import-export unit32
|
|
(import)
|
|
(export sig7)
|
|
((sig8) unit15))
|
|
(let ()
|
|
(define-compound-unit unit33
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit32]
|
|
[() unit14 S]))
|
|
(invoke-unit unit33))
|
|
(let ()
|
|
(define-compound-unit unit34
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit32]
|
|
[() unit16 S]))
|
|
(test-contract-error "(unit unit32)" "f" "not a number"
|
|
(invoke-unit unit34)))
|
|
|
|
;; contracted export -> contracted export
|
|
(define-unit/new-import-export unit35
|
|
(import)
|
|
(export sig9)
|
|
((sig8) unit15))
|
|
(let ()
|
|
(define-unit unit36-1
|
|
(import sig9)
|
|
(export)
|
|
(f 3))
|
|
(define-compound-unit unit36-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit35]
|
|
[() unit36-1 S]))
|
|
(invoke-unit unit36-2))
|
|
(let ()
|
|
(define-unit unit37-1
|
|
(import sig9)
|
|
(export)
|
|
(f #f))
|
|
(define-compound-unit unit37-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit35]
|
|
[() unit37-1 S]))
|
|
(test-contract-error "(unit unit37-1)" "f" "not a number"
|
|
(invoke-unit unit37-2)))
|
|
|
|
;; Converting units with internal contract violations
|
|
|
|
;; uncontracted import -> contracted import
|
|
(define-unit/new-import-export unit38
|
|
(import sig8)
|
|
(export)
|
|
(() unit16 sig7))
|
|
(let ()
|
|
(define-compound-unit unit39
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit15]
|
|
[() unit38 S]))
|
|
(test-contract-error "(unit unit38)" "f" "not a number"
|
|
(invoke-unit unit39)))
|
|
(let ()
|
|
(define-compound-unit unit40
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit19]
|
|
[() unit38 S]))
|
|
(test-contract-error "(unit unit38)" "f" "not a number"
|
|
(invoke-unit unit40)))
|
|
|
|
;; contracted import -> uncontracted import
|
|
(define-unit/new-import-export unit41
|
|
(import sig7)
|
|
(export)
|
|
(() unit17 sig8))
|
|
(let ()
|
|
(define-compound-unit unit42
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit14]
|
|
[() unit41 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit42)))
|
|
(let ()
|
|
(define-compound-unit unit43
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit18]
|
|
[() unit41 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit43)))
|
|
|
|
;; contracted import -> contracted import
|
|
(define-unit/new-import-export unit44
|
|
(import sig9)
|
|
(export)
|
|
(() unit17 sig8))
|
|
(let ()
|
|
(define-unit unit45-1
|
|
(import)
|
|
(export sig9)
|
|
(define (f n) 3))
|
|
(define-compound-unit unit45-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit45-1]
|
|
[() unit44 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit45-2)))
|
|
(let ()
|
|
(define-unit unit46-1
|
|
(import)
|
|
(export sig9)
|
|
(define (f n) #t))
|
|
(define-compound-unit unit46-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit46-1]
|
|
[() unit44 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit46-2)))
|
|
|
|
;; uncontracted export -> contracted export
|
|
(define-unit/new-import-export unit47
|
|
(import)
|
|
(export sig8)
|
|
((sig7) unit18))
|
|
(let ()
|
|
(define-compound-unit unit48
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit47]
|
|
[() unit13 S]))
|
|
(test-contract-error "(unit unit47)" "f" "not a number"
|
|
(invoke-unit unit48)))
|
|
(let ()
|
|
(define-compound-unit unit49
|
|
(import)
|
|
(export)
|
|
(link [((S : sig8)) unit47]
|
|
[() unit17 S]))
|
|
(test-contract-error "(unit unit17)" "f" "not a number"
|
|
(invoke-unit unit49)))
|
|
|
|
;; contracted import -> uncontracted import
|
|
(define-unit/new-import-export unit50
|
|
(import)
|
|
(export sig7)
|
|
((sig8) unit19))
|
|
(let ()
|
|
(define-compound-unit unit51
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit50]
|
|
[() unit12 S]))
|
|
(test-contract-error "(unit unit19)" "f" "not a number"
|
|
(invoke-unit unit51)))
|
|
(let ()
|
|
(define-compound-unit unit52
|
|
(import)
|
|
(export)
|
|
(link [((S : sig7)) unit50]
|
|
[() unit16 S]))
|
|
(test-contract-error "(unit unit50)" "f" "not a number"
|
|
(invoke-unit unit52)))
|
|
|
|
;; contracted export -> contracted export
|
|
(define-unit/new-import-export unit53
|
|
(import)
|
|
(export sig9)
|
|
((sig8) unit19))
|
|
(let ()
|
|
(define-unit unit54-1
|
|
(import sig9)
|
|
(export)
|
|
(f 3))
|
|
(define-compound-unit unit54-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit53]
|
|
[() unit54-1 S]))
|
|
(test-contract-error "(unit unit19)" "f" "not a number"
|
|
(invoke-unit unit54-2)))
|
|
(let ()
|
|
(define-unit unit55-1
|
|
(import sig9)
|
|
(export)
|
|
(f #t))
|
|
(define-compound-unit unit55-2
|
|
(import)
|
|
(export)
|
|
(link [((S : sig9)) unit53]
|
|
[() unit55-1 S]))
|
|
(test-contract-error "(unit unit55-1)" "f" "not a number"
|
|
(invoke-unit unit55-2)))
|
|
|
|
(module m1 scheme
|
|
(define-signature foo^ (x))
|
|
(define-signature bar^ (y))
|
|
(provide foo^ bar^)
|
|
|
|
(define-unit U@
|
|
(import foo^)
|
|
(export bar^)
|
|
(define (y s)
|
|
(if (eq? s 'bork)
|
|
3
|
|
(string-append (symbol->string s) " " (if (x 3) "was true on 3" "was not true on 3")))))
|
|
(provide/contract [U@ (unit/c (import (foo^ [x (-> number? boolean?)]))
|
|
(export (bar^ [y (-> symbol? string?)])))]))
|
|
|
|
(module m2 scheme
|
|
(require 'm1)
|
|
|
|
(define x zero?)
|
|
(define-values/invoke-unit U@
|
|
(import foo^)
|
|
(export bar^))
|
|
|
|
(define (z)
|
|
(y 'a))
|
|
(define (w)
|
|
(y "foo"))
|
|
(define (v)
|
|
(y 'bork))
|
|
|
|
(provide z w v))
|
|
|
|
(require (prefix-in m2: 'm2))
|
|
|
|
(m2:z)
|
|
(test-contract-error "'m2" "U@" "not a symbol" (m2:w))
|
|
(test-contract-error "'m1" "U@" "not a string" (m2:v))
|
|
|
|
(test-syntax-error "no y in sig1"
|
|
(unit/c (import (sig1 [y number?]))
|
|
(export)))
|
|
(test-syntax-error "two xs for sig1"
|
|
(unit/c (import)
|
|
(export (sig1 [x string?] [x number?]))))
|
|
(test-syntax-error "no sig called faux^, so import description matching fails"
|
|
(unit/c (import faux^) (export)))
|
|
|
|
(test-contract-error "(definition bad-export@)" "bad-export@" "unit must export sig1"
|
|
(let ()
|
|
(define/contract bad-export@
|
|
(unit/c (import) (export sig1))
|
|
(unit (import) (export)))
|
|
bad-export@))
|
|
|
|
(test-contract-error "(definition bad-import@)" "bad-import@" "contract must import sig1"
|
|
(let ()
|
|
(define/contract bad-import@
|
|
(unit/c (import) (export))
|
|
(unit (import sig1) (export) (+ x 1)))
|
|
bad-import@))
|
|
|
|
(test-contract-error "(definition not-a-unit)" "not-a-unit" "not a unit"
|
|
(let ()
|
|
(define/contract not-a-unit
|
|
(unit/c (import) (export))
|
|
3)
|
|
not-a-unit))
|
|
|
|
;; Adding a test to make sure that contracts can refer
|
|
;; to other parts of the signature.
|
|
|
|
(module m3 scheme
|
|
(define-signature toy-factory^
|
|
((contracted
|
|
[build-toys (-> integer? (listof toy?))]
|
|
[repaint (-> toy? symbol? toy?)]
|
|
[toy? (-> any/c boolean?)]
|
|
[toy-color (-> toy? symbol?)])))
|
|
|
|
(define-unit simple-factory@
|
|
(import)
|
|
(export toy-factory^)
|
|
|
|
(define-struct toy (color) #:transparent)
|
|
|
|
(define (build-toys n)
|
|
(for/list ([i (in-range n)])
|
|
(make-toy 'blue)))
|
|
|
|
(define (repaint t col)
|
|
(make-toy col)))
|
|
|
|
(provide toy-factory^ simple-factory@))
|
|
|
|
(module m4 scheme
|
|
(define-signature foo^ (x? (contracted [f (-> x? boolean?)])))
|
|
|
|
(define-unit U@
|
|
(import)
|
|
(export foo^)
|
|
(define (x? x) #f)
|
|
(define (f x) (x? x)))
|
|
|
|
(define-values/invoke-unit/infer U@)
|
|
|
|
(provide f x?))
|
|
|
|
(require (prefix-in m4: 'm4))
|
|
|
|
(test-contract-error "'m4" "f" "not an x"
|
|
(m4:f 3))
|
|
|
|
(require (prefix-in m3: 'm3))
|
|
|
|
(test-contract-error top-level "build-toys" "not a integer"
|
|
(let ()
|
|
(define-values/invoke-unit/infer m3:simple-factory@)
|
|
(build-toys #f)))
|
|
|
|
(module m5 scheme
|
|
(define-signature foo^ (f (contracted [x? (-> any/c boolean?)])))
|
|
|
|
(define-unit U@
|
|
(import)
|
|
(export foo^)
|
|
(define (x? n) (zero? n))
|
|
(define (f x) (x? x)))
|
|
|
|
(provide foo^)
|
|
(provide/contract
|
|
[U@
|
|
(unit/c (import)
|
|
(export (foo^ [f (-> x? boolean?)])))]))
|
|
|
|
(require (prefix-in m5: 'm5))
|
|
|
|
(define-values/invoke-unit m5:U@
|
|
(import)
|
|
(export (prefix m5: m5:foo^)))
|
|
|
|
(m5:f 0)
|
|
|
|
(test-contract-error top-level "U@" "not an x"
|
|
(m5:f 3))
|
|
|
|
(let ()
|
|
(define-signature foo^ (x? f))
|
|
(define-signature bar^ ((contracted [x? (-> number? boolean?)]
|
|
[f (-> x? number?)])))
|
|
(define-unit U@
|
|
(import)
|
|
(export bar^)
|
|
(define x? zero?)
|
|
(define f values))
|
|
|
|
(define-unit/new-import-export V@
|
|
(import)
|
|
(export bar^)
|
|
((bar^) U@))
|
|
|
|
(define-values/invoke-unit/infer V@)
|
|
|
|
(f 0)
|
|
(test-contract-error top-level "f" "not an x"
|
|
(f 3)))
|
|
|
|
(let ()
|
|
(define-signature foo^ ((contracted [x? (-> number? boolean?)]
|
|
[f (-> x? number?)])))
|
|
(define-signature bar^ (f (contracted [x? (-> any/c boolean?)])))
|
|
(define-unit U@
|
|
(import)
|
|
(export foo^)
|
|
(define x? zero?)
|
|
(define f values))
|
|
|
|
(define-unit/new-import-export V@
|
|
(import)
|
|
(export bar^)
|
|
((foo^) U@))
|
|
|
|
(define-values/invoke-unit/infer V@)
|
|
|
|
(f 0)
|
|
(test-contract-error "(unit V@)" "f" "not an x"
|
|
(f 3)))
|
|
|
|
(let ()
|
|
(define-signature foo^ (x y))
|
|
(define-unit/contract U@
|
|
(import)
|
|
(export (foo^ [x (-> number? number?)]))
|
|
(define (x n) (zero? n))
|
|
(define y 4))
|
|
(define-unit V@
|
|
(import foo^)
|
|
(export)
|
|
(x 4))
|
|
(define-compound-unit/infer W@
|
|
(import) (export) (link U@ V@))
|
|
(define-values/invoke-unit/infer U@)
|
|
y
|
|
(test-contract-error top-level "U@" "not a number"
|
|
(x #t))
|
|
(test-contract-error "(unit U@)" "U@" "not a number"
|
|
(x 3))
|
|
(test-contract-error "(unit U@)" "U@" "not a number"
|
|
(invoke-unit W@)))
|
|
|
|
(let ()
|
|
(define-signature foo^ (x? f))
|
|
(define-unit/contract U@
|
|
(import)
|
|
(export (foo^ [f (-> x? number?)]))
|
|
(define (x? n) (or (= n 3)
|
|
(zero? n)))
|
|
(define (f n) (if (= n 3) #t n)))
|
|
(define-unit V@
|
|
(import foo^)
|
|
(export)
|
|
(test-contract-error top-level "U@" "not an x"
|
|
(f 2))
|
|
(test-contract-error "(unit U@)" "U@" "not an number"
|
|
(f 3)))
|
|
(define-compound-unit/infer W@
|
|
(import) (export) (link U@ V@))
|
|
(define-values/invoke-unit/infer U@)
|
|
(test-contract-error top-level "U@" "not an x"
|
|
(f 4))
|
|
(test-contract-error "(unit U@)" "U@" "not a number"
|
|
(f 3))
|
|
(invoke-unit W@))
|
|
|
|
(let ()
|
|
(define-signature foo^
|
|
((contracted
|
|
[x? (-> number? boolean?)]
|
|
[f (-> x? number?)])))
|
|
|
|
(define-unit/contract foo@
|
|
(import)
|
|
(export (foo^ [x? (-> any/c boolean?)]))
|
|
|
|
(define (x? n) (zero? n))
|
|
(define (f x) 3))
|
|
|
|
(define-values/invoke-unit/infer foo@)
|
|
|
|
(f 0)
|
|
(test-contract-error top-level "f" "not an x"
|
|
(f 4))
|
|
;; This is a weird one. The definition for foo@ has two conflicting
|
|
;; contracts. Who gets blamed? Still the top-level, since foo@ can't
|
|
;; get blamed for breaking its own contract. In theory you could say
|
|
;; that perhaps the top-level shouldn't be blamed, and that it should
|
|
;; just be an "overriding" contract, but a) that won't really work and
|
|
;; b) what about other units that might link with foo@, that expect
|
|
;; the stronger contract?
|
|
(test-contract-error top-level "x?" "not a number"
|
|
(f #t)))
|
|
|
|
(let ()
|
|
(define-signature student^
|
|
((struct/ctc student ([name string?] [id number?]))))
|
|
(define-unit student@
|
|
(import)
|
|
(export student^)
|
|
(define-struct student (name id)))
|
|
(define-values/invoke-unit/infer student@)
|
|
(make-student "foo" 3)
|
|
(test-contract-error top-level "make-student" "not a string"
|
|
(make-student 4 3))
|
|
(test-contract-error top-level "student-id" "not a student"
|
|
(student-id 'a))) |