..
original commit: bd5c5824b968ee5aade63419b360cf575535ed2c
This commit is contained in:
Robby Findler
parent
e0b93e85f5
commit
859eb8f118
|
|
@ -457,7 +457,8 @@
|
|||
(unless (and (string? name)
|
||||
(procedure? contract)
|
||||
(procedure-arity-includes? contract 1))
|
||||
(error 'flat-named-contract "expected string and procedure of one argument as arguments, given: ~e and ~e"
|
||||
(error 'flat-named-contract
|
||||
"expected string and procedure of one argument as arguments, given: ~e and ~e"
|
||||
name contract))
|
||||
(make-flat-named-contract name contract))])
|
||||
flat-named-contract))
|
||||
|
|
@ -495,7 +496,8 @@
|
|||
src-info))
|
||||
(unless (and (symbol? neg-blame)
|
||||
(symbol? pos-blame))
|
||||
(error 'contract "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e"
|
||||
(error 'contract
|
||||
"expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e"
|
||||
neg-blame pos-blame
|
||||
a-contract
|
||||
name
|
||||
|
|
@ -509,7 +511,7 @@
|
|||
name))
|
||||
(check-contract a-contract name pos-blame neg-blame src-info)))])))
|
||||
|
||||
;; check-contract : contract any symbol symbol syntax -> ...
|
||||
;; check-contract : contract any symbol symbol syntax -> any
|
||||
(define (check-contract contract val pos neg src-info)
|
||||
(cond
|
||||
[(contract? contract)
|
||||
|
|
@ -563,7 +565,8 @@
|
|||
tbb
|
||||
src-loc))
|
||||
(unless (symbol? tbb)
|
||||
(error 'contract-=> "expected symbol as names for assigning blame, given: ~e, other args ~e ~e ~e ~e"
|
||||
(error 'contract-=>
|
||||
"expected symbol as names for assigning blame, given: ~e, other args ~e ~e ~e ~e"
|
||||
tbb
|
||||
c1
|
||||
c2
|
||||
|
|
@ -902,6 +905,7 @@
|
|||
|
||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
|
||||
[(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
|
|
@ -944,18 +948,32 @@
|
|||
...))))))
|
||||
(syntax
|
||||
(lambda (ant conq val tbb src-info)
|
||||
(let* ([ant-info (contract-impl-info conq)]
|
||||
[dom-ant-info (ant-info dom-length)])
|
||||
(if dom-ant-info
|
||||
(let ([dom-ant-x (vector-ref dom-ant-info dom-index)] ...)
|
||||
(lambda (arg-x ...)
|
||||
(val (check-implication dom-x dom-ant-x arg-x tbb src-info) ...)))
|
||||
(raise-contract-implication-error ant conq val tbb src-info)))))
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val dom-length))
|
||||
(let* ([ant-info (contract-impl-info ant)]
|
||||
[dom-ant-info (ant-info dom-length #t #f)]
|
||||
[rng-ant-info (ant-info rng-length #f #f)])
|
||||
(if (and rng-ant-info dom-ant-info)
|
||||
(let ([dom-ant-x (vector-ref dom-ant-info dom-index)] ...
|
||||
[rng-ant-x (vector-ref rng-ant-info rng-index)] ...)
|
||||
(lambda (arg-x ...)
|
||||
(let-values ([(res-x ...)
|
||||
(val (check-implication dom-x dom-ant-x arg-x tbb src-info) ...)])
|
||||
(values
|
||||
(check-implication rng-ant-x rng-x res-x tbb src-info) ...))))
|
||||
(raise-contract-implication-error ant conq val tbb src-info)))
|
||||
(raise-contract-implication-error ant conq val tbb src-info))))
|
||||
(syntax
|
||||
(lambda (len)
|
||||
(cond
|
||||
[(= len dom-length) (vector dom-x ...)]
|
||||
[else #f])))))]
|
||||
(lambda (len dom? and-more?)
|
||||
(if and-more?
|
||||
#f
|
||||
(if dom?
|
||||
(cond
|
||||
[(= len dom-length) (vector dom-x ...)]
|
||||
[else #f])
|
||||
(cond
|
||||
[(= len rng-length) (vector rng-x ...)]
|
||||
[else #f])))))))]
|
||||
[(_ (dom ...) rest (rng ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
|
|
|
|||
|
|
@ -9,11 +9,13 @@
|
|||
;; test/spec-passed : symbol sexp -> void
|
||||
;; tests a passing specification
|
||||
(define (test/spec-passed name expression)
|
||||
(printf "testing: ~s\n" name)
|
||||
(test (void)
|
||||
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
|
||||
(list expression '(void))))
|
||||
|
||||
(define (test/spec-passed/result name expression result)
|
||||
(printf "testing: ~s\n" name)
|
||||
(test result
|
||||
eval
|
||||
expression))
|
||||
|
|
@ -21,18 +23,21 @@
|
|||
;; test/spec-failed : symbol sexp string -> void
|
||||
;; tests a failing specification with blame assigned to `blame'
|
||||
(define (test/spec-failed name expression blame)
|
||||
(define (failed-contract x)
|
||||
(and (string? x)
|
||||
(cond
|
||||
[(regexp-match ": ([^ ]*) broke" x) => cadr]
|
||||
[(regexp-match "([^ ]+): .* does not imply" x) => cadr]
|
||||
[else #f])))
|
||||
(define (ensure-contract-failed x)
|
||||
(let ([result (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||
exn-message])
|
||||
(list 'normal-termination
|
||||
(eval x)))])
|
||||
(if (string? result)
|
||||
(cond
|
||||
[(regexp-match ": ([^ ]*) broke" result) => cadr]
|
||||
[(regexp-match "([^ ]+): .* does not imply" result) => cadr]
|
||||
[else "no blame in error message"])
|
||||
result)))
|
||||
(printf "testing: ~s\n" name)
|
||||
(test blame
|
||||
failed-contract
|
||||
(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||
exn-message])
|
||||
(eval expression)
|
||||
'failed/expected-exn-got-normal-termination)))
|
||||
ensure-contract-failed
|
||||
expression))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-flat1
|
||||
|
|
@ -550,18 +555,143 @@
|
|||
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>1
|
||||
'contract-=>flat1
|
||||
'(contract-=> (>=/c 5) (>=/c 10) 1 'badguy)
|
||||
1)
|
||||
(test/spec-passed/result
|
||||
'contract-=>2
|
||||
'contract-=>flat2
|
||||
'(contract-=> (>=/c 5) (>=/c 10) 12 'badguy)
|
||||
12)
|
||||
(test/spec-failed
|
||||
'contract-=>3
|
||||
'contract-=>flat3
|
||||
'(contract-=> (>=/c 5) (>=/c 10) 6 'badguy)
|
||||
"badguy")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-=>->1
|
||||
'(contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->2
|
||||
'(contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) 'not-a-proc 'badguy)
|
||||
"badguy")
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>->3
|
||||
'((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy)
|
||||
1)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>->4
|
||||
'((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy)
|
||||
12)
|
||||
12)
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->5
|
||||
'((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 5)) (lambda (x) x) 'badguy)
|
||||
7)
|
||||
"badguy")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->6
|
||||
'((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 10) . -> . (>=/c 10)) (lambda (x) 7) 'badguy)
|
||||
7)
|
||||
"badguy")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-=>->*1
|
||||
'(contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values x y))
|
||||
'badguy))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->*2
|
||||
'(contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
'not-a-proc
|
||||
'badguy)
|
||||
"badguy")
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>->*3
|
||||
'(let-values ([(r1 r2)
|
||||
((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values x y))
|
||||
'badguy)
|
||||
1 7)])
|
||||
r1)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>->*4
|
||||
'(let-values ([(r1 r2)
|
||||
((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values x y))
|
||||
'badguy)
|
||||
11 21)])
|
||||
r1)
|
||||
11)
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->*5
|
||||
'((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values x y))
|
||||
'badguy)
|
||||
5 21)
|
||||
"badguy")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->*6
|
||||
'((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values x y))
|
||||
'badguy)
|
||||
11 10)
|
||||
"badguy")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->*7
|
||||
'((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values 8 25))
|
||||
'badguy)
|
||||
11 21)
|
||||
"badguy")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>->*8
|
||||
'((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y) (values 15 10))
|
||||
'badguy)
|
||||
11 21)
|
||||
"badguy")
|
||||
|
||||
(test/spec-passed/result
|
||||
'contract-=>->*9
|
||||
'(let-values ([(a b)
|
||||
((contract-=> (->* ((>=/c 10) (>=/c 20) (>=/c 30)) ((>=/c 3) (>=/c 8)))
|
||||
(->* ((>=/c 3) (>=/c 8) (>=/c 30)) ((>=/c 10) (>=/c 20)))
|
||||
(lambda (x y z) (values x z))
|
||||
'badguy)
|
||||
101 102 103)])
|
||||
b)
|
||||
103)
|
||||
|
||||
(test/spec-failed
|
||||
'contract-=>mismatch
|
||||
'(contract-=> (>=/c 5)
|
||||
(-> (>=/c 3) (>=/c 8))
|
||||
1
|
||||
'badguy)
|
||||
"badguy")
|
||||
|
||||
))
|
||||
|
||||
(report-errs)
|
||||
Loading…
Reference in New Issue
Block a user