suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merged changes from branches/cce/plt+contract-tests:

Browse Source 
- Added tests for make-proj-contract
- Added tests for opt/c, specifically to track 'positive-position?' blame
- Fixed 'positive-position?' in opt/c (bug 10629)

svn: r17105
This commit is contained in:
Carl Eastlund 2009-11-30 04:40:51 +00:00
parent 06f231a0a7
commit 3b9d254fda
3 changed files with 147 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/contract/private/opt-guts.ss
View File

@ -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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1
collects/scheme/contract/private/opt.ss
View File

@ -127,6 +127,7 @@
#'src-info
#'orig-str
#'positive-position?
#f
(syntax->list #'(opt-recursive-args ...))
#f
#f

130
collects/tests/mzscheme/contract-test.ss
View File

@ -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
#;