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

typos, name tests for opt/c.

Browse Source 
svn: r4781
This commit is contained in:
Shu-Yu Guo 2006-11-05 06:45:58 +00:00
parent 9f2578e0f8
commit eaf71a272a
3 changed files with 148 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/private/contract-basic-opters.ss
View File

@ -39,6 +39,9 @@
(define/opter (integer? opt/i pos neg stx) (define/opter (integer? opt/i pos neg stx)
(syntax-case stx (integer?) (syntax-case stx (integer?)
[integer? (opt/pred pos #'integer?)])) [integer? (opt/pred pos #'integer?)]))
(define/opter (char? opt/i pos neg stx)
(syntax-case stx (char?)
[char? (opt/pred pos #'char?)]))
(define/opter (number? opt/i pos neg stx) (define/opter (number? opt/i pos neg stx)
(syntax-case stx (number?) (syntax-case stx (number?)
[number? (opt/pred pos #'number?)])) [number? (opt/pred pos #'number?)]))

16
collects/mzlib/private/contract.ss
View File

@ -1202,10 +1202,10 @@ add struct contracts for immutable structs?
high high
(cond (cond
[(eq? checker 'between/c) #'(check-between/c n m)] [(eq? checker 'between/c) #'(check-between/c n m)]
[(eq? checker '>/c #'(check-unary-between/c '>/c n))] [(eq? checker '>/c) #'(check-unary-between/c '>/c n)]
[(eq? checker '>=/c #'(check-unary-between/c '>=/c n))] [(eq? checker '>=/c) #'(check-unary-between/c '>=/c n)]
[(eq? checker '</c #'(check-unary-between/c '</c m))] [(eq? checker '</c) #'(check-unary-between/c '</c m)]
[(eq? checker '<=/c #'(check-unary-between/c '<=/c m))]))) [(eq? checker '<=/c) #'(check-unary-between/c '<=/c m)])))
null null
(syntax (and (number? val) (op n val m))) (syntax (and (number? val) (op n val m)))
#f)))) #f))))
@ -1220,16 +1220,16 @@ add struct contracts for immutable structs?
[(between/c low high) (opt/between-ctc pos stx #'low #'high #'<= 'between/c)])) [(between/c low high) (opt/between-ctc pos stx #'low #'high #'<= 'between/c)]))
(define/opter (>/c opt/i pos neg stx) (define/opter (>/c opt/i pos neg stx)
(syntax-case stx (>/c) (syntax-case stx (>/c)
[(>/c low) (opt/between-ctc #'low #'+inf.0 #'< '>/c)])) [(>/c low) (opt/between-ctc pos stx #'low #'+inf.0 #'< '>/c)]))
(define/opter (>=/c opt/i pos neg stx) (define/opter (>=/c opt/i pos neg stx)
(syntax-case stx (>=/c) (syntax-case stx (>=/c)
[(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<= '>=/c)])) [(>=/c low) (opt/between-ctc pos stx #'low #'+inf.0 #'<= '>=/c)]))
(define/opter (</c opt/i pos neg stx) (define/opter (</c opt/i pos neg stx)
(syntax-case stx (</c) (syntax-case stx (</c)
[(</c high) (opt/between-ctc #'-inf.0 #'high #'< '</c)])) [(</c high) (opt/between-ctc pos stx #'-inf.0 #'high #'< '</c)]))
(define/opter (<=/c opt/i pos neg stx) (define/opter (<=/c opt/i pos neg stx)
(syntax-case stx (<=/c) (syntax-case stx (<=/c)
[(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<= '<=/c)])) [(<=/c high) (opt/between-ctc pos stx #'-inf.0 #'high #'<= '<=/c)]))
(define (</c x) (define (</c x)
(flat-named-contract (flat-named-contract

137
collects/tests/mzscheme/contract-opt-tests.ss
View File

@ -13,10 +13,14 @@
(define ((match-msg msg) exn) (define ((match-msg msg) exn)
(regexp-match (regexp msg) (exn-message exn))) (regexp-match (regexp msg) (exn-message exn)))
(define-check (check-pred2 func thunk) (define-simple-check (check-pred2 func thunk)
(let-values ([(a b) (thunk)]) (let-values ([(a b) (thunk)])
(func a b))) (func a b)))
(define-simple-check (check-name expected ctc)
(let ((got (contract-name ctc)))
(equal? expected got)))
(define opt-tests (define opt-tests
(test-suite (test-suite
"Tests for opt/c" "Tests for opt/c"
@ -149,6 +153,137 @@
(λ () (λ ()
(contract (opt/c (between/c 1 'b)) 1 'pos 'neg))) (contract (opt/c (between/c 1 'b)) 1 'pos 'neg)))
;;
;; name tests
;;
(test-case
"integer? name"
(check-name 'integer? (opt/c (flat-contract integer?))))
(test-case
"boolean? name"
(check-name 'boolean? (opt/c (flat-contract boolean?))))
(test-case
"char? name"
(check-name 'char? (opt/c (flat-contract char?))))
(test-case
"any/c name"
(check-name 'any/c (opt/c any/c)))
(test-case
"-> name 1"
(check-name '(-> integer? integer?) (opt/c (-> integer? integer?))))
(test-case
"-> name 2"
(check-name '(-> integer? any) (opt/c (-> integer? any))))
(test-case
"-> name 3"
(check-name '(-> integer? (values boolean? char?)) (opt/c (-> integer? (values boolean? char?)))))
(test-case
"or/c name 1"
(check-name '(or/c) (opt/c (or/c))))
(test-case
"or/c name 2"
(check-name '(or/c integer? gt0?) (opt/c (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))))
(test-case
"or/c name 3"
(check-name '(or/c integer? boolean?)
(opt/c (or/c (flat-contract integer?)
(flat-contract boolean?)))))
(test-case
"or/c name 4"
(check-name '(or/c integer? boolean?)
(opt/c (or/c integer? boolean?))))
(test-case
"or/c name 5"
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(opt/c (or/c (-> (>=/c 5) (>=/c 5)) boolean?))))
(test-case
"or/c name 6"
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(opt/c (or/c boolean? (-> (>=/c 5) (>=/c 5))))))
(test-case
"or/c name 7"
(check-name '(or/c (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5)))
(opt/c (or/c (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5))))))
(test-case
"or/c name 8"
(check-name '(or/c boolean?
(-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5)))
(opt/c (or/c boolean?
(-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5))))))
(test-case
"=/c name 1"
(check-name '(=/c 5) (opt/c (=/c 5))))
(test-case
">=/c name 1"
(check-name '(>=/c 5) (opt/c (>=/c 5))))
(test-case
"<=/c name 1"
(check-name '(<=/c 5) (opt/c (<=/c 5))))
(test-case
"</c name 1"
(check-name '(</c 5) (opt/c (</c 5))))
(test-case
">/c name 1"
(check-name '(>/c 5) (opt/c (>/c 5))))
(test-case
"between/c name 1"
(check-name '(between/c 5 6) (opt/c (between/c 5 6))))
(test-case
"cons/c name 1"
(check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case
"cons/c name 2"
(check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case
"cons-immutable/c name 1"
(check-name '(cons-immutable/c boolean? integer?)
(opt/c (cons-immutable/c boolean? (flat-contract integer?)))))
(test-case
"cons-immutable/c name 2"
(check-name '(cons-immutable/c boolean? integer?)
(opt/c (cons-immutable/c boolean? (flat-contract integer?)))))
(test-case
"cons-immutable/c name 3"
(check-name '(cons-immutable/c boolean? integer?)
(opt/c (cons-immutable/c boolean? (flat-contract integer?)))))
(test-case
"cons-immutable/c name 4"
(check-name '(cons-immutable/c (-> boolean? boolean?) integer?)
(opt/c (cons-immutable/c (-> boolean? boolean?) integer?))))
)) ))
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 1))) (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 1)))