diff --git a/collects/scheme/contract/private/opt-guts.ss b/collects/scheme/contract/private/opt-guts.ss index d7efff5ecc..1dedd43c54 100644 --- a/collects/scheme/contract/private/opt-guts.ss +++ b/collects/scheme/contract/private/opt-guts.ss @@ -56,8 +56,14 @@ ;; struct for color-keeping across opters -(define-struct opt/info (contract val pos neg src-info orig-str positive-position? - free-vars recf base-pred this that)) +(define-struct opt/info + (contract val pos neg src-info orig-str position-var position-swap? + free-vars recf base-pred this that)) + +(define (opt/info-positive-position? oi) + (if (opt/info-position-swap? oi) + #`(not #,(opt/info-position-var oi)) + (opt/info-position-var oi))) ;; opt/info-swap-blame : opt/info -> opt/info ;; swaps pos and neg @@ -66,7 +72,8 @@ (val (opt/info-val info)) (pos (opt/info-pos info)) (neg (opt/info-neg info)) - (positive-position? (opt/info-positive-position? info)) + (position-var (opt/info-position-var info)) + (position-swap? (opt/info-position-swap? info)) (src-info (opt/info-src-info info)) (orig-str (opt/info-orig-str info)) (free-vars (opt/info-free-vars info)) @@ -74,7 +81,8 @@ (base-pred (opt/info-base-pred info)) (this (opt/info-this info)) (that (opt/info-that info))) - (make-opt/info ctc val neg pos src-info orig-str (not positive-position?) + (make-opt/info ctc val neg pos src-info orig-str + position-var (not position-swap?) free-vars recf base-pred this that))) ;; opt/info-change-val : identifier opt/info -> opt/info @@ -83,7 +91,8 @@ (let ((ctc (opt/info-contract info)) (pos (opt/info-pos info)) (neg (opt/info-neg info)) - (positive-position? (opt/info-positive-position? info)) + (position-var (opt/info-position-var info)) + (position-swap? (opt/info-position-swap? info)) (src-info (opt/info-src-info info)) (orig-str (opt/info-orig-str info)) (free-vars (opt/info-free-vars info)) @@ -91,7 +100,9 @@ (base-pred (opt/info-base-pred info)) (this (opt/info-this info)) (that (opt/info-that info))) - (make-opt/info ctc val pos neg src-info orig-str positive-position? free-vars recf base-pred this that))) + (make-opt/info ctc val pos neg src-info orig-str + position-var position-swap? + free-vars recf base-pred this that))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/scheme/contract/private/opt.ss b/collects/scheme/contract/private/opt.ss index d0383f4920..888b11c84c 100644 --- a/collects/scheme/contract/private/opt.ss +++ b/collects/scheme/contract/private/opt.ss @@ -127,6 +127,7 @@ #'src-info #'orig-str #'positive-position? + #f (syntax->list #'(opt-recursive-args ...)) #f #f diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 89e6e5d1b7..3de105d6a2 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2282,7 +2282,53 @@ 'neg) 'x) 1) - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make-proj-contract + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(define proj:add1->sub1 + (make-proj-contract + 'proj:add1->sub1 + (lambda (pos neg src name blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-contract-error f src pos name + "expected a unary function, got: ~e" + f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-contract-error x src neg name + "expected an integer, got: ~e" + x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-contract-error y src pos name + "expected an integer, got: ~e" + y)) + (sub1 y))))) + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + + (test/spec-passed/result + 'make-proj-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + + (test/pos-blame + 'make-proj-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + + (test/pos-blame + 'make-proj-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + + (test/neg-blame + 'make-proj-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) ; ; @@ -5200,6 +5246,88 @@ ;; end of define-opt/c ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; opt/c and blame + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(begin + + (define proj:blame/c + (make-proj-contract + 'proj:blame/c + (lambda (pos neg src name blame) + (lambda (x) + (if blame 'positive 'negative))) + (lambda (x) #t))) + + (define call*0 'dummy) + (define (call*1 x0) x0) + (define (call*2 f1 x0) (f1 x0)) + (define (call*3 f2 x1 x0) (f2 x1 x0)))) + + (test/spec-passed/result + 'opt/c-blame-0 + '((contract + (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-1 + '((contract + (opt/c (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c)) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-2 + '((contract + (-> (opt/c (-> (-> proj:blame/c any/c) any/c any/c)) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-3 + '((contract + (-> (-> (opt/c (-> proj:blame/c any/c)) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-4 + '((contract + (-> (-> (-> (opt/c proj:blame/c) any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) ;; NOT YET RELEASED #;