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

fixed up printing ~s vs ~a in contract system and made the contract tests run in drdr

Browse Source
This commit is contained in:
Robby Findler 2011-05-11 21:16:46 -05:00
parent c163e75023
commit 1db3ae3476
7 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/meta/props
View File

@ -1751,10 +1751,10 @@ path/s is either such a string or a list of them.
"collects/tests/racket/compile.rktl" drdr:command-line #f "collects/tests/racket/compile.rktl" drdr:command-line #f
"collects/tests/racket/contmark.rktl" drdr:command-line #f "collects/tests/racket/contmark.rktl" drdr:command-line #f
"collects/tests/racket/contract-mzlib-test.rktl" responsible (robby) drdr:command-line (racket "-qr" *) "collects/tests/racket/contract-mzlib-test.rktl" responsible (robby) drdr:command-line (racket "-qr" *)
"collects/tests/racket/contract-opt-tests.rkt" responsible (robby) drdr:command-line (racket "-f" *) "collects/tests/racket/contract-opt-tests.rkt" responsible (robby) drdr:command-line (racket "-qr" *)
"collects/tests/racket/contract-stress-argmin.rkt" responsible (robby) "collects/tests/racket/contract-stress-argmin.rkt" responsible (robby) drdr:command-line (racket "-qr" *)
"collects/tests/racket/contract-stress-take-right.rkt" responsible (robby) "collects/tests/racket/contract-stress-take-right.rkt" responsible (robby) drdr:command-line (racket "-qr" *)
"collects/tests/racket/contract-test.rktl" responsible (robby) drdr:command-line #f "collects/tests/racket/contract-test.rktl" responsible (robby) drdr:command-line (racket "-qr" *)
"collects/tests/racket/control.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/control.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/date.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/date.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/deep.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/deep.rktl" drdr:command-line (racket "-f" *)

4
collects/racket/contract/private/basic-opters.rkt
View File

@ -22,7 +22,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val)))) val))))
null null
@ -102,7 +102,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val))) val)))
(interleave-lifts (interleave-lifts

6
collects/racket/contract/private/ds.rkt
View File

@ -246,7 +246,7 @@ it around flattened out.
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, got ~e" 'name val)) "expected <~s>, got ~e" 'name val))
(cond (cond
[(already-there? contract/info val lazy-depth-to-look) [(already-there? contract/info val lazy-depth-to-look)
val] val]
@ -299,7 +299,7 @@ it around flattened out.
(do-selection struct (+ i 1)) (do-selection struct (+ i 1))
(wrap-get struct (+ i 1)))] (wrap-get struct (+ i 1)))]
[else [else
(error selector-name "expected <~a>, got ~e" 'name struct)])) (error selector-name "expected <~s>, got ~e" 'name struct)]))
(define (lazy-contract-name ctc) (define (lazy-contract-name ctc)
(do-contract-name 'struct/c (do-contract-name 'struct/c
@ -452,7 +452,7 @@ it around flattened out.
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, got ~e" "expected <~s>, got ~e"
(contract-name ctc) (contract-name ctc)
val)])) val)]))
lifts lifts

2
collects/racket/contract/private/misc.rkt
View File

@ -607,7 +607,7 @@
[cdr-p (cdr-proj blame)]) [cdr-p (cdr-proj blame)])
(λ (v) (λ (v)
(unless (pair? v) (unless (pair? v)
(raise-blame-error blame v "expected <~a>, given: ~e" 'cons v)) (raise-blame-error blame v "expected <cons?>, given: ~e" v))
(combine v (car-p (car v)) (cdr-p (cdr v)))))) (combine v (car-p (car v)) (cdr-p (cdr v))))))
(cond (cond
[(and (flat-contract? ctc-car) (flat-contract? ctc-cdr)) [(and (flat-contract? ctc-car) (flat-contract? ctc-cdr))

8
collects/racket/contract/private/opters.rkt
View File

@ -148,7 +148,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val))) val)))
lifts3 lifts3
@ -186,7 +186,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val))) val)))
lifts3 lifts3
@ -268,7 +268,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val)))) val))))
(append (append
@ -329,7 +329,7 @@
(raise-blame-error (raise-blame-error
blame blame
val val
"expected <~a>, given: ~e" "expected <~s>, given: ~e"
(contract-name ctc) (contract-name ctc)
val)))) val))))
(append lifts-hdp lifts-tlp) (append lifts-hdp lifts-tlp)

2
collects/racket/contract/private/prop.rkt
View File

@ -211,7 +211,7 @@
(define (((first-order-projection name first-order) b) x) (define (((first-order-projection name first-order) b) x)
(if (first-order x) (if (first-order x)
x x
(raise-blame-error b x "expected <~a>, given: ~e" name x))) (raise-blame-error b x "expected <~s>, given: ~e" name x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

4
collects/racket/contract/private/struct.rkt
View File

@ -36,12 +36,12 @@
(append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc)))]) (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc)))])
(λ (val fail [first-order? #f]) (λ (val fail [first-order? #f])
(unless (pred? val) (unless (pred? val)
(fail "expected <~a>, got ~e" name val)) (fail "expected <~s>, got ~e" name val))
(when first-order? (when first-order?
(for ([p (in-list ctc/ref-pairs)]) (for ([p (in-list ctc/ref-pairs)])
(let ([c (car p)] [v ((cdr p) val)]) (let ([c (car p)] [v ((cdr p) val)])
(unless (contract-first-order-passes? c v) (unless (contract-first-order-passes? c v)
(fail "expected <~a>, got ~e" (contract-name c) v))))) (fail "expected <~s>, got ~e" (contract-name c) v)))))
#t))) #t)))
(define (struct/c-first-order ctc) (define (struct/c-first-order ctc)