From 859eb8f1186ac0a0017721efc89d31d5b189d697 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 16 Jan 2003 16:26:33 +0000 Subject: [PATCH] .. original commit: bd5c5824b968ee5aade63419b360cf575535ed2c --- collects/mzlib/contracts.ss | 48 +++++--- collects/tests/mzscheme/contracts.ss | 158 ++++++++++++++++++++++++--- 2 files changed, 177 insertions(+), 29 deletions(-) diff --git a/collects/mzlib/contracts.ss b/collects/mzlib/contracts.ss index 3d029ee..f694cab 100644 --- a/collects/mzlib/contracts.ss +++ b/collects/mzlib/contracts.ss @@ -457,7 +457,8 @@ (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" + (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)) @@ -495,7 +496,8 @@ 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" + (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 @@ -509,7 +511,7 @@ name)) (check-contract a-contract name pos-blame neg-blame src-info)))]))) - ;; check-contract : contract any symbol symbol syntax -> ... + ;; check-contract : contract any symbol symbol syntax -> any (define (check-contract contract val pos neg src-info) (cond [(contract? contract) @@ -563,7 +565,8 @@ tbb src-loc)) (unless (symbol? tbb) - (error 'contract-=> "expected symbol as names for assigning blame, given: ~e, other args ~e ~e ~e ~e" + (error 'contract-=> + "expected symbol as names for assigning blame, given: ~e, other args ~e ~e ~e ~e" tbb c1 c2 @@ -902,6 +905,7 @@ [(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values @@ -944,18 +948,32 @@ ...)))))) (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))))) + (if (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (let* ([ant-info (contract-impl-info ant)] + [dom-ant-info (ant-info dom-length #t #f)] + [rng-ant-info (ant-info rng-length #f #f)]) + (if (and rng-ant-info dom-ant-info) + (let ([dom-ant-x (vector-ref dom-ant-info dom-index)] ... + [rng-ant-x (vector-ref rng-ant-info rng-index)] ...) + (lambda (arg-x ...) + (let-values ([(res-x ...) + (val (check-implication dom-x dom-ant-x arg-x tbb src-info) ...)]) + (values + (check-implication rng-ant-x rng-x res-x tbb src-info) ...)))) + (raise-contract-implication-error ant conq val 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])))))] + (lambda (len dom? and-more?) + (if and-more? + #f + (if dom? + (cond + [(= len dom-length) (vector dom-x ...)] + [else #f]) + (cond + [(= len rng-length) (vector rng-x ...)] + [else #f])))))))] [(_ (dom ...) rest (rng ...)) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] diff --git a/collects/tests/mzscheme/contracts.ss b/collects/tests/mzscheme/contracts.ss index 037fd60..c7b773d 100644 --- a/collects/tests/mzscheme/contracts.ss +++ b/collects/tests/mzscheme/contracts.ss @@ -9,11 +9,13 @@ ;; test/spec-passed : symbol sexp -> void ;; tests a passing specification (define (test/spec-passed name expression) + (printf "testing: ~s\n" name) (test (void) (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval) (list expression '(void)))) (define (test/spec-passed/result name expression result) + (printf "testing: ~s\n" name) (test result eval expression)) @@ -21,18 +23,21 @@ ;; 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) - (cond - [(regexp-match ": ([^ ]*) broke" x) => cadr] - [(regexp-match "([^ ]+): .* does not imply" x) => cadr] - [else #f]))) + (define (ensure-contract-failed x) + (let ([result (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x))) + exn-message]) + (list 'normal-termination + (eval x)))]) + (if (string? result) + (cond + [(regexp-match ": ([^ ]*) broke" result) => cadr] + [(regexp-match "([^ ]+): .* does not imply" result) => cadr] + [else "no blame in error message"]) + result))) + (printf "testing: ~s\n" name) (test blame - failed-contract - (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x))) - exn-message]) - (eval expression) - 'failed/expected-exn-got-normal-termination))) + ensure-contract-failed + expression)) (test/spec-passed 'contract-flat1 @@ -550,18 +555,143 @@ (test/spec-passed/result - 'contract-=>1 + 'contract-=>flat1 '(contract-=> (>=/c 5) (>=/c 10) 1 'badguy) 1) (test/spec-passed/result - 'contract-=>2 + 'contract-=>flat2 '(contract-=> (>=/c 5) (>=/c 10) 12 'badguy) 12) (test/spec-failed - 'contract-=>3 + 'contract-=>flat3 '(contract-=> (>=/c 5) (>=/c 10) 6 'badguy) "badguy") + + (test/spec-passed + 'contract-=>->1 + '(contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy)) + (test/spec-failed + 'contract-=>->2 + '(contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) 'not-a-proc 'badguy) + "badguy") + + (test/spec-passed/result + 'contract-=>->3 + '((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy) + 1) + 1) + + (test/spec-passed/result + 'contract-=>->4 + '((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 10)) (lambda (x) x) 'badguy) + 12) + 12) + + (test/spec-failed + 'contract-=>->5 + '((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 5) . -> . (>=/c 5)) (lambda (x) x) 'badguy) + 7) + "badguy") + + (test/spec-failed + 'contract-=>->6 + '((contract-=> ((>=/c 10) . -> . (>=/c 5)) ((>=/c 10) . -> . (>=/c 10)) (lambda (x) 7) 'badguy) + 7) + "badguy") + + (test/spec-passed + 'contract-=>->*1 + '(contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values x y)) + 'badguy)) + + (test/spec-failed + 'contract-=>->*2 + '(contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + 'not-a-proc + 'badguy) + "badguy") + + (test/spec-passed/result + 'contract-=>->*3 + '(let-values ([(r1 r2) + ((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values x y)) + 'badguy) + 1 7)]) + r1) + 1) + + (test/spec-passed/result + 'contract-=>->*4 + '(let-values ([(r1 r2) + ((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values x y)) + 'badguy) + 11 21)]) + r1) + 11) + + (test/spec-failed + 'contract-=>->*5 + '((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values x y)) + 'badguy) + 5 21) + "badguy") + + (test/spec-failed + 'contract-=>->*6 + '((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values x y)) + 'badguy) + 11 10) + "badguy") + + (test/spec-failed + 'contract-=>->*7 + '((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values 8 25)) + 'badguy) + 11 21) + "badguy") + + (test/spec-failed + 'contract-=>->*8 + '((contract-=> (->* ((>=/c 10) (>=/c 20)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8)) ((>=/c 10) (>=/c 20))) + (lambda (x y) (values 15 10)) + 'badguy) + 11 21) + "badguy") + + (test/spec-passed/result + 'contract-=>->*9 + '(let-values ([(a b) + ((contract-=> (->* ((>=/c 10) (>=/c 20) (>=/c 30)) ((>=/c 3) (>=/c 8))) + (->* ((>=/c 3) (>=/c 8) (>=/c 30)) ((>=/c 10) (>=/c 20))) + (lambda (x y z) (values x z)) + 'badguy) + 101 102 103)]) + b) + 103) + + (test/spec-failed + 'contract-=>mismatch + '(contract-=> (>=/c 5) + (-> (>=/c 3) (>=/c 8)) + 1 + 'badguy) + "badguy") + )) (report-errs) \ No newline at end of file