From c21b3852be4538066d17219892e7dda9f586388a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 26 Feb 2002 21:48:35 +0000 Subject: [PATCH] .. original commit: 7afd47087c61a4940d90d29bc1474250c0ed54ce --- collects/framework/specs.ss | 658 ++++++++++++++------------ collects/tests/framework/spec-test.ss | 300 +++++++++--- 2 files changed, 586 insertions(+), 372 deletions(-) diff --git a/collects/framework/specs.ss b/collects/framework/specs.ss index e055b54..bad0a6a 100644 --- a/collects/framework/specs.ss +++ b/collects/framework/specs.ss @@ -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 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))))) ) diff --git a/collects/tests/framework/spec-test.ss b/collects/tests/framework/spec-test.ss index 8ed636c..fc8ac76 100644 --- a/collects/tests/framework/spec-test.ss +++ b/collects/tests/framework/spec-test.ss @@ -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") - )