..
original commit: 7afd47087c61a4940d90d29bc1474250c0ed54ce
This commit is contained in:
Robby Findler
parent
ec623c1ed5
commit
c21b3852be
|
|
@ -5,8 +5,7 @@
|
|||
->d
|
||||
->*
|
||||
->d*
|
||||
;case->
|
||||
)
|
||||
case->)
|
||||
(require-for-syntax mzscheme
|
||||
(lib "list.ss")
|
||||
(lib "stx.ss" "syntax"))
|
||||
|
|
@ -19,7 +18,6 @@
|
|||
(apply format fmt args))))
|
||||
|
||||
(define-struct contract (f))
|
||||
(define-struct (simple-arrow-contract contract) ())
|
||||
|
||||
(define-syntax -contract
|
||||
(lambda (stx)
|
||||
|
|
@ -67,9 +65,20 @@
|
|||
src-info))
|
||||
(check-contract a-contract name pos-blame neg-blame src-info-e)))])))
|
||||
|
||||
(define-syntaxes (-> ->* ->d ->d*)
|
||||
(define-syntaxes (-> ->* ->d ->d* case->)
|
||||
(let ()
|
||||
(define (->/f stx)
|
||||
;; 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 ...)
|
||||
|
|
@ -78,16 +87,28 @@
|
|||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '-> "expected contract as argument, got ~e" ct-x)) ...
|
||||
(unless (contract-p? rng-x)
|
||||
(error '-> "expected contract as argument, got: ~e" rng-x))
|
||||
(->* (dom-x ...) (rng-x))))))]))
|
||||
(let ([->add-outer-check
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '-> "expected contract as argument, got ~e" dom-x)) ...
|
||||
(unless (contract-p? rng-x)
|
||||
(error '-> "expected contract as argument, got: ~e" rng-x))
|
||||
body))))]
|
||||
[->body (syntax (->* (dom-x ...) (rng-x)))])
|
||||
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
|
||||
(values
|
||||
(lambda (x) (->add-outer-check (->*add-outer-check x)))
|
||||
(lambda (args)
|
||||
(->*make-inner-check args))
|
||||
(lambda (args)
|
||||
(->*make-body args)))))))]))
|
||||
|
||||
(define (->*/f 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 ...)))]
|
||||
|
|
@ -95,77 +116,93 @@
|
|||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng] ...)
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->* "expected contract as argument, got ~e" ct-x)) ...
|
||||
(unless (contract-p? rng-x)
|
||||
(error '->* "expected contract as argument, got: ~e" rng-x)) ...
|
||||
(make-simple-arrow-contract
|
||||
(lambda (val pos-blame neg-blame src-info)
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(lambda (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)
|
||||
...)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
val)))))))]
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng] ...)
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->* "expected contract as argument, got ~e" dom-x)) ...
|
||||
(unless (contract-p? rng-x)
|
||||
(error '->* "expected contract as argument, got: ~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-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~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 ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-x rng] ...)
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->* "expected contract for domain position, got ~e" dom-x)) ...
|
||||
(unless (contract-p? dom-rest-x)
|
||||
(error '->* "expected contract for rest position, got ~e" dom-rest-x))
|
||||
(unless (contract-p? rng-x)
|
||||
(error '->* "expected contract for range position, got: ~e" rng-x)) ...
|
||||
(make-simple-arrow-contract
|
||||
(lambda (val pos-blame neg-blame src-info)
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(lambda (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)
|
||||
...)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
val)))))))]))
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-x rng] ...)
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->* "expected contract for domain position, got ~e" dom-x)) ...
|
||||
(unless (contract-p? dom-rest-x)
|
||||
(error '->* "expected contract for rest position, got ~e" dom-rest-x))
|
||||
(unless (contract-p? rng-x)
|
||||
(error '->* "expected contract for range position, got: ~e" rng-x)) ...
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (procedure? val)
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~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)
|
||||
...))))))))]))
|
||||
|
||||
(define (->d/f stx)
|
||||
;; ->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 ...)
|
||||
|
|
@ -174,137 +211,252 @@
|
|||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->d "expected contract as argument, got ~e" ct-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, got: ~e"
|
||||
arity
|
||||
rng-x))
|
||||
(make-simple-arrow-contract
|
||||
(lambda (val pos-blame neg-blame src-info)
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(lambda (arg-x ...)
|
||||
(let ([rng-contract (rng-x arg-x ...)])
|
||||
(unless (contract-p? rng-contract)
|
||||
(error '->d "expected range portion to return a contract, got: ~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)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
val))))))))]))
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-x rng])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->d "expected contract as argument, got ~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, got: ~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-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~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-p? rng-contract)
|
||||
(error '->d "expected range portion to return a contract, got: ~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)))))))))]))
|
||||
|
||||
(define (->*d/f stx)
|
||||
;; ->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 ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-mk-x rng-mk])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->*d "expected contract as argument, got ~e" ct-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 ~ arguments, got: ~e"
|
||||
arity rng-mk-x))
|
||||
(make-simple-arrow-contract
|
||||
(lambda (val pos-blame neg-blame src-info)
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(lambda (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, got ~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))
|
||||
range-contracts
|
||||
results)))))))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
val)))))))]
|
||||
[(_ (dom ...) rest (rng ...))
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[rng-mk-x rng-mk])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->*d "expected contract as argument, got ~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 ~ arguments, got: ~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-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~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, got ~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 ...)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-x rng] ...)
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->* "expected contract for domain position, got ~e" dom-x)) ...
|
||||
(unless (contract-p? dom-rest-x)
|
||||
(error '->* "expected contract for rest position, got ~e" dom-rest-x))
|
||||
(unless (contract-p? rng-x)
|
||||
(error '->* "expected contract for range position, got: ~e" rng-x)) ...
|
||||
(make-simple-arrow-contract
|
||||
(lambda (val pos-blame neg-blame src-info)
|
||||
(if (and (procedure? val)
|
||||
(procedure-arity-includes? val arity))
|
||||
(lambda (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)
|
||||
...)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
val)))))))]))
|
||||
(values
|
||||
(lambda (body)
|
||||
(with-syntax ([body body])
|
||||
(syntax
|
||||
(let ([dom-x dom] ...
|
||||
[dom-rest-x rest]
|
||||
[rng-mk-x rng-mk])
|
||||
(unless (contract-p? dom-x)
|
||||
(error '->*d "expected contract as argument, got ~e" dom-x)) ...
|
||||
(unless (contract-p? dom-rest-x)
|
||||
(error '->*d "expected contract for rest argument, got ~e" dom-rest-x))
|
||||
(unless (procedure? rng-mk-x)
|
||||
(error '->*d "expected range position to be a procedure that accepts ~a arguments, got: ~e"
|
||||
arity rng-mk-x))
|
||||
body))))
|
||||
(lambda (stx)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info) stx])
|
||||
(syntax
|
||||
(unless (procedure? val)
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~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, got ~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)])
|
||||
(add-outer-check
|
||||
(syntax
|
||||
(make-contract
|
||||
(lambda outer-args
|
||||
inner-check
|
||||
(lambda inner-args body))))))))))
|
||||
|
||||
;; ->/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)])
|
||||
(add-outer-check
|
||||
(syntax
|
||||
(make-contract
|
||||
(lambda outer-args
|
||||
inner-check ...
|
||||
(case-lambda body ...))))))))]))
|
||||
|
||||
;; 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)))
|
||||
(values ->/f ->*/f ->d/f ->d*/f case->/f)))
|
||||
|
||||
(define (contract-p? val)
|
||||
(or (contract? val)
|
||||
|
|
@ -325,120 +477,7 @@
|
|||
contract
|
||||
val))]))
|
||||
|
||||
#|
|
||||
(define-syntax contract/internal
|
||||
(lambda (stx)
|
||||
(define (all-but-last lst)
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[(null? (cdr lst)) null]
|
||||
[else (cons (car lst) (all-but-last (cdr lst)))]))
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract name pos-blame neg-blame src-info)
|
||||
(and (identifier? (syntax name))
|
||||
(identifier? (syntax neg-blame))
|
||||
(identifier? (syntax pos-blame)))
|
||||
|
||||
(let ()
|
||||
;; build-single-case : syntax[(listof contracts)] -> syntax[(list syntax[args] syntax)]
|
||||
;; builds the arguments and result for a single case of a case-lambda or
|
||||
;; just a single lambda expression.
|
||||
(define (build-single-case funs)
|
||||
(with-syntax ([(dom ...) (all-but-last (syntax->list funs))]
|
||||
[rng (car (last-pair (syntax->list funs)))])
|
||||
(with-syntax ([(ins ...) (generate-temporaries (syntax (dom ...)))])
|
||||
(syntax
|
||||
((ins ...)
|
||||
(let ([out (name
|
||||
(contract/internal dom ins neg-blame pos-blame src-info)
|
||||
...)])
|
||||
(contract/internal rng out pos-blame neg-blame src-info)))))))
|
||||
|
||||
(syntax-case (syntax a-contract) (-> ->d ->* case->)
|
||||
[(->)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"unknown contract specification"
|
||||
stx
|
||||
(syntax type))]
|
||||
[(-> fun funs ...)
|
||||
(with-syntax ([(args body) (build-single-case (syntax (fun funs ...)))]
|
||||
[arity (- (length (syntax->list (syntax (fun funs ...))))
|
||||
1)])
|
||||
(syntax
|
||||
(if (and (procedure? name)
|
||||
(procedure-arity-includes? name arity))
|
||||
(lambda args body)
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
name))))]
|
||||
[(->* (dom ...) (rngs ...))
|
||||
(with-syntax ([arity (length (syntax->list (syntax (dom ...))))]
|
||||
[(dom-vars ...) (generate-temporaries (syntax (dom ...)))]
|
||||
[(rng-vars ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
(syntax
|
||||
(if (and (procedure? name)
|
||||
(procedure-arity-includes? name arity))
|
||||
(lambda (dom-vars ...)
|
||||
(let-values ([(rng-vars ...)
|
||||
(name
|
||||
(contract/internal dom dom-vars neg-blame pos-blame src-info)
|
||||
...)])
|
||||
(values (contract/internal rngs rng-vars pos-blame neg-blame src-info)
|
||||
...)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"3.expected a procedure that accepts ~a arguments, got: ~e"
|
||||
arity
|
||||
name))))]
|
||||
[(case-> (-> funs funss ...) ...)
|
||||
(with-syntax ([((args bodies) ...) (map build-single-case
|
||||
(syntax->list (syntax ((funs funss ...) ...))))]
|
||||
[(arities ...) (map (lambda (x) (- (length (syntax->list x)) 1))
|
||||
(syntax->list (syntax ((funs funss ...) ...))))])
|
||||
(syntax
|
||||
(if (and (procedure? name)
|
||||
(procedure-arity-includes? name arities) ...)
|
||||
(case-lambda [args bodies] ...)
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"1.expected a procedure that accepts these arities: ~a, got: ~e"
|
||||
(list arities ...)
|
||||
name))))]
|
||||
[(->d fun funs ...)
|
||||
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (fun funs ...))))]
|
||||
[rng (car (last-pair (syntax->list (syntax (fun funs ...)))))])
|
||||
(with-syntax ([(ins ...) (generate-temporaries (syntax (dom ...)))])
|
||||
(syntax
|
||||
(if (procedure? name)
|
||||
(lambda (ins ...)
|
||||
(let ([->d-rng-contract (rng ins ...)]
|
||||
[out (name (contract/internal dom ins
|
||||
neg-blame pos-blame src-info)
|
||||
...)])
|
||||
(contract/internal ->d-rng-contract out pos-blame neg-blame src-info)))
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"expected a procedure, got: ~e"
|
||||
name)))))]
|
||||
[_
|
||||
(syntax
|
||||
(if (a-contract name)
|
||||
name
|
||||
(raise-error
|
||||
src-info
|
||||
pos-blame
|
||||
"predicate ~s failed for: ~e"
|
||||
'a-contract
|
||||
name)))]))])))
|
||||
|
||||
|#
|
||||
|
||||
(provide and/f or/f
|
||||
>=/c <=/c </c >/c
|
||||
false? any?
|
||||
|
|
@ -494,4 +533,9 @@
|
|||
(lambda (v)
|
||||
(and (list? v)
|
||||
(andmap p v))))
|
||||
|
||||
(define (vectorof p)
|
||||
(lambda (v)
|
||||
(and (vector? v)
|
||||
(andmap p (vector->list v)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -37,23 +37,254 @@
|
|||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-flat3
|
||||
'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-flat4
|
||||
'contract-arrow2
|
||||
'(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-ho1
|
||||
'contract-arrow3
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-ho2
|
||||
'contract-arrow4
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)
|
||||
"pos")
|
||||
|
||||
|
||||
|
||||
(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
|
||||
|
|
@ -118,30 +349,6 @@
|
|||
#t)
|
||||
"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-failed
|
||||
'contract-d-protect-shared-state
|
||||
'(let ([x 1])
|
||||
|
|
@ -153,42 +360,6 @@
|
|||
'neg)
|
||||
(lambda () (set! x 2))))
|
||||
"neg")
|
||||
|
||||
(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-failed
|
||||
'combo1
|
||||
|
|
@ -208,7 +379,6 @@
|
|||
(cf (lambda (x%) 'going-to-be-bad)))
|
||||
"neg")
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user