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

..

Browse Source 
original commit: 2a49215031f2556d02e4f98e6a488ac4b1b418b6
This commit is contained in:
Robby Findler 2003-03-31 19:38:11 +00:00
parent ad939ca68b
commit 31fea16ff9
1 changed files with 68 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/mzlib/contract.ss
View File

@ -14,7 +14,12 @@
;object-contract ;; not yet good enough
(rename -contract? contract?)
provide/contract
define/contract)
define/contract
none?
none-v
any-mb
none-mb)
(require-for-syntax mzscheme
"list.ss"
@ -429,7 +434,41 @@
;; flat-named-contract = (make-flat-named-contract string (any -> boolean))
;; this holds flat contracts that have names for error reporting
(define-struct flat-named-contract (type-name predicate))
(define (make-mb pos?)
(make-contract
(lambda (val pos neg src-loc)
(define (any-contract v)
(cond
[(procedure? v)
(lambda x
(call-with-values
(lambda ()
(apply v (map none-contract x)))
(lambda x
(apply values (map any-contract x)))))]
[else v]))
(define (none-contract v)
(make-none
(if (procedure? v)
(lambda x
(call-with-values
(lambda ()
(apply v (map any-contract x)))
(lambda x
(apply values (map none-contract x)))))
v)
(if pos? pos neg)))
(any-contract val))
(lambda (a b c d e) (error 'any-mb "subtyping unimplemented"))))
(define any-mb (make-mb #f))
(define none-mb (make-mb #t))
(define-struct none (v tbb))
(provide (rename build-flat-named-contract flat-named-contract)
flat-named-contract-type-name
flat-named-contract-predicate)
@ -498,26 +537,34 @@
(cond
[(contract? contract)
((contract-wrap contract) val pos neg src-info)]
[(flat-named-contract? contract)
(if ((flat-named-contract-predicate contract) val)
val
(raise-contract-error
src-info
pos
neg
"expected type <~a>, given: ~e"
(flat-named-contract-type-name contract)
val))]
[else
(if (contract val)
val
(raise-contract-error
src-info
pos
neg
"~agiven: ~e"
(predicate->expected-msg contract)
val))]))
(let ([passed-test?
(if (flat-named-contract? contract)
((flat-named-contract-predicate contract) val)
(contract val))])
(if passed-test?
val
(let ([actual-pos (if (none? val)
(none-tbb val)
pos)]
[actual-neg (if (none? val)
(none-tbb val)
neg)])
(if (flat-named-contract? contract)
(raise-contract-error
src-info
actual-pos
actual-neg
"expected type <~a>, given: ~e"
(flat-named-contract-type-name contract)
val)
(raise-contract-error
src-info
actual-pos
actual-neg
"~agiven: ~e"
(predicate->expected-msg contract)
val)))))]))
(define-syntax (contract-=> stx)
(syntax-case stx ()