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

more repairs from Will

Browse Source 
svn: r10907
This commit is contained in:
Matthew Flatt 2008-07-25 12:38:03 +00:00
parent 5c61c1b997
commit 9fece2f96b
3 changed files with 85 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/tests/r6rs/hashtables.sls
View File

@ -99,19 +99,13 @@
(hashtable-set! h 2 'two)
(hashtable-set! h 3 'three)
(hashtable-entries h))])
(test (or (equal? (cons kv vv)
'(#(1 2 3) . #(one two three)))
(equal? (cons kv vv)
'(#(1 3 2) . #(one three two)))
(equal? (cons kv vv)
'(#(2 1 3) . #(two one three)))
(equal? (cons kv vv)
'(#(2 3 1) . #(two three one)))
(equal? (cons kv vv)
'(#(3 1 2) . #(three one two)))
(equal? (cons kv vv)
'(#(3 2 1) . #(three two one))))
#t))
(test/alts (cons kv vv)
'(#(1 2 3) . #(one two three))
'(#(1 3 2) . #(one three two))
'(#(2 1 3) . #(two one three))
'(#(2 3 1) . #(two three one))
'(#(3 1 2) . #(three one two))
'(#(3 2 1) . #(three two one))))
(test-ht (make-eq-hashtable) eq?
(['a 7] ['b "bee"]

16
collects/tests/r6rs/io/ports.sls
View File

@ -37,15 +37,13 @@
(test (string->bytevector "apple\x85;"
(make-transcoder (latin-1-codec)))
#vu8(97 112 112 108 101 #x85))
(test (let ([v (string->bytevector "app\x03BB;e"
(make-transcoder (utf-16-codec)))])
;; Could be LE or BE:
(if (= (bytevector-u8-ref v 0) #xFE)
v
(if (equal? v #vu8(#xFF #xFE 97 0 112 0 112 0 #xBB #x3 101 0))
#vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101)
v)))
#vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101))
(test/alts (string->bytevector "app\x03BB;e"
(make-transcoder (utf-16-codec)))
;; Could be LE or BE, with or without BOM:
#vu8(#xFF #xFE 97 0 112 0 112 0 #xBB #x3 101 0)
#vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101)
#vu8(97 0 112 0 112 0 #xBB #x3 101 0)
#vu8(0 97 0 112 0 112 #x3 #xBB 0 101))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'lf))
#vu8(97 10 98))

88
collects/tests/r6rs/test.sls
View File

@ -3,6 +3,7 @@
(library (tests r6rs test)
(export test
test/approx
test/alts
test/exn
test/values
test/output
@ -22,6 +23,12 @@
(define-record-type multiple-results
(fields values))
(define-record-type approx
(fields value))
(define-record-type alts
(fields values))
(define-syntax test
(syntax-rules ()
[(_ expr expected)
@ -33,17 +40,48 @@
(define (catch-exns thunk)
(guard (c [#t (make-err c)])
(thunk)))
(call-with-values thunk
(lambda x
(if (= 1 (length x))
(car x)
(make-multiple-results x))))))
(define-syntax test/approx
(syntax-rules ()
[(_ expr expected)
(test (approx expr) (approx expected))]))
(run-test 'expr
(make-approx expr)
(make-approx expected))]))
(define (approx v)
(let ([n (* (inexact v) 1000.0)])
(+ (round (real-part n))
(* (round (imag-part n)) (sqrt -1)))))
(define-syntax test/alts
(syntax-rules ()
[(_ expr expected0 expected ...)
(run-test 'expr
expr
(make-alts (list expected0 expected ...)))]))
(define (good-enough? x y)
;; relative error should be with 0.1%, but greater
;; relative error is allowed when the expected value
;; is near zero.
(cond ((not (number? x)) #f)
((not (number? y)) #f)
((or (not (real? x))
(not (real? y)))
(and (good-enough? (real-part x) (real-part y))
(good-enough? (imag-part x) (imag-part y))))
((infinite? x)
(= x (* 2.0 y)))
((infinite? y)
(= (* 2.0 x) y))
((nan? y)
(nan? x))
((> (magnitude y) 1e-6)
(< (/ (magnitude (- x y))
(magnitude y))
1e-3))
(else
(< (magnitude (- x y)) 1e-6))))
(define-syntax test/exn
(syntax-rules ()
@ -57,10 +95,7 @@
(syntax-rules ()
[(_ expr val ...)
(run-test 'expr
(catch-exns (lambda ()
(call-with-values
(lambda () expr)
(lambda results (make-multiple-results results)))))
(catch-exns (lambda () expr))
(make-multiple-results (list val ...)))]))
(define-syntax test/output
@ -117,6 +152,10 @@
(and (real? got) (nan? got))]
[(expected-exception? expected)
(expected-exception? got)]
[(approx? expected)
(and (approx? got)
(good-enough? (approx-value expected)
(approx-value got)))]
[(multiple-results? expected)
(and (multiple-results? got)
(= (length (multiple-results-values expected))
@ -124,6 +163,9 @@
(for-all same-result?
(multiple-results-values expected)
(multiple-results-values got)))]
[(alts? expected)
(exists (lambda (e) (same-result? got e))
(alts-values expected))]
[else (equal? got expected)]))
(define (run-test expr got expected)
@ -134,13 +176,25 @@
failures))))
(define (write-result prefix v)
(if (multiple-results? v)
(for-each (lambda (v)
(write-result prefix v))
(multiple-results-values v))
(begin
(display prefix)
(write v))))
(cond
[(multiple-results? v)
(for-each (lambda (v)
(write-result prefix v))
(multiple-results-values v))]
[(approx? v)
(display prefix)
(display "approximately ")
(write (approx-value v))]
[(alts? v)
(write-result (string-append prefix " ")
(car (alts-values v)))
(for-each (lambda (v)
(write-result (string-append prefix "OR ")
v))
(cdr (alts-values v)))]
[else
(display prefix)
(write v)]))
(define (report-test-results)
(if (null? failures)