From a431e855fb6553b83b1b103e459cc52bb8350633 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 Jan 2003 13:44:41 +0000 Subject: [PATCH] . original commit: 38508ceba337eabb7b437262f1743646b7d20451 --- collects/mzlib/contracts.ss | 139 ++++++++++++++++++--------- collects/tests/mzscheme/contracts.ss | 55 +++++++++++ 2 files changed, 151 insertions(+), 43 deletions(-) diff --git a/collects/mzlib/contracts.ss b/collects/mzlib/contracts.ss index f694cab..350180a 100644 --- a/collects/mzlib/contracts.ss +++ b/collects/mzlib/contracts.ss @@ -432,7 +432,6 @@ ;; -> ;; 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 @@ -441,7 +440,11 @@ ;; ;; impl-builder and impl-info are two pieces used to build ;; implication contracts. - (define-struct contract (wrap impl-builder impl-info)) + (define-struct contract (wrap impl-builder)) + + ;; proc-contract = (make-proc-contract ... + ;; (number boolean boolean -> (union false (vectorof contract))) + (define-struct (proc-contract contract) (info)) ;; flat-named-contract = (make-flat-named-contract string (any -> boolean)) ;; this holds flat contracts that have names for error reporting @@ -721,7 +724,7 @@ (define (case->/proc stx) (syntax-case stx () [(_ case ...) - (let-values ([(add-outer-check make-inner-check make-bodies _1 _2) + (let-values ([(add-outer-check make-inner-check make-bodies _1 _2 _3) (case->/h stx (syntax->list (syntax (case ...))))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (with-syntax ([outer-args outer-args] @@ -733,7 +736,7 @@ (syntax/loc stx (case-lambda body ...)))]) (add-outer-check (syntax/loc stx - (make-contract + (make-proc-contract (lambda outer-args inner-check ... inner-lambda) @@ -747,7 +750,7 @@ (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...) (map (lambda (meth-contract-stx) (let ([/h (select/h meth-contract-stx 'class-contract stx)]) - (let-values ([(make-outer-check xxx build-pieces impl-builder impl-info) + (let-values ([(make-outer-check xxx build-pieces impl-wrap impl-builder impl-info) (/h meth-contract-stx)]) (list make-outer-check xxx build-pieces)))) (syntax->list (syntax (meth-contract ...))))]) @@ -781,7 +784,6 @@ (rename [super-meth-name meth-name] ...) method ... (super-instantiate ()))) - (lambda x (error 'impl-contract "unimplemented")) (lambda x (error 'impl-contract "unimplemented")))) make-outer-checks))))] [(_ (meth-name meth-contract) ...) @@ -875,6 +877,7 @@ (let-values ([(->*add-outer-check ->*make-inner-check ->*make-body + impl-wrap impl-builder impl-info) (->*/h ->body)]) @@ -891,6 +894,7 @@ ...))))) (lambda (stx) (->*make-body stx))) + impl-wrap impl-builder impl-info))))))])) @@ -906,8 +910,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 ...))))]) + [(res-x ...) (generate-temporaries (syntax (rng ...)))]) (values (lambda (body) (with-syntax ([body body]) @@ -923,13 +926,13 @@ (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax (unless (and (procedure? val) - (procedure-arity-includes? val arity)) + (procedure-arity-includes? val dom-length)) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" - arity + dom-length val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) @@ -946,23 +949,27 @@ neg-blame src-info) ...)))))) + (lambda (body) + (with-syntax ([body body]) + (syntax + (lambda (ant conq val tbb src-info) + (if (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (let* ([ant-info (proc-contract-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)] ...) + body) + (raise-contract-implication-error ant conq val tbb src-info))) + (raise-contract-implication-error ant conq val tbb src-info)))))) (syntax - (lambda (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)))) + ((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) ...)))) (syntax (lambda (len dom? and-more?) (if and-more? @@ -977,7 +984,14 @@ [(_ (dom ...) rest (rng ...)) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + [(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 @@ -1003,18 +1017,18 @@ pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" - arity + dom-length val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax - ((arg-x ... . rest-arg-x) + ((arg-x ... . arg-rest-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))]) + (check-contract dom-rest-x arg-rest-x neg-blame pos-blame src-info))]) (values (check-contract rng-x res-x @@ -1022,8 +1036,42 @@ neg-blame src-info) ...)))))) - (syntax (lambda x (error 'impl-contract "unimplemented"))) - (syntax (lambda x (error 'impl-contract "unimplemented")))))])) + (lambda (body) + (with-syntax ([body body]) + (syntax + (lambda (ant conq val tbb src-info) + (if (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (let* ([ant-info (proc-contract-info ant)] + [dom-ant-info (ant-info dom-length #t #t)] + [rng-ant-info (ant-info rng-length #f #t)]) + (if (and rng-ant-info dom-ant-info) + (let ([dom-ant-rest-x (vector-ref dom-ant-info 0)] + [dom-ant-x (vector-ref dom-ant-info (+ dom-index 1))] ... + [rng-ant-x (vector-ref rng-ant-info rng-index)] ...) + body) + (raise-contract-implication-error ant conq val tbb src-info))) + (raise-contract-implication-error ant conq val tbb src-info)))))) + (syntax + ((arg-x ... . arg-rest-x) + (let-values ([(res-x ...) + (apply + val + (check-implication dom-x dom-ant-x arg-x tbb src-info) ... + (check-implication dom-rest-x dom-ant-rest-x arg-rest-x tbb src-info))]) + (values + (check-implication rng-ant-x rng-x res-x tbb src-info) ...)))) + (syntax + (lambda (len dom? and-more?) + (if and-more? + (if dom? + (cond + [(= len dom-length) (vector dom-rest-x dom-x ...)] + [else #f]) + (cond + [(= len rng-length) (vector rng-x ...)] + [else #f])) + #f)))))])) ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->d/h stx) @@ -1075,7 +1123,8 @@ pos-blame neg-blame src-info)))))) - (syntax (lambda x (error 'impl-contract "unimplemented"))) + (lambda (body) (syntax (lambda x (error 'impl-contract "unimplemented")))) + (syntax (x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))))])) ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) @@ -1139,7 +1188,8 @@ src-info)) rng-contracts results)))))))))) - (syntax (lambda x (error 'impl-contract "unimplemented"))) + (lambda (body) (syntax (lambda x (error 'impl-contract "unimplemented")))) + (syntax (x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented")))))] [(_ (dom ...) rest rng-mk) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] @@ -1202,21 +1252,23 @@ src-info )) rng-contracts results)))))))))) - (syntax (lambda x (error 'impl-contract "unimplemented"))) + (lambda (body) (syntax (lambda x (error 'impl-contract "unimplemented")))) + (syntax (x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented")))))])) ;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) ;; syntax ;; -> (syntax -> syntax) (define (make-/proc /h stx) - (let-values ([(add-outer-check make-inner-check make-main impl-first impl-second) (/h stx)]) + (let-values ([(add-outer-check make-inner-check make-main impl-wrap impl-first impl-second) (/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)] - [impl-first impl-first] + [(impl-first-params impl-first-body) impl-first] [impl-second impl-second]) - (with-syntax ([inner-lambda + (with-syntax ([impl-first (impl-wrap (syntax (lambda impl-first-params impl-first-body)))] + [inner-lambda (set-inferred-name-from stx (syntax/loc stx (lambda inner-args body)))]) @@ -1224,7 +1276,7 @@ (set-inferred-name-from stx (syntax/loc stx - (make-contract + (make-proc-contract (lambda outer-args inner-check inner-lambda) @@ -1240,12 +1292,13 @@ [(null? cases) (values (lambda (x) x) (lambda (args) (syntax ())) (lambda (args) (syntax ())) - (syntax (lambda x (error 'impl-contract "unimplemented"))) + (lambda (body) (syntax (lambda x (error 'impl-contract "unimplemented")))) + (syntax (x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))] [else (let ([/h (select/h (car cases) 'case-> orig-stx)]) - (let-values ([(add-outer-checks make-inner-checks make-bodies _a _b) (loop (cdr cases))] - [(add-outer-check make-inner-check make-body _1 _2) (/h (car cases))]) + (let-values ([(add-outer-checks make-inner-checks make-bodies _a _b _c) (loop (cdr cases))] + [(add-outer-check make-inner-check make-body _1 _2 _3) (/h (car cases))]) (values (lambda (x) (add-outer-check (add-outer-checks x))) (lambda (args) @@ -1256,7 +1309,8 @@ (with-syntax ([case (make-body args)] [cases (make-bodies args)]) (syntax (case . cases)))) - (syntax (lambda x (error 'impl-contract "unimplemented"))) + (lambda (body) (syntax (lambda x (error 'impl-contract "unimplemented")))) + (syntax (x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))))]))) ;; select/h : syntax -> /h-function @@ -1390,7 +1444,6 @@ (raise-contract-error src-info pos neg "union failed, given: ~e" val)] [(null? (cdr contracts)) ((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 diff --git a/collects/tests/mzscheme/contracts.ss b/collects/tests/mzscheme/contracts.ss index c7b773d..4272e69 100644 --- a/collects/tests/mzscheme/contracts.ss +++ b/collects/tests/mzscheme/contracts.ss @@ -692,6 +692,61 @@ 'badguy) "badguy") + (test/spec-passed/result + 'contract-=>->*10 + '((contract-=> (->* ((>=/c 10)) (listof (>=/c 20)) ((>=/c 3))) + (->* ((>=/c 3)) (listof (>=/c 8)) ((>=/c 10))) + (lambda (x . y) 1) + 'badguy) + 100 + 200 + 300) + 1) + + (test/spec-failed + 'contract-=>->*11 + '((contract-=> (->* ((>=/c 10)) (listof (>=/c 20)) ((>=/c 3))) + (->* ((>=/c 3)) (listof (>=/c 8)) ((>=/c 10))) + (lambda (x . y) 1) + 'badguy) + 7 + 200 + 300) + "badguy") + + (test/spec-failed + 'contract-=>->*12 + '((contract-=> (->* ((>=/c 10)) (listof (>=/c 20)) ((>=/c 3))) + (->* ((>=/c 3)) (listof (>=/c 8)) ((>=/c 10))) + (lambda (x . y) 1) + 'badguy) + 100 + 10 + 300) + "badguy") + + (test/spec-failed + 'contract-=>->*13 + '((contract-=> (->* ((>=/c 10)) (listof (>=/c 20)) ((>=/c 3))) + (->* ((>=/c 3)) (listof (>=/c 8)) ((>=/c 10))) + (lambda (x . y) 1) + 'badguy) + 100 + 200 + 10) + "badguy") + + (test/spec-failed + 'contract-=>->*14 + '((contract-=> (->* ((>=/c 10)) (listof (>=/c 20)) ((>=/c 3))) + (->* ((>=/c 3)) (listof (>=/c 8)) ((>=/c 10))) + (lambda (x . y) 5) + 'badguy) + 100 + 200 + 300) + "badguy") + )) (report-errs) \ No newline at end of file