..
original commit: 4d74daf4d9752872e2edd02ab3ac60e1de96649d
This commit is contained in:
Robby Findler
parent
0eb3c57f1b
commit
e0b93e85f5
|
|
@ -425,6 +425,51 @@
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
||||||
|
;; contract = (make-contract (alpha
|
||||||
|
;; sym
|
||||||
|
;; sym
|
||||||
|
;; (union syntax #f)
|
||||||
|
;; ->
|
||||||
|
;; alpha)
|
||||||
|
;; (contract alpha sym src-info -> alpha)
|
||||||
|
;; (??? -> ???)
|
||||||
|
;; generic contract container;
|
||||||
|
;; the first argument to wrap is the value to test the contract.
|
||||||
|
;; the second to wrap is a symbol representing the name of the positive blame
|
||||||
|
;; the third to wrap is the symbol representing the name of the negative blame
|
||||||
|
;; the fourth argument to wrap is the src-info.
|
||||||
|
;;
|
||||||
|
;; impl-builder and impl-info are two pieces used to build
|
||||||
|
;; implication contracts.
|
||||||
|
(define-struct contract (wrap impl-builder impl-info))
|
||||||
|
|
||||||
|
;; 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 -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-syntax -contract
|
(define-syntax -contract
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
|
|
@ -468,7 +513,7 @@
|
||||||
(define (check-contract contract val pos neg src-info)
|
(define (check-contract contract val pos neg src-info)
|
||||||
(cond
|
(cond
|
||||||
[(contract? contract)
|
[(contract? contract)
|
||||||
((contract-f contract) val pos neg src-info)]
|
((contract-wrap contract) val pos neg src-info)]
|
||||||
[(flat-named-contract? contract)
|
[(flat-named-contract? contract)
|
||||||
(if ((flat-named-contract-predicate contract) val)
|
(if ((flat-named-contract-predicate contract) val)
|
||||||
val
|
val
|
||||||
|
|
@ -492,17 +537,17 @@
|
||||||
|
|
||||||
(define-syntax (contract-=> stx)
|
(define-syntax (contract-=> stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ c1-e c2-e val-e tbb-e)
|
[(_ ant-e conq-e val-e tbb-e)
|
||||||
(with-syntax ([src-loc (datum->syntax-object stx 'here)])
|
(with-syntax ([src-loc (datum->syntax-object stx 'here)])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(contract-=> c1-e c2-e val-e tbb-e (quote-syntax src-loc))))]
|
(contract-=> ant-e conq-e val-e tbb-e (quote-syntax src-loc))))]
|
||||||
[(_ c1-e c2-e val-e tbb-e src-loc-e)
|
[(_ ant-e conq-e val-e tbb-e src-info-e)
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(let ([c1 c1-e]
|
(let ([c1 ant-e]
|
||||||
[c2 c2-e]
|
[c2 conq-e]
|
||||||
[val val-e]
|
[val val-e]
|
||||||
[tbb tbb-e]
|
[tbb tbb-e]
|
||||||
[src-loc src-loc-e])
|
[src-info src-info-e])
|
||||||
(unless (-contract? c1)
|
(unless (-contract? c1)
|
||||||
(error 'contract-=> "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e"
|
(error 'contract-=> "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e"
|
||||||
c1
|
c1
|
||||||
|
|
@ -534,38 +579,43 @@
|
||||||
(check-implication c1 c2 val tbb src-info)))]))
|
(check-implication c1 c2 val tbb src-info)))]))
|
||||||
|
|
||||||
;; check-implication : contract contract any symbol (union syntax #f) -> any
|
;; check-implication : contract contract any symbol (union syntax #f) -> any
|
||||||
(define (check-implication c1 c2 val tbb src-info)
|
(define (check-implication antecedent consequent val tbb src-info)
|
||||||
(cond
|
(cond
|
||||||
[(and (contract? c1) (contract? c2))
|
[(and (contract? antecedent) (contract? consequent))
|
||||||
(error 'check-implication "not implemented")]
|
((contract-impl-builder consequent)
|
||||||
[(or (contract? c1) (contract? c2))
|
antecedent
|
||||||
(raise-contract-implication-error c1 c2 val tbb src-info)]
|
consequent
|
||||||
|
val
|
||||||
|
tbb
|
||||||
|
src-info)]
|
||||||
|
[(or (contract? antecedent) (contract? consequent))
|
||||||
|
(raise-contract-implication-error antecedent consequent val tbb src-info)]
|
||||||
[else
|
[else
|
||||||
(let ([test-contract
|
(let ([test-contract
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(cond
|
(cond
|
||||||
[(flat-named-contract? c) ((flat-named-contract-predicate c) val)]
|
[(flat-named-contract? c) ((flat-named-contract-predicate c) val)]
|
||||||
[else (c val)]))])
|
[else (c val)]))])
|
||||||
(if (or (not (test-contract c1))
|
(if (or (not (test-contract antecedent))
|
||||||
(test-contract c2))
|
(test-contract consequent))
|
||||||
val
|
val
|
||||||
(raise-contract-implication-error c1 c2 val tbb src-info)))]))
|
(raise-contract-implication-error antecedent consequent val tbb src-info)))]))
|
||||||
|
|
||||||
;; raise-contract-implication-error : contract contract any symbol (union syntax #f) -> alpha
|
;; raise-contract-implication-error : contract contract any symbol (union syntax #f) -> alpha
|
||||||
;; escapes
|
;; escapes
|
||||||
(define (raise-contract-implication-error c1 c2 val tbb src-info)
|
(define (raise-contract-implication-error antecedent consequent val tbb src-info)
|
||||||
(let ([blame-src (src-info-as-string src-info)])
|
(let ([blame-src (src-info-as-string src-info)])
|
||||||
(raise
|
(raise
|
||||||
(make-exn
|
(make-exn
|
||||||
(string->immutable-string
|
(string->immutable-string
|
||||||
(format "~a~a does not imply ~a for ~e"
|
(format "~a~a: ~a does not imply ~a for ~e"
|
||||||
blame-src
|
blame-src
|
||||||
(contract->type-name c1)
|
tbb
|
||||||
(contract->type-name c2)
|
(contract->type-name antecedent)
|
||||||
|
(contract->type-name consequent)
|
||||||
val))
|
val))
|
||||||
(current-continuation-marks)))))
|
(current-continuation-marks)))))
|
||||||
|
|
||||||
|
|
||||||
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
|
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
|
||||||
;; doesn't return
|
;; doesn't return
|
||||||
(define (raise-contract-error src-info to-blame other-party fmt . args)
|
(define (raise-contract-error src-info to-blame other-party fmt . args)
|
||||||
|
|
@ -595,49 +645,6 @@
|
||||||
""))
|
""))
|
||||||
""))
|
""))
|
||||||
|
|
||||||
;; contract = (make-contract (alpha
|
|
||||||
;; sym
|
|
||||||
;; sym
|
|
||||||
;; (union syntax #f)
|
|
||||||
;; ->
|
|
||||||
;; alpha))
|
|
||||||
;; generic contract container;
|
|
||||||
;; the first argument to f is the value to test the contract.
|
|
||||||
;; the second to f is a symbol representing the name of the positive blame
|
|
||||||
;; the third to f is the symbol representing the name of the negative blame
|
|
||||||
;; the fourth argument is the src-info.
|
|
||||||
(define-struct contract (f))
|
|
||||||
|
|
||||||
(define-struct (->*contract contract) (doms rngs implication-maker))
|
|
||||||
|
|
||||||
;; 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 -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?))
|
|
||||||
|
|
||||||
;; predicate->expected-msg : function -> string
|
;; predicate->expected-msg : function -> string
|
||||||
;; if the function has a name and the name ends
|
;; if the function has a name and the name ends
|
||||||
;; with a question mark, turn it into a mzscheme
|
;; with a question mark, turn it into a mzscheme
|
||||||
|
|
@ -711,7 +718,7 @@
|
||||||
(define (case->/proc stx)
|
(define (case->/proc stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ case ...)
|
[(_ case ...)
|
||||||
(let-values ([(add-outer-check make-inner-check make-bodies)
|
(let-values ([(add-outer-check make-inner-check make-bodies _1 _2)
|
||||||
(case->/h stx (syntax->list (syntax (case ...))))])
|
(case->/h stx (syntax->list (syntax (case ...))))])
|
||||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
||||||
(with-syntax ([outer-args outer-args]
|
(with-syntax ([outer-args outer-args]
|
||||||
|
|
@ -726,7 +733,9 @@
|
||||||
(make-contract
|
(make-contract
|
||||||
(lambda outer-args
|
(lambda outer-args
|
||||||
inner-check ...
|
inner-check ...
|
||||||
inner-lambda))))))))]))
|
inner-lambda)
|
||||||
|
(lambda x (error 'impl-contract "unimplemented"))
|
||||||
|
(lambda x (error 'impl-contract "unimplemented")) )))))))]))
|
||||||
|
|
||||||
(define (class-contract/proc stx)
|
(define (class-contract/proc stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
@ -735,7 +744,8 @@
|
||||||
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
|
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
|
||||||
(map (lambda (meth-contract-stx)
|
(map (lambda (meth-contract-stx)
|
||||||
(let ([/h (select/h meth-contract-stx 'class-contract stx)])
|
(let ([/h (select/h meth-contract-stx 'class-contract stx)])
|
||||||
(let-values ([(make-outer-check xxx build-pieces) (/h meth-contract-stx)])
|
(let-values ([(make-outer-check xxx build-pieces impl-builder impl-info)
|
||||||
|
(/h meth-contract-stx)])
|
||||||
(list make-outer-check xxx build-pieces))))
|
(list make-outer-check xxx build-pieces))))
|
||||||
(syntax->list (syntax (meth-contract ...))))])
|
(syntax->list (syntax (meth-contract ...))))])
|
||||||
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
|
(let* ([outer-args (syntax (val pos-blame neg-blame src-info))]
|
||||||
|
|
@ -767,7 +777,9 @@
|
||||||
(class val
|
(class val
|
||||||
(rename [super-meth-name meth-name] ...)
|
(rename [super-meth-name meth-name] ...)
|
||||||
method ...
|
method ...
|
||||||
(super-instantiate ())))))
|
(super-instantiate ())))
|
||||||
|
(lambda x (error 'impl-contract "unimplemented"))
|
||||||
|
(lambda x (error 'impl-contract "unimplemented"))))
|
||||||
make-outer-checks))))]
|
make-outer-checks))))]
|
||||||
[(_ (meth-name meth-contract) ...)
|
[(_ (meth-name meth-contract) ...)
|
||||||
(for-each (lambda (name)
|
(for-each (lambda (name)
|
||||||
|
|
@ -857,7 +869,12 @@
|
||||||
(error '-> "expected contract as argument, given: ~e" rng-x))
|
(error '-> "expected contract as argument, given: ~e" rng-x))
|
||||||
body))))]
|
body))))]
|
||||||
[->body (syntax (->* (dom-x ...) (rng-x)))])
|
[->body (syntax (->* (dom-x ...) (rng-x)))])
|
||||||
(let-values ([(->*add-outer-check ->*make-inner-check ->*make-body) (->*/h ->body)])
|
(let-values ([(->*add-outer-check
|
||||||
|
->*make-inner-check
|
||||||
|
->*make-body
|
||||||
|
impl-builder
|
||||||
|
impl-info)
|
||||||
|
(->*/h ->body)])
|
||||||
(values
|
(values
|
||||||
(lambda (body) (->add-outer-check (->*add-outer-check body)))
|
(lambda (body) (->add-outer-check (->*add-outer-check body)))
|
||||||
(lambda (stx) (->*make-inner-check stx))
|
(lambda (stx) (->*make-inner-check stx))
|
||||||
|
|
@ -870,15 +887,21 @@
|
||||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||||
...)))))
|
...)))))
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(->*make-body stx)))))))))]))
|
(->*make-body stx)))
|
||||||
|
impl-builder
|
||||||
|
impl-info))))))]))
|
||||||
|
|
||||||
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->*/h stx)
|
(define (->*/h stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (dom ...) (rng ...))
|
[(_ (dom ...) (rng ...))
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
|
||||||
|
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
|
||||||
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
[(rng-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
|
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
|
||||||
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
[(res-x ...) (generate-temporaries (syntax (rng ...)))]
|
||||||
[arity (length (syntax->list (syntax (dom ...))))])
|
[arity (length (syntax->list (syntax (dom ...))))])
|
||||||
(values
|
(values
|
||||||
|
|
@ -918,7 +941,21 @@
|
||||||
pos-blame
|
pos-blame
|
||||||
neg-blame
|
neg-blame
|
||||||
src-info)
|
src-info)
|
||||||
...))))))))]
|
...))))))
|
||||||
|
(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)))))
|
||||||
|
(syntax
|
||||||
|
(lambda (len)
|
||||||
|
(cond
|
||||||
|
[(= len dom-length) (vector dom-x ...)]
|
||||||
|
[else #f])))))]
|
||||||
[(_ (dom ...) rest (rng ...))
|
[(_ (dom ...) rest (rng ...))
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
|
@ -966,7 +1003,9 @@
|
||||||
pos-blame
|
pos-blame
|
||||||
neg-blame
|
neg-blame
|
||||||
src-info)
|
src-info)
|
||||||
...))))))))]))
|
...))))))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))))]))
|
||||||
|
|
||||||
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->d/h stx)
|
(define (->d/h stx)
|
||||||
|
|
@ -1017,7 +1056,9 @@
|
||||||
(val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
|
(val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
|
||||||
pos-blame
|
pos-blame
|
||||||
neg-blame
|
neg-blame
|
||||||
src-info)))))))))]))
|
src-info))))))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented"))))))]))
|
||||||
|
|
||||||
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
(define (->d*/h stx)
|
(define (->d*/h stx)
|
||||||
|
|
@ -1079,7 +1120,9 @@
|
||||||
neg-blame
|
neg-blame
|
||||||
src-info))
|
src-info))
|
||||||
rng-contracts
|
rng-contracts
|
||||||
results))))))))))))]
|
results))))))))))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))))]
|
||||||
[(_ (dom ...) rest rng-mk)
|
[(_ (dom ...) rest rng-mk)
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||||
|
|
@ -1140,30 +1183,35 @@
|
||||||
neg-blame
|
neg-blame
|
||||||
src-info ))
|
src-info ))
|
||||||
rng-contracts
|
rng-contracts
|
||||||
results))))))))))))]))
|
results))))))))))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))))]))
|
||||||
|
|
||||||
;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
|
||||||
;; syntax
|
;; syntax
|
||||||
;; -> (syntax -> syntax)
|
;; -> (syntax -> syntax)
|
||||||
(define (make-/proc /h stx)
|
(define (make-/proc /h stx)
|
||||||
(let-values ([(add-outer-check make-inner-check make-main) (/h stx)])
|
(let-values ([(add-outer-check make-inner-check make-main impl-first impl-second) (/h stx)])
|
||||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
|
||||||
(with-syntax ([outer-args outer-args]
|
(with-syntax ([outer-args outer-args]
|
||||||
[inner-check (make-inner-check outer-args)]
|
[inner-check (make-inner-check outer-args)]
|
||||||
[(inner-args body) (make-main outer-args)])
|
[(inner-args body) (make-main outer-args)]
|
||||||
|
[impl-first impl-first]
|
||||||
|
[impl-second impl-second])
|
||||||
(with-syntax ([inner-lambda
|
(with-syntax ([inner-lambda
|
||||||
(set-inferred-name-from
|
(set-inferred-name-from
|
||||||
stx
|
stx
|
||||||
(syntax/loc stx (lambda inner-args body)))])
|
(syntax/loc stx (lambda inner-args body)))])
|
||||||
(add-outer-check
|
(add-outer-check
|
||||||
|
|
||||||
(set-inferred-name-from
|
(set-inferred-name-from
|
||||||
stx
|
stx
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(make-contract
|
(make-contract
|
||||||
(lambda outer-args
|
(lambda outer-args
|
||||||
inner-check
|
inner-check
|
||||||
inner-lambda))))))))))
|
inner-lambda)
|
||||||
|
impl-first
|
||||||
|
impl-second)))))))))
|
||||||
|
|
||||||
;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||||
;; like the other /h functions, but composes the wrapper functions
|
;; like the other /h functions, but composes the wrapper functions
|
||||||
|
|
@ -1173,11 +1221,13 @@
|
||||||
(cond
|
(cond
|
||||||
[(null? cases) (values (lambda (x) x)
|
[(null? cases) (values (lambda (x) x)
|
||||||
(lambda (args) (syntax ()))
|
(lambda (args) (syntax ()))
|
||||||
(lambda (args) (syntax ())))]
|
(lambda (args) (syntax ()))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented"))))]
|
||||||
[else
|
[else
|
||||||
(let ([/h (select/h (car cases) 'case-> orig-stx)])
|
(let ([/h (select/h (car cases) 'case-> orig-stx)])
|
||||||
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))]
|
(let-values ([(add-outer-checks make-inner-checks make-bodies _a _b) (loop (cdr cases))]
|
||||||
[(add-outer-check make-inner-check make-body) (/h (car cases))])
|
[(add-outer-check make-inner-check make-body _1 _2) (/h (car cases))])
|
||||||
(values
|
(values
|
||||||
(lambda (x) (add-outer-check (add-outer-checks x)))
|
(lambda (x) (add-outer-check (add-outer-checks x)))
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
|
|
@ -1187,7 +1237,9 @@
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(with-syntax ([case (make-body args)]
|
(with-syntax ([case (make-body args)]
|
||||||
[cases (make-bodies args)])
|
[cases (make-bodies args)])
|
||||||
(syntax (case . cases)))))))])))
|
(syntax (case . cases))))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented")))
|
||||||
|
(syntax (lambda x (error 'impl-contract "unimplemented"))))))])))
|
||||||
|
|
||||||
;; select/h : syntax -> /h-function
|
;; select/h : syntax -> /h-function
|
||||||
(define (select/h stx err-name ctxt-stx)
|
(define (select/h stx err-name ctxt-stx)
|
||||||
|
|
@ -1216,7 +1268,19 @@
|
||||||
(cond
|
(cond
|
||||||
[(null? l) (error 'all-but-last "bad input")]
|
[(null? l) (error 'all-but-last "bad input")]
|
||||||
[(null? (cdr l)) null]
|
[(null? (cdr l)) null]
|
||||||
[else (cons (car l) (all-but-last (cdr l)))])))
|
[else (cons (car l) (all-but-last (cdr l)))]))
|
||||||
|
|
||||||
|
;; generate-indicies : syntax[list] -> (cons number (listof number))
|
||||||
|
;; given a syntax list of length `n', returns a list containing
|
||||||
|
;; the number n followed by th numbers from 0 to n-1
|
||||||
|
(define (generate-indicies stx)
|
||||||
|
(let ([n (length (syntax->list stx))])
|
||||||
|
(cons n
|
||||||
|
(let loop ([i n])
|
||||||
|
(cond
|
||||||
|
[(zero? i) null]
|
||||||
|
[else (cons (- n i)
|
||||||
|
(loop (- i 1)))]))))))
|
||||||
|
|
||||||
(define-syntax (opt-> stx)
|
(define-syntax (opt-> stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
@ -1307,7 +1371,9 @@
|
||||||
[(null? contracts)
|
[(null? contracts)
|
||||||
(raise-contract-error src-info pos neg "union failed, given: ~e" val)]
|
(raise-contract-error src-info pos neg "union failed, given: ~e" val)]
|
||||||
[(null? (cdr contracts))
|
[(null? (cdr contracts))
|
||||||
((contract-f (car contracts)) val pos neg src-info)])))])))
|
((contract-wrap (car contracts)) val pos neg src-info)]))
|
||||||
|
(lambda x (error 'impl-contract "unimplemented"))
|
||||||
|
(lambda x (error 'impl-contract "unimplemented")))])))
|
||||||
|
|
||||||
(provide and/f or/f
|
(provide and/f or/f
|
||||||
>=/c <=/c </c >/c
|
>=/c <=/c </c >/c
|
||||||
|
|
|
||||||
|
|
@ -13,13 +13,20 @@
|
||||||
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
|
(let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
|
||||||
(list expression '(void))))
|
(list expression '(void))))
|
||||||
|
|
||||||
|
(define (test/spec-passed/result name expression result)
|
||||||
|
(test result
|
||||||
|
eval
|
||||||
|
expression))
|
||||||
|
|
||||||
;; test/spec-failed : symbol sexp string -> void
|
;; test/spec-failed : symbol sexp string -> void
|
||||||
;; tests a failing specification with blame assigned to `blame'
|
;; tests a failing specification with blame assigned to `blame'
|
||||||
(define (test/spec-failed name expression blame)
|
(define (test/spec-failed name expression blame)
|
||||||
(define (failed-contract x)
|
(define (failed-contract x)
|
||||||
(and (string? x)
|
(and (string? x)
|
||||||
(let ([m (regexp-match ": ([^ ]*) broke" x)])
|
(cond
|
||||||
(and m (cadr m)))))
|
[(regexp-match ": ([^ ]*) broke" x) => cadr]
|
||||||
|
[(regexp-match "([^ ]+): .* does not imply" x) => cadr]
|
||||||
|
[else #f])))
|
||||||
(test blame
|
(test blame
|
||||||
failed-contract
|
failed-contract
|
||||||
(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||||
|
|
@ -540,6 +547,21 @@
|
||||||
(define-struct s (a))))
|
(define-struct s (a))))
|
||||||
(eval '(require contract-test-suite6))
|
(eval '(require contract-test-suite6))
|
||||||
(eval '(define-struct (t s) ()))))
|
(eval '(define-struct (t s) ()))))
|
||||||
|
|
||||||
|
|
||||||
|
(test/spec-passed/result
|
||||||
|
'contract-=>1
|
||||||
|
'(contract-=> (>=/c 5) (>=/c 10) 1 'badguy)
|
||||||
|
1)
|
||||||
|
(test/spec-passed/result
|
||||||
|
'contract-=>2
|
||||||
|
'(contract-=> (>=/c 5) (>=/c 10) 12 'badguy)
|
||||||
|
12)
|
||||||
|
(test/spec-failed
|
||||||
|
'contract-=>3
|
||||||
|
'(contract-=> (>=/c 5) (>=/c 10) 6 'badguy)
|
||||||
|
"badguy")
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
Loading…
Reference in New Issue
Block a user