[uim-commit] r2826 - branches/r5rs/sigscheme/test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Jan 6 20:07:09 PST 2006
Author: yamaken
Date: 2006-01-06 20:06:55 -0800 (Fri, 06 Jan 2006)
New Revision: 2826
Modified:
branches/r5rs/sigscheme/test/test-r4rs.scm
Log:
* sigscheme/test/test-r4rs.scm
- Modify expect value of string->number tests that does not conform
to both R4RS and R5RS
- Comment out tests that not supported by SigScheme
Modified: branches/r5rs/sigscheme/test/test-r4rs.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-r4rs.scm 2006-01-07 03:30:27 UTC (rev 2825)
+++ branches/r5rs/sigscheme/test/test-r4rs.scm 2006-01-07 04:06:55 UTC (rev 2826)
@@ -564,213 +564,223 @@
(define (test-string->number str)
(define ans (string->number str))
(cond ((not ans) #t) ((number? ans) #t) (else ans)))
-(for-each (lambda (str) (test #t test-string->number str))
- '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
- "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
- "#i" "#e" "#" "#i0/0"))
-(cond ((number? (string->number "1+1i")) ;More kawa bait
- (test #t number? (string->number "#i-i"))
- (test #t number? (string->number "#i+i"))
- (test #t number? (string->number "#i2+i"))))
+;; MODIFIED: these exps are invalid for both R4RS and R5RS
+;;(for-each (lambda (str) (test #t test-string->number str))
+;; '("+#.#" "-#.#" "#.#" "#i" "#e" "#"))
+(for-each (lambda (str) (test #f test-string->number str))
+ '("+#.#" "-#.#" "#.#" "#i" "#e" "#"))
+;; DISABLED: not supported by SigScheme
+;;(for-each (lambda (str) (test #t test-string->number str))
+;; '("1/0" "-1/0" "0/0"
+;; "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
+;; "#i0/0"))
+;;(cond ((number? (string->number "1+1i")) ;More kawa bait
+;; (test #t number? (string->number "#i-i"))
+;; (test #t number? (string->number "#i+i"))
+;; (test #t number? (string->number "#i2+i"))))
-;;;;From: fred at sce.carleton.ca (Fred J Kaudel)
-;;; Modified by jaffer.
-(define (test-inexact)
- (define f3.9 (string->number "3.9"))
- (define f4.0 (string->number "4.0"))
- (define f-3.25 (string->number "-3.25"))
- (define f.25 (string->number ".25"))
- (define f4.5 (string->number "4.5"))
- (define f3.5 (string->number "3.5"))
- (define f0.0 (string->number "0.0"))
- (define f0.8 (string->number "0.8"))
- (define f1.0 (string->number "1.0"))
- (define wto write-test-obj)
- (define lto load-test-obj)
- (newline)
- (display ";testing inexact numbers; ")
- (newline)
- (SECTION 6 2)
- (test #f eqv? 1 f1.0)
- (test #f eqv? 0 f0.0)
- (SECTION 6 5 5)
- (test #t inexact? f3.9)
- (test #t 'max (inexact? (max f3.9 4)))
- (test f4.0 max f3.9 4)
- (test f4.0 exact->inexact 4)
- (test f4.0 exact->inexact 4.0)
- (test 4 inexact->exact 4)
- (test 4 inexact->exact 4.0)
- (test (- f4.0) round (- f4.5))
- (test (- f4.0) round (- f3.5))
- (test (- f4.0) round (- f3.9))
- (test f0.0 round f0.0)
- (test f0.0 round f.25)
- (test f1.0 round f0.8)
- (test f4.0 round f3.5)
- (test f4.0 round f4.5)
- (test 1 expt 0 0)
- (test 0 expt 0 1)
- (test (atan 1) atan 1 1)
- (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
- (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
- (test #t call-with-output-file
- "tmp3"
- (lambda (test-file)
- (write-char #\; test-file)
- (display #\; test-file)
- (display ";" test-file)
- (write write-test-obj test-file)
- (newline test-file)
- (write load-test-obj test-file)
- (output-port? test-file)))
- (check-test-file "tmp3")
- (set! write-test-obj wto)
- (set! load-test-obj lto)
- (let ((x (string->number "4195835.0"))
- (y (string->number "3145727.0")))
- (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
- (report-errs))
+;; DISABLED: not supported by SigScheme
+;;;;;;From: fred at sce.carleton.ca (Fred J Kaudel)
+;;;;; Modified by jaffer.
+;;(define (test-inexact)
+;; (define f3.9 (string->number "3.9"))
+;; (define f4.0 (string->number "4.0"))
+;; (define f-3.25 (string->number "-3.25"))
+;; (define f.25 (string->number ".25"))
+;; (define f4.5 (string->number "4.5"))
+;; (define f3.5 (string->number "3.5"))
+;; (define f0.0 (string->number "0.0"))
+;; (define f0.8 (string->number "0.8"))
+;; (define f1.0 (string->number "1.0"))
+;; (define wto write-test-obj)
+;; (define lto load-test-obj)
+;; (newline)
+;; (display ";testing inexact numbers; ")
+;; (newline)
+;; (SECTION 6 2)
+;; (test #f eqv? 1 f1.0)
+;; (test #f eqv? 0 f0.0)
+;; (SECTION 6 5 5)
+;; (test #t inexact? f3.9)
+;; (test #t 'max (inexact? (max f3.9 4)))
+;; (test f4.0 max f3.9 4)
+;; (test f4.0 exact->inexact 4)
+;; (test f4.0 exact->inexact 4.0)
+;; (test 4 inexact->exact 4)
+;; (test 4 inexact->exact 4.0)
+;; (test (- f4.0) round (- f4.5))
+;; (test (- f4.0) round (- f3.5))
+;; (test (- f4.0) round (- f3.9))
+;; (test f0.0 round f0.0)
+;; (test f0.0 round f.25)
+;; (test f1.0 round f0.8)
+;; (test f4.0 round f3.5)
+;; (test f4.0 round f4.5)
+;; (test 1 expt 0 0)
+;; (test 0 expt 0 1)
+;; (test (atan 1) atan 1 1)
+;; (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+;; (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+;; (test #t call-with-output-file
+;; "tmp3"
+;; (lambda (test-file)
+;; (write-char #\; test-file)
+;; (display #\; test-file)
+;; (display ";" test-file)
+;; (write write-test-obj test-file)
+;; (newline test-file)
+;; (write load-test-obj test-file)
+;; (output-port? test-file)))
+;; (check-test-file "tmp3")
+;; (set! write-test-obj wto)
+;; (set! load-test-obj lto)
+;; (let ((x (string->number "4195835.0"))
+;; (y (string->number "3145727.0")))
+;; (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+;; (report-errs))
-(define (test-inexact-printing)
- (let ((f0.0 (string->number "0.0"))
- (f0.5 (string->number "0.5"))
- (f1.0 (string->number "1.0"))
- (f2.0 (string->number "2.0")))
- (define log2
- (let ((l2 (log 2)))
- (lambda (x) (/ (log x) l2))))
+;; DISABLED: not supported by SigScheme
+;;(define (test-inexact-printing)
+;; (let ((f0.0 (string->number "0.0"))
+;; (f0.5 (string->number "0.5"))
+;; (f1.0 (string->number "1.0"))
+;; (f2.0 (string->number "2.0")))
+;; (define log2
+;; (let ((l2 (log 2)))
+;; (lambda (x) (/ (log x) l2))))
+;;
+;; (define (slow-frexp x)
+;; (if (zero? x)
+;; (list f0.0 0)
+;; (let* ((l2 (log2 x))
+;; (e (floor (log2 x)))
+;; (e (if (= l2 e)
+;; (inexact->exact e)
+;; (+ (inexact->exact e) 1)))
+;; (f (/ x (expt 2 e))))
+;; (list f e))))
+;;
+;; (define float-precision
+;; (let ((mantissa-bits
+;; (do ((i 0 (+ i 1))
+;; (eps f1.0 (* f0.5 eps)))
+;; ((= f1.0 (+ f1.0 eps))
+;; i)))
+;; (minval
+;; (do ((x f1.0 (* f0.5 x)))
+;; ((zero? (* f0.5 x)) x))))
+;; (lambda (x)
+;; (apply (lambda (f e)
+;; (let ((eps
+;; (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
+;; ((zero? f) minval)
+;; (else (expt f2.0 (- e mantissa-bits))))))
+;; (if (zero? eps) ;Happens if gradual underflow.
+;; minval
+;; eps)))
+;; (slow-frexp x)))))
+;;
+;; (define (float-print-test x)
+;; (define (testit number)
+;; (eqv? number (string->number (number->string number))))
+;; (let ((eps (float-precision x))
+;; (all-ok? #t))
+;; (do ((j -100 (+ j 1)))
+;; ((or (not all-ok?) (> j 100)) all-ok?)
+;; (let* ((xx (+ x (* j eps)))
+;; (ok? (testit xx)))
+;; (cond ((not ok?)
+;; (display "Number readback failure for ")
+;; (display `(+ ,x (* ,j ,eps)))
+;; (newline)
+;; (display xx)
+;; (newline)
+;; (set! all-ok? #f))
+;; ;; (else (display xx) (newline))
+;; )))))
+;;
+;; (define (mult-float-print-test x)
+;; (let ((res #t))
+;; (for-each
+;; (lambda (mult)
+;; (or (float-print-test (* mult x)) (set! res #f)))
+;; (map string->number
+;; '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
+;; "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
+;; res))
+;;
+;; (SECTION 6 5 6)
+;; (test #t 'float-print-test (float-print-test f0.0))
+;; (test #t 'mult-float-print-test (mult-float-print-test f1.0))
+;; (test #t 'mult-float-print-test (mult-float-print-test
+;; (string->number "3.0")))
+;; (test #t 'mult-float-print-test (mult-float-print-test
+;; (string->number "7.0")))
+;; (test #t 'mult-float-print-test (mult-float-print-test
+;; (string->number "3.1415926535897931")))
+;; (test #t 'mult-float-print-test (mult-float-print-test
+;; (string->number "2.7182818284590451")))))
- (define (slow-frexp x)
- (if (zero? x)
- (list f0.0 0)
- (let* ((l2 (log2 x))
- (e (floor (log2 x)))
- (e (if (= l2 e)
- (inexact->exact e)
- (+ (inexact->exact e) 1)))
- (f (/ x (expt 2 e))))
- (list f e))))
+;; DISABLED: not supported by SigScheme
+;;(define (test-bignum)
+;; (define tb
+;; (lambda (n1 n2)
+;; (= n1 (+ (* n2 (quotient n1 n2))
+;; (remainder n1 n2)))))
+;; (newline)
+;; (display ";testing bignums; ")
+;; (newline)
+;; (SECTION 6 5 7)
+;; (test 0 modulo 33333333333333333333 3)
+;; (test 0 modulo 33333333333333333333 -3)
+;; (test 0 remainder 33333333333333333333 3)
+;; (test 0 remainder 33333333333333333333 -3)
+;; (test 2 modulo 33333333333333333332 3)
+;; (test -1 modulo 33333333333333333332 -3)
+;; (test 2 remainder 33333333333333333332 3)
+;; (test 2 remainder 33333333333333333332 -3)
+;; (test 1 modulo -33333333333333333332 3)
+;; (test -2 modulo -33333333333333333332 -3)
+;; (test -2 remainder -33333333333333333332 3)
+;; (test -2 remainder -33333333333333333332 -3)
+;;
+;; (test 3 modulo 3 33333333333333333333)
+;; (test 33333333333333333330 modulo -3 33333333333333333333)
+;; (test 3 remainder 3 33333333333333333333)
+;; (test -3 remainder -3 33333333333333333333)
+;; (test -33333333333333333330 modulo 3 -33333333333333333333)
+;; (test -3 modulo -3 -33333333333333333333)
+;; (test 3 remainder 3 -33333333333333333333)
+;; (test -3 remainder -3 -33333333333333333333)
+;;
+;; (test 0 modulo -2177452800 86400)
+;; (test 0 modulo 2177452800 -86400)
+;; (test 0 modulo 2177452800 86400)
+;; (test 0 modulo -2177452800 -86400)
+;; (test 0 modulo 0 -2177452800)
+;; (test #t 'remainder (tb 281474976710655325431 65535))
+;; (test #t 'remainder (tb 281474976710655325430 65535))
+;;
+;; (SECTION 6 5 8)
+;; (test 281474976710655325431 string->number "281474976710655325431")
+;; (test "281474976710655325431" number->string 281474976710655325431)
+;; (report-errs))
- (define float-precision
- (let ((mantissa-bits
- (do ((i 0 (+ i 1))
- (eps f1.0 (* f0.5 eps)))
- ((= f1.0 (+ f1.0 eps))
- i)))
- (minval
- (do ((x f1.0 (* f0.5 x)))
- ((zero? (* f0.5 x)) x))))
- (lambda (x)
- (apply (lambda (f e)
- (let ((eps
- (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
- ((zero? f) minval)
- (else (expt f2.0 (- e mantissa-bits))))))
- (if (zero? eps) ;Happens if gradual underflow.
- minval
- eps)))
- (slow-frexp x)))))
+;; DISABLED: not supported by SigScheme
+;;(define (test-numeric-predicates)
+;; (let* ((big-ex (expt 2 90))
+;; (big-inex (exact->inexact big-ex)))
+;; (newline)
+;; (display ";testing bignum-inexact comparisons;")
+;; (newline)
+;; (SECTION 6 5 5)
+;; (test #f = (+ big-ex 1) big-inex (- big-ex 1))
+;; (test #f = big-inex (+ big-ex 1) (- big-ex 1))
+;; (test #t < (- (inexact->exact big-inex) 1)
+;; big-inex
+;; (+ (inexact->exact big-inex) 1))))
- (define (float-print-test x)
- (define (testit number)
- (eqv? number (string->number (number->string number))))
- (let ((eps (float-precision x))
- (all-ok? #t))
- (do ((j -100 (+ j 1)))
- ((or (not all-ok?) (> j 100)) all-ok?)
- (let* ((xx (+ x (* j eps)))
- (ok? (testit xx)))
- (cond ((not ok?)
- (display "Number readback failure for ")
- (display `(+ ,x (* ,j ,eps)))
- (newline)
- (display xx)
- (newline)
- (set! all-ok? #f))
- ;; (else (display xx) (newline))
- )))))
- (define (mult-float-print-test x)
- (let ((res #t))
- (for-each
- (lambda (mult)
- (or (float-print-test (* mult x)) (set! res #f)))
- (map string->number
- '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
- "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
- res))
-
- (SECTION 6 5 6)
- (test #t 'float-print-test (float-print-test f0.0))
- (test #t 'mult-float-print-test (mult-float-print-test f1.0))
- (test #t 'mult-float-print-test (mult-float-print-test
- (string->number "3.0")))
- (test #t 'mult-float-print-test (mult-float-print-test
- (string->number "7.0")))
- (test #t 'mult-float-print-test (mult-float-print-test
- (string->number "3.1415926535897931")))
- (test #t 'mult-float-print-test (mult-float-print-test
- (string->number "2.7182818284590451")))))
-
-(define (test-bignum)
- (define tb
- (lambda (n1 n2)
- (= n1 (+ (* n2 (quotient n1 n2))
- (remainder n1 n2)))))
- (newline)
- (display ";testing bignums; ")
- (newline)
- (SECTION 6 5 7)
- (test 0 modulo 33333333333333333333 3)
- (test 0 modulo 33333333333333333333 -3)
- (test 0 remainder 33333333333333333333 3)
- (test 0 remainder 33333333333333333333 -3)
- (test 2 modulo 33333333333333333332 3)
- (test -1 modulo 33333333333333333332 -3)
- (test 2 remainder 33333333333333333332 3)
- (test 2 remainder 33333333333333333332 -3)
- (test 1 modulo -33333333333333333332 3)
- (test -2 modulo -33333333333333333332 -3)
- (test -2 remainder -33333333333333333332 3)
- (test -2 remainder -33333333333333333332 -3)
-
- (test 3 modulo 3 33333333333333333333)
- (test 33333333333333333330 modulo -3 33333333333333333333)
- (test 3 remainder 3 33333333333333333333)
- (test -3 remainder -3 33333333333333333333)
- (test -33333333333333333330 modulo 3 -33333333333333333333)
- (test -3 modulo -3 -33333333333333333333)
- (test 3 remainder 3 -33333333333333333333)
- (test -3 remainder -3 -33333333333333333333)
-
- (test 0 modulo -2177452800 86400)
- (test 0 modulo 2177452800 -86400)
- (test 0 modulo 2177452800 86400)
- (test 0 modulo -2177452800 -86400)
- (test 0 modulo 0 -2177452800)
- (test #t 'remainder (tb 281474976710655325431 65535))
- (test #t 'remainder (tb 281474976710655325430 65535))
-
- (SECTION 6 5 8)
- (test 281474976710655325431 string->number "281474976710655325431")
- (test "281474976710655325431" number->string 281474976710655325431)
- (report-errs))
-
-(define (test-numeric-predicates)
- (let* ((big-ex (expt 2 90))
- (big-inex (exact->inexact big-ex)))
- (newline)
- (display ";testing bignum-inexact comparisons;")
- (newline)
- (SECTION 6 5 5)
- (test #f = (+ big-ex 1) big-inex (- big-ex 1))
- (test #f = big-inex (+ big-ex 1) (- big-ex 1))
- (test #t < (- (inexact->exact big-inex) 1)
- big-inex
- (+ (inexact->exact big-inex) 1))))
-
-
(SECTION 6 5 9)
(test "0" number->string 0)
(test "100" number->string 100)
More information about the uim-commit
mailing list