..
original commit: 84590ddec88502e234cff59005d00b29e94354ce
This commit is contained in:
Robby Findler
parent
d7cd38d4f0
commit
c857d40841
|
|
@ -1,894 +0,0 @@
|
|||
|
||||
(module specs mzscheme
|
||||
(provide (rename -contract contract)
|
||||
->
|
||||
->d
|
||||
->*
|
||||
->d*
|
||||
case->
|
||||
opt->
|
||||
opt->*
|
||||
(rename -contract? contract?)
|
||||
provide/contract)
|
||||
|
||||
(require-for-syntax mzscheme
|
||||
(lib "list.ss")
|
||||
(lib "name.ss" "syntax")
|
||||
(lib "stx.ss" "syntax"))
|
||||
|
||||
(require (lib "class.ss"))
|
||||
|
||||
;; (provide/contract (id expr) ...)
|
||||
;; provides each `id' with the contract `expr'.
|
||||
(define-syntax (provide/contract provide-stx)
|
||||
(syntax-case provide-stx ()
|
||||
[(_ (id ctrct) ...)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(with-syntax ([(id-rename ...)
|
||||
(map (lambda (x)
|
||||
(datum->syntax-object
|
||||
provide-stx
|
||||
(string->symbol
|
||||
(format "provide/contract-id-~a-ACK-DONT_USE_ME"
|
||||
(syntax-object->datum x)))))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[(contract-id ...)
|
||||
(map (lambda (x)
|
||||
(datum->syntax-object
|
||||
provide-stx
|
||||
(string->symbol
|
||||
(format "provide/contract-contract-id-~a-ACK-DONT_USE_ME"
|
||||
(syntax-object->datum x)))))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[pos-blame-stx (datum->syntax-object provide-stx 'here)]
|
||||
[module-source-as-symbol (datum->syntax-object provide-stx 'module-source-as-symbol)])
|
||||
(syntax
|
||||
(begin
|
||||
(provide (rename id-rename id) ...)
|
||||
(require (lib "contract-helpers.scm" "framework" "private"))
|
||||
(define contract-id ctrct) ...
|
||||
(define-syntax id-rename
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-blame-stx (datum->syntax-object stx 'here)])
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ body) (raise-syntax-error
|
||||
#f
|
||||
"cannot mutate provide/contract identifier"
|
||||
stx
|
||||
(syntax _))]
|
||||
[(_ arg (... ...))
|
||||
(syntax
|
||||
((-contract contract-id
|
||||
id
|
||||
(module-source-as-symbol (quote-syntax pos-blame-stx))
|
||||
(module-source-as-symbol (quote-syntax neg-blame-stx))
|
||||
(quote-syntax _))
|
||||
arg
|
||||
(... ...)))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax
|
||||
(-contract contract-id
|
||||
id
|
||||
(module-source-as-symbol (quote-syntax pos-blame-stx))
|
||||
(module-source-as-symbol (quote-syntax neg-blame-stx))
|
||||
(quote-syntax _)))])))))
|
||||
...)))]
|
||||
[(_ clauses ...)
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(x y)
|
||||
(identifier? (syntax x))
|
||||
(void)]
|
||||
[(x y)
|
||||
(raise-syntax-error
|
||||
'provide/contract
|
||||
"malformed clause (expected an identifier as first item in clause)"
|
||||
provide-stx
|
||||
(syntax x))]
|
||||
[_ (raise-syntax-error
|
||||
'provide/contract
|
||||
"malformed clause (expected two items in each clause)"
|
||||
provide-stx
|
||||
clause)]))
|
||||
(syntax->list (syntax (clauses ...))))]))
|
||||
|
||||
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
|
||||
;; doesn't return
|
||||
(define (raise-contract-error src-info to-blame other-party fmt . args)
|
||||
(let ([blame-src (if (syntax? src-info)
|
||||
(let ([source (syntax-source src-info)]
|
||||
[line (syntax-line src-info)]
|
||||
[col (syntax-column src-info)]
|
||||
[pos (syntax-position src-info)])
|
||||
(cond
|
||||
[(and (string? source) line col)
|
||||
(format "~a: ~a.~a: " source line col)]
|
||||
[(and line col)
|
||||
(format "~a.~a: " line col)]
|
||||
[(and (string? source) pos)
|
||||
(format "~a: ~a: " source pos)]
|
||||
[pos
|
||||
(format "~a: " pos)]
|
||||
[else ""]))
|
||||
"")]
|
||||
[specific-blame
|
||||
(let ([datum (syntax-object->datum src-info)])
|
||||
(if (symbol? datum)
|
||||
(format "broke ~a's contract" datum)
|
||||
"failed contract"))])
|
||||
(raise
|
||||
(make-exn
|
||||
(string->immutable-string
|
||||
(string-append (format "~a~a: ~a ~a: "
|
||||
blame-src
|
||||
other-party
|
||||
to-blame
|
||||
specific-blame)
|
||||
(apply format fmt args)))
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; contract = (make-contract (alpha sym sym sym -> alpha))
|
||||
;; generic contract container
|
||||
(define-struct contract (f))
|
||||
|
||||
;; 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))
|
||||
(provide (rename build-flat-named-contract flat-named-contract)
|
||||
flat-named-contract-type-name
|
||||
flat-named-contract-predicate)
|
||||
(define build-flat-named-contract
|
||||
(let ([flat-named-contract
|
||||
(lambda (name contract)
|
||||
(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"
|
||||
name contract))
|
||||
(make-flat-named-contract name contract))])
|
||||
flat-named-contract))
|
||||
|
||||
(define-syntax -contract
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract to-check pos-blame-e neg-blame-e)
|
||||
(with-syntax ([src-loc (datum->syntax-object stx 'here)])
|
||||
(syntax
|
||||
(-contract a-contract to-check pos-blame-e neg-blame-e
|
||||
(quote-syntax src-loc))))]
|
||||
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
|
||||
(let ([name (syntax-local-infer-name (syntax a-contract-e))])
|
||||
(with-syntax ([named-a-contract-e
|
||||
(if name
|
||||
(syntax-property (syntax a-contract-e) 'inferred-name name)
|
||||
(syntax a-contract-e))])
|
||||
(syntax
|
||||
(let ([a-contract named-a-contract-e]
|
||||
[name to-check]
|
||||
[neg-blame neg-blame-e]
|
||||
[pos-blame pos-blame-e]
|
||||
[src-info src-info-e])
|
||||
(unless (-contract? a-contract)
|
||||
(error 'contract "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e"
|
||||
a-contract
|
||||
name
|
||||
pos-blame
|
||||
neg-blame
|
||||
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"
|
||||
neg-blame pos-blame
|
||||
a-contract
|
||||
name
|
||||
src-info))
|
||||
(unless (syntax? src-info)
|
||||
(error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e"
|
||||
src-info
|
||||
neg-blame
|
||||
pos-blame
|
||||
a-contract
|
||||
name))
|
||||
(check-contract a-contract name pos-blame neg-blame src-info)))))])))
|
||||
|
||||
(define-syntaxes (-> ->* ->d ->d* case->)
|
||||
(let ()
|
||||
;; Each of the /h functions builds three pieces of syntax:
|
||||
;; - code that does error checking for the contract specs
|
||||
;; (were the arguments all contracts?)
|
||||
;; - code that does error checking on the contract'd value
|
||||
;; (is a function of the right arity?)
|
||||
;; - a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
;; They are combined into a lambda for the -> ->* ->d ->d* macros,
|
||||
;; and combined into a case-lambda for the case-> macro.
|
||||
|
||||
;; ->/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->/h stx)
|
||||
(syntax-case stx ()
|
||||
[(_) (raise-syntax-error '-> "expected at least one argument" stx)]
|
||||
[(_ ct ...)
|
||||
(let* ([rng-normal (car (last-pair (syntax->list (syntax (ct ...)))))]
|
||||
[ignore-range-checking?
|
||||
(syntax-case rng-normal (any)
|
||||
[any #t]
|
||||
[_ #f])])
|
||||
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))]
|
||||
[rng (if ignore-range-checking?
|
||||
(syntax any?) ;; hack to simplify life...
|
||||
rng-normal)])
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(let ([->add-outer-check
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (-contract? dom-x)
|
||||
(error '-> "expected contract as argument, given: ~e" dom-x)) ...
|
||||
(unless (-contract? rng-x)
|
||||
(error '-> "expected contract as argument, given: ~e" rng-x))
|
||||
body))))]
|
||||
[->body (syntax (->* (dom-x ...) (rng-x)))])
|
||||
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
|
||||
(values
|
||||
(lambda (body) (->add-outer-check (->*add-outer-check body)))
|
||||
(lambda (stx) (->*make-inner-check stx))
|
||||
(if ignore-range-checking?
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
...)))))
|
||||
(lambda (stx)
|
||||
(->*make-body stx)))))))))]))
|
||||
|
||||
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->*/h stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (dom ...) (rng ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng] ...)
|
||||
(unless (-contract? dom-x)
|
||||
(error '->* "expected contract as argument, given: ~e" dom-x)) ...
|
||||
(unless (-contract? rng-x)
|
||||
(error '->* "expected contract as argument, given: ~e" rng-x)) ...
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||
arity
|
||||
val)))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(let-values ([(res-x ...)
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
...)])
|
||||
(values (check-contract
|
||||
rng-x
|
||||
res-x
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)
|
||||
...))))))))]
|
||||
[(_ (dom ...) rest (rng ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-x rng] ...)
|
||||
(unless (-contract? dom-x)
|
||||
(error '->* "expected contract for domain position, given: ~e" dom-x)) ...
|
||||
(unless (-contract? dom-rest-x)
|
||||
(error '->* "expected contract for rest position, given: ~e" dom-rest-x))
|
||||
(unless (-contract? rng-x)
|
||||
(error '->* "expected contract for range position, given: ~e" rng-x)) ...
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||
arity
|
||||
val)))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ... . rest-arg-x)
|
||||
(let-values ([(res-x ...)
|
||||
(apply
|
||||
val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
...
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info))])
|
||||
(values (check-contract
|
||||
rng-x
|
||||
res-x
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)
|
||||
...))))))))]))
|
||||
|
||||
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d/h stx)
|
||||
(syntax-case stx ()
|
||||
[(_) (raise-syntax-error '->d "expected at least one argument" stx)]
|
||||
[(_ ct ...)
|
||||
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))]
|
||||
[rng (car (last-pair (syntax->list (syntax (ct ...)))))])
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (-contract? dom-x)
|
||||
(error '->d "expected contract as argument, given: ~e" dom-x)) ...
|
||||
(unless (and (procedure? rng-x)
|
||||
(procedure-arity-includes? rng-x arity))
|
||||
(error '->d "expected range portion to be a function that takes ~a arguments, given: ~e"
|
||||
arity
|
||||
rng-x))
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||
arity
|
||||
val)))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(let ([rng-contract (rng-x arg-x ...)])
|
||||
(unless (-contract? rng-contract)
|
||||
(error '->d "expected range portion to return a contract, given: ~e"
|
||||
rng-contract))
|
||||
(check-contract
|
||||
rng-contract
|
||||
(val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)))))))))]))
|
||||
|
||||
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d*/h stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (dom ...) rng-mk)
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-mk-x rng-mk])
|
||||
(unless (-contract? dom-x)
|
||||
(error '->*d "expected contract as argument, given: ~e" dom-x)) ...
|
||||
(unless (and (procedure? rng-mk-x)
|
||||
(procedure-arity-includes? rng-mk-x arity))
|
||||
(error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
||||
arity rng-mk-x))
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||
arity
|
||||
val)))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(rng-mk-x arg-x ...))
|
||||
(lambda rng-contracts
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
...))
|
||||
(lambda results
|
||||
(unless (= (length results) (length rng-contracts))
|
||||
(error '->d*
|
||||
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
|
||||
(length results) (length rng-contracts)))
|
||||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(check-contract
|
||||
rng-contract
|
||||
result
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info))
|
||||
rng-contracts
|
||||
results))))))))))))]
|
||||
[(_ (dom ...) rest rng-mk)
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-mk-x rng-mk])
|
||||
(unless (-contract? dom-x)
|
||||
(error '->*d "expected contract as argument, given: ~e" dom-x)) ...
|
||||
(unless (-contract? dom-rest-x)
|
||||
(error '->*d "expected contract for rest argument, given: ~e" dom-rest-x))
|
||||
(unless (procedure? rng-mk-x)
|
||||
(error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e"
|
||||
arity rng-mk-x))
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error
|
||||
src-info
|
||||
pos-blame
|
||||
neg-blame
|
||||
"expected a procedure that accepts ~a arguments, given: ~e"
|
||||
arity
|
||||
val)))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
((arg-x ... . rest-arg-x)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply rng-mk-x arg-x ... rest-arg-x))
|
||||
(lambda rng-contracts
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply
|
||||
val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
...
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info)))
|
||||
(lambda results
|
||||
(unless (= (length results) (length rng-contracts))
|
||||
(error '->d*
|
||||
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
|
||||
(length results) (length rng-contracts)))
|
||||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(check-contract
|
||||
rng-contract
|
||||
result
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info))
|
||||
rng-contracts
|
||||
results))))))))))))]))
|
||||
|
||||
;; make-/f : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
||||
;; -> (syntax -> syntax)
|
||||
(define (make-/f /h)
|
||||
(lambda (stx)
|
||||
(let-values ([(add-outer-check make-inner-check make-main) (/h stx)])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
||||
(with-syntax ([outer-args outer-args]
|
||||
[inner-check (make-inner-check outer-args)]
|
||||
[(inner-args body) (make-main outer-args)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
stx
|
||||
(syntax (lambda inner-args body)))])
|
||||
(add-outer-check
|
||||
(syntax
|
||||
(make-contract
|
||||
(lambda outer-args
|
||||
inner-check
|
||||
inner-lambda))))))))))
|
||||
|
||||
;; set-inferred-name-from : syntax syntax -> syntax
|
||||
(define (set-inferred-name-from with-name to-be-named)
|
||||
(let ([name (syntax-local-infer-name with-name)])
|
||||
(if name
|
||||
(syntax-property to-be-named 'inferred-name name)
|
||||
to-be-named)))
|
||||
|
||||
;; ->/f : syntax -> syntax
|
||||
;; the transformer for the -> macro
|
||||
(define ->/f (make-/f ->/h))
|
||||
|
||||
;; ->*/f : syntax -> syntax
|
||||
;; the transformer for the ->* macro
|
||||
(define ->*/f (make-/f ->*/h))
|
||||
|
||||
;; ->d/f : syntax -> syntax
|
||||
;; the transformer for the ->d macro
|
||||
(define ->d/f (make-/f ->d/h))
|
||||
|
||||
;; ->d*/f : syntax -> syntax
|
||||
;; the transformer for the ->d* macro
|
||||
(define ->d*/f (make-/f ->d*/h))
|
||||
|
||||
;; case->/f : syntax -> syntax
|
||||
;; the transformer for the case-> macro
|
||||
(define (case->/f stx)
|
||||
(syntax-case stx ()
|
||||
[(_ case ...)
|
||||
(let-values ([(add-outer-check make-inner-check make-bodies)
|
||||
(case->/h (syntax->list (syntax (case ...))))])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
||||
(with-syntax ([outer-args outer-args]
|
||||
[(inner-check ...) (make-inner-check outer-args)]
|
||||
[(body ...) (make-bodies outer-args)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
stx
|
||||
(syntax (case-lambda body ...)))])
|
||||
(add-outer-check
|
||||
(syntax
|
||||
(make-contract
|
||||
(lambda outer-args
|
||||
inner-check ...
|
||||
inner-lambda))))))))]))
|
||||
|
||||
;; case->/h : (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
;; like the other /h functions, but composes the wrapper functions
|
||||
;; together and combines the cases of the case-lambda into a single list.
|
||||
(define (case->/h cases)
|
||||
(let loop ([cases cases])
|
||||
(cond
|
||||
[(null? cases) (values (lambda (x) x)
|
||||
(lambda (args) (syntax ()))
|
||||
(lambda (args) (syntax ())))]
|
||||
[else
|
||||
(let ([/h (syntax-case (car cases) (-> ->* ->d ->d*)
|
||||
[(-> . args) ->/h]
|
||||
[(->* . args) ->*/h]
|
||||
[(->d . args) ->d/h]
|
||||
[(->d* . args) ->d*/h])])
|
||||
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))]
|
||||
[(add-outer-check make-inner-check make-body) (/h (car cases))])
|
||||
(values
|
||||
(lambda (x) (add-outer-check (add-outer-checks x)))
|
||||
(lambda (args)
|
||||
(with-syntax ([checks (make-inner-checks args)]
|
||||
[check (make-inner-check args)])
|
||||
(syntax (check . checks))))
|
||||
(lambda (args)
|
||||
(with-syntax ([case (make-body args)]
|
||||
[cases (make-bodies args)])
|
||||
(syntax (case . cases)))))))])))
|
||||
|
||||
(define (all-but-last l)
|
||||
(cond
|
||||
[(null? l) (error 'all-but-last "bad input")]
|
||||
[(null? (cdr l)) null]
|
||||
[else (cons (car l) (all-but-last (cdr l)))]))
|
||||
|
||||
(values ->/f ->*/f ->d/f ->d*/f case->/f)))
|
||||
|
||||
(define-syntax (opt-> stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (reqs ...) (opts ...) res)
|
||||
(syntax (opt->* (reqs ...) (opts ...) (res)))]))
|
||||
|
||||
(define-syntax (opt->* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (reqs ...) (opts ...) (ress ...))
|
||||
(let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))]
|
||||
[req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
|
||||
[opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
|
||||
[cases
|
||||
(reverse
|
||||
(let loop ([opt-vs (reverse opt-vs)])
|
||||
(cond
|
||||
[(null? opt-vs) (list req-vs)]
|
||||
[else (cons (append req-vs (reverse opt-vs))
|
||||
(loop (cdr opt-vs)))])))])
|
||||
(with-syntax ([((double-res-vs ...) ...) (map (lambda (x) res-vs) cases)]
|
||||
[(res-vs ...) res-vs]
|
||||
[(req-vs ...) req-vs]
|
||||
[(opt-vs ...) opt-vs]
|
||||
[((case-doms ...) ...) cases])
|
||||
(syntax
|
||||
(let ([res-vs ress] ...
|
||||
[req-vs reqs] ...
|
||||
[opt-vs opts] ...)
|
||||
(case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))]))
|
||||
|
||||
(define -contract?
|
||||
(let ([contract?
|
||||
(lambda (val)
|
||||
(or (contract? val) ;; refers to struct predicate
|
||||
(flat-named-contract? val)
|
||||
(and (procedure? val)
|
||||
(procedure-arity-includes? val 1))))])
|
||||
contract?))
|
||||
|
||||
(define (check-contract contract val pos neg src-info)
|
||||
(cond
|
||||
[(contract? contract)
|
||||
((contract-f 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->type-name contract)
|
||||
val))]))
|
||||
|
||||
;; predicate->type-name : function -> string
|
||||
;; if the function has a name and the name ends
|
||||
;; with a question mark, turn it into a mzscheme
|
||||
;; style type name
|
||||
(define (predicate->type-name pred)
|
||||
(let* ([name (object-name pred)])
|
||||
(if name
|
||||
(let ([m (regexp-match "(.*)\\?" (symbol->string name))])
|
||||
(if m
|
||||
(format "expected type <~a>, " (cadr m))
|
||||
""))
|
||||
"")))
|
||||
|
||||
(provide union)
|
||||
(define (union . args)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (-contract? x)
|
||||
(error 'union "expected procedures of arity 1, flat-named-contracts, or -> contracts, given: ~e" x)))
|
||||
args)
|
||||
(let-values ([(contracts procs)
|
||||
(let loop ([ctcs null]
|
||||
[procs null]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ctcs procs)]
|
||||
[else (let ([arg (car args)])
|
||||
(if (contract? arg)
|
||||
(loop (cons arg ctcs) procs (cdr args))
|
||||
(loop ctcs (cons arg procs) (cdr args))))]))])
|
||||
(unless (or (null? contracts)
|
||||
(null? (cdr contracts)))
|
||||
(error 'union "expected at most one function contract, given: ~e" args))
|
||||
(make-contract
|
||||
(lambda (val pos neg src-info)
|
||||
(cond
|
||||
[(ormap (lambda (proc)
|
||||
(if (flat-named-contract? proc)
|
||||
((flat-named-contract-predicate proc) val)
|
||||
(proc val)))
|
||||
procs)
|
||||
val]
|
||||
[(null? contracts)
|
||||
(raise-contract-error src-info pos neg "union failed, given: ~e" val)]
|
||||
[(null? (cdr contracts))
|
||||
((contract-f (car contracts)) val pos neg src-info)])))))
|
||||
|
||||
(provide and/f or/f
|
||||
>=/c <=/c </c >/c
|
||||
natural-number?
|
||||
false? any?
|
||||
printable?
|
||||
symbols
|
||||
subclass?/c implementation?/c is-a?/c
|
||||
listof vectorof cons/p list/p
|
||||
mixin-contract make-mixin-contract)
|
||||
|
||||
(define (symbols . ss)
|
||||
(unless ((length ss) . >= . 1)
|
||||
(error 'symbols "expected at least one argument"))
|
||||
(unless (andmap symbol? ss)
|
||||
(error 'symbols "expected symbols as arguments, given: ~a"
|
||||
(apply string-append (map (lambda (x) (format "~e " x)) ss))))
|
||||
(make-flat-named-contract
|
||||
(apply string-append
|
||||
(format "'~a" (car ss))
|
||||
(map (lambda (x) (format ", '~a" x)) (cdr ss)))
|
||||
(lambda (x)
|
||||
(memq x ss))))
|
||||
|
||||
(define (printable? x)
|
||||
(or (symbol? x)
|
||||
(string? x)
|
||||
(boolean? x)
|
||||
(char? x)
|
||||
(null? x)
|
||||
(number? x)
|
||||
(and (pair? x)
|
||||
(printable? (car x))
|
||||
(printable? (cdr x)))
|
||||
(and (vector? x)
|
||||
(andmap printable? (vector->list x)))
|
||||
(and (box? x)
|
||||
(printable? (unbox x)))))
|
||||
|
||||
(define (and/f . fs)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (or (flat-named-contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1)))
|
||||
(error 'and/f "expected procedures of arity 1 or <flat-named-contract>s, given: ~e" x)))
|
||||
fs)
|
||||
(lambda (x)
|
||||
(andmap (lambda (f)
|
||||
(if (flat-named-contract? f)
|
||||
((flat-named-contract-predicate f) x)
|
||||
(f x)))
|
||||
fs)))
|
||||
|
||||
(define (or/f . fs)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (or (flat-named-contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1)))
|
||||
(error 'or/f "expected procedures of arity 1 or <flat-named-contract>s, given: ~e" x)))
|
||||
fs)
|
||||
(lambda (x)
|
||||
(ormap (lambda (f)
|
||||
(if (flat-named-contract? f)
|
||||
((flat-named-contract-predicate f) x)
|
||||
(f x)))
|
||||
fs)))
|
||||
|
||||
(define (>=/c x)
|
||||
(make-flat-named-contract
|
||||
(format "number >= ~a" x)
|
||||
(lambda (y) (and (number? y) (>= y x)))))
|
||||
(define (<=/c x)
|
||||
(make-flat-named-contract
|
||||
(format "number <= ~a" x)
|
||||
(lambda (y) (and (number? y) (<= y x)))))
|
||||
(define (</c x)
|
||||
(make-flat-named-contract
|
||||
(format "number < ~a" x)
|
||||
(lambda (y) (and (number? y) (< y x)))))
|
||||
(define (>/c x)
|
||||
(make-flat-named-contract
|
||||
(format "number > ~a" x)
|
||||
(lambda (y) (and (number? y) (> y x)))))
|
||||
|
||||
(define (natural-number? x)
|
||||
(and (number? x)
|
||||
(integer? x)
|
||||
(x . >= . 0)))
|
||||
|
||||
(define (is-a?/c <%>)
|
||||
(unless (or (interface? <%>)
|
||||
(class? <%>))
|
||||
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
|
||||
(let ([name (object-name <%>)])
|
||||
(make-flat-named-contract
|
||||
(if name
|
||||
(format "instance of ~a" name)
|
||||
"instance of <<unknown>>")
|
||||
(lambda (x) (is-a? x <%>)))))
|
||||
|
||||
(define (subclass?/c %)
|
||||
(unless (class? %)
|
||||
(error 'subclass?/c "expected type <class>, given: ~e" %))
|
||||
(let ([name (object-name %)])
|
||||
(make-flat-named-contract
|
||||
(if name
|
||||
(format "subclass of ~a" name)
|
||||
"subclass of <<unknown>>")
|
||||
(lambda (x) (subclass? x %)))))
|
||||
|
||||
(define (implementation?/c <%>)
|
||||
(unless (interface? <%>)
|
||||
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
|
||||
(let ([name (object-name <%>)])
|
||||
(make-flat-named-contract
|
||||
(if name
|
||||
(format "implementation of ~a" name)
|
||||
"implementation of <<unknown>>")
|
||||
(lambda (x) (implementation? x <%>)))))
|
||||
|
||||
(define (false? x) (not x))
|
||||
(define (any? x) #t)
|
||||
|
||||
(define (listof p)
|
||||
(lambda (v)
|
||||
(and (list? v)
|
||||
(andmap p v))))
|
||||
|
||||
(define (vectorof p)
|
||||
(lambda (v)
|
||||
(and (vector? v)
|
||||
(andmap p (vector->list v)))))
|
||||
|
||||
(define (cons/p hdp tlp)
|
||||
(lambda (x)
|
||||
(and (pair? x)
|
||||
(hdp (car x))
|
||||
(tlp (cdr x)))))
|
||||
|
||||
(define (list/p . args)
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) null?]
|
||||
[else (cons/p (car args) (loop (cdr args)))])))
|
||||
|
||||
(define mixin-contract
|
||||
(class?
|
||||
. ->d .
|
||||
subclass?/c))
|
||||
|
||||
(define (make-mixin-contract . %/<%>s)
|
||||
((and/f class? (apply and/f (map sub/impl?/c %/<%>s)))
|
||||
. ->d .
|
||||
subclass?/c))
|
||||
|
||||
(define (sub/impl?/c %/<%>)
|
||||
(cond
|
||||
[(interface? %/<%>) (implementation?/c %/<%>)]
|
||||
[(class? %/<%>) (subclass?/c %/<%>)]
|
||||
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)])))
|
||||
428
collects/tests/mzscheme/contracts.ss
Normal file
428
collects/tests/mzscheme/contracts.ss
Normal file
|
|
@ -0,0 +1,428 @@
|
|||
(load-relative "loadtest.ss")
|
||||
(require (lib "specs.ss" "framework")
|
||||
(lib "class.ss"))
|
||||
|
||||
(SECTION 'contracts)
|
||||
|
||||
(let ()
|
||||
;; test/spec-passed : symbol sexp -> void
|
||||
;; tests a passing specification
|
||||
(define (test/spec-passed name expression)
|
||||
(test 'passed
|
||||
eval
|
||||
`(begin ,expression 'passed)))
|
||||
|
||||
;; 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)
|
||||
(let ([m (regexp-match ": (.*) failed contract:" x)])
|
||||
(and m (cadr m)))))
|
||||
(test blame
|
||||
failed-contract
|
||||
(eval
|
||||
`(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||
exn-message])
|
||||
,expression
|
||||
'failed/expected-exn-got-normal-termination))))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-flat1
|
||||
'(contract not #f 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-flat2
|
||||
'(contract not #t 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star0a
|
||||
'(contract (->* (integer?) (integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star0b
|
||||
'((contract (->* (integer?) (integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star0c
|
||||
'((contract (->* (integer?) (integer?))
|
||||
(lambda (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star1
|
||||
'(let-values ([(a b) ((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
2)])
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star2
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star3
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values 1 #t))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star4
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values #t 1))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star5
|
||||
'(let-values ([(a b) ((contract (->* (integer?)
|
||||
(listof integer?)
|
||||
(integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
2)])
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star6
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star7
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values 1 #t))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star8
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values #t 1))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star9
|
||||
'((contract (->* (integer?) (listof integer?) (integer?))
|
||||
(lambda (x . y) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 2))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star10
|
||||
'((contract (->* (integer?) (listof integer?) (integer?))
|
||||
(lambda (x . y) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 2 'bad)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d1
|
||||
'(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
1
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-d2
|
||||
'(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d2
|
||||
'((contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
(lambda (x) (+ x 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow1
|
||||
'(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow2
|
||||
'(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow3
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow4
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)
|
||||
"pos")
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-any1
|
||||
'(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-any2
|
||||
'(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-any3
|
||||
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)
|
||||
"neg")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d1
|
||||
'((contract (->d* (integer?) (lambda (arg) (lambda (res) (= arg res))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d2
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d3
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 1 2))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d4
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 2 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d5
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg) (lambda (res) (= arg res))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d6
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d7
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 1 2))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d8
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 2 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->1
|
||||
'(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->2
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
1 2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->3
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->4
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
'a 2)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->5
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
2 'a)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->6
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
#t)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d-protect-shared-state
|
||||
'(let ([x 1])
|
||||
((contract ((->d (lambda () (let ([pre-x x]) (lambda (res) (= x pre-x)))))
|
||||
. -> .
|
||||
(lambda (x) #t))
|
||||
(lambda (thnk) (thnk))
|
||||
'pos
|
||||
'neg)
|
||||
(lambda () (set! x 2))))
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'combo1
|
||||
'(let ([cf (contract (case->
|
||||
((class? . ->d . (lambda (%) (lambda (x) #f))) . -> . void?)
|
||||
((class? . ->d . (lambda (%) (lambda (x) #f))) boolean? . -> . void?))
|
||||
(letrec ([c% (class object% (super-instantiate ()))]
|
||||
[f
|
||||
(case-lambda
|
||||
[(class-maker) (f class-maker #t)]
|
||||
[(class-maker b)
|
||||
(class-maker c%)
|
||||
(void)])])
|
||||
f)
|
||||
'pos
|
||||
'neg)])
|
||||
(cf (lambda (x%) 'going-to-be-bad)))
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'union1
|
||||
'(contract (union false?) #t 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'union2
|
||||
'(contract (union false?) #f 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'union3
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
|
||||
|
||||
(test/spec-failed
|
||||
'union4
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'union5
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'union6
|
||||
'(contract (union false? (-> integer? integer?)) #f 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'union7
|
||||
'((contract (union false? (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
|
||||
|
||||
)
|
||||
|
||||
(report-errs)
|
||||
Loading…
Reference in New Issue
Block a user