ikarus/scheme/tests/fixnums.ss

169 lines
4.7 KiB
Scheme
Raw Normal View History

2007-11-11 20:43:59 -05:00
(library (tests fixnums)
2008-10-18 13:03:17 -04:00
(export run-tests)
2007-11-11 20:43:59 -05:00
(import (ikarus))
2008-10-18 13:03:17 -04:00
(define (run-tests)
(test-fxdiv-and-mod)
(test-fxdiv0-and-mod0)
(test-fxlength)
(test-fxcarry))
(define (test-fxcarry)
(define (fx*/carry-reference fx1 fx2 fx3)
(let* ([s (+ (* fx1 fx2) fx3)]
[s0 (mod0 s (expt 2 (fixnum-width)))]
[s1 (div0 s (expt 2 (fixnum-width)))])
(values s0 s1)))
(define (fx+/carry-reference fx1 fx2 fx3)
(let* ([s (+ (+ fx1 fx2) fx3)]
[s0 (mod0 s (expt 2 (fixnum-width)))]
[s1 (div0 s (expt 2 (fixnum-width)))])
(values s0 s1)))
(define (fx-/carry-reference fx1 fx2 fx3)
(let* ([s (- (- fx1 fx2) fx3)]
[s0 (mod0 s (expt 2 (fixnum-width)))]
[s1 (div0 s (expt 2 (fixnum-width)))])
(values s0 s1)))
(define (test name fxop/carry fxop/carry-reference fx1 fx2 fx3)
(let-values ([(s0 s1) (fxop/carry fx1 fx2 fx3)]
[(s2 s3) (fxop/carry-reference fx1 fx2 fx3)])
(unless (fx= s0 s2)
(error name "failed (value1) on ~s ~s ~s, got ~s, should be ~s"
fx1 fx2 fx3 s0 s2))
(unless (fx= s1 s3)
(error name "failed (value2) on ~s ~s ~s, got ~s, should be ~s"
fx1 fx2 fx3 s1 s3))))
(define ls
(list 0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)))
(printf "[~s: test-fxcarry] " (expt (length ls) 3))
(for-each
(lambda (fx1)
(for-each
(lambda (fx2)
(for-each
(lambda (fx3)
(test 'fx*/carry fx*/carry fx*/carry-reference fx1 fx2 fx3)
(test 'fx+/carry fx+/carry fx+/carry-reference fx1 fx2 fx3)
(test 'fx-/carry fx-/carry fx-/carry-reference fx1 fx2 fx3))
ls))
ls))
ls)
)
2007-11-11 20:43:59 -05:00
(define (test-fxdiv-and-mod)
(define (test x1 x2)
(let-values ([(d m) (fxdiv-and-mod x1 x2)])
(printf "(fxdiv-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (fxdiv x1 x2)))
(assert (= m (fxmod x1 x2)))
(assert (<= 0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m)))))
(test +17 +3)
(test +17 -3)
(test -17 +3)
(test -17 -3)
(test +16 +3)
(test +16 -3)
(test -16 +3)
(test -16 -3)
(test +15 +3)
(test +15 -3)
(test -15 +3)
(test -15 -3)
(test +10 +4)
(test +10 -4)
(test -10 +4)
(test -10 -4))
(define (test-fxdiv0-and-mod0)
(define (test x1 x2)
(let-values ([(d m) (fxdiv0-and-mod0 x1 x2)])
(printf "(fxdiv0-and-mod0 ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (fxdiv0 x1 x2)))
(assert (= m (fxmod0 x1 x2)))
(assert (<= (- (abs (/ x2 2))) m))
(assert (< m (abs (/ x2 2))))
(assert (= x1 (+ (* d x2) m)))))
(test +17 +3)
(test +17 -3)
(test -17 +3)
(test -17 -3)
(test +16 +3)
(test +16 -3)
(test -16 +3)
(test -16 -3)
(test +15 +3)
(test +15 -3)
(test -15 +3)
(test -15 -3)
(test +10 +4)
(test +10 -4)
(test -10 +4)
(test -10 -4)
(test (least-fixnum) +1)
;(test (least-fixnum) -1) ;; overflows
(test (greatest-fixnum) +1)
(test (greatest-fixnum) -1)
(test (least-fixnum) +2)
(test (least-fixnum) -2)
(test (greatest-fixnum) +2)
(test (greatest-fixnum) -2)
(test 0 (least-fixnum))
(test 0 (greatest-fixnum))
(test +1 (least-fixnum))
(test +1 (greatest-fixnum))
(test -1 (least-fixnum))
(test -1 (greatest-fixnum))
(test +2 (least-fixnum))
(test +2 (greatest-fixnum))
(test -2 (least-fixnum))
(test -2 (greatest-fixnum))
(test (least-fixnum) (least-fixnum))
(test (greatest-fixnum) (least-fixnum))
(test (least-fixnum) (greatest-fixnum))
(test (greatest-fixnum) (greatest-fixnum)))
2007-11-13 23:24:21 -05:00
(define (test-fxlength)
(define (test x)
(define (bitlen x)
(if (zero? x)
0
(+ 1 (bitlen (bitwise-arithmetic-shift-right x 1)))))
(define (len x)
(if (< x 0)
(bitlen (bitwise-not x))
(bitlen x)))
(let ([c0 (len x)]
[c1 (fxlength x)])
(unless (= c0 c1)
(error 'test-fxlength "failed/expected/got" x c0 c1))))
(define (test-fx count n inc)
(when (fixnum? n)
(when (zero? (fxlogand count #xFFFF))
(printf "bitwise-bit-count ~s\n" n))
(test n)
(test-fx (+ count 1) (+ n inc) inc)))
2007-11-13 23:24:21 -05:00
(test 0)
(test 1)
(test 2)
(test 3)
(test -1)
(test -2)
(test -3)
(if (= (fixnum-width) 30)
(test-fx 0 (least-fixnum) #xFF)
(test-fx 0 (least-fixnum) #xFF00000000)) )
)
2007-11-11 20:43:59 -05:00